From 6e7e8a2b207c482936b835f7674bceed1e1ff281 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Wed, 9 Jun 2021 14:09:40 +0200 Subject: [PATCH] refactor(sheets): prepare for sheet-scoped statements --- models/sheets.model | 4 +-- src/Handler/Sheet/Edit.hs | 51 +++++++++++++++++++++++------------- src/Handler/Sheet/Form.hs | 53 ++++++++++++++++++++++++++++++-------- src/Handler/Sheet/New.hs | 12 ++++----- src/Handler/Sheet/Show.hs | 4 +-- templates/sheetShow.hamlet | 10 +++---- 6 files changed, 90 insertions(+), 44 deletions(-) diff --git a/models/sheets.model b/models/sheets.model index 6b78c7d36..796ebbe76 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -15,7 +15,7 @@ Sheet -- exercise sheet for a given course anonymousCorrection Bool default=true requireExamRegistration ExamId Maybe -- Students may only submit if they are registered for the given exam allowNonPersonalisedSubmission Bool default=true - authorshipStatement AuthorshipStatementDefinitionId Maybe +-- authorshipStatement AuthorshipStatementDefinitionId Maybe -- TODO: sheet-specific authorship statement; for exam-unrelated sheets and for exam setting overrides CourseSheet course name deriving Generic SheetEdit -- who edited when a row in table "Course", kept indefinitely @@ -65,4 +65,4 @@ FallbackPersonalisedSheetFilesKey secret ByteString generated UTCTime UniqueFallbackPersonalisedSheetFilesKey course index - deriving Generic \ No newline at end of file + deriving Generic diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs index bf6e031c8..7e370a960 100644 --- a/src/Handler/Sheet/Edit.hs +++ b/src/Handler/Sheet/Edit.hs @@ -22,15 +22,20 @@ import Handler.Sheet.PersonalisedFiles getSEditR, postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSEditR = postSEditR postSEditR tid ssh csh shn = do - (Entity sid Sheet{..}, sheetFileIds, currentLoads, hasPersonalisedFiles, mAuthorshipStatement) <- runDB $ do - ent@(Entity sid Sheet{..}) <- fetchSheet tid ssh csh shn + (Entity sid Sheet{..}, sheetFileIds, currentLoads, hasPersonalisedFiles) <- runDB $ do + ent@(Entity sid _) <- fetchSheet tid ssh csh shn fti <- getFtIdMap $ entityKey ent cLoads <- Map.union <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (InvDBDataSheetCorrector sheetCorrectorLoad sheetCorrectorState, InvTokenDataSheetCorrector)) (selectList [ SheetCorrectorSheet ==. sid ] []) <*> fmap (fmap (, InvTokenDataSheetCorrector) . Map.mapKeysMonotonic Left) (sourceInvitationsF sid) hasPersonalisedFiles <- exists [ PersonalisedSheetFileSheet ==. sid ] - mAuthorshipStatement <- maybe (pure Nothing) get sheetAuthorshipStatement - return (ent, fti, cLoads, hasPersonalisedFiles, mAuthorshipStatement) + -- TODO: update statement if school authorship statement was updated? + -- mSchoolAuthorshipStatement <- runMaybeT $ do + -- Entity _ School{..} <- MaybeT . getEntity $ ssh + -- definitionId <- MaybeT . return $ schoolSheetAuthorshipStatementDefinition + -- MaybeT . getEntity $ definitionId + -- mAuthorshipStatement <- maybe (pure Nothing) getEntity sheetAuthorshipStatement + return (ent, fti, cLoads, hasPersonalisedFiles) let template = Just $ SheetForm { sfName = sheetName , sfDescription = sheetDescription @@ -56,7 +61,6 @@ postSEditR tid ssh csh shn = do , spffAllowNonPersonalisedSubmission = sheetAllowNonPersonalisedSubmission , spffFiles = Nothing } - , sfAuthorshipStatement = authorshipStatementDefinitionContent <$> mAuthorshipStatement } let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead @@ -73,18 +77,29 @@ handleSheetEdit tid ssh csh msId template dbAction = do saveOkay <- runDBJobs $ do actTime <- liftIO getCurrentTime - let insertNewOrKeepStatement mNewStatement = do - mOldAuthorshipStatement <- runMaybeT $ do - sId <- MaybeT . return $ msId - Entity _ Sheet{..} <- MaybeT $ getEntity sId - statementId <- MaybeT . return $ sheetAuthorshipStatement - MaybeT $ getEntity statementId - if - | Just newDef@(AuthorshipStatementDefinition newContent) <- mNewStatement - , maybe True ((/=) newContent . authorshipStatementDefinitionContent . entityVal) mOldAuthorshipStatement - -> Just <$> (insert newDef) - | otherwise -> return $ entityKey <$> mOldAuthorshipStatement - mNewAuthorshipStatementId <- insertNewOrKeepStatement $ AuthorshipStatementDefinition <$> sfAuthorshipStatement + -- let insertNewOrKeepStatement = \case + -- -- statement disabled: + -- Nothing -> pure Nothing + -- -- use school preset (i.e. return the id of a *copy*): + -- Just Nothing -> runMaybeT $ do + -- Entity _ School{..} <- MaybeT . getEntity $ ssh + -- schoolStatementId <- MaybeT . return $ schoolSheetAuthorshipStatementDefinition + -- Entity _ AuthorshipStatementDefinition{..} <- MaybeT . getEntity $ schoolStatementId + -- lift . insert $ AuthorshipStatementDefinition authorshipStatementDefinitionContent + -- -- use custom statement: + -- Just (Just newContent) -> do + -- mOldAuthorshipStatement <- runMaybeT $ do + -- sId <- MaybeT . return $ msId + -- Entity _ Sheet{..} <- MaybeT . getEntity $ sId + -- statementId <- MaybeT . return $ sheetAuthorshipStatement + -- MaybeT . getEntity $ statementId + -- if + -- -- statement modified: insert new statement + -- | maybe True ((/=) newContent . authorshipStatementDefinitionContent . entityVal) mOldAuthorshipStatement + -- -> Just <$> (insert $ AuthorshipStatementDefinition newContent) + -- -- statement not modified: return id of old statement + -- | otherwise -> return $ entityKey <$> mOldAuthorshipStatement + -- mNewAuthorshipStatementId <- insertNewOrKeepStatement sfAuthorshipStatement let newSheet = Sheet { sheetCourse = cid @@ -103,7 +118,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do , sheetAnonymousCorrection = sfAnonymousCorrection , sheetRequireExamRegistration = sfRequireExamRegistration , sheetAllowNonPersonalisedSubmission = maybe True spffAllowNonPersonalisedSubmission sfPersonalF - , sheetAuthorshipStatement = mNewAuthorshipStatementId + -- , sheetAuthorshipStatement = Nothing -- TODO: implement sheet-specific statements } mbsid <- dbAction newSheet case mbsid of diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs index 9d827f9a9..4a1bcd754 100644 --- a/src/Handler/Sheet/Form.hs +++ b/src/Handler/Sheet/Form.hs @@ -42,7 +42,7 @@ data SheetForm = SheetForm , sfMarkingText :: Maybe StoredMarkup , sfAnonymousCorrection :: Bool , sfCorrectors :: Loads - , sfAuthorshipStatement :: Maybe StoredMarkup + -- , sfAuthorshipStatement :: Maybe (Either AuthorshipStatementDefinitionId StoredMarkup) -- TODO: exam-unrelated statement, override for exam setting } data SheetPersonalisedFilesForm = SheetPersonalisedFilesForm @@ -66,12 +66,14 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS (Just sId) -> liftHandler $ runDB $ getFtIdMap sId MsgRenderer mr <- getMsgRenderer ctime <- ceilingQuarterHour <$> liftIO getCurrentTime - mSchoolAuthorshipStatement <- liftHandler . runDB . runMaybeT $ do - Entity _ Course{courseSchool} <- MaybeT . getEntity $ cId - Entity _ School{..} <- MaybeT . getEntity $ courseSchool - statementId <- MaybeT . return $ bool Nothing schoolSheetAuthorshipStatementDefinition (schoolSheetAuthorshipStatementMode /= SchoolAuthorshipStatementModeNone) - MaybeT . getEntity $ statementId - -- TODO: compare versions: school > msId if school statement is newer than msId statement, msId > school otherwise (TODO: add lastEdited to model) + -- TODO: use + ((_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 flip (renderAForm FormStandard) html $ SheetForm <$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template) @@ -104,8 +106,37 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template) <*> correctorForm (maybe mempty sfCorrectors template) - <* aformSection MsgSheetAuthorshipStatement - <*> optionalActionA (apreq htmlField (fslI MsgSheetAuthorshipStatement) (join (sfAuthorshipStatement <$> template) <|> authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement)) (fslI MsgSheetAuthorshipStatementRequired & setTooltip MsgSheetAuthorshipStatementRequiredTip) ((is _Just . sfAuthorshipStatement <$> template) <|> (pure $ is _Just mSchoolAuthorshipStatement)) -- TODO: disable option and set accordingly if school mode prevents edits + -- <* aformSection MsgSheetAuthorshipStatementSection + -- TODO: add info: applies to exam-unrelated sheets only, will be overriden if sheet is related to an exam and this exam has an authorship statement + -- TODO: compare versions: school > msId if school statement is newer than msId statement, msId > school otherwise (TODO: add lastEdited to model) + -- <*> optionalActionA + -- ( optionalActionA + -- ( apreq htmlField + -- (fslI MsgSheetAuthorshipStatementCustom) + -- (join (join (sfAuthorshipStatement <$> template) <|> (Just . authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement))) + -- ) + -- ( fslI MsgSheetAuthorshipStatementUseSchoolDefault + -- & setTooltip MsgSheetAuthorshipStatementUseSchoolDefaultTip + -- -- TODO: disable if school mode prevents custom statements + -- -- & addAttr "disabled" "disabled" + -- ) + -- ( + -- -- TODO: set accordingly if school mode prevents custom statements + -- pure $ is _Just mSchoolAuthorshipStatement + -- ) + -- -- TODO: display current school statement + -- -- <* maybe (pure ()) (authorshipStatementDefinitionContent . entityVal) mSchoolAuthorshipStatement + -- ) + -- ( fslI MsgSheetAuthorshipStatementRequired + -- & setTooltip MsgSheetAuthorshipStatementRequiredTip + -- -- TODO: disable if school mode enforces/disables statements for this sheet + -- -- & addAttr "disabled" "disabled" + -- ) + -- ( + -- -- TODO: set accordingly if school mode enforces/disables statements for this sheet + -- -- TODO: school statement > template iff the school statement is newer + -- (is _Just . sfAuthorshipStatement <$> template) <|> (pure $ is _Just mSchoolAuthorshipStatement) + -- ) where makeSheetPersonalisedFilesForm :: Maybe SheetPersonalisedFilesForm -> MForm Handler (AForm Handler SheetPersonalisedFilesForm) makeSheetPersonalisedFilesForm template' = do @@ -165,8 +196,8 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS || sfType == NotGraded -- TODO: do authorship statement validation - -- TODO: if school mode is none or required for this sheet (exam-related/exam-umrelated?), statementRequired must be set accordingly - -- TODO: authorship statement definition must not be empty when statement is required + -- TODO: if school mode is none or required for this sheet (exam-related/exam-umrelated?), statement must be set accordingly (Just for required, Nothing for none) + -- TODO: if school prevents custom statements, statement must match current school statement correctorForm :: Loads -> AForm Handler Loads correctorForm loads' = wFormToAForm $ do diff --git a/src/Handler/Sheet/New.hs b/src/Handler/Sheet/New.hs index 3b2dc8ea1..e2fe398e0 100644 --- a/src/Handler/Sheet/New.hs +++ b/src/Handler/Sheet/New.hs @@ -38,16 +38,16 @@ postSheetNewR tid ssh csh = do firstEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId return . E.min_ $ sheetEdit E.^. SheetEditTime - mAuthorshipStatement = E.subSelect . E.from $ \authorshipStatementDefinition -> do - E.where_ $ E.just (authorshipStatementDefinition E.^. AuthorshipStatementDefinitionId) E.==. sheet E.^. SheetAuthorshipStatement - return $ authorshipStatementDefinition E.^. AuthorshipStatementDefinitionContent - return (sheet, firstEdit, mAuthorshipStatement) + -- mAuthorshipStatement = E.subSelect . E.from $ \authorshipStatementDefinition -> do + -- E.where_ $ E.just (authorshipStatementDefinition E.^. AuthorshipStatementDefinitionId) E.==. sheet E.^. SheetAuthorshipStatement + -- return $ authorshipStatementDefinition E.^. AuthorshipStatementDefinitionContent + return (sheet, firstEdit) cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh loads <- defaultLoads cid return (lSheets, loads) now <- liftIO getCurrentTime let template = case lastSheets of - ((Entity {entityVal=Sheet{..}}, E.Value fEdit, E.Value mAuthorshipStatement):_) -> + ((Entity {entityVal=Sheet{..}}, E.Value fEdit):_) -> let addTime = addWeeks $ max 1 $ weeksToAdd (fromMaybe (UTCTime systemEpochDay 0) $ sheetActiveTo <|> fEdit) now in Just $ SheetForm { sfName = stepTextCounterCI sheetName @@ -70,7 +70,7 @@ postSheetNewR tid ssh csh = do , sfAnonymousCorrection = sheetAnonymousCorrection , sfRequireExamRegistration = Nothing , sfPersonalF = Nothing - , sfAuthorshipStatement = mAuthorshipStatement + -- , sfAuthorshipStatement = mAuthorshipStatement } _other -> Nothing let action = -- More specific error message for new sheet could go here, if insertUnique returns Nothing diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs index 772649a4e..1fdaaab21 100644 --- a/src/Handler/Sheet/Show.hs +++ b/src/Handler/Sheet/Show.hs @@ -22,8 +22,8 @@ getSShowR tid ssh csh shn = do Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility - mayEdit <- hasWriteAccessTo $ CSheetR tid ssh csh shn SEditR - maySubmit <- hasWriteAccessTo $ CSheetR tid ssh csh shn SubmissionNewR + -- mayEdit <- hasWriteAccessTo $ CSheetR tid ssh csh shn SEditR + -- maySubmit <- hasWriteAccessTo $ CSheetR tid ssh csh shn SubmissionNewR let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a sftVisible sft | Just dts <- sheetFileTypeDates sheet sft diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index fd378a60a..ec8c6e259 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -70,11 +70,11 @@ $maybe descr <- sheetDescription sheet _{MsgTableSheetType}
^{sTypeDesc tr} - $if mayEdit || maySubmit -
- _{MsgSheetAuthorshipStatementSection} -
- _{maybe MsgSheetAuthorshipStatementIsRequiredFalse (const MsgSheetAuthorshipStatementIsRequiredTrue) (sheetAuthorshipStatement sheet)} +$# $if mayEdit || maySubmit +$#
+$# _{MsgSheetAuthorshipStatementSection} +$#
+$# _{maybe MsgSheetAuthorshipStatementIsRequiredFalse (const MsgSheetAuthorshipStatementIsRequiredTrue) (sheetAuthorshipStatement sheet)} $maybe marktxt <- markingText