{-# LANGUAGE CPP #-}
-- |A compatibility routing layer for Snap applications.
module Web.Route.Invertible.Snap
  ( module Web.Route.Invertible.Common
  , snapRequest
  , routeSnap
  , routeMonadSnap
  ) where

import Control.Arrow (left)
import qualified Data.HashMap.Lazy as HM
import Data.Maybe (fromMaybe)
import qualified Data.Map.Lazy as M
import Network.HTTP.Types.Header (hContentType)
import Network.HTTP.Types.URI (decodePath)
import Network.HTTP.Types.Status (statusCode)
import qualified Snap.Core as Snap

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

-- |Corvert a 'Snap.Request' to a request.
snapRequest :: Snap.Request -> Request
snapRequest :: Request -> Request
snapRequest Request
q = Request :: Bool
-> [HostString]
-> Method
-> [PathString]
-> QueryParams
-> HostString
-> Request
Request
  { requestHost :: [HostString]
requestHost = HostString -> [HostString]
splitHost (HostString -> [HostString]) -> HostString -> [HostString]
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_snap_core(1,0,0)
    Request -> HostString
Snap.rqHostName Request
q
#else
    Snap.rqServerName q
#endif
  , requestSecure :: Bool
requestSecure = Request -> Bool
Snap.rqIsSecure 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
Snap.rqMethod Request
q
  , requestPath :: [PathString]
requestPath = ([PathString], Query) -> [PathString]
forall a b. (a, b) -> a
fst (([PathString], Query) -> [PathString])
-> ([PathString], Query) -> [PathString]
forall a b. (a -> b) -> a -> b
$ HostString -> ([PathString], Query)
decodePath (HostString -> ([PathString], Query))
-> HostString -> ([PathString], Query)
forall a b. (a -> b) -> a -> b
$ Request -> HostString
Snap.rqPathInfo Request
q
  , requestQuery :: QueryParams
requestQuery = [(HostString, [HostString])] -> QueryParams
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(HostString, [HostString])] -> QueryParams)
-> [(HostString, [HostString])] -> QueryParams
forall a b. (a -> b) -> a -> b
$ Map HostString [HostString] -> [(HostString, [HostString])]
forall k a. Map k a -> [(k, a)]
M.toList (Map HostString [HostString] -> [(HostString, [HostString])])
-> Map HostString [HostString] -> [(HostString, [HostString])]
forall a b. (a -> b) -> a -> b
$ Request -> Map HostString [HostString]
Snap.rqQueryParams 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
$ CI HostString -> Request -> Maybe HostString
forall a. HasHeaders a => CI HostString -> a -> Maybe HostString
Snap.getHeader CI HostString
hContentType Request
q
  }

-- |Lookup a snap request in a route map, returning either an empty error response or a successful result.
routeSnap :: Snap.Request -> RouteMap a -> Either Snap.Response a
routeSnap :: Request -> RouteMap a -> Either Response a
routeSnap 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
snapRequest 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) -> CI HostString -> HostString -> Response -> Response
forall a. HasHeaders a => CI HostString -> HostString -> a -> a
Snap.setHeader CI HostString
n HostString
v)
    (Int -> Response -> Response
Snap.setResponseCode (Status -> Int
statusCode Status
s) (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$ Response
Snap.emptyResponse)
    t (CI HostString, HostString)
h
  
-- |Combine a set of snap actions in a routing map into a single action, pre-setting an empty response.and returning Nothing in case of error.
routeMonadSnap :: Snap.MonadSnap m => RouteMap (m a) -> m (Maybe a)
routeMonadSnap :: RouteMap (m a) -> m (Maybe a)
routeMonadSnap RouteMap (m a)
m = do
  Request
q <- m Request
forall (m :: * -> *). MonadSnap m => m Request
Snap.getRequest
  (Response -> m (Maybe a))
-> (m a -> m (Maybe a)) -> Either Response (m a) -> m (Maybe a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> m () -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$) Maybe a
forall a. Maybe a
Nothing (m () -> m (Maybe a))
-> (Response -> m ()) -> Response -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> m ()
forall (m :: * -> *). MonadSnap m => Response -> m ()
Snap.putResponse) (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Either Response (m a) -> m (Maybe a))
-> Either Response (m a) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Request -> RouteMap (m a) -> Either Response (m a)
forall a. Request -> RouteMap a -> Either Response a
routeSnap Request
q RouteMap (m a)
m