Merged Yesod.Form and yesod.Formable
This commit is contained in:
Michael Snoyman
parent
95047029f8
commit
1a375e8fb4
4
Yesod.hs
4
Yesod.hs
@ -10,7 +10,6 @@ module Yesod
|
||||
, module Yesod.Form
|
||||
, module Yesod.Hamlet
|
||||
, module Yesod.Json
|
||||
, module Yesod.Formable
|
||||
, Application
|
||||
, liftIO
|
||||
, mempty
|
||||
@ -27,8 +26,7 @@ import Yesod.Dispatch
|
||||
#endif
|
||||
|
||||
import Yesod.Request
|
||||
import Yesod.Form hiding (Form)
|
||||
import Yesod.Formable
|
||||
import Yesod.Form
|
||||
import Yesod.Yesod
|
||||
import Yesod.Handler hiding (runHandler)
|
||||
import Network.Wai (Application)
|
||||
|
||||
420
Yesod/Form.hs
420
Yesod/Form.hs
@ -1,25 +1,38 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
-- | Parse forms (and query strings).
|
||||
module Yesod.Form
|
||||
( Form (..)
|
||||
, runFormGeneric
|
||||
, runFormPost
|
||||
( -- * Data types
|
||||
Form (..)
|
||||
, Formlet
|
||||
, FormResult (..)
|
||||
-- * Unwrapping functions
|
||||
, runFormGet
|
||||
, runFormPost
|
||||
, runFormGet'
|
||||
, runFormPost'
|
||||
-- * Create your own formlets
|
||||
, incr
|
||||
, input
|
||||
, applyForm
|
||||
-- * Specific checks
|
||||
, required
|
||||
, optional
|
||||
, notEmpty
|
||||
, checkDay
|
||||
, checkBool
|
||||
, checkInteger
|
||||
-- * Utility
|
||||
, catchFormError
|
||||
, check
|
||||
-- * Error display
|
||||
, wrapperRow
|
||||
, sealFormlet
|
||||
, sealForm
|
||||
, sealRow
|
||||
-- * Formable
|
||||
, Formable (..)
|
||||
, deriveFormable
|
||||
, share2
|
||||
-- * Pre-built formlets
|
||||
) where
|
||||
|
||||
import Text.Hamlet
|
||||
import Yesod.Request
|
||||
import Yesod.Handler
|
||||
import Control.Applicative hiding (optional)
|
||||
@ -28,110 +41,323 @@ import Data.Maybe (fromMaybe)
|
||||
import "transformers" Control.Monad.IO.Class
|
||||
import Yesod.Internal
|
||||
import Control.Monad.Attempt
|
||||
import Control.Monad ((<=<), liftM, join)
|
||||
import Data.Monoid (mempty, mappend)
|
||||
import Control.Monad.Trans.State
|
||||
import Control.Arrow (first)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Database.Persist.Base (PersistField, EntityDef (..))
|
||||
import Data.Char (isAlphaNum, toUpper, isUpper)
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Web.Routes.Quasi (SinglePiece)
|
||||
import Data.Int (Int64)
|
||||
import qualified Data.ByteString.Lazy.UTF8
|
||||
|
||||
noParamNameError :: String
|
||||
noParamNameError = "No param name (miscalling of Yesod.Form library)"
|
||||
|
||||
data Form x = Form (
|
||||
(ParamName -> [ParamValue])
|
||||
-> Either [(ParamName, FormError)] (Maybe ParamName, x)
|
||||
)
|
||||
data FormResult a = FormMissing
|
||||
| FormFailure [String]
|
||||
| FormSuccess a
|
||||
instance Functor FormResult where
|
||||
fmap _ FormMissing = FormMissing
|
||||
fmap _ (FormFailure errs) = FormFailure errs
|
||||
fmap f (FormSuccess a) = FormSuccess $ f a
|
||||
instance Applicative FormResult where
|
||||
pure = FormSuccess
|
||||
(FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
|
||||
(FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
|
||||
(FormFailure x) <*> _ = FormFailure x
|
||||
_ <*> (FormFailure y) = FormFailure y
|
||||
_ <*> _ = FormMissing
|
||||
|
||||
instance Functor Form where
|
||||
fmap f (Form x) = Form $ \l -> case x l of
|
||||
Left errors -> Left errors
|
||||
Right (pn, x') -> Right (pn, f x')
|
||||
instance Applicative Form where
|
||||
pure x = Form $ \_ -> Right (Nothing, x)
|
||||
(Form f') <*> (Form x') = Form $ \l -> case (f' l, x' l) of
|
||||
(Right (_, f), Right (_, x)) -> Right (Nothing, f x)
|
||||
(Left e1, Left e2) -> Left $ e1 ++ e2
|
||||
(Left e, _) -> Left e
|
||||
(_, Left e) -> Left e
|
||||
newtype Form sub y a = Form
|
||||
{ deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y))
|
||||
}
|
||||
type Formlet sub y a = Maybe a -> Form sub y a
|
||||
|
||||
type FormError = String
|
||||
type Env = [(String, String)]
|
||||
|
||||
runFormGeneric :: Failure ErrorResponse m
|
||||
=> (ParamName -> [ParamValue]) -> Form x -> m x
|
||||
runFormGeneric params (Form f) =
|
||||
case f params of
|
||||
Left es -> invalidArgs es
|
||||
Right (_, x) -> return x
|
||||
instance Functor (Form sub url) where
|
||||
fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env)
|
||||
|
||||
instance Applicative (Form sub url) where
|
||||
pure a = Form $ const $ return (pure a, mempty)
|
||||
(Form f) <*> (Form g) = Form $ \env -> do
|
||||
(f1, f2) <- f env
|
||||
(g1, g2) <- g env
|
||||
return (f1 <*> g1, f2 `mappend` g2)
|
||||
|
||||
runFormGeneric :: Env
|
||||
-> Form sub y a
|
||||
-> GHandler sub y (FormResult a, Hamlet (Routes y))
|
||||
runFormGeneric env f = evalStateT (deform f env) 1
|
||||
|
||||
-- | Run a form against POST parameters.
|
||||
runFormPost :: (RequestReader m, Failure ErrorResponse m, MonadIO m)
|
||||
=> Form x -> m x
|
||||
runFormPost :: Form sub y a
|
||||
-> GHandler sub y (FormResult a, Hamlet (Routes y))
|
||||
runFormPost f = do
|
||||
rr <- getRequest
|
||||
(pp, _) <- liftIO $ reqRequestBody rr
|
||||
runFormGeneric (flip lookup' pp) f
|
||||
runFormGeneric pp f
|
||||
|
||||
lookup' :: Eq a => a -> [(a, b)] -> [b]
|
||||
lookup' a = map snd . filter (\x -> a == fst x)
|
||||
-- | Run a form against POST parameters, disregarding the resulting HTML and
|
||||
-- returning an error response on invalid input.
|
||||
runFormPost' :: Form sub y a -> GHandler sub y a
|
||||
runFormPost' = helper <=< runFormPost
|
||||
|
||||
-- | Run a form against GET parameters, disregarding the resulting HTML and
|
||||
-- returning an error response on invalid input.
|
||||
runFormGet' :: Form sub y a -> GHandler sub y a
|
||||
runFormGet' = helper <=< runFormGet
|
||||
|
||||
helper :: (FormResult a, Hamlet (Routes y)) -> GHandler sub y a
|
||||
helper (FormSuccess a, _) = return a
|
||||
helper (FormFailure e, _) = invalidArgs e
|
||||
helper (FormMissing, _) = invalidArgs ["No input found"]
|
||||
|
||||
-- | Run a form against GET parameters.
|
||||
runFormGet :: (RequestReader m, Failure ErrorResponse m)
|
||||
=> Form x -> m x
|
||||
runFormGet :: Form sub y a
|
||||
-> GHandler sub y (FormResult a, Hamlet (Routes y))
|
||||
runFormGet f = do
|
||||
rr <- getRequest
|
||||
runFormGeneric (flip lookupGetParams rr) f
|
||||
gets <- reqGetParams `fmap` getRequest
|
||||
runFormGeneric gets f
|
||||
|
||||
input :: ParamName -> Form [ParamValue]
|
||||
input pn = Form $ \l -> Right (Just pn, l pn)
|
||||
type Incr = StateT Int
|
||||
|
||||
applyForm :: (x -> Either FormError y) -> Form x -> Form y
|
||||
applyForm f (Form x') =
|
||||
Form $ \l ->
|
||||
case x' l of
|
||||
Left e -> Left e
|
||||
Right (pn, x) ->
|
||||
case f x of
|
||||
Left e -> Left [(fromMaybe noParamNameError pn, e)]
|
||||
Right y -> Right (pn, y)
|
||||
incr :: Monad m => Incr m Int
|
||||
incr = do
|
||||
i <- get
|
||||
let i' = i + 1
|
||||
put i'
|
||||
return i'
|
||||
|
||||
required :: Form [ParamValue] -> Form ParamValue
|
||||
required = applyForm $ \pvs -> case pvs of
|
||||
[x] -> Right x
|
||||
[] -> Left "No value for required field"
|
||||
_ -> Left "Multiple values for required field"
|
||||
input :: (String -> String -> Hamlet (Routes y))
|
||||
-> Maybe String
|
||||
-> Form sub y String
|
||||
input mkXml val = Form $ \env -> do
|
||||
i <- incr
|
||||
let i' = show i
|
||||
let param = lookup i' env
|
||||
let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param
|
||||
return (maybe FormMissing FormSuccess param, xml)
|
||||
|
||||
optional :: Form [ParamValue] -> Form (Maybe ParamValue)
|
||||
optional = applyForm $ \pvs -> case pvs of
|
||||
[""] -> Right Nothing
|
||||
[x] -> Right $ Just x
|
||||
[] -> Right Nothing
|
||||
_ -> Left "Multiple values for optional field"
|
||||
|
||||
notEmpty :: Form ParamValue -> Form ParamValue
|
||||
notEmpty = applyForm $ \pv ->
|
||||
if null pv
|
||||
then Left "Value required"
|
||||
else Right pv
|
||||
|
||||
checkDay :: Form ParamValue -> Form Day
|
||||
checkDay = applyForm $ maybe (Left "Invalid day") Right . readMay
|
||||
check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b
|
||||
check (Form form) f = Form $ \env -> liftM (first go) (form env)
|
||||
where
|
||||
readMay s = case reads s of
|
||||
(x, _):_ -> Just x
|
||||
[] -> Nothing
|
||||
go FormMissing = FormMissing
|
||||
go (FormFailure x) = FormFailure x
|
||||
go (FormSuccess a) =
|
||||
case f a of
|
||||
Left errs -> FormFailure errs
|
||||
Right b -> FormSuccess b
|
||||
|
||||
checkBool :: Form [ParamValue] -> Form Bool
|
||||
checkBool = applyForm $ \pv -> Right $ case pv of
|
||||
[] -> False
|
||||
[""] -> False
|
||||
["false"] -> False
|
||||
_ -> True
|
||||
wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url
|
||||
wrapperRow label errs control = [$hamlet|
|
||||
%tr
|
||||
%th $string.label$
|
||||
%td ^control^
|
||||
$if not.null.errs
|
||||
%td.errors
|
||||
%ul
|
||||
$forall errs err
|
||||
%li $string.err$
|
||||
|]
|
||||
|
||||
checkInteger :: Form ParamValue -> Form Integer
|
||||
checkInteger = applyForm $ \pv ->
|
||||
case reads pv of
|
||||
[] -> Left "Invalid integer"
|
||||
((i, _):_) -> Right i
|
||||
sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b
|
||||
sealRow label getVal val =
|
||||
sealForm (wrapperRow label) $ formable $ fmap getVal val
|
||||
|
||||
-- | Instead of calling 'failure' with an 'InvalidArgs', return the error
|
||||
-- messages.
|
||||
catchFormError :: Form x -> Form (Either [(ParamName, FormError)] x)
|
||||
catchFormError (Form x) = Form $ \l ->
|
||||
case x l of
|
||||
Left e -> Right (Nothing, Left e)
|
||||
Right (_, v) -> Right (Nothing, Right v)
|
||||
sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
|
||||
-> Form sub y a -> Form sub y a
|
||||
sealForm wrapper (Form form) = Form $ \env -> liftM go (form env)
|
||||
where
|
||||
go (res, xml) = (res, wrapper (toList res) xml)
|
||||
toList (FormFailure errs) = errs
|
||||
toList _ = []
|
||||
|
||||
sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
|
||||
-> Formlet sub y a -> Formlet sub y a
|
||||
sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal
|
||||
|
||||
class Formable a where
|
||||
formable :: Formlet sub master a
|
||||
|
||||
--------------- Formable instances
|
||||
instance Formable String where
|
||||
formable x = input go x `check` notEmpty
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=text!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
notEmpty s
|
||||
| null s = Left ["Value required"]
|
||||
| otherwise = Right s
|
||||
|
||||
instance Formable (Maybe String) where
|
||||
formable x = input go (join x) `check` isEmpty
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=text!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
isEmpty s
|
||||
| null s = Right Nothing
|
||||
| otherwise = Right $ Just s
|
||||
|
||||
instance Formable (Html ()) where
|
||||
formable = fmap preEscapedString
|
||||
. input go
|
||||
. fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)
|
||||
where
|
||||
go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]
|
||||
|
||||
instance Formable Day where
|
||||
formable x = input go (fmap show x) `check` asDay
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=date!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asDay s = case reads s of
|
||||
(y, _):_ -> Right y
|
||||
[] -> Left ["Invalid day"]
|
||||
|
||||
instance Formable Int64 where
|
||||
formable x = input go (fmap show x) `check` asInt
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=number!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asInt s = case reads s of
|
||||
(y, _):_ -> Right y
|
||||
[] -> Left ["Invalid integer"]
|
||||
|
||||
instance Formable Double where
|
||||
formable x = input go (fmap numstring x) `check` asDouble
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=number!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asDouble s = case reads s of
|
||||
(y, _):_ -> Right y
|
||||
[] -> Left ["Invalid double"]
|
||||
numstring d =
|
||||
let s = show d
|
||||
in case reverse s of
|
||||
'0':'.':y -> reverse y
|
||||
_ -> s
|
||||
|
||||
instance Formable (Maybe Day) where
|
||||
formable x = input go (fmap show $ join x) `check` asDay
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=date!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asDay "" = Right Nothing
|
||||
asDay s = case reads s of
|
||||
(y, _):_ -> Right $ Just y
|
||||
[] -> Left ["Invalid day"]
|
||||
|
||||
instance Formable (Maybe Int) where
|
||||
formable x = input go (fmap show $ join x) `check` asInt
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=number!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asInt "" = Right Nothing
|
||||
asInt s = case reads s of
|
||||
(y, _):_ -> Right $ Just y
|
||||
[] -> Left ["Invalid integer"]
|
||||
|
||||
instance Formable (Maybe Int64) where
|
||||
formable x = input go (fmap show $ join x) `check` asInt
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=number!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asInt "" = Right Nothing
|
||||
asInt s = case reads s of
|
||||
(y, _):_ -> Right $ Just y
|
||||
[] -> Left ["Invalid integer"]
|
||||
|
||||
instance Formable Bool where
|
||||
formable x = Form $ \env -> do
|
||||
i <- incr
|
||||
let i' = show i
|
||||
let param = lookup i' env
|
||||
let def = if null env then fromMaybe False x else isJust param
|
||||
return (FormSuccess $ isJust param, go i' def)
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=checkbox!name=$string.name$!:val:checked
|
||||
|]
|
||||
|
||||
instance Formable Int where
|
||||
formable x = input go (fmap show x) `check` asInt
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=number!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asInt s = case reads s of
|
||||
(y, _):_ -> Right y
|
||||
[] -> Left ["Invalid integer"]
|
||||
|
||||
newtype Slug = Slug { unSlug :: String }
|
||||
deriving (Read, Eq, Show, SinglePiece, PersistField)
|
||||
|
||||
instance Formable Slug where
|
||||
formable x = input go (fmap unSlug x) `check` asSlug
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=text!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asSlug [] = Left ["Slug must be non-empty"]
|
||||
asSlug x'
|
||||
| all (\c -> c `elem` "-_" || isAlphaNum c) x' =
|
||||
Right $ Slug x'
|
||||
| otherwise = Left ["Slug must be alphanumeric, - and _"]
|
||||
|
||||
share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
|
||||
share2 f g a = do
|
||||
f' <- f a
|
||||
g' <- g a
|
||||
return $ f' ++ g'
|
||||
|
||||
deriveFormable :: [EntityDef] -> Q [Dec]
|
||||
deriveFormable = mapM derive
|
||||
where
|
||||
derive :: EntityDef -> Q Dec
|
||||
derive t = do
|
||||
let fst3 (x, _, _) = x
|
||||
let cols = map (toLabel . fst3) $ entityColumns t
|
||||
ap <- [|(<*>)|]
|
||||
just <- [|pure|]
|
||||
nothing <- [|Nothing|]
|
||||
let just' = just `AppE` ConE (mkName $ entityName t)
|
||||
let c1 = Clause [ ConP (mkName "Nothing") []
|
||||
]
|
||||
(NormalB $ go ap just' $ zip cols $ map (const nothing) cols)
|
||||
[]
|
||||
xs <- mapM (const $ newName "x") cols
|
||||
let xs' = map (AppE just . VarE) xs
|
||||
let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)
|
||||
$ map VarP xs]]
|
||||
(NormalB $ go ap just' $ zip cols xs')
|
||||
[]
|
||||
return $ InstanceD [] (ConT ''Formable
|
||||
`AppT` ConT (mkName $ entityName t))
|
||||
[FunD (mkName "formable") [c1, c2]]
|
||||
go ap just' = foldl (ap' ap) just' . map go'
|
||||
go' (label, ex) =
|
||||
VarE (mkName "sealForm") `AppE`
|
||||
(VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE`
|
||||
(VarE (mkName "formable") `AppE` ex)
|
||||
ap' ap x y = InfixE (Just x) ap (Just y)
|
||||
|
||||
toLabel :: String -> String
|
||||
toLabel "" = ""
|
||||
toLabel (x:rest) = toUpper x : go rest
|
||||
where
|
||||
go "" = ""
|
||||
go (c:cs)
|
||||
| isUpper c = ' ' : c : go cs
|
||||
| otherwise = c : go cs
|
||||
|
||||
@ -1,319 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
module Yesod.Formable
|
||||
( Form (..)
|
||||
, Formlet
|
||||
, FormResult (..)
|
||||
, runForm
|
||||
, incr
|
||||
, Formable (..)
|
||||
, deriveFormable
|
||||
, share2
|
||||
, wrapperRow
|
||||
, sealFormlet
|
||||
, sealForm
|
||||
, Slug (..)
|
||||
, sealRow
|
||||
, check
|
||||
) where
|
||||
|
||||
import Text.Hamlet
|
||||
import Data.Time (Day)
|
||||
import Control.Applicative
|
||||
import Database.Persist (PersistField)
|
||||
import Database.Persist.Base (EntityDef (..))
|
||||
import Data.Char (isAlphaNum, toUpper, isUpper)
|
||||
import Language.Haskell.TH.Syntax
|
||||
import Control.Monad (liftM, join)
|
||||
import Control.Arrow (first)
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Monoid (mempty, mappend)
|
||||
import qualified Data.ByteString.Lazy.UTF8
|
||||
import Yesod.Request
|
||||
import Yesod.Handler
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Trans.State
|
||||
import Web.Routes.Quasi (SinglePiece)
|
||||
import Data.Int (Int64)
|
||||
|
||||
sealRow :: Formable b => String -> (a -> b) -> Maybe a -> Form sub master b
|
||||
sealRow label getVal val =
|
||||
sealForm (wrapperRow label) $ formable $ fmap getVal val
|
||||
|
||||
runForm :: Form sub y a
|
||||
-> GHandler sub y (FormResult a, Hamlet (Routes y))
|
||||
runForm f = do
|
||||
req <- getRequest
|
||||
(pp, _) <- liftIO $ reqRequestBody req
|
||||
evalStateT (deform f pp) 1
|
||||
|
||||
type Env = [(String, String)]
|
||||
|
||||
type Incr = StateT Int
|
||||
|
||||
incr :: Monad m => Incr m Int
|
||||
incr = do
|
||||
i <- get
|
||||
let i' = i + 1
|
||||
put i'
|
||||
return i'
|
||||
|
||||
data FormResult a = FormMissing
|
||||
| FormFailure [String]
|
||||
| FormSuccess a
|
||||
instance Functor FormResult where
|
||||
fmap _ FormMissing = FormMissing
|
||||
fmap _ (FormFailure errs) = FormFailure errs
|
||||
fmap f (FormSuccess a) = FormSuccess $ f a
|
||||
instance Applicative FormResult where
|
||||
pure = FormSuccess
|
||||
(FormSuccess f) <*> (FormSuccess g) = FormSuccess $ f g
|
||||
(FormFailure x) <*> (FormFailure y) = FormFailure $ x ++ y
|
||||
(FormFailure x) <*> _ = FormFailure x
|
||||
_ <*> (FormFailure y) = FormFailure y
|
||||
_ <*> _ = FormMissing
|
||||
|
||||
newtype Form sub y a = Form
|
||||
{ deform :: Env -> Incr (GHandler sub y) (FormResult a, Hamlet (Routes y))
|
||||
}
|
||||
type Formlet sub y a = Maybe a -> Form sub y a
|
||||
|
||||
instance Functor (Form sub url) where
|
||||
fmap f (Form g) = Form $ \env -> liftM (first $ fmap f) (g env)
|
||||
|
||||
instance Applicative (Form sub url) where
|
||||
pure a = Form $ const $ return (pure a, mempty)
|
||||
(Form f) <*> (Form g) = Form $ \env -> do
|
||||
(f1, f2) <- f env
|
||||
(g1, g2) <- g env
|
||||
return (f1 <*> g1, f2 `mappend` g2)
|
||||
|
||||
sealForm :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
|
||||
-> Form sub y a -> Form sub y a
|
||||
sealForm wrapper (Form form) = Form $ \env -> liftM go (form env)
|
||||
where
|
||||
go (res, xml) = (res, wrapper (toList res) xml)
|
||||
toList (FormFailure errs) = errs
|
||||
toList _ = []
|
||||
|
||||
sealFormlet :: ([String] -> Hamlet (Routes y) -> Hamlet (Routes y))
|
||||
-> Formlet sub y a -> Formlet sub y a
|
||||
sealFormlet wrapper formlet initVal = sealForm wrapper $ formlet initVal
|
||||
|
||||
input' :: (String -> String -> Hamlet (Routes y))
|
||||
-> Maybe String
|
||||
-> Form sub y String
|
||||
input' mkXml val = Form $ \env -> do
|
||||
i <- incr
|
||||
let i' = show i
|
||||
let param = lookup i' env
|
||||
let xml = mkXml i' $ fromMaybe (fromMaybe "" val) param
|
||||
return (maybe FormMissing FormSuccess param, xml)
|
||||
|
||||
check :: Form sub url a -> (a -> Either [String] b) -> Form sub url b
|
||||
check (Form form) f = Form $ \env -> liftM (first go) (form env)
|
||||
where
|
||||
go FormMissing = FormMissing
|
||||
go (FormFailure x) = FormFailure x
|
||||
go (FormSuccess a) =
|
||||
case f a of
|
||||
Left errs -> FormFailure errs
|
||||
Right b -> FormSuccess b
|
||||
|
||||
class Formable a where
|
||||
formable :: Formlet sub master a
|
||||
|
||||
wrapperRow :: String -> [String] -> Hamlet url -> Hamlet url
|
||||
wrapperRow label errs control = [$hamlet|
|
||||
%tr
|
||||
%th $string.label$
|
||||
%td ^control^
|
||||
$if not.null.errs
|
||||
%td.errors
|
||||
%ul
|
||||
$forall errs err
|
||||
%li $string.err$
|
||||
|]
|
||||
|
||||
instance Formable String where
|
||||
formable x = input' go x `check` notEmpty
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=text!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
notEmpty s
|
||||
| null s = Left ["Value required"]
|
||||
| otherwise = Right s
|
||||
|
||||
instance Formable (Maybe String) where
|
||||
formable x = input' go (join x) `check` isEmpty
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=text!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
isEmpty s
|
||||
| null s = Right Nothing
|
||||
| otherwise = Right $ Just s
|
||||
|
||||
instance Formable (Html ()) where
|
||||
formable = fmap preEscapedString
|
||||
. input' go
|
||||
. fmap (Data.ByteString.Lazy.UTF8.toString . renderHtml)
|
||||
where
|
||||
go name val = [$hamlet|%textarea!name=$string.name$ $string.val$|]
|
||||
|
||||
instance Formable Day where
|
||||
formable x = input' go (fmap show x) `check` asDay
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=date!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asDay s = case reads s of
|
||||
(y, _):_ -> Right y
|
||||
[] -> Left ["Invalid day"]
|
||||
|
||||
instance Formable Int64 where
|
||||
formable x = input' go (fmap show x) `check` asInt
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=number!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asInt s = case reads s of
|
||||
(y, _):_ -> Right y
|
||||
[] -> Left ["Invalid integer"]
|
||||
|
||||
instance Formable Double where
|
||||
formable x = input' go (fmap numstring x) `check` asDouble
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=number!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asDouble s = case reads s of
|
||||
(y, _):_ -> Right y
|
||||
[] -> Left ["Invalid double"]
|
||||
numstring d =
|
||||
let s = show d
|
||||
in case reverse s of
|
||||
'0':'.':y -> reverse y
|
||||
_ -> s
|
||||
|
||||
instance Formable (Maybe Day) where
|
||||
formable x = input' go (fmap show $ join x) `check` asDay
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=date!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asDay "" = Right Nothing
|
||||
asDay s = case reads s of
|
||||
(y, _):_ -> Right $ Just y
|
||||
[] -> Left ["Invalid day"]
|
||||
|
||||
instance Formable (Maybe Int) where
|
||||
formable x = input' go (fmap show $ join x) `check` asInt
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=number!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asInt "" = Right Nothing
|
||||
asInt s = case reads s of
|
||||
(y, _):_ -> Right $ Just y
|
||||
[] -> Left ["Invalid integer"]
|
||||
|
||||
instance Formable (Maybe Int64) where
|
||||
formable x = input' go (fmap show $ join x) `check` asInt
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=number!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asInt "" = Right Nothing
|
||||
asInt s = case reads s of
|
||||
(y, _):_ -> Right $ Just y
|
||||
[] -> Left ["Invalid integer"]
|
||||
|
||||
instance Formable Bool where
|
||||
formable x = Form $ \env -> do
|
||||
i <- incr
|
||||
let i' = show i
|
||||
let param = lookup i' env
|
||||
let def = if null env then fromMaybe False x else isJust param
|
||||
return (FormSuccess $ isJust param, go i' def)
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=checkbox!name=$string.name$!:val:checked
|
||||
|]
|
||||
|
||||
instance Formable Int where
|
||||
formable x = input' go (fmap show x) `check` asInt
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=number!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asInt s = case reads s of
|
||||
(y, _):_ -> Right y
|
||||
[] -> Left ["Invalid integer"]
|
||||
|
||||
newtype Slug = Slug { unSlug :: String }
|
||||
deriving (Read, Eq, Show, SinglePiece, PersistField)
|
||||
|
||||
instance Formable Slug where
|
||||
formable x = input' go (fmap unSlug x) `check` asSlug
|
||||
where
|
||||
go name val = [$hamlet|
|
||||
%input!type=text!name=$string.name$!value=$string.val$
|
||||
|]
|
||||
asSlug [] = Left ["Slug must be non-empty"]
|
||||
asSlug x'
|
||||
| all (\c -> c `elem` "-_" || isAlphaNum c) x' =
|
||||
Right $ Slug x'
|
||||
| otherwise = Left ["Slug must be alphanumeric, - and _"]
|
||||
|
||||
share2 :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
|
||||
share2 f g a = do
|
||||
f' <- f a
|
||||
g' <- g a
|
||||
return $ f' ++ g'
|
||||
|
||||
deriveFormable :: [EntityDef] -> Q [Dec]
|
||||
deriveFormable = mapM derive
|
||||
where
|
||||
derive :: EntityDef -> Q Dec
|
||||
derive t = do
|
||||
let fst3 (x, _, _) = x
|
||||
let cols = map (toLabel . fst3) $ entityColumns t
|
||||
ap <- [|(<*>)|]
|
||||
just <- [|pure|]
|
||||
nothing <- [|Nothing|]
|
||||
let just' = just `AppE` ConE (mkName $ entityName t)
|
||||
let c1 = Clause [ ConP (mkName "Nothing") []
|
||||
]
|
||||
(NormalB $ go ap just' $ zip cols $ map (const nothing) cols)
|
||||
[]
|
||||
xs <- mapM (const $ newName "x") cols
|
||||
let xs' = map (AppE just . VarE) xs
|
||||
let c2 = Clause [ ConP (mkName "Just") [ConP (mkName $ entityName t)
|
||||
$ map VarP xs]]
|
||||
(NormalB $ go ap just' $ zip cols xs')
|
||||
[]
|
||||
return $ InstanceD [] (ConT ''Formable
|
||||
`AppT` ConT (mkName $ entityName t))
|
||||
[FunD (mkName "formable") [c1, c2]]
|
||||
go ap just' = foldl (ap' ap) just' . map go'
|
||||
go' (label, ex) =
|
||||
VarE (mkName "sealForm") `AppE`
|
||||
(VarE (mkName "wrapperRow") `AppE` LitE (StringL label)) `AppE`
|
||||
(VarE (mkName "formable") `AppE` ex)
|
||||
ap' ap x y = InfixE (Just x) ap (Just y)
|
||||
|
||||
toLabel :: String -> String
|
||||
toLabel "" = ""
|
||||
toLabel (x:rest) = toUpper x : go rest
|
||||
where
|
||||
go "" = ""
|
||||
go (c:cs)
|
||||
| isUpper c = ' ' : c : go cs
|
||||
| otherwise = c : go cs
|
||||
@ -377,7 +377,7 @@ permissionDenied :: Failure ErrorResponse m => String -> m a
|
||||
permissionDenied = failure . PermissionDenied
|
||||
|
||||
-- | Return a 400 invalid arguments page.
|
||||
invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a
|
||||
invalidArgs :: Failure ErrorResponse m => [String] -> m a
|
||||
invalidArgs = failure . InvalidArgs
|
||||
|
||||
------- Headers
|
||||
|
||||
@ -179,10 +179,22 @@ $maybe message msg
|
||||
%input!type=submit!value=Login
|
||||
|]
|
||||
|
||||
-- FIXME next two functions should show up in Yesod.Form properly
|
||||
requiredField :: String -> Form sub master String
|
||||
requiredField n = Form $ \env ->
|
||||
return (maybe FormMissing FormSuccess $ lookup n env, mempty)
|
||||
|
||||
notEmptyField :: String -> Form sub master String
|
||||
notEmptyField n = Form $ \env -> return
|
||||
(case lookup n env of
|
||||
Nothing -> FormMissing
|
||||
Just "" -> FormFailure [n ++ ": You must provide a non-empty string"]
|
||||
Just x -> FormSuccess x, mempty)
|
||||
|
||||
getOpenIdForward :: GHandler Auth master ()
|
||||
getOpenIdForward = do
|
||||
testOpenId
|
||||
oid <- runFormGet $ required $ input "openid"
|
||||
oid <- runFormGet' $ requiredField "openid"
|
||||
render <- getUrlRender
|
||||
toMaster <- getRouteToMaster
|
||||
let complete = render $ toMaster OpenIdComplete
|
||||
@ -220,7 +232,7 @@ handleRpxnowR = do
|
||||
token1 <- lookupGetParam "token"
|
||||
token2 <- lookupPostParam "token"
|
||||
let token = case token1 `mplus` token2 of
|
||||
Nothing -> invalidArgs [("token", "Value not supplied")]
|
||||
Nothing -> invalidArgs ["token: Value not supplied"]
|
||||
Just x -> x
|
||||
Rpxnow.Identifier ident extra <- liftIO $ Rpxnow.authenticate apiKey token
|
||||
let creds = Creds
|
||||
@ -302,7 +314,7 @@ getEmailRegisterR = do
|
||||
postEmailRegisterR :: YesodAuth master => GHandler Auth master RepHtml
|
||||
postEmailRegisterR = do
|
||||
ae <- getAuthEmailSettings
|
||||
email <- runFormPost $ notEmpty $ required $ input "email" -- FIXME checkEmail
|
||||
email <- runFormPost' $ notEmptyField "email" -- FIXME checkEmail
|
||||
y <- getYesod
|
||||
mecreds <- liftIO $ getEmailCreds ae email
|
||||
(lid, verKey) <-
|
||||
@ -366,9 +378,9 @@ $maybe msg ms
|
||||
postEmailLoginR :: YesodAuth master => GHandler Auth master ()
|
||||
postEmailLoginR = do
|
||||
ae <- getAuthEmailSettings
|
||||
(email, pass) <- runFormPost $ (,)
|
||||
<$> notEmpty (required $ input "email") -- FIXME valid e-mail?
|
||||
<*> required (input "password")
|
||||
(email, pass) <- runFormPost' $ (,)
|
||||
<$> notEmptyField "email" -- FIXME valid e-mail?
|
||||
<*> requiredField "password"
|
||||
y <- getYesod
|
||||
mecreds <- liftIO $ getEmailCreds ae email
|
||||
let mlid =
|
||||
@ -419,9 +431,9 @@ $maybe msg ms
|
||||
postEmailPasswordR :: YesodAuth master => GHandler Auth master ()
|
||||
postEmailPasswordR = do
|
||||
ae <- getAuthEmailSettings
|
||||
(new, confirm) <- runFormPost $ (,)
|
||||
<$> notEmpty (required $ input "new")
|
||||
<*> notEmpty (required $ input "confirm")
|
||||
(new, confirm) <- runFormPost' $ (,)
|
||||
<$> notEmptyField "new"
|
||||
<*> notEmptyField "confirm"
|
||||
toMaster <- getRouteToMaster
|
||||
when (new /= confirm) $ do
|
||||
setMessage $ string "Passwords did not match, please try again"
|
||||
@ -495,7 +507,7 @@ getFacebookR = do
|
||||
render <- getUrlRender
|
||||
tm <- getRouteToMaster
|
||||
let fb = Facebook.Facebook cid secret $ render $ tm FacebookR
|
||||
code <- runFormGet $ required $ input "code"
|
||||
code <- runFormGet' $ requiredField "code"
|
||||
at <- liftIO $ Facebook.getAccessToken fb code
|
||||
so <- liftIO $ Facebook.getGraphData at "me"
|
||||
let c = fromMaybe (error "Invalid response from Facebook") $ do
|
||||
|
||||
@ -15,7 +15,7 @@ import Yesod.Dispatch
|
||||
import Yesod.Content
|
||||
import Yesod.Handler
|
||||
import Text.Hamlet
|
||||
import Yesod.Formable
|
||||
import Yesod.Form
|
||||
import Data.Monoid (mempty)
|
||||
|
||||
class Formable a => Item a where
|
||||
@ -127,7 +127,7 @@ crudHelper
|
||||
-> GHandler (Crud master a) master RepHtml
|
||||
crudHelper title me isPost = do
|
||||
crud <- getYesodSub
|
||||
(errs, form) <- runForm $ formable $ fmap snd me
|
||||
(errs, form) <- runFormPost $ formable $ fmap snd me
|
||||
toMaster <- getRouteToMaster
|
||||
case (isPost, errs) of
|
||||
(True, FormSuccess a) -> do
|
||||
|
||||
@ -13,7 +13,7 @@ module Yesod.Internal
|
||||
data ErrorResponse =
|
||||
NotFound
|
||||
| InternalError String
|
||||
| InvalidArgs [(String, String)]
|
||||
| InvalidArgs [String]
|
||||
| PermissionDenied String
|
||||
| BadMethod String
|
||||
deriving (Show, Eq)
|
||||
|
||||
@ -183,10 +183,9 @@ defaultErrorHandler (PermissionDenied msg) =
|
||||
defaultErrorHandler (InvalidArgs ia) =
|
||||
applyLayout' "Invalid Arguments" $ [$hamlet|
|
||||
%h1 Invalid Arguments
|
||||
%dl
|
||||
$forall ia pair
|
||||
%dt $string.fst.pair$
|
||||
%dd $string.snd.pair$
|
||||
%ul
|
||||
$forall ia msg
|
||||
%li $string.msg$
|
||||
|]
|
||||
defaultErrorHandler (InternalError e) =
|
||||
applyLayout' "Internal Server Error" $ [$hamlet|
|
||||
|
||||
@ -48,7 +48,6 @@ library
|
||||
Yesod.Content
|
||||
Yesod.Dispatch
|
||||
Yesod.Form
|
||||
Yesod.Formable
|
||||
Yesod.Hamlet
|
||||
Yesod.Handler
|
||||
Yesod.Internal
|
||||
|
||||
Loading…
Reference in New Issue
Block a user