Merge branch 'master' into 307-studiengange-behandeln

src/Handler/Admin.hs

@@ -74,7 +74,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
@@ -95,14 +95,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

src/Handler/Corrections.hs

@@ -353,6 +353,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
           return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
       , dbParamsFormEvaluate = liftHandlerT . runFormPost
       , dbParamsFormResult = _1
+      , dbParamsFormIdent = def
       }
     -- -- Similar Query for Statistics over alle possible Table elements (not just the ones shown)
     -- gradingSummary <- do
@@ -614,13 +615,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 +694,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
 

src/Handler/Course.hs

@@ -558,7 +558,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
 

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

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

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

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
@@ -215,6 +215,7 @@ postMessageListR = do
           return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
       , dbParamsFormEvaluate = liftHandlerT . runFormPost
       , dbParamsFormResult = id
+      , dbParamsFormIdent = def
       }
     , dbtIdent = "messages" :: Text
     }
@@ -246,7 +247,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

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

src/Handler/Utils/Form.hs

@@ -605,42 +605,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

src/Handler/Utils/Table/Pagination.hs

@@ -459,6 +459,19 @@ instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x
 instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
   def = DBParamsDB
 
+data DBParamsFormIdent where
+  DBParamsFormTableIdent :: DBParamsFormIdent
+  DBParamsFormOverrideIdent :: forall t. PathPiece t => t -> DBParamsFormIdent
+  DBParamsFormNoIdent :: DBParamsFormIdent
+
+instance Default DBParamsFormIdent where
+  def = DBParamsFormTableIdent
+
+unDBParamsFormIdent :: DBTable m x -> DBParamsFormIdent -> Maybe Text
+unDBParamsFormIdent DBTable{dbtIdent}  DBParamsFormTableIdent       = Just $ toPathPiece dbtIdent
+unDBParamsFormIdent _                 (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
+unDBParamsFormIdent _                  DBParamsFormNoIdent          = Nothing
+
 instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
   data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
     { dbParamsFormMethod     :: StdMethod
@@ -468,6 +481,7 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
     , dbParamsFormAdditional :: Form a
     , dbParamsFormEvaluate   :: forall m' a' x'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => (Html -> MForm (HandlerT UniWorX IO) (FormResult a', x')) -> m' ((FormResult a', x'), Enctype)
     , dbParamsFormResult     :: Lens' x (FormResult a)
+    , dbParamsFormIdent      :: DBParamsFormIdent
     }
   type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = (x, Widget)
   -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
@@ -490,7 +504,15 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
   dbWidget _ _ = return . snd
   dbHandler _ _ f = return . over _2 f
   -- runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable (MForm (HandlerT UniWorX IO)) x -> PaginationInput -> [k'] -> (MForm (HandlerT UniWorX IO)) (x, Widget) -> ReaderT SqlBackend m' (x, Widget)
-  runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1) . dbParamsFormEvaluate . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x))) . dbParamsFormWrap dbtParams . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment
+  runDBTable dbtable@(DBTable{ dbtParams = dbtParams@DBParamsForm{..} }) pi pKeys
+    = fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1)
+    . dbParamsFormEvaluate
+    . fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x)))
+    . dbParamsFormWrap dbtParams
+    . maybe id (identifyForm' dbParamsFormResult) (unDBParamsFormIdent dbtable dbParamsFormIdent)
+    . addPIHiddenField dbtable pi
+    . addPreviousHiddenField dbtable pKeys
+    . withFragment
 
   dbInvalidateResult DBParamsForm{..} reason result = do
     reasonTxt <- getMessageRender <*> pure reason
@@ -508,6 +530,7 @@ instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [La
     , dbParamsFormAdditional = \_ -> return (pure (), mempty)
     , dbParamsFormEvaluate   = liftHandlerT . runFormPost
     , dbParamsFormResult     = lens (\_ -> pure ()) (\s _ -> s)
+    , dbParamsFormIdent      = def
     }
 
 dbParamsFormWrap :: Monoid x => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
@@ -603,9 +626,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')

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

src/Utils.hs

@@ -24,6 +24,7 @@ import Utils.DateTime as Utils
 import Utils.PathPiece as Utils
 import Utils.Message as Utils
 import Utils.Lang as Utils
+import Utils.Parameters as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
@@ -595,32 +596,7 @@ getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
 -- GET Parameters --
 --------------------
 
-data GlobalGetParam = GetReferer
+-- Moved to Utils.Parameters
-  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)
 
 ---------------------------------
 -- Custom HTTP Request-Headers --

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,7 +214,9 @@ data FormIdentifier
   | FIDSystemMessageAddTranslation
   | FIDDBTableFilter
   | FIDDBTablePagesize
+  | FIDDBTable
   | FIDDelete
+  | FIDCourseRegister
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
@@ -218,11 +224,32 @@ instance PathPiece FormIdentifier where
   toPathPiece = showToPathPiece
 
 
-identForm :: (Monad m, PathPiece ident)
+identifyForm' :: (Monad m, PathPiece ident, Eq ident)
-          => ident -- ^ Form identification
+              => Lens' x (FormResult a)
-          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+              -> ident -- ^ Form identification
-          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+              -> (Html -> MForm m (x, widget))
-identForm = identifyForm . toPathPiece
+              -> (Html -> MForm m (x, widget))
+identifyForm' resLens identVal form fragment = do
+    -- Create hidden <input>.
+    let fragment' =
+          [shamlet|
+            <input .form-identifier type=hidden name=#{toPathPiece PostFormIdentifier} value=#{toPathPiece identVal}>
+            #{fragment}
+          |]
+
+    -- Check if we got its value back.
+    hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier 
+
+    -- Run the form proper (with our hidden <input>).  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 . resLens) $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment'
+
+identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget))
+identifyForm = identifyForm' id
 
 {- Hinweise zur Erinnerung:
   - identForm primär, wenn es mehr als ein Formular pro Handler gibt
@@ -513,4 +540,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)

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)

static/js/utils/asyncTable.js

@@ -217,7 +217,9 @@
     }
 
     function destroyUtils() {
-      utilInstances.forEach(function(utilInstance) {
+      utilInstances.filter(function(utilInstance) {
+        return !!utilInstance;
+      }).forEach(function(utilInstance) {
         utilInstance.destroy();
       });
     }

static/js/utils/form.js

@@ -48,7 +48,9 @@
     form.classList.add(JS_INITIALIZED);
 
     function destroyUtils() {
-      utilInstances.forEach(function(utilInstance) {
+      utilInstances.filter(function(utilInstance) {
+        return !!utilInstance;
+      }).forEach(function(utilInstance) {
         utilInstance.destroy();
       });
     }

static/js/utils/inputs.js

@@ -38,7 +38,9 @@
     });
 
     function destroyUtils() {
-      utilInstances.forEach(function(utilInstance) {
+      utilInstances.filter(function(utilInstance) {
+        return !!utilInstance;
+      }).forEach(function(utilInstance) {
         utilInstance.destroy();
       });
     }

static/js/utils/modal.js

@@ -140,7 +140,9 @@
     setup();
 
     function destroyUtils() {
-      utilInstances.forEach(function(utilInstance) {
+      utilInstances.filter(function(utilInstance) {
+        return !!utilInstance;
+      }).forEach(function(utilInstance) {
         utilInstance.destroy();
       });
     }