reform-happstack (empty) → 0.1
raw patch · 4 files changed
+275/−0 lines, 4 filesdep +basedep +bytestringdep +happstack-serversetup-changed
Dependencies added: base, bytestring, happstack-server, mtl, random, reform, utf8-string
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Text/Reform/Happstack.hs +214/−0
- reform-happstack.cabal +29/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Jeremy Shaw++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jeremy Shaw nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Reform/Happstack.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE FlexibleInstances, TypeFamilies #-}+{- |+Support for using Reform with the Haskell Web Framework Happstack. <http://happstack.com/>+-}+module Text.Reform.Happstack where++import Control.Applicative (Applicative((<*>)), Alternative, (<$>), (<|>), (*>), optional)+import Control.Applicative.Indexed (IndexedApplicative(..))+import Control.Monad (msum, mplus)+import Control.Monad.Trans (liftIO)+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy.UTF8 as UTF8+import Data.Either (lefts, rights)+import Data.Maybe (mapMaybe)+import Data.Monoid (Monoid)+import System.Random (randomIO)+import Text.Reform.Backend (FormInput(..), FileType, CommonFormError(NoFileFound, MultiFilesFound), commonFormError)+import Text.Reform.Core (Environment(..), Form, Proved(..), Value(..), View(..), (++>), eitherForm, runForm, mapView, viewForm)+import Text.Reform.Result (Result(..), FormRange)+import Happstack.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 encodings+instance FormInput [Input] where+ type FileType [Input] = (FilePath, FilePath, ContentType)+ getInputStrings inputs = map UTF8.toString $ rights $ map inputValue inputs+ getInputFile inputs =+ case [ (tmpFilePath, uploadName, contentType) | (Input (Left tmpFilePath) (Just uploadName) contentType) <- inputs ] of+ [(tmpFilePath, uploadName, contentType)] -> Right (tmpFilePath, uploadName, contentType)+ [] -> Left (commonFormError $ NoFileFound inputs)+ _ -> Left (commonFormError $ MultiFilesFound inputs)++-- | create an 'Environment' to be used with 'runForm'+environment :: (Happstack m) => Environment m [Input]+environment =+ Environment $ \formId ->+ do ins <- lookInputs (show formId)+ case ins of+ [] -> return $ Missing+ _ -> return $ Found ins++-- | 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 :: (Happstack m) =>+ ([(String, String)] -> view -> view) -- ^ wrap raw form html inside a <form> tag+ -> String -- ^ form prefix+ -> Form m [Input] error view proof a -- ^ Form to run+ -> m (Either view a) -- ^ Result+happstackEitherForm toForm prefix frm =+ do mthd <- rqMethod <$> askRq+ case mthd of+ POST ->+ do checkCSRF csrfName+ -- expireCookie csrfName+ r <- eitherForm environment prefix frm+ case r of+ (Left view) -> Left <$> happstackView toForm prefix view+ (Right a) -> return (Right a)+ _ ->+ do Left <$> happstackViewForm toForm prefix frm++-- | similar to 'viewForm' but includes double-submit+-- (Cross Site Request Forgery) CSRF protection.+--+-- Must be used with 'happstackEitherForm'.+--+-- see also: 'happstackEitherForm'.+happstackViewForm :: (Happstack m) =>+ ([(String, String)] -> view -> view) -- ^ wrap raw form html inside a @\<form\>@ tag+ -> String+ -> Form m input error view proof a+ -> m view+happstackViewForm toForm prefix frm =+ do formChildren <- viewForm prefix frm+ happstackView toForm prefix formChildren++-- | 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 :: (Happstack m) =>+ ([(String, String)] -> view -> view) -- ^ wrap raw form html inside a @\<form\>@ tag+ -> String+ -> view+ -> m view+happstackView toForm prefix view =+ do csrfToken <- addCSRFCookie csrfName+ return (toForm [(csrfName, csrfToken)] view)++-- | Utility Function: add a cookie for CSRF protection+addCSRFCookie :: (Happstack m) =>+ String -- ^ name to use for the cookie+ -> m String+addCSRFCookie name =+ do mc <- optional $ lookCookie name+ case mc of+ Nothing ->+ do i <- liftIO $ randomIO+ addCookie Session ((mkCookie name (show i)) { httpOnly = True })+ return (show (i :: Integer))+ (Just c) ->+ return (cookieValue c)++-- | Utility Function: get CSRF protection cookie+getCSRFCookie :: (Happstack m) => String -> m String+getCSRFCookie name = cookieValue <$> lookCookie name++-- | 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 :: (Happstack m) => String -> m ()+checkCSRF name =+ do mc <- optional $ getCSRFCookie name+ mi <- optional $ look name+ case (mc, mi) of+ (Just c, Just c')+ | 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 :: String+csrfName = "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 :: (ToMessage b, Happstack m, Alternative m, Monoid view) =>+ ([(String, String)] -> view -> view) -- ^ wrap raw form html inside a <form> tag+ -> String -- ^ prefix+ -> (a -> m b) -- ^ handler used when form validates+ -> Maybe ([(FormRange, error)] -> view -> m b) -- ^ handler used when form does not validate+ -> Form m [Input] error view proof a -- ^ the formlet+ -> m view+reformSingle toForm prefix handleSuccess mHandleFailure form =+ msum [ do method [GET, HEAD]+ csrfToken <- addCSRFCookie csrfName+ toForm [(csrfName, csrfToken)] <$> viewForm prefix form++ , do method POST+ checkCSRF csrfName+ (v, mresult) <- runForm environment prefix form+ result <- mresult+ case result of+ (Ok a) ->+ (escape . fmap toResponse) $ do -- expireCookie csrfName+ handleSuccess (unProved a)+ (Error errors) ->+ do csrfToken <- addCSRFCookie csrfName+ case mHandleFailure of+ (Just handleFailure) ->+ (escape . fmap toResponse) $+ handleFailure errors (toForm [(csrfName, csrfToken)] (unView v errors))+ Nothing ->+ return $ toForm [(csrfName, csrfToken)] (unView v errors)+ ]++-- | 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 :: (ToMessage b, Happstack m, Alternative m, Monoid view) =>+ ([(String, String)] -> view -> view) -- ^ wrap raw form html inside a @\<form\>@ tag+ -> String -- ^ prefix+ -> (a -> m b) -- ^ success handler used when form validates+ -> Maybe ([(FormRange, error)] -> view -> m b) -- ^ failure handler used when form does not validate+ -> Form m [Input] error view proof a -- ^ the formlet+ -> m view++reform toForm prefix success failure form =+ guard prefix (reformSingle toForm' prefix success failure form)+ where+ toForm' hidden view = toForm (("formname",prefix) : hidden) view+ guard :: (Happstack m) => String -> m a -> m a+ guard formName part =+ (do method POST+ submittedName <- getDataFn (look "formname")+ if (submittedName == (Right formName))+ then part+ else localRq (\req -> req { rqMethod = GET }) part+ ) `mplus` part+
+ reform-happstack.cabal view
@@ -0,0 +1,29 @@+Name: reform-happstack+Version: 0.1+Synopsis: Happstack support for reform.+Description: Reform is a library for building and validating forms using applicative functors. This package add support for using reform with Happstack.+Homepage: http://www.happstack.com/+License: BSD3+License-file: LICENSE+Author: Jeremy Shaw+Maintainer: jeremy@n-heptane.com+Copyright: 2012 Jeremy Shaw, Jasper Van der Jeugt, SeeReason Partners LLC+Category: Web+Build-type: Simple+Cabal-version: >=1.6++source-repository head+ type: darcs+ subdir: reform+ location: http://patch-tag.com/r/stepcut/reform-happstack++Library+ Exposed-modules: Text.Reform.Happstack+ Build-depends: base >4 && <5,+ bytestring == 0.9.*,+ happstack-server == 7.0.*,+ mtl >= 2.0 && <2.2,+ random == 1.0.*,+ reform == 0.1.*,+ utf8-string == 0.3.*+-- Build-tools: trhsx