module Happstack.Server.RqData
(
look
, looks
, lookText
, lookTexts
, lookBS
, lookBSs
, lookRead
, lookReads
, lookFile
, lookPairs
, lookPairsBS
, lookCookie
, lookCookieValue
, readCookieValue
, lookInput
, lookInputs
, body
, queryString
, checkRq
, checkRqM
, readRq
, unsafeReadRq
, 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.Char8 as P
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), FilterMonad, WebMonad, ServerPartT, escape)
import Happstack.Server.Internal.RFC822Headers (parseContentType)
import Happstack.Server.Types (ContentType(..), FromReqURI(..), Input(inputValue, inputFilename, inputContentType), Response, Request(rqInputsQuery, rqInputsBody, rqCookies, rqMethod), Method(POST,PUT), getHeader, readInputsBody)
import Happstack.Server.Internal.MessageWrap (BodyPolicy(..), bodyInput, defaultBodyPolicy)
import Happstack.Server.Response (internalServerError, requestEntityTooLarge, toResponse)
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)], Maybe [(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)) && (isDecodable (ctype rq))
then readInputsBody rq
else return (Just [])
return (rqInputsQuery rq, mbi, rqCookies rq)
where
ctype :: Request -> Maybe ContentType
ctype req = parseContentType . P.unpack =<< getHeader "content-type" req
isDecodable :: Maybe ContentType -> Bool
isDecodable Nothing = True
isDecodable (Just (ContentType "application" "x-www-form-urlencoded" _)) = True
isDecodable (Just (ContentType "multipart" "form-data" ps)) = True
isDecodable (Just _) = False
rqDataError e = mzero
localRqEnv f m =
do rq <- askRq
b <- liftIO $ readInputsBody rq
let (q', b', c') = f (rqInputsQuery rq, b, rqCookies rq)
bv <- liftIO $ newMVar (fromMaybe [] 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))
unsafeReadRq :: (Read a) =>
String
-> String
-> Either String a
unsafeReadRq key val =
case reads val of
[(a,[])] -> Right a
_ -> Left $ "readRq failed while parsing key: " ++ key ++ " which has the value: " ++ val
readRq :: (FromReqURI a) =>
String
-> String
-> Either String a
readRq key val =
case fromReqURI val of
(Just 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)
fromMaybeBody :: String -> String -> Maybe [(String, Input)] -> [(String, Input)]
fromMaybeBody funName fieldName mBody =
case mBody of
Nothing -> error $ funName ++ " " ++ fieldName ++ " failed because the request body has not been decoded yet. Try using 'decodeBody' to decode the body. Or the 'queryString' filter to ignore the body."
(Just body) -> body
lookInput :: (Monad m, HasRqData m) => String -> m Input
lookInput name
= do (query, mBody, _cookies) <- askRqEnv
let body = fromMaybeBody "lookInput" name mBody
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, mBody, _cookies) <- askRqEnv
let body = fromMaybeBody "lookInputs" name mBody
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, FromReqURI a) => String -> m a
readCookieValue name = fmap cookieValue (lookCookie name) `checkRq` (readRq name)
lookRead :: (Functor m, Monad m, HasRqData m, FromReqURI a) => String -> m a
lookRead name = look name `checkRq` (readRq name)
lookReads :: (Functor m, Monad m, HasRqData m, FromReqURI 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, mBody, _cookies) <- askRqEnv
let body = fromMaybeBody "lookPairs" "" mBody
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, mBody, _cookies) <- askRqEnv
let body = fromMaybeBody "lookPairsBS" "" mBody
return $ map (\(n,vbs) -> (n, inputValue vbs)) (query ++ body)
decodeBody :: (ServerMonad m, MonadPlus m, MonadIO m, FilterMonad Response m, WebMonad Response m) => BodyPolicy -> m ()
decodeBody bp =
do rq <- askRq
(_, me) <- bodyInput bp rq
case me of
Nothing -> return ()
Just e -> escape $ requestEntityTooLarge (toResponse e)
getDataFn :: (HasRqData m, ServerMonad m) =>
RqData a
-> m (Either [String] a)
getDataFn rqData =
do rqEnv <- askRqEnv
return (runRqData rqData rqEnv)
withDataFn :: (HasRqData m, MonadPlus m, ServerMonad m) => RqData a -> (a -> m r) -> m r
withDataFn fn handle = getDataFn fn >>= either (const mzero) handle
getData :: (HasRqData m, ServerMonad m, FromData a) => m (Either [String] a)
getData = getDataFn fromData
withData :: (HasRqData 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, Just [], [])
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