-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Winnie Ros -- -- 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
_{MsgSheetPersonalisedFilesDownloadTemplateHere}
^{modal downloadTrigger (Left (SomeRoute downloadRoute))} $maybe lRoute <- listRoute

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