{-# LANGUAGE FlexibleInstances, TypeFamilies #-}{- |
Support for using Reform with the Haskell Web Framework Happstack. <http://happstack.com/>
-}moduleText.Reform.HappstackwhereimportControl.Applicative(Applicative((<*>)),Alternative,(<$>),(<|>),(*>),optional)importControl.Applicative.Indexed(IndexedApplicative(..))importControl.Monad(msum,mplus)importControl.Monad.Trans(liftIO)importData.ByteString.Lazy(ByteString)importqualifiedData.ByteString.Lazy.UTF8asUTF8importData.Either(lefts,rights)importData.Maybe(mapMaybe)importData.Monoid(Monoid)importSystem.Random(randomIO)importText.Reform.Backend(FormInput(..),FileType,CommonFormError(NoFileFound,MultiFilesFound),commonFormError)importText.Reform.Core(Environment(..),Form,Proved(..),Value(..),View(..),(++>),eitherForm,runForm,mapView,viewForm)importText.Reform.Result(Result(..),FormRange)importHappstack.Server(Cookie(..),CookieLife(Session),ContentType,Happstack,Input(..),Method(GET,HEAD,POST),ServerMonad(localRq),ToMessage(..),Request(rqMethod),addCookie,askRq,expireCookie,forbidden,lookCookie,lookInputs,look,body,escape,method,mkCookie,getDataFn)-- FIXME: we should really look at Content Type and check for non-UTF-8 encodingsinstanceFormInput[Input]wheretypeFileType[Input]=(FilePath,FilePath,ContentType)getInputStringsinputs=mapUTF8.toString$rights$mapinputValueinputsgetInputFileinputs=case[(tmpFilePath,uploadName,contentType)|(Input(LefttmpFilePath)(JustuploadName)contentType)<-inputs]of[(tmpFilePath,uploadName,contentType)]->Right(tmpFilePath,uploadName,contentType)[]->Left(commonFormError$NoFileFoundinputs)_->Left(commonFormError$MultiFilesFoundinputs)-- | create an 'Environment' to be used with 'runForm'environment::(Happstackm)=>Environmentm[Input]environment=Environment$\formId->doins<-lookInputs(showformId)caseinsof[]->return$Missing_->return$Foundins-- | similar to 'eitherForm environment' but includes double-submit-- (Cross Site Request Forgery) CSRF protection.---- The form must have been created using 'happstackViewForm'---- see also: 'happstackViewForm'happstackEitherForm::(Happstackm)=>([(String,String)]->view->view)-- ^ wrap raw form html inside a <form> tag->String-- ^ form prefix->Formm[Input]errorviewproofa-- ^ Form to run->m(Eitherviewa)-- ^ ResulthappstackEitherFormtoFormprefixfrm=domthd<-rqMethod<$>askRqcasemthdofPOST->docheckCSRFcsrfName-- expireCookie csrfNamer<-eitherFormenvironmentprefixfrmcaserof(Leftview)->Left<$>happstackViewtoFormprefixview(Righta)->return(Righta)_->doLeft<$>happstackViewFormtoFormprefixfrm-- | similar to 'viewForm' but includes double-submit-- (Cross Site Request Forgery) CSRF protection.---- Must be used with 'happstackEitherForm'.---- see also: 'happstackEitherForm'.happstackViewForm::(Happstackm)=>([(String,String)]->view->view)-- ^ wrap raw form html inside a @\<form\>@ tag->String->Formminputerrorviewproofa->mviewhappstackViewFormtoFormprefixfrm=doformChildren<-viewFormprefixfrmhappstackViewtoFormprefixformChildren-- | Utility Function: wrap the @view@ in a @\<form\>@ that includes-- double-submit CSRF protection.---- calls 'addCSRFCookie' to set the cookie and adds the token as a-- hidden field.---- see also: 'happstackViewForm', 'happstackEitherForm', 'checkCSRF'happstackView::(Happstackm)=>([(String,String)]->view->view)-- ^ wrap raw form html inside a @\<form\>@ tag->String->view->mviewhappstackViewtoFormprefixview=docsrfToken<-addCSRFCookiecsrfNamereturn(toForm[(csrfName,csrfToken)]view)-- | Utility Function: add a cookie for CSRF protectionaddCSRFCookie::(Happstackm)=>String-- ^ name to use for the cookie->mStringaddCSRFCookiename=domc<-optional$lookCookienamecasemcofNothing->doi<-liftIO$randomIOaddCookieSession((mkCookiename(showi)){httpOnly=True})return(show(i::Integer))(Justc)->return(cookieValuec)-- | Utility Function: get CSRF protection cookiegetCSRFCookie::(Happstackm)=>String->mStringgetCSRFCookiename=cookieValue<$>lookCookiename-- | Utility Function: check that the CSRF cookie and hidden field exist and are equal---- If the check fails, this function will call:---- > escape $ forbidden (toResponse "CSRF check failed.")checkCSRF::(Happstackm)=>String->m()checkCSRFname=domc<-optional$getCSRFCookienamemi<-optional$looknamecase(mc,mi)of(Justc,Justc')|c==c'->return()_->escape$forbidden(toResponse"CSRF check failed.")-- | generate the name to use for the csrf cookie---- Currently this returns the static cookie "reform-csrf". Using the prefix would allow csrfName::StringcsrfName="reform-csrf"-- | This function allows you to embed a a single 'Form' into a HTML page.---- In general, you will want to use the 'reform' function instead,-- which allows more than one 'Form' to be used on the same page.---- see also: 'reform'reformSingle::(ToMessageb,Happstackm,Alternativem,Monoidview)=>([(String,String)]->view->view)-- ^ wrap raw form html inside a <form> tag->String-- ^ prefix->(a->mb)-- ^ handler used when form validates->Maybe([(FormRange,error)]->view->mb)-- ^ handler used when form does not validate->Formm[Input]errorviewproofa-- ^ the formlet->mviewreformSingletoFormprefixhandleSuccessmHandleFailureform=msum[domethod[GET,HEAD]csrfToken<-addCSRFCookiecsrfNametoForm[(csrfName,csrfToken)]<$>viewFormprefixform,domethodPOSTcheckCSRFcsrfName(v,mresult)<-runFormenvironmentprefixformresult<-mresultcaseresultof(Oka)->(escape.fmaptoResponse)$do-- expireCookie csrfNamehandleSuccess(unProveda)(Errorerrors)->docsrfToken<-addCSRFCookiecsrfNamecasemHandleFailureof(JusthandleFailure)->(escape.fmaptoResponse)$handleFailureerrors(toForm[(csrfName,csrfToken)](unViewverrors))Nothing->return$toForm[(csrfName,csrfToken)](unViewverrors)]-- | this function embeds a 'Form' in an HTML page.---- When the page is requested with a 'GET' request, the form view will-- be rendered.---- When the page is requested with a 'POST' request, the form data-- will be extracted and validated.---- If a value is successfully produced the success handler will be-- called with the value.---- On failure the failure handler will be called. If no failure-- handler is provided, then the page will simply be redisplayed. The-- form will be rendered with the errors and previous submit data shown.---- The first argument to 'reform' is a function which generates the-- @\<form\>@ tag. It should generally come from the template library-- you are using, such as the @form@ function from @reform-hsp@.---- The @[(String, String)]@ argument is a list of '(name, value)'-- pairs for extra hidden fields that should be added to the-- @\<form\>@ tag. These hidden fields are used to provide cross-site-- request forgery (CSRF) protection, and to support multiple forms on-- the same page.reform::(ToMessageb,Happstackm,Alternativem,Monoidview)=>([(String,String)]->view->view)-- ^ wrap raw form html inside a @\<form\>@ tag->String-- ^ prefix->(a->mb)-- ^ success handler used when form validates->Maybe([(FormRange,error)]->view->mb)-- ^ failure handler used when form does not validate->Formm[Input]errorviewproofa-- ^ the formlet->mviewreformtoFormprefixsuccessfailureform=guardprefix(reformSingletoForm'prefixsuccessfailureform)wheretoForm'hiddenview=toForm(("formname",prefix):hidden)viewguard::(Happstackm)=>String->ma->maguardformNamepart=(domethodPOSTsubmittedName<-getDataFn(look"formname")if(submittedName==(RightformName))thenpartelselocalRq(\req->req{rqMethod=GET})part)`mplus`part