diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index 946310640..6edcbf05f 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -57,7 +57,7 @@ emailTestForm = (,)
SelFormatTime -> t
makeDemoForm :: Int -> Form (Int,Bool,Double)
-makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used identForm instead!
+makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
(result, widget) <- flip (renderAForm FormStandard) html $ (,,)
<$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing
<* aformSection MsgFormBehaviour
@@ -78,14 +78,14 @@ makeDemoForm n = identifyForm "adminTestForm" $ \html -> do -- Important: used i
getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
getAdminTestR = postAdminTestR
postAdminTestR = do
- ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate)
+ ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
case btnResult of
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
FormMissing -> return ()
_other -> addMessage Warning "KEIN Knopf erkannt"
- ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm
+ ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
formResultModal emailResult AdminTestR $ \(email, ls) -> do
jId <- mapWriterT runDB $ do
jId <- queueJob $ JobSendTestEmail email ls
diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs
index 14a50dc03..8f802798f 100644
--- a/src/Handler/Corrections.hs
+++ b/src/Handler/Corrections.hs
@@ -614,13 +614,13 @@ postCorrectionR tid ssh csh shn cid = do
(fslpI MsgRatingPoints "Punktezahl")
(Just submissionRatingPoints)
- ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
+ ((corrResult, corrForm), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,)
<$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
<*> pointsForm
<*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
<* submitButton
- ((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identForm FIDcorrectionUpload . renderAForm FormStandard $
+ ((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
areq (zipFileField True) (fslI MsgRatingFiles) Nothing
<* submitButton
@@ -693,7 +693,7 @@ getCorrectionUserR tid ssh csh shn cid = do
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
getCorrectionsUploadR = postCorrectionsUploadR
postCorrectionsUploadR = do
- ((uploadRes, upload), uploadEncoding) <- runFormPost . identForm FIDcorrectionsUpload . renderAForm FormStandard $
+ ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
areq (zipFileField True) (fslI MsgCorrUploadField) Nothing
<* submitButton
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index 30399b505..6cc98cc64 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -286,7 +286,7 @@ getCShowR tid ssh csh = do
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) registered
- (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course
+ (regWidget, regEnctype) <- generateFormPost $ identifyForm FIDCourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
siteLayout (toWgt $ courseName course) $ do
setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
@@ -312,7 +312,7 @@ postCRegisterR tid ssh csh = do
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
registered <- isJust <$> getBy (UniqueParticipant aid cid)
return (cid, course, registered)
- ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
+ ((regResult,_), _) <- runFormPost $ identifyForm FIDCourseRegister $ registerForm registered $ courseRegisterSecret course
case regResult of
(FormSuccess codeOk)
| registered -> do
@@ -528,7 +528,7 @@ courseToForm (Entity cid Course{..}) = CourseForm
}
makeCourseForm :: Maybe CourseForm -> Form CourseForm
-makeCourseForm template = identForm FIDcourse $ \html -> do
+makeCourseForm template = identifyForm FIDcourse $ \html -> do
-- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
-- let editCid = cfCourseId =<< template -- possible start for refactoring
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index a57e1149c..5b767b1fe 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -27,7 +27,7 @@ data SettingsForm = SettingsForm
}
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
-makeSettingForm template = identForm FIDsettings $ \html -> do
+makeSettingForm template = identifyForm FIDsettings $ \html -> do
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
<$ aformSection MsgFormCosmetics
<*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index f6e4fe51c..c2c8136d1 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -90,7 +90,7 @@ getFtIdMap sId = do
return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
-makeSheetForm msId template = identForm FIDsheet $ \html -> do
+makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
oldFileIds <- (return.) <$> case msId of
Nothing -> return $ partitionFileType mempty
(Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
@@ -780,7 +780,7 @@ postSCorrR = getSCorrR
getSCorrR tid ssh csh shn = do
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
- ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
+ ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
case res of
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index feb44cb9b..6ce62d265 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -49,7 +49,7 @@ import System.FilePath
makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail)
-makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsubmission $ \html -> do
+makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FIDsubmission $ \html -> do
let
fileUploadForm = case uploadMode of
NoUpload -> pure Nothing
diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs
index ad791a9e6..c219b394a 100644
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@@ -35,7 +35,7 @@ postMessageR cID = do
let
mkForm = do
- ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard
+ ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
$ SystemMessage
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
<*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
@@ -51,7 +51,7 @@ postMessageR cID = do
modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do
cID' <- encrypt tId
- runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
+ runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
$ (,)
<$> fmap (Entity tId)
( SystemMessageTranslation
@@ -64,7 +64,7 @@ postMessageR cID = do
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
- ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard
+ ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
$ SystemMessageTranslation
<$> pure smId
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing
@@ -246,7 +246,7 @@ postMessageListR = do
FormSuccess (_, _selection) -- prop> null _selection
-> addMessageI Error MsgSystemMessageEmptySelection
- ((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
+ ((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
<*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs
index 400ef2d72..e98d7d98f 100644
--- a/src/Handler/Utils/Delete.hs
+++ b/src/Handler/Utils/Delete.hs
@@ -51,7 +51,7 @@ confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelet
multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
-confirmForm' drRecords confirmString = addDeleteTargets . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
+confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
where
addDeleteTargets :: Form a -> Form a
addDeleteTargets form csrf = do
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index a3454fe32..cbaed2eaf 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -564,42 +564,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
, optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
}) cPairs
-mforced :: (site ~ HandlerSite m, MonadHandler m)
- => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
-mforced Field{..} FieldSettings{..} val = do
- tell fieldEnctype
- name <- maybe newFormIdent return fsName
- theId <- lift $ maybe newIdent return fsId
- mr <- getMessageRender
- let fsAttrs' = fsAttrs <> [("disabled", "")]
- return ( FormSuccess val
- , FieldView
- { fvLabel = toHtml $ mr fsLabel
- , fvTooltip = toHtml <$> fmap mr fsTooltip
- , fvId = theId
- , fvInput = fieldView theId name fsAttrs' (Right val) False
- , fvErrors = Nothing
- , fvRequired = False
- }
- )
-
-aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
- => Field m a -> FieldSettings site -> a -> AForm m a
-aforced field settings val = formToAForm $ second pure <$> mforced field settings val
-
-apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
- => Field m a -> FieldSettings site -> Maybe a -> AForm m a
--- ^ Pseudo required
-apreq f fs mx = formToAForm $ do
- mr <- getMessageRender
- over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
-
-wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
- => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
-wpreq f fs mx = mFormToWForm $ do
- mr <- getMessageRender
- over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
-
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> Maybe action
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index 67e5a3f46..ca3408316 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -605,9 +605,9 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
(((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
- (filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
+ (filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
- (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
+ (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
<* autosubmitButton
return (filterRes', pagesizeRes')
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index ff88f3065..4a5735725 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -3,7 +3,7 @@ module Import.NoFoundation
, MForm
) where
-import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField)
+import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm)
import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import
diff --git a/src/Utils.hs b/src/Utils.hs
index a523c723b..ad4bc5568 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -25,6 +25,7 @@ import Utils.PathPiece as Utils
import Utils.Message as Utils
import Utils.Lang as Utils
import Control.Lens as Utils (none)
+import Utils.Parameters as Utils
import Text.Blaze (Markup, ToMarkup)
@@ -574,32 +575,7 @@ getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
-- GET Parameters --
--------------------
-data GlobalGetParam = GetReferer
- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-
-instance Universe GlobalGetParam
-instance Finite GlobalGetParam
-nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1)
-
-lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result)
-lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident)
-
-hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
-hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
-
-
-data GlobalPostParam = PostDeleteTarget
- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-
-instance Universe GlobalPostParam
-instance Finite GlobalPostParam
-nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1)
-
-lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result)
-lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident)
-
-hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
-hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
+-- Moved to Utils.Parameters
---------------------------------
-- Custom HTTP Request-Headers --
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 8c53501f8..625d1c570 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -2,9 +2,11 @@
module Utils.Form where
-import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..))
+import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
import Settings
+import Utils.Parameters
+
-- import Text.Blaze (toMarkup) -- for debugging
import qualified Text.Blaze.Internal as Blaze (null)
import qualified Data.Text as T
@@ -18,6 +20,8 @@ import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set
import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Reader.Class (MonadReader(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
import Data.List ((!!))
@@ -210,6 +214,7 @@ data FormIdentifier
| FIDDBTableFilter
| FIDDBTablePagesize
| FIDDelete
+ | FIDCourseRegister
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where
@@ -217,11 +222,28 @@ instance PathPiece FormIdentifier where
toPathPiece = showToPathPiece
-identForm :: (Monad m, PathPiece ident)
- => ident -- ^ Form identification
- -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
- -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
-identForm = identifyForm . toPathPiece
+identifyForm :: (Monad m, PathPiece ident, Eq ident)
+ => ident -- ^ Form identification
+ -> (Html -> MForm m (FormResult a, widget))
+ -> (Html -> MForm m (FormResult a, widget))
+identifyForm identVal form fragment = do
+ -- Create hidden .
+ let fragment' =
+ [shamlet|
+
+ #{fragment}
+ |]
+
+ -- Check if we got its value back.
+ hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier
+
+ -- Run the form proper (with our hidden ). If the
+ -- data is missing, then do not provide any params to the
+ -- form, which will turn its result into FormMissing. Also,
+ -- doing this avoids having lots of fields with red errors.
+ let eraseParams | not hasIdent = local (\(_, h, l) -> (Nothing, h, l))
+ | otherwise = id
+ fmap (over _1 $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment'
{- Hinweise zur Erinnerung:
- identForm primär, wenn es mehr als ein Formular pro Handler gibt
@@ -512,4 +534,42 @@ prismAForm p outer form = review p <$> form inner
where
inner = outer >>= preview p
+---------------------------------------------
+-- Special variants of @mopt@, @mreq@, ... --
+---------------------------------------------
+mforced :: (site ~ HandlerSite m, MonadHandler m)
+ => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
+mforced Field{..} FieldSettings{..} val = do
+ tell fieldEnctype
+ name <- maybe newFormIdent return fsName
+ theId <- lift $ maybe newIdent return fsId
+ mr <- getMessageRender
+ let fsAttrs' = fsAttrs <> [("disabled", "")]
+ return ( FormSuccess val
+ , FieldView
+ { fvLabel = toHtml $ mr fsLabel
+ , fvTooltip = toHtml <$> fmap mr fsTooltip
+ , fvId = theId
+ , fvInput = fieldView theId name fsAttrs' (Right val) False
+ , fvErrors = Nothing
+ , fvRequired = False
+ }
+ )
+
+aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+ => Field m a -> FieldSettings site -> a -> AForm m a
+aforced field settings val = formToAForm $ second pure <$> mforced field settings val
+
+apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+ => Field m a -> FieldSettings site -> Maybe a -> AForm m a
+-- ^ Pseudo required
+apreq f fs mx = formToAForm $ do
+ mr <- getMessageRender
+ over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
+
+wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+ => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
+wpreq f fs mx = mFormToWForm $ do
+ mr <- getMessageRender
+ over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs
new file mode 100644
index 000000000..81b0c210a
--- /dev/null
+++ b/src/Utils/Parameters.hs
@@ -0,0 +1,78 @@
+module Utils.Parameters
+ ( GlobalGetParam(..)
+ , lookupGlobalGetParam, hasGlobalGetParam
+ , lookupGlobalGetParamForm, hasGlobalGetParamForm
+ , globalGetParamField
+ , GlobalPostParam(..)
+ , lookupGlobalPostParam, hasGlobalPostParam
+ , lookupGlobalPostParamForm, hasGlobalPostParamForm
+ , globalPostParamField
+ ) where
+
+import ClassyPrelude.Yesod
+
+import Utils.PathPiece
+
+import qualified Data.Map as Map
+
+import Data.Universe
+
+import Control.Monad.Trans.Maybe (MaybeT(..))
+
+
+data GlobalGetParam = GetReferer
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe GlobalGetParam
+instance Finite GlobalGetParam
+nullaryPathPiece ''GlobalGetParam (camelToPathPiece' 1)
+
+lookupGlobalGetParam :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m (Maybe result)
+lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece ident)
+
+hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
+hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
+
+
+lookupGlobalGetParamForm :: (Monad m, PathPiece result) => GlobalGetParam -> MForm m (Maybe result)
+lookupGlobalGetParamForm ident = runMaybeT $ do
+ ps <- MaybeT askParams
+ MaybeT . return $ Map.lookup (toPathPiece ident) ps >>= listToMaybe >>= fromPathPiece
+
+hasGlobalGetParamForm :: Monad m => GlobalGetParam -> MForm m Bool
+hasGlobalGetParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
+
+globalGetParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a)
+globalGetParamField ident Field{fieldParse} = runMaybeT $ do
+ ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
+ fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
+ MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs)
+
+data GlobalPostParam = PostFormIdentifier
+ | PostDeleteTarget
+ | PostMassInputShape
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+
+instance Universe GlobalPostParam
+instance Finite GlobalPostParam
+nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1)
+
+lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result)
+lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident)
+
+hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
+hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
+
+lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result)
+lookupGlobalPostParamForm ident = runMaybeT $ do
+ ps <- MaybeT askParams
+ MaybeT . return $ Map.lookup (toPathPiece ident) ps >>= listToMaybe >>= fromPathPiece
+
+hasGlobalPostParamForm :: Monad m => GlobalPostParam -> MForm m Bool
+hasGlobalPostParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
+
+globalPostParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a)
+globalPostParamField ident Field{fieldParse} = runMaybeT $ do
+ ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
+ fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
+ MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs)