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