diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 7fca70344..e5e83648c 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -250,7 +250,7 @@ data ActionCorrectionsData = CorrDownloadData | CorrSetCorrectorData (Maybe UserId) | CorrAutoSetCorrectorData SheetId -correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent +correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do tableForm <- makeCorrectionsTable whereClause displayColumns psValidator ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do @@ -325,16 +325,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = $(widgetFile "corrections") -type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) +type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) downloadAction :: ActionCorrections' downloadAction = ( CorrDownload - , return (pure CorrDownloadData, Nothing) + , pure CorrDownloadData ) assignAction :: Either CourseId SheetId -> ActionCorrections' assignAction selId = ( CorrSetCorrector - , over (mapped._2) Just $ do + , wFormToAForm $ do correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet @@ -348,14 +348,13 @@ assignAction selId = ( CorrSetCorrector correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey - ($ mempty) . renderAForm FormStandard . wFormToAForm $ do - cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing - fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId + cId <- wpreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing + fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId ) autoAssignAction :: SheetId -> ActionCorrections' autoAssignAction shid = ( CorrAutoSetCorrector - , return (pure $ CorrAutoSetCorrectorData shid, Nothing) + , pure $ CorrAutoSetCorrectorData shid ) getCorrectionsR, postCorrectionsR :: Handler TypedContent diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0bede325e..7eab2aefc 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -24,7 +24,7 @@ import Handler.Utils.Templates import Handler.Utils.DateTime import qualified Data.Time as Time -import Import +import Import hiding (cons) import qualified Data.Char as Char import Data.String (IsString(..)) @@ -359,13 +359,13 @@ sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler S sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do let selOptions = Map.fromList - [ ( Bonus', renderAForm' $ Bonus <$> maxPointsReq ) - , ( Normal', renderAForm' $ Normal <$> maxPointsReq ) - , ( Pass', renderAForm' $ Pass + [ ( Bonus', Bonus <$> maxPointsReq ) + , ( Normal', Normal <$> maxPointsReq ) + , ( Pass', Pass <$> maxPointsReq - <*> areq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template) + <*> apreq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template) ) - , ( NotGraded', return (FormSuccess NotGraded, Nothing) ) + , ( NotGraded', pure NotGraded ) ] (res, selView) <- multiAction selOptions (classify' <$> template) @@ -386,9 +386,7 @@ sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do ]) where - renderAForm' = fmap (over _2 Just) . ($ mempty) . renderAForm FormStandard - - maxPointsReq = areq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template) + maxPointsReq = apreq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template) classify' :: SheetType -> SheetType' classify' = \case @@ -401,11 +399,11 @@ sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do let selOptions = Map.fromList - [ ( Arbitrary', renderAForm' $ Arbitrary - <$> areq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template) + [ ( Arbitrary', Arbitrary + <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template) ) - , ( RegisteredGroups', return (FormSuccess RegisteredGroups, Nothing) ) - , ( NoGroups', return (FormSuccess NoGroups, Nothing) ) + , ( RegisteredGroups', pure RegisteredGroups ) + , ( NoGroups', pure NoGroups ) ] (res, selView) <- multiAction selOptions (classify' <$> template) @@ -426,8 +424,6 @@ sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do ]) where - renderAForm' = fmap (over _2 Just) . ($ mempty) . renderAForm FormStandard - classify' :: SheetGroup -> SheetGroup' classify' = \case Arbitrary _ -> Arbitrary' @@ -545,8 +541,21 @@ 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 + fmap (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 + fmap (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 (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget)) + => Map action (AForm (HandlerT UniWorX IO) a) -> Maybe action -> MForm (HandlerT UniWorX IO) (FormResult a, Widget) multiAction acts defAction = do @@ -554,7 +563,12 @@ multiAction acts defAction = do let options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece (actionRes, actionView) <- mreq (selectField $ return options) "" defAction - results <- sequence acts - let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results + results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts + let mToWidget (_, []) = return Nothing + mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty + widgets <- mapM mToWidget results + let actionWidgets = Map.foldrWithKey accWidget [] widgets + accWidget act Nothing = id + accWidget act (Just w) = cons $(widgetFile "widgets/multiAction") actionResults = Map.map fst results return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))