266 lines
14 KiB
Haskell
266 lines
14 KiB
Haskell
module Handler.Sheet.Form
|
|
( SheetForm(..), SheetPersonalisedFilesForm(..), Loads
|
|
, makeSheetForm
|
|
, getFtIdMap
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Invitations
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.Map ((!))
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
|
|
import Handler.Sheet.CorrectorInvite
|
|
|
|
|
|
type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector)
|
|
|
|
data SheetForm = SheetForm
|
|
{ sfName :: SheetName
|
|
, sfDescription :: Maybe Html
|
|
, sfRequireExamRegistration :: Maybe ExamId
|
|
, sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads
|
|
, sfPersonalF :: Maybe SheetPersonalisedFilesForm
|
|
, sfVisibleFrom :: Maybe UTCTime
|
|
, sfActiveFrom :: Maybe UTCTime
|
|
, sfActiveTo :: Maybe UTCTime
|
|
, sfHintFrom :: Maybe UTCTime
|
|
, sfSolutionFrom :: Maybe UTCTime
|
|
, sfSubmissionMode :: SubmissionMode
|
|
, sfGrouping :: SheetGroup
|
|
, sfType :: SheetType
|
|
, sfAutoDistribute :: Bool
|
|
, sfMarkingText :: Maybe Html
|
|
, sfAnonymousCorrection :: Bool
|
|
, sfCorrectors :: Loads
|
|
-- Keine SheetId im Formular!
|
|
}
|
|
|
|
data SheetPersonalisedFilesForm = SheetPersonalisedFilesForm
|
|
{ spffFiles :: Maybe FileUploads
|
|
, spffFilesKeepExisting :: Bool
|
|
, spffAllowNonPersonalisedSubmission :: Bool
|
|
}
|
|
|
|
|
|
getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference)
|
|
getFtIdMap sId = do
|
|
allSheetFiles <- E.select . E.from $ \sheetFile -> do
|
|
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
|
|
return sheetFile
|
|
return $ partitionFileType [ (sheetFileType, sf ^. _FileReference . _1) | Entity _ sf@SheetFile{..} <- allSheetFiles ]
|
|
|
|
makeSheetForm :: CourseId -> Maybe SheetId -> Maybe SheetForm -> Form SheetForm
|
|
makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateSheet $ \html -> do
|
|
oldFileIds <- (return.) <$> case msId of
|
|
Nothing -> return $ partitionFileType mempty
|
|
(Just sId) -> liftHandler $ runDB $ getFtIdMap sId
|
|
MsgRenderer mr <- getMsgRenderer
|
|
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
|
|
sheetPersonalisedFilesForm <- makeSheetPersonalisedFilesForm $ template >>= sfPersonalF
|
|
flip (renderAForm FormStandard) html $ SheetForm
|
|
<$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
|
|
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
|
<*> optionalActionA (apreq (examField Nothing cId) (fslI MsgSheetRequiredExam) (sfRequireExamRegistration =<< template)) (fslI MsgSheetRequireExam & setTooltip MsgSheetRequireExamTip) (is _Just . sfRequireExamRegistration <$> template)
|
|
<* aformSection MsgSheetFormFiles
|
|
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
|
|
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
|
|
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
|
|
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles
|
|
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
|
|
<*> optionalActionA sheetPersonalisedFilesForm (fslI MsgSheetPersonalisedFiles & setTooltip MsgSheetPersonalisedFilesTip) (is _Just . sfPersonalF <$> template)
|
|
<* aformSection MsgSheetFormTimes
|
|
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
|
& setTooltip MsgSheetVisibleFromTip)
|
|
((sfVisibleFrom <$> template) <|> pure (Just ctime))
|
|
<*> aopt utcTimeField (fslI MsgSheetActiveFrom
|
|
& setTooltip MsgSheetActiveFromTip)
|
|
(sfActiveFrom <$> template)
|
|
<*> aopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder)
|
|
& setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder)
|
|
& setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
|
|
<* aformSection MsgSheetFormType
|
|
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
|
|
<*> sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups)
|
|
<*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
|
|
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
|
|
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
|
<*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
|
|
<*> correctorForm (maybe mempty sfCorrectors template)
|
|
where
|
|
makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm)
|
|
makeSheetPersonalisedFilesForm template' = do
|
|
templateDownloadMessage <- runMaybeT . hoist (liftHandler . runDB) $ do
|
|
mbSheet <- maybe (return Nothing) (fmap Just . hoistMaybe) =<< traverse (lift . get) msId
|
|
Course{..} <- MaybeT $ get cId
|
|
let downloadRoute = case mbSheet of
|
|
Just Sheet{..} -> CSheetR courseTerm courseSchool courseShorthand sheetName SPersonalFilesR
|
|
Nothing -> CourseR courseTerm courseSchool courseShorthand CPersonalFilesR
|
|
downloadTrigger
|
|
= [whamlet|
|
|
$newline never
|
|
#{iconFileZip}
|
|
\ _{MsgMenuSheetPersonalisedFiles}
|
|
|]
|
|
listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl
|
|
( CourseR courseTerm courseSchool courseShorthand CUsersR
|
|
, [ ("courseUsers-has-personalised-sheet-files"
|
|
, toPathPiece shn
|
|
)
|
|
]
|
|
)
|
|
guardM $ hasReadAccessTo downloadRoute
|
|
messageIconWidget Info IconFileUser
|
|
[whamlet|
|
|
$newline never
|
|
<div>
|
|
_{MsgSheetPersonalisedFilesDownloadTemplateHere}
|
|
<br />
|
|
^{modal downloadTrigger (Left (SomeRoute downloadRoute))}
|
|
$maybe lRoute <- listRoute
|
|
<p .explanation>
|
|
<a href=#{lRoute} target="_blank">
|
|
_{MsgSheetPersonalisedFilesUsersList}
|
|
|]
|
|
return $ SheetPersonalisedFilesForm
|
|
<$ maybe (pure ()) aformMessage templateDownloadMessage
|
|
<*> aopt (zipFileField True Nothing) (fslI MsgSheetPersonalisedFilesUpload & setTooltip MsgSheetPersonalisedFilesUploadTip) Nothing
|
|
<*> apopt checkBoxField (fslI MsgSheetPersonalisedFilesKeepExisting & setTooltip MsgSheetPersonalisedFilesKeepExistingTip) (fmap spffFilesKeepExisting template' <|> Just True)
|
|
<*> apopt checkBoxField (fslI MsgSheetPersonalisedFilesAllowNonPersonalisedSubmission & setTooltip MsgSheetPersonalisedFilesAllowNonPersonalisedSubmissionTip) (fmap spffAllowNonPersonalisedSubmission template' <|> Just True)
|
|
|
|
validateSheet :: FormValidator SheetForm Handler ()
|
|
validateSheet = do
|
|
SheetForm{..} <- State.get
|
|
|
|
guardValidation MsgSheetErrVisibility $ NTop sfVisibleFrom <= NTop sfActiveFrom
|
|
guardValidation MsgSheetErrDeadlineEarly $ NTop sfActiveFrom <= NTop sfActiveTo
|
|
guardValidation MsgSheetErrHintEarly $ NTop sfHintFrom >= NTop sfActiveFrom
|
|
guardValidation MsgSheetErrSolutionEarly $ NTop sfSolutionFrom >= NTop sfActiveTo
|
|
|
|
guardValidation MsgSheetErrVisibleWithoutActive $ is _Just sfActiveFrom || is _Nothing sfVisibleFrom
|
|
|
|
warnValidation MsgSheetWarnNoActiveTo $ is _Just sfActiveTo || is _Nothing sfActiveFrom
|
|
|
|
warnValidation MsgSheetSubmissionModeNoneWithoutNotGraded
|
|
$ classifySubmissionMode sfSubmissionMode /= SubmissionModeNone
|
|
|| sfType == NotGraded
|
|
|
|
correctorForm :: Loads -> AForm Handler Loads
|
|
correctorForm loads' = wFormToAForm $ do
|
|
currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
|
|
userId <- liftHandler requireAuthId
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
let
|
|
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
|
|
loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
|
|
|
|
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> Just True == byTutorial) $ Map.elems loads
|
|
|
|
|
|
let
|
|
previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
|
|
previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
|
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
|
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
|
|
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
|
return user
|
|
|
|
miAdd :: ListPosition
|
|
-> Natural
|
|
-> (Text -> Text)
|
|
-> FieldView UniWorX
|
|
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
|
|
miAdd _ _ nudge submitView = Just $ \csrf -> do
|
|
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
|
|
let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
|
|
| existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
|
|
, not $ null existing
|
|
-> FormFailure [mr MsgCorrectorExists]
|
|
| otherwise
|
|
-> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs
|
|
return (addRes', $(widgetFile "sheetCorrectors/add"))
|
|
|
|
miCell :: ListPosition
|
|
-> Either UserEmail UserId
|
|
-> Maybe (CorrectorState, Load)
|
|
-> (Text -> Text)
|
|
-> Form (CorrectorState, Load)
|
|
miCell _ userIdent initRes nudge csrf = do
|
|
(stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
|
|
(byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
|
|
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
|
|
let
|
|
res :: FormResult (CorrectorState, Load)
|
|
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
|
|
tutRes'
|
|
| FormSuccess True <- byTutRes = Just <$> countTutRes
|
|
| otherwise = Nothing <$ byTutRes
|
|
identWidget <- case userIdent of
|
|
Left email -> return . toWidget $ mailtoHtml email
|
|
Right uid -> do
|
|
User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid
|
|
return $ nameEmailWidget userEmail userDisplayName userSurname
|
|
invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
|
|
return (res, $(widgetFile "sheetCorrectors/cell"))
|
|
|
|
|
|
miDelete :: Map ListPosition (Either UserEmail UserId)
|
|
-> ListPosition
|
|
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
|
|
miDelete = miDeleteList
|
|
|
|
miAllowAdd :: ListPosition
|
|
-> Natural
|
|
-> ListLength
|
|
-> Bool
|
|
miAllowAdd _ _ _ = True
|
|
|
|
miAddEmpty :: ListPosition
|
|
-> Natural
|
|
-> ListLength
|
|
-> Set ListPosition
|
|
miAddEmpty _ _ _ = Set.empty
|
|
|
|
miButtonAction :: forall p.
|
|
PathPiece p
|
|
=> p
|
|
-> Maybe (SomeRoute UniWorX)
|
|
miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
|
|
|
|
miLayout :: ListLength
|
|
-> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load))
|
|
-> Map ListPosition Widget
|
|
-> Map ListPosition (FieldView UniWorX)
|
|
-> Map (Natural, ListPosition) Widget
|
|
-> Widget
|
|
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
|
|
|
|
miIdent :: Text
|
|
miIdent = "correctors"
|
|
|
|
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Loads
|
|
postProcess = Map.fromList . map postProcess' . Map.elems
|
|
where
|
|
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> (Either UserEmail UserId, (InvitationDBData SheetCorrector, InvitationTokenData SheetCorrector))
|
|
postProcess' = over _2 $ \(cState, load) -> (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)
|
|
|
|
filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
|
|
filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!
|
|
|
|
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) False filledData
|