salvia-0.1: src/Network/Salvia/Handler/VirtualHosting.hs

module Network.Salvia.Handler.VirtualHosting (
    hHostRouter
  , hVirtualHosting
  ) where

import Data.Ord
import Data.List
import Data.Record.Label
import Network.Protocol.Http
import Network.Protocol.Uri
import Network.Salvia.Handler.Dispatching
import Network.Salvia.Httpd hiding (hostname)

{- |
List dispatcher based on the host part of the hostname request header.
Everything not part of the real hostname (like the port number) will be
ignored.
-}

hVirtualHosting :: ListDispatcher String a
hVirtualHosting = (hListDispatch disp) . parse
  where
    disp    = hDispatch (hostname % request) cmp
    parse   = map (\(a, b) -> (parseAuthority a, b))
    cmp a b = (==EQ) $ comparing (fmap (lget _host)) a b

{- |
List dispatcher based on the hostname request header. This header field is
parsed and interpreted as an `Authority` field.
-}

hHostRouter :: ListDispatcher (Maybe Authority) a
hHostRouter = hListDispatch $ hDispatch (hostname % request) (==)