reform-happstack-0.2.5.1/0000755000000000000000000000000012635075071013317 5ustar0000000000000000reform-happstack-0.2.5.1/LICENSE0000644000000000000000000000275712635075071014337 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.5.1/reform-happstack.cabal0000644000000000000000000000237312635075071017556 0ustar0000000000000000Name: reform-happstack Version: 0.2.5.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 tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3 source-repository head type: git location: https://github.com/Happstack/reform-happstack.git Library Exposed-modules: Text.Reform.Happstack Build-depends: base >4 && <5, bytestring >= 0.9 && < 0.11, happstack-server >= 7.0 && < 7.5, mtl >= 2.0 && < 2.3, random >= 1.0 && < 1.2, reform == 0.2.*, text >= 0.11 && < 1.3, utf8-string >= 0.3 && < 1.1 reform-happstack-0.2.5.1/Setup.hs0000644000000000000000000000005612635075071014754 0ustar0000000000000000import Distribution.Simple main = defaultMain reform-happstack-0.2.5.1/Text/0000755000000000000000000000000012635075071014243 5ustar0000000000000000reform-happstack-0.2.5.1/Text/Reform/0000755000000000000000000000000012635075071015475 5ustar0000000000000000reform-happstack-0.2.5.1/Text/Reform/Happstack.hs0000644000000000000000000002362412635075071017756 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