module Happstack.Server.RqData
(
look
, looks
, lookBS
, lookBSs
, lookRead
, lookReads
, lookFile
, lookPairs
, lookPairsBS
, lookCookie
, lookCookieValue
, readCookieValue
, lookInput
, lookInputs
, body
, queryString
, checkRq
, checkRqM
, readRq
, decodeBody
, BodyPolicy(..)
, defaultBodyPolicy
, RqData
, mapRqData
, Errors(..)
, getDataFn
, withDataFn
, FromData(..)
, getData
, withData
, RqEnv
, HasRqData(askRqEnv, localRqEnv,rqDataError)
) where
import Control.Applicative (Applicative((<*>), pure), Alternative((<|>), empty), WrappedMonad(WrapMonad, unwrapMonad), (<$>))
import Control.Concurrent.MVar (newMVar)
import Control.Monad (MonadPlus(mzero), liftM)
import Control.Monad.Reader (ReaderT(ReaderT, runReaderT), MonadReader(ask, local), mapReaderT)
import Control.Monad.Error (Error(noMsg, strMsg))
import Control.Monad.Trans (MonadIO(..))
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as LU
import Data.Char (toLower)
import Data.Either (partitionEithers)
import Data.Generics (Data, Typeable)
import Data.Maybe (fromMaybe, fromJust)
import Data.Monoid (Monoid(mempty, mappend, mconcat))
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.Encoding as Text
import Happstack.Server.Cookie (Cookie (cookieValue))
import Happstack.Server.Internal.Monads (ServerMonad(askRq, localRq), ServerPartT)
import Happstack.Server.Types (ContentType(..), Input(inputValue, inputFilename, inputContentType), Request(rqInputsQuery, rqInputsBody, rqCookies, rqMethod), Method(POST,PUT), readInputsBody)
import Happstack.Server.Internal.MessageWrap (BodyPolicy(..), bodyInput, defaultBodyPolicy)
newtype ReaderError r e a = ReaderError { unReaderError :: ReaderT r (Either e) a }
deriving (Functor, Monad, MonadPlus)
instance (Error e) => MonadReader r (ReaderError r e) where
ask = ReaderError ask
local f m = ReaderError $ local f (unReaderError m)
instance (Monoid e, Error e) => Applicative (ReaderError r e) where
pure = return
(ReaderError (ReaderT f)) <*> (ReaderError (ReaderT a))
= ReaderError $ ReaderT $ \env -> (f env) `apEither` (a env)
instance (Monoid e, Error e) => Alternative (ReaderError r e) where
empty = unwrapMonad empty
f <|> g = unwrapMonad $ (WrapMonad f) <|> (WrapMonad g)
apEither :: (Monoid e) => Either e (a -> b) -> Either e a -> Either e b
apEither (Left errs1) (Left errs2) = Left (errs1 `mappend` errs2)
apEither (Left errs) _ = Left errs
apEither _ (Left errs) = Left errs
apEither (Right f) (Right a) = Right (f a)
newtype Errors a = Errors { unErrors :: [a] }
deriving (Eq, Ord, Show, Read, Data, Typeable)
instance Monoid (Errors a) where
mempty = Errors []
(Errors x) `mappend` (Errors y) = Errors (x ++ y)
mconcat errs = Errors $ concatMap unErrors errs
instance Error (Errors String) where
noMsg = Errors []
strMsg str = Errors [str]
mapReaderErrorT :: (Either e a -> Either e' b) -> (ReaderError r e a) -> (ReaderError r e' b)
mapReaderErrorT f m = ReaderError $ mapReaderT f (unReaderError m)
readerError :: (Monoid e, Error e) => e -> ReaderError r e b
readerError e = mapReaderErrorT ((Left e) `apEither`) (return ())
runReaderError :: ReaderError r e a -> r -> Either e a
runReaderError = runReaderT . unReaderError
type RqEnv = ([(String, Input)], [(String, Input)], [(String, Cookie)])
newtype RqData a = RqData { unRqData :: ReaderError RqEnv (Errors String) a }
deriving (Functor, Monad, MonadPlus, Applicative, Alternative, MonadReader RqEnv )
class HasRqData m where
askRqEnv :: m RqEnv
localRqEnv :: (RqEnv -> RqEnv) -> m a -> m a
rqDataError :: Errors String -> m a
instance HasRqData RqData where
askRqEnv = RqData ask
localRqEnv f (RqData re) = RqData $ local f re
rqDataError e = mapRqData ((Left e) `apEither`) (return ())
instance (MonadIO m) => HasRqData (ServerPartT m) where
askRqEnv =
do rq <- askRq
mbi <- liftIO $ if ((rqMethod rq) == POST) || ((rqMethod rq) == PUT)
then readInputsBody rq
else return (Just [])
case mbi of
Nothing -> fail "askRqEnv failed because the request body has not been decoded yet. Try using 'decodeBody'."
(Just bi) -> return (rqInputsQuery rq, bi, rqCookies rq)
rqDataError e = mzero
localRqEnv f m =
do rq <- askRq
b <- liftM (fromMaybe []) $ liftIO $ readInputsBody rq
let (q', b', c') = f (rqInputsQuery rq, b, rqCookies rq)
bv <- liftIO $ newMVar b'
let rq' = rq { rqInputsQuery = q'
, rqInputsBody = bv
, rqCookies = c'
}
localRq (const rq') m
runRqData :: RqData a -> RqEnv -> Either [String] a
runRqData rqData rqEnv =
either (Left . unErrors) Right $ runReaderError (unRqData rqData) rqEnv
mapRqData :: (Either (Errors String) a -> Either (Errors String) b) -> RqData a -> RqData b
mapRqData f m = RqData $ ReaderError $ mapReaderT f (unReaderError (unRqData m))
readRq :: (Read a) =>
String
-> String
-> Either String a
readRq key val =
case reads val of
[(a,[])] -> Right a
_ -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val
checkRq :: (Monad m, HasRqData m) => m a -> (a -> Either String b) -> m b
checkRq rq f =
do a <- rq
case f a of
(Left e) -> rqDataError (strMsg e)
(Right b) -> return b
checkRqM :: (Monad m, HasRqData m) => m a -> (a -> m (Either String b)) -> m b
checkRqM rq f =
do a <- rq
b <- f a
case b of
(Left e) -> rqDataError (strMsg e)
(Right b) -> return b
class FromData a where
fromData :: RqData a
instance (FromData a, FromData b) => FromData (a,b) where
fromData = (,) <$> fromData <*> fromData
instance (FromData a, FromData b, FromData c) => FromData (a,b,c) where
fromData = (,,) <$> fromData <*> fromData <*> fromData
instance (FromData a, FromData b, FromData c, FromData d) => FromData (a,b,c,d) where
fromData = (,,,) <$> fromData <*> fromData <*> fromData <*> fromData
instance FromData a => FromData (Maybe a) where
fromData = (Just <$> fromData) <|> (pure Nothing)
lookups :: (Eq a) => a -> [(a, b)] -> [b]
lookups a = map snd . filter ((a ==) . fst)
lookInput :: (Monad m, HasRqData m) => String -> m Input
lookInput name
= do (query, body, _cookies) <- askRqEnv
case lookup name (query ++ body) of
Just i -> return $ i
Nothing -> rqDataError (strMsg $ "Parameter not found: " ++ name)
lookInputs :: (Monad m, HasRqData m) => String -> m [Input]
lookInputs name
= do (query, body, _cookies) <- askRqEnv
return $ lookups name (query ++ body)
lookBS :: (Functor m, Monad m, HasRqData m) => String -> m L.ByteString
lookBS n =
do i <- fmap inputValue (lookInput n)
case i of
(Left fp) -> rqDataError $ (strMsg $ "lookBS: " ++ n ++ " is a file.")
(Right bs) -> return bs
lookBSs :: (Functor m, Monad m, HasRqData m) => String -> m [L.ByteString]
lookBSs n =
do is <- fmap (map inputValue) (lookInputs n)
case partitionEithers is of
([], bs) -> return bs
(fp, _) -> rqDataError (strMsg $ "lookBSs: " ++ n ++ " is a file.")
look :: (Functor m, Monad m, HasRqData m) => String -> m String
look = fmap LU.toString . lookBS
looks :: (Functor m, Monad m, HasRqData m) => String -> m [String]
looks = fmap (map LU.toString) . lookBSs
lookText :: (Functor m, Monad m, HasRqData m) => String -> m Text
lookText = fmap Text.decodeUtf8 . lookBS
lookTexts :: (Functor m, Monad m, HasRqData m) => String -> m [Text]
lookTexts = fmap (map Text.decodeUtf8) . lookBSs
lookCookie :: (Monad m, HasRqData m) => String -> m Cookie
lookCookie name
= do (_query,_body, cookies) <- askRqEnv
case lookup (map toLower name) cookies of
Nothing -> rqDataError $ strMsg $ "lookCookie: cookie not found: " ++ name
Just c -> return c
lookCookieValue :: (Functor m, Monad m, HasRqData m) => String -> m String
lookCookieValue = fmap cookieValue . lookCookie
readCookieValue :: (Functor m, Monad m, HasRqData m, Read a) => String -> m a
readCookieValue name = fmap cookieValue (lookCookie name) `checkRq` (readRq name)
lookRead :: (Functor m, Monad m, HasRqData m, Read a) => String -> m a
lookRead name = look name `checkRq` (readRq name)
lookReads :: (Functor m, Monad m, HasRqData m, Read a) => String -> m [a]
lookReads name =
do vals <- looks name
mapM (\v -> (return v) `checkRq` (readRq name)) vals
lookFile :: (Monad m, HasRqData m) =>
String
-> m (FilePath, FilePath, ContentType)
lookFile n =
do i <- lookInput n
case inputValue i of
(Right _) -> rqDataError $ (strMsg $ "lookFile: " ++ n ++ " was found but is not a file.")
(Left fp) -> return (fp, fromJust $ inputFilename i, inputContentType i)
lookPairs :: (Monad m, HasRqData m) => m [(String, Either FilePath String)]
lookPairs =
do (query, body, _cookies) <- askRqEnv
return $ map (\(n,vbs)->(n, (\e -> case e of Left fp -> Left fp ; Right bs -> Right (LU.toString bs)) $ inputValue vbs)) (query ++ body)
lookPairsBS :: (Monad m, HasRqData m) => m [(String, Either FilePath L.ByteString)]
lookPairsBS =
do (query, body, _cookies) <- askRqEnv
return $ map (\(n,vbs) -> (n, inputValue vbs)) (query ++ body)
decodeBody :: (ServerMonad m, MonadPlus m, MonadIO m) => BodyPolicy -> m ()
decodeBody bp =
do rq <- askRq
(_, me) <- bodyInput bp rq
case me of
Nothing -> return ()
Just e -> fail e
getDataFn :: (HasRqData m, ServerMonad m, MonadIO m) =>
RqData a
-> m (Either [String] a)
getDataFn rqData =
do rqEnv <- askRqEnv
return (runRqData rqData rqEnv)
withDataFn :: (HasRqData m, MonadIO m, MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r
withDataFn fn handle = getDataFn fn >>= either (const mzero) handle
getData :: (HasRqData m, MonadIO m, ServerMonad m, FromData a) => m (Either [String] a)
getData = getDataFn fromData
withData :: (HasRqData m, MonadIO m, FromData a, MonadPlus m, ServerMonad m) => (a -> m r) -> m r
withData = withDataFn fromData
body :: (HasRqData m) => m a -> m a
body rqData = localRqEnv f rqData
where
f (_query, body, _cookies) = ([], body, [])
queryString :: (HasRqData m) => m a -> m a
queryString rqData = localRqEnv f rqData
where
f (query, _body, _cookies) = (query, [], [])
right :: (MonadPlus m) => Either a b -> m b
right (Right a) = return a
right (Left e) = mzero
bytestring :: (HasRqData m) => m a -> m a
bytestring rqData = localRqEnv f rqData
where
f (query, body, cookies) = (filter bsf query, filter bsf body, cookies)
bsf (_, i) =
case inputValue i of
(Left _fp) -> False
(Right _bs) -> True