-- |A compatibility routing layer for WAI applications.
module Web.Route.Invertible.Wai
  ( module Web.Route.Invertible.Common
  , waiRequest
  , routeWai
  , routeWaiError
  , routeWaiApplicationError
  , routeWaiApplication
  ) where

import Control.Arrow (second)
import Data.Maybe (fromMaybe)
import qualified Network.Wai as Wai
import Network.HTTP.Types.Header (ResponseHeaders, hContentType)
import Network.HTTP.Types.Status (Status)

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

-- |Convert a 'Wai.Request' to a request.
waiRequest :: Wai.Request -> Request
waiRequest :: Request -> Request
waiRequest Request
q = Request
  { requestHost :: [Method]
requestHost = [Method] -> (Method -> [Method]) -> Maybe Method -> [Method]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Method -> [Method]
splitHost (Maybe Method -> [Method]) -> Maybe Method -> [Method]
forall a b. (a -> b) -> a -> b
$ Request -> Maybe Method
Wai.requestHeaderHost Request
q
  , requestSecure :: Bool
requestSecure = Request -> Bool
Wai.isSecure 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
Wai.requestMethod Request
q
  , requestPath :: [PathString]
requestPath = Request -> [PathString]
Wai.pathInfo Request
q
  , requestQuery :: QueryParams
requestQuery = SimpleQuery -> QueryParams
simpleQueryParams (SimpleQuery -> QueryParams) -> SimpleQuery -> QueryParams
forall a b. (a -> b) -> a -> b
$ (QueryItem -> SimpleQueryItem) -> [QueryItem] -> SimpleQuery
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe Method -> Method) -> QueryItem -> SimpleQueryItem
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Maybe Method -> Method) -> QueryItem -> SimpleQueryItem)
-> (Maybe Method -> Method) -> QueryItem -> SimpleQueryItem
forall a b. (a -> b) -> a -> b
$ Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe Method
forall a. Monoid a => a
mempty) ([QueryItem] -> SimpleQuery) -> [QueryItem] -> SimpleQuery
forall a b. (a -> b) -> a -> b
$ Request -> [QueryItem]
Wai.queryString Request
q
  , requestContentType :: Method
requestContentType = Method -> Maybe Method -> Method
forall a. a -> Maybe a -> a
fromMaybe Method
forall a. Monoid a => a
mempty (Maybe Method -> Method) -> Maybe Method -> Method
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType [(HeaderName, Method)]
headers
  } where headers :: [(HeaderName, Method)]
headers = Request -> [(HeaderName, Method)]
Wai.requestHeaders Request
q

-- |Lookup a wai request in a route map, returning either an error code and headers or a successful result.
routeWai :: Wai.Request -> RouteMap a -> Either (Status, ResponseHeaders) a
routeWai :: forall a.
Request -> RouteMap a -> Either (Status, [(HeaderName, Method)]) a
routeWai = Request -> RouteMap a -> Either (Status, [(HeaderName, Method)]) a
forall a.
Request -> RouteMap a -> Either (Status, [(HeaderName, Method)]) a
routeRequest (Request
 -> RouteMap a -> Either (Status, [(HeaderName, Method)]) a)
-> (Request -> Request)
-> Request
-> RouteMap a
-> Either (Status, [(HeaderName, Method)]) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
waiRequest

-- |Combine a set of applications in a routing map into a single application, calling a custom error handler in case of routing error.
routeWaiError :: (Status -> ResponseHeaders -> Wai.Request -> a) -> RouteMap (Wai.Request -> a) -> Wai.Request -> a
routeWaiError :: forall a.
(Status -> [(HeaderName, Method)] -> Request -> a)
-> RouteMap (Request -> a) -> Request -> a
routeWaiError Status -> [(HeaderName, Method)] -> Request -> a
e RouteMap (Request -> a)
m Request
q = ((Status, [(HeaderName, Method)]) -> a)
-> ((Request -> a) -> a)
-> Either (Status, [(HeaderName, Method)]) (Request -> a)
-> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\(Status
s, [(HeaderName, Method)]
h) -> Status -> [(HeaderName, Method)] -> Request -> a
e Status
s [(HeaderName, Method)]
h Request
q) (\Request -> a
a -> Request -> a
a Request
q) (Either (Status, [(HeaderName, Method)]) (Request -> a) -> a)
-> Either (Status, [(HeaderName, Method)]) (Request -> a) -> a
forall a b. (a -> b) -> a -> b
$ Request
-> RouteMap (Request -> a)
-> Either (Status, [(HeaderName, Method)]) (Request -> a)
forall a.
Request -> RouteMap a -> Either (Status, [(HeaderName, Method)]) a
routeWai Request
q RouteMap (Request -> a)
m

-- |Specialization of 'routeWaiError'.
routeWaiApplicationError :: (Status -> ResponseHeaders -> Wai.Application) -> RouteMap Wai.Application -> Wai.Application
routeWaiApplicationError :: (Status -> [(HeaderName, Method)] -> Application)
-> RouteMap Application -> Application
routeWaiApplicationError = (Status -> [(HeaderName, Method)] -> Application)
-> RouteMap Application -> Application
forall a.
(Status -> [(HeaderName, Method)] -> Request -> a)
-> RouteMap (Request -> a) -> Request -> a
routeWaiError

-- |Combine a set of applications in a routing map into a single application, returning an empty error response in case of routing error.
routeWaiApplication :: RouteMap Wai.Application -> Wai.Application
routeWaiApplication :: RouteMap Application -> Application
routeWaiApplication = (Status -> [(HeaderName, Method)] -> Application)
-> RouteMap Application -> Application
routeWaiApplicationError ((Status -> [(HeaderName, Method)] -> Application)
 -> RouteMap Application -> Application)
-> (Status -> [(HeaderName, Method)] -> Application)
-> RouteMap Application
-> Application
forall a b. (a -> b) -> a -> b
$ \Status
s [(HeaderName, Method)]
h Request
_ Response -> IO ResponseReceived
r -> Response -> IO ResponseReceived
r (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> [(HeaderName, Method)] -> Builder -> Response
Wai.responseBuilder Status
s [(HeaderName, Method)]
h Builder
forall a. Monoid a => a
mempty