gemini-router-0.1.2.0: Network/Gemini/Router.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
module Network.Gemini.Router (
-- * The Route monad transformer
RouteT
, Route
, RouteIO
-- * Running Routes
, runRouteT
, runRouteT'
-- * Building Routes
, end
, domain
, dir
, capture
, input
, optionalInput
, cert
, optionalCert
, custom
-- * Getters
, getRequest
, getPath
) where
import Network.Gemini.Server
import Data.Maybe (fromMaybe)
import Data.Functor.Identity (Identity)
import Control.Applicative (Alternative(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.IO.Class (MonadIO(..))
import Network.URI
( uriQuery, pathSegments, unEscapeString, uriAuthority, uriRegName )
import OpenSSL.X509 (X509)
#if __GLASGOW_HASKELL__ < 808
import Control.Monad.Fail (MonadFail(..))
#endif
-- The RouteT monad transformer
-------------------------------
-- | Represents a way of routing requests through different handlers
newtype RouteT m a = RouteT { runRouteT :: Request -> [String] -> m (Maybe a) }
type Route = RouteT Identity
type RouteIO = RouteT IO
instance Functor f => Functor (RouteT f) where
fmap f r = RouteT $ \req path -> fmap f <$> runRouteT r req path
instance Applicative f => Applicative (RouteT f) where
pure x = RouteT $ \_ _ -> pure $ pure x
f <*> x = RouteT $ \req path ->
fmap (<*>) (runRouteT f req path) <*> runRouteT x req path
instance Monad m => Monad (RouteT m) where
rx >>= f = RouteT $ \req path -> do
mx <- runRouteT rx req path
runRouteT (maybe (RouteT $ \_ _ -> pure Nothing) f mx) req path
instance MonadTrans RouteT where
lift = RouteT . const . const . fmap pure
instance MonadIO m => MonadIO (RouteT m) where
liftIO = RouteT . const . const . fmap pure . liftIO
-- TODO all other transformers instances
instance Monad m => MonadFail (RouteT m) where
--TODO or maybe we shoudl just throw an exception
--or is it possible to somehow directly return Response 42 err mempty? it would require early return... like happstack
fail _ = empty
-- | 'empty' skips to the next route.
-- @r1 '<|>' r2@ means go to @r2@ if @r1@ skips
instance Monad f => Alternative (RouteT f) where
empty = RouteT $ \_ _ -> pure Nothing
r1 <|> r2 = RouteT $ \req path -> do
maybe1 <- runRouteT r1 req path
maybe2 <- runRouteT r2 req path
pure $ maybe1 <|> maybe2
-- Running routes
-------------------------------
-- MAYBE swap names with runRouteT
-- | Given a @run@ function for the inner 'Monad', make a 'Handler'
runRouteT' :: (m (Maybe Response) -> IO (Maybe Response)) -- ^ Inner @run@
-> RouteT m Response
-> Handler
runRouteT' runM r req = fromMaybe notFound <$> runM (runRouteT r req path)
where
notFound = Response 51 "Not found" mempty
path = unEscapeString <$> pathSegments (requestURI req)
-- Building Routes
-------------------------------
-- | Match on the end of the path
end :: Applicative f
=> RouteT f a -- ^ Route to run
-> RouteT f a
end r = RouteT $ \req path -> case path of
[] -> runRouteT r req path
_ -> pure Nothing
-- | Match on a specified domain
-- @since 0.1.2.0
domain :: Applicative f
=> String -- ^ What the domain must match
-> RouteT f a -- ^ route to run on match
-> RouteT f a
domain d r = RouteT $ \req path ->
if Just d == fmap uriRegName (uriAuthority $ requestURI req)
then runRouteT r req path
else pure Nothing
-- | Match on a specific path segment
dir :: Applicative f
=> String -- ^ What the segment must match
-> RouteT f a -- ^ Route to run on the rest of the path
-> RouteT f a
dir str r = RouteT $ \req path -> case path of
frag:rest | frag == str -> runRouteT r req rest
_ -> pure Nothing
-- TODO use a parsing class
-- | Match on an arbitrary path segment, and capture it
capture :: Applicative f
=> (String -> RouteT f a) -- ^ Function that takes the segment and
-- returns the route to run on the rest of
-- the path
-> RouteT f a
capture f = RouteT $ \req path -> case path of
frag:rest -> runRouteT (f frag) req rest
_ -> pure Nothing
-- TODO use a parsing class
-- | Require a query string, by asking the client (code 10) if necessary
input :: Applicative f
=> String -- ^ String to return to the client if there is no query string
-> (String -> RouteT f Response) -- ^ Function that takes the query string
-- and returns the route to run on the
-- rest of the path
-> RouteT f Response
input q f = RouteT $ \req path -> case uriQuery $ requestURI req of
'?':query -> runRouteT (f $ unEscapeString query) req path
_ -> pure $ pure $ Response 10 q mempty
-- | Capture, if present, the query string
optionalInput :: Applicative f
=> (Maybe String -> RouteT f a) -- ^ Function that takes the
-- query string (if present) and
-- returns the route to run on
-- the rest of the path
-> RouteT f a
optionalInput f = RouteT $ \req path -> case uriQuery $ requestURI req of
'?':query -> runRouteT (f $ Just $ unEscapeString query) req path
_ -> runRouteT (f Nothing) req path
-- | Require a client certificate, returning an error (code 60) if absent
cert :: Applicative m
=> String -- ^ String to return to the client if there is no
-- client certificate in the request
-> (X509 -> RouteT m Response) -- ^ Function that takes the client
-- certificate and returns the route to run
-- on the rest of the request
-> RouteT m Response
cert msg f = RouteT $ \req path -> case requestCert req of
Just c -> runRouteT (f c) req path
Nothing -> pure $ pure $ Response 60 msg mempty
-- | Obtain, if present, the client certificate
optionalCert :: Applicative m
=> (Maybe X509 -> RouteT m Response)
-- ^ Function that takes the client certificate (if present)
-- and returns the route to run on the rest of the request
-> RouteT m Response
optionalCert f = RouteT $ \req path ->
runRouteT (f $ requestCert req) req path
-- | Build custom routes. Takes a function that takes the request and the
-- remaining path segments and returns the result. A 'Nothing' makes the
-- request fall through to the next route
custom :: (Request -> [String] -> m (Maybe a)) -> RouteT m a
custom = RouteT
-- Getters
-------------------------------
getRequest :: Applicative m => RouteT m Request
getRequest = RouteT $ \req _ -> pure $ Just req
getPath :: Applicative m => RouteT m [String]
getPath = RouteT $ \_ path -> pure $ Just path