{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

{- | 'ControllerT' provides a convenient syntax for writting 'Application'
  code as a Monadic action with access to an HTTP request as well as app
  specific data (e.g. a database connection pool, app configuration etc.)
  This module also defines some
  helper functions that leverage this feature. For example, 'redirectBack'
  reads the underlying request to extract the referer and returns a redirect
  response:

  @
    myControllerT = do
      ...
      if badLogin then
        redirectBack
        else
          ...
  @
-}
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

-- | The ControllerT Monad is both a State-like monad which, when run, computes
-- either a 'Response' or a result. Within the ControllerT Monad, the remainder
-- of the computation can be short-circuited by 'respond'ing with a 'Response'.
newtype ControllerT s m a = ControllerT
  { forall s (m :: * -> *) a.
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 :: forall a b. (a -> b) -> ControllerT s m a -> ControllerT s m b
fmap a -> b
f (ControllerT s -> Request -> m (Either Response a, s)
act) = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
st0 Request
req ->
    (Either Response a, s) -> (Either Response b, s)
go 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 (Either Response a
eaf, s
st) = case Either Response a
eaf of
                              Left Response
resp -> (forall a b. a -> Either a b
Left Response
resp, s
st)
                              Right a
result -> (forall a b. b -> Either a b
Right 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 :: forall a. a -> ControllerT s m a
pure a
a = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
st Request
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a b. b -> Either a b
Right a
a, s
st)
  <*> :: forall a 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 :: forall a. a -> ControllerT s m a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (ControllerT s -> Request -> m (Either Response a, s)
act) >>= :: forall a b.
ControllerT s m a -> (a -> ControllerT s m b) -> ControllerT s m b
>>= a -> ControllerT s m b
fn = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
st0 Request
req -> do
    (Either Response a
eres, s
st) <- s -> Request -> m (Either Response a, s)
act s
st0 Request
req
    case Either Response a
eres of
      Left Response
resp -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left Response
resp, s
st)
      Right a
result -> do
        let (ControllerT 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 :: forall a. ControllerT s m a
empty = forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond Response
notFound
  <|> :: forall 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 :: forall a. ControllerT s m a
mzero = forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond Response
notFound
  mplus :: forall a.
ControllerT s m a -> ControllerT s m a -> ControllerT s m a
mplus = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)

instance MonadTrans (ControllerT s) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> ControllerT s m a
lift m a
act = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
st Request
_ -> m a
act forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
s Request
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right s
s, s
s)
  put :: s -> ControllerT s m ()
put s
s = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
_ Request
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
st Request
req -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Request
req, s
st)
  local :: forall a.
(Request -> Request) -> ControllerT s m a -> ControllerT s m a
local Request -> Request
f (ControllerT s -> Request -> m (Either Response a, s)
act) = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
st 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 :: forall a. IO a -> ControllerT s m a
liftIO = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance Monad m => MonadFail (ControllerT s m) where
  fail :: forall a. String -> ControllerT s m a
fail = 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 :: forall α. m α -> ControllerT s m α
liftBase = 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 :: forall a.
(RunInBase (ControllerT s m) m -> m a) -> ControllerT s m a
liftBaseWith RunInBase (ControllerT s m) m -> m a
fn = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
st Request
req -> do
    a
res <- RunInBase (ControllerT s m) m -> m a
fn forall a b. (a -> b) -> a -> b
$ \ControllerT s m a
act -> 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
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
res, s
st)
  restoreM :: forall a. StM (ControllerT s m) a -> ControllerT s m a
restoreM (Either Response a
a, s
s) = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
_ Request
_ -> 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 :: forall (m :: * -> *) a s.
Monad m =>
Either Response a -> ControllerT s m a
hoistEither Either Response a
eith = forall s (m :: * -> *) a.
(s -> Request -> m (Either Response a, s)) -> ControllerT s m a
ControllerT forall a b. (a -> b) -> a -> b
$ \s
st Request
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Either Response a
eith, s
st)

-- | Extract the request
request :: Monad m => ControllerT s m Request
request :: forall (m :: * -> *) s. Monad m => ControllerT s m Request
request = forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Modify the request for the given computation
localRequest :: Monad m
             => (Request -> Request) -> ControllerT s m a -> ControllerT s m a
