-- |A compatibility routing layer for Happstack applications.
module Web.Route.Invertible.Happstack
  ( module Web.Route.Invertible.Common
  , happstackRequest
  , routeHappstack
  ) where

import Control.Arrow ((***), left)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import qualified Data.CaseInsensitive as CI
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Network.HTTP.Types.Header (hHost, hContentType)
import Network.HTTP.Types.Status (statusCode)
import qualified Happstack.Server.Types as HS

import Web.Route.Invertible.Internal
import Web.Route.Invertible.Common
import Web.Route.Invertible

-- |Convert a 'HS.Request' to a request.
happstackRequest :: HS.Request -> Request
happstackRequest :: Request -> Request
happstackRequest Request
q = Request :: Bool
-> [HostString]
-> Method
-> [PathString]
-> QueryParams
-> HostString
-> Request
Request
  { requestHost :: [HostString]
requestHost = [HostString]
-> (HostString -> [HostString]) -> Maybe HostString -> [HostString]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] HostString -> [HostString]
splitHost (Maybe HostString -> [HostString])
-> Maybe HostString -> [HostString]
forall a b. (a -> b) -> a -> b
$ HostString -> Request -> Maybe HostString
forall r. HasHeaders r => HostString -> r -> Maybe HostString
HS.getHeaderBS (CI HostString -> HostString
forall s. CI s -> s
CI.original CI HostString
hHost) Request
q
  , requestSecure :: Bool
requestSecure = Request -> Bool
HS.rqSecure Request
q
  , requestMethod :: Method
requestMethod = Method -> Method
forall m. IsMethod m => m -> Method
toMethod (Method -> Method) -> Method -> Method
forall a b. (a -> b) -> a -> b
$ Request -> Method
HS.rqMethod Request
q
  , requestPath :: [PathString]
requestPath = (String -> PathString) -> [String] -> [PathString]
forall a b. (a -> b) -> [a] -> [b]
map String -> PathString
T.pack ([String] -> [PathString]) -> [String] -> [PathString]
forall a b. (a -> b) -> a -> b
$ Request -> [String]
HS.rqPaths Request
q
  , requestQuery :: QueryParams
requestQuery = SimpleQuery -> QueryParams
simpleQueryParams (SimpleQuery -> QueryParams) -> SimpleQuery -> QueryParams
forall a b. (a -> b) -> a -> b
$ ((String, Input) -> SimpleQueryItem)
-> [(String, Input)] -> SimpleQuery
forall a b. (a -> b) -> [a] -> [b]
map (String -> HostString
BSC.pack (String -> HostString)
-> (Input -> HostString) -> (String, Input) -> SimpleQueryItem
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (String -> HostString)
-> (ByteString -> HostString)
-> Either String ByteString
-> HostString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> HostString
BSC.pack ByteString -> HostString
BSL.toStrict (Either String ByteString -> HostString)
-> (Input -> Either String ByteString) -> Input -> HostString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Either String ByteString
HS.inputValue) ([(String, Input)] -> SimpleQuery)
-> [(String, Input)] -> SimpleQuery
forall a b. (a -> b) -> a -> b
$ Request -> [(String, Input)]
HS.rqInputsQuery Request
q
  , requestContentType :: HostString
requestContentType = HostString -> Maybe HostString -> HostString
forall a. a -> Maybe a -> a
fromMaybe HostString
forall a. Monoid a => a
mempty (Maybe HostString -> HostString) -> Maybe HostString -> HostString
forall a b. (a -> b) -> a -> b
$ HostString -> Request -> Maybe HostString
forall r. HasHeaders r => HostString -> r -> Maybe HostString
HS.getHeaderBS (CI HostString -> HostString
forall s. CI s -> s
CI.original CI HostString
hContentType) Request
q
  }

-- |Lookup a Happstack request in a route map, returning either an empty error response or a successful result.
routeHappstack :: HS.Request -> RouteMap a -> Either HS.Response a
routeHappstack :: Request -> RouteMap a -> Either Response a
routeHappstack Request
q = ((Status, [(CI HostString, HostString)]) -> Response)
-> Either (Status, [(CI HostString, HostString)]) a
-> Either Response a
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (Status, [(CI HostString, HostString)]) -> Response
forall (t :: * -> *).
Foldable t =>
(Status, t (CI HostString, HostString)) -> Response
err (Either (Status, [(CI HostString, HostString)]) a
 -> Either Response a)
-> (RouteMap a -> Either (Status, [(CI HostString, HostString)]) a)
-> RouteMap a
-> Either Response a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request
-> RouteMap a -> Either (Status, [(CI HostString, HostString)]) a
forall a.
Request
-> RouteMap a -> Either (Status, [(CI HostString, HostString)]) a
routeRequest (Request -> Request
happstackRequest Request
q) where
  err :: (Status, t (CI HostString, HostString)) -> Response
err (Status
s, t (CI HostString, HostString)
h) = ((CI HostString, HostString) -> Response -> Response)
-> Response -> t (CI HostString, HostString) -> Response
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(CI HostString
n,HostString
v) -> HostString -> HostString -> Response -> Response
forall r. HasHeaders r => HostString -> HostString -> r -> r
HS.setHeaderBS (CI HostString -> HostString
forall s. CI s -> s
CI.original CI HostString
n) HostString
v)
    (Int -> ByteString -> Response
HS.resultBS (Status -> Int
statusCode Status
s) ByteString
BSL.empty)
    t (CI HostString, HostString)
h