Gregor Kleen
parent
b25bf48821
commit
ff68ef7c9f
@ -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
|
||||
|
||||
@ -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"))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user