{-# 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 { 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

-- 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 :: forall a. String -> RouteT m a
fail String
_ = forall (f :: * -> *) a. Alternative f => f a
empty

-- | 'empty' skips to the next route.
-- @r1 '<|>' r2@ means go to @r2@ if @r1@ skips
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

-- 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' :: 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)

-- Building Routes
-------------------------------

-- | Match on the end of the path
end :: Applicative f
    => RouteT f a -- ^ Route to run
    -> 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

-- | 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 :: 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

-- | 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 :: 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

-- 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 :: 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

-- 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 :: 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

-- | 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 :: 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

-- | 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 :: 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

-- | 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 :: 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

-- | 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 :: forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
custom = forall (m :: * -> *) a.
(Request -> [String] -> m (Maybe a)) -> RouteT m a
RouteT

-- Getters
-------------------------------

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