149 lines
4.7 KiB
Haskell
149 lines
4.7 KiB
Haskell
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
---------------------------------------------------------
|
|
--
|
|
-- Module : Yesod.Request
|
|
-- Copyright : Michael Snoyman
|
|
-- License : BSD3
|
|
--
|
|
-- Maintainer : Michael Snoyman <michael@snoyman.com>
|
|
-- Stability : Stable
|
|
-- Portability : portable
|
|
--
|
|
-- Code for extracting parameters from requests.
|
|
--
|
|
---------------------------------------------------------
|
|
module Yesod.Request
|
|
(
|
|
-- * RawRequest
|
|
RawRequest (..)
|
|
, RequestReader (..)
|
|
, parseEnv
|
|
, cookies
|
|
, getParams
|
|
, postParams
|
|
, languages
|
|
, parseWaiRequest
|
|
-- * Parameter
|
|
, ParamType (..)
|
|
, ParamName
|
|
, ParamValue
|
|
, ParamException
|
|
#if TEST
|
|
, testSuite
|
|
#endif
|
|
) where
|
|
|
|
import qualified Network.Wai as W
|
|
import qualified Network.Wai.Enumerator as WE
|
|
import Data.Function.Predicate (equals)
|
|
import Yesod.Definitions
|
|
import Web.Encodings
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import Data.Convertible.Text
|
|
import Control.Arrow ((***))
|
|
import Control.Exception (SomeException (..))
|
|
import Data.Maybe (fromMaybe)
|
|
import "transformers" Control.Monad.Trans
|
|
import Control.Concurrent.MVar
|
|
|
|
#if TEST
|
|
import Test.Framework (testGroup, Test)
|
|
--import Test.Framework.Providers.HUnit
|
|
--import Test.HUnit hiding (Test)
|
|
#endif
|
|
|
|
data ParamType = GetParam | PostParam
|
|
type ParamName = String
|
|
type ParamValue = String
|
|
type ParamException = [((ParamType, ParamName, [ParamValue]), SomeException)]
|
|
|
|
class RequestReader m where
|
|
getRawRequest :: m RawRequest
|
|
invalidParams :: ParamException -> m a
|
|
|
|
languages :: (Functor m, RequestReader m) => m [Language]
|
|
languages = rawLangs `fmap` getRawRequest
|
|
|
|
-- | Get the raw 'W.Env' value.
|
|
parseEnv :: (Functor m, RequestReader m) => m W.Request
|
|
parseEnv = rawRequest `fmap` getRawRequest
|
|
|
|
type RequestBodyContents =
|
|
( [(ParamName, ParamValue)]
|
|
, [(ParamName, FileInfo String BL.ByteString)]
|
|
)
|
|
|
|
-- | The raw information passed through W, cleaned up a bit.
|
|
data RawRequest = RawRequest
|
|
{ rawGetParams :: [(ParamName, ParamValue)]
|
|
, rawCookies :: [(ParamName, ParamValue)]
|
|
, rawSession :: [(B.ByteString, B.ByteString)]
|
|
, rawRequestBody :: IO RequestBodyContents
|
|
, rawRequest :: W.Request
|
|
, rawLangs :: [Language]
|
|
}
|
|
|
|
multiLookup :: [(ParamName, ParamValue)] -> ParamName -> [ParamValue]
|
|
multiLookup [] _ = []
|
|
multiLookup ((k, v):rest) pn
|
|
| k == pn = v : multiLookup rest pn
|
|
| otherwise = multiLookup rest pn
|
|
|
|
-- | All GET paramater values with the given name.
|
|
getParams :: RawRequest -> ParamName -> [ParamValue]
|
|
getParams rr = multiLookup $ rawGetParams rr
|
|
|
|
-- | All POST paramater values with the given name.
|
|
postParams :: MonadIO m => RawRequest -> m (ParamName -> [ParamValue])
|
|
postParams rr = do
|
|
(pp, _) <- liftIO $ rawRequestBody rr
|
|
return $ multiLookup pp
|
|
|
|
-- | All cookies with the given name.
|
|
cookies :: RawRequest -> ParamName -> [ParamValue]
|
|
cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr
|
|
|
|
parseWaiRequest :: W.Request -> [(B.ByteString, B.ByteString)] -> IO RawRequest
|
|
parseWaiRequest env session = do
|
|
let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env
|
|
let rawCookie = fromMaybe B.empty $ lookup W.Cookie $ W.httpHeaders env
|
|
cookies' = map (cs *** cs) $ parseCookies rawCookie
|
|
acceptLang = lookup W.AcceptLanguage $ W.httpHeaders env
|
|
langs = map cs $ maybe [] parseHttpAccept acceptLang
|
|
langs' = case lookup langKey cookies' of
|
|
Nothing -> langs
|
|
Just x -> x : langs
|
|
langs'' = case lookup langKey gets' of
|
|
Nothing -> langs'
|
|
Just x -> x : langs'
|
|
mrb <- newMVar $ Left env
|
|
return $ RawRequest gets' cookies' session (rbHelper mrb) env langs''
|
|
|
|
rbHelper :: MVar (Either W.Request RequestBodyContents)
|
|
-> IO RequestBodyContents
|
|
rbHelper mvar = modifyMVar mvar helper where
|
|
helper (Right bc) = return (Right bc, bc)
|
|
helper (Left env) = do
|
|
inputLBS <- WE.toLBS $ W.requestBody env -- FIXME
|
|
let clength = maybe "0" cs $ lookup W.ReqContentLength
|
|
$ W.httpHeaders env
|
|
let ctype = maybe "" cs $ lookup W.ReqContentType $ W.httpHeaders env
|
|
let convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c
|
|
let ret = map (cs *** cs) ***
|
|
map (cs *** convertFileInfo)
|
|
$ parsePost ctype clength inputLBS
|
|
return (Right ret, ret)
|
|
|
|
#if TEST
|
|
testSuite :: Test
|
|
testSuite = testGroup "Yesod.Request"
|
|
[
|
|
]
|
|
#endif
|