{-# LANGUAGE FlexibleInstances, TypeFamilies #-} {- | 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 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