{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-}-- | Functions for extracting values from the query string, form data, cookies, etc. ---- For in-depth documentation see the following section of the Happstack Crash Course:---- <http://happstack.com/docs/crashcourse/RqData.html>moduleHappstack.Server.RqData(-- * Looking up keys-- ** Form Values and Query Parameterslook,looks,lookText,lookTexts,lookBS,lookBSs,lookRead,lookReads,lookFile,lookPairs,lookPairsBS-- ** Cookies,lookCookie,lookCookieValue,readCookieValue-- ** low-level,lookInput,lookInputs-- * Filters-- The look* functions normally search the QUERY_STRING and the Request-- body for matches keys. ,body,queryString-- * Validation and Parsing,checkRq,checkRqM,readRq-- * Handling POST\/PUT Requests,decodeBody-- ** Body Policy,BodyPolicy(..),defaultBodyPolicy-- * RqData Monad & Error Reporting,RqData,mapRqData,Errors(..)-- ** Using RqData with ServerMonad,getDataFn,withDataFn,FromData(..),getData,withData-- * HasRqData class,RqEnv,HasRqData(askRqEnv,localRqEnv,rqDataError))whereimportControl.Applicative(Applicative((<*>),pure),Alternative((<|>),empty),WrappedMonad(WrapMonad,unwrapMonad),(<$>))importControl.Concurrent.MVar(newMVar)importControl.Monad(MonadPlus(mzero),liftM)importControl.Monad.Reader(ReaderT(ReaderT,runReaderT),MonadReader(ask,local),mapReaderT)importControl.Monad.Error(Error(noMsg,strMsg))importControl.Monad.Trans(MonadIO(..))importqualifiedData.ByteString.Lazy.Char8asLimportqualifiedData.ByteString.Lazy.UTF8asLUimportData.Char(toLower)importData.Either(partitionEithers)importData.Generics(Data,Typeable)importData.Maybe(fromMaybe,fromJust)importData.Monoid(Monoid(mempty,mappend,mconcat))importData.Text.Lazy(Text)importqualifiedData.Text.Lazy.EncodingasTextimportHappstack.Server.Cookie(Cookie(cookieValue))importHappstack.Server.Internal.Monads(ServerMonad(askRq,localRq),ServerPartT)importHappstack.Server.Types(ContentType(..),Input(inputValue,inputFilename,inputContentType),Request(rqInputsQuery,rqInputsBody,rqCookies,rqMethod),Method(POST,PUT),readInputsBody)importHappstack.Server.Internal.MessageWrap(BodyPolicy(..),bodyInput,defaultBodyPolicy)newtypeReaderErrorrea=ReaderError{unReaderError::ReaderTr(Eithere)a}deriving(Functor,Monad,MonadPlus)instance(Errore)=>MonadReaderr(ReaderErrorre)whereask=ReaderErrorasklocalfm=ReaderError$localf(unReaderErrorm)instance(Monoide,Errore)=>Applicative(ReaderErrorre)wherepure=return(ReaderError(ReaderTf))<*>(ReaderError(ReaderTa))=ReaderError$ReaderT$\env->(fenv)`apEither`(aenv)instance(Monoide,Errore)=>Alternative(ReaderErrorre)whereempty=unwrapMonademptyf<|>g=unwrapMonad$(WrapMonadf)<|>(WrapMonadg)apEither::(Monoide)=>Eithere(a->b)->Eitherea->EitherebapEither(Lefterrs1)(Lefterrs2)=Left(errs1`mappend`errs2)apEither(Lefterrs)_=LefterrsapEither_(Lefterrs)=LefterrsapEither(Rightf)(Righta)=Right(fa)-- | a list of errorsnewtypeErrorsa=Errors{unErrors::[a]}deriving(Eq,Ord,Show,Read,Data,Typeable)instanceMonoid(Errorsa)wheremempty=Errors[](Errorsx)`mappend`(Errorsy)=Errors(x++y)mconcaterrs=Errors$concatMapunErrorserrsinstanceError(ErrorsString)wherenoMsg=Errors[]strMsgstr=Errors[str]mapReaderErrorT::(Eitherea->Eithere'b)->(ReaderErrorrea)->(ReaderErrorre'b)mapReaderErrorTfm=ReaderError$mapReaderTf(unReaderErrorm)readerError::(Monoide,Errore)=>e->ReaderErrorrebreaderErrore=mapReaderErrorT((Lefte)`apEither`)(return())runReaderError::ReaderErrorrea->r->EitherearunReaderError=runReaderT.unReaderError-- | the environment used to lookup query parameters. It consists of-- the triple: (query string inputs, body inputs, cookie inputs)typeRqEnv=([(String,Input)],[(String,Input)],[(String,Cookie)])-- | An applicative functor and monad for looking up key/value pairs-- in the QUERY_STRING, Request body, and cookies.newtypeRqDataa=RqData{unRqData::ReaderErrorRqEnv(ErrorsString)a}deriving(Functor,Monad,MonadPlus,Applicative,Alternative,MonadReaderRqEnv)-- | A class for monads which contain a 'RqEnv'classHasRqDatamwhereaskRqEnv::mRqEnvlocalRqEnv::(RqEnv->RqEnv)->ma->ma-- | lift some 'Errors' into 'RqData'rqDataError::ErrorsString->mainstanceHasRqDataRqDatawhereaskRqEnv=RqDataasklocalRqEnvf(RqDatare)=RqData$localfrerqDataErrore=mapRqData((Lefte)`apEither`)(return())-- instance (MonadPlus m, MonadIO m, ServerMonad m) => (HasRqData m) whereinstance(MonadIOm)=>HasRqData(ServerPartTm)whereaskRqEnv=dorq<-askRqmbi<-liftIO$if((rqMethodrq)==POST)||((rqMethodrq)==PUT)thenreadInputsBodyrqelsereturn(Just[])casembiofNothing->fail"askRqEnv failed because the request body has not been decoded yet. Try using 'decodeBody'."(Justbi)->return(rqInputsQueryrq,bi,rqCookiesrq)rqDataErrore=mzerolocalRqEnvfm=dorq<-askRqb<-liftM(fromMaybe[])$liftIO$readInputsBodyrqlet(q',b',c')=f(rqInputsQueryrq,b,rqCookiesrq)bv<-liftIO$newMVarb'letrq'=rq{rqInputsQuery=q',rqInputsBody=bv,rqCookies=c'}localRq(constrq')m-- | apply 'RqData a' to a 'RqEnv'---- see also: 'getData', 'getDataFn', 'withData', 'withDataFn', 'RqData', 'getDataFn'runRqData::RqDataa->RqEnv->Either[String]arunRqDatarqDatarqEnv=either(Left.unErrors)Right$runReaderError(unRqDatarqData)rqEnv-- | transform the result of 'RqData a'.---- This is similar to 'fmap' except it also allows you to modify the-- 'Errors' not just 'a'.mapRqData::(Either(ErrorsString)a->Either(ErrorsString)b)->RqDataa->RqDatabmapRqDatafm=RqData$ReaderError$mapReaderTf(unReaderError(unRqDatam))-- | use 'read' to convert a 'String' to a value of type 'a'---- > look "key" `checkRq` (readRq "key")-- -- use with 'checkRq'readRq::(Reada)=>String-- ^ name of key (only used for error reporting)->String-- ^ 'String' to 'read'->EitherStringa-- ^ 'Left' on error, 'Right' on successreadRqkeyval=casereadsvalof[(a,[])]->Righta_->Left$"readRq failed while parsing key: "++key++" which has the value: "++val-- | convert or validate a value---- This is similar to 'fmap' except that the function can fail by-- returning Left and an error message. The error will be propagated-- by calling 'rqDataError'.---- This function is useful for a number of things including:-- -- (1) Parsing a 'String' into another type---- (2) Checking that a value meets some requirements (for example, that is an Int between 1 and 10).---- Example usage at:---- <http://happstack.com/docs/crashcourse/RqData.html#rqdatacheckrq>checkRq::(Monadm,HasRqDatam)=>ma->(a->EitherStringb)->mbcheckRqrqf=doa<-rqcasefaof(Lefte)->rqDataError(strMsge)(Rightb)->returnb-- | like 'checkRq' but the check function can be monadiccheckRqM::(Monadm,HasRqDatam)=>ma->(a->m(EitherStringb))->mbcheckRqMrqf=doa<-rqb<-facasebof(Lefte)->rqDataError(strMsge)(Rightb)->returnb-- | Used by 'withData' and 'getData'. Make your preferred data-- type an instance of 'FromData' to use those functions.classFromDataawherefromData::RqDataa{-
instance (Eq a,Show a,Xml a,G.Data a) => FromData a where
fromData = do mbA <- lookPairs >>= return . normalize . fromPairs
case mbA of
Just a -> return a
Nothing -> fail "FromData G.Data failure"
-- fromData = lookPairs >>= return . normalize . fromPairs
-}instance(FromDataa,FromDatab)=>FromData(a,b)wherefromData=(,)<$>fromData<*>fromDatainstance(FromDataa,FromDatab,FromDatac)=>FromData(a,b,c)wherefromData=(,,)<$>fromData<*>fromData<*>fromDatainstance(FromDataa,FromDatab,FromDatac,FromDatad)=>FromData(a,b,c,d)wherefromData=(,,,)<$>fromData<*>fromData<*>fromData<*>fromDatainstanceFromDataa=>FromData(Maybea)wherefromData=(Just<$>fromData)<|>(pureNothing)-- | similar to 'Data.List.lookup' but returns all matches not just the firstlookups::(Eqa)=>a->[(a,b)]->[b]lookupsa=mapsnd.filter((a==).fst)-- | Gets the first matching named input parameter-- -- Searches the QUERY_STRING followed by the Request body.---- see also: 'lookInputs'lookInput::(Monadm,HasRqDatam)=>String->mInputlookInputname=do(query,body,_cookies)<-askRqEnvcaselookupname(query++body)ofJusti->return$iNothing->rqDataError(strMsg$"Parameter not found: "++name)-- | Gets all matches for the named input parameter-- -- Searches the QUERY_STRING followed by the Request body.---- see also: 'lookInput'lookInputs::(Monadm,HasRqDatam)=>String->m[Input]lookInputsname=do(query,body,_cookies)<-askRqEnvreturn$lookupsname(query++body)-- | Gets the first matching named input parameter as a lazy 'ByteString'---- Searches the QUERY_STRING followed by the Request body.---- see also: 'lookBSs'lookBS::(Functorm,Monadm,HasRqDatam)=>String->mL.ByteStringlookBSn=doi<-fmapinputValue(lookInputn)caseiof(Leftfp)->rqDataError$(strMsg$"lookBS: "++n++" is a file.")(Rightbs)->returnbs-- | Gets all matches for the named input parameter as lazy 'ByteString's---- Searches the QUERY_STRING followed by the Request body.---- see also: 'lookBS'lookBSs::(Functorm,Monadm,HasRqDatam)=>String->m[L.ByteString]lookBSsn=dois<-fmap(mapinputValue)(lookInputsn)casepartitionEithersisof([],bs)->returnbs(fp,_)->rqDataError(strMsg$"lookBSs: "++n++" is a file.")-- | Gets the first matching named input parameter as a 'String'---- Searches the QUERY_STRING followed by the Request body.---- This function assumes the underlying octets are UTF-8 encoded.---- Example:---- > handler :: ServerPart Response-- > handler =-- > do foo <- look "foo"-- > ok $ toResponse $ "foo = " ++ foo---- see also: 'looks', 'lookBS', and 'lookBSs'look::(Functorm,Monadm,HasRqDatam)=>String->mStringlook=fmapLU.toString.lookBS-- | Gets all matches for the named input parameter as 'String's---- Searches the QUERY_STRING followed by the Request body.---- This function assumes the underlying octets are UTF-8 encoded.---- see also: 'look' and 'lookBSs'looks::(Functorm,Monadm,HasRqDatam)=>String->m[String]looks=fmap(mapLU.toString).lookBSs-- | Gets the first matching named input parameter as a lazy 'Text'---- Searches the QUERY_STRING followed by the Request body.---- This function assumes the underlying octets are UTF-8 encoded.---- see also: 'lookTexts', 'look', 'looks', 'lookBS', and 'lookBSs'lookText::(Functorm,Monadm,HasRqDatam)=>String->mTextlookText=fmapText.decodeUtf8.lookBS-- | Gets all matches for the named input parameter as lazy 'Text's---- Searches the QUERY_STRING followed by the Request body.---- This function assumes the underlying octets are UTF-8 encoded.---- see also: 'lookText', 'looks' and 'lookBSs'lookTexts::(Functorm,Monadm,HasRqDatam)=>String->m[Text]lookTexts=fmap(mapText.decodeUtf8).lookBSs-- | Gets the named cookie-- the cookie name is case insensitivelookCookie::(Monadm,HasRqDatam)=>String->mCookielookCookiename=do(_query,_body,cookies)<-askRqEnvcaselookup(maptoLowername)cookiesof-- keys are lowercasedNothing->rqDataError$strMsg$"lookCookie: cookie not found: "++nameJustc->returnc-- | gets the named cookie as a stringlookCookieValue::(Functorm,Monadm,HasRqDatam)=>String->mStringlookCookieValue=fmapcookieValue.lookCookie-- | gets the named cookie as the requested Read typereadCookieValue::(Functorm,Monadm,HasRqDatam,Reada)=>String->mareadCookieValuename=fmapcookieValue(lookCookiename)`checkRq`(readRqname)-- | Gets the first matching named input parameter and decodes it using 'Read'---- Searches the QUERY_STRING followed by the Request body.---- This function assumes the underlying octets are UTF-8 encoded.---- see also: 'lookReads'lookRead::(Functorm,Monadm,HasRqDatam,Reada)=>String->malookReadname=lookname`checkRq`(readRqname)-- | Gets all matches for the named input parameter and decodes them using 'Read'---- Searches the QUERY_STRING followed by the Request body.---- This function assumes the underlying octets are UTF-8 encoded.---- see also: 'lookReads'lookReads::(Functorm,Monadm,HasRqDatam,Reada)=>String->m[a]lookReadsname=dovals<-looksnamemapM(\v->(returnv)`checkRq`(readRqname))vals-- | Gets the first matching named file---- Files can only appear in the request body. Additionally, the form-- must set enctype=\"multipart\/form-data\".---- This function returns a tuple consisting of:-- -- (1) The temporary location of the uploaded file---- (2) The local filename supplied by the browser---- (3) The content-type supplied by the browser---- NOTE: You must move the file from the temporary location before the-- 'Response' is sent. The temporary files are automatically removed-- after the 'Response' is sent.lookFile::(Monadm,HasRqDatam)=>String-- ^ name of input field to search for->m(FilePath,FilePath,ContentType)-- ^ (temporary file location, uploaded file name, content-type)lookFilen=doi<-lookInputncaseinputValueiof(Right_)->rqDataError$(strMsg$"lookFile: "++n++" was found but is not a file.")(Leftfp)->return(fp,fromJust$inputFilenamei,inputContentTypei)-- | gets all the input parameters, and converts them to a 'String'---- The results will contain the QUERY_STRING followed by the Request-- body.---- This function assumes the underlying octets are UTF-8 encoded.---- see also: 'lookPairsBS'lookPairs::(Monadm,HasRqDatam)=>m[(String,EitherFilePathString)]lookPairs=do(query,body,_cookies)<-askRqEnvreturn$map(\(n,vbs)->(n,(\e->caseeofLeftfp->Leftfp;Rightbs->Right(LU.toStringbs))$inputValuevbs))(query++body)-- | gets all the input parameters---- The results will contain the QUERY_STRING followed by the Request-- body.---- see also: 'lookPairs'lookPairsBS::(Monadm,HasRqDatam)=>m[(String,EitherFilePathL.ByteString)]lookPairsBS=do(query,body,_cookies)<-askRqEnvreturn$map(\(n,vbs)->(n,inputValuevbs))(query++body)-- | The POST\/PUT body of a Request is not received or decoded unless-- this function is invoked. ---- It is an error to try to use the look functions for a POST\/PUT-- request with out first calling this function.---- It is ok to call 'decodeBody' at the beginning of every request:---- > main = simpleHTTP nullConf $ -- > do decodeBody (defaultBodyPolicy "/tmp/" 4096 4096 4096)-- > handlers---- You can achieve finer granularity quotas by calling 'decodeBody'-- with different values in different handlers.---- Only the first call to 'decodeBody' will have any effect. Calling-- it a second time, even with different quota values, will do-- nothing.decodeBody::(ServerMonadm,MonadPlusm,MonadIOm)=>BodyPolicy->m()decodeBodybp=dorq<-askRq(_,me)<-bodyInputbprqcasemeofNothing->return()Juste->faile-- FIXME: is this the best way to report the error-- | run 'RqData' in a 'ServerMonad'.---- Example: a simple @GET@ or @POST@ variable based authentication-- guard. It handles the request with 'errorHandler' if-- authentication fails.---- > data AuthCredentials = AuthCredentials { username :: String, password :: String }-- >-- > isValid :: AuthCredentials -> Bool-- > isValid = const True-- >-- > myRqData :: RqData AuthCredentials-- > myRqData = do-- > username <- look "username"-- > password <- look "password"-- > return (AuthCredentials username password)-- >-- > checkAuth :: (String -> ServerPart Response) -> ServerPart Response-- > checkAuth errorHandler = do-- > d <- getDataFn myRqData-- > case d of-- > (Left e) -> errorHandler (unlines e)-- > (Right a) | isValid a -> mzero-- > (Right a) | otherwise -> errorHandler "invalid"---- NOTE: you must call 'decodeBody' prior to calling this function if-- the request method is POST or PUT.getDataFn::(HasRqDatam,ServerMonadm,MonadIOm)=>RqDataa-- ^ 'RqData' monad to evaluate->m(Either[String]a)-- ^ return 'Left' errors or 'Right' agetDataFnrqData=dorqEnv<-askRqEnvreturn(runRqDatarqDatarqEnv)-- | similar to 'getDataFn', except it calls a sub-handler on success-- or 'mzero' on failure.-- -- NOTE: you must call 'decodeBody' prior to calling this function if-- the request method is POST or PUT.withDataFn::(HasRqDatam,MonadIOm,MonadPlusm,ServerMonadm)=>RqDataa->(a->mr)->mrwithDataFnfnhandle=getDataFnfn>>=either(constmzero)handle-- | A variant of 'getDataFn' that uses 'FromData' to chose your-- 'RqData' for you. The example from 'getData' becomes:-- -- > data AuthCredentials = AuthCredentials { username :: String, password :: String }-- >-- > isValid :: AuthCredentials -> Bool-- > isValid = const True-- >-- > myRqData :: RqData AuthCredentials-- > myRqData = do-- > username <- look "username"-- > password <- look "password"-- > return (AuthCredentials username password)-- >-- > instance FromData AuthCredentials where-- > fromData = myRqData-- >-- > checkAuth :: (String -> ServerPart Response) -> ServerPart Response-- > checkAuth errorHandler = do-- > d <- getData-- > case d of-- > (Left e) -> errorHandler (unlines e)-- > (Right a) | isValid a -> mzero-- > (Right a) | otherwise -> errorHandler "invalid"---- NOTE: you must call 'decodeBody' prior to calling this function if-- the request method is POST or PUT.getData::(HasRqDatam,MonadIOm,ServerMonadm,FromDataa)=>m(Either[String]a)getData=getDataFnfromData-- | similar to 'getData' except it calls a subhandler on success or 'mzero' on failure.---- NOTE: you must call 'decodeBody' prior to calling this function if-- the request method is POST or PUT.withData::(HasRqDatam,MonadIOm,FromDataa,MonadPlusm,ServerMonadm)=>(a->mr)->mrwithData=withDataFnfromData-- | limit the scope to the Request body---- > handler :: ServerPart Response-- > handler =-- > do foo <- body $ look "foo"-- > ok $ toResponse $ "foo = " ++ foobody::(HasRqDatam)=>ma->mabodyrqData=localRqEnvfrqDatawheref(_query,body,_cookies)=([],body,[])-- | limit the scope to the QUERY_STRING---- > handler :: ServerPart Response-- > handler =-- > do foo <- queryString $ look "foo"-- > ok $ toResponse $ "foo = " ++ fooqueryString::(HasRqDatam)=>ma->maqueryStringrqData=localRqEnvfrqDatawheref(query,_body,_cookies)=(query,[],[])right::(MonadPlusm)=>Eitherab->mbright(Righta)=returnaright(Lefte)=mzerobytestring::(HasRqDatam)=>ma->mabytestringrqData=localRqEnvfrqDatawheref(query,body,cookies)=(filterbsfquery,filterbsfbody,cookies)bsf(_,i)=caseinputValueiof(Left_fp)->False(Right_bs)->True