fradrive/src/Handler/Sheet/Form.hs

354 lines
20 KiB
Haskell

-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -Wwarn #-}
module Handler.Sheet.Form
( SheetForm(..), SheetPersonalisedFilesForm(..), Loads
, makeSheetForm
, getFtIdMap
) where
import Import
import Handler.Utils
import Handler.Utils.Invitations
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils 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 StoredMarkup
, 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 ExamPartId
, sfAutoDistribute :: Bool
, sfMarkingText :: Maybe StoredMarkup
, sfAnonymousCorrection :: Bool
, sfCorrectors :: Loads
, sfAuthorshipStatementMode :: SheetAuthorshipStatementMode
, sfAuthorshipStatementExam :: Maybe ExamId
, sfAuthorshipStatement :: Maybe I18nStoredMarkup
}
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
mr'@(MsgRenderer mr) <- getMsgRenderer
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
((School{..}, mSchoolAuthorshipStatement), _course) <- liftHandler . runDB $ do
course@Course{courseSchool} <- get404 cId
school@School{..} <- get404 courseSchool
mSchoolAuthorshipStatement <- runMaybeT $ do
statementId <- MaybeT . return $ schoolSheetAuthorshipStatementDefinition
MaybeT . getEntity $ statementId
return ((school, mSchoolAuthorshipStatement), course)
sheetPersonalisedFilesForm <- makeSheetPersonalisedFilesForm $ template >>= sfPersonalF
let mkSheetForm
sfName
sfDescription
sfRequireExamRegistration
sfSheetF sfHintF sfSolutionF sfMarkingF
sfPersonalF sfVisibleFrom sfActiveFrom sfActiveTo sfHintFrom sfSolutionFrom
sfSubmissionMode sfGrouping sfType
sfAutoDistribute sfMarkingText sfAnonymousCorrection sfCorrectors
(sfAuthorshipStatementMode, sfAuthorshipStatementExam, sfAuthorshipStatement)
= SheetForm{..}
flip (renderAForm FormStandard) html $ mkSheetForm
<$> 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 False))
<*> sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups)
<*> sheetTypeAFormReq cId (fslI MsgSheetSheetType) (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)
<*> let sfAuthorshipStatementExam' = sfAuthorshipStatementExam =<< template
sfAuthorshipStatement' = sfAuthorshipStatement =<< template
in wFormToAForm $ (\res -> (,,) <$> view _1 res <*> view _2 res <*> view _3 res) <$>
if | isn't _SchoolAuthorshipStatementModeNone schoolSheetAuthorshipStatementMode -> do
wformSection MsgSheetAuthorshipStatementSection
let
reqContentField :: AForm Handler I18nStoredMarkup
reqContentField = formResultUnOpt mr' MsgSheetAuthorshipStatementContent
`fmapAForm` i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text)
(fslI MsgSheetAuthorshipStatementContent)
True
( fmap Just $ (sfAuthorshipStatement =<< template)
<|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement)
)
forcedContentField = wforced forcedAuthorshipStatementField (fslI MsgSheetAuthorshipStatementContent & setTooltip MsgSheetAuthorshipStatementContentForcedTip)
if | not schoolSheetAuthorshipStatementAllowOther
-> (pure SheetAuthorshipStatementModeEnabled, pure sfAuthorshipStatementExam', )
<$> (fmap (traverse $ fmap authorshipStatementDefinitionContent) . traverse forcedContentField $ entityVal <$> mSchoolAuthorshipStatement)
| otherwise -> do
examOpts <-
let examFieldQuery = E.from $ \exam -> do
E.where_ $ exam E.^. ExamCourse E.==. E.val cId
when (is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode) $
E.where_ . E.isJust $ exam E.^. ExamAuthorshipStatement
return exam
in liftHandler $ optionsCryptoIdE examFieldQuery examName
let modeOpts = case schoolSheetAuthorshipStatementMode of
SchoolAuthorshipStatementModeNone -> Set.singleton SheetAuthorshipStatementModeDisabled
SchoolAuthorshipStatementModeOptional -> Set.fromList universeF
SchoolAuthorshipStatementModeRequired -> Set.fromList universeF
& Set.delete SheetAuthorshipStatementModeDisabled
& bool id (Set.delete SheetAuthorshipStatementModeExam) (hasn't (_olOptions . folded) examOpts)
modeOpts' = explainOptionList (optionsPathPiece . map (id &&& id) $ Set.toList modeOpts) $ \case
SheetAuthorshipStatementModeDisabled -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/disabled")
SheetAuthorshipStatementModeExam -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/exam")
SheetAuthorshipStatementModeEnabled -> return $(i18nWidgetFile "sheet-authorship-statement-mode-tip/enabled")
examField' = selectField' (Just $ SomeMessage MsgSheetAuthorshipStatementExamNone) . return $ entityKey <$> examOpts
examField'' :: AForm Handler (Maybe ExamId)
examField''
| isn't _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode
= aopt examField' (fslI MsgSheetAuthorshipStatementExam) (sfAuthorshipStatementExam <$> template)
| otherwise
= Just <$> apreq examField' (fslI MsgSheetAuthorshipStatementExam) (sfAuthorshipStatementExam =<< template)
modeForms = flip Map.fromSet modeOpts $ \case
SheetAuthorshipStatementModeDisabled -> pure
( SheetAuthorshipStatementModeDisabled
, sfAuthorshipStatementExam'
, sfAuthorshipStatement'
)
SheetAuthorshipStatementModeExam -> (SheetAuthorshipStatementModeExam,, )
<$> examField''
<*> pure sfAuthorshipStatement'
SheetAuthorshipStatementModeEnabled -> (SheetAuthorshipStatementModeEnabled, sfAuthorshipStatementExam', )
<$> fmap Just reqContentField
massage res = (view _1 <$> res, view _2 <$> res, view _3 <$> res)
massage <$> explainedMultiActionW modeForms modeOpts' (fslI MsgSheetAuthorshipStatementRequired & setTooltip (bool MsgSheetAuthorshipStatementRequiredTip MsgSheetAuthorshipStatementRequiredForcedTip $ is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode)) (sfAuthorshipStatementMode <$> template)
| otherwise -> return
( pure SheetAuthorshipStatementModeDisabled
, pure sfAuthorshipStatementExam'
, pure sfAuthorshipStatement'
)
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}
\ _{MsgSheetPersonalisedFilesDownload}
|]
listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl
( CourseR courseTerm courseSchool courseShorthand CUsersR
, [ ("courseUsers-has-personalised-sheet-files"
, toPathPiece shn
)
]
)
guardM . lift $ 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 True) (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{..}) -> fromMaybe False 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
-> ListLength
-> (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 MsgSheetCorrector (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
(deficitRes, deficitView) <- mreq checkBoxField ("" & addName (nudge "deficit")) $ ((/= 0) . byDeficit . snd <$> initRes) <|> Just True
(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 <*> deficitRes')
tutRes'
| FormSuccess True <- byTutRes = Just <$> countTutRes
| otherwise = Nothing <$ byTutRes
deficitRes' = bool 0 1 <$> deficitRes
identWidget <- case userIdent of
Left email -> return . toWidget $ mailtoHtml email
Right uid -> do
usr <- liftHandler . runDB $ getJust uid
return $ userEmailWidget usr
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
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