-- |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
  { requestHost :: [ByteString]
requestHost = [ByteString]
-> (ByteString -> [ByteString]) -> Maybe ByteString -> [ByteString]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [ByteString]
splitHost (Maybe ByteString -> [ByteString])
-> Maybe ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Maybe ByteString
forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
HS.getHeaderBS (CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
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 -> ByteString
BSC.pack (String -> ByteString)
-> (Input -> ByteString) -> (String, Input) -> SimpleQueryItem
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (String -> ByteString)
-> (LazyByteString -> ByteString)
-> Either String LazyByteString
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> ByteString
BSC.pack LazyByteString -> ByteString
BSL.toStrict (Either String LazyByteString -> ByteString)
-> (Input -> Either String LazyByteString) -> Input -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> Either String LazyByteString
HS.inputValue) ([(String, Input)] -> SimpleQuery)
-> [(String, Input)] -> SimpleQuery
forall a b. (a -> b) -> a -> b
$ Request -> [(String, Input)]
HS.rqInputsQuery Request
q
  , requestContentType :: ByteString
requestContentType = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Maybe ByteString
forall r. HasHeaders r => ByteString -> r -> Maybe ByteString
HS.getHeaderBS (CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
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 :: forall a. Request -> RouteMap a -> Either Response a
routeHappstack Request
q = ((Status, ResponseHeaders) -> Response)
-> Either (Status, ResponseHeaders) a -> Either Response a
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (Status, ResponseHeaders) -> Response
forall {t :: * -> *}.
Foldable t =>
(Status, t (CI ByteString, ByteString)) -> Response
err (Either (Status, ResponseHeaders) a -> Either Response a)
-> (RouteMap a -> Either (Status, ResponseHeaders) a)
-> RouteMap a
-> Either Response a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> RouteMap a -> Either (Status, ResponseHeaders) a
forall a.
Request -> RouteMap a -> Either (Status, ResponseHeaders) a
routeRequest (Request -> Request
happstackRequest Request
q) where
  err :: (Status, t (CI ByteString, ByteString)) -> Response
err (Status
s, t (CI ByteString, ByteString)
h) = ((CI ByteString, ByteString) -> Response -> Response)
-> Response -> t (CI ByteString, ByteString) -> Response
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(CI ByteString
n,ByteString
v) -> ByteString -> ByteString -> Response -> Response
forall r. HasHeaders r => ByteString -> ByteString -> r -> r
HS.setHeaderBS (CI ByteString -> ByteString
forall s. CI s -> s
CI.original CI ByteString
n) ByteString
v)
    (Int -> LazyByteString -> Response
HS.resultBS (Status -> Int
statusCode Status
s) LazyByteString
BSL.empty)
    t (CI ByteString, ByteString)
h