Better handle FormFailure and allow de-duplication within miAdd

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.

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|]

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
+    formResult result $ \case
-      (FormSuccess res@CourseForm
+      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
+          let addRes'' = case (,) <$> addRes <*> addRes' of
-            FormSuccess (email, Nothing) -> formFailure [ MsgEMailUnknown $ CI.mk email ]
+                FormSuccess (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ]
-            FormSuccess (_,Just lid) -> return $ FormSuccess lid
+                FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if
-            FormFailure errs -> return $ FormFailure errs
+                  | lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ]
-            FormMissing -> return FormMissing
+                  | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid
-          let addRes''' =  (\dat l -> (fromIntegral l, dat)) <$> addRes''
+                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

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
+            (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
-            let btnRes
+            let btnRes = do
-                  | FormSuccess  Nothing <- btnRes' = FormMissing
+                  Just x <- btnRes'
-                  | FormSuccess (Just x) <- btnRes' = FormSuccess x
+                  return x
-                  | otherwise                       = error "Value of btnRes should only be inspected if FormSuccess" <$ btnRes'
+                wBtnRes res = do
-            addRes' <- over (mapped . _Just . _1) (btnRes *>) . local (bool id (set _1 Nothing) $ is _FormMissing btnRes) . traverse ($ mempty) $
+                  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
+    justAdded = Map.keysSet shape Set.\\ Map.keysSet sentShape'
-      where
+
-        addedCoord res
-          | FormSuccess (Just mkResult) <- res
-          = Just . fst $ mkResult sentLiveliness
-          | otherwise = Nothing
     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
+      result = do
-        | shapeChanged = FormMissing
+        FormSuccess () <|> void (asum $ Map.elems addResults')
-        | otherwise = traverse (\(cData, (cResult, _)) -> (cData, ) <$> cResult) cellResults
+        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

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 --

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