{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
module Network.Gemini.Router (
RouteT
, Route
, RouteIO
, runRouteT
, runRouteT'
, end
, dir
, capture
, input
, optionalInput
, cert
, optionalCert
, custom
, 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)
import OpenSSL.X509 (X509)
#if __GLASGOW_HASKELL__ < 808
import Control.Monad.Fail (MonadFail(..))
#endif
newtype RouteT m a = RouteT { RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT :: Request -> [String] -> m (Maybe a) }
type Route = RouteT Identity
type RouteIO = RouteT IO
instance Functor f => Functor (RouteT f) where
fmap :: (a -> b) -> RouteT f a -> RouteT f b
fmap a -> b
f RouteT f a
r = (Request -> [String] -> f (Maybe b)) -> RouteT f b
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> f (Maybe b)) -> RouteT f b)
-> (Request -> [String] -> f (Maybe b)) -> RouteT f b
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path -> (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Maybe a -> Maybe b) -> f (Maybe a) -> f (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RouteT f a -> Request -> [String] -> f (Maybe a)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT RouteT f a
r Request
req [String]
path
instance Applicative f => Applicative (RouteT f) where
pure :: a -> RouteT f a
pure a
x = (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> f (Maybe a)) -> RouteT f a)
-> (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall a b. (a -> b) -> a -> b
$ \Request
_ [String]
_ -> Maybe a -> f (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> f (Maybe a)) -> Maybe a -> f (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
RouteT f (a -> b)
f <*> :: RouteT f (a -> b) -> RouteT f a -> RouteT f b
<*> RouteT f a
x = (Request -> [String] -> f (Maybe b)) -> RouteT f b
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> f (Maybe b)) -> RouteT f b)
-> (Request -> [String] -> f (Maybe b)) -> RouteT f b
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path ->
(Maybe (a -> b) -> Maybe a -> Maybe b)
-> f (Maybe (a -> b)) -> f (Maybe a -> Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (RouteT f (a -> b) -> Request -> [String] -> f (Maybe (a -> b))
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT RouteT f (a -> b)
f Request
req [String]
path) f (Maybe a -> Maybe b) -> f (Maybe a) -> f (Maybe b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RouteT f a -> Request -> [String] -> f (Maybe a)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT RouteT f a
x Request
req [String]
path
instance Monad m => Monad (RouteT m) where
RouteT m a
rx >>= :: RouteT m a -> (a -> RouteT m b) -> RouteT m b
>>= a -> RouteT m b
f = (Request -> [String] -> m (Maybe b)) -> RouteT m b
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> m (Maybe b)) -> RouteT m b)
-> (Request -> [String] -> m (Maybe b)) -> RouteT m b
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path -> do
Maybe a
mx <- RouteT m a -> Request -> [String] -> m (Maybe a)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT RouteT m a
rx Request
req [String]
path
RouteT m b -> Request -> [String] -> m (Maybe b)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT (RouteT m b -> (a -> RouteT m b) -> Maybe a -> RouteT m b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Request -> [String] -> m (Maybe b)) -> RouteT m b
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> m (Maybe b)) -> RouteT m b)
-> (Request -> [String] -> m (Maybe b)) -> RouteT m b
forall a b. (a -> b) -> a -> b
$ \Request
_ [String]
_ -> Maybe b -> m (Maybe b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe b
forall a. Maybe a
Nothing) a -> RouteT m b
f Maybe a
mx) Request
req [String]
path
instance MonadTrans RouteT where
lift :: m a -> RouteT m a
lift = (Request -> [String] -> m (Maybe a)) -> RouteT m a
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> m (Maybe a)) -> RouteT m a)
-> (m a -> Request -> [String] -> m (Maybe a)) -> m a -> RouteT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> m (Maybe a)) -> Request -> [String] -> m (Maybe a)
forall a b. a -> b -> a
const (([String] -> m (Maybe a)) -> Request -> [String] -> m (Maybe a))
-> (m a -> [String] -> m (Maybe a))
-> m a
-> Request
-> [String]
-> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Maybe a) -> [String] -> m (Maybe a)
forall a b. a -> b -> a
const (m (Maybe a) -> [String] -> m (Maybe a))
-> (m a -> m (Maybe a)) -> m a -> [String] -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance MonadIO m => MonadIO (RouteT m) where
liftIO :: IO a -> RouteT m a
liftIO = (Request -> [String] -> m (Maybe a)) -> RouteT m a
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> m (Maybe a)) -> RouteT m a)
-> (IO a -> Request -> [String] -> m (Maybe a))
-> IO a
-> RouteT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> m (Maybe a)) -> Request -> [String] -> m (Maybe a)
forall a b. a -> b -> a
const (([String] -> m (Maybe a)) -> Request -> [String] -> m (Maybe a))
-> (IO a -> [String] -> m (Maybe a))
-> IO a
-> Request
-> [String]
-> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Maybe a) -> [String] -> m (Maybe a)
forall a b. a -> b -> a
const (m (Maybe a) -> [String] -> m (Maybe a))
-> (IO a -> m (Maybe a)) -> IO a -> [String] -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m a -> m (Maybe a)) -> (IO a -> m a) -> IO a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
instance Monad m => MonadFail (RouteT m) where
fail :: String -> RouteT m a
fail String
_ = RouteT m a
forall (f :: * -> *) a. Alternative f => f a
empty
instance Monad f => Alternative (RouteT f) where
empty :: RouteT f a
empty = (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> f (Maybe a)) -> RouteT f a)
-> (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall a b. (a -> b) -> a -> b
$ \Request
_ [String]
_ -> Maybe a -> f (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
RouteT f a
r1 <|> :: RouteT f a -> RouteT f a -> RouteT f a
<|> RouteT f a
r2 = (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> f (Maybe a)) -> RouteT f a)
-> (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path -> do
Maybe a
maybe1 <- RouteT f a -> Request -> [String] -> f (Maybe a)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT RouteT f a
r1 Request
req [String]
path
Maybe a
maybe2 <- RouteT f a -> Request -> [String] -> f (Maybe a)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT RouteT f a
r2 Request
req [String]
path
Maybe a -> f (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> f (Maybe a)) -> Maybe a -> f (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a
maybe1 Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a
maybe2
runRouteT' :: (m (Maybe Response) -> IO (Maybe Response))
-> RouteT m Response
-> Handler
runRouteT' :: (m (Maybe Response) -> IO (Maybe Response))
-> RouteT m Response -> Handler
runRouteT' m (Maybe Response) -> IO (Maybe Response)
runM RouteT m Response
r Request
req = Response -> Maybe Response -> Response
forall a. a -> Maybe a -> a
fromMaybe Response
notFound (Maybe Response -> Response) -> IO (Maybe Response) -> IO Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe Response) -> IO (Maybe Response)
runM (RouteT m Response -> Request -> [String] -> m (Maybe Response)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT RouteT m Response
r Request
req [String]
path)
where
notFound :: Response
notFound = Int -> String -> ByteString -> Response
Response Int
51 String
"Not found" ByteString
forall a. Monoid a => a
mempty
path :: [String]
path = String -> String
unEscapeString (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> URI -> [String]
pathSegments (Request -> URI
requestURI Request
req)
end :: Applicative f
=> RouteT f a
-> RouteT f a
end :: RouteT f a -> RouteT f a
end RouteT f a
r = (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> f (Maybe a)) -> RouteT f a)
-> (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path -> case [String]
path of
[] -> RouteT f a -> Request -> [String] -> f (Maybe a)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT RouteT f a
r Request
req [String]
path
[String]
_ -> Maybe a -> f (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
dir :: Applicative f
=> String
-> RouteT f a
-> RouteT f a
dir :: String -> RouteT f a -> RouteT f a
dir String
str RouteT f a
r = (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> f (Maybe a)) -> RouteT f a)
-> (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path -> case [String]
path of
String
frag:[String]
rest | String
frag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
str -> RouteT f a -> Request -> [String] -> f (Maybe a)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT RouteT f a
r Request
req [String]
rest
[String]
_ -> Maybe a -> f (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
capture :: Applicative f
=> (String -> RouteT f a)
-> RouteT f a
capture :: (String -> RouteT f a) -> RouteT f a
capture String -> RouteT f a
f = (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> f (Maybe a)) -> RouteT f a)
-> (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path -> case [String]
path of
String
frag:[String]
rest -> RouteT f a -> Request -> [String] -> f (Maybe a)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT (String -> RouteT f a
f String
frag) Request
req [String]
rest
[String]
_ -> Maybe a -> f (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
input :: Applicative f
=> String
-> (String -> RouteT f Response)
-> RouteT f Response
input :: String -> (String -> RouteT f Response) -> RouteT f Response
input String
q String -> RouteT f Response
f = (Request -> [String] -> f (Maybe Response)) -> RouteT f Response
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> f (Maybe Response)) -> RouteT f Response)
-> (Request -> [String] -> f (Maybe Response)) -> RouteT f Response
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path -> case URI -> String
uriQuery (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ Request -> URI
requestURI Request
req of
Char
'?':String
query -> RouteT f Response -> Request -> [String] -> f (Maybe Response)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT (String -> RouteT f Response
f (String -> RouteT f Response) -> String -> RouteT f Response
forall a b. (a -> b) -> a -> b
$ String -> String
unEscapeString String
query) Request
req [String]
path
String
_ -> Maybe Response -> f (Maybe Response)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Response -> f (Maybe Response))
-> Maybe Response -> f (Maybe Response)
forall a b. (a -> b) -> a -> b
$ Response -> Maybe Response
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Maybe Response) -> Response -> Maybe Response
forall a b. (a -> b) -> a -> b
$ Int -> String -> ByteString -> Response
Response Int
10 String
q ByteString
forall a. Monoid a => a
mempty
optionalInput :: Applicative f
=> (Maybe String -> RouteT f a)
-> RouteT f a
optionalInput :: (Maybe String -> RouteT f a) -> RouteT f a
optionalInput Maybe String -> RouteT f a
f = (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> f (Maybe a)) -> RouteT f a)
-> (Request -> [String] -> f (Maybe a)) -> RouteT f a
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path -> case URI -> String
uriQuery (URI -> String) -> URI -> String
forall a b. (a -> b) -> a -> b
$ Request -> URI
requestURI Request
req of
Char
'?':String
query -> RouteT f a -> Request -> [String] -> f (Maybe a)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT (Maybe String -> RouteT f a
f (Maybe String -> RouteT f a) -> Maybe String -> RouteT f a
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String
unEscapeString String
query) Request
req [String]
path
String
_ -> RouteT f a -> Request -> [String] -> f (Maybe a)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT (Maybe String -> RouteT f a
f Maybe String
forall a. Maybe a
Nothing) Request
req [String]
path
cert :: Applicative m
=> String
-> (X509 -> RouteT m Response)
-> RouteT m Response
cert :: String -> (X509 -> RouteT m Response) -> RouteT m Response
cert String
msg X509 -> RouteT m Response
f = (Request -> [String] -> m (Maybe Response)) -> RouteT m Response
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> m (Maybe Response)) -> RouteT m Response)
-> (Request -> [String] -> m (Maybe Response)) -> RouteT m Response
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path -> case Request -> Maybe X509
requestCert Request
req of
Just X509
c -> RouteT m Response -> Request -> [String] -> m (Maybe Response)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT (X509 -> RouteT m Response
f X509
c) Request
req [String]
path
Maybe X509
Nothing -> Maybe Response -> m (Maybe Response)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Response -> m (Maybe Response))
-> Maybe Response -> m (Maybe Response)
forall a b. (a -> b) -> a -> b
$ Response -> Maybe Response
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Maybe Response) -> Response -> Maybe Response
forall a b. (a -> b) -> a -> b
$ Int -> String -> ByteString -> Response
Response Int
60 String
msg ByteString
forall a. Monoid a => a
mempty
optionalCert :: Applicative m
=> (Maybe X509 -> RouteT m Response)
-> RouteT m Response
optionalCert :: (Maybe X509 -> RouteT m Response) -> RouteT m Response
optionalCert Maybe X509 -> RouteT m Response
f = (Request -> [String] -> m (Maybe Response)) -> RouteT m Response
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> m (Maybe Response)) -> RouteT m Response)
-> (Request -> [String] -> m (Maybe Response)) -> RouteT m Response
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
path ->
RouteT m Response -> Request -> [String] -> m (Maybe Response)
forall (m :: * -> *) a.
RouteT m a -> Request -> [String] -> m (Maybe a)
runRouteT (Maybe X509 -> RouteT m Response
f (Maybe X509 -> RouteT m Response)
-> Maybe X509 -> RouteT m Response
forall a b. (a -> b) -> a -> b
$ Request -> Maybe X509
requestCert Request
req) Request
req [String]
path
custom :: (Request -> [String] -> m (Maybe a)) -> RouteT m a
custom :: (Request -> [String] -> m (Maybe a)) -> RouteT m a
custom = (Request -> [String] -> m (Maybe a)) -> RouteT m a
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT
getRequest :: Applicative m => RouteT m Request
getRequest :: RouteT m Request
getRequest = (Request -> [String] -> m (Maybe Request)) -> RouteT m Request
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> m (Maybe Request)) -> RouteT m Request)
-> (Request -> [String] -> m (Maybe Request)) -> RouteT m Request
forall a b. (a -> b) -> a -> b
$ \Request
req [String]
_ -> Maybe Request -> m (Maybe Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Request -> m (Maybe Request))
-> Maybe Request -> m (Maybe Request)
forall a b. (a -> b) -> a -> b
$ Request -> Maybe Request
forall a. a -> Maybe a
Just Request
req
getPath :: Applicative m => RouteT m [String]
getPath :: RouteT m [String]
getPath = (Request -> [String] -> m (Maybe [String])) -> RouteT m [String]
forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT ((Request -> [String] -> m (Maybe [String])) -> RouteT m [String])
-> (Request -> [String] -> m (Maybe [String])) -> RouteT m [String]
forall a b. (a -> b) -> a -> b
$ \Request
_ [String]
path -> Maybe [String] -> m (Maybe [String])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe [String] -> m (Maybe [String]))
-> Maybe [String] -> m (Maybe [String])
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
path