{-# LANGUAGE FlexibleInstances, TypeFamilies, OverloadedStrings #-}
module Text.Reform.Happstack where
import Control.Applicative (Applicative((<*>)), Alternative, (<$>), (<|>), (*>), optional)
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 :: [Input] -> [String]
getInputStrings [Input]
inputs = forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
UTF8.toString forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
rights forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Input -> Either String ByteString
inputValue [Input]
inputs
getInputFile :: forall error.
(FormError error, ErrorInputType error ~ [Input]) =>
[Input] -> Either error (FileType [Input])
getInputFile [Input]
inputs =
case [ (String
tmpFilePath, String
uploadName, ContentType
contentType) | (Input (Left String
tmpFilePath) (Just String
uploadName) ContentType
contentType) <- [Input]
inputs ] of
[(String
tmpFilePath, String
uploadName, ContentType
contentType)] -> forall a b. b -> Either a b
Right (String
tmpFilePath, String
uploadName, ContentType
contentType)
[] -> forall a b. a -> Either a b
Left (forall e. FormError e => CommonFormError (ErrorInputType e) -> e
commonFormError forall a b. (a -> b) -> a -> b
$ forall input. input -> CommonFormError input
NoFileFound [Input]
inputs)
[(String, String, ContentType)]
_ -> forall a b. a -> Either a b
Left (forall e. FormError e => CommonFormError (ErrorInputType e) -> e
commonFormError forall a b. (a -> b) -> a -> b
$ forall input. input -> CommonFormError input
MultiFilesFound [Input]
inputs)
environment :: (Happstack m) => Environment m [Input]
environment :: forall (m :: * -> *). Happstack m => Environment m [Input]
environment =
forall (m :: * -> *) input.
(FormId -> m (Value input)) -> Environment m input
Environment forall a b. (a -> b) -> a -> b
$ \FormId
formId ->
do [Input]
ins <- forall (m :: * -> *). (Monad m, HasRqData m) => String -> m [Input]
lookInputs (forall a. Show a => a -> String
show FormId
formId)
case [Input]
ins of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Value a
Missing
[Input]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Value a
Found [Input]
ins
happstackEitherForm :: (Happstack m) =>
([(Text, Text)] -> view -> view)
-> Text
-> Form m [Input] error view proof a
-> m (Either view a)
happstackEitherForm :: forall (m :: * -> *) view error proof a.
Happstack m =>
([(Text, Text)] -> view -> view)
-> Text -> Form m [Input] error view proof a -> m (Either view a)
happstackEitherForm [(Text, Text)] -> view -> view
toForm Text
prefix Form m [Input] error view proof a
frm =
do Method
mthd <- Request -> Method
rqMethod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ServerMonad m => m Request
askRq
case Method
mthd of
Method
POST ->
do forall (m :: * -> *). Happstack m => Text -> m ()
checkCSRF Text
csrfName
Either view a
r <- forall (m :: * -> *) input error view proof a.
Monad m =>
Environment m input
-> Text -> Form m input error view proof a -> m (Either view a)
eitherForm forall (m :: * -> *). Happstack m => Environment m [Input]
environment Text
prefix Form m [Input] error view proof a
frm
case Either view a
r of
(Left view
view) -> forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) view.
Happstack m =>
([(Text, Text)] -> view -> view) -> Text -> view -> m view
happstackView [(Text, Text)] -> view -> view
toForm Text
prefix view
view
(Right a
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right a
a)
Method
_ ->
do forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) view input error proof a.
Happstack m =>
([(Text, Text)] -> view -> view)
-> Text -> Form m input error view proof a -> m view
happstackViewForm [(Text, Text)] -> view -> view
toForm Text
prefix Form m [Input] error view proof a
frm
happstackViewForm :: (Happstack m) =>
([(Text, Text)] -> view -> view)
-> Text
-> Form m input error view proof a
-> m view
happstackViewForm :: forall (m :: * -> *) view input error proof a.
Happstack m =>
([(Text, Text)] -> view -> view)
-> Text -> Form m input error view proof a -> m view
happstackViewForm [(Text, Text)] -> view -> view
toForm Text
prefix Form m input error view proof a
frm =
do view
formChildren <- forall (m :: * -> *) input error view proof a.
Monad m =>
Text -> Form m input error view proof a -> m view
viewForm Text
prefix Form m input error view proof a
frm
forall (m :: * -> *) view.
Happstack m =>
([(Text, Text)] -> view -> view) -> Text -> view -> m view
happstackView [(Text, Text)] -> view -> view
toForm Text
prefix view
formChildren
happstackView :: (Happstack m) =>
([(Text, Text)] -> view -> view)
-> Text
-> view
-> m view
happstackView :: forall (m :: * -> *) view.
Happstack m =>
([(Text, Text)] -> view -> view) -> Text -> view -> m view
happstackView [(Text, Text)] -> view -> view
toForm Text
prefix view
view =
do Text
csrfToken <- forall (m :: * -> *). Happstack m => Text -> m Text
addCSRFCookie Text
csrfName
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Text, Text)] -> view -> view
toForm [(Text
csrfName, Text
csrfToken)] view
view)
addCSRFCookie :: (Happstack m) =>
Text
-> m Text
addCSRFCookie :: forall (m :: * -> *). Happstack m => Text -> m Text
addCSRFCookie Text
name =
do Maybe Cookie
mc <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Monad m, HasRqData m) => String -> m Cookie
lookCookie (Text -> String
TL.unpack Text
name)
case Maybe Cookie
mc of
Maybe Cookie
Nothing ->
do Integer
i <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
forall (m :: * -> *).
(MonadIO m, FilterMonad Response m) =>
CookieLife -> Cookie -> m ()
addCookie CookieLife
Session ((String -> String -> Cookie
mkCookie (Text -> String
TL.unpack Text
name) (forall a. Show a => a -> String
show Integer
i)) { httpOnly :: Bool
httpOnly = Bool
True })
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
TL.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (Integer
i :: Integer))
(Just Cookie
c) ->
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
TL.pack forall a b. (a -> b) -> a -> b
$ Cookie -> String
cookieValue Cookie
c)
getCSRFCookie :: (Happstack m) => Text -> m Text
getCSRFCookie :: forall (m :: * -> *). Happstack m => Text -> m Text
getCSRFCookie Text
name = String -> Text
TL.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> String
cookieValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). (Monad m, HasRqData m) => String -> m Cookie
lookCookie (Text -> String
TL.unpack Text
name)
checkCSRF :: (Happstack m) => Text -> m ()
checkCSRF :: forall (m :: * -> *). Happstack m => Text -> m ()
checkCSRF Text
name =
do Maybe Text
mc <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Happstack m => Text -> m Text
getCSRFCookie Text
name
Maybe Text
mi <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m Text
lookText (Text -> String
TL.unpack Text
name)
case (Maybe Text
mc, Maybe Text
mi) of
(Just Text
c, Just Text
c')
| Text
c forall a. Eq a => a -> a -> Bool
== Text
c' -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Maybe Text, Maybe Text)
_ -> forall a (m :: * -> *) b.
(WebMonad a m, FilterMonad a m) =>
m a -> m b
escape forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. FilterMonad Response m => a -> m a
forbidden (forall a. ToMessage a => a -> Response
toResponse (Text
"CSRF check failed." :: Text))
csrfName :: Text
csrfName :: Text
csrfName = Text
"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 :: forall b (m :: * -> *) view a error proof.
(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 [(Text, Text)] -> view -> view
toForm Text
prefix a -> m b
handleSuccess Maybe ([(FormRange, error)] -> view -> m b)
mHandleFailure Form m [Input] error view proof a
form =
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ do forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method [Method
GET, Method
HEAD]
Text
csrfToken <- forall (m :: * -> *). Happstack m => Text -> m Text
addCSRFCookie Text
csrfName
[(Text, Text)] -> view -> view
toForm [(Text
csrfName, Text
csrfToken)] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) input error view proof a.
Monad m =>
Text -> Form m input error view proof a -> m view
viewForm Text
prefix Form m [Input] error view proof a
form
, do forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST
forall (m :: * -> *). Happstack m => Text -> m ()
checkCSRF Text
csrfName
(View error view
v, m (Result error (Proved proof a))
mresult) <- forall (m :: * -> *) input error view proof a.
Monad m =>
Environment m input
-> Text
-> Form m input error view proof a
-> m (View error view, m (Result error (Proved proof a)))
runForm forall (m :: * -> *). Happstack m => Environment m [Input]
environment Text
prefix Form m [Input] error view proof a
form
Result error (Proved proof a)
result <- m (Result error (Proved proof a))
mresult
case Result error (Proved proof a)
result of
(Ok Proved proof a
a) ->
(forall a (m :: * -> *) b.
(WebMonad a m, FilterMonad a m) =>
m a -> m b
escape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToMessage a => a -> Response
toResponse) forall a b. (a -> b) -> a -> b
$ do
a -> m b
handleSuccess (forall proofs a. Proved proofs a -> a
unProved Proved proof a
a)
(Error [(FormRange, error)]
errors) ->
do Text
csrfToken <- forall (m :: * -> *). Happstack m => Text -> m Text
addCSRFCookie Text
csrfName
case Maybe ([(FormRange, error)] -> view -> m b)
mHandleFailure of
(Just [(FormRange, error)] -> view -> m b
handleFailure) ->
(forall a (m :: * -> *) b.
(WebMonad a m, FilterMonad a m) =>
m a -> m b
escape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToMessage a => a -> Response
toResponse) forall a b. (a -> b) -> a -> b
$
[(FormRange, error)] -> view -> m b
handleFailure [(FormRange, error)]
errors ([(Text, Text)] -> view -> view
toForm [(Text
csrfName, Text
csrfToken)] (forall error v. View error v -> [(FormRange, error)] -> v
unView View error view
v [(FormRange, error)]
errors))
Maybe ([(FormRange, error)] -> view -> m b)
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(Text, Text)] -> view -> view
toForm [(Text
csrfName, Text
csrfToken)] (forall error v. View error v -> [(FormRange, error)] -> v
unView View error view
v [(FormRange, error)]
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 :: forall b (m :: * -> *) view a error proof.
(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 [(Text, Text)] -> view -> view
toForm Text
prefix a -> m b
success Maybe ([(FormRange, error)] -> view -> m b)
failure Form m [Input] error view proof a
form =
forall (m :: * -> *) a. Happstack m => Text -> m a -> m a
guard Text
prefix (forall b (m :: * -> *) view a error proof.
(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 [(Text, Text)] -> view -> view
toForm' Text
prefix a -> m b
success Maybe ([(FormRange, error)] -> view -> m b)
failure Form m [Input] error view proof a
form)
where
toForm' :: [(Text, Text)] -> view -> view
toForm' [(Text, Text)]
hidden view
view = [(Text, Text)] -> view -> view
toForm ((Text
"formname",Text
prefix) forall a. a -> [a] -> [a]
: [(Text, Text)]
hidden) view
view
guard :: (Happstack m) => Text -> m a -> m a
guard :: forall (m :: * -> *) a. Happstack m => Text -> m a -> m a
guard Text
formName m a
part =
(do forall (m :: * -> *) method.
(ServerMonad m, MonadPlus m, MatchMethod method) =>
method -> m ()
method Method
POST
Either [String] Text
submittedName <- forall (m :: * -> *) a.
(HasRqData m, ServerMonad m) =>
RqData a -> m (Either [String] a)
getDataFn (forall (m :: * -> *).
(Functor m, Monad m, HasRqData m) =>
String -> m Text
lookText String
"formname")
if (Either [String] Text
submittedName forall a. Eq a => a -> a -> Bool
== (forall a b. b -> Either a b
Right Text
formName))
then m a
part
else forall (m :: * -> *) a.
ServerMonad m =>
(Request -> Request) -> m a -> m a
localRq (\Request
req -> Request
req { rqMethod :: Method
rqMethod = Method
GET }) m a
part
) forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` m a
part