Better handle FormFailure and allow de-duplication within miAdd
This commit is contained in:
Gregor Kleen
parent
59baf88294
commit
62e11a1ca1
@ -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.
|
||||
|
||||
@ -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|]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user