reform-happstack-0.2.0/0000755000000000000000000000000012171027546013152 5ustar0000000000000000reform-happstack-0.2.0/LICENSE0000644000000000000000000000275712171027546014172 0ustar0000000000000000Copyright (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. reform-happstack-0.2.0/reform-happstack.cabal0000644000000000000000000000232412171027546017405 0ustar0000000000000000Name: reform-happstack Version: 0.2.0 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-happstack location: http://hub.darcs.net/stepcut/reform Library Exposed-modules: Text.Reform.Happstack Build-depends: base >4 && <5, bytestring >= 0.9 && < 0.11, happstack-server >= 7.0 && < 7.4, mtl >= 2.0 && <2.2, random == 1.0.*, reform == 0.2.*, text == 0.11.*, utf8-string == 0.3.* -- Build-tools: trhsxreform-happstack-0.2.0/Setup.hs0000644000000000000000000000005612171027546014607 0ustar0000000000000000import Distribution.Simple main = defaultMain reform-happstack-0.2.0/Text/0000755000000000000000000000000012171027546014076 5ustar0000000000000000reform-happstack-0.2.0/Text/Reform/0000755000000000000000000000000012171027546015330 5ustar0000000000000000reform-happstack-0.2.0/Text/Reform/Happstack.hs0000644000000000000000000002362412171027546017611 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TypeFamilies, OverloadedStrings #-} {- | Support for using Reform with the Haskell Web Framework Happstack. -} 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 Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL 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, lookText, 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) => ([(Text, Text)] -> view -> view) -- ^ wrap raw form html inside a
tag -> Text -- ^ 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) => ([(Text, Text)] -> view -> view) -- ^ wrap raw form html inside a @\@ tag -> Text -> 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 @\@ 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) => ([(Text, Text)] -> view -> view) -- ^ wrap raw form html inside a @\@ tag -> Text -> 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) => Text -- ^ name to use for the cookie -> m Text addCSRFCookie name = do mc <- optional $ lookCookie (TL.unpack name) case mc of Nothing -> do i <- liftIO $ randomIO addCookie Session ((mkCookie (TL.unpack name) (show i)) { httpOnly = True }) return (TL.pack $ show (i :: Integer)) (Just c) -> return (TL.pack $ cookieValue c) -- | Utility Function: get CSRF protection cookie getCSRFCookie :: (Happstack m) => Text -> m Text getCSRFCookie name = TL.pack . cookieValue <$> lookCookie (TL.unpack 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) => Text -> m () checkCSRF name = do mc <- optional $ getCSRFCookie name mi <- optional $ lookText (TL.unpack name) case (mc, mi) of (Just c, Just c') | c == c' -> return () _ -> escape $ forbidden (toResponse ("CSRF check failed." :: Text)) -- | generate the name to use for the csrf cookie -- -- Currently this returns the static cookie "reform-csrf". Using the prefix would allow csrfName :: Text 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) => ([(Text, Text)] -> view -> view) -- ^ wrap raw form html inside a tag -> Text -- ^ 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 -- @\@ 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 -- @\@ 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) => ([(Text, Text)] -> view -> view) -- ^ wrap raw form html inside a @\@ tag -> Text -- ^ 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) => Text -> m a -> m a guard formName part = (do method POST submittedName <- getDataFn (lookText "formname") if (submittedName == (Right formName)) then part else localRq (\req -> req { rqMethod = GET }) part ) `mplus` part