{-# 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
  { requestHost :: [QueryString]
requestHost = QueryString -> [QueryString]
splitHost (QueryString -> [QueryString]) -> QueryString -> [QueryString]
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_snap_core(1,0,0)
    Request -> QueryString
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
$ QueryString -> ([PathString], Query)
decodePath (QueryString -> ([PathString], Query))
-> QueryString -> ([PathString], Query)
forall a b. (a -> b) -> a -> b
$ Request -> QueryString
Snap.rqPathInfo Request
q
  , requestQuery :: QueryParams
requestQuery = [(QueryString, [QueryString])] -> QueryParams
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(QueryString, [QueryString])] -> QueryParams)
-> [(QueryString, [QueryString])] -> QueryParams
forall a b. (a -> b) -> a -> b
$ Map QueryString [QueryString] -> [(QueryString, [QueryString])]
forall k a. Map k a -> [(k, a)]
M.toList (Map QueryString [QueryString] -> [(QueryString, [QueryString])])
-> Map QueryString [QueryString] -> [(QueryString, [QueryString])]
forall a b. (a -> b) -> a -> b
$ Request -> Map QueryString [QueryString]
Snap.rqQueryParams Request
q
  , requestContentType :: QueryString
requestContentType = QueryString -> Maybe QueryString -> QueryString
forall a. a -> Maybe a -> a
fromMaybe QueryString
forall a. Monoid a => a
mempty (Maybe QueryString -> QueryString)
-> Maybe QueryString -> QueryString
forall a b. (a -> b) -> a -> b
$ CI QueryString -> Request -> Maybe QueryString
forall a. HasHeaders a => CI QueryString -> a -> Maybe QueryString
Snap.getHeader CI QueryString
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 :: forall a. Request -> RouteMap a -> Either Response a
routeSnap 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 QueryString, QueryString)) -> 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
snapRequest Request
q) where
  err :: (Status, t (CI QueryString, QueryString)) -> Response
err (Status
s, t (CI QueryString, QueryString)
h) = ((CI QueryString, QueryString) -> Response -> Response)
-> Response -> t (CI QueryString, QueryString) -> 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 QueryString
n,QueryString
v) -> CI QueryString -> QueryString -> Response -> Response
forall a. HasHeaders a => CI QueryString -> QueryString -> a -> a
Snap.setHeader CI QueryString
n QueryString
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 QueryString, QueryString)
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 :: forall (m :: * -> *) a.
MonadSnap m =>
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 a b. a -> m b -> m 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