From 62e11a1ca104ac2cd39cbbea5b71b33692d17c82 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 27 Mar 2019 15:52:04 +0100 Subject: [PATCH] Better handle FormFailure and allow de-duplication within miAdd --- messages/uniworx/de.msg | 1 + src/Handler/Admin.hs | 9 +++-- src/Handler/Course.hs | 35 +++++++++---------- src/Handler/Utils/Form/MassInput.hs | 52 +++++++++++++++++------------ src/Utils.hs | 3 ++ src/Yesod/Core/Instances.hs | 15 +++++++++ 6 files changed, 74 insertions(+), 41 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index d3e91f601..1f343a7cb 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -103,6 +103,7 @@ CourseUserNoteDeleted: Teilnehmernotiz gelöscht CourseLecturers: Kursverwalter CourseLecturer: Dozent CourseAssistant: Assistent +CourseLecturerAlreadyAdded email@UserEmail: Es gibt bereits einen Kursverwalter mit E-Mail #{email} NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index a497edf11..9d96a5802 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -170,11 +170,11 @@ postAdminTestR = do -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3 -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique -> FieldView UniWorX -- ^ Submit-Button for this add-widget - -> Maybe (Form (ListLength -> (ListPosition, Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cell and data needed to initialize cell + -> Maybe (Form (Map ListPosition Int -> FormResult (Map ListPosition Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cells and data needed to initialize cells mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing -- Any old field; for demonstration let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes -- Do something semi-interesting on the result of the @textField@ to demonstrate that further processing can be done - addRes'' = (\dat l -> (fromIntegral l, dat)) <$> addRes' -- Construct the callback to determine new cell position and data within @FormResult@ as required + addRes'' = addRes' <&> \dat prev -> FormSuccess (Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) dat) -- Construct the callback to determine new cell positions and data within @FormResult@ as required, nested @FormResult@ allows aborting the add depending on previous data return (addRes'', toWidget csrf >> fvInput addView >> fvInput submitBtn) mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form" @@ -199,10 +199,13 @@ postAdminTestR = do -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition) allowAdd :: ListPosition -> Natural -> ListLength -> Bool allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases) + -- | Where to send the user when they click a shape-changing button, given the id of the Wrapper of the `massInput`-`Widget` + buttonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX) + buttonAction frag = Just . SomeRoute $ AdminTestR :#: frag -- The actual call to @massInput@ is comparatively simple: - ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd) "" True Nothing + ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e707c8cd1..6ee54ac0f 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -459,13 +459,13 @@ courseEditHandler :: Maybe CourseForm -> Handler Html courseEditHandler mbCourseForm = do aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! ((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm mbCourseForm - case result of - (FormSuccess res@CourseForm + formResult result $ \case + res@CourseForm { cfCourseId = Nothing , cfShort = csh , cfSchool = ssh , cfTerm = tid - }) -> do -- create new course + } -> do -- create new course now <- liftIO getCurrentTime insertOkay <- runDB $ do insertOkay <- insertUnique Course @@ -493,12 +493,12 @@ courseEditHandler mbCourseForm = do Nothing -> addMessageI Warning $ MsgCourseNewDupShort tid ssh csh - (FormSuccess res@CourseForm + res@CourseForm { cfCourseId = Just cid , cfShort = csh , cfSchool = ssh , cfTerm = tid - }) -> do -- edit existing course + } -> do -- edit existing course now <- liftIO getCurrentTime -- addMessage "debug" [shamlet| #{show res}|] success <- runDB $ do @@ -529,9 +529,6 @@ courseEditHandler mbCourseForm = do addMessageI Success $ MsgCourseEditOk tid ssh csh return True when success $ redirect $ CourseR tid ssh csh CShowR - - (FormFailure _) -> addMessageI Warning MsgInvalidInput - FormMissing -> return () actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute defaultLayout $ do setTitleI MsgCourseEditTitle @@ -581,7 +578,7 @@ 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 - mr <- liftHandlerT getMessageRender -- needed for translation of placeholders + MsgRenderer mr <- getMsgRenderer uid <- liftHandlerT requireAuthId (lecSchools, admSchools) <- liftHandlerT . runDB $ (,) @@ -600,18 +597,19 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do | otherwise -> termsSetField [cfTerm cform] _allOtherCases -> return termsAllowedField - let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (ListLength -> (ListPosition, UserId))) + let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition UserId -> FormResult (Map ListPosition UserId))) miAdd _ _ nudge btn = Just $ \csrf -> do (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk - addRes'' <- case (,) <$> addRes <*> addRes' of - FormSuccess (email, Nothing) -> formFailure [ MsgEMailUnknown $ CI.mk email ] - FormSuccess (_,Just lid) -> return $ FormSuccess lid - FormFailure errs -> return $ FormFailure errs - FormMissing -> return FormMissing - let addRes''' = (\dat l -> (fromIntegral l, dat)) <$> addRes'' + let addRes'' = case (,) <$> addRes <*> addRes' of + FormSuccess (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ] + FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if + | lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ] + | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid + FormFailure errs -> FormFailure errs + FormMissing -> FormMissing addView' = toWidget csrf >> fvInput addView >> fvInput btn - return (addRes''', addView') + return (addRes'', addView') miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType miCell _ lid defType nudge = \csrf -> do @@ -634,6 +632,9 @@ makeCourseForm template = identifyForm FIDcourse $ \html -> do miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ _ = True + miButtonAction :: PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction _ = Nothing + lecturerForm :: AForm Handler [(UserId,LecturerType)] lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 0a65194b6..6b9e35f1b 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -185,7 +185,7 @@ data MassInput handler liveliness cellData cellResult = MassInput -> Natural -- Zero-based dimension index @dimIx@ -> (Text -> Text) -- Nudge deterministic field ids -> FieldView UniWorX -- Submit button - -> Maybe (Markup -> MForm handler (FormResult (liveliness -> (BoxCoord liveliness, cellData)), Widget)) -- ^ Construct a Cell-Addition Widget + -> Maybe (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData)), Widget)) -- ^ Construct a Cell-Addition Widget , miCell :: BoxCoord liveliness -- Position -> cellData -- @cellData@ from @miAdd@ -> Maybe cellResult -- Initial result from Argument to @massInput@ @@ -198,6 +198,7 @@ data MassInput handler liveliness cellData cellResult = MassInput -> Natural -> liveliness -> Bool -- ^ Decide whether an addition-operation should be permitted + , miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment` } massInput :: forall handler cellData cellResult liveliness. @@ -215,6 +216,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do let initialShape = fmap fst <$> initialResult miName <- maybe newFormIdent return fsName + fvId <- maybe newIdent return fsId + miAction <- traverse toTextUrl $ miButtonAction fvId + let addFormAction = maybe id (addAttr "formaction") miAction + let shapeName :: MassInputFieldName (BoxCoord liveliness) shapeName = MassInputShape{..} @@ -230,19 +235,21 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do | otherwise -> throwM MassInputInvalidShape sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness - let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (liveliness -> (BoxCoord liveliness, cellData))), Maybe Widget)) + let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget)) addForm = addForm' boxOrigin . zip [0..] where addForm' _ [] = return Map.empty addForm' miCoord ((dimIx, _) : remDims) = do let nudgeAddWidgetName :: Text -> Text nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..} - (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..}) Nothing - let btnRes - | FormSuccess Nothing <- btnRes' = FormMissing - | FormSuccess (Just x) <- btnRes' = FormSuccess x - | otherwise = error "Value of btnRes should only be inspected if FormSuccess" <$ btnRes' - addRes' <- over (mapped . _Just . _1) (btnRes *>) . local (bool id (set _1 Nothing) $ is _FormMissing btnRes) . traverse ($ mempty) $ + (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing + let btnRes = do + Just x <- btnRes' + return x + wBtnRes res = do + guard $ isn't _FormMissing btnRes + res + addRes' <- over (mapped . _Just . _1) wBtnRes . local (bool id (set _1 Nothing) $ is _FormMissing btnRes) . traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes') case remDims of @@ -254,9 +261,15 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do return $ dimRes' `Map.union` fold dimRess addResults <- addForm boxDimensions + let + addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData))) + addResults' = flip Map.mapWithKey (fst <$> addResults) $ \(dimIx, miCoord) -> \case + FormSuccess (Just mkResult) + | miAllowAdd miCoord dimIx sentLiveliness -> Just <$> mkResult sentShape' + other -> Nothing <$ other let addShape | [((dimIx, miCoord), FormSuccess (Just mkResult))] <- Map.toList . Map.filter (is $ _FormSuccess . _Just) $ fmap fst addResults - = Just $ maybe id (uncurry Map.insert) (mkResult sentLiveliness <$ guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape' + = Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape' <* guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape' | otherwise = Nothing addedShape <- if @@ -267,10 +280,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do let delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX) delForm miCoord = do - (delRes, delView) <- lift $ mpreq (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..}) Nothing + (delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing shapeUpdate <- miDelete addedLiveliness miCoord guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness) - return (shapeUpdate <$ delRes, delView) + return (shapeUpdate <$ assertM (is _Just) delRes, delView) delResults <- fmap (Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape) let @@ -305,12 +318,8 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do | otherwise = prevEnv justAdded :: Set (BoxCoord liveliness) - justAdded = Set.fromList . mapMaybe (addedCoord . fst) $ Map.elems addResults - where - addedCoord res - | FormSuccess (Just mkResult) <- res - = Just . fst $ mkResult sentLiveliness - | otherwise = Nothing + justAdded = Map.keysSet shape Set.\\ Map.keysSet sentShape' + restrictJustAdded :: BoxCoord liveliness -> Maybe a -> Maybe a restrictJustAdded miCoord env = env <* guard (not $ Set.member miCoord justAdded) @@ -320,9 +329,11 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do nudgeCellName miCellField = toPathPiece (MassInputCell{..} :: MassInputFieldName (BoxCoord liveliness)) local (over _1 (applyDelShapeUpdate . restrictJustAdded miCoord)) $ (cData, ) <$> miCell miCoord cData (fmap snd . Map.lookup miCoord =<< initialResult) nudgeCellName mempty let result :: FormResult (Map (BoxCoord liveliness) (cellData, cellResult)) - result - | shapeChanged = FormMissing - | otherwise = traverse (\(cData, (cResult, _)) -> (cData, ) <$> cResult) cellResults + result = do + FormSuccess () <|> void (asum $ Map.elems addResults') + FormSuccess () <|> void (asum . Map.elems $ fst <$> delResults) + guard $ not shapeChanged + for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget miWidget' _ [] = mempty @@ -342,7 +353,6 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions MsgRenderer mr <- getMsgRenderer - fvId <- maybe newIdent return fsId let fvLabel = toHtml $ mr fsLabel diff --git a/src/Utils.hs b/src/Utils.hs index 24631fd2f..1139ba7f2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -442,6 +442,9 @@ instance Ord a => Ord (NTop (Maybe a)) where exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT +formResultToMaybe :: Alternative m => FormResult a -> m a +formResultToMaybe (FormSuccess x) = pure x +formResultToMaybe _ = empty ------------ -- Either -- diff --git a/src/Yesod/Core/Instances.hs b/src/Yesod/Core/Instances.hs index b5ac9bed8..6512c936a 100644 --- a/src/Yesod/Core/Instances.hs +++ b/src/Yesod/Core/Instances.hs @@ -17,6 +17,9 @@ import System.FilePath (()) import Data.Aeson import Control.Monad.Fix +import Control.Monad.Fail (MonadFail) +import qualified Control.Monad.Fail as MonadFail +import Control.Monad.Except (MonadError(..)) import Data.Functor.Extend @@ -50,6 +53,18 @@ instance Monad FormResult where FormMissing >>= _ = FormMissing (FormFailure errs) >>= _ = FormFailure errs + fail = MonadFail.fail + +instance MonadFail FormResult where + fail _ = FormMissing + +instance MonadError [Text] FormResult where + throwError = FormFailure + + catchError a@(FormSuccess _) _ = a + catchError FormMissing _ = FormMissing + catchError (FormFailure errs) h = h errs + instance MonadPlus FormResult instance MonadFix FormResult where