localRequest :: forall (m :: * -> *) s a.
Monad m =>
(Request -> Request) -> ControllerT s m a -> ControllerT s m a
localRequest = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local

-- | Extract the application-specific state
controllerState :: Monad m => ControllerT s m s
controllerState :: forall (m :: * -> *) s. Monad m => ControllerT s m s
controllerState = forall s (m :: * -> *). MonadState s m => m s
get

putState :: Monad m => s -> ControllerT s m ()
putState :: forall (m :: * -> *) s. Monad m => s -> ControllerT s m ()
putState = forall s (m :: * -> *). MonadState s m => s -> m ()
put

-- | Convert the controller into an 'Application'
controllerApp :: Monad m => s -> ControllerT s m a -> SimpleApplication m
controllerApp :: forall (m :: * -> *) s a.
Monad m =>
s -> ControllerT s m a -> SimpleApplication m
controllerApp s
s ControllerT s m a
ctrl Request
req =
  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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Response
notFound) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst

-- | Provide a response
--
-- @respond r >>= f === respond r@
respond :: Monad m => Response -> ControllerT s m a
respond :: forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond Response
resp = forall (m :: * -> *) a s.
Monad m =>
Either Response a -> ControllerT s m a
hoistEither forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Response
resp


-- | Lift an application to a controller
fromApp :: Monad m => (Request -> m Response) -> ControllerT s m ()
fromApp :: forall (m :: * -> *) s.
Monad m =>
(Request -> m Response) -> ControllerT s m ()
fromApp Request -> m Response
app = do
  Request
req <- forall (m :: * -> *) s. Monad m => ControllerT s m Request
request
  Response
resp <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Request -> m Response
app Request
req
  forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond Response
resp

