{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Web.Simple.Controller.Trans where
import Control.Exception
import Control.Monad hiding (guard)
import Control.Monad.Base
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Applicative
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import Data.List (find)
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Typeable
import Network.HTTP.Types
import Network.Wai
import Web.Simple.Responses
newtype ControllerT s m a = ControllerT
{ ControllerT s m a -> s -> Request -> m (Either Response a, s)
runController :: s -> Request ->
m (Either Response a, s) }
instance Functor m => Functor (ControllerT s m) where
fmap :: (a -> b) -> ControllerT s m a -> ControllerT s m b
fmap f :: a -> b
f (ControllerT act :: s -> Request -> m (Either Response a, s)
act) = (s -> Request -> m (Either Response b, s)) -> ControllerT s m b
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response b, s)) -> ControllerT s m b)
-> (s -> Request -> m (Either Response b, s)) -> ControllerT s m b
forall a b. (a -> b) -> a -> b
$ \st0 :: s
st0 req :: Request
req ->
(Either Response a, s) -> (Either Response b, s)
go ((Either Response a, s) -> (Either Response b, s))
-> m (Either Response a, s) -> m (Either Response b, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` s -> Request -> m (Either Response a, s)
act s
st0 Request
req
where go :: (Either Response a, s) -> (Either Response b, s)
go (eaf :: Either Response a
eaf, st :: s
st) = case Either Response a
eaf of
Left resp :: Response
resp -> (Response -> Either Response b
forall a b. a -> Either a b
Left Response
resp, s
st)
Right result :: a
result -> (b -> Either Response b
forall a b. b -> Either a b
Right (b -> Either Response b) -> b -> Either Response b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
result, s
st)
instance (Monad m, Functor m) => Applicative (ControllerT s m) where
pure :: a -> ControllerT s m a
pure = a -> ControllerT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: ControllerT s m (a -> b) -> ControllerT s m a -> ControllerT s m b
(<*>) = ControllerT s m (a -> b) -> ControllerT s m a -> ControllerT s m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad m => Monad (ControllerT s m) where
return :: a -> ControllerT s m a
return a :: a
a = (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response a, s)) -> ControllerT s m a)
-> (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall a b. (a -> b) -> a -> b
$ \st :: s
st _ -> (Either Response a, s) -> m (Either Response a, s)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Either Response a, s) -> m (Either Response a, s))
-> (Either Response a, s) -> m (Either Response a, s)
forall a b. (a -> b) -> a -> b
$ (a -> Either Response a
forall a b. b -> Either a b
Right a
a, s
st)
(ControllerT act :: s -> Request -> m (Either Response a, s)
act) >>= :: ControllerT s m a -> (a -> ControllerT s m b) -> ControllerT s m b
>>= fn :: a -> ControllerT s m b
fn = (s -> Request -> m (Either Response b, s)) -> ControllerT s m b
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response b, s)) -> ControllerT s m b)
-> (s -> Request -> m (Either Response b, s)) -> ControllerT s m b
forall a b. (a -> b) -> a -> b
$ \st0 :: s
st0 req :: Request
req -> do
(eres :: Either Response a
eres, st :: s
st) <- s -> Request -> m (Either Response a, s)
act s
st0 Request
req
case Either Response a
eres of
Left resp :: Response
resp -> (Either Response b, s) -> m (Either Response b, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> Either Response b
forall a b. a -> Either a b
Left Response
resp, s
st)
Right result :: a
result -> do
let (ControllerT fres :: s -> Request -> m (Either Response b, s)
fres) = a -> ControllerT s m b
fn a
result
s -> Request -> m (Either Response b, s)
fres s
st Request
req
instance (Functor m, Monad m) => Alternative (ControllerT s m) where
empty :: ControllerT s m a
empty = Response -> ControllerT s m a
forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond Response
notFound
<|> :: ControllerT s m a -> ControllerT s m a -> ControllerT s m a
(<|>) = ControllerT s m a -> ControllerT s m a -> ControllerT s m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)
instance Monad m => MonadPlus (ControllerT s m) where
mzero :: ControllerT s m a
mzero = Response -> ControllerT s m a
forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond Response
notFound
mplus :: ControllerT s m a -> ControllerT s m a -> ControllerT s m a
mplus = (ControllerT s m a -> ControllerT s m a -> ControllerT s m a)
-> ControllerT s m a -> ControllerT s m a -> ControllerT s m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ControllerT s m a -> ControllerT s m a -> ControllerT s m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)
instance MonadTrans (ControllerT s) where
lift :: m a -> ControllerT s m a
lift act :: m a
act = (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response a, s)) -> ControllerT s m a)
-> (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall a b. (a -> b) -> a -> b
$ \st :: s
st _ -> m a
act m a -> (a -> m (Either Response a, s)) -> m (Either Response a, s)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \r :: a
r -> (Either Response a, s) -> m (Either Response a, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either Response a
forall a b. b -> Either a b
Right a
r, s
st)
instance Monad m => MonadState s (ControllerT s m) where
get :: ControllerT s m s
get = (s -> Request -> m (Either Response s, s)) -> ControllerT s m s
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response s, s)) -> ControllerT s m s)
-> (s -> Request -> m (Either Response s, s)) -> ControllerT s m s
forall a b. (a -> b) -> a -> b
$ \s :: s
s _ -> (Either Response s, s) -> m (Either Response s, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (s -> Either Response s
forall a b. b -> Either a b
Right s
s, s
s)
put :: s -> ControllerT s m ()
put s :: s
s = (s -> Request -> m (Either Response (), s)) -> ControllerT s m ()
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response (), s)) -> ControllerT s m ())
-> (s -> Request -> m (Either Response (), s))
-> ControllerT s m ()
forall a b. (a -> b) -> a -> b
$ \_ _ -> (Either Response (), s) -> m (Either Response (), s)
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either Response ()
forall a b. b -> Either a b
Right (), s
s)
instance Monad m => MonadReader Request (ControllerT s m) where
ask :: ControllerT s m Request
ask = (s -> Request -> m (Either Response Request, s))
-> ControllerT s m Request
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response Request, s))
-> ControllerT s m Request)
-> (s -> Request -> m (Either Response Request, s))
-> ControllerT s m Request
forall a b. (a -> b) -> a -> b
$ \st :: s
st req :: Request
req -> (Either Response Request, s) -> m (Either Response Request, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> Either Response Request
forall a b. b -> Either a b
Right Request
req, s
st)
local :: (Request -> Request) -> ControllerT s m a -> ControllerT s m a
local f :: Request -> Request
f (ControllerT act :: s -> Request -> m (Either Response a, s)
act) = (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response a, s)) -> ControllerT s m a)
-> (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall a b. (a -> b) -> a -> b
$ \st :: s
st req :: Request
req -> s -> Request -> m (Either Response a, s)
act s
st (Request -> Request
f Request
req)
instance MonadIO m => MonadIO (ControllerT s m) where
liftIO :: IO a -> ControllerT s m a
liftIO = m a -> ControllerT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ControllerT s m a)
-> (IO a -> m a) -> IO a -> ControllerT s m 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 (ControllerT s m) where
fail :: String -> ControllerT s m a
fail = String -> ControllerT s m a
forall s (m :: * -> *) a. String -> ControllerT s m a
err
instance (Applicative m, Monad m, MonadBase m m) => MonadBase m (ControllerT s m) where
liftBase :: m α -> ControllerT s m α
liftBase = m α -> ControllerT s m α
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) α.
(MonadTrans t, MonadBase b m) =>
b α -> t m α
liftBaseDefault
instance MonadBaseControl m m => MonadBaseControl m (ControllerT s m) where
type StM (ControllerT s m) a = (Either Response a, s)
liftBaseWith :: (RunInBase (ControllerT s m) m -> m a) -> ControllerT s m a
liftBaseWith fn :: RunInBase (ControllerT s m) m -> m a
fn = (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response a, s)) -> ControllerT s m a)
-> (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall a b. (a -> b) -> a -> b
$ \st :: s
st req :: Request
req -> do
a
res <- RunInBase (ControllerT s m) m -> m a
fn (RunInBase (ControllerT s m) m -> m a)
-> RunInBase (ControllerT s m) m -> m a
forall a b. (a -> b) -> a -> b
$ \act :: ControllerT s m a
act -> ControllerT s m a -> s -> Request -> m (Either Response a, s)
forall s (m :: * -> *) a.
ControllerT s m a -> s -> Request -> m (Either Response a, s)
runController ControllerT s m a
act s
st Request
req
(Either Response a, s) -> m (Either Response a, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either Response a
forall a b. b -> Either a b
Right a
res, s
st)
restoreM :: StM (ControllerT s m) a -> ControllerT s m a
restoreM (a, s) = (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response a, s)) -> ControllerT s m a)
-> (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall a b. (a -> b) -> a -> b
$ \_ _ -> (Either Response a, s) -> m (Either Response a, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Response a
a, s
s)
hoistEither :: Monad m => Either Response a -> ControllerT s m a
hoistEither :: Either Response a -> ControllerT s m a
hoistEither eith :: Either Response a
eith = (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT ((s -> Request -> m (Either Response a, s)) -> ControllerT s m a)
-> (s -> Request -> m (Either Response a, s)) -> ControllerT s m a
forall a b. (a -> b) -> a -> b
$ \st :: s
st _ -> (Either Response a, s) -> m (Either Response a, s)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Response a
eith, s
st)
request :: Monad m => ControllerT s m Request
request :: ControllerT s m Request
request = ControllerT s m Request
forall r (m :: * -> *). MonadReader r m => m r
ask
localRequest :: Monad m
=> (Request -> Request) -> ControllerT s m a -> ControllerT s m a
localRequest :: (Request -> Request) -> ControllerT s m a -> ControllerT s m a
localRequest = (Request -> Request) -> ControllerT s m a -> ControllerT s m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
controllerState :: Monad m => ControllerT s m s
controllerState :: ControllerT s m s
controllerState = ControllerT s m s
forall s (m :: * -> *). MonadState s m => m s
get
putState :: Monad m => s -> ControllerT s m ()
putState :: s -> ControllerT s m ()
putState = s -> ControllerT s m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
controllerApp :: Monad m => s -> ControllerT s m a -> SimpleApplication m
controllerApp :: s -> ControllerT s m a -> SimpleApplication m
controllerApp s :: s
s ctrl :: ControllerT s m a
ctrl req :: Request
req =
ControllerT s m a -> s -> Request -> m (Either Response a, s)
forall s (m :: * -> *) a.
ControllerT s m a -> s -> Request -> m (Either Response a, s)
runController ControllerT s m a
ctrl s
s Request
req m (Either Response a, s)
-> ((Either Response a, s) -> m Response) -> m Response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(Response -> m Response)
-> (a -> m Response) -> Either Response a -> m Response
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Response -> m Response
forall (m :: * -> *) a. Monad m => a -> m a
return (m Response -> a -> m Response
forall a b. a -> b -> a
const (m Response -> a -> m Response) -> m Response -> a -> m Response
forall a b. (a -> b) -> a -> b
$ Response -> m Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
notFound) (Either Response a -> m Response)
-> ((Either Response a, s) -> Either Response a)
-> (Either Response a, s)
-> m Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either Response a, s) -> Either Response a
forall a b. (a, b) -> a
fst
respond :: Monad m => Response -> ControllerT s m a
respond :: Response -> ControllerT s m a
respond resp :: Response
resp = Either Response a -> ControllerT s m a
forall (m :: * -> *) a s.
Monad m =>
Either Response a -> ControllerT s m a
hoistEither (Either Response a -> ControllerT s m a)
-> Either Response a -> ControllerT s m a
forall a b. (a -> b) -> a -> b
$ Response -> Either Response a
forall a b. a -> Either a b
Left Response
resp
fromApp :: Monad m => (Request -> m Response) -> ControllerT s m ()
fromApp :: (Request -> m Response) -> ControllerT s m ()
fromApp app :: Request -> m Response
app = do
Request
req <- ControllerT s m Request
forall (m :: * -> *) s. Monad m => ControllerT s m Request
request
Response
resp <- m Response -> ControllerT s m Response
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Response -> ControllerT s m Response)
-> m Response -> ControllerT s m Response
forall a b. (a -> b) -> a -> b
$ Request -> m Response
app Request
req
Response -> ControllerT s m ()
forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond Response
resp
routeHost :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m ()
routeHost :: ByteString -> ControllerT s m a -> ControllerT s m ()
routeHost host :: ByteString
host = (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
forall (m :: * -> *) s a.
Monad m =>
(Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq ((Request -> Bool) -> ControllerT s m a -> ControllerT s m ())
-> (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
forall a b. (a -> b) -> a -> b
$ \req :: Request
req ->
ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
host Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Request -> Maybe ByteString
requestHeaderHost Request
req
routeTop :: Monad m => ControllerT s m a -> ControllerT s m ()
routeTop :: ControllerT s m a -> ControllerT s m ()
routeTop = (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
forall (m :: * -> *) s a.
Monad m =>
(Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq ((Request -> Bool) -> ControllerT s m a -> ControllerT s m ())
-> (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
forall a b. (a -> b) -> a -> b
$ \req :: Request
req -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Request -> [Text]
pathInfo Request
req) Bool -> Bool -> Bool
||
(Text -> Int
T.length (Text -> Int) -> ([Text] -> Text) -> [Text] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. [a] -> a
head ([Text] -> Int) -> [Text] -> Int
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
req) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
routeMethod :: Monad m => StdMethod -> ControllerT s m a -> ControllerT s m ()
routeMethod :: StdMethod -> ControllerT s m a -> ControllerT s m ()
routeMethod method :: StdMethod
method = (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
forall (m :: * -> *) s a.
Monad m =>
(Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq ((Request -> Bool) -> ControllerT s m a -> ControllerT s m ())
-> (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
forall a b. (a -> b) -> a -> b
$ (StdMethod -> ByteString
renderStdMethod StdMethod
method ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==) (ByteString -> Bool) -> (Request -> ByteString) -> Request -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ByteString
requestMethod
routeAccept :: Monad m => S8.ByteString -> ControllerT s m a -> ControllerT s m ()
routeAccept :: ByteString -> ControllerT s m a -> ControllerT s m ()
routeAccept contentType :: ByteString
contentType = (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
forall (m :: * -> *) s a.
Monad m =>
(Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq (Maybe (HeaderName, ByteString) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (HeaderName, ByteString) -> Bool)
-> (Request -> Maybe (HeaderName, ByteString)) -> Request -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> Bool)
-> [(HeaderName, ByteString)] -> Maybe (HeaderName, ByteString)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (HeaderName, ByteString) -> Bool
matching ([(HeaderName, ByteString)] -> Maybe (HeaderName, ByteString))
-> (Request -> [(HeaderName, ByteString)])
-> Request
-> Maybe (HeaderName, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(HeaderName, ByteString)]
requestHeaders)
where matching :: (HeaderName, ByteString) -> Bool
matching hdr :: (HeaderName, ByteString)
hdr = (HeaderName, ByteString) -> HeaderName
forall a b. (a, b) -> a
fst (HeaderName, ByteString)
hdr HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hAccept Bool -> Bool -> Bool
&& (HeaderName, ByteString) -> ByteString
forall a b. (a, b) -> b
snd (HeaderName, ByteString)
hdr ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
contentType
routePattern :: Monad m
=> Text -> ControllerT s m a -> ControllerT s m ()
routePattern :: Text -> ControllerT s m a -> ControllerT s m ()
routePattern pattern :: Text
pattern route :: ControllerT s m a
route =
let patternParts :: [Text]
patternParts = ByteString -> [Text]
decodePathSegments (Text -> ByteString
T.encodeUtf8 Text
pattern)
in (Text -> ControllerT s m () -> ControllerT s m ())
-> ControllerT s m () -> [Text] -> ControllerT s m ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> ControllerT s m () -> ControllerT s m ()
forall (m :: * -> *) s a.
Monad m =>
Text -> ControllerT s m a -> ControllerT s m ()
mkRoute (ControllerT s m a
route ControllerT s m a -> ControllerT s m () -> ControllerT s m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ControllerT s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) [Text]
patternParts
where mkRoute :: Text -> ControllerT s m a -> ControllerT s m ()
mkRoute name :: Text
name = case Text -> Maybe (Char, Text)
T.uncons Text
name of
Just (':', varName :: Text
varName) -> Text -> ControllerT s m a -> ControllerT s m ()
forall (m :: * -> *) s a.
Monad m =>
Text -> ControllerT s m a -> ControllerT s m ()
routeVar Text
varName
_ -> Text -> ControllerT s m a -> ControllerT s m ()
forall (m :: * -> *) s a.
Monad m =>
Text -> ControllerT s m a -> ControllerT s m ()
routeName Text
name
routeName :: Monad m => Text -> ControllerT s m a -> ControllerT s m ()
routeName :: Text -> ControllerT s m a -> ControllerT s m ()
routeName name :: Text
name next :: ControllerT s m a
next = do
Request
req <- ControllerT s m Request
forall (m :: * -> *) s. Monad m => ControllerT s m Request
request
if ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> Int) -> [Text] -> Int
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
req) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
&& Text
name Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== ([Text] -> Text
forall a. [a] -> a
head ([Text] -> Text) -> (Request -> [Text]) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo) Request
req
then (Request -> Request) -> ControllerT s m a -> ControllerT s m a
forall (m :: * -> *) s a.
Monad m =>
(Request -> Request) -> ControllerT s m a -> ControllerT s m a
localRequest Request -> Request
popHdr ControllerT s m a
next ControllerT s m a -> ControllerT s m () -> ControllerT s m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ControllerT s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else () -> ControllerT s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where popHdr :: Request -> Request
popHdr req :: Request
req = Request
req { pathInfo :: [Text]
pathInfo = ([Text] -> [Text]
forall a. [a] -> [a]
tail ([Text] -> [Text]) -> (Request -> [Text]) -> Request -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo (Request -> [Text]) -> Request -> [Text]
forall a b. (a -> b) -> a -> b
$ Request
req) }
routeVar :: Monad m => Text -> ControllerT s m a -> ControllerT s m ()
routeVar :: Text -> ControllerT s m a -> ControllerT s m ()
routeVar varName :: Text
varName next :: ControllerT s m a
next = do
Request
req <- ControllerT s m Request
forall (m :: * -> *) s. Monad m => ControllerT s m Request
request
case Request -> [Text]
pathInfo Request
req of
[] -> () -> ControllerT s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
x :: Text
x:_ | Text -> Bool
T.null Text
x -> () -> ControllerT s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> (Request -> Request) -> ControllerT s m a -> ControllerT s m a
forall (m :: * -> *) s a.
Monad m =>
(Request -> Request) -> ControllerT s m a -> ControllerT s m a
localRequest Request -> Request
popHdr ControllerT s m a
next ControllerT s m a -> ControllerT s m () -> ControllerT s m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ControllerT s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where popHdr :: Request -> Request
popHdr req :: Request
req = Request
req {
pathInfo :: [Text]
pathInfo = ([Text] -> [Text]
forall a. [a] -> [a]
tail ([Text] -> [Text]) -> (Request -> [Text]) -> Request -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo (Request -> [Text]) -> Request -> [Text]
forall a b. (a -> b) -> a -> b
$ Request
req)
, queryString :: Query
queryString = (Text -> ByteString
T.encodeUtf8 Text
varName, ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Request -> ByteString
varVal Request
req))(ByteString, Maybe ByteString) -> Query -> Query
forall a. a -> [a] -> [a]
:(Request -> Query
queryString Request
req)}
varVal :: Request -> ByteString
varVal req :: Request
req = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (Request -> Text) -> Request -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. [a] -> a
head ([Text] -> Text) -> (Request -> [Text]) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo (Request -> ByteString) -> Request -> ByteString
forall a b. (a -> b) -> a -> b
$ Request
req
queryParam :: (Monad m, Parseable a)
=> S8.ByteString
-> ControllerT s m (Maybe a)
queryParam :: ByteString -> ControllerT s m (Maybe a)
queryParam varName :: ByteString
varName = do
Query
qr <- (Request -> Query)
-> ControllerT s m Request -> ControllerT s m Query
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Query
queryString ControllerT s m Request
forall (m :: * -> *) s. Monad m => ControllerT s m Request
request
Maybe a -> ControllerT s m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> ControllerT s m (Maybe a))
-> Maybe a -> ControllerT s m (Maybe a)
forall a b. (a -> b) -> a -> b
$ case ByteString -> Query -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
varName Query
qr of
Just p :: Maybe ByteString
p -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ ByteString -> a
forall a. Parseable a => ByteString -> a
parse (ByteString -> a) -> ByteString -> a
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
S.empty Maybe ByteString
p
_ -> Maybe a
forall a. Maybe a
Nothing
queryParam' :: (Monad m, Parseable a)
=> S.ByteString -> ControllerT s m a
queryParam' :: ByteString -> ControllerT s m a
queryParam' varName :: ByteString
varName =
ByteString -> ControllerT s m (Maybe a)
forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m (Maybe a)
queryParam ByteString
varName ControllerT s m (Maybe a)
-> (Maybe a -> ControllerT s m a) -> ControllerT s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ControllerT s m a
-> (a -> ControllerT s m a) -> Maybe a -> ControllerT s m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ControllerT s m a
forall s (m :: * -> *) a. String -> ControllerT s m a
err (String -> ControllerT s m a) -> String -> ControllerT s m a
forall a b. (a -> b) -> a -> b
$ "no parameter " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
varName) a -> ControllerT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return
queryParams :: (Monad m, Parseable a)
=> S.ByteString -> ControllerT s m [a]
queryParams :: ByteString -> ControllerT s m [a]
queryParams varName :: ByteString
varName = ControllerT s m Request
forall (m :: * -> *) s. Monad m => ControllerT s m Request
request ControllerT s m Request
-> (Request -> ControllerT s m [a]) -> ControllerT s m [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [a] -> ControllerT s m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> ControllerT s m [a])
-> (Request -> [a]) -> Request -> ControllerT s m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((ByteString, Maybe ByteString) -> a) -> Query -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> a
forall a. Parseable a => ByteString -> a
parse (ByteString -> a)
-> ((ByteString, Maybe ByteString) -> ByteString)
-> (ByteString, Maybe ByteString)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
S.empty (Maybe ByteString -> ByteString)
-> ((ByteString, Maybe ByteString) -> Maybe ByteString)
-> (ByteString, Maybe ByteString)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, Maybe ByteString) -> Maybe ByteString
forall a b. (a, b) -> b
snd) (Query -> [a]) -> (Request -> Query) -> Request -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
((ByteString, Maybe ByteString) -> Bool) -> Query -> Query
forall a. (a -> Bool) -> [a] -> [a]
filter ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
varName) (ByteString -> Bool)
-> ((ByteString, Maybe ByteString) -> ByteString)
-> (ByteString, Maybe ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, Maybe ByteString) -> ByteString
forall a b. (a, b) -> a
fst) (Query -> Query) -> (Request -> Query) -> Request -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Request -> Query
queryString
class Parseable a where
parse :: S8.ByteString -> a
instance Parseable S8.ByteString where
parse :: ByteString -> ByteString
parse = ByteString -> ByteString
forall a. a -> a
id
instance Parseable String where
parse :: ByteString -> String
parse = ByteString -> String
S8.unpack
instance Parseable Text where
parse :: ByteString -> Text
parse = ByteString -> Text
T.decodeUtf8
readQueryParam :: (Monad m, Read a)
=> S8.ByteString
-> ControllerT s m (Maybe a)
readQueryParam :: ByteString -> ControllerT s m (Maybe a)
readQueryParam varName :: ByteString
varName =
ByteString -> ControllerT s m (Maybe Text)
forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m (Maybe a)
queryParam ByteString
varName ControllerT s m (Maybe Text)
-> (Maybe Text -> ControllerT s m (Maybe a))
-> ControllerT s m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ControllerT s m (Maybe a)
-> (Text -> ControllerT s m (Maybe a))
-> Maybe Text
-> ControllerT s m (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a -> ControllerT s m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) ((a -> Maybe a) -> ControllerT s m a -> ControllerT s m (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just (ControllerT s m a -> ControllerT s m (Maybe a))
-> (Text -> ControllerT s m a) -> Text -> ControllerT s m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text -> ControllerT s m a
forall (m :: * -> *) a s.
(Monad m, Read a) =>
ByteString -> Text -> ControllerT s m a
readParamValue ByteString
varName)
readQueryParam' :: (Monad m, Read a)
=> S8.ByteString
-> ControllerT s m a
readQueryParam' :: ByteString -> ControllerT s m a
readQueryParam' varName :: ByteString
varName =
ByteString -> ControllerT s m Text
forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m a
queryParam' ByteString
varName ControllerT s m Text
-> (Text -> ControllerT s m a) -> ControllerT s m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Text -> ControllerT s m a
forall (m :: * -> *) a s.
(Monad m, Read a) =>
ByteString -> Text -> ControllerT s m a
readParamValue ByteString
varName
readQueryParams :: (Monad m, Read a)
=> S8.ByteString
-> ControllerT s m [a]
readQueryParams :: ByteString -> ControllerT s m [a]
readQueryParams varName :: ByteString
varName =
ByteString -> ControllerT s m [Text]
forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m [a]
queryParams ByteString
varName ControllerT s m [Text]
-> ([Text] -> ControllerT s m [a]) -> ControllerT s m [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> ControllerT s m a) -> [Text] -> ControllerT s m [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ByteString -> Text -> ControllerT s m a
forall (m :: * -> *) a s.
(Monad m, Read a) =>
ByteString -> Text -> ControllerT s m a
readParamValue ByteString
varName)
readParamValue :: (Monad m, Read a)
=> S8.ByteString -> Text -> ControllerT s m a
readParamValue :: ByteString -> Text -> ControllerT s m a
readParamValue varName :: ByteString
varName =
ControllerT s m a
-> (a -> ControllerT s m a) -> Maybe a -> ControllerT s m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ControllerT s m a
forall s (m :: * -> *) a. String -> ControllerT s m a
err (String -> ControllerT s m a) -> String -> ControllerT s m a
forall a b. (a -> b) -> a -> b
$ "cannot read parameter: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
varName) a -> ControllerT s m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> ControllerT s m a)
-> (Text -> Maybe a) -> Text -> ControllerT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> Maybe a
forall a. Read a => String -> Maybe a
readMay (String -> Maybe a) -> (Text -> String) -> Text -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
where readMay :: String -> Maybe a
readMay s :: String
s = case [a
x | (x :: a
x,rst :: String
rst) <- ReadS a
forall a. Read a => ReadS a
reads String
s, ("", "") <- ReadS String
lex String
rst] of
[x :: a
x] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
_ -> Maybe a
forall a. Maybe a
Nothing
requestHeader :: Monad m => HeaderName -> ControllerT s m (Maybe S8.ByteString)
name :: HeaderName
name = ControllerT s m Request
forall (m :: * -> *) s. Monad m => ControllerT s m Request
request ControllerT s m Request
-> (Request -> ControllerT s m (Maybe ByteString))
-> ControllerT s m (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ByteString -> ControllerT s m (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> ControllerT s m (Maybe ByteString))
-> (Request -> Maybe ByteString)
-> Request
-> ControllerT s m (Maybe ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
name ([(HeaderName, ByteString)] -> Maybe ByteString)
-> (Request -> [(HeaderName, ByteString)])
-> Request
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [(HeaderName, ByteString)]
requestHeaders
redirectBack :: Monad m => ControllerT s m ()
redirectBack :: ControllerT s m ()
redirectBack = Response -> ControllerT s m ()
forall (m :: * -> *) s. Monad m => Response -> ControllerT s m ()
redirectBackOr (ByteString -> Response
redirectTo "/")
redirectBackOr :: Monad m
=> Response
-> ControllerT s m ()
redirectBackOr :: Response -> ControllerT s m ()
redirectBackOr def :: Response
def = do
Maybe ByteString
mrefr <- HeaderName -> ControllerT s m (Maybe ByteString)
forall (m :: * -> *) s.
Monad m =>
HeaderName -> ControllerT s m (Maybe ByteString)
requestHeader "referer"
case Maybe ByteString
mrefr of
Just refr :: ByteString
refr -> Response -> ControllerT s m ()
forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond (Response -> ControllerT s m ()) -> Response -> ControllerT s m ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Response
redirectTo ByteString
refr
Nothing -> Response -> ControllerT s m ()
forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond Response
def
type SimpleApplication m = Request -> m Response
type SimpleMiddleware m = SimpleApplication m -> SimpleApplication m
guard :: Monad m => Bool -> ControllerT s m a -> ControllerT s m ()
guard :: Bool -> ControllerT s m a -> ControllerT s m ()
guard b :: Bool
b c :: ControllerT s m a
c = if Bool
b then ControllerT s m a
c ControllerT s m a -> ControllerT s m () -> ControllerT s m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ControllerT s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else () -> ControllerT s m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
guardM :: Monad m
=> ControllerT s m Bool -> ControllerT s m a -> ControllerT s m ()
guardM :: ControllerT s m Bool -> ControllerT s m a -> ControllerT s m ()
guardM b :: ControllerT s m Bool
b c :: ControllerT s m a
c = ControllerT s m Bool
b ControllerT s m Bool
-> (Bool -> ControllerT s m ()) -> ControllerT s m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> ControllerT s m a -> ControllerT s m ())
-> ControllerT s m a -> Bool -> ControllerT s m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> ControllerT s m a -> ControllerT s m ()
forall (m :: * -> *) s a.
Monad m =>
Bool -> ControllerT s m a -> ControllerT s m ()
guard ControllerT s m a
c
guardReq :: Monad m
=> (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq :: (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq f :: Request -> Bool
f = ControllerT s m Bool -> ControllerT s m a -> ControllerT s m ()
forall (m :: * -> *) s a.
Monad m =>
ControllerT s m Bool -> ControllerT s m a -> ControllerT s m ()
guardM ((Request -> Bool)
-> ControllerT s m Request -> ControllerT s m Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Bool
f ControllerT s m Request
forall (m :: * -> *) s. Monad m => ControllerT s m Request
request)
data ControllerException = ControllerException String
deriving (Typeable)
instance Show ControllerException where
show :: ControllerException -> String
show (ControllerException msg :: String
msg) = "ControllerT: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
instance Exception ControllerException
err :: String -> ControllerT s m a
err :: String -> ControllerT s m a
err = ControllerException -> ControllerT s m a
forall a e. Exception e => e -> a
throw (ControllerException -> ControllerT s m a)
-> (String -> ControllerException) -> String -> ControllerT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ControllerException
ControllerException