Trans.hs

{-# 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
  { runController :: s -> Request ->
                      m (Either Response a, s) }

instance Functor m => Functor (ControllerT s m) where
  fmap f (ControllerT act) = ControllerT $ \st0 req ->
    go `fmap` act st0 req
    where go (eaf, st) = case eaf of
                              Left resp -> (Left resp, st)
                              Right result -> (Right $ f result, st)

instance (Monad m, Functor m) => Applicative (ControllerT s m) where
  pure = return
  (<*>) = ap

instance Monad m => Monad (ControllerT s m) where
  return a = ControllerT $ \st _ -> return $ (Right a, st)
  (ControllerT act) >>= fn = ControllerT $ \st0 req -> do
    (eres, st) <- act st0 req
    case eres of
      Left resp -> return (Left resp, st)
      Right result -> do
        let (ControllerT fres) = fn result
        fres st req

instance (Functor m, Monad m) => Alternative (ControllerT s m) where
  empty = respond notFound
  (<|>) = (>>)

instance Monad m => MonadPlus (ControllerT s m) where
  mzero = respond notFound
  mplus = flip (>>)

instance MonadTrans (ControllerT s) where
  lift act = ControllerT $ \st _ -> act >>= \r -> return (Right r, st)

instance Monad m => MonadState s (ControllerT s m) where
  get = ControllerT $ \s _ -> return (Right s, s)
  put s = ControllerT $ \_ _ -> return (Right (), s)

instance Monad m => MonadReader Request (ControllerT s m) where
  ask = ControllerT $ \st req -> return (Right req, st)
  local f (ControllerT act) = ControllerT $ \st req -> act st (f req)

instance MonadIO m => MonadIO (ControllerT s m) where
  liftIO = lift . liftIO

instance (Applicative m, Monad m, MonadBase m m) => MonadBase m (ControllerT s m) where
  liftBase = liftBaseDefault

instance MonadBaseControl m m => MonadBaseControl m (ControllerT s m) where
  type StM (ControllerT s m) a = (Either Response a, s)
  liftBaseWith fn = ControllerT $ \st req -> do
    res <- fn $ \act -> runController act st req
    return (Right res, st)
  restoreM (a, s) = ControllerT $ \_ _ -> return (a, s)

hoistEither :: Monad m => Either Response a -> ControllerT s m a
hoistEither eith = ControllerT $ \st _ -> return (eith, st)

-- | Extract the request
request :: Monad m => ControllerT s m Request
request = ask

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

-- | Extract the application-specific state
controllerState :: Monad m => ControllerT s m s
controllerState = get

putState :: Monad m => s -> ControllerT s m ()
putState = put

-- | Convert the controller into an 'Application'
controllerApp :: Monad m => s -> ControllerT s m a -> SimpleApplication m
controllerApp s ctrl req =
  runController ctrl s req >>=
    either return (const $ return notFound) . fst

-- | Provide a response
--
-- @respond r >>= f === respond r@
respond :: Monad m => Response -> ControllerT s m a
respond resp = hoistEither $ Left resp


-- | Lift an application to a controller
fromApp :: Monad m => (Request -> m Response) -> ControllerT s m ()
fromApp app = do
  req <- request
  resp <- lift $ app req
  respond 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 host = guardReq $ \req ->
  Just host == requestHeaderHost 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 = guardReq $ \req -> null (pathInfo req) ||
                              (T.length . head $ pathInfo req) == 0

-- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')
routeMethod :: Monad m => StdMethod -> ControllerT s m a -> ControllerT s m ()
routeMethod method = guardReq $ (renderStdMethod method ==) . 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 contentType = guardReq (isJust . find matching . requestHeaders)
 where matching hdr = fst hdr == hAccept && snd hdr == 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 pattern route =
  let patternParts = decodePathSegments (T.encodeUtf8 pattern)
  in foldr mkRoute (route >> return ()) patternParts
  where mkRoute name = case T.uncons name of
                            Just (':', varName) -> routeVar varName
                            _ -> routeName 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 name next = do
  req <- request
  if (length $ pathInfo req) > 0 && name == (head . pathInfo) req
    then localRequest popHdr next >> return ()
    else return ()
  where popHdr req = req { pathInfo = (tail . pathInfo $ 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 varName next = do
  req <- request
  case pathInfo req of
    [] -> return ()
    x:_ | T.null x -> return ()
        | otherwise -> localRequest popHdr next >> return ()
  where popHdr req = req {
              pathInfo = (tail . pathInfo $ req)
            , queryString = (T.encodeUtf8 varName, Just (varVal req)):(queryString req)}
        varVal req = T.encodeUtf8 . head . pathInfo $ 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 varName = do
  qr <- liftM queryString request
  return $ case lookup varName qr of
    Just p -> Just $ parse $ fromMaybe S.empty p
    _ -> 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' varName =
  queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return

-- | Selects all values with the given parameter name
queryParams :: (Monad m, Parseable a)
            => S.ByteString -> ControllerT s m [a]
queryParams varName = request >>= return .
                                  map (parse . fromMaybe S.empty . snd) .
                                  filter ((== varName) . fst) .
                                  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 = id
instance Parseable String where
  parse = S8.unpack
instance Parseable Text where
  parse = 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 varName =
  queryParam varName >>= maybe (return Nothing) (liftM Just . readParamValue 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' varName =
  queryParam' varName >>= readParamValue 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 varName =
  queryParams varName >>= mapM (readParamValue varName)

readParamValue :: (Monad m, Read a)
               => S8.ByteString -> Text -> ControllerT s m a
readParamValue varName =
  maybe (err $ "cannot read parameter: " ++ show varName) return .
    readMay . T.unpack
  where readMay s = case [x | (x,rst) <- reads s, ("", "") <- lex rst] of
                      [x] -> Just x
                      _ -> 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 name = request >>= return . lookup name . 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 = redirectBackOr (redirectTo "/")

-- | 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 def = do
  mrefr <- requestHeader "referer"
  case mrefr of
    Just refr -> respond $ redirectTo refr
    Nothing   -> respond 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 b c = if b then c >> return () else return ()

guardM :: Monad m
       => ControllerT s m Bool -> ControllerT s m a -> ControllerT s m ()
guardM b c = b >>= flip guard c

guardReq :: Monad m
         => (Request -> Bool) -> ControllerT s m a -> ControllerT s m ()
guardReq f = guardM (liftM f request)

data ControllerException = ControllerException String
  deriving (Typeable)

instance Show ControllerException where
  show (ControllerException msg) = "ControllerT: " ++ msg

instance Exception ControllerException

err :: String -> ControllerT s m a
err = throw . 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?\"
@

-}