-- | Matches on the hostname from the 'Request'. The route only succeeds on
-- exact matches.
routeHost :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m ()
routeHost :: forall (m :: * -> *) s a.
Monad m =>
ByteString -> ControllerT s m a -> ControllerT s m ()
routeHost ByteString
host = forall (m :: * -> *) s a.
Monad m =>
(Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq forall a b. (a -> b) -> a -> b
$ \Request
req ->
  forall a. a -> Maybe a
Just ByteString
host forall a. Eq a => a -> a -> Bool
== Request -> Maybe ByteString
requestHeaderHost Request
req

-- | Matches if the path is empty.
--
-- Note that this route checks that 'pathInfo'
-- is empty, so it works as expected in nested contexts that have
-- popped components from the 'pathInfo' list.
routeTop :: Monad m => ControllerT s m a -> ControllerT s m ()
routeTop :: forall (m :: * -> *) s a.
Monad m =>
ControllerT s m a -> ControllerT s m ()
routeTop = forall (m :: * -> *) s a.
Monad m =>
(Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq forall a b. (a -> b) -> a -> b
$ \Request
req -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Request -> [Text]
pathInfo Request
req) Bool -> Bool -> Bool
||
                              (Text -> Int
T.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
req) forall a. Eq a => a -> a -> Bool
== Int
0

-- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')
routeMethod :: Monad m => StdMethod -> ControllerT s m a -> ControllerT s m ()
routeMethod :: forall (m :: * -> *) s a.
Monad m =>
StdMethod -> ControllerT s m a -> ControllerT s m ()
routeMethod StdMethod
method = forall (m :: * -> *) s a.
Monad m =>
(Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq forall a b. (a -> b) -> a -> b
$ (StdMethod -> ByteString
renderStdMethod StdMethod
method forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ByteString
requestMethod

-- | Matches if the request's Content-Type exactly matches the given string
routeAccept :: Monad m => S8.ByteString -> ControllerT s m a -> ControllerT s m ()
routeAccept :: forall (m :: * -> *) s a.
Monad m =>
ByteString -> ControllerT s m a -> ControllerT s m ()
routeAccept ByteString
contentType = forall (m :: * -> *) s a.
Monad m =>
(Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (HeaderName, ByteString) -> Bool
matching forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> RequestHeaders
requestHeaders)
 where matching :: (HeaderName, ByteString) -> Bool
matching (HeaderName, ByteString)
hdr = forall a b. (a, b) -> a
fst (HeaderName, ByteString)
hdr forall a. Eq a => a -> a -> Bool
== HeaderName
hAccept Bool -> Bool -> Bool
&& forall a b. (a, b) -> b
snd (HeaderName, ByteString)
hdr forall a. Eq a => a -> a -> Bool
== ByteString
contentType

-- | Routes the given URL pattern. Patterns can include
-- directories as well as variable patterns (prefixed with @:@) to be added
-- to 'queryString' (see 'routeVar')
--
--  * \/posts\/:id
--
--  * \/posts\/:id\/new
--
--  * \/:date\/posts\/:category\/new
--
routePattern :: Monad m
             => Text -> ControllerT s m a -> ControllerT s m ()
routePattern :: forall (m :: * -> *) s a.
Monad m =>
Text -> ControllerT s m a -> ControllerT s m ()
routePattern Text
pattern ControllerT s m a
route =
  let patternParts :: [Text]
patternParts = ByteString -> [Text]
decodePathSegments (Text -> ByteString
T.encodeUtf8 Text
pattern)
  in forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (m :: * -> *) s a.
Monad m =>
Text -> ControllerT s m a -> ControllerT s m ()
mkRoute (ControllerT s m a
route forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()) [Text]
patternParts
  where mkRoute :: Text -> ControllerT s m a -> ControllerT s m ()
mkRoute Text
name = case Text -> Maybe (Char, Text)
T.uncons Text
name of
                            Just (Char
':', Text
varName) -> forall (m :: * -> *) s a.
Monad m =>
Text -> ControllerT s m a -> ControllerT s m ()
routeVar Text
varName
                            Maybe (Char, Text)
_ -> forall (m :: * -> *) s a.
Monad m =>
Text -> ControllerT s m a -> ControllerT s m ()
routeName Text
name

-- | Matches if the first directory in the path matches the given 'ByteString'
routeName :: Monad m => Text -> ControllerT s m a -> ControllerT s m ()
routeName :: forall (m :: * -> *) s a.
Monad m =>
Text -> ControllerT s m a -> ControllerT s m ()
routeName Text
name ControllerT s m a
next = do
  Request
req <- forall (m :: * -> *) s. Monad m => ControllerT s m Request
request
  if (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
req) forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Text
name forall a. Eq a => a -> a -> Bool
== (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo) Request
req
    then 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where popHdr :: Request -> Request
popHdr Request
req = Request
req { pathInfo :: [Text]
pathInfo = (forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo forall a b. (a -> b) -> a -> b
$ Request
req) }

-- | Always matches if there is at least one directory in 'pathInfo' but and
-- adds a parameter to 'queryString' where the key is the first parameter and
-- the value is the directory consumed from the path.
routeVar :: Monad m => Text -> ControllerT s m a -> ControllerT s m ()
routeVar :: forall (m :: * -> *) s a.
Monad m =>
Text -> ControllerT s m a -> ControllerT s m ()
routeVar Text
varName ControllerT s m a
next = do
  Request
req <- forall (m :: * -> *) s. Monad m => ControllerT s m Request
request
  case Request -> [Text]
pathInfo Request
req of
    [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Text
x:[Text]
_ | Text -> Bool
T.null Text
x -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise -> 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where popHdr :: Request -> Request
popHdr Request
req = Request
req {
              pathInfo :: [Text]
pathInfo = (forall a. [a] -> [a]
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo forall a b. (a -> b) -> a -> b
$ Request
req)
            , queryString :: Query
queryString = (Text -> ByteString
T.encodeUtf8 Text
varName, forall a. a -> Maybe a
Just (Request -> ByteString
varVal Request
req))forall a. a -> [a] -> [a]
:(Request -> Query
queryString Request
req)}
        varVal :: Request -> ByteString
varVal Request
req = Text -> ByteString
T.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Text]
pathInfo forall a b. (a -> b) -> a -> b
$ Request
req

--
-- query parameters
--

-- | Looks up the parameter name in the request's query string and returns the
-- @Parseable@ value or 'Nothing'.
--
-- For example, for a request with query string: \"?foo=bar&baz=7\",
-- @queryParam \"foo\"@
-- would return @Just "bar"@, but
-- @queryParam \"zap\"@
-- would return @Nothing@.
queryParam :: (Monad m, Parseable a)
           => S8.ByteString -- ^ Parameter name
           -> ControllerT s m (Maybe a)
queryParam :: forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m (Maybe a)
queryParam ByteString
varName = do
  Query
qr <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Query
queryString forall (m :: * -> *) s. Monad m => ControllerT s m Request
request
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
varName Query
qr of
    Just Maybe ByteString
p -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Parseable a => ByteString -> a
parse forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe ByteString
S.empty Maybe ByteString
p
    Maybe (Maybe ByteString)
_ -> forall a. Maybe a
Nothing

-- | Like 'queryParam', but throws an exception if the parameter is not present.
queryParam' :: (Monad m, Parseable a)
            => S.ByteString -> ControllerT s m a
queryParam' :: forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m a
queryParam' ByteString
varName =
  forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m (Maybe a)
queryParam ByteString
varName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall s (m :: * -> *) a. String -> ControllerT s m a
err forall a b. (a -> b) -> a -> b
$ String
"no parameter " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
varName) forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Selects all values with the given parameter name
queryParams :: (Monad m, Parseable a)
            => S.ByteString -> ControllerT s m [a]
queryParams :: forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m [a]
queryParams ByteString
varName = forall (m :: * -> *) s. Monad m => ControllerT s m Request
request forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                  forall a b. (a -> b) -> [a] -> [b]
map (forall a. Parseable a => ByteString -> a
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe ByteString
S.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                  forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== ByteString
varName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                  Request -> Query
queryString

-- | The class of types into which query parameters may be converted
class Parseable a where
  parse :: S8.ByteString -> a

instance Parseable S8.ByteString where
  parse :: ByteString -> ByteString
parse = 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

-- | Like 'queryParam', but further processes the parameter value with @read@.
-- If that conversion fails, an exception is thrown.
readQueryParam :: (Monad m, Read a)
               => S8.ByteString -- ^ Parameter name
               -> ControllerT s m (Maybe a)
readQueryParam :: forall (m :: * -> *) a s.
(Monad m, Read a) =>
ByteString -> ControllerT s m (Maybe a)
readQueryParam ByteString
varName =
  forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m (Maybe a)
queryParam ByteString
varName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a s.
(Monad m, Read a) =>
ByteString -> Text -> ControllerT s m a
readParamValue ByteString
varName)

-- | Like 'readQueryParam', but throws an exception if the parameter is not present.
readQueryParam' :: (Monad m, Read a)
                => S8.ByteString -- ^ Parameter name
                -> ControllerT s m a
readQueryParam' :: forall (m :: * -> *) a s.
(Monad m, Read a) =>
ByteString -> ControllerT s m a
readQueryParam' ByteString
varName =
  forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m a
queryParam' ByteString
varName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a s.
(Monad m, Read a) =>
ByteString -> Text -> ControllerT s m a
readParamValue ByteString
varName

-- | Like 'queryParams', but further processes the parameter values with @read@.
-- If any read-conversion fails, an exception is thrown.
readQueryParams :: (Monad m, Read a)
                => S8.ByteString -- ^ Parameter name
                -> ControllerT s m [a]
readQueryParams :: forall (m :: * -> *) a s.
(Monad m, Read a) =>
ByteString -> ControllerT s m [a]
readQueryParams ByteString
varName =
  forall (m :: * -> *) a s.
(Monad m, Parseable a) =>
ByteString -> ControllerT s m [a]
queryParams ByteString
varName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 :: forall (m :: * -> *) a s.
(Monad m, Read a) =>
ByteString -> Text -> ControllerT s m a
readParamValue ByteString
varName =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall s (m :: * -> *) a. String -> ControllerT s m a
err forall a b. (a -> b) -> a -> b
$ String
"cannot read parameter: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
varName) forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall {a}. Read a => String -> Maybe a
readMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
  where readMay :: String -> Maybe a
readMay String
s = case [a
x | (a
x,String
rst) <- forall a. Read a => ReadS a
reads String
s, (String
"", String
"") <- ReadS String
lex String
rst] of
                      [a
x] -> forall a. a -> Maybe a
Just a
x
                      [a]
_ -> forall a. Maybe a
Nothing

-- | Returns the value of the given request header or 'Nothing' if it is not
-- present in the HTTP request.
requestHeader :: Monad m => HeaderName -> ControllerT s m (Maybe S8.ByteString)
requestHeader :: forall (m :: * -> *) s.
Monad m =>
HeaderName -> ControllerT s m (Maybe ByteString)
requestHeader HeaderName
name = forall (m :: * -> *) s. Monad m => ControllerT s m Request
request forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> RequestHeaders
requestHeaders

-- | Redirect back to the referer. If the referer header is not present
-- redirect to root (i.e., @\/@).
redirectBack :: Monad m => ControllerT s m ()
redirectBack :: forall (m :: * -> *) s. Monad m => ControllerT s m ()
redirectBack = forall (m :: * -> *) s. Monad m => Response -> ControllerT s m ()
redirectBackOr (ByteString -> Response
redirectTo ByteString
"/")

-- | Redirect back to the referer. If the referer header is not present
-- fallback on the given 'Response'.
redirectBackOr :: Monad m
               => Response -- ^ Fallback response
               -> ControllerT s m ()
redirectBackOr :: forall (m :: * -> *) s. Monad m => Response -> ControllerT s m ()
redirectBackOr Response
def = do
  Maybe ByteString
mrefr <- forall (m :: * -> *) s.
Monad m =>
HeaderName -> ControllerT s m (Maybe ByteString)
requestHeader HeaderName
"referer"
  case Maybe ByteString
mrefr of
    Just ByteString
refr -> forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond forall a b. (a -> b) -> a -> b
$ ByteString -> Response
redirectTo ByteString
refr
    Maybe ByteString
Nothing   -> forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
respond Response
def

-- | Like 'Application', but with 'm' as the underlying monad
type SimpleApplication m = Request -> m Response

-- | Like 'Application', but with 'm' as the underlying monad
type SimpleMiddleware m = SimpleApplication m -> SimpleApplication m

-- guard

guard :: Monad m => Bool -> ControllerT s m a -> ControllerT s m ()
guard :: forall (m :: * -> *) s a.
Monad m =>
Bool -> ControllerT s m a -> ControllerT s m ()
guard Bool
b ControllerT s m a
c = if Bool
b then ControllerT s m a
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return () else forall (m :: * -> *) a. Monad m => a -> m a
return ()

guardM :: Monad m
       => ControllerT s m Bool -> ControllerT s m a -> ControllerT s m ()
guardM :: forall (m :: * -> *) s a.
Monad m =>
ControllerT s m Bool -> ControllerT s m a -> ControllerT s m ()
guardM ControllerT s m Bool
b ControllerT s m a
c = ControllerT s m Bool
b forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 :: forall (m :: * -> *) s a.
Monad m =>
(Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq Request -> Bool
f = forall (m :: * -> *) s a.
Monad m =>
ControllerT s m Bool -> ControllerT s m a -> ControllerT s m ()
guardM (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Request -> Bool
f 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 String
msg) = String
"ControllerT: " forall a. [a] -> [a] -> [a]
++ String
msg

instance Exception ControllerException

err :: String -> ControllerT s m a
err :: forall s (m :: * -> *) a. String -> ControllerT s m a
err = forall a e. Exception e => e -> a
throw forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ControllerException
ControllerException

{- $Example
 #example#

The most basic 'Routeable' types are 'Application' and 'Response'. Reaching
either of these types marks a termination in the routing lookup. This module
exposes a monadic type 'Route' which makes it easy to create routing logic
in a DSL-like fashion.

'Route's are concatenated using the '>>' operator (or using do-notation).
In the end, any 'Routeable', including a 'Route' is converted to an
'Application' and passed to the server using 'mkRoute':

@

  mainAction :: ControllerT () ()
  mainAction = ...

  signinForm :: ControllerT () ()
  signinForm req = ...

  login :: ControllerT () ()
  login = ...

  updateProfile :: ControllerT () ()
  updateProfile = ...

  main :: IO ()
  main = run 3000 $ controllerApp () $ do
    routeTop mainAction
    routeName \"sessions\" $ do
      routeMethod GET signinForm
      routeMethod POST login
    routeMethod PUT $ routePattern \"users/:id\" updateProfile
    routeAll $ responseLBS status404 [] \"Are you in the right place?\"
@

-}