Domain based routing

[WARNING] Yesod Cookbook has moved to a new place. Please contribute there.

-- This example shows how you can perform routing based on the domain name.
-- Normal stuff up here...
{-# LANGUAGE QuasiQuotes, TemplateHaskell, MultiParamTypeClasses,
    TypeFamilies, OverloadedStrings #-}
import Yesod
import Control.Arrow ((***))
import Network.Wai.Handler.Warp (run)
import Network.Wai
import Network.HTTP.Types
import Data.Monoid (mappend)
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TEE

data Subdomain = Subdomain

-- Here's the trick: the subdomain will be encoded as the first piece in the
-- path. This gives us lots of flexibility; we can match explicitly against
-- some domains (e.g., www.mydomain.com), or use wildcards (e.g. <username>).
-- This is a purposely simple example to be run on a localhost system without
-- playing with your hosts file.
mkYesod "Subdomain" [parseRoutes|
/localhost LocalhostR GET
/127.0.0.1 OnetwosevenR GET
|]

instance Yesod Subdomain where
    -- approot is entirely ignored for this application
    approot _ = ""

    -- And here's the first bit of magic. joinPath is what turns our list of
    -- path pieces into a URL. So we grab the first piece, treat is as a domain
    -- name, and otherwise do normal processing (encoding query string
    -- parameters, etc).
    joinPath _ _ (domain:pieces') qs' =
    copyByteString "http://"
    `mappend` fromText domain
    -- Insert the port in as well. Obviously if you have a port besides
    -- 3000 you'd want to change this. A more robust approach would be to
    -- define a variable containing the port, and use it both here and in
    -- main.
    `mappend` copyByteString ":3000"
    `mappend` encodePath pieces qs
      where
    pieces = if null pieces' then [""] else pieces'
    qs = map (TE.encodeUtf8 *** go) qs'
    go "" = Nothing
    go x = Just $ TE.encodeUtf8 x

    -- An empty path list no longer makes sense (i.e., you can't have a URL
    -- without a domain).
    joinPath _ _ [] _ = error "joinPath with null list"

-- The second piece of magic: a middleware that automatically prepends the
-- domain name to the list of path pieces. It also strips off the port (if
-- present), which means that our route definitions do not need to change for
-- port number changes.
--
-- In theory, if you want to, you could leave the port number on and route
-- based on that as well.
prependSubdomain :: Middleware
prependSubdomain app req =
    app req { pathInfo = domain : pathInfo req }
  where
    domain = T.takeWhile (/= ':')
       $ maybe "localhost" (TE.decodeUtf8With TEE.lenientDecode)
       $ lookup "host"
       $ requestHeaders req

-- Just some standard handler functions. Notice how easy it is to link to the
-- different domains.
getOnetwosevenR = defaultLayout [whamlet|
<h1>127.0.0.1
<p>
    <a href=@{LocalhostR}>localhost
|]

getLocalhostR = defaultLayout [whamlet|
<h1>localhost
<p>
    <a href=@{OnetwosevenR}>127.0.0.1
|]

main :: IO ()
main = do
    app <- toWaiApp Subdomain
    -- Finally, just make sure to use the middleware.
    run 3000 $ prependSubdomain app