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