{-# LANGUAGE CPP #-}
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
snapRequest :: Snap.Request -> Request
snapRequest q = Request
{ requestHost = splitHost $
#if MIN_VERSION_snap_core(1,0,0)
Snap.rqHostName q
#else
Snap.rqServerName q
#endif
, requestSecure = Snap.rqIsSecure q
, requestMethod = toMethod $ Snap.rqMethod q
, requestPath = fst $ decodePath $ Snap.rqPathInfo q
, requestQuery = HM.fromList $ M.toList $ Snap.rqQueryParams q
, requestContentType = fromMaybe mempty $ Snap.getHeader hContentType 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 q = left err . routeRequest (snapRequest q) where
err (s, h) = foldr (\(n,v) -> Snap.setHeader n v)
(Snap.setResponseCode (statusCode s) $ Snap.emptyResponse)
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 m = do
q <- Snap.getRequest
either ((<$) Nothing . Snap.putResponse) (Just <$>) $ routeSnap q m