diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index ed5c31550..6751053b2 100644 --- a/src/Handler/Admin.hs +++ b/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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 47f6f8a74..ab0d737bb 100644 --- a/src/Handler/Corrections.hs +++ b/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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index fd49acdce..fa3c811cb 100644 --- a/src/Handler/Course.hs +++ b/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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 5717bd357..f615d3899 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..34ab467ac 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 @@ -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 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 f974c5a61..b9409d059 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 22e536887..d0e0d0be7 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/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') diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index f044ca557..1a6255df4 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 73debb0e8..965a32f66 100644 --- a/src/Utils.hs +++ b/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 - 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 b007b0cb3..bf8243b69 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,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) - => 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) + => Lens' x (FormResult a) + -> ident -- ^ Form identification + -> (Html -> MForm m (x, widget)) + -> (Html -> MForm m (x, widget)) +identifyForm' resLens 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 . 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) 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) diff --git a/static/js/utils/asyncTable.js b/static/js/utils/asyncTable.js index ea6458633..5e8e371e9 100644 --- a/static/js/utils/asyncTable.js +++ b/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(); }); } diff --git a/static/js/utils/form.js b/static/js/utils/form.js index 8dc8642a2..e45fd56c0 100644 --- a/static/js/utils/form.js +++ b/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(); }); } diff --git a/static/js/utils/inputs.js b/static/js/utils/inputs.js index 85229e678..68425b5ba 100644 --- a/static/js/utils/inputs.js +++ b/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(); }); } diff --git a/static/js/utils/modal.js b/static/js/utils/modal.js index 8bf15bd1a..5c6c1ec43 100644 --- a/static/js/utils/modal.js +++ b/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(); }); }