WaiParameters.hs

module CQRSExample.WaiParameters
       ( runParameters
       , lookGUID
       , requireBool
       , requireDay
       , requireDuration
       , requireGUID
       , requireText
       ) where

import           Control.Applicative ((<*>))
import           Control.Monad (liftM)
import           Control.Monad.Trans.Resource (ResourceT)
import           Control.Monad.Trans.Reader (ask, ReaderT, runReaderT)
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import           Data.Conduit (($$))
import           Data.CQRS
import           Data.CQRS.GUID (hexDecode)
import           Data.Text (Text)
import qualified Data.Text.Encoding as TE
import           Data.Time (Day)
import           Data.Time.Format (parseTime)
import           Network.HTTP.Types (Query)
import           Network.Wai (Application, Request, Response, queryString, requestBody)
import           Network.Wai.Parse (lbsSink, parseRequestBody, Param)
import           Prelude hiding (mapM)
import           System.Locale (defaultTimeLocale)

import           CQRSExample.Duration (Duration)
import qualified CQRSExample.Duration as D

-- Type of the monad.
type ParametersT = ReaderT ([Param], Query)

runParameters :: ParametersT (ResourceT IO) Response -> Application
runParameters r req = do
  -- TODO: Impose a max body length.
  (params, _) <- requestBody req $$ parseRequestBody lbsSink req
  runReaderT r (params, queryString req)

look :: Monad m => ByteString -> ParametersT m (Maybe ByteString)
look n = do
  (ps, qs) <- ask
  let mq = lookup n qs
  let mp = lookup n ps
  return $ maybe mp id mq

required :: Monad m => ByteString -> ParametersT m (Maybe a) -> ParametersT m a
required n = flip (>>=) require
  where
    require (Just a) = return a
    require Nothing = fail $ "Missing/invalid parameter '" ++ (B8.unpack n) ++ "'"

lookText :: Monad m => ByteString -> ParametersT m (Maybe Text)
lookText n = liftM (maybe Nothing decode) $ look n
  where decode = either (const Nothing) Just . TE.decodeUtf8'

requireText :: Monad m => ByteString -> ParametersT m Text
requireText = required <*> lookText

lookGUID :: Monad m => ByteString -> ParametersT m (Maybe GUID)
lookGUID n = liftM (maybe Nothing hexDecode) $ look n

requireGUID :: Monad m => ByteString -> ParametersT m GUID
requireGUID = required <*> lookGUID

lookInteger :: Monad m => ByteString -> ParametersT m (Maybe Integer)
lookInteger n = liftM (maybe Nothing (f . B8.readInteger)) $ look n
  where
    f (Just (x, "")) = Just x
    f _ = Nothing

requiredInteger :: Monad m => ByteString -> ParametersT m Integer
requiredInteger = required <*> lookInteger

requireDuration :: Monad m => ByteString -> ParametersT m Duration
requireDuration n = liftM D.minutes $ requiredInteger n

lookDay :: Monad m => ByteString -> ParametersT m (Maybe Day)
lookDay n = liftM (maybe Nothing parseDay) $ look n
  where parseDay = parseTime defaultTimeLocale "%F" . B8.unpack

requireDay :: Monad m => ByteString -> ParametersT m Day
requireDay = required <*> lookDay

lookBool :: Monad m => ByteString -> ParametersT m (Maybe Bool)
lookBool n = liftM f $ look n
  where
    f (Just "true") = Just True
    f (Just "false") = Just False
    f _ = Nothing

requireBool :: Monad m => ByteString -> ParametersT m Bool
requireBool = required <*> lookBool