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)
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)
environment :: (Happstack m) => Environment m [Input]
environment =
Environment $ \formId ->
do ins <- lookInputs (show formId)
case ins of
[] -> return $ Missing
_ -> return $ Found ins
happstackEitherForm :: (Happstack m) =>
([(Text, Text)] -> view -> view)
-> Text
-> Form m [Input] error view proof a
-> m (Either view a)
happstackEitherForm toForm prefix frm =
do mthd <- rqMethod <$> askRq
case mthd of
POST ->
do checkCSRF 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
happstackViewForm :: (Happstack m) =>
([(Text, Text)] -> view -> view)
-> Text
-> Form m input error view proof a
-> m view
happstackViewForm toForm prefix frm =
do formChildren <- viewForm prefix frm
happstackView toForm prefix formChildren
happstackView :: (Happstack m) =>
([(Text, Text)] -> view -> view)
-> Text
-> view
-> m view
happstackView toForm prefix view =
do csrfToken <- addCSRFCookie csrfName
return (toForm [(csrfName, csrfToken)] view)
addCSRFCookie :: (Happstack m) =>
Text
-> 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)
getCSRFCookie :: (Happstack m) => Text -> m Text
getCSRFCookie name = TL.pack . cookieValue <$> lookCookie (TL.unpack name)
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))
csrfName :: Text
csrfName = "reform-csrf"
reformSingle :: (ToMessage b, Happstack m, Alternative m, Monoid view) =>
([(Text, Text)] -> view -> view)
-> Text
-> (a -> m b)
-> Maybe ([(FormRange, error)] -> view -> m b)
-> Form m [Input] error view proof a
-> 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
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)
]
reform :: (ToMessage b, Happstack m, Alternative m, Monoid view) =>
([(Text, Text)] -> view -> view)
-> Text
-> (a -> m b)
-> Maybe ([(FormRange, error)] -> view -> m b)
-> Form m [Input] error view proof a
-> 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