#{tshow res} |] + + i18nIdent <- newIdent + let i18nForm' = wrapForm i18nWidget FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ AdminTestR :#: i18nIdent + , formEncoding = i18nEnc + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just i18nIdent + } + [whamlet| +
+ #{toYAML res}
+ |]
[whamlet|
diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs
index 39d909ee6..8809c034a 100644
--- a/src/Handler/Allocation/Accept.hs
+++ b/src/Handler/Allocation/Accept.hs
@@ -109,12 +109,12 @@ allocationAcceptForm aId = runMaybeT $ do
let
showTerms
- | [_] <- nubOn (view $ _1 . _2 . _entityVal . _courseTerm) allocationCourses'
+ | [_] <- nubOrdOn (view $ _1 . _2 . _entityVal . _courseTerm) allocationCourses'
= False
| otherwise
= True
showSchools
- | [_] <- nubOn (view $ _1 . _2 . _entityVal . _courseSchool) allocationCourses'
+ | [_] <- nubOrdOn (view $ _1 . _2 . _entityVal . _courseSchool) allocationCourses'
= False
| otherwise
= True
diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs
index eb348e266..f034eccd6 100644
--- a/src/Handler/Allocation/Show.hs
+++ b/src/Handler/Allocation/Show.hs
@@ -118,7 +118,7 @@ postAShowR tid ssh ash = do
wouldNotifyNewCourse <- fmap (maybe False E.unValue . join) . for muid $ E.selectMaybe . pure . allocationNotifyNewCourses (E.val aId) . E.val
- return (alloc, school, isAnyLecturer, isAdmin, nubOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse)
+ return (alloc, school, isAnyLecturer, isAdmin, nubOrdOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse)
let nextSubstitutesDeadline = minimumOf (folded . resultAllocationCourse . _allocationCourseAcceptSubstitutes . _Just . filtered (>= now)) courses
freeCapacity = fmap getSum . getAp . flip foldMap courses $ \cEntry -> Ap . fmap (Sum . max 0) $ subtract (cEntry ^. resultParticipantCount) <$> preview (resultCourse . _entityVal . _courseCapacity . _Just) cEntry
diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs
index 7b86b1a61..d637eb50a 100644
--- a/src/Handler/Course/Application/List.hs
+++ b/src/Handler/Course/Application/List.hs
@@ -612,7 +612,7 @@ postCApplicationsR tid ssh csh = do
sortedApplications <- unstableSortBy cmp applications
let applicants = sortedApplications
- & nubOn (view $ _1 . _entityKey)
+ & nubOrdOn (view $ _1 . _entityKey)
& maybe id take openCapacity
& setOf (case invMode of
AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right
diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs
index 5973c7043..fb426ca94 100644
--- a/src/Handler/Course/Edit.hs
+++ b/src/Handler/Course/Edit.hs
@@ -121,7 +121,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
return (lecturerSchools, adminSchools, oldSchool)
- let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
+ let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
(termsField, userTerms) <- liftHandler $ case template of
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
@@ -136,8 +136,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
-> return (termsSetField [cfTerm cform], [cfTerm cform])
_allOtherCases -> (termsAllowedField, ) . Set.toList <$> runDB getActiveTerms
- let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
- miAdd _ _ nudge btn = Just $ \csrf -> do
+ let miAdd :: ListPosition -> Natural -> ListLength -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+ miAdd _ _ _ nudge btn = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserInvitationField $ MUILookupAnyUser Nothing) (fslI MsgCourseLecturerEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
let addRes'' = addRes <&> \newDat oldDat -> if
| existing <- newDat `Set.intersection` Set.fromList (Map.elems oldDat)
@@ -165,9 +165,6 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
-> MaybeT (MForm (HandlerFor UniWorX)) (Map ListPosition ListPosition)
miDelete = miDeleteList
- miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
- miAllowAdd _ _ _ = True
-
miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
miAddEmpty _ _ _ = Set.empty
diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs
index 30ef678c2..7ef122422 100644
--- a/src/Handler/Course/User.hs
+++ b/src/Handler/Course/User.hs
@@ -240,10 +240,11 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
-courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do
+courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid User{..}) = do
guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR
- let whereClause = (E.&&.) <$> courseIs cid <*> userIs uid
+ let whereClause :: CorrectionTableWhere
+ whereClause = (E.&&.) <$> courseIs cid <*> userIs uid
colonnade = mconcat -- should match getSSubsR for consistent UX
[ colSelect
, colSheet
@@ -256,18 +257,24 @@ courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do
, colCorrector
, colAssigned
] -- Continue here
- filterUI = Just $ \mPrev -> mconcat
- [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseCourseMembers)
- , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr)
- -- "pseudonym" TODO DB only stores Word24
- , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
- , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgTableCorrector)
- , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector)
- , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime)
- , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
+ filterUI = Just $ mconcat
+ [ filterUIUserNameEmail
+ , filterUIUserMatrikelnummer
+ , filterUIPseudonym
+ , filterUISheetSearch
+ , filterUICorrectorNameEmail
+ , filterUIIsAssigned
+ , filterUIIsRated
+ , filterUISubmission
]
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
- (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI psValidator $ Map.fromList
+ csvSettings = Just CorrectionTableCsvSettings
+ { cTableCsvQualification = CorrectionTableCsvQualifySheet
+ , cTableCsvName = MsgCorrectionTableCsvNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName
+ , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName
+ , cTableShowCorrector = True
+ }
+ (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI csvSettings psValidator $ Map.fromList
[ downloadAction
, assignAction (Left cid)
, deleteAction
diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs
index e9d2eb811..0d25a488b 100644
--- a/src/Handler/Course/Users.hs
+++ b/src/Handler/Course/Users.hs
@@ -197,17 +197,13 @@ instance Csv.ToNamedRecord UserTableCsv where
, "email" Csv..= csvUserEmail
, "study-features" Csv..= csvUserStudyFeatures
, "submission-group" Csv..= csvUserSubmissionGroup
- ] ++
- [ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1
- in "tutorial" Csv..= tutsStr
+ , "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1)
] ++
[ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut)
| (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2
] ++
- [ let examsStr = Text.intercalate "; " $ map CI.original csvUserExams
- in "exams" Csv..= examsStr
- ] ++
- [ "registration" Csv..= csvUserRegistration
+ [ "exams" Csv..= CsvSemicolonList csvUserExams
+ , "registration" Csv..= csvUserRegistration
] ++
[ encodeUtf8 (CI.foldedCase shn) Csv..= res
| (shn, res) <- Map.toList csvUserSheets
@@ -623,7 +619,7 @@ postCUsersR tid ssh csh = do
, E.desc $ sheet E.^. SheetActiveFrom
]
return $ sheet E.^. SheetName
- let exams = nubOn entityKey $ examOccurrencesPerExam ^.. folded . _1
+ let exams = nubOrdOn entityKey $ examOccurrencesPerExam ^.. folded . _1
let colChoices = mconcat $ catMaybes
[ pure . cap' $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, pure . cap' $ colUserNameLink (CourseR tid ssh csh . CUserR)
diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs
index 5ecffe1f0..dd4bba89f 100644
--- a/src/Handler/Exam/Edit.hs
+++ b/src/Handler/Exam/Edit.hs
@@ -40,6 +40,7 @@ postEEditR tid ssh csh examn = do
editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> do
res <- trySql @ExamEditException $ do
+ examAuthorshipStatement <- traverse insertAuthorshipStatement efAuthorshipStatement
insertRes <- myReplaceUnique eId Exam
{ examCourse = cid
, examName = efName
@@ -62,6 +63,7 @@ postEEditR tid ssh csh examn = do
, examExamMode = efExamMode
, examStaff = efStaff
, examPartsFrom = efPartsFrom
+ , examAuthorshipStatement
}
when (is _Just insertRes) $
diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs
index 9801ab658..927f98bac 100644
--- a/src/Handler/Exam/Form.hs
+++ b/src/Handler/Exam/Form.hs
@@ -52,6 +52,7 @@ data ExamForm = ExamForm
, efStaff :: Maybe Text
, efCorrectors :: Set (Either UserEmail UserId)
, efExamParts :: Set ExamPartForm
+ , efAuthorshipStatement :: Maybe I18nStoredMarkup
}
data ExamOccurrenceForm = ExamOccurrenceForm
@@ -110,8 +111,11 @@ examForm :: ( MonadHandler m
)
=> Entity Course -> Maybe ExamForm -> (Html -> MForm m (FormResult ExamForm, Widget))
examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do
- MsgRenderer mr <- getMsgRenderer
- School{..} <- liftHandler . runDBRead $ getJust courseSchool
+ mr'@(MsgRenderer mr) <- getMsgRenderer
+ (School{..}, mSchoolAuthorshipStatement) <- liftHandler . runDBRead $ do
+ school@School{..} <- getJust courseSchool
+ mSchoolAuthorshipStatement <- maybe (pure Nothing) getEntity schoolSheetExamAuthorshipStatementDefinition
+ return (school, mSchoolAuthorshipStatement)
flip (renderAForm FormStandard) csrf $ ExamForm
<$> areq ciField (fslpI MsgTableExamName (mr MsgTableExamName) & setTooltip MsgExamNameTip) (efName <$> template)
@@ -143,6 +147,31 @@ examForm (Entity _ Course{..}) template csrf = hoist liftHandler $ do
<*> examCorrectorsForm (efCorrectors <$> template)
<* aformSection MsgExamFormParts
<*> examPartsForm (efExamParts <$> template)
+ <*> let
+ reqContentField :: (FieldSettings UniWorX -> FieldSettings UniWorX) -> AForm Handler I18nStoredMarkup
+ reqContentField ttip = fmapAForm (formResultUnOpt mr' MsgSheetAuthorshipStatementContent)
+ $ i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text)
+ (fslI MsgSheetAuthorshipStatementContent & ttip)
+ True
+ ( fmap Just $ (efAuthorshipStatement =<< template)
+ <|> (authorshipStatementDefinitionContent . entityVal <$> mSchoolAuthorshipStatement)
+ )
+ forcedContentField = aforced forcedAuthorshipStatementField
+ (fslI MsgExamAuthorshipStatementContent & setTooltip MsgExamAuthorshipStatementContentForcedTip)
+ contentField ttipReq
+ | not schoolSheetExamAuthorshipStatementAllowOther
+ = fmap (fmap authorshipStatementDefinitionContent) . traverse forcedContentField $ entityVal <$> mSchoolAuthorshipStatement
+ | otherwise
+ = Just <$> reqContentField ttipReq
+ in case schoolSheetExamAuthorshipStatementMode of
+ SchoolAuthorshipStatementModeNone -> pure Nothing -- suppress display of whole section incl. header
+ otherMode -> aformSection MsgExamAuthorshipStatementSection
+ *> case otherMode of
+ SchoolAuthorshipStatementModeOptional -> optionalActionA (fmapAForm (formResultUnOpt mr' MsgSheetAuthorshipStatementContent) $ contentField id)
+ (fslI MsgExamAuthorshipStatementRequired & setTooltip MsgExamAuthorshipStatementRequiredTip)
+ ((is _Just . efAuthorshipStatement <$> template) <|> Just (is _Just mSchoolAuthorshipStatement))
+ SchoolAuthorshipStatementModeRequired -> contentField $ setTooltip MsgExamAuthorshipStatementRequiredForcedTip
+ _none -> pure Nothing
officeSchoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId)
officeSchoolsForm mPrev = wFormToAForm $ do
@@ -316,6 +345,8 @@ examFormTemplate (Entity eId Exam{..}) = do
examParts' <- forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
+ mAuthorshipStatement <- maybe (pure Nothing) getEntity examAuthorshipStatement
+
return ExamForm
{ efName = examName
, efGradingRule = examGradingRule
@@ -363,6 +394,7 @@ examFormTemplate (Entity eId Exam{..}) = do
, efExamMode = examExamMode
, efOfficeSchools = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools
, efStaff = examStaff
+ , efAuthorshipStatement = authorshipStatementDefinitionContent . entityVal <$> mAuthorshipStatement
}
examTemplate :: MonadHandler m
@@ -370,8 +402,9 @@ examTemplate :: MonadHandler m
examTemplate cid = runMaybeT $ do
newCourse <- MaybeT $ get cid
- [(Entity _ oldCourse, Entity oldExamId oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do
+ [(Entity _ oldCourse, Entity oldExamId oldExam, mOldExamAuthorshipStatement)] <- lift . E.select . E.from $ \(course `E.InnerJoin` (exam `E.LeftOuterJoin` authorshipStatementDefinition)) -> do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+ E.on $ exam E.^. ExamAuthorshipStatement E.==. authorshipStatementDefinition E.?. AuthorshipStatementDefinitionId
E.where_ $ ( course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse)
E.||. course E.^. CourseName E.==. E.val (courseName newCourse)
)
@@ -382,7 +415,7 @@ examTemplate cid = runMaybeT $ do
E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom
E.limit 1
E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ]
- return (course, exam)
+ return (course, exam, authorshipStatementDefinition)
extraSchools <- lift $ selectList [ ExamOfficeSchoolExam ==. oldExamId ] []
@@ -415,6 +448,7 @@ examTemplate cid = runMaybeT $ do
, efExamMode = examExamMode oldExam
, efStaff = examStaff oldExam
, efOfficeSchools = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools
+ , efAuthorshipStatement = authorshipStatementDefinitionContent . entityVal <$> mOldExamAuthorshipStatement
}
diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs
index 4c20fe692..c3a8c6fc7 100644
--- a/src/Handler/Exam/New.hs
+++ b/src/Handler/Exam/New.hs
@@ -29,6 +29,8 @@ postCExamNewR tid ssh csh = do
newExamAct <- formResultMaybe newExamResult $ \ExamForm{..} -> do
now <- liftIO getCurrentTime
+ examAuthorshipStatement <- traverse insertAuthorshipStatement efAuthorshipStatement
+
insertRes <- insertUnique Exam
{ examName = efName
, examCourse = cid
@@ -51,6 +53,7 @@ postCExamNewR tid ssh csh = do
, examExamMode = efExamMode
, examStaff = efStaff
, examPartsFrom = efPartsFrom
+ , examAuthorshipStatement
}
whenIsJust insertRes $ \examid -> do
insertMany_
diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs
index 79e6da3a4..baf745264 100644
--- a/src/Handler/ExamOffice/Users.hs
+++ b/src/Handler/ExamOffice/Users.hs
@@ -101,7 +101,7 @@ makeExamOfficeUsersForm template = renderWForm FormStandard $ do
| null newUsers
-> pure oldUsers
| otherwise
- -> pure . nub $ oldUsers ++ Set.toList newUsers
+ -> pure . nubOrd $ oldUsers ++ Set.toList newUsers
return (res', $(widgetFile "widgets/massinput/examOfficeUsers/add"))
miCell' :: Either UserEmail UserId -> Widget
miCell' (Left email) = do
diff --git a/src/Handler/ExternalExam/Form.hs b/src/Handler/ExternalExam/Form.hs
index 5c278e3ad..da5fd6a32 100644
--- a/src/Handler/ExternalExam/Form.hs
+++ b/src/Handler/ExternalExam/Form.hs
@@ -46,7 +46,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
adminSchools <- filterM (hasWriteAccessTo . flip SchoolR SchoolEditR) protoAdminSchools
let oldSchool = eefSchool <$> template
return (lecturerSchools, adminSchools, oldSchool)
- let userSchools = nub . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
+ let userSchools = nubOrd . maybe id (:) oldSchool $ lecturerSchools ++ adminSchools
templateSchool = eefSchool <$> template <|> case userSchools of
[ssh] -> pure ssh
_ -> mzero
diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs
index 2e0e961b5..021ab7865 100644
--- a/src/Handler/Material.hs
+++ b/src/Handler/Material.hs
@@ -18,6 +18,7 @@ import qualified Data.CaseInsensitive as CI
-- import qualified Data.Text.Encoding as Text
import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Utils as E
import Utils.Form
import Handler.Utils
@@ -97,22 +98,31 @@ getMaterialListR tid ssh csh = do
MsgRenderer mr <- getMsgRenderer
table <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+ let typeOptions :: HandlerFor UniWorX (OptionList Text)
+ typeOptions = do
+ previouslyUsed <- runDB $
+ E.select $ E.from $ \material ->
+ E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do
+ E.where_ $ material E.^. MaterialCourse E.==. E.val cid
+ E.&&. E.not_ (E.isNothing $ material E.^. MaterialType)
+ return $ material E.^. MaterialType
+ return . mkOptionList . map (\(CI.original -> t) -> Option t t t) . Set.toAscList . Set.fromList $ mapMaybe E.unValue previouslyUsed
let row2material = view $ _dbrOutput . _1 . _entityVal
psValidator = def & defaultSorting [SortDescBy "last-edit"]
& forceFilter "may-access" (Any True)
dbTableWidget' psValidator DBTable
{ dbtIdent = "material-list" :: Text
- , dbtStyle = def
+ , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtParams = def
- , dbtSQLQuery = \material -> do
+ , dbtSQLQuery = \material -> do
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
let filesNum :: E.SqlExpr (E.Value Int64)
filesNum = E.subSelectCount . E.from $ \materialFile ->
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
return (material, filesNum)
, dbtRowKey = (E.^. MaterialId)
- , dbtProj = dbtProjFilteredPostId
- , dbtColonnade = widgetColonnade $ mconcat
+ , dbtProj = dbtProjFilteredPostId
+ , dbtColonnade = widgetColonnade $ mconcat
[ -- dbRow,
sortable (Just "type") (i18nCell MsgMaterialType)
$ foldMap (textCell . CI.original) . materialType . row2material
@@ -140,8 +150,17 @@ getMaterialListR tid ssh csh = do
, dbtFilter = mconcat
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr
-> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool
+ , singletonMap "name". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of
+ Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
+ Just needle -> E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
+ , singletonMap "type-and-description". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of
+ Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
+ Just needle -> (E.maybe (E.val mempty) E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+ E.||. (E.maybe (E.val mempty) (E.castString.esqueletoMarkupOutput) (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
]
- , dbtFilterUI = mempty
+ , dbtFilterUI = \mPrev -> mconcat $ catMaybes
+ [ Just $ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch)
+ , Just $ prismAForm (singletonFilter "type-and-description") mPrev $ aopt (textField & addDatalist typeOptions) (fslI MsgFilterMaterialTypeAndDescriptionSearch)]
, dbtCsvEncode = noCsvEncode
, dbtCsvDecode = Nothing
, dbtExtraReps = []
@@ -389,4 +408,3 @@ getMArchiveR tid ssh csh mnm = do
let getMatQuery = materialArchiveSource tid ssh csh mnm
serveSomeFiles archiveName getMatQuery
-
diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs
index 6cadaa2a0..d5af2a26d 100644
--- a/src/Handler/Metrics.hs
+++ b/src/Handler/Metrics.hs
@@ -44,7 +44,7 @@ getMetricsR = selectRep $ do
-> suffix
| otherwise
= sName
- getLabels = nub . concatMap (\(Sample _ lPairs _) -> lPairs ^.. folded . _1)
+ getLabels = nubOrd . concatMap (\(Sample _ lPairs _) -> lPairs ^.. folded . _1)
singleSample base [Sample sName lPairs sValue]
| sName == base = Just (lPairs, sValue)
singleSample _ _ = Nothing
diff --git a/src/Handler/School.hs b/src/Handler/School.hs
index c6373ae23..72dd75bbf 100644
--- a/src/Handler/School.hs
+++ b/src/Handler/School.hs
@@ -68,6 +68,12 @@ data SchoolForm = SchoolForm
, sfExamRequireModeForRegistration :: Bool
, sfExamDiscouragedModes :: ExamModeDNF
, sfExamCloseMode :: ExamCloseMode
+ , sfSheetAuthorshipStatementMode :: SchoolAuthorshipStatementMode
+ , sfSheetAuthorshipStatementDefinition :: Maybe I18nStoredMarkup
+ , sfSheetAuthorshipStatementAllowOther :: Bool
+ , sfSheetExamAuthorshipStatementMode :: SchoolAuthorshipStatementMode
+ , sfSheetExamAuthorshipStatementDefinition :: Maybe I18nStoredMarkup
+ , sfSheetExamAuthorshipStatementAllowOther :: Bool
}
mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
@@ -75,11 +81,20 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
<$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh (textField & cfStrip & cfCI) (fslI MsgSchoolShort)
<*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template)
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") MsgSchoolLdapOrganisationMissing (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
+ <* aformSection MsgSchoolExamSection
<*> aopt daysField (fslI MsgSchoolExamMinimumRegisterBeforeStart & setTooltip MsgSchoolExamMinimumRegisterBeforeStartTip) (sfExamMinimumRegisterBeforeStart <$> template)
<*> aopt daysField (fslI MsgSchoolExamMinimumRegisterDuration & setTooltip MsgSchoolExamMinimumRegisterDurationTip) (sfExamMinimumRegisterDuration <$> template)
<*> apopt checkBoxField (fslI MsgSchoolExamRequireModeForRegistration & setTooltip MsgSchoolExamRequireModeForRegistration) (sfExamRequireModeForRegistration <$> template)
- <*> areq pathPieceField (fslI MsgSchoolExamDiscouragedModes) (sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse))
+ <*> (fromMaybe (ExamModeDNF predDNFFalse) <$> aopt pathPieceField (fslI MsgSchoolExamDiscouragedModes) (Just $ sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse)))
<*> apopt (selectField optionsFinite) (fslI MsgExamCloseMode) (sfExamCloseMode <$> template <|> pure ExamCloseSeparate)
+ <* aformSection MsgSchoolAuthorshipStatementSection
+ <*> apopt (selectField optionsFinite) (fslI MsgSchoolAuthorshipStatementSheetMode) (sfSheetAuthorshipStatementMode <$> template <|> pure SchoolAuthorshipStatementModeOptional)
+ <*> i18nFieldA htmlField False (\_ -> Nothing) ("sheet-authorship-statement-definition" :: Text) (fslI MsgSchoolAuthorshipStatementSheetDefinition & setTooltip MsgSchoolAuthorshipStatementSheetDefinitionTip) False (sfSheetAuthorshipStatementDefinition <$> template)
+ <*> apopt checkBoxField (fslI MsgSchoolAuthorshipStatementSheetAllowOther) (sfSheetAuthorshipStatementAllowOther <$> template <|> pure True)
+ <*> apopt (selectField optionsFinite) (fslI MsgSchoolAuthorshipStatementSheetExamMode) (sfSheetExamAuthorshipStatementMode <$> template <|> pure SchoolAuthorshipStatementModeOptional)
+ <*> i18nFieldA htmlField False (\_ -> Nothing) ("exam-authorship-statement-definition" :: Text) (fslI MsgSchoolAuthorshipStatementSheetExamDefinition & setTooltip MsgSchoolAuthorshipStatementSheetExamDefinitionTip) False (sfSheetExamAuthorshipStatementDefinition <$> template)
+ <*> apopt checkBoxField (fslI MsgSchoolAuthorshipStatementSheetExamAllowOther) (sfSheetExamAuthorshipStatementAllowOther <$> template <|> pure True)
+ -- TODO(AuthorshipStatements): disallow not allowOther && is _Nothing definition
where
ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
@@ -89,6 +104,10 @@ schoolToForm :: SchoolId -> DB (Form SchoolForm)
schoolToForm ssh = do
School{..} <- get404 ssh
ldapFrags <- selectList [SchoolLdapSchool ==. Just ssh] []
+
+ mSheetAuthorshipStatementDefinition <- maybe (return Nothing) get schoolSheetAuthorshipStatementDefinition
+ mSheetExamAuthorshipStatementDefinition <- maybe (return Nothing) get schoolSheetExamAuthorshipStatementDefinition
+
return . mkSchoolForm (Just ssh) $ Just SchoolForm
{ sfShorthand = schoolShorthand
, sfName = schoolName
@@ -98,9 +117,14 @@ schoolToForm ssh = do
, sfExamRequireModeForRegistration = schoolExamRequireModeForRegistration
, sfExamDiscouragedModes = schoolExamDiscouragedModes
, sfExamCloseMode = schoolExamCloseMode
+ , sfSheetAuthorshipStatementMode = schoolSheetAuthorshipStatementMode
+ , sfSheetAuthorshipStatementDefinition = authorshipStatementDefinitionContent <$> mSheetAuthorshipStatementDefinition
+ , sfSheetAuthorshipStatementAllowOther = schoolSheetAuthorshipStatementAllowOther
+ , sfSheetExamAuthorshipStatementMode = schoolSheetExamAuthorshipStatementMode
+ , sfSheetExamAuthorshipStatementDefinition = authorshipStatementDefinitionContent <$> mSheetExamAuthorshipStatementDefinition
+ , sfSheetExamAuthorshipStatementAllowOther = schoolSheetExamAuthorshipStatementAllowOther
}
-
getSchoolEditR, postSchoolEditR :: SchoolId -> Handler Html
getSchoolEditR = postSchoolEditR
postSchoolEditR ssh = do
@@ -110,6 +134,8 @@ postSchoolEditR ssh = do
formResult sfResult $ \SchoolForm{..} -> do
runDB $ do
+ mSheetAuthorshipStatementId <- traverse insertAuthorshipStatement sfSheetAuthorshipStatementDefinition
+ mSheetExamAuthorshipStatementId <- traverse insertAuthorshipStatement sfSheetExamAuthorshipStatementDefinition
update ssh
[ SchoolName =. sfName
, SchoolExamMinimumRegisterBeforeStart =. sfExamMinimumRegisterBeforeStart
@@ -117,6 +143,12 @@ postSchoolEditR ssh = do
, SchoolExamRequireModeForRegistration =. sfExamRequireModeForRegistration
, SchoolExamDiscouragedModes =. sfExamDiscouragedModes
, SchoolExamCloseMode =. sfExamCloseMode
+ , SchoolSheetAuthorshipStatementMode =. sfSheetAuthorshipStatementMode
+ , SchoolSheetAuthorshipStatementDefinition =. mSheetAuthorshipStatementId
+ , SchoolSheetAuthorshipStatementAllowOther =. sfSheetAuthorshipStatementAllowOther
+ , SchoolSheetExamAuthorshipStatementMode =. sfSheetExamAuthorshipStatementMode
+ , SchoolSheetExamAuthorshipStatementDefinition =. mSheetExamAuthorshipStatementId
+ , SchoolSheetExamAuthorshipStatementAllowOther =. sfSheetExamAuthorshipStatementAllowOther
]
forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
void $ upsert SchoolLdap
@@ -151,6 +183,8 @@ postSchoolNewR = do
formResult sfResult $ \SchoolForm{..} -> do
let ssh = SchoolKey sfShorthand
insertOkay <- runDB $ do
+ mSheetAuthorshipStatementId <- traverse insertAuthorshipStatement sfSheetExamAuthorshipStatementDefinition
+ mSheetExamAuthorshipStatementId <- traverse insertAuthorshipStatement sfSheetExamAuthorshipStatementDefinition
didInsert <- is _Just <$> insertUnique School
{ schoolShorthand = sfShorthand
, schoolName = sfName
@@ -159,6 +193,12 @@ postSchoolNewR = do
, schoolExamRequireModeForRegistration = sfExamRequireModeForRegistration
, schoolExamDiscouragedModes = sfExamDiscouragedModes
, schoolExamCloseMode = sfExamCloseMode
+ , schoolSheetAuthorshipStatementMode = sfSheetAuthorshipStatementMode
+ , schoolSheetAuthorshipStatementDefinition = mSheetAuthorshipStatementId
+ , schoolSheetAuthorshipStatementAllowOther = sfSheetAuthorshipStatementAllowOther
+ , schoolSheetExamAuthorshipStatementMode = sfSheetExamAuthorshipStatementMode
+ , schoolSheetExamAuthorshipStatementDefinition = mSheetExamAuthorshipStatementId
+ , schoolSheetExamAuthorshipStatementAllowOther = sfSheetExamAuthorshipStatementAllowOther
}
when didInsert $ do
insert_ UserFunction
diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs
index 5ac173421..080e49b51 100644
--- a/src/Handler/Sheet/Edit.hs
+++ b/src/Handler/Sheet/Edit.hs
@@ -22,14 +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) <- runDB $ do
- ent@(Entity sid _) <- fetchSheet tid ssh csh shn
+ (Entity sid Sheet{..}, sheetFileIds, currentLoads, hasPersonalisedFiles, mAuthorshipStatement) <- runDB $ do
+ ent@(Entity sid oldSheet) <- 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 ]
- return (ent, fti, cLoads, hasPersonalisedFiles)
+ -- 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 (oldSheet ^. _sheetAuthorshipStatement)
+ return (ent, fti, cLoads, hasPersonalisedFiles, mAuthorshipStatement)
let template = Just $ SheetForm
{ sfName = sheetName
, sfDescription = sheetDescription
@@ -55,6 +61,9 @@ postSEditR tid ssh csh shn = do
, spffAllowNonPersonalisedSubmission = sheetAllowNonPersonalisedSubmission
, spffFiles = Nothing
}
+ , sfAuthorshipStatementMode = sheetAuthorshipStatementMode
+ , sfAuthorshipStatementExam = sheetAuthorshipStatementExam
+ , sfAuthorshipStatement = authorshipStatementDefinitionContent . entityVal <$> mAuthorshipStatement
}
let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
@@ -70,6 +79,33 @@ handleSheetEdit tid ssh csh msId template dbAction = do
(FormSuccess SheetForm{..}) -> do
saveOkay <- runDBJobs $ do
actTime <- liftIO getCurrentTime
+
+ -- 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
+
+ sheetAuthorshipStatement <- traverse insertAuthorshipStatement sfAuthorshipStatement
+
let newSheet = Sheet
{ sheetCourse = cid
, sheetName = sfName
@@ -87,6 +123,9 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetAnonymousCorrection = sfAnonymousCorrection
, sheetRequireExamRegistration = sfRequireExamRegistration
, sheetAllowNonPersonalisedSubmission = maybe True spffAllowNonPersonalisedSubmission sfPersonalF
+ , sheetAuthorshipStatementMode = sfAuthorshipStatementMode
+ , sheetAuthorshipStatementExam = sfAuthorshipStatementExam
+ , sheetAuthorshipStatement
}
mbsid <- dbAction newSheet
case mbsid of
diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs
index 4cd5ba324..15afa9566 100644
--- a/src/Handler/Sheet/Form.hs
+++ b/src/Handler/Sheet/Form.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wwarn #-}
+
module Handler.Sheet.Form
( SheetForm(..), SheetPersonalisedFilesForm(..), Loads
, makeSheetForm
@@ -10,6 +12,7 @@ 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
@@ -42,7 +45,9 @@ data SheetForm = SheetForm
, sfMarkingText :: Maybe StoredMarkup
, sfAnonymousCorrection :: Bool
, sfCorrectors :: Loads
- -- Keine SheetId im Formular!
+ , sfAuthorshipStatementMode :: SheetAuthorshipStatementMode
+ , sfAuthorshipStatementExam :: Maybe ExamId
+ , sfAuthorshipStatement :: Maybe I18nStoredMarkup
}
data SheetPersonalisedFilesForm = SheetPersonalisedFilesForm
@@ -64,40 +69,123 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
oldFileIds <- (return.) <$> case msId of
Nothing -> return $ partitionFileType mempty
(Just sId) -> liftHandler $ runDB $ getFtIdMap sId
- MsgRenderer mr <- getMsgRenderer
+ 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
- flip (renderAForm FormStandard) html $ SheetForm
- <$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
- <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
+
+ 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
+
+ <* aformSection MsgSheetFormFiles
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
- <*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> 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)
+ <*> 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
+
+ <* 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)
+ <*> 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)
+ <*> 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
@@ -181,10 +269,11 @@ correctorForm loads' = wFormToAForm $ do
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
+ 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
@@ -225,12 +314,6 @@ correctorForm loads' = wFormToAForm $ do
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
miDelete = miDeleteList
- miAllowAdd :: ListPosition
- -> Natural
- -> ListLength
- -> Bool
- miAllowAdd _ _ _ = True
-
miAddEmpty :: ListPosition
-> Natural
-> ListLength
diff --git a/src/Handler/Sheet/New.hs b/src/Handler/Sheet/New.hs
index 8d8bd1c2b..9ec4770c6 100644
--- a/src/Handler/Sheet/New.hs
+++ b/src/Handler/Sheet/New.hs
@@ -25,8 +25,9 @@ postSheetNewR tid ssh csh = do
let searchShn sheet = case parShn of
(FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
_other -> return ()
- (lastSheets, loads) <- runDB $ do
- lSheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+ now <- liftIO getCurrentTime
+ template <- runDB $ do
+ lastSheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
@@ -34,40 +35,41 @@ postSheetNewR tid ssh csh = do
searchShn sheet
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
E.limit 1
- let firstEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do
- E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
- return . E.min_ $ sheetEdit E.^. SheetEditTime
+ let
+ firstEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do
+ E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
+ return . E.min_ $ sheetEdit E.^. SheetEditTime
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):_) ->
- let addTime = addWeeks $ max 1 $ weeksToAdd (fromMaybe (UTCTime systemEpochDay 0) $ sheetActiveTo <|> fEdit) now
- in Just $ SheetForm
- { sfName = stepTextCounterCI sheetName
- , sfDescription = sheetDescription
- , sfType = review _SqlKey <$> sheetType
- , sfGrouping = sheetGrouping
- , sfVisibleFrom = addTime <$> sheetVisibleFrom
- , sfActiveFrom = addTime <$> sheetActiveFrom
- , sfActiveTo = addTime <$> sheetActiveTo
- , sfSubmissionMode = sheetSubmissionMode
- , sfSheetF = Nothing
- , sfHintFrom = addTime <$> sheetHintFrom
- , sfHintF = Nothing
- , sfSolutionFrom = addTime <$> sheetSolutionFrom
- , sfSolutionF = Nothing
- , sfMarkingF = Nothing
- , sfMarkingText = sheetMarkingText
- , sfAutoDistribute = sheetAutoDistribute
- , sfCorrectors = loads
- , sfAnonymousCorrection = sheetAnonymousCorrection
- , sfRequireExamRegistration = Nothing
- , sfPersonalF = Nothing
- }
- _other -> Nothing
+ for (lastSheets ^? _head) $ \(Entity _ Sheet{..}, E.Value fEdit) -> do
+ let addTime = addWeeks $ max 1 $ weeksToAdd (fromMaybe (UTCTime systemEpochDay 0) $ sheetActiveTo <|> fEdit) now
+ mStmt <- traverse getJust sheetAuthorshipStatement
+ return SheetForm
+ { sfName = stepTextCounterCI sheetName
+ , sfDescription = sheetDescription
+ , sfType = review _SqlKey <$> sheetType
+ , sfGrouping = sheetGrouping
+ , sfVisibleFrom = addTime <$> sheetVisibleFrom
+ , sfActiveFrom = addTime <$> sheetActiveFrom
+ , sfActiveTo = addTime <$> sheetActiveTo
+ , sfSubmissionMode = sheetSubmissionMode
+ , sfSheetF = Nothing
+ , sfHintFrom = addTime <$> sheetHintFrom
+ , sfHintF = Nothing
+ , sfSolutionFrom = addTime <$> sheetSolutionFrom
+ , sfSolutionF = Nothing
+ , sfMarkingF = Nothing
+ , sfMarkingText = sheetMarkingText
+ , sfAutoDistribute = sheetAutoDistribute
+ , sfCorrectors = loads
+ , sfAnonymousCorrection = sheetAnonymousCorrection
+ , sfRequireExamRegistration = Nothing
+ , sfPersonalF = Nothing
+ , sfAuthorshipStatementMode = sheetAuthorshipStatementMode
+ , sfAuthorshipStatementExam = sheetAuthorshipStatementExam
+ , sfAuthorshipStatement = authorshipStatementDefinitionContent <$> mStmt
+ }
let action = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
insertUnique
handleSheetEdit tid ssh csh Nothing template action
diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs
index f1276f124..6c1ec3048 100644
--- a/src/Handler/Sheet/PersonalisedFiles.hs
+++ b/src/Handler/Sheet/PersonalisedFiles.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
module Handler.Sheet.PersonalisedFiles
( sinkPersonalisedSheetFiles
, getSPersonalFilesR, getCPersonalFilesR
@@ -74,6 +76,9 @@ data PersonalisedSheetFilesForm = PersonalisedSheetFilesForm
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
+embedRenderMessage ''UniWorX ''PersonalisedSheetFilesDownloadAnonymous id
+
+
personalisedSheetFileTypes :: [SheetFileType]
personalisedSheetFileTypes = filter (/= SheetMarking) universeF
@@ -103,8 +108,8 @@ resolvePersonalisedSheetFiles fpL isDir cid sid = do
let
getUid :: _ -> _ -> MemoStateT _ _ _ (SqlPersistT m) (Maybe UserId)
getUid mbIdx' cID' = runMaybeT $ do
- cIDKey <- catchMPlus (Proxy @PersonalisedSheetFilesKeyException) . lift . lift $ getPersonalisedFilesKey cid (Just sid) mbIdx'
- uid <- either (const mzero) return . (runReaderT ?? cIDKey) $ I.decrypt cID'
+ kSet <- catchMPlus (Proxy @PersonalisedSheetFilesKeyException) . lift . lift $ getPersonalisedFilesKey cid (Just sid) mbIdx'
+ uid <- either (const mzero) return . (runReaderT ?? psfksCryptoID kSet) $ I.decrypt cID'
guardM . lift . lift $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid]
return uid
@@ -166,7 +171,7 @@ sinkPersonalisedSheetFiles cid sid keep
Right nSink -> State.modify . Map.insert redResidual $ Map.insert residual nSink sinks
openSinks <- State.get
lift . lift . mapM_ closeResumableSink $ openSinks ^.. folded . folded
- let (nub -> sinkSheets, nub -> sinkUsers) = unzip $ Map.keys openSinks
+ let (nubOrd -> sinkSheets, nubOrd -> sinkUsers) = unzip $ Map.keys openSinks
unless keep $
lift . lift $ deleteWhere [ PersonalisedSheetFileSheet <-. sinkSheets
, PersonalisedSheetFileUser /<-. sinkUsers
@@ -213,7 +218,7 @@ sourcePersonalisedSheetFiles :: forall m.
-> Set PersonalisedSheetFilesRestriction
-> ConduitT () (Either PersonalisedSheetFile DBFile) (SqlPersistT m) ()
sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do
- (mbIdx, cIDKey) <- lift . newPersonalisedFilesKey $ maybe (Left cId) Right mbsid
+ (mbIdx, kSet) <- lift . newPersonalisedFilesKey $ maybe (Left cId) Right mbsid
let
genSuffixes uid = case anonMode of
PersonalisedSheetFilesDownloadGroups -> do
@@ -222,7 +227,7 @@ sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cId
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
return $ submissionGroup E.^. SubmissionGroupName
- return . nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) subGroups
+ return . Set.toList . Set.fromList $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) subGroups
otherAnon
| Just f <- userFeature otherAnon -> do
features <- E.select . E.from $ \user -> do
@@ -260,7 +265,7 @@ sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do
suf <- lift . lift $ genSuffixes courseParticipantUser
_sufCache %= Map.insert courseParticipantUser suf
return suf
- cID <- throwLeft . (runReaderT ?? cIDKey) $ I.encrypt courseParticipantUser
+ cID <- throwLeft . (runReaderT ?? psfksCryptoID kSet) $ I.encrypt courseParticipantUser
let dirName = unpack . Text.intercalate "_" . map pack $ suffix `snoc` mkPersonalisedFilesDirectory mbIdx cID
unlessM (uses _dirCache $ Set.member dirName) $ do
yield $ Right File
@@ -275,7 +280,8 @@ sourcePersonalisedSheetFiles cId mbsid mbuids anonMode restrs = do
, fileModified = courseParticipantRegistration
}
yieldM . fmap Right $ do
- fileContent' <- lift $ formatPersonalisedSheetFilesMeta anonMode cPart cID
+ mr' <- getMsgRenderer
+ fileContent' <- lift $ formatPersonalisedSheetFilesMeta mr' anonMode cPart cID (mkPersonalisedSheetFilesSeed <$> psfksSeed kSet)
let fileTitle = (dirName ) . ensureExtension "yaml" . unpack . mr $ MsgPersonalisedSheetFilesMetaFilename cID
fileModified = courseParticipantRegistration
fileContent = Just $ C.sourceLazy fileContent'
@@ -307,21 +313,24 @@ newPersonalisedFilesKey :: forall m.
, HandlerSite m ~ UniWorX
, MonadThrow m, MonadRandom m
)
- => Either CourseId SheetId -> SqlPersistT m (Maybe Word24, CryptoIDKey)
-newPersonalisedFilesKey (Right shId) = cryptoIDKey $ \cIDKey -> fmap (Nothing,) $
- either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $
- Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'newPersonalisedFilesKey) (toStrict $ Binary.encode shId) cIDKey
+ => Either CourseId SheetId -> SqlPersistT m (Maybe Word24, PersonalisedSheetFilesKeySet)
+newPersonalisedFilesKey (Right shId) = (Nothing, ) <$> do
+ psfksCryptoID <- cryptoIDKey $ \cIDKey ->
+ either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $
+ Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'newPersonalisedFilesKey) (toStrict $ Binary.encode shId) cIDKey
+ psfksSeed <- fmap Just . getsYesod . views _appPersonalisedSheetFilesSeedKey . flip derivePersonalisedSheetFilesSeedKey . toStrict $ Binary.encode (nameBase 'newPersonalisedFilesKey, shId)
+ return PersonalisedSheetFilesKeySet{..}
newPersonalisedFilesKey (Left cId) = do
now <- liftIO getCurrentTime
secret <- CryptoID.genKey
let secret' = toStrict $ Binary.encode secret
firstN <- getRandom
- let loop :: Word24 -> SqlPersistT m (Maybe Word24, CryptoIDKey)
+ let loop :: Word24 -> SqlPersistT m (Maybe Word24, PersonalisedSheetFilesKeySet)
loop n = do
didInsert <- is _Just <$> insertUnique (FallbackPersonalisedSheetFilesKey cId n secret' now)
if | didInsert
- -> return (Just n, secret)
+ -> return (Just n, PersonalisedSheetFilesKeySet secret Nothing)
| (firstN == minBound && n == maxBound)
|| n == pred firstN
-> throwM FallbackPersonalisedSheetFilesKeysExhausted
@@ -336,12 +345,13 @@ getPersonalisedFilesKey :: forall m.
, HandlerSite m ~ UniWorX
, MonadThrow m, MonadRandom m
)
- => CourseId -> Maybe SheetId -> Maybe Word24 -> SqlPersistT m CryptoIDKey
+ => CourseId -> Maybe SheetId -> Maybe Word24 -> SqlPersistT m PersonalisedSheetFilesKeySet
getPersonalisedFilesKey _ Nothing Nothing = throwM PersonalisedSheetFilesKeyInsufficientContext
getPersonalisedFilesKey _ (Just shId) Nothing = view _2 <$> newPersonalisedFilesKey (Right shId)
getPersonalisedFilesKey cId _ (Just idx) = maybeT (throwM PersonalisedSheetFilesKeyNotFound) $ do
Entity _ FallbackPersonalisedSheetFilesKey{..} <- MaybeT . getBy $ UniqueFallbackPersonalisedSheetFilesKey cId idx
- either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict $ BA.convert fallbackPersonalisedSheetFilesKeySecret
+ psfksCryptoID <- either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail $ fromStrict fallbackPersonalisedSheetFilesKeySecret
+ return $ PersonalisedSheetFilesKeySet{ psfksSeed = Nothing, .. }
mkPersonalisedFilesDirectory :: Maybe Word24 -> CryptoFileNameUser -> FilePath
mkPersonalisedFilesDirectory Nothing cID = unpack $ toPathPiece cID
diff --git a/src/Handler/Sheet/PersonalisedFiles/Meta.hs b/src/Handler/Sheet/PersonalisedFiles/Meta.hs
index e95993ae8..2b0713041 100644
--- a/src/Handler/Sheet/PersonalisedFiles/Meta.hs
+++ b/src/Handler/Sheet/PersonalisedFiles/Meta.hs
@@ -27,16 +27,20 @@ data PrettifyState
= PrettifyInitial
| PrettifyFlowSequence PrettifyState
| PrettifyBlockSequence PrettifyState
+ | PrettifySeed | PrettifySeedDone
deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
formatPersonalisedSheetFilesMeta
:: MonadIO m
- => PersonalisedSheetFilesDownloadAnonymous
+ => MsgRendererS UniWorX
+ -> PersonalisedSheetFilesDownloadAnonymous
-> CourseParticipant
-> CryptoFileNameUser
+ -> Maybe (UserIdent -> PersonalisedSheetFilesSeed)
-> SqlPersistT m Lazy.ByteString
-formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
+formatPersonalisedSheetFilesMeta (MsgRenderer mr) anonMode CourseParticipant{..} cID mkSeed = do
User{..} <- getJust courseParticipantUser
exams <- E.select . E.from $ \(exam `E.InnerJoin` examRegistration) -> E.distinctOnOrderBy [E.asc $ exam E.^. ExamName] $ do
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
@@ -50,6 +54,7 @@ formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
, YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block
]
, mapEvents (str' "user") (str $ toPathPiece cID)
+ , mapEvents (str' "seed") (maybe (YAML.Scalar () YAML.SNull) (str . toPathPiece . ($ userIdent)) mkSeed)
, guardOnM (isn't _PersonalisedSheetFilesDownloadAnonymous anonMode) $ concat
[ mapEvents (str' "display_name") (str userDisplayName)
, mapEvents (str' "surname") (str userSurname)
@@ -113,6 +118,11 @@ formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
in (before <> ann1 <> fromStrict (encodeUtf8 $ ann3 event'') <> fromStrict (encodeUtf8 $ ann2 ws) <> after, pos1')
transduce :: PrettifyState -> YAML.Event.Event -> ((Text, Text -> Text, Text -> Text), PrettifyState)
+ transduce PrettifyInitial (YAML.Event.Scalar _ _ _ k)
+ | k == "seed", is _Just mkSeed = (("\n# " <> mr MsgSheetPersonalisedFilesMetaYAMLSeedComment <> "\n", id, id), PrettifySeed)
+ | k == "seed" = (("\n# " <> mr MsgSheetPersonalisedFilesMetaYAMLNoSeedComment <> "\n", id, id), PrettifySeed)
+ transduce PrettifySeed YAML.Event.Scalar{}
+ = ((mempty, id, beforeBreak "\n"), PrettifySeedDone)
transduce cState (YAML.Event.SequenceStart _ _ YAML.Event.Flow) = ((mempty, id, bool " " mempty . null), PrettifyFlowSequence cState)
transduce (PrettifyFlowSequence pState) YAML.Event.SequenceEnd = ((mempty, id, id), pState)
transduce cState@(PrettifyFlowSequence _) _ = ((mempty, f, bool " " mempty . null), cState)
@@ -124,4 +134,11 @@ formatPersonalisedSheetFilesMeta anonMode CourseParticipant{..} cID = do
transduce cState@(PrettifyBlockSequence _) _ = ((mempty, Text.replace "\n-" "\n -", id), cState)
transduce cState _ = ((mempty, id, id), cState)
-- transduce cState _ = (("<", id, \ws -> "|" <> ws <> ">"), cState) -- TODO
+
+ beforeBreak :: Text -> Text -> Text
+ beforeBreak ins ws = before <> ins <> break' <> after
+ where (before', after) = Text.breakOnEnd "\n" ws
+ before = Text.dropWhileEnd (== '\n') before'
+ break' = Text.takeWhileEnd (== '\n') before'
+
return prettyYAML
diff --git a/src/Handler/Sheet/PersonalisedFiles/Types.hs b/src/Handler/Sheet/PersonalisedFiles/Types.hs
index c3f5a5ca8..b53d3c055 100644
--- a/src/Handler/Sheet/PersonalisedFiles/Types.hs
+++ b/src/Handler/Sheet/PersonalisedFiles/Types.hs
@@ -1,9 +1,33 @@
module Handler.Sheet.PersonalisedFiles.Types
( PersonalisedSheetFilesDownloadAnonymous(..)
, _PersonalisedSheetFilesDownloadAnonymous, _PersonalisedSheetFilesDownloadSurnames, _PersonalisedSheetFilesDownloadMatriculations, _PersonalisedSheetFilesDownloadGroups
+ , PersonalisedSheetFilesSeed(..)
+ , mkPersonalisedSheetFilesSeed
+ , PersonalisedSheetFilesSeedKey
+ , derivePersonalisedSheetFilesSeedKey, newPersonalisedSheetFilesSeedKey
+ , PersonalisedSheetFilesKeySet(..)
) where
-import Import
+import Import.NoModel
+import Model.Types.Common (UserIdent)
+
+import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
+import Data.ByteArray (ByteArrayAccess)
+import qualified Data.ByteArray as BA
+
+import Crypto.Hash.Algorithms (SHAKE256)
+import qualified Crypto.MAC.KMAC as Crypto
+import qualified Crypto.Random as Crypto
+import qualified Data.Binary as Binary
+
+import qualified Data.CaseInsensitive as CI
+
+import Data.CryptoID.ByteString (CryptoIDKey)
+
+import Data.Typeable (typeOf)
+
+import Data.Binary.Put (putByteString)
+import Data.Binary.Get (getByteString)
data PersonalisedSheetFilesDownloadAnonymous
@@ -14,6 +38,56 @@ data PersonalisedSheetFilesDownloadAnonymous
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
nullaryPathPiece ''PersonalisedSheetFilesDownloadAnonymous $ camelToPathPiece' 4
-embedRenderMessage ''UniWorX ''PersonalisedSheetFilesDownloadAnonymous id
makePrisms ''PersonalisedSheetFilesDownloadAnonymous
+
+
+newtype PersonalisedSheetFilesSeed = PersonalisedSheetFilesSeed (Digest (SHAKE256 144))
+ deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
+ deriving newtype ( PersistField
+ , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
+ , Hashable, NFData
+ , ByteArrayAccess
+ , Binary
+ )
+
+newtype PersonalisedSheetFilesSeedKey = PersonalisedSheetFilesSeedKey { psfskKeyMaterial :: ByteString }
+ deriving (Typeable)
+ deriving newtype (ByteArrayAccess)
+
+-- | Does not actually show any key material
+instance Show PersonalisedSheetFilesSeedKey where
+ show = show . typeOf
+
+instance Binary PersonalisedSheetFilesSeedKey where
+ put = putByteString . psfskKeyMaterial
+ get = PersonalisedSheetFilesSeedKey <$> getByteString 16
+
+instance Eq PersonalisedSheetFilesSeedKey where
+ (==) = BA.constEq
+
+derivePersistFieldBinary ''PersonalisedSheetFilesSeedKey
+deriveJSONBinary ''PersonalisedSheetFilesSeedKey
+
+
+derivePersonalisedSheetFilesSeedKey :: ByteArrayAccess ba => PersonalisedSheetFilesSeedKey -> ba -> PersonalisedSheetFilesSeedKey
+derivePersonalisedSheetFilesSeedKey k = PersonalisedSheetFilesSeedKey . BA.convert . Crypto.kmac @(SHAKE256 128) (enc 'derivePersonalisedSheetFilesSeedKey) k
+ where
+ enc :: forall a. Binary a => a -> ByteString
+ enc = toStrict . Binary.encode
+
+newPersonalisedSheetFilesSeedKey :: Crypto.MonadRandom m => m PersonalisedSheetFilesSeedKey
+newPersonalisedSheetFilesSeedKey = PersonalisedSheetFilesSeedKey <$> Crypto.getRandomBytes 16
+
+mkPersonalisedSheetFilesSeed :: PersonalisedSheetFilesSeedKey
+ -> UserIdent
+ -> PersonalisedSheetFilesSeed
+mkPersonalisedSheetFilesSeed k u = PersonalisedSheetFilesSeed . Crypto.kmacGetDigest $ Crypto.kmac (enc 'mkPersonalisedSheetFilesSeed) k (enc $ CI.foldedCase u)
+ where
+ enc :: forall a. Binary a => a -> ByteString
+ enc = toStrict . Binary.encode
+
+data PersonalisedSheetFilesKeySet = PersonalisedSheetFilesKeySet
+ { psfksCryptoID :: CryptoIDKey
+ , psfksSeed :: Maybe PersonalisedSheetFilesSeedKey
+ } deriving (Show, Typeable)
diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs
index 045d8d631..a416b5aaa 100644
--- a/src/Handler/Sheet/Show.hs
+++ b/src/Handler/Sheet/Show.hs
@@ -19,8 +19,11 @@ getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid ssh csh shn = do
now <- liftIO getCurrentTime
muid <- maybeAuthId
- Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
+ sheetEnt@(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
let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a
sftVisible sft | Just dts <- sheetFileTypeDates sheet sft
@@ -151,6 +154,7 @@ getSShowR tid ssh csh shn = do
return $ notification NotificationBroad =<< messageI Warning MsgSheetSubmissionModeNoneWithoutNotGraded
sTypeDesc <- runDB $ sheetTypeDescription (sheetCourse sheet) (sheetType sheet)
+ authorshipStatementRequired <- fmap (is _Just) . runDB $ getSheetAuthorshipStatement sheetEnt
defaultLayout $ do
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index db3beb8a6..ca4ff3130 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -11,6 +11,7 @@ module Handler.Submission
, module Handler.Submission.Create
, module Handler.Submission.Grade
, module Handler.Submission.Upload
+ , module Handler.Submission.AuthorshipStatements
) where
import Handler.Submission.New
@@ -24,6 +25,7 @@ import Handler.Submission.Correction
import Handler.Submission.Create
import Handler.Submission.Grade
import Handler.Submission.Upload
+import Handler.Submission.AuthorshipStatements
import Handler.Utils
diff --git a/src/Handler/Submission/AuthorshipStatements.hs b/src/Handler/Submission/AuthorshipStatements.hs
new file mode 100644
index 000000000..ed22014a2
--- /dev/null
+++ b/src/Handler/Submission/AuthorshipStatements.hs
@@ -0,0 +1,142 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module Handler.Submission.AuthorshipStatements
+ ( getSubAuthorshipStatementsR
+ ) where
+
+import Import
+import Handler.Utils
+import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Utils as E
+
+
+type AuthorshipStatementsExpr = E.SqlExpr (Entity AuthorshipStatementSubmission)
+ `E.InnerJoin` E.SqlExpr (Entity User)
+ `E.InnerJoin` E.SqlExpr (Entity AuthorshipStatementDefinition)
+
+queryAuthorshipStatement :: Getter AuthorshipStatementsExpr (E.SqlExpr (Entity AuthorshipStatementSubmission))
+queryAuthorshipStatement = to $(E.sqlIJproj 3 1)
+
+queryUser :: Getter AuthorshipStatementsExpr (E.SqlExpr (Entity User))
+queryUser = to $(E.sqlIJproj 3 2)
+
+queryDefinition :: Getter AuthorshipStatementsExpr (E.SqlExpr (Entity AuthorshipStatementDefinition))
+queryDefinition = to $(E.sqlIJproj 3 3)
+
+
+type AuthorshipStatementsData = DBRow ( Entity AuthorshipStatementSubmission
+ , Entity User
+ , Entity AuthorshipStatementDefinition
+ )
+
+resultAuthorshipStatement :: Lens' AuthorshipStatementsData (Entity AuthorshipStatementSubmission)
+resultAuthorshipStatement = _dbrOutput . _1
+
+resultUser :: Lens' AuthorshipStatementsData (Entity User)
+resultUser = _dbrOutput . _2
+
+resultDefinition :: Lens' AuthorshipStatementsData (Entity AuthorshipStatementDefinition)
+resultDefinition = _dbrOutput . _3
+
+
+getSubAuthorshipStatementsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
+getSubAuthorshipStatementsR tid ssh csh shn cID = do
+ authorshipStatementTable <- runDB $ do
+ subId <- decrypt cID
+ Submission{..} <- get404 subId
+ isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
+ mASDefinition <- getSheetAuthorshipStatement =<< getEntity404 submissionSheet
+
+ let dbtIdent :: Text
+ dbtIdent = "authorship-statements"
+
+ dbtSQLQuery = runReaderT $ do
+ authorshipStatement <- view queryAuthorshipStatement
+ user <- view queryUser
+ definition <- view queryDefinition
+
+ lift $ do
+ E.on $ definition E.^. AuthorshipStatementDefinitionId E.==. authorshipStatement E.^. AuthorshipStatementSubmissionStatement
+ E.on $ user E.^. UserId E.==. authorshipStatement E.^. AuthorshipStatementSubmissionUser
+
+ E.where_ $ authorshipStatement E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId
+
+ return (authorshipStatement, user, definition)
+ dbtRowKey = views queryAuthorshipStatement (E.^. AuthorshipStatementSubmissionId)
+
+ dbtProj = dbtProjId
+
+ dbtColonnade :: Colonnade Sortable AuthorshipStatementsData (DBCell (HandlerFor UniWorX) ())
+ dbtColonnade = mconcat $ catMaybes
+ [ pure . sortable (Just "authorship-statement-time") (i18nCell MsgSubmissionColumnAuthorshipStatementTime) $ views (resultAuthorshipStatement . _entityVal . _authorshipStatementSubmissionTime) dateTimeCell
+ , pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusG 2) _userDisplayName _userSurname)
+ , guardOn isLecturer $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
+ , pure $ lmap (view $ resultUser . _entityVal) colUserEmail
+ , pure . sortable Nothing (i18nCell MsgSubmissionColumnAuthorshipStatementWording) $ views resultDefinition definitionCell
+ ]
+ where
+ definitionCell (Entity asdId asd)
+ = withColor . (cellAttrs %~ addAttrsClass "table__td--center") . modalCell $ authorshipStatementWidget asd
+ where
+ withColor c
+ | Just (Entity currASDId _) <- mASDefinition
+ = c
+ & cellAttrs %~ addAttrsClass "heated"
+ & cellAttrs <>~ pure ("style", [st|--hotness: #{tshow (boolHeat (asdId /= currASDId))}|])
+ | otherwise
+ = c
+
+ dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
+
+ dbtSorting = mconcat
+ [ singletonMap "authorship-statement-time" . SortColumn $ views queryAuthorshipStatement (E.^. AuthorshipStatementSubmissionTime)
+ , sortUserName' (queryUser . $(multifocusG 2) (to (E.^. UserDisplayName)) (to (E.^. UserSurname)))
+ , sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
+ , uncurry singletonMap $ sortUserEmail (view queryUser)
+ ]
+ dbtFilter = mconcat
+ [ fltrUserName' (queryUser . to (E.^. UserDisplayName))
+ , fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
+ , uncurry singletonMap $ fltrUserEmail (view queryUser)
+ , singletonMap "authorship-statement-current" . FilterColumn $ \(view queryAuthorshipStatement -> subStmt) (Last isCurrent)
+ -> let isCurrent'
+ | Just (Entity asdId _) <- mASDefinition
+ = subStmt E.^. AuthorshipStatementSubmissionStatement E.==. E.val asdId
+ | otherwise
+ = E.false
+ in maybe E.true ((E.==. isCurrent') . E.val) isCurrent
+ ]
+
+ dbtFilterUI = mconcat $ catMaybes
+ [ pure fltrUserNameUI'
+ , guardOn isLecturer fltrUserMatriculationUI
+ , pure fltrUserEmailUI
+ , pure . flip (prismAForm $ singletonFilter "authorship-statement-current" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgSubmissionFilterAuthorshipStatementCurrent)
+ ]
+
+ dbtParams = def
+
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+ dbtExtraReps = []
+
+ asPSValidator = def
+ & defaultSorting [SortDescBy "authorship-statement-time"]
+ & restrictFilter lecturerFilter & restrictSorting lecturerSorting
+ where
+ lecturerFilter fk _
+ | isLecturer = True
+ | otherwise = fk /= "user-matriculation"
+ lecturerSorting sk _
+ | isLecturer = True
+ | otherwise = sk /= "user-matriculation"
+ in dbTableWidget' asPSValidator DBTable{..}
+
+ let (heading, title) = ( MsgSubmissionAuthorshipStatementsHeading tid ssh csh shn cID
+ , MsgSubmissionAuthorshipStatementsTitle tid ssh csh shn cID
+ )
+
+ siteLayoutMsg heading $ do
+ setTitleI title
+
+ authorshipStatementTable
diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs
index 194ac5c35..d805b574e 100644
--- a/src/Handler/Submission/Grade.hs
+++ b/src/Handler/Submission/Grade.hs
@@ -19,7 +19,8 @@ getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
getCorrectionsGradeR = postCorrectionsGradeR
postCorrectionsGradeR = do
uid <- requireAuthId
- let whereClause = ratedBy uid
+ let whereClause :: CorrectionTableWhere
+ whereClause = ratedBy uid
displayColumns = mconcat -- should match getSSubsR for consistent UX
[ -- dbRow,
colSchool
@@ -37,32 +38,33 @@ postCorrectionsGradeR = do
, colMaxPointsField
, colCommentField
] -- Continue here
- filterUI = Just $ \mPrev -> mconcat
- [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse)
- , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTableTerm)
- , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool)
- , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
- , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime)
- , prismAForm (singletonFilter "rating-visible" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
- , prismAForm (singletonFilter "rating" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
- , Map.singleton "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
+ filterUI = Just $ mconcat
+ [ filterUICourse courseOptions
+ , filterUITerm termOptions
+ , filterUISchool schoolOptions
+ , filterUISheetSearch
+ , filterUIPseudonym
+ , filterUIIsRated
+ -- , flip (prismAForm $ singletonFilter "rating-visible" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgRatingDone)
+ , filterUIRating
+ , filterUIComment
]
courseOptions = runDB $ do
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
- optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
+ optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . courseShorthand . entityVal) courses
termOptions = runDB $ do
courses <- selectList [] [Asc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
- optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
+ optionsPairs . map (id &&& id) . nubOrd $ map (termToText . unTermKey . courseTerm . entityVal) courses
schoolOptions = runDB $ do
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
- optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
+ optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
psValidator = def
& restrictAnonymous
& restrictCorrector
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
- unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
+ unFormResult = getDBFormResult $ \(view $ resultSubmission . _entityVal -> sub@Submission{..}) -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
- (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def
+ (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI Nothing psValidator $ def
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
}
diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs
index c0c003dc3..3b6521f1b 100644
--- a/src/Handler/Submission/Helper.hs
+++ b/src/Handler/Submission/Helper.hs
@@ -1,5 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-
module Handler.Submission.Helper
( submissionHelper
) where
@@ -12,11 +10,12 @@ import Handler.Utils
import Handler.Utils.Submission
import Handler.Utils.Invitations
+import Handler.Submission.Helper.ArchiveTable
+
import Data.Maybe (fromJust)
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
-import qualified Database.Esqueleto.Internal.Internal as E (unsafeSqlFunction)
import qualified Data.Set as Set
import Data.Map ((!), (!?))
@@ -32,15 +31,40 @@ import Handler.Submission.SubmissionUserInvite
import qualified Data.Conduit.Combinators as C
-makeSubmissionForm :: CourseId -> SheetId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId))
-makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
- <$> uploadForm
- <*> wFormToAForm submittorsForm'
+makeSubmissionForm :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m)
+ => CourseId -> SheetId -> Maybe (Entity AuthorshipStatementDefinition) -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId)
+ -> (Markup -> MForm (ReaderT SqlBackend m) (FormResult (Maybe FileUploads, Set (Either UserEmail UserId), Maybe AuthorshipStatementDefinitionId), Widget))
+makeSubmissionForm cid shid mASDefinition msmid uploadMode grouping mPrev isLecturer prefillUsers = identifyForm FIDsubmission . renderWForm FormStandard $ do
+ uploadRes <- aFormToWForm uploadForm
+ submittorsRes <- submittorsForm'
+ lecturerIsSubmittor <- case submittorsRes of
+ FormSuccess subs -> maybe False ((`Set.member` subs) . Right) <$> maybeAuthId
+ _other -> return False
+ authorshipStatementRes <- authorshipStatementForm lecturerIsSubmittor
+ return $ (,,) <$> uploadRes <*> submittorsRes <*> authorshipStatementRes
where
- uploadForm
- | is _NoUpload uploadMode = pure Nothing
- | is _Nothing msmid = uploadForm'
- | otherwise = join <$> optionalActionNegatedA uploadForm' (fslI MsgSubmissionFilesUnchanged & setTooltip MsgSubmissionFilesUnchangedTip) (Just False)
+ -- TODO(AuthorshipStatements): for lecturer: optionally only invite (co-)submittors instead of adding directly; so they will be forced to make authorship statements
+ -- also take care that accepting the invite (optionally) remains possible even after the submission deadline (for creating submissions for course users as a lecturer)
+
+ authorshipStatementForm :: Bool -> WForm (ReaderT SqlBackend m) (FormResult (Maybe AuthorshipStatementDefinitionId))
+ authorshipStatementForm lecturerIsSubmittor = maybeT (return $ FormSuccess Nothing) $ do
+ asd <- hoistMaybe mASDefinition
+ let authorshipStatementForm' = apopt (acceptAuthorshipStatementField asd) (fslI MsgSubmissionAuthorshipStatement & setTooltip MsgSubmissionAuthorshipStatementTip) Nothing
+ authorshipStatementRes <- lift . hoist (hoist liftHandler) $ if
+ | isLecturer
+ -> optionalActionW authorshipStatementForm' (fslI MsgSubmissionLecturerAuthorshipStatement & setTooltip MsgSubmissionLecturerAuthorshipStatementTip) (Just False)
+ | otherwise
+ -> fmap Just <$> aFormToWForm authorshipStatementForm'
+ if
+ | FormSuccess Nothing <- authorshipStatementRes
+ , lecturerIsSubmittor -> formFailure [MsgSubmissionLecturerAuthorshipStatementRequiredBecauseSubmittor]
+ | otherwise -> return authorshipStatementRes
+
+ uploadForm :: AForm (ReaderT SqlBackend m) (Maybe FileUploads)
+ uploadForm = hoistAForm liftHandler $ if
+ | is _NoUpload uploadMode -> pure Nothing
+ | is _Nothing msmid -> uploadForm'
+ | otherwise -> join <$> optionalActionNegatedA uploadForm' (fslI MsgSubmissionFilesUnchanged & setTooltip MsgSubmissionFilesUnchangedTip) (Just False)
uploadForm' = fileUploadForm (not isLecturer) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode mPrev
@@ -98,9 +122,11 @@ makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUs
E.orderBy [E.asc $ user E.^. UserEmail]
return user
- addField :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> Field m (Set (Either UserEmail UserId))
+ addField :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => UserId -> Field m' (Set (Either UserEmail UserId))
addField uid = multiUserInvitationField . MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationPrevCoSubmittors) $ previousCoSubmittors uid
+ addFieldLecturer, addFieldAuthorshipStatements :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Field m' (Set (Either UserEmail UserId))
addFieldLecturer = multiUserInvitationField $ MUILookupSuggested (SomeMessage MsgMultiUserFieldExplanationCourseParticipants) courseUsers
+ addFieldAuthorshipStatements = multiUserInvitationField MUIAlwaysInvite
addFieldSettings :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> FieldSettings UniWorX
addFieldSettings mr = fslpI MsgSubmissionMembers $ mr MsgLdapIdentificationOrEmail
@@ -119,6 +145,7 @@ makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUs
miButtonAction' :: forall p. PathPiece p => Maybe (Route UniWorX) -> p -> Maybe (SomeRoute UniWorX)
miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag)
+ submittorsForm' :: WForm (ReaderT SqlBackend m) (FormResult (Set (Either UserEmail UserId)))
submittorsForm' = maybeT submittorsForm $ do
restr <- MaybeT (liftHandler $ maybeCurrentBearerRestrictions @Value) >>= hoistMaybe . preview (_Object . ix "submittors" . _Array)
let _Submittor = prism (either toJSON toJSON) $ \x -> first (const x) $ JSON.parseEither (\x' -> fmap Right (parseJSON x') <|> fmap Left (parseJSON x')) x
@@ -126,10 +153,11 @@ makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUs
fmap Set.fromList <$> forMOf (traverse . traverse . _Right) submittors decrypt
+ submittorsForm :: WForm (ReaderT SqlBackend m) (FormResult (Set (Either UserEmail UserId)))
submittorsForm
| isLecturer = do -- Form is being used by lecturer; allow Everything™
let
- miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
+ miAdd :: (Text -> Text) -> FieldView UniWorX -> (Markup -> MForm (ReaderT SqlBackend m) (FormResult ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]), Widget))
miAdd nudge btn csrf = do
MsgRenderer mr <- getMsgRenderer
(addRes, addView) <- mpreq addFieldLecturer (addFieldSettings mr & addName (nudge "emails")) Nothing
@@ -150,16 +178,28 @@ makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUs
| otherwise = do
uid <- liftHandler requireAuthId
mRoute <- getCurrentRoute
+ let doAuthorshipStatements = is _Just mASDefinition
+
+ prefillUsers' <- lift . lift . fmap catMaybes . for (Set.toList prefillUsers) $ \case
+ Right uid' | doAuthorshipStatements
+ , uid /= uid'
+ -> fmap (Left . userEmail) <$> get uid'
+ other -> return $ pure other
let
miAdd :: ListPosition
-> Natural
+ -> ListLength
-> (Text -> Text)
-> FieldView UniWorX
- -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
- miAdd _ _ nudge btn = Just $ \csrf -> do
+ -> Maybe (Markup -> MForm (ReaderT SqlBackend m) (FormResult (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))), Widget))
+ miAdd dim pos liveliness nudge btn = guardOn (miAllowAdd dim pos liveliness) $ \csrf -> do
MsgRenderer mr <- getMsgRenderer
- (addRes, addView) <- mpreq (addField uid) (addFieldSettings mr & addName (nudge "emails")) Nothing
+ (addRes, addView) <- if
+ | doAuthorshipStatements
+ -> mpreq addFieldAuthorshipStatements (addFieldSettings mr & addName (nudge "emails") & setTooltip MsgSubmissionCoSubmittorsInviteRequiredBecauseAuthorshipStatements) Nothing
+ | otherwise
+ -> mpreq (addField uid) (addFieldSettings mr & addName (nudge "emails")) Nothing
let addRes' = addRes <&> \newData oldData -> if
| existing <- newData `Set.intersection` setOf folded oldData
, not $ Set.null existing
@@ -172,12 +212,12 @@ makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUs
-> Either UserEmail UserId
-> Maybe ()
-> (Text -> Text)
- -> Form ()
+ -> (Markup -> MForm (ReaderT SqlBackend m) (FormResult (), Widget))
miCell _ dat _ _ csrf = return (FormSuccess (), miCell' csrf dat)
miDelete :: Map ListPosition (Either UserEmail UserId)
-> ListPosition
- -> MaybeT (MForm Handler) (Map ListPosition ListPosition)
+ -> MaybeT (MForm (ReaderT SqlBackend m)) (Map ListPosition ListPosition)
miDelete dat delPos = do
guard mayEdit
guard $ Map.size dat > 1
@@ -214,7 +254,7 @@ makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUs
where resultUsers = setOf (folded . _1) valMap
-- when (maxSize > Just 1) $
-- wformMessage =<< messageI Info MsgCosubmittorTip
- fmap postProcess <$> massInputW MassInput{..} submittorSettings' True (Just . Map.fromList . zip [0..] . map (, ()) $ Set.toList prefillUsers)
+ fmap postProcess <$> massInputW MassInput{..} submittorSettings' True (Just . Map.fromList . zip [0..] . map (, ()) $ prefillUsers')
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html
submissionHelper tid ssh csh shn mcid = do
@@ -225,6 +265,7 @@ submissionHelper tid ssh csh shn mcid = do
let
getSheetInfo = do
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
+ mASDefinition <- getSheetAuthorshipStatement csheet
maySubmit <- (== Authorized) <$> evalAccessDB actionUrl True
isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
@@ -257,6 +298,7 @@ submissionHelper tid ssh csh shn mcid = do
, isLecturer
, not isLecturer
, Nothing, Nothing
+ , mASDefinition
)
(Nothing, RegisteredGroups) -> do
buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do
@@ -286,8 +328,9 @@ submissionHelper tid ssh csh shn mcid = do
, isLecturer
, not isLecturer
, Nothing, Nothing
+ , mASDefinition
)
- (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing)
+ (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer, Nothing, Nothing, mASDefinition)
(Just smid, _) -> do
void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
@@ -324,280 +367,257 @@ submissionHelper tid ssh csh shn mcid = do
corrector <- join <$> traverse getEntity submissionRatingBy
- return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector)
+ return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner,Just sub,corrector,mASDefinition)
-- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
-- Therefore we do not restrict upload behaviour in any way in that case
- ((res,formWidget'), formEnctype) <- do
- (Entity shid Sheet{..}, buddies, _, _, isLecturer, isOwner, _, _) <- runDB getSheetInfo
+ ((formWidget', formEnctype), mAct) <- runDBJobs . setSerializable $ do
+ (Entity shid Sheet{..}, buddies, _, _, isLecturer, isOwner, msubmission, _, mASDefinition) <- hoist lift getSheetInfo
let mPrevUploads = msmid <&> \smid -> runDBSource $ selectSource [SubmissionFileSubmission ==. smid, SubmissionFileIsUpdate ==. False] [Asc SubmissionFileTitle] .| C.map (view $ _FileReference . _1)
- runFormPost . makeSubmissionForm sheetCourse shid msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping mPrevUploads isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
+ ((res, formWidget'), formEnctype) <- hoist lift . runFormPost . makeSubmissionForm sheetCourse shid mASDefinition msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping mPrevUploads isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
+
+ -- Calling `msgSubmissionErrors` within a `runDB` is okay as long as we handle `transactionUndo` ourselves iff it returns nothing
+ mAct' <- msgSubmissionErrors $ do
+ submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
+ E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
+ E.where_ $ E.just (submissionUser E.^. SubmissionUserUser) E.==. E.val muid
+ E.&&. submission E.^. SubmissionSheet E.==. E.val shid
+ return $ submission E.^. SubmissionId
+ case (msmid, submissions) of
+ (Nothing, E.Value smid : _) -> do
+ cID <- encrypt smid
+ addMessageI Info MsgSubmissionAlreadyExists
+ redirect $ CSubmissionR tid ssh csh shn cID SubShowR
+ _other -> return ()
+
+ when ( is _Nothing muid
+ && is _Nothing msubmission
+ && not isLecturer
+ )
+ notAuthenticated
+
+ -- Determine old submission users
+ subUsersOld <- if
+ | Just smid <- msmid -> Set.union
+ <$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] [])
+ <*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email))
+ | otherwise -> return Set.empty
+
+ res' <- case res of
+ FormMissing -> return FormMissing
+ (FormFailure failmsgs) -> return $ FormFailure failmsgs
+ (FormSuccess res'@(_, groupMembers, _))
+ | groupMembers == subUsersOld -> return $ FormSuccess res'
+ | isLecturer -> return $ FormSuccess res'
+ | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members
+ let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers
+ prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool))
+ prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
+ participants <- fmap prep . E.select . E.from $ \user -> do
+ E.where_ $ (user E.^. UserId) `E.in_` E.valList gIds
+ let
+ isParticipant = E.exists . E.from $ \courseParticipant -> do
+ E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+ E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
+ E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
+ hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
+ E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+ E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+ E.&&. submission E.^. SubmissionSheet E.==. E.val shid
+ case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3
+ Nothing -> return ()
+ Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
+ return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
+
+ $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
+
+ mr <- getMessageRender
+ let
+ failmsgs = (concat :: [[Text]] -> [Text])
+ [ flip Map.foldMapWithKey participants $ \email -> \case
+ -- Nothing -> pure . mr $ MsgEMailUnknown email
+ (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
+ (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
+ _other -> mempty
+ , case fromIntegral (Map.size participants) `compare` maxParticipants of
+ GT | not isLecturer -> pure $ mr MsgTooManyParticipants
+ _ -> mempty
+ ]
+ return $ if null failmsgs
+ then FormSuccess res'
+ else FormFailure failmsgs
+ | otherwise -> return $ FormSuccess res'
+
+
+ formResultMaybe res' $ \(mFiles, adhocMembers, mASDId) -> do
+ now <- liftIO getCurrentTime
+
+ smid <- case (mFiles, msmid) of
+ (Nothing, Just smid) -- no new files, existing submission partners updated
+ -> return smid
+ (Just files, _) -> -- new files
+ runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False
+ (Nothing, Nothing) -- new submission, no file upload requested
+ -> do
+ sid <- insert Submission
+ { submissionSheet = shid
+ , submissionRatingPoints = Nothing
+ , submissionRatingComment = Nothing
+ , submissionRatingBy = Nothing
+ , submissionRatingAssigned = Nothing
+ , submissionRatingTime = Nothing
+ }
+ audit $ TransactionSubmissionEdit sid shid
+
+ insert_ $ SubmissionEdit muid now sid
+
+ return sid
+
+ -- Determine new submission users
+ subUsers <- if
+ | isLecturer -> return adhocMembers
+ | RegisteredGroups <- sheetGrouping -> do
+ -- Determine members of pre-registered group
+ groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
+ E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
+ E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+ E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid
+ E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
+
+ E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
+ E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+ E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
+ E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser
+ E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
+
+ return $ submissionGroupUser' E.^. SubmissionGroupUserUser
+ -- SubmissionUser for all group members (pre-registered & ad-hoc)
+ return $ maybe id (Set.insert . Right) muid groupUids
+ | otherwise -> return adhocMembers
+
+ -- Since invitations carry no data we only need to consider changes to
+ -- the set of users/invited emails
+ -- Otherwise we would have to update old invitations (via
+ -- `sinkInvitationsF`) because their associated @DBData@ might have
+ -- changed
+
+ forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if
+ -- change is a new user being added to the submission users => send invitation / insert
+ | change `Set.member` subUsers -> case change of
+ Left subEmail -> do
+ -- user does not exist yet => send invitation
+ sinkInvitationsF submissionUserInvitationConfig [(subEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))]
+ return ()
+ Right subUid -> do
+ -- user exists and has an id => insert as SubmissionUser and audit
+ insert_ $ SubmissionUser subUid smid
+ audit $ TransactionSubmissionUserEdit smid subUid
+ unless (Just subUid == muid) $
+ queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid
+ -- change is an old user that is not a submission user anymore => delete invitation / delete
+ | otherwise -> case change of
+ Left subEmail -> deleteInvitation @SubmissionUser smid subEmail
+ Right subUid -> do
+ deleteBy $ UniqueSubmissionUser subUid smid
+ audit $ TransactionSubmissionUserDelete smid subUid
+ unless (Just subUid == muid) $
+ queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid
+
+ hasAuthorshipStatement <- maybeT (return True) $ do
+ uid <- hoistMaybe muid
+ asDId <- hoistMaybe mASDId
+ lift $ exists [AuthorshipStatementSubmissionStatement ==. asDId, AuthorshipStatementSubmissionSubmission ==. smid, AuthorshipStatementSubmissionUser ==. uid]
+
+ forM_ mASDId $ \asdId -> do
+ uid <- maybe notAuthenticated return muid
+ insert_ $ AuthorshipStatementSubmission asdId smid uid now
+
+
+ if | is _Nothing msmid -> addMessageI Success MsgSubmissionCreated
+ | is _Just mFiles -> addMessageI Success MsgSubmissionUpdated
+ | subUsers == subUsersOld
+ , not hasAuthorshipStatement -> addMessageI Success MsgSubmissionUpdatedAuthorshipStatement
+ | subUsers == subUsersOld -> addMessageI Info MsgSubmissionUnchanged
+ | otherwise -> addMessageI Success MsgSubmissionUsersUpdated
+
+ cID <- encrypt smid
+ let showRoute = CSubmissionR tid ssh csh shn cID SubShowR
+ mayShow <- hoist lift $ hasReadAccessTo showRoute
+
+ return . Just $ if
+ | mayShow -> redirect showRoute
+ | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
+
+ case mAct' of
+ Nothing -> ((formWidget', formEnctype), Nothing) <$ E.transactionUndo -- manual rollback because we are calling `msgSubmissionErrors` within a `runDB`
+ Just mAct -> return ((formWidget', formEnctype), mAct)
+
+ sequence_ mAct
let formWidget = wrapForm' BtnHandIn formWidget' def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype
}
- mCID <- fmap join . msgSubmissionErrors . runDBJobs . setSerializable $ do
- (Entity shid Sheet{..}, _, _, _, isLecturer, _, msubmission, _) <- hoist lift getSheetInfo
+ ((Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector, _), (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget, (subUsers, subUsersVisible), isLecturer, isOwner, doAuthorshipStatements) <- runDB $ do
+ sheetInfo@(Entity shid Sheet{..}, buddies, _, _, isLecturer, isOwner, msubmission, _, mASDefinition) <- getSheetInfo
- submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
- E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
- E.where_ $ E.just (submissionUser E.^. SubmissionUserUser) E.==. E.val muid
- E.&&. submission E.^. SubmissionSheet E.==. E.val shid
- return $ submission E.^. SubmissionId
- case (msmid, submissions) of
- (Nothing, E.Value smid : _) -> do
- cID <- encrypt smid
- addMessageI Info MsgSubmissionAlreadyExists
- redirect $ CSubmissionR tid ssh csh shn cID SubShowR
- _other -> return ()
+ (showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> do
+ showCorrection <- hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
+ correctionInvisible <- correctionInvisibleWidget tid ssh csh shn cid subEnt
- when ( is _Nothing muid
- && is _Nothing msubmission
- && not isLecturer
- )
- notAuthenticated
+ return (showCorrection, correctionInvisible)
- -- Determine old submission users
- subUsersOld <- if
- | Just smid <- msmid -> Set.union
- <$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] [])
- <*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email))
- | otherwise -> return Set.empty
+ -- Maybe construct a table to display uploaded archive files
+ mFileTable' <- for msmid $ mkSubmissionArchiveTable tid ssh csh shn showCorrection
+ let filesCorrected = maybe False (view _1) mFileTable'
+ mFileTable = view _2 <$> mFileTable'
- res' <- case res of
- FormMissing -> return FormMissing
- (FormFailure failmsgs) -> return $ FormFailure failmsgs
- (FormSuccess res'@(_, groupMembers))
- | groupMembers == subUsersOld -> return $ FormSuccess res'
- | isLecturer -> return $ FormSuccess res'
- | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members
- let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers
- prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool))
- prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
- participants <- fmap prep . E.select . E.from $ \user -> do
- E.where_ $ (user E.^. UserId) `E.in_` E.valList gIds
- let
- isParticipant = E.exists . E.from $ \courseParticipant -> do
- E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
- E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
- E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
- hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
- E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
- E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
- E.&&. submission E.^. SubmissionSheet E.==. E.val shid
- case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3
- Nothing -> return ()
- Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
- return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
+ sheetTypeDesc <- sheetTypeDescription sheetCourse sheetType
- $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
-
- mr <- getMessageRender
- let
- failmsgs = (concat :: [[Text]] -> [Text])
- [ flip Map.foldMapWithKey participants $ \email -> \case
- -- Nothing -> pure . mr $ MsgEMailUnknown email
- (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
- (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
- _other -> mempty
- , case fromIntegral (Map.size participants) `compare` maxParticipants of
- GT | not isLecturer -> pure $ mr MsgTooManyParticipants
- _ -> mempty
- ]
- return $ if null failmsgs
- then FormSuccess res'
- else FormFailure failmsgs
- | otherwise -> return $ FormSuccess res'
-
-
- formResultMaybe res' $ \(mFiles, adhocMembers) -> do
- smid <- case (mFiles, msmid) of
- (Nothing, Just smid) -- no new files, existing submission partners updated
- -> return smid
- (Just files, _) -> -- new files
- runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission muid (maybe (Left shid) Right msmid) False
- (Nothing, Nothing) -- new submission, no file upload requested
- -> do
- sid <- insert Submission
- { submissionSheet = shid
- , submissionRatingPoints = Nothing
- , submissionRatingComment = Nothing
- , submissionRatingBy = Nothing
- , submissionRatingAssigned = Nothing
- , submissionRatingTime = Nothing
- }
- audit $ TransactionSubmissionEdit sid shid
-
- now <- liftIO getCurrentTime
- insert_ $ SubmissionEdit muid now sid
-
- return sid
-
- -- Determine new submission users
- subUsers <- if
- | isLecturer -> return adhocMembers
- | RegisteredGroups <- sheetGrouping -> do
- -- Determine members of pre-registered group
- groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
- E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
- E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
- E.where_ $ E.just (submissionGroupUser E.^. SubmissionGroupUserUser) E.==. E.val muid
- E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
-
- E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
- E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
- E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
- E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser
- E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
-
- return $ submissionGroupUser' E.^. SubmissionGroupUserUser
- -- SubmissionUser for all group members (pre-registered & ad-hoc)
- return $ maybe id (Set.insert . Right) muid groupUids
- | otherwise -> return adhocMembers
-
- -- Since invitations carry no data we only need to consider changes to
- -- the set of users/invited emails
- -- Otherwise we would have to update old invitations (via
- -- `sinkInvitationsF`) because their associated @DBData@ might have
- -- changed
-
- forM_ (subUsers `setSymmDiff` subUsersOld) $ \change -> if
- -- change is a new user being added to the submission users => send invitation / insert
- | change `Set.member` subUsers -> case change of
- Left subEmail -> do
- -- user does not exist yet => send invitation
- sinkInvitationsF submissionUserInvitationConfig [(subEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))]
- return ()
- Right subUid -> do
- -- user exists and has an id => insert as SubmissionUser and audit
- insert_ $ SubmissionUser subUid smid
- audit $ TransactionSubmissionUserEdit smid subUid
- unless (Just subUid == muid) $
- queueDBJob . JobQueueNotification $ NotificationSubmissionUserCreated subUid smid
- -- change is an old user that is not a submission user anymore => delete invitation / delete
- | otherwise -> case change of
- Left subEmail -> deleteInvitation @SubmissionUser smid subEmail
- Right subUid -> do
- deleteBy $ UniqueSubmissionUser subUid smid
- audit $ TransactionSubmissionUserDelete smid subUid
- unless (Just subUid == muid) $
- queueDBJob . JobQueueNotification $ NotificationSubmissionUserDeleted subUid shid smid
-
- addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated
- | otherwise -> MsgSubmissionUpdated
- Just <$> encrypt smid
-
- case mCID of
- Just cID -> do
- let showRoute = CSubmissionR tid ssh csh shn cID SubShowR
- mayShow <- hasReadAccessTo showRoute
- if
- | mayShow -> redirect showRoute
- | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
- Nothing -> return ()
-
- (Entity shid Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo
-
- (showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> runDB $ do
- showCorrection <- hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
- correctionInvisible <- correctionInvisibleWidget tid ssh csh shn cid subEnt
-
- return (showCorrection, correctionInvisible)
-
- -- Maybe construct a table to display uploaded archive files
- let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ())
- colonnadeFiles cid = mconcat $ catMaybes
- [ Just . sortable (Just "path") (i18nCell MsgTableFileTitle) $ \(mOrig, mCorr) -> let
- Just fileTitle' = submissionFileTitle . entityVal <$> (mOrig <|> mCorr)
- origIsFile = fmap (isJust . submissionFileContent . entityVal) mOrig
- corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr
- Just isFile = origIsFile <|> corrIsFile
- in if
- | Just True <- origIsFile -> anchorCell (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
- | otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
- , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgTableCorState) $ \(_, mCorr) -> case mCorr of
- Nothing -> cell mempty
- Just (Entity _ SubmissionFile{..})
- | isJust submissionFileContent -> anchorCell (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
- | otherwise -> i18nCell MsgCorrected
- , Just . sortable (Just "time") (i18nCell MsgTableFileModified) $ \(mOrig, mCorr) -> let
- origTime = submissionFileModified . entityVal <$> mOrig
- corrTime = submissionFileModified . entityVal <$> mCorr
- Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
- in dateTimeCell fileTime
+ multipleSubmissionWarnWidget <- runMaybeT $ do
+ subId <- hoistMaybe msmid
+ cID <- hoistMaybe mcid
+ guardM . lift $ orM
+ [ hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubDelR
+ , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubShowR
+ , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR
+ , hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
]
- subDownloadLink cid sft fileTitle' = CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle'
- submissionFiles :: _ -> _ -> E.SqlQuery _
- submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do
- E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle
- E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission
- E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId
- E.&&. sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False)
+ guardM . lift . E.selectExists . E.from $ \(submissionUser `E.InnerJoin` (otherSubmissionUser `E.InnerJoin` submission)) -> do
+ E.on $ otherSubmissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+ E.on $ submissionUser E.^. SubmissionUserSubmission E.!=. otherSubmissionUser E.^. SubmissionUserSubmission
+ E.&&. submissionUser E.^. SubmissionUserUser E.==. otherSubmissionUser E.^. SubmissionUserUser
+ E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
+ E.&&. submission E.^. SubmissionId E.!=. E.val subId
+ E.&&. submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
+ return $ notification NotificationBroad =<< messageIconI Warning IconSubmissionUserDuplicate MsgSubmissionSomeUsersDuplicateWarning
- E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate))
- E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True) E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate))
- E.&&. (sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) E.||. E.isNothing (sf2 E.?. SubmissionFileIsDeletion))
- E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid))
+ subUsers <- maybeT (return []) $ do
+ subId <- hoistMaybe msmid
+ lift $ buddies
+ & bool id (maybe id (Set.insert . Right) muid) isOwner
+ & Set.toList
+ & mapMOf (traverse . _Right) (\uid -> (,,) <$> (encrypt uid :: DB CryptoUUIDUser) <*> getJust uid <*> getUserAuthorshipStatement mASDefinition subId uid)
+ & fmap (sortOn . over _Right $ (,,,) <$> views _2 userSurname <*> views _2 userDisplayName <*> views _2 userEmail <*> view _1)
- return (sf1, sf2)
- smid2ArchiveTable (smid,cid) = DBTable
- { dbtSQLQuery = submissionFiles smid
- , dbtRowKey = \(sf1 `E.FullOuterJoin` sf2) -> (sf1 E.?. SubmissionFileId, sf2 E.?. SubmissionFileId)
- , dbtColonnade = colonnadeFiles cid
- , dbtProj = dbrOutput <$> dbtProjId
- , dbtStyle = def
- , dbtIdent = "files" :: Text
- , dbtSorting = mconcat
- [ singletonMap "path" . SortColumn $ \(sf1 `E.FullOuterJoin` sf2) -> (E.unsafeSqlFunction "string_to_array" :: (E.SqlExpr (E.Value (Maybe String)), E.SqlExpr (E.Value String)) -> E.SqlExpr (E.Value [String])) (E.coalesce [sf1 E.?. SubmissionFileTitle, sf2 E.?. SubmissionFileTitle], E.val "/" :: E.SqlExpr (E.Value String))
- , singletonMap "time" . SortColumn $ \(sf1 `E.FullOuterJoin` sf2) -> (E.unsafeSqlFunction "GREATEST" ([sf1 E.?. SubmissionFileModified, sf2 E.?. SubmissionFileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
- ]
- , dbtFilter = mconcat
- [ singletonMap "may-access" . FilterColumn $ \(Any b) (sf1 `E.FullOuterJoin` (_ :: E.SqlExpr (Maybe (Entity SubmissionFile))))
- -> E.val b E.==. (E.val showCorrection E.||. E.isJust (sf1 E.?. SubmissionFileId))
- ]
- , dbtFilterUI = mempty
- , dbtParams = def
- , dbtCsvEncode = noCsvEncode
- , dbtCsvDecode = Nothing
- , dbtExtraReps = []
- }
- archiveTableValidator = def
- & defaultSorting [SortAscBy "path"]
- & forceFilter "may-access" (Any True)
- mFileTable <- traverse (runDB . dbTableWidget' archiveTableValidator) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
-
-
- filesCorrected <- fmap (fromMaybe False) . for msmid $ \subId -> runDB . E.selectExists . E.from $ \(sFile1 `E.LeftOuterJoin` sFile2) -> do
- E.on $ E.just (sFile1 E.^. SubmissionFileTitle) E.==. sFile2 E.?. SubmissionFileTitle
- E.&&. E.just (sFile1 E.^. SubmissionFileSubmission) E.==. sFile2 E.?. SubmissionFileSubmission
- E.&&. sFile1 E.^. SubmissionFileContent E.!=. E.joinV (sFile2 E.?. SubmissionFileContent)
- E.&&. sFile1 E.^. SubmissionFileIsUpdate E.&&. E.maybe E.false E.not_ (sFile2 E.?. SubmissionFileIsUpdate)
- E.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. E.val subId
- E.where_ $ sFile2 E.?. SubmissionFileSubmission E.==. E.just (E.val subId)
-
- sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
-
- multipleSubmissionWarnWidget <- runDB . runMaybeT $ do
- subId <- hoistMaybe msmid
- cID <- hoistMaybe mcid
- guardM . lift $ orM
- [ hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubDelR
- , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubShowR
- , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR
+ subUsersVisible <- orM
+ [ return isOwner
+ , return isLecturer
+ , return $ not sheetAnonymousCorrection
, hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR
]
- guardM . lift . E.selectExists . E.from $ \(submissionUser `E.InnerJoin` (otherSubmissionUser `E.InnerJoin` submission)) -> do
- E.on $ otherSubmissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
- E.on $ submissionUser E.^. SubmissionUserSubmission E.!=. otherSubmissionUser E.^. SubmissionUserSubmission
- E.&&. submissionUser E.^. SubmissionUserUser E.==. otherSubmissionUser E.^. SubmissionUserUser
- E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
- E.&&. submission E.^. SubmissionId E.!=. E.val subId
- E.&&. submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
- return $ notification NotificationBroad =<< messageIconI Warning IconSubmissionUserDuplicate MsgSubmissionSomeUsersDuplicateWarning
- defaultLayout $ do
- setTitleI $ MsgHeadingSubmissionEditHead tid ssh csh shn
+ return (sheetInfo, (showCorrection, correctionInvisible), mFileTable, filesCorrected, sheetTypeDesc, multipleSubmissionWarnWidget, (subUsers, subUsersVisible), isLecturer, isOwner, is _Just mASDefinition)
+
+ -- TODO(AuthorshipStatements): discuss whether to display prompt for user to update their authorship statement, if lecturer changed it
+
+ let (title, heading)
+ | Just cID <- mcid, maySubmit, not isLecturer || isOwner = (MsgSubmissionTitle tid ssh csh shn cID, MsgSubmissionHeadingEdit tid ssh csh shn cID)
+ | Just cID <- mcid = (MsgSubmissionTitle tid ssh csh shn cID, MsgSubmissionHeadingShow tid ssh csh shn cID)
+ | otherwise = (MsgSubmissionTitleNew tid ssh csh shn, MsgSubmissionHeadingNew tid ssh csh shn)
+
+ siteLayoutMsg heading $ do
+ setTitleI title
(urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID
-> let mkUrl sft = toTextUrl . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft
in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal
@@ -610,4 +630,10 @@ submissionHelper tid ssh csh shn mcid = do
, is _Just submissionRatingPoints, is _Just submissionRatingComment
]
correctionVisibleWarnWidget = guardOnM (is _Just msubmission && is _Just mcid && showCorrection) correctionInvisible
+ asStatusExplain = $(i18nWidgetFiles "authorship-statement-submission-explanation")
+ asStatuses = setOf (folded . _Right . _3) subUsers
+ & Set.union (Set.fromList [ASExists, ASMissing])
+ & Set.toList
+ & mapMaybe (\stmt -> (stmt, ) <$> asStatusExplain Map.!? toPathPiece stmt)
+ asStatusExplainWdgt = $(widgetFile "widgets/authorship-statement-submission-explanation")
$(widgetFile "submission")
diff --git a/src/Handler/Submission/Helper/ArchiveTable.hs b/src/Handler/Submission/Helper/ArchiveTable.hs
new file mode 100644
index 000000000..d7e9c4fc1
--- /dev/null
+++ b/src/Handler/Submission/Helper/ArchiveTable.hs
@@ -0,0 +1,112 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
+module Handler.Submission.Helper.ArchiveTable
+ ( mkSubmissionArchiveTable
+ ) where
+
+import Import
+import Handler.Utils
+import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Utils as E
+import qualified Database.Esqueleto.Internal.Internal as E (unsafeSqlFunction)
+
+
+type SubmissionArchiveExpr = E.SqlExpr (Maybe (Entity SubmissionFile)) `E.FullOuterJoin` E.SqlExpr (Maybe (Entity SubmissionFile))
+
+queryOriginal, queryCorrected :: Getter SubmissionArchiveExpr (E.SqlExpr (Maybe (Entity SubmissionFile)))
+queryOriginal = to $(E.sqlFOJproj 2 1)
+queryCorrected = to $(E.sqlFOJproj 2 2)
+
+
+type SubmissionArchiveData = DBRow ( Maybe (Entity SubmissionFile)
+ , Maybe (Entity SubmissionFile)
+ )
+
+resultOriginal, resultCorrected :: Traversal' SubmissionArchiveData (Entity SubmissionFile)
+resultOriginal = _dbrOutput . _1 . _Just
+resultCorrected = _dbrOutput . _2 . _Just
+
+
+mkSubmissionArchiveTable :: TermId -> SchoolId -> CourseShorthand -> SheetName
+ -> Bool -- ^ @showCorrection@
+ -> SubmissionId
+ -> DB (Bool, Widget)
+mkSubmissionArchiveTable tid ssh csh shn showCorrection smid = do
+ cID <- encrypt smid :: DB CryptoFileNameSubmission -- shouldn't be expensive due to caching
+
+ let
+ dbtIdent :: Text
+ dbtIdent = "files"
+
+ dbtSQLQuery = runReaderT $ do
+ original <- view queryOriginal
+ corrected <- view queryCorrected
+
+ lift . E.on $
+ original E.?. SubmissionFileTitle E.==. corrected E.?. SubmissionFileTitle
+ E.&&. original E.?. SubmissionFileSubmission E.==. corrected E.?. SubmissionFileSubmission
+ E.&&. original E.?. SubmissionFileId E.!=. corrected E.?. SubmissionFileId
+ E.&&. corrected E.?. SubmissionFileIsDeletion E.==. E.val (Just False)
+ E.&&. E.val showCorrection -- Do not correlate files if we don't show correction; together with `may-access` this treats corrected files like they literally don't exist
+
+ lift . E.where_ $ original E.?. SubmissionFileSubmission E.==. E.val (Just smid)
+ E.||. corrected E.?. SubmissionFileSubmission E.==. E.val (Just smid)
+
+ lift . E.where_ . E.maybe E.true E.not_ $ original E.?. SubmissionFileIsUpdate -- @original@ is unset or not an update
+ lift . E.where_ . E.maybe E.true id $ corrected E.?. SubmissionFileIsUpdate -- @corrected@ is unset or an update
+ lift . E.where_ . E.maybe E.true E.not_ $ corrected E.?. SubmissionFileIsDeletion -- @corrected@ is unset or not a deletion
+ return (original, corrected)
+ dbtRowKey = (,) <$> views queryOriginal (E.?. SubmissionFileId) <*> views queryCorrected (E.?. SubmissionFileId)
+
+ dbtProj = dbtProjId
+
+ dbtColonnade = mconcat $ catMaybes
+ [ Just . sortable (Just "path") (i18nCell MsgTableFileTitle) $ \t -> let
+ mOrig = t ^? resultOriginal
+ mCorr = t ^? resultCorrected
+ fileTitle'' = submissionFileTitle . entityVal <$> (mOrig <|> mCorr)
+ origIsFile = fmap (isJust . submissionFileContent . entityVal) mOrig
+ corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr
+ isFile' = origIsFile <|> corrIsFile
+ in maybeCell ((,) <$> fileTitle'' <*> isFile') $ \(fileTitle', isFile) -> if
+ | Just True <- origIsFile -> anchorCell (subDownloadLink SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
+ | otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
+ , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgTableCorState) $ \t -> case t ^? resultCorrected of
+ Nothing -> cell mempty
+ Just (Entity _ SubmissionFile{..}) -> tellCell (Any True) $ if
+ | isJust submissionFileContent -> anchorCell (subDownloadLink SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
+ | otherwise -> i18nCell MsgCorrected
+ , Just . sortable (Just "time") (i18nCell MsgTableFileModified) $ \t -> let
+ mOrig = t ^? resultOriginal
+ mCorr = t ^? resultCorrected
+ origTime = submissionFileModified . entityVal <$> mOrig
+ corrTime = submissionFileModified . entityVal <$> mCorr
+ fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
+ in maybeCell fileTime dateTimeCell
+ ]
+ where
+ subDownloadLink sft fileTitle' = CSubmissionR tid ssh csh shn cID $ SubDownloadR sft fileTitle'
+
+ dbtStyle = def
+
+ dbtSorting = mconcat
+ [ singletonMap "path" . SortColumn $ \r -> (E.unsafeSqlFunction "string_to_array" :: (E.SqlExpr (E.Value (Maybe String)), E.SqlExpr (E.Value String)) -> E.SqlExpr (E.Value [String])) (E.coalesce [views queryOriginal (E.?. SubmissionFileTitle) r, views queryCorrected (E.?. SubmissionFileTitle) r], E.val "/" :: E.SqlExpr (E.Value String))
+ , singletonMap "time" . SortColumn $ \r -> (E.unsafeSqlFunction "GREATEST" ([views queryOriginal (E.?. SubmissionFileModified) r, views queryCorrected (E.?. SubmissionFileModified) r] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
+ ]
+ dbtFilter = mconcat
+ [ singletonMap "may-access" . FilterColumn $ \(Any b) r
+ -> E.val b E.==. (E.val showCorrection E.||. E.isJust (views queryOriginal (E.?. SubmissionFileId) r))
+ ]
+
+ dbtFilterUI = mempty
+
+ dbtParams = def
+
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+ dbtExtraReps = []
+
+ archiveTableValidator = def
+ & defaultSorting [SortAscBy "path"]
+ & forceFilter "may-access" (Any True)
+ in over _1 getAny <$> dbTableWidget archiveTableValidator DBTable{..}
diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs
index 72ef9192a..d9976e95c 100644
--- a/src/Handler/Submission/List.hs
+++ b/src/Handler/Submission/List.hs
@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
module Handler.Submission.List
( getCorrectionsR, postCorrectionsR
, getCCorrectionsR, postCCorrectionsR
@@ -5,10 +8,13 @@ module Handler.Submission.List
, correctionsR'
, restrictAnonymous, restrictCorrector
, ratedBy, courseIs, sheetIs, userIs
- , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups
+ , resultSubmission
+ , colTerm, colSchool, colCourse, colSheet, colCorrector, colSubmissionLink, colSelect, colSubmittors, colSMatrikel, colRating, colAssigned, colRated, colPseudonyms, colRatedField, colPointsField, colMaxPointsField, colCommentField, colLastEdit, colSGroups, colAuthorshipStatementState
+ , filterUICourse, filterUITerm, filterUISchool, filterUISheetSearch, filterUIIsRated, filterUISubmission, filterUIUserNameEmail, filterUIUserMatrikelnummer, filterUICorrectorNameEmail, filterUIIsAssigned, filterUISubmissionGroup, filterUIRating, filterUIComment, filterUIPseudonym, filterUIAuthorshipStatementState
, makeCorrectionsTable
- , CorrectionTableData
+ , CorrectionTableData, CorrectionTableWhere
, ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction
+ , CorrectionTableCsvQualification(..), CorrectionTableCsvSettings(..)
) where
import Import hiding (link)
@@ -18,7 +24,6 @@ import Handler.Utils.Submission
import Handler.Utils.SheetType
import Handler.Utils.Delete
-import Data.List as List (foldr)
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
@@ -28,7 +33,8 @@ import qualified Data.CaseInsensitive as CI
import Database.Esqueleto.Utils.TH
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
-import qualified Database.Esqueleto.Internal.Internal as IE (From)
+
+import qualified Data.Conduit.Combinators as C
import Text.Hamlet (ihamletFile)
@@ -36,399 +42,741 @@ import Database.Persist.Sql (updateWhereCount)
import Data.List (genericLength)
+import qualified Data.Csv as Csv
-newtype CorrectionTableFilterProj = CorrectionTableFilterProj
+
+data CorrectionTableFilterProj = CorrectionTableFilterProj
{ corrProjFilterSubmission :: Maybe (Set [CI Char])
+ , corrProjFilterPseudonym :: Maybe (Set [CI Char])
+ , corrProjFilterAuthorshipStatementState :: Last AuthorshipStatementSubmissionState
}
-
+
instance Default CorrectionTableFilterProj where
def = CorrectionTableFilterProj
{ corrProjFilterSubmission = Nothing
+ , corrProjFilterPseudonym = Nothing
+ , corrProjFilterAuthorshipStatementState = Last Nothing
}
makeLenses_ ''CorrectionTableFilterProj
-type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
-type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
-type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym, Maybe SubmissionGroupName), CryptoFileNameSubmission, Bool {- Access to non-anonymous submission data -})
-correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v
-correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
- E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
- E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
- E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
- E.where_ $ whereClause t
- return $ returnStatement t
+type CorrectionTableExpr = ( E.SqlExpr (Entity Course)
+ `E.InnerJoin` E.SqlExpr (Entity Sheet)
+ `E.InnerJoin` E.SqlExpr (Entity Submission)
+ )
+ `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
+type CorrectionTableWhere = forall m. MonadReader CorrectionTableExpr m => m (E.SqlExpr (E.Value Bool))
+type CorrectionTableCourseData = (CourseName, CourseShorthand, TermId, SchoolId)
+type CorrectionTableUserData = (User, Maybe Pseudonym, Maybe SubmissionGroupName, Maybe AuthorshipStatementSubmissionState)
+type CorrectionTableData = DBRow ( Entity Submission
+ , Entity Sheet
+ , CorrectionTableCourseData
+ , Maybe (Entity User)
+ , Maybe UTCTime
+ , Map UserId CorrectionTableUserData
+ , CryptoFileNameSubmission
+ , Bool {- Access to non-anonymous submission data -}
+ , Maybe AuthorshipStatementSubmissionState
+ )
-lastEditQuery :: IE.From (E.SqlExpr (Entity SubmissionEdit))
- => E.SqlExpr (Entity Submission) -> E.SqlExpr (E.Value (Maybe UTCTime))
-lastEditQuery submission = E.subSelectMaybe $ E.from $ \edit -> do
- E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
- return $ E.max_ $ edit E.^. SubmissionEditTime
-queryCourse :: CorrectionTableExpr -> E.SqlExpr (Entity Course)
-queryCourse = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
+queryCourse :: Getter CorrectionTableExpr (E.SqlExpr (Entity Course))
+queryCourse = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 2 1)
-querySubmission :: CorrectionTableExpr -> E.SqlExpr (Entity Submission)
-querySubmission = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
+querySheet :: Getter CorrectionTableExpr (E.SqlExpr (Entity Sheet))
+querySheet = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 2 1)
-queryCorrector :: CorrectionTableExpr -> E.SqlExpr (Maybe (Entity User))
-queryCorrector = $(sqlLOJproj 2 2)
+querySubmission :: Getter CorrectionTableExpr (E.SqlExpr (Entity Submission))
+querySubmission = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 2 1)
+
+queryCorrector :: Getter CorrectionTableExpr (E.SqlExpr (Maybe (Entity User)))
+queryCorrector = to $(sqlLOJproj 2 2)
+
+queryLastEdit :: Getter CorrectionTableExpr (E.SqlExpr (E.Value (Maybe UTCTime)))
+queryLastEdit = querySubmission . submissionLastEdit
+ where
+ submissionLastEdit = to $ \submission -> E.subSelectMaybe . E.from $ \edit -> do
+ E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
+ return $ E.max_ $ edit E.^. SubmissionEditTime
+
+
+resultSubmission :: Lens' CorrectionTableData (Entity Submission)
+resultSubmission = _dbrOutput . _1
+
+resultSheet :: Lens' CorrectionTableData (Entity Sheet)
+resultSheet = _dbrOutput . _2
+
+resultCourseName :: Lens' CorrectionTableData CourseName
+resultCourseName = _dbrOutput . _3 . _1
+
+resultCourseShorthand :: Lens' CorrectionTableData CourseShorthand
+resultCourseShorthand = _dbrOutput . _3 . _2
+
+resultCourseTerm :: Lens' CorrectionTableData TermId
+resultCourseTerm = _dbrOutput . _3 . _3
+
+resultCourseSchool :: Lens' CorrectionTableData SchoolId
+resultCourseSchool = _dbrOutput . _3 . _4
+
+resultCorrector :: Traversal' CorrectionTableData (Entity User)
+resultCorrector = _dbrOutput . _4 . _Just
+
+resultLastEdit :: Traversal' CorrectionTableData UTCTime
+resultLastEdit = _dbrOutput . _5 . _Just
+
+resultSubmittors :: IndexedTraversal' UserId CorrectionTableData CorrectionTableUserData
+resultSubmittors = _dbrOutput . _6 . itraversed
+
+resultUserUser :: Lens' CorrectionTableUserData User
+resultUserUser = _1
+
+resultUserPseudonym :: Traversal' CorrectionTableUserData Pseudonym
+resultUserPseudonym = _2 . _Just
+
+resultUserSubmissionGroup :: Traversal' CorrectionTableUserData SubmissionGroupName
+resultUserSubmissionGroup = _3 . _Just
+
+resultUserAuthorshipStatementState :: Traversal' CorrectionTableUserData AuthorshipStatementSubmissionState
+resultUserAuthorshipStatementState = _4 . _Just
+
+resultCryptoID :: Lens' CorrectionTableData CryptoFileNameSubmission
+resultCryptoID = _dbrOutput . _7
+
+resultNonAnonymousAccess :: Lens' CorrectionTableData Bool
+resultNonAnonymousAccess = _dbrOutput . _8
+
+resultASState :: Lens' CorrectionTableData (Maybe AuthorshipStatementSubmissionState)
+resultASState = _dbrOutput . _9
+
+
+data CorrectionTableCsv = CorrectionTableCsv
+ { csvCorrectionTerm :: Maybe TermIdentifier
+ , csvCorrectionSchool :: Maybe SchoolShorthand
+ , csvCorrectionCourse :: Maybe CourseShorthand
+ , csvCorrectionSheet :: Maybe SheetName
+ , csvCorrectionSubmission :: Maybe (CI Text)
+ , csvCorrectionLastEdit :: Maybe UTCTime
+ , csvCorrectionSurname :: Maybe [Maybe UserSurname]
+ , csvCorrectionFirstName :: Maybe [Maybe UserFirstName]
+ , csvCorrectionName :: Maybe [Maybe UserDisplayName]
+ , csvCorrectionMatriculation :: Maybe [Maybe UserMatriculation]
+ , csvCorrectionEmail :: Maybe [Maybe UserEmail]
+ , csvCorrectionPseudonym :: Maybe [Maybe Pseudonym]
+ , csvCorrectionSubmissionGroup :: Maybe [Maybe SubmissionGroupName]
+ , csvCorrectionAuthorshipStatementState :: Maybe [Maybe AuthorshipStatementSubmissionState]
+ , csvCorrectionAssigned :: Maybe UTCTime
+ , csvCorrectionCorrectorName :: Maybe UserDisplayName
+ , csvCorrectionCorrectorEmail :: Maybe UserEmail
+ , csvCorrectionRatingDone :: Maybe Bool
+ , csvCorrectionRatedAt :: Maybe UTCTime
+ , csvCorrectionRatingPoints :: Maybe Points
+ , csvCorrectionRatingComment :: Maybe Text
+ } deriving (Generic)
+makeLenses_ ''CorrectionTableCsv
+
+correctionTableCsvOptions :: Csv.Options
+correctionTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 }
+
+instance Csv.ToNamedRecord CorrectionTableCsv where
+ toNamedRecord CorrectionTableCsv{..} = Csv.namedRecord
+ [ "term" Csv..= csvCorrectionTerm
+ , "school" Csv..= csvCorrectionSchool
+ , "course" Csv..= csvCorrectionCourse
+ , "sheet" Csv..= csvCorrectionSheet
+ , "submission" Csv..= csvCorrectionSubmission
+ , "last-edit" Csv..= csvCorrectionLastEdit
+ , "surname" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionSurname
+ , "first-name" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionFirstName
+ , "name" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionName
+ , "matriculation" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionMatriculation
+ , "email" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionEmail
+ , "pseudonym" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionPseudonym
+ , "submission-group" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionSubmissionGroup
+ , "authorship-statement-state" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionAuthorshipStatementState
+ , "assigned" Csv..= csvCorrectionAssigned
+ , "corrector-name" Csv..= csvCorrectionCorrectorName
+ , "corrector-email" Csv..= csvCorrectionCorrectorEmail
+ , "rating-done" Csv..= csvCorrectionRatingDone
+ , "rated-at" Csv..= csvCorrectionRatedAt
+ , "rating-points" Csv..= csvCorrectionRatingPoints
+ , "rating-comment" Csv..= csvCorrectionRatingComment
+ ]
+ where
+ mkEmpty = \case
+ [Nothing] -> []
+ x -> x
+
+instance Csv.DefaultOrdered CorrectionTableCsv where
+ headerOrder = Csv.genericHeaderOrder correctionTableCsvOptions
+
+instance Csv.FromNamedRecord CorrectionTableCsv where
+ parseNamedRecord csv
+ = CorrectionTableCsv
+ <$> csv .:?? "term"
+ <*> csv .:?? "school"
+ <*> csv .:?? "course"
+ <*> csv .:?? "sheet"
+ <*> csv .:?? "submission"
+ <*> csv .:?? "last-edit"
+ <*> fmap (fmap unCsvSemicolonList) (csv .:?? "surname")
+ <*> fmap (fmap unCsvSemicolonList) (csv .:?? "first-name")
+ <*> fmap (fmap unCsvSemicolonList) (csv .:?? "name")
+ <*> fmap (fmap unCsvSemicolonList) (csv .:?? "matriculation")
+ <*> fmap (fmap unCsvSemicolonList) (csv .:?? "email")
+ <*> fmap (fmap unCsvSemicolonList) (csv .:?? "pseudonym")
+ <*> fmap (fmap unCsvSemicolonList) (csv .:?? "submission-group")
+ <*> fmap (fmap unCsvSemicolonList) (csv .:?? "authorship-statement-state")
+ <*> csv .:?? "assigned"
+ <*> csv .:?? "corrector-name"
+ <*> csv .:?? "corrector-email"
+ <*> csv .:?? "rating-done"
+ <*> csv .:?? "rated-at"
+ <*> csv .:?? "rating-points"
+ <*> csv .:?? "rating-comment"
+
+instance CsvColumnsExplained CorrectionTableCsv where
+ csvColumnsExplanations = genericCsvColumnsExplanations correctionTableCsvOptions $ Map.fromList
+ [ ('csvCorrectionTerm , MsgCsvColumnCorrectionTerm)
+ , ('csvCorrectionSchool , MsgCsvColumnCorrectionSchool)
+ , ('csvCorrectionCourse , MsgCsvColumnCorrectionCourse)
+ , ('csvCorrectionSheet , MsgCsvColumnCorrectionSheet)
+ , ('csvCorrectionSubmission , MsgCsvColumnCorrectionSubmission)
+ , ('csvCorrectionLastEdit , MsgCsvColumnCorrectionLastEdit)
+ , ('csvCorrectionSurname , MsgCsvColumnCorrectionSurname)
+ , ('csvCorrectionFirstName , MsgCsvColumnCorrectionFirstName)
+ , ('csvCorrectionName , MsgCsvColumnCorrectionName)
+ , ('csvCorrectionMatriculation , MsgCsvColumnCorrectionMatriculation)
+ , ('csvCorrectionEmail , MsgCsvColumnCorrectionEmail)
+ , ('csvCorrectionPseudonym , MsgCsvColumnCorrectionPseudonym)
+ , ('csvCorrectionSubmissionGroup, MsgCsvColumnCorrectionSubmissionGroup)
+ , ('csvCorrectionAuthorshipStatementState, MsgCsvColumnCorrectionAuthorshipStatementState)
+ , ('csvCorrectionAssigned , MsgCsvColumnCorrectionAssigned)
+ , ('csvCorrectionCorrectorName , MsgCsvColumnCorrectionCorrectorName)
+ , ('csvCorrectionCorrectorEmail , MsgCsvColumnCorrectionCorrectorEmail)
+ , ('csvCorrectionRatingDone , MsgCsvColumnCorrectionRatingDone)
+ , ('csvCorrectionRatedAt , MsgCsvColumnCorrectionRatedAt)
+ , ('csvCorrectionRatingPoints , MsgCsvColumnCorrectionRatingPoints)
+ , ('csvCorrectionRatingComment , MsgCsvColumnCorrectionRatingComment)
+ ]
+
+data CorrectionTableCsvQualification
+ = CorrectionTableCsvNoQualification
+ | CorrectionTableCsvQualifySheet
+ | CorrectionTableCsvQualifyCourse
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite)
+
+correctionTableCsvHeader :: Bool -- ^ @showCorrector@
+ -> CorrectionTableCsvQualification -> Csv.Header
+correctionTableCsvHeader showCorrector qual = Csv.header $ catMaybes
+ [ guardOn (qual >= CorrectionTableCsvQualifyCourse) "term"
+ , guardOn (qual >= CorrectionTableCsvQualifyCourse) "school"
+ , guardOn (qual >= CorrectionTableCsvQualifyCourse) "course"
+ , guardOn (qual >= CorrectionTableCsvQualifySheet) "sheet"
+ , pure "submission"
+ , pure "last-edit"
+ , pure "surname"
+ , pure "first-name"
+ , pure "name"
+ , pure "matriculation"
+ , pure "email"
+ , pure "pseudonym"
+ , pure "submission-group"
+ , pure "authorship-statement-state"
+ , pure "assigned"
+ , guardOn showCorrector "corrector-name"
+ , guardOn showCorrector "corrector-email"
+ , pure "rating-done"
+ , pure "rated-at"
+ , pure "rating-points"
+ , pure "rating-comment"
+ ]
+
+data CorrectionTableCsvSettings = forall filename sheetName.
+ ( RenderMessage UniWorX filename, RenderMessage UniWorX sheetName
+ ) => CorrectionTableCsvSettings
+ { cTableCsvQualification :: CorrectionTableCsvQualification
+ , cTableCsvName :: filename
+ , cTableCsvSheetName :: sheetName
+ , cTableShowCorrector :: Bool
+ }
+
+newtype CorrectionTableCsvExportData = CorrectionTableCsvExportData
+ { csvCorrectionSingleSubmittors :: Bool
+ } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+instance Default CorrectionTableCsvExportData where
+ def = CorrectionTableCsvExportData False
+
+data CorrectionTableJson = CorrectionTableJson
+ { jsonCorrectionTerm :: TermIdentifier
+ , jsonCorrectionSchool :: SchoolShorthand
+ , jsonCorrectionCourse :: CourseShorthand
+ , jsonCorrectionSheet :: SheetName
+ , jsonCorrectionLastEdit :: Maybe UTCTime
+ , jsonCorrectionSubmittors :: Maybe [CorrectionTableSubmittorJson]
+ , jsonCorrectionAssigned :: Maybe UTCTime
+ , jsonCorrectionCorrectorName :: Maybe UserDisplayName
+ , jsonCorrectionCorrectorEmail :: Maybe UserEmail
+ , jsonCorrectionRatingDone :: Bool
+ , jsonCorrectionRatedAt :: Maybe UTCTime
+ , jsonCorrectionRatingPoints :: Maybe Points
+ , jsonCorrectionRatingComment :: Maybe Text
+ } deriving (Generic)
+
+data CorrectionTableSubmittorJson = CorrectionTableSubmittorJson
+ { jsonCorrectionSurname :: UserSurname
+ , jsonCorrectionFirstName :: UserFirstName
+ , jsonCorrectionName :: UserDisplayName
+ , jsonCorrectionMatriculation :: Maybe UserMatriculation
+ , jsonCorrectionEmail :: UserEmail
+ , jsonCorrectionPseudonym :: Maybe Pseudonym
+ , jsonCorrectionSubmissionGroup :: Maybe SubmissionGroupName
+ , jsonCorrectionAuthorshipStatementState :: Maybe AuthorshipStatementSubmissionState
+ } deriving (Generic)
+
+deriveToJSON defaultOptions
+ { fieldLabelModifier = camelToPathPiece' 2
+ } ''CorrectionTableSubmittorJson
+
+deriveToJSON defaultOptions
+ { fieldLabelModifier = camelToPathPiece' 2
+ } ''CorrectionTableJson
-- Where Clauses
ratedBy :: UserId -> CorrectionTableWhere
-ratedBy uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
+ratedBy uid = views querySubmission $ (E.==. E.justVal uid) . (E.^. SubmissionRatingBy)
courseIs :: CourseId -> CorrectionTableWhere
-courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = course E.^. CourseId E.==. E.val cid
+courseIs cid = views queryCourse $ (E.==. E.val cid) . (E.^. CourseId)
sheetIs :: Key Sheet -> CorrectionTableWhere
-sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
+sheetIs shid = views querySheet $ (E.==. E.val shid) . (E.^. SheetId)
userIs :: Key User -> CorrectionTableWhere
-userIs uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = E.exists . E.from $ \submissionUser ->
+userIs uid = views querySubmission $ \submission -> E.exists . E.from $ \submissionUser ->
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.&&. submissionUser E.^. SubmissionUserUser E.==. E.val uid
+
-- Columns
colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colTerm = sortable (Just "term") (i18nCell MsgTableTerm)
- $ \DBRow{ dbrOutput } ->
- textCell $ termToText $ unTermKey $ dbrOutput ^. _3 . _3 -- kurze Semsterkürzel
+colTerm = sortable (Just "term") (i18nCell MsgTableTerm) . views (resultCourseTerm . _TermId) $ textCell . termToText
colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSchool = sortable (Just "school") (i18nCell MsgTableCourseSchool)
- $ \DBRow{ dbrOutput } -> let course = dbrOutput ^. _3 in
- anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|]
+colSchool = sortable (Just "school") (i18nCell MsgTableCourseSchool) $ \x ->
+ let tid = x ^. resultCourseTerm
+ ssh = x ^. resultCourseSchool
+ in anchorCell (TermSchoolCourseListR tid ssh)
+ (ssh ^. _SchoolId)
colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colCourse = sortable (Just "course") (i18nCell MsgTableCourse)
- $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _, _, _) } -> courseCellCL (tid,sid,csh)
+colCourse = sortable (Just "course") (i18nCell MsgTableCourse) $ views ($(multifocusG 3) resultCourseTerm resultCourseSchool resultCourseShorthand) courseCellCL
colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSheet = sortable (Just "sheet") (i18nCell MsgTableSheet) $ \row ->
- let sheet = row ^. _dbrOutput . _2
- course= row ^. _dbrOutput . _3
- tid = course ^. _3
- ssh = course ^. _4
- csh = course ^. _2
- shn = sheetName $ entityVal sheet
- in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|_{shn}|]
+colSheet = sortable (Just "sheet") (i18nCell MsgTableSheet) $ \x ->
+ let tid = x ^. resultCourseTerm
+ ssh = x ^. resultCourseSchool
+ csh = x ^. resultCourseShorthand
+ shn = x ^. resultSheet . _entityVal . _sheetName
+ in anchorCell (CSheetR tid ssh csh shn SShowR) shn
colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colCorrector = sortable (Just "corrector") (i18nCell MsgTableCorrector) $ \case
- DBRow{ dbrOutput = (_, _, _, Nothing , _, _, _, _) } -> cell mempty
- DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _, _, _) } -> userCell userDisplayName userSurname
+colCorrector = sortable (Just "corrector") (i18nCell MsgTableCorrector) $ \x ->
+ maybeCell (x ^? resultCorrector) $ \(Entity _ User{..}) -> userCell userDisplayName userSurname
colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission)
- $ \DBRow{ dbrOutput=(_, sheet, course, _, _,_, cid, _) } ->
- let csh = course ^. _2
- tid = course ^. _3
- ssh = course ^. _4
- shn = sheetName $ entityVal sheet
- in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn cid SubShowR) (toPathPiece cid)
+colSubmissionLink = sortable (Just "submission") (i18nCell MsgTableSubmission) $ \x ->
+ let tid = x ^. resultCourseTerm
+ ssh = x ^. resultCourseSchool
+ csh = x ^. resultCourseShorthand
+ shn = x ^. resultSheet . _entityVal . _sheetName
+ subCID = x ^. resultCryptoID
+ in anchorCellC $cacheIdentHere (CSubmissionR tid ssh csh shn subCID SubShowR) (toPathPiece subCID)
colSelect :: forall act h epId. (Semigroup act, Monoid act, Headedness h, Ord epId) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary epId))
-colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(_, _, _, _, _, _, cid, _) } -> return cid
+colSelect = dbSelect (_1 . applying _2) id $ views resultCryptoID return
+
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users, _, hasAccess) } ->
- let
- csh = course ^. _2
- tid = course ^. _3
- ssh = course ^. _4
- link cid = CourseR tid ssh csh $ CUserR cid
- protoCell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo, _)) ->
- anchorCellCM $cacheIdentHere (link <$> encrypt userId) $ case mPseudo of
- Nothing -> nameWidget userDisplayName userSurname
- Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review _PseudonymText p})|]
- in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
- | otherwise -> mempty
+colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x ->
+ let tid = x ^. resultCourseTerm
+ ssh = x ^. resultCourseSchool
+ csh = x ^. resultCourseShorthand
+ link uCID = CourseR tid ssh csh $ CUserR uCID
+ protoCell = listCell (sortOn (view $ _2 . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) $ itoListOf resultSubmittors x) $ \(encrypt -> mkUCID, u) ->
+ let User{..} = u ^. resultUserUser
+ mPseudo = u ^? resultUserPseudonym
+ in anchorCellCM $cacheIdentHere (link <$> mkUCID)
+ [whamlet|
+ $newline never
+ ^{nameWidget userDisplayName userSurname}
+ $maybe p <- mPseudo
+ \ (#{review _PseudonymText p})
+ |]
+ in guardMonoid (x ^. resultNonAnonymousAccess) $
+ protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput=(_, _, (_, csh, tid, ssh), _, _, users, _, hasAccess) } ->
- let protoCell = listCell (Map.toList $ Map.mapMaybe (\x@(User{userMatrikelnummer}, _, _) -> (x,) <$> assertM (not . null) userMatrikelnummer) users) $ \(userId, (_, matr)) -> anchorCellCM $cacheIdentHere (CourseR tid ssh csh . CUserR <$> encrypt userId) matr
- in if | hasAccess -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
- | otherwise -> mempty
+colSMatrikel = sortable (Just "submittors-matriculation") (i18nCell MsgTableMatrikelNr) $ \x ->
+ let protoCell = listCell (sort $ x ^.. resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) wgtCell
+ in guardMonoid (x ^. resultNonAnonymousAccess) $
+ protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colSGroups :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colSGroups = sortable (Just "submittors-group") (i18nCell MsgTableSubmissionGroup) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{..}, _, _, _, users, _, hasAccess) } ->
- let protoCell = listCell (nubOn (view _2) . Map.toList $ Map.mapMaybe (view _3) users) $ \(_, sGroup) -> cell $ toWidget sGroup
- in if | hasAccess
- , is _RegisteredGroups sheetGrouping
- -> protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
- | otherwise
- -> mempty
+colSGroups = sortable (Just "submittors-group") (i18nCell MsgTableSubmissionGroup) $ \x ->
+ let protoCell = listCell (setOf (resultSubmittors . resultUserSubmissionGroup) x) wgtCell
+ in guardMonoid (x ^. resultNonAnonymousAccess) $
+ protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
-colRating :: forall m a. IsDBTable m (a, SheetTypeSummary SqlBackendKey) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary SqlBackendKey))
-colRating = sortable (Just "rating") (i18nCell MsgTableRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _, _, _) } ->
- let csh = course ^. _2
- tid = course ^. _3
- ssh = course ^. _4
- -- shn = sheetName
+colRating :: forall m a a'. (IsDBTable m a, a ~ (a', SheetTypeSummary SqlBackendKey)) => Colonnade Sortable CorrectionTableData (DBCell m a)
+colRating = colRating' _2
- mkRoute = do
- cid <- encrypt subId
- return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
- in mconcat
- [ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating")
- , writerCell $ do
- let
- summary :: SheetTypeSummary SqlBackendKey
- summary = sheetTypeSum sheetType $ submissionRatingPoints <* guard (submissionRatingDone sub)
- scribe (_2 :: Lens' (a, SheetTypeSummary SqlBackendKey) (SheetTypeSummary SqlBackendKey)) summary
- ]
+colRating' :: forall m a. IsDBTable m a => ASetter' a (SheetTypeSummary SqlBackendKey) -> Colonnade Sortable CorrectionTableData (DBCell m a)
+colRating' l = sortable (Just "rating") (i18nCell MsgTableRating) $ \x ->
+ let tid = x ^. resultCourseTerm
+ ssh = x ^. resultCourseSchool
+ csh = x ^. resultCourseShorthand
+ shn = x ^. resultSheet . _entityVal . _sheetName
+ cID = x ^. resultCryptoID
+ sub@Submission{..} = x ^. resultSubmission . _entityVal
+ Sheet{..} = x ^. resultSheet . _entityVal
+
+ mkRoute = return $ CSubmissionR tid ssh csh shn cID CorrectionR
+ in mconcat
+ [ anchorCellCM $cacheIdentHere mkRoute $(widgetFile "widgets/rating/rating")
+ , writerCell $ do
+ let summary :: SheetTypeSummary SqlBackendKey
+ summary = sheetTypeSum sheetType $ submissionRatingPoints <* guard (submissionRatingDone sub)
+ scribe l summary
+ ]
colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } ->
- maybe mempty dateTimeCell submissionRatingAssigned
+colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingAssigned . _Just) dateTimeCell
colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _, _, _) } ->
- maybe mempty dateTimeCell submissionRatingTime
+colRated = sortable (Just "ratingtime") (i18nCell MsgTableRatingTime) $ \x -> maybeCell (x ^? resultSubmission . _entityVal . _submissionRatingTime . _Just) dateTimeCell
colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users, _, _) } -> let
- lCell = listCell (catMaybes $ view (_2 . _2) <$> Map.toList users) $ \pseudo ->
- cell [whamlet|#{review _PseudonymText pseudo}|]
- in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \x ->
+ let protoCell = listCell (sort $ x ^.. resultSubmittors . resultUserPseudonym . re _PseudonymText) wgtCell
+ in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
-colRatedField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData)))
-colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
- (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
- (\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
+colRatedField :: a' ~ (Bool, a, b) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData)))
+colRatedField = colRatedField' _1
-colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
-colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
- (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
- (\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _, _, _) } mkUnique -> case sheetType of
- NotGraded -> pure $ over (_1.mapped) (_2 .~) (FormSuccess Nothing, mempty)
- _other -> over (_1.mapped) (_2 .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
+colRatedField' :: ASetter' a Bool -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData)))
+colRatedField' l = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
+ (views (resultSubmission . _entityKey) return)
+ (\(views (resultSubmission . _entityVal) submissionRatingDone -> done) mkUnique -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
+
+colPointsField :: a' ~ (a, Maybe Points, b) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData)))
+colPointsField = colPointsField' _2
+
+colPointsField' :: ASetter' a (Maybe Points) -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData)))
+colPointsField' l = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
+ (views (resultSubmission . _entityKey) return)
+ (\(view $ $(multifocusG 2) (resultSubmission . _entityVal) (resultSheet . _entityVal) -> (Submission{..}, Sheet{..})) mkUnique -> case sheetType of
+ NotGraded -> pure $ over (_1.mapped) (l .~) (FormSuccess Nothing, mempty)
+ _other -> over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) (fsUniq mkUnique "points") (Just submissionRatingPoints)
)
-colMaxPointsField :: _ => Colonnade Sortable CorrectionTableData (DBCell m (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
-colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgTableSheetType) $ \DBRow{ dbrOutput=(_, Entity _ Sheet{sheetCourse, sheetType}, _, _, _, _, _, _) } -> cell $ do
+colMaxPointsField :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
+colMaxPointsField = sortable (Just "sheet-type") (i18nCell MsgTableSheetType) $ \x -> cell $ do
+ let Sheet{..} = x ^. resultSheet . _entityVal
sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
- tr <- getTranslate
- toWidget $ sheetTypeDesc tr
+ toWidget . sheetTypeDesc =<< getTranslate
-colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
-colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
- (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _, _, _) } -> return subId)
- (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
+colCommentField :: a' ~ (a, b, Maybe Text) => Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a' CorrectionTableData)))
+colCommentField = colCommentField' _3
+
+colCommentField' :: ASetter' a (Maybe Text) -> Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId a CorrectionTableData)))
+colCommentField' l = sortable (Just "comment") (i18nCell MsgRatingComment) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
+ (views (resultSubmission . _entityKey) return)
+ (\(view (resultSubmission . _entityVal) -> Submission{..}) mkUnique -> over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
-colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $
- \DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _, _, _) } -> maybe mempty dateTimeCell mbLastEdit
+colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^? resultLastEdit) dateTimeCell
+
+colAuthorshipStatementState :: forall m a. IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
+colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmissionUserAuthorshipStatementState) $ \x ->
+ let heatC :: AuthorshipStatementSubmissionState -> DBCell m a -> DBCell m a
+ heatC s c
+ = c
+ & cellAttrs %~ addAttrsClass "heated"
+ & cellAttrs <>~ pure ("style", [st|--hotness: #{tshow (boolHeat (s /= ASExists))}|])
+ tid = x ^. resultCourseTerm
+ ssh = x ^. resultCourseSchool
+ csh = x ^. resultCourseShorthand
+ shn = x ^. resultSheet . _entityVal . _sheetName
+ cID = x ^. resultCryptoID
+
+ asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR
+ in maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget))
+
+
+filterUICourse :: Handler (OptionList Text) -> DBFilterUI
+filterUICourse courseOptions = flip (prismAForm $ singletonFilter "course") $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse)
+
+filterUITerm :: Handler (OptionList Text) -> DBFilterUI
+filterUITerm termOptions = flip (prismAForm $ singletonFilter "term") $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTableTerm)
+
+filterUISchool :: Handler (OptionList Text) -> DBFilterUI
+filterUISchool schoolOptions = flip (prismAForm $ singletonFilter "school") $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool)
+
+filterUISheetSearch :: DBFilterUI
+filterUISheetSearch mPrev = singletonMap "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
+
+filterUIIsRated :: DBFilterUI
+filterUIIsRated = flip (prismAForm $ singletonFilter "israted" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime)
+
+filterUISubmission :: DBFilterUI
+filterUISubmission = flip (prismAForm $ singletonFilter "submission") $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
+
+filterUIPseudonym :: DBFilterUI
+filterUIPseudonym = flip (prismAForm $ singletonFilter "pseudonym") $ aopt (lift `hoistField` textField) (fslI MsgSubmissionPseudonym)
+
+filterUIUserNameEmail :: DBFilterUI
+filterUIUserNameEmail = flip (prismAForm $ singletonFilter "user-name-email") $ aopt textField (fslI MsgTableCourseMembers)
+
+filterUIUserMatrikelnummer :: DBFilterUI
+filterUIUserMatrikelnummer = flip (prismAForm $ singletonFilter "user-matriclenumber") $ aopt textField (fslI MsgTableMatrikelNr)
+
+filterUICorrectorNameEmail :: DBFilterUI
+filterUICorrectorNameEmail = flip (prismAForm $ singletonFilter "corrector-name-email") $ aopt textField (fslI MsgTableCorrector)
+
+filterUIIsAssigned :: DBFilterUI
+filterUIIsAssigned = flip (prismAForm $ singletonFilter "isassigned" . maybePrism _PathPiece) $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector)
+
+filterUISubmissionGroup :: DBFilterUI
+filterUISubmissionGroup = flip (prismAForm $ singletonFilter "submission-group") $ aopt textField (fslI MsgTableSubmissionGroup)
+
+filterUIRating :: DBFilterUI
+filterUIRating = flip (prismAForm $ singletonFilter "rating" . maybePrism _PathPiece) $ aopt (lift `hoistField` pointsField) (fslI MsgColumnRatingPoints)
+
+filterUIComment :: DBFilterUI
+filterUIComment mPrev = singletonMap "comment" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgRatingComment) (Just <$> listToMaybe =<< (Map.lookup "comment" =<< mPrev))
+
+filterUIAuthorshipStatementState :: DBFilterUI
+filterUIAuthorshipStatementState = flip (prismAForm $ singletonFilter "as-state" . maybePrism _PathPiece) $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) optionsFinite :: Field _ AuthorshipStatementSubmissionState) (fslI MsgSubmissionUserAuthorshipStatementState)
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
- => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x)
-makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtParams = do
- let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
- dbtSQLQuery = correctionsTableQuery whereClause
- (\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
- let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName)
- , course E.^. CourseShorthand
- , course E.^. CourseTerm
- , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
- )
- in (submission, sheet, crse, corrector, lastEditQuery submission)
- )
- dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
- (submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput
- cid <- encrypt sId
- forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria ->
- let haystack = map CI.mk . unpack $ toPathPiece cid
- in guard $ any (`isInfixOf` haystack) criteria
+ => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> Maybe CorrectionTableCsvSettings -> PSValidator m x -> DBParams m x -> DB (DBResult m x)
+makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' mCSVSettings psValidator dbtParams
+ = let dbtSQLQuery = runReaderT $ do
+ course <- view queryCourse
+ sheet <- view querySheet
+ submission <- view querySubmission
+ corrector <- view queryCorrector
- submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
- E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
- E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
- E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
- E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
- E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
- let submissionGroup' = E.subSelectMaybe . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
- E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
- E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
- E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
- return . E.just $ submissionGroup E.^. SubmissionGroupName
+ lift $ do
+ E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
+ E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
+ E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
- return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup')
- let
- submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors
- nonAnonymousAccess <- lift . lift $ or2M
- (return $ not sheetAnonymousCorrection)
- (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
+ lastEdit <- view queryLastEdit
- return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess)
- dbTable psValidator DBTable
- { dbtSQLQuery
- , dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
- , dbtColonnade
- , dbtProj
- , dbtSorting = Map.fromList
- [ ( "term"
- , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
- )
- , ( "school"
- , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseSchool
- )
- , ( "course"
- , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
- )
- , ( "sheet"
- , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
- )
- , ( "corrector"
- , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
- )
- , ( "rating"
- , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
- )
- , ( "sheet-type"
- , SortColumns $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) ->
- [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value))
- , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value))
- , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value))
+ let crse = ( course E.^. CourseName
+ , course E.^. CourseShorthand
+ , course E.^. CourseTerm
+ , course E.^. CourseSchool
+ )
+
+ lift . E.where_ =<< whereClause
+
+ return (submission, sheet, crse, corrector, lastEdit)
+ dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
+ (submission@(Entity sId _), sheet@(Entity shId Sheet{..}), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) <- view $ _dbtProjRow . _dbrOutput
+
+ cid <- encrypt sId
+ forMM_ (view $ _dbtProjFilter . _corrProjFilterSubmission) $ \criteria ->
+ let haystack = map CI.mk . unpack $ toPathPiece cid
+ in guard $ any (`isInfixOf` haystack) criteria
+
+
+ submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
+ E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
+ E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
+ E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+ E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
+ E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
+ let submissionGroup' = E.subSelectMaybe . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
+ E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
+ E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
+ E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
+ return . E.just $ submissionGroup E.^. SubmissionGroupName
+
+ return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup')
+
+ mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet
+ (submittorMap, fmap getMax -> asState) <- runWriterT . flip foldMapM submittors $ \(Entity userId user, E.Value pseudo, E.Value sGroup) -> do
+ asState <- for mASDefinition $ \_ -> lift . lift . lift $ getUserAuthorshipStatement mASDefinition sId userId
+ tell $ Max <$> asState
+ return $ Map.singleton userId (user, pseudo, sGroup, asState)
+
+ forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion ->
+ guard $ asState == Just criterion
+
+ forMM_ (view $ _dbtProjFilter . _corrProjFilterPseudonym) $ \criteria ->
+ let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap
+ in guard $ any (\haystack -> any (`isInfixOf` haystack) criteria) haystacks
+
+ nonAnonymousAccess <- lift . lift $ or2M
+ (return $ not sheetAnonymousCorrection)
+ (hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR)
+
+ return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap, cid, nonAnonymousAccess, asState)
+ dbtRowKey = views querySubmission (E.^. SubmissionId)
+ dbtSorting = mconcat
+ [ singletonMap "term" . SortColumn $ views queryCourse (E.^. CourseTerm)
+ , singletonMap "school" . SortColumn $ views queryCourse (E.^. CourseSchool)
+ , singletonMap "course" . SortColumn $ views queryCourse (E.^. CourseShorthand)
+ , singletonMap "sheet" . SortColumn $ views querySheet (E.^. SheetName)
+ , singletonMap "corrector" . SortColumns $ \x ->
+ [ SomeExprValue (views queryCorrector (E.?. UserSurname) x)
+ , SomeExprValue (views queryCorrector (E.?. UserDisplayName) x)
+ ]
+ , singletonMap "rating" . SortColumn $ views querySubmission (E.^. SubmissionRatingPoints)
+ , singletonMap "sheet-type" . SortColumns $ \(view querySheet -> sheet) ->
+ [ SomeExprValue ((sheet E.^. SheetType) E.->. "type" :: E.SqlExpr (E.Value Value))
+ , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "max" :: E.SqlExpr (E.Value Value))
+ , SomeExprValue (((sheet E.^. SheetType) E.->. "grading" :: E.SqlExpr (E.Value Value)) E.->. "passing" :: E.SqlExpr (E.Value Value))
+ ]
+ , singletonMap "israted" . SortColumn $ views querySubmission $ E.not_ . E.isNothing . (E.^. SubmissionRatingTime)
+ , singletonMap "ratingtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingTime)
+ , singletonMap "assignedtime" . SortColumn $ views querySubmission (E.^. SubmissionRatingAssigned)
+ , singletonMap "submittors" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) x
+ , singletonMap "submittors-matriculation" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserUser . _userMatrikelnummer . _Just) x
+ , singletonMap "submittors-group" . SortProjected . comparing $ \x -> guardOn @Maybe (x ^. resultNonAnonymousAccess) $ setOf (resultSubmittors . resultUserSubmissionGroup) x
+ , singletonMap "submittors-pseudonyms" . SortProjected . comparing $ \x -> setOf (resultSubmittors . resultUserPseudonym . re _PseudonymText) x
+ , singletonMap "comment" . SortColumn $ views querySubmission (E.^. SubmissionRatingComment) -- sorting by comment specifically requested by correctors to easily see submissions to be done
+ , singletonMap "last-edit" . SortColumn $ view queryLastEdit
+ , singletonMap "submission" . SortProjected . comparing $ views resultCryptoID toPathPiece
+ , singletonMap "as-state" . SortProjected . comparing $ view resultASState
]
- )
- , ( "israted"
- , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime
- )
- , ( "ratingtime"
- , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime
- )
- , ( "assignedtime"
- , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingAssigned
- )
- , ( "submittors"
- , SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap ((userSurname &&& userDisplayName) . view _1) $ Map.elems submittors
- )
- , ( "submittors-matriculation"
- , SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view $ _1 . _userMatrikelnummer) $ Map.elems submittors
- )
- , ( "submittors-group"
- , SortProjected . comparing $ \DBRow{ dbrOutput = (_, _, _, _, _, submittors, _, hasAccess) } -> guardOn @Maybe hasAccess . fmap (view _3) $ Map.elems submittors
- )
- , ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done
- , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment
- )
- , ( "last-edit"
- , SortColumn $ \((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) -> lastEditQuery submission
- )
- , ( "submission"
- , SortProjected . comparing $ toPathPiece . view (_dbrOutput . _7)
- )
- ]
- , dbtFilter = Map.fromList
- [ ( "term"
- , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
- | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
- | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
- )
- , ( "school"
- , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) sids -> if
- | Set.null sids -> E.val True :: E.SqlExpr (E.Value Bool)
- | otherwise -> course E.^. CourseSchool `E.in_` E.valList (Set.toList sids)
- )
- , ( "course"
- , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
- | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
- | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
- )
- , ( "sheet"
- , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
- | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
- | otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
- )
- , ( "sheet-search"
- , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> case getLast (shns :: Last (CI Text)) of
- Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
- Just needle -> sheet E.^. SheetName `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
- )
- , ( "corrector"
- , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
- | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
- | otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
- E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
- )
- , ( "isassigned"
- , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
- Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
- Just True -> E.isJust $ submission E.^. SubmissionRatingBy
- Just False-> E.isNothing $ submission E.^. SubmissionRatingBy
- )
- , ( "israted"
- , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
- Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
- Just True -> E.isJust $ submission E.^. SubmissionRatingTime
- Just False-> E.isNothing $ submission E.^. SubmissionRatingTime
- )
- , ( "corrector-name-email" -- corrector filter does not work for text-filtering
- , FilterColumn $ E.anyFilter
- [ E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserSurname)
- , E.mkContainsFilterWith Just $ queryCorrector >>> (E.?. UserDisplayName)
- , E.mkContainsFilterWith (Just . CI.mk) $ queryCorrector >>> (E.?. UserEmail)
+ dbtFilter = mconcat
+ [ singletonMap "term" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseTerm)
+ , singletonMap "school" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseSchool)
+ , singletonMap "course" . FilterColumn . E.mkExactFilter $ views queryCourse (E.^. CourseShorthand)
+ , singletonMap "sheet" . FilterColumn . E.mkExactFilter $ views querySheet (E.^. SheetName)
+ , singletonMap "sheet-search" . FilterColumn . E.mkContainsFilter $ views querySheet (E.^. SheetName)
+ , singletonMap "corrector" . FilterColumn . E.mkExactFilterWith Just $ views queryCorrector (E.?. UserIdent)
+ , singletonMap "isassigned" . FilterColumn . E.mkExactFilterLast $ views querySubmission (E.isJust . (E.^. SubmissionRatingBy))
+ , singletonMap "israted" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone
+ , singletonMap "corrector-name-email" . FilterColumn $ E.anyFilter
+ [ E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserSurname)
+ , E.mkContainsFilterWith Just $ views queryCorrector (E.?. UserDisplayName)
+ , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserEmail)
+ , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserIdent)
+ , E.mkContainsFilterWith (Just . CI.mk) $ views queryCorrector (E.?. UserDisplayEmail)
]
- )
- , ( "user-name-email"
- , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do
+ , singletonMap "user-name-email" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
- E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
- E.where_ $ (\f -> f user $ Set.singleton needle) $ E.anyFilter
+ E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission
+ E.where_ $ E.anyFilter
[ E.mkContainsFilter (E.^. UserSurname)
, E.mkContainsFilter (E.^. UserDisplayName)
, E.mkContainsFilterWith CI.mk (E.^. UserEmail)
- ]
- )
- , ( "user-matriclenumber"
- , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do
+ , E.mkContainsFilterWith CI.mk (E.^. UserIdent)
+ , E.mkContainsFilterWith CI.mk (E.^. UserDisplayEmail)
+ ] user (Set.singleton needle)
+ , singletonMap "user-matriclenumber" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
- E.where_ $ querySubmission table E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
- E.where_ $ (\f -> f user $ Set.singleton needle) $
- E.mkContainsFilter (E.^. UserMatrikelnummer)
- )
- , ( "submission-group"
- , FilterColumn $ E.mkExistsFilter $ \table needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
+ E.where_ $ dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission
+ E.where_ $ E.mkContainsFilterWith Just (E.^. UserMatrikelnummer) user (Set.singleton needle)
+ , singletonMap "submission-group" . FilterColumn $ E.mkExistsFilter $ \row needle -> E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do
+ E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
- E.where_ $ queryCourse table E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
- E.where_ $ (\f -> f submissionGroup $ Set.singleton needle) $
- E.mkContainsFilter (E.^. SubmissionGroupName)
- )
- , ( "rating-visible"
- , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
- Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
- Just True -> E.isJust $ submission E.^. SubmissionRatingTime
- Just False-> E.isNothing $ submission E.^. SubmissionRatingTime
- )
- , ( "rating"
- , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) pts -> if
- | Set.null pts -> E.val True :: E.SqlExpr (E.Value Bool)
- | otherwise -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (\p -> p `E.in_` E.valList (Set.toList pts)) (submission E.^. SubmissionRatingPoints)
- )
- , ( "comment"
- , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) comm -> case getLast (comm :: Last Text) of
- Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
- Just needle -> E.maybe (E.val False :: E.SqlExpr (E.Value Bool)) (E.isInfixOf $ E.val needle) (submission E.^. SubmissionRatingComment)
- )
- , ( "submission"
- , FilterProjected (_corrProjFilterSubmission ?~)
- -- , FilterProjected $ \(DBRow{..} :: CorrectionTableData) (criteria :: Set Text) ->
- -- let cid = map CI.mk . unpack . toPathPiece $ dbrOutput ^. _7
- -- criteria' = map CI.mk . unpack <$> Set.toList criteria
- -- in any (`isInfixOf` cid) criteria'
- )
- ]
- , dbtFilterUI = fromMaybe mempty dbtFilterUI
- , dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI }
- , dbtParams
- , dbtIdent = "corrections" :: Text
- , dbtCsvEncode = noCsvEncode
- , dbtCsvDecode = Nothing
- , dbtExtraReps = []
- }
+ E.where_ $ (row ^. queryCourse) E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
+ E.&&. dbtRowKey row E.==. submissionUser E.^. SubmissionUserSubmission
+ E.where_ $ E.mkContainsFilter (E.^. SubmissionGroupName) submissionGroup (Set.singleton needle)
+ , singletonMap "rating-visible" . FilterColumn . E.mkExactFilterLast $ views querySubmission sqlSubmissionRatingDone -- TODO: Identical with israted?
+ , singletonMap "rating" . FilterColumn . E.mkExactFilterWith Just $ views querySubmission (E.^. SubmissionRatingPoints)
+ , singletonMap "comment" . FilterColumn . E.mkContainsFilterWith Just $ views querySubmission (E.^. SubmissionRatingComment)
+ , singletonMap "submission" $ FilterProjected (_corrProjFilterSubmission ?~)
+ , singletonMap "pseudonym" $ FilterProjected (_corrProjFilterPseudonym ?~)
+ , singletonMap "as-state" $ FilterProjected (_corrProjFilterAuthorshipStatementState <>~)
+ ]
+ dbtFilterUI = fromMaybe mempty dbtFilterUI'
+ dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' }
+ dbtIdent = "corrections" :: Text
+ dbtCsvEncode = do
+ CorrectionTableCsvSettings{..} <- mCSVSettings
+ return DBTCsvEncode
+ { dbtCsvExportForm = CorrectionTableCsvExportData
+ <$> apopt checkBoxField (fslI MsgCorrectionCsvSingleSubmittors & setTooltip MsgCorrectionCsvSingleSubmittorsTip) (Just $ csvCorrectionSingleSubmittors def)
+ , dbtCsvNoExportData = Nothing
+ , dbtCsvDoEncode = \CorrectionTableCsvExportData{..} -> awaitForever $ \(_, row) -> runReaderC row $ do
+ submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) . toListOf resultSubmittors
+ forM_ (bool pure (map pure) csvCorrectionSingleSubmittors submittors) $ \submittors' -> transPipe (withReaderT (, submittors')) $ do
+ let guardNonAnonymous = runMaybeT . guardMOnM (view $ _1 . resultNonAnonymousAccess) . MaybeT
+ yieldM $ CorrectionTableCsv
+ <$> preview (_1 . resultCourseTerm . _TermId)
+ <*> preview (_1 . resultCourseSchool . _SchoolId)
+ <*> preview (_1 . resultCourseShorthand)
+ <*> preview (_1 . resultSheet . _entityVal . _sheetName)
+ <*> preview (_1 . resultCryptoID . re (_CI . _PathPiece))
+ <*> guardNonAnonymous (preview $ _1 . resultLastEdit)
+ <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userSurname . re _Just))
+ <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userFirstName . re _Just))
+ <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userDisplayName . re _Just))
+ <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userMatrikelnummer))
+ <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userEmail . re _Just))
+ <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserPseudonym))
+ <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserSubmissionGroup))
+ <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserAuthorshipStatementState))
+ <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingAssigned . _Just)
+ <*> preview (_1 . resultCorrector . _entityVal . _userDisplayName)
+ <*> preview (_1 . resultCorrector . _entityVal . _userEmail)
+ <*> preview (_1 . resultSubmission . _entityVal . to submissionRatingDone)
+ <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingTime . _Just)
+ <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingPoints . _Just)
+ <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingComment . _Just)
+ , dbtCsvName = cTableCsvName, dbtCsvSheetName = cTableCsvSheetName
+ , dbtCsvHeader = \_ -> return $ correctionTableCsvHeader cTableShowCorrector cTableCsvQualification
+ , dbtCsvExampleData = Nothing
+ }
+ dbtCsvDecode = Nothing
+ dbtExtraReps = maybe id (\CorrectionTableCsvSettings{..} -> withCsvExtraRep cTableCsvSheetName (def :: CorrectionTableCsvExportData) dbtCsvEncode) mCSVSettings
+ [ DBTExtraRep $ toPrettyJSON <$> repCorrectionJson, DBTExtraRep $ toYAML <$> repCorrectionJson
+ ]
+
+ repCorrectionJson :: ConduitT (E.Value SubmissionId, CorrectionTableData) Void DB (Map CryptoFileNameSubmission CorrectionTableJson)
+ repCorrectionJson = C.foldMap $ \(_, res) -> Map.singleton (res ^. resultCryptoID) $ mkCorrectionTableJson res
+ where
+ mkCorrectionTableJson :: CorrectionTableData -> CorrectionTableJson
+ mkCorrectionTableJson res' = flip runReader res' $ do
+ let guardNonAnonymous :: Reader CorrectionTableData (Maybe a) -> Reader CorrectionTableData (Maybe a)
+ guardNonAnonymous = runMaybeT . guardMOnM (view resultNonAnonymousAccess) . MaybeT
+ mkCorrectionTableSubmittorJson :: Reader CorrectionTableData (Maybe [CorrectionTableSubmittorJson])
+ mkCorrectionTableSubmittorJson = Just <$> do
+ submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) . toListOf resultSubmittors
+ forM submittors $ \submittor -> lift . flip runReaderT submittor $
+ CorrectionTableSubmittorJson
+ <$> view (resultUserUser . _userSurname)
+ <*> view (resultUserUser . _userFirstName)
+ <*> view (resultUserUser . _userDisplayName)
+ <*> view (resultUserUser . _userMatrikelnummer)
+ <*> view (resultUserUser . _userEmail)
+ <*> preview resultUserPseudonym
+ <*> preview resultUserSubmissionGroup
+ <*> preview resultUserAuthorshipStatementState
+ CorrectionTableJson
+ <$> view (resultCourseTerm . _TermId)
+ <*> view (resultCourseSchool . _SchoolId)
+ <*> view resultCourseShorthand
+ <*> view (resultSheet . _entityVal . _sheetName)
+ <*> guardNonAnonymous (preview resultLastEdit)
+ <*> guardNonAnonymous mkCorrectionTableSubmittorJson
+ <*> preview (resultSubmission . _entityVal . _submissionRatingAssigned . _Just)
+ <*> preview (resultCorrector . _entityVal . _userDisplayName)
+ <*> preview (resultCorrector . _entityVal . _userEmail)
+ <*> view (resultSubmission . _entityVal . to submissionRatingDone)
+ <*> preview (resultSubmission . _entityVal . _submissionRatingTime . _Just)
+ <*> preview (resultSubmission . _entityVal . _submissionRatingPoints . _Just)
+ <*> preview (resultSubmission . _entityVal . _submissionRatingComment . _Just)
+ in dbTable psValidator DBTable{..}
data ActionCorrections = CorrDownload
| CorrSetCorrector
@@ -447,16 +795,16 @@ data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous Submis
| CorrAutoSetCorrectorData SheetId
| CorrDeleteData
-correctionsR :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
-correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
- (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI psValidator actions
+correctionsR :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent
+correctionsR whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do
+ (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions
fmap toTypedContent . defaultLayout $ do
setTitleI MsgCourseCorrectionsTitle
$(widgetFile "corrections")
-correctionsR' :: _ -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey)
-correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
+correctionsR' :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey)
+correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do
currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler
postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords)
@@ -465,7 +813,7 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do
}
((actionRes', statistics), table) <- runDB $
- makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator DBParamsForm
+ makeCorrectionsTable whereClause displayColumns dbtFilterUI csvSettings psValidator DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
@@ -605,7 +953,12 @@ restrictAnonymous :: PSValidator m x -> PSValidator m x
restrictAnonymous = restrictFilter (\k _ -> k /= "user-matriclenumber")
. restrictFilter (\k _ -> k /= "user-name-email")
. restrictFilter (\k _ -> k /= "submission-group")
+ . restrictFilter (\k _ -> k /= "as-state")
+ . restrictSorting (\k _ -> k /= "submittors")
+ . restrictSorting (\k _ -> k /= "submittors-matriculation")
+ . restrictSorting (\k _ -> k /= "submittors-group")
. restrictSorting (\k _ -> k /= "last-edit")
+ . restrictSorting (\k _ -> k /= "as-state")
restrictCorrector :: PSValidator m x -> PSValidator m x
restrictCorrector = restrictFilter (\k _ -> k /= "corrector")
@@ -654,7 +1007,8 @@ getCorrectionsR, postCorrectionsR :: Handler TypedContent
getCorrectionsR = postCorrectionsR
postCorrectionsR = do
uid <- requireAuthId
- let whereClause = ratedBy uid
+ let whereClause :: CorrectionTableWhere
+ whereClause = ratedBy uid
colonnade = mconcat
[ colSelect
, colSchool
@@ -670,64 +1024,89 @@ postCorrectionsR = do
, colRating
, colRated
] -- Continue here
- filterUI = Just $ \mPrev -> mconcat
- [ prismAForm (singletonFilter "course" ) mPrev $ aopt (lift `hoistField` selectField courseOptions) (fslI MsgTableCourse)
- , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTableTerm)
- , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgTableCourseSchool)
- , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` textField) (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
- , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime)
- , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
+ filterUI = Just $ mconcat
+ [ filterUIPseudonym
+ , filterUICourse courseOptions
+ , filterUITerm termOptions
+ , filterUISchool schoolOptions
+ , filterUISheetSearch
+ , filterUIIsRated
+ , filterUISubmission
]
courseOptions = runDB $ do
courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
- optionsPairs $ map (id &&& id) $ nub $ map (CI.original . courseShorthand . entityVal) courses
+ optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . courseShorthand . entityVal) courses
termOptions = runDB $ do
courses <- selectList [] [Desc CourseTerm] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
- optionsPairs $ map (id &&& id) $ nub $ map (termToText . unTermKey . courseTerm . entityVal) courses
+ optionsPairs . map (id &&& id) . nubOrd $ map (termToText . unTermKey . courseTerm . entityVal) courses
schoolOptions = runDB $ do
courses <- selectList [] [Asc CourseSchool] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand)
- optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
+ optionsPairs . map (id &&& id) . nubOrd $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
psValidator = def
& restrictCorrector
& restrictAnonymous
& defaultSorting [SortDescBy "ratingtime", SortAscBy "assignedtime" ]
& defaultFilter (singletonMap "israted" [toPathPiece False])
- correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
+
+ csvSettings = Just CorrectionTableCsvSettings
+ { cTableCsvQualification = CorrectionTableCsvQualifyCourse
+ , cTableCsvName = MsgCorrectionTableCsvNameCorrections
+ , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCorrections
+ , cTableShowCorrector = False
+ }
+ correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList
[ downloadAction
]
getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
getCCorrectionsR = postCCorrectionsR
postCCorrectionsR tid ssh csh = do
- Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
- let whereClause = courseIs cid
- colonnade = mconcat -- should match getSSubsR for consistent UX
- [ colSelect
- , colSheet
- , colSMatrikel
- , colSubmittors
- , colSGroups
- , colSubmissionLink
- , colLastEdit
- , colRating
- , colRated
- , colCorrector
- , colAssigned
+ (Entity cid _, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do
+ course@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
+ doSubmissionGroups <- exists [SubmissionGroupCourse ==. cid]
+ doAuthorshipStatements <- runConduit $
+ (E.selectSource . E.from $ \sheet -> sheet <$ E.where_ (sheet E.^. SheetCourse E.==. E.val cid))
+ .| C.mapM getSheetAuthorshipStatement
+ .| C.map (is _Just)
+ .| C.or
+ return (course, doSubmissionGroups, doAuthorshipStatements)
+ let whereClause :: CorrectionTableWhere
+ whereClause = courseIs cid
+ colonnade = mconcat $ catMaybes -- should match getSSubsR for consistent UX
+ [ pure colSelect
+ , pure colSheet
+ , pure colSMatrikel
+ , pure colSubmittors
+ , guardOn doSubmissionGroups colSGroups
+ , pure colSubmissionLink
+ , pure colLastEdit
+ , guardOn doAuthorshipStatements colAuthorshipStatementState
+ , pure colRating
+ , pure colRated
+ , pure colCorrector
+ , pure colAssigned
] -- Continue here
- filterUI = Just $ \mPrev -> mconcat
- [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgTableCourseMembers)
- , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr)
- -- "pseudonym" TODO DB only stores Word24
- , Map.singleton "sheet-search" . maybeToList <$> aopt textField (fslI MsgTableSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev)))
- , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgTableCorrector)
- , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector)
- , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime)
- , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup)
- , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
+ filterUI = Just $ mconcat
+ [ filterUISheetSearch
+ , filterUIUserNameEmail
+ , filterUIUserMatrikelnummer
+ , filterUIPseudonym
+ , filterUISubmissionGroup
+ , filterUIAuthorshipStatementState
+ , filterUICorrectorNameEmail
+ , filterUIIsAssigned
+ , filterUIIsRated
+ , filterUISubmission
]
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
- correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
+ csvSettings = Just CorrectionTableCsvSettings
+ { cTableCsvQualification = CorrectionTableCsvQualifySheet
+ , cTableCsvName = MsgCorrectionTableCsvNameCourseCorrections tid ssh csh
+ , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseCorrections tid ssh csh
+ , cTableShowCorrector = True
+ }
+ correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList
[ downloadAction
, assignAction (Left cid)
, deleteAction
@@ -736,31 +1115,45 @@ postCCorrectionsR tid ssh csh = do
getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
getSSubsR = postSSubsR
postSSubsR tid ssh csh shn = do
- shid <- runDB $ fetchSheetId tid ssh csh shn
- let whereClause = sheetIs shid
- colonnade = mconcat -- should match getCCorrectionsR for consistent UX
- [ colSelect
- , colSMatrikel
- , colSubmittors
- , colSubmissionLink
- , colLastEdit
- , colRating
- , colRated
- , colCorrector
- , colAssigned
+ (shid, doSubmissionGroups, doAuthorshipStatements) <- runDB $ do
+ sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
+ doSubmissionGroups <- exists [SubmissionGroupCourse ==. sheetCourse]
+ doAuthorshipStatements <- is _Just <$> getSheetAuthorshipStatement sheet
+ return (shid, doSubmissionGroups, doAuthorshipStatements)
+ let whereClause :: CorrectionTableWhere
+ whereClause = sheetIs shid
+ colonnade = mconcat $ catMaybes -- should match getCCorrectionsR for consistent UX
+ [ pure colSelect
+ , pure colSMatrikel
+ , pure colSubmittors
+ , guardOn doSubmissionGroups colSGroups
+ , pure colSubmissionLink
+ , pure colLastEdit
+ , guardOn doAuthorshipStatements colAuthorshipStatementState
+ , pure colRating
+ , pure colRated
+ , pure colCorrector
+ , pure colAssigned
]
- filterUI = Just $ \mPrev -> mconcat
- [ prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgTableCourseMembers)
- , prismAForm (singletonFilter "user-matriclenumber") mPrev $ aopt textField (fslI MsgTableMatrikelNr)
- , prismAForm (singletonFilter "corrector-name-email") mPrev $ aopt textField (fslI MsgTableCorrector)
- , prismAForm (singletonFilter "isassigned" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableHasCorrector)
- , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgTableRatingTime)
- , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgTableSubmissionGroup)
- , prismAForm (singletonFilter "submission") mPrev $ aopt (lift `hoistField` textField) (fslI MsgTableSubmission)
- -- "pseudonym" TODO DB only stores Word24
+ filterUI = Just $ mconcat
+ [ filterUIUserNameEmail
+ , filterUIUserMatrikelnummer
+ , filterUIPseudonym
+ , filterUISubmissionGroup
+ , filterUIAuthorshipStatementState
+ , filterUICorrectorNameEmail
+ , filterUIIsAssigned
+ , filterUIIsRated
+ , filterUISubmission
]
psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway
- correctionsR whereClause colonnade filterUI psValidator $ Map.fromList
+ csvSettings = Just CorrectionTableCsvSettings
+ { cTableCsvQualification = CorrectionTableCsvNoQualification
+ , cTableCsvName = MsgCorrectionTableCsvNameSheetCorrections tid ssh csh shn
+ , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameSheetCorrections tid ssh csh shn
+ , cTableShowCorrector = True
+ }
+ correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList
[ downloadAction
, assignAction (Right shid)
, autoAssignAction shid
diff --git a/src/Handler/Submission/SubmissionUserInvite.hs b/src/Handler/Submission/SubmissionUserInvite.hs
index b2c7b9e41..d8095f164 100644
--- a/src/Handler/Submission/SubmissionUserInvite.hs
+++ b/src/Handler/Submission/SubmissionUserInvite.hs
@@ -7,8 +7,10 @@ module Handler.Submission.SubmissionUserInvite
) where
import Import
+import Utils.Form
import Handler.Utils.Invitations
+import Handler.Utils.AuthorshipStatement
import Data.Aeson hiding (Result(..))
@@ -79,8 +81,18 @@ submissionUserInvitationConfig = InvitationConfig{..}
itStartsAt = Nothing
return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized
- invitationForm _ _ _ = pure (JunctionSubmissionUser, ())
- invitationInsertHook _ _ _ _ _ = id
+ invitationForm (Entity _ Submission{..}) _ _ = wFormToAForm $ do
+ -- TODO(AuthorshipStatements): allow invitee to download submission files/see co-submittors iff authorship-statement is required
+ authorshipStatementRes <- maybeT (return $ FormSuccess Nothing) . fmap (fmap Just) $ do
+ sheetEnt <- lift . lift . lift $ getJustEntity submissionSheet
+ asd <- MaybeT . lift . lift $ getSheetAuthorshipStatement sheetEnt
+ lift $ wpopt (acceptAuthorshipStatementField asd) (fslI MsgSubmissionAuthorshipStatement & setTooltip MsgSubmissionAuthorshipStatementTip) Nothing
+ return $ (JunctionSubmissionUser, ) <$> authorshipStatementRes
+ invitationInsertHook _ (Entity smid _) _ SubmissionUser{..} masdId act = do
+ for_ masdId $ \asdId -> do
+ now <- liftIO getCurrentTime
+ insert_ $ AuthorshipStatementSubmission asdId smid submissionUserUser now
+ act
invitationSuccessMsg (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet
return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName
diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs
index f472d932c..521634de4 100644
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@@ -21,6 +21,12 @@ import qualified Database.Esqueleto.Legacy as E
-- htmlField' moved to Handler.Utils.Form/Fields
+invalidateVisibleSystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
+ => m ()
+invalidateVisibleSystemMessages
+ = memcachedByInvalidate AuthCacheVisibleSystemMessages $ Proxy @(Map SystemMessageId (Maybe UTCTime, Maybe UTCTime))
+
+
getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
getMessageR = postMessageR
postMessageR cID = do
@@ -138,6 +144,7 @@ postMessageR cID = do
where
modifySystemMessage smId sm = do
runDB $ replace smId sm
+ invalidateVisibleSystemMessages
addMessageI Success MsgSystemMessageEditSuccess
redirect $ MessageR cID
@@ -258,18 +265,21 @@ postMessageListR = do
| not $ null selection -> do
selection' <- traverse decrypt $ Set.toList selection
runDB $ deleteWhere [ SystemMessageId <-. selection' ]
+ invalidateVisibleSystemMessages
$(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet")
redirect MessageListR
FormSuccess (SMDActivate ts, selection)
| not $ null selection -> do
selection' <- traverse decrypt $ Set.toList selection
runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageFrom =. ts ]
+ invalidateVisibleSystemMessages
$(addMessageFile Success "templates/messages/systemMessagesSetFrom.hamlet")
redirect MessageListR
FormSuccess (SMDDeactivate ts, selection)
| not $ null selection -> do
selection' <- traverse decrypt $ Set.toList selection
runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ]
+ invalidateVisibleSystemMessages
$(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet")
redirect MessageListR
FormSuccess (_, _selection) -- prop> null _selection
diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs
index b49eea883..9043cb08d 100644
--- a/src/Handler/Tutorial/List.hs
+++ b/src/Handler/Tutorial/List.hs
@@ -71,6 +71,12 @@ getCTutorialListR tid ssh csh = do
dbtSorting = Map.fromList
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
+ , ( "tutors"
+ , SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
+ E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
+ E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
+ return . E.min_ $ user E.^. UserSurname
+ )
, ("participants", SortColumn $ \tutorial -> let participantCount :: E.SqlExpr (E.Value Int)
participantCount = E.subSelectCount . E.from $ \tutorialParticipant ->
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index 7ca9e1843..5d635e60e 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -25,6 +25,7 @@ import Handler.Utils.Occurrences as Handler.Utils
import Handler.Utils.Memcached as Handler.Utils hiding (manageMemcachedLocalInvalidations)
import Handler.Utils.Files as Handler.Utils
import Handler.Utils.Download as Handler.Utils
+import Handler.Utils.AuthorshipStatement as Handler.Utils
import Handler.Utils.Term as Handler.Utils
diff --git a/src/Handler/Utils/AuthorshipStatement.hs b/src/Handler/Utils/AuthorshipStatement.hs
new file mode 100644
index 000000000..fa09969d9
--- /dev/null
+++ b/src/Handler/Utils/AuthorshipStatement.hs
@@ -0,0 +1,125 @@
+module Handler.Utils.AuthorshipStatement
+ ( insertAuthorshipStatement
+ , forcedAuthorshipStatementField
+ , authorshipStatementWidget
+ , getSheetAuthorshipStatement
+ , acceptAuthorshipStatementField
+ ) where
+
+import Import
+import Utils.Form
+
+import qualified Data.Map.Strict as Map
+
+import Handler.Utils.Form (i18nLangMap, I18nLang(..))
+
+import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Utils as E
+
+import qualified Data.ByteString.Base64.URL as Base64
+import qualified Data.ByteArray as BA
+
+
+insertAuthorshipStatement :: MonadIO m
+ => I18nStoredMarkup -> SqlWriteT m AuthorshipStatementDefinitionId
+insertAuthorshipStatement authorshipStatementDefinitionContent = withCompatibleBackend @SqlBackend $ do
+ let authorshipStatementDefinitionHash = toAuthorshipStatementReference authorshipStatementDefinitionContent
+ unlessM (exists [AuthorshipStatementDefinitionHash ==. authorshipStatementDefinitionHash]) $
+ insert_ AuthorshipStatementDefinition{..}
+ return $ AuthorshipStatementDefinitionKey authorshipStatementDefinitionHash
+
+forcedAuthorshipStatementField :: (MonadHandler handler, HandlerSite handler ~ UniWorX)
+ => Field handler AuthorshipStatementDefinition
+forcedAuthorshipStatementField = Field{..}
+ where
+ fieldParse _ _ = pure . Left $ SomeMessage ("Result of forcedAuthorshipStatementField inspected" :: Text)
+ fieldEnctype = UrlEncoded
+ fieldView theId _name attrs (preview _Right -> mVal) _isReq
+ = [whamlet|
+ $newline never
+
+ ^{maybe mempty authorshipStatementWidget mVal}
+ |]
+
+authorshipStatementWidget :: AuthorshipStatementDefinition -> Widget
+authorshipStatementWidget AuthorshipStatementDefinition{..}
+ = [whamlet|
+ $newline never
+
+ $forall (I18nLang l, t) <- Map.toList (review i18nLangMap authorshipStatementDefinitionContent)
+ -
+ _{MsgLanguageEndonym l}
+
-
+ #{markupOutput t}
+
+
+ #{hashText}
+ |]
+ where hashText = decodeUtf8 . Base64.encodeUnpadded $ BA.convert authorshipStatementDefinitionHash
+
+acceptAuthorshipStatementField :: forall m.
+ (MonadHandler m, HandlerSite m ~ UniWorX)
+ => Entity AuthorshipStatementDefinition
+ -> Field m AuthorshipStatementDefinitionId
+acceptAuthorshipStatementField (Entity asdId asd)
+ = checkBoxField
+ & _fieldView %~ adjFieldView
+ & checkMap (bool (Left MsgAuthorshipStatementStatementIsRequired) (Right asdId)) (== asdId)
+ where
+ adjFieldView :: FieldViewFunc m Bool -> FieldViewFunc m Bool
+ adjFieldView checkboxView theId theName attrs val isReq = do
+ let checkboxWdgt = checkboxView checkboxId theName [] val isReq
+ checkboxId = theId <> "__checkbox"
+ $(widgetFile "widgets/authorship-statement-accept")
+
+
+getSheetAuthorshipStatement :: MonadIO m
+ => Entity Sheet
+ -> SqlReadT m (Maybe (Entity AuthorshipStatementDefinition))
+getSheetAuthorshipStatement (Entity _ Sheet{..}) = withCompatibleBackend @SqlBackend $ traverse getJustEntity <=< runMaybeT $ do
+ Entity _ School{..} <- MaybeT . E.selectMaybe . E.from $ \(school `E.InnerJoin` course) -> do
+ E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
+ E.where_ $ course E.^. CourseId E.==. E.val sheetCourse
+ return school
+
+ let examId = fmap Right sheetAuthorshipStatementExam
+ <|> fmap Left (sheetType ^? _examPart . re _SqlKey)
+ <|> fmap Right sheetRequireExamRegistration
+ exam <- lift . for examId $ \case
+ Right e -> getJust e
+ Left epId -> getJust epId >>= getJust . examPartExam
+
+ let
+ examAuthorshipStatement' = exam >>= examAuthorshipStatement
+ sheetAuthorshipStatement' = guardOnM (is _SheetAuthorshipStatementModeEnabled sheetAuthorshipStatementMode) sheetAuthorshipStatement
+ sheetDoAuthorshipStatements
+ = is _SheetAuthorshipStatementModeEnabled sheetAuthorshipStatementMode
+ || (is _SheetAuthorshipStatementModeExam sheetAuthorshipStatementMode && is _Just examAuthorshipStatement')
+
+ if
+ | is _Just exam
+ , is _SchoolAuthorshipStatementModeNone schoolSheetExamAuthorshipStatementMode
+ -> mzero
+ | is _Just exam
+ , not schoolSheetExamAuthorshipStatementAllowOther
+ -> guardOnM (is _SchoolAuthorshipStatementModeRequired schoolSheetExamAuthorshipStatementMode || sheetDoAuthorshipStatements) $ hoistMaybe schoolSheetExamAuthorshipStatementDefinition
+ | is _Just exam
+ , is _SchoolAuthorshipStatementModeRequired schoolSheetExamAuthorshipStatementMode
+ -> hoistMaybe $ sheetAuthorshipStatement'
+ <|> guardOnM (is _SheetAuthorshipStatementModeExam sheetAuthorshipStatementMode) examAuthorshipStatement'
+ <|> schoolSheetExamAuthorshipStatementDefinition
+
+ | is _Nothing exam
+ , is _SchoolAuthorshipStatementModeNone schoolSheetAuthorshipStatementMode
+ -> mzero
+ | is _Nothing exam
+ , not schoolSheetAuthorshipStatementAllowOther
+ -> guardOnM (is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode || sheetDoAuthorshipStatements) $ hoistMaybe schoolSheetAuthorshipStatementDefinition
+ | is _Nothing exam
+ , is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode
+ -> hoistMaybe $ sheetAuthorshipStatement' <|> schoolSheetAuthorshipStatementDefinition
+
+ | otherwise
+ -> case exam of
+ Just _ -> hoistMaybe $ sheetAuthorshipStatement' <|> examAuthorshipStatement'
+ Nothing -> hoistMaybe sheetAuthorshipStatement'
diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs
index 1377ab621..ca32a1b71 100644
--- a/src/Handler/Utils/Communication.hs
+++ b/src/Handler/Utils/Communication.hs
@@ -146,12 +146,12 @@ commR CommunicationRoute{..} = do
let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
where
- miAdd (BoundedPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
+ miAdd pos@(BoundedPosition RecipientCustom, 0) dim@1 liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ \csrf -> do
(addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgUtilEMail (mr MsgUtilEMail) & setTooltip MsgUtilMultiEmailFieldTip & addName (nudge "email")) Nothing
let
addRes' = addRes <&> \nEmails ((Map.elems &&& maybe 0 (succ . snd . fst) . Map.lookupMax) . Map.filterWithKey (\(BoundedPosition c, _) _ -> c == RecipientCustom) -> (oEmails, kStart)) -> FormSuccess . Map.fromList . zip (map (BoundedPosition RecipientCustom, ) [kStart..]) . Set.toList $ nEmails `Set.difference` Set.fromList oEmails
return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
- miAdd _ _ _ _ = Nothing
+ miAdd _ _ _ _ _ = Nothing
miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index a43dd4403..34a372192 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+
module Handler.Utils.Form
( module Handler.Utils.Form
, module Handler.Utils.Form.MassInput
@@ -60,7 +62,7 @@ import Data.Aeson.Text (encodeToLazyText)
import qualified Text.Email.Validate as Email
import Data.Text.Lens (unpacked)
-import Text.Blaze (toMarkup)
+import Text.Blaze (toMarkup, Markup)
import Handler.Utils.Form.MassInput
@@ -73,6 +75,8 @@ import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Yaml as Yaml
import Control.Monad.Catch.Pure (runCatch)
+
+import qualified Data.List.NonEmpty as NonEmpty
{-# ANN module ("HLint: ignore Use const" :: String) #-}
@@ -458,6 +462,15 @@ explainedMultiActionA :: forall action a.
-> AForm Handler a
explainedMultiActionA acts mActsOpts fSettings defAction = formToAForm $ explainedMultiAction acts mActsOpts fSettings defAction mempty
+explainedMultiActionW :: forall action a.
+ Ord action
+ => Map action (AForm Handler a)
+ -> Handler ([(Option action, Maybe Widget)], Text -> Maybe action)
+ -> FieldSettings UniWorX
+ -> Maybe action
+ -> WForm Handler (FormResult a)
+explainedMultiActionW acts mActsOpts fSettings defAction = aFormToWForm $ explainedMultiActionA acts mActsOpts fSettings defAction
+
------------
-- Fields --
------------
@@ -696,7 +709,7 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
, $(widgetFile "widgets/massinput/uploadSpecificFiles/form")
)
- miAdd _ _ nudge submitView = Just $ \csrf -> do
+ miAdd _ _ _ nudge submitView = Just $ \csrf -> do
(formRes, formWidget) <- sFileForm nudge Nothing csrf
let formWidget' = $(widgetFile "widgets/massinput/uploadSpecificFiles/add")
addRes' = formRes <&> \fileRes oldRess ->
@@ -707,7 +720,6 @@ uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
sFileForm nudge (Just initFile) csrf
miDelete :: MassInputDelete ListLength
miDelete = miDeleteList
- miAllowAdd _ _ _ = True
miAddEmpty _ _ _ = Set.empty
miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
@@ -2345,3 +2357,175 @@ roomReferenceForm' noneOpt fs mPrev = multiActionAOpts opts opts' fs $ fmap clas
<$> roomRefLink'
<*> roomRefInstructions'
return $ Just <$> res
+
+newtype I18nLangs = I18nLangs { unI18nLangs :: Set I18nLang }
+ deriving newtype (ToJSON, FromJSON, MonoFoldable, Semigroup, Monoid, Lattice, BoundedJoinSemiLattice)
+ deriving (Eq, Ord, Generic, Typeable, Read, Show)
+type instance Element I18nLangs = I18nLang
+
+newtype I18nLang = I18nLang { unI18nLang :: Lang }
+ deriving newtype (PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
+ deriving (Eq, Generic, Typeable, Read, Show)
+
+instance Ord I18nLang where
+ compare = mconcat
+ [ comparing $ NTop . flip elemIndex (toList appLanguages) . unI18nLang
+ , comparing $ T.splitOn "-" . unI18nLang
+ ]
+
+makeWrapped ''I18nLangs
+makeWrapped ''I18nLang
+
+instance IsBoxCoord I18nLang where
+ boxDimensions = [BoxDimension _Wrapped]
+ boxOrigin = _Wrapped # NonEmpty.head appLanguages
+
+instance Liveliness I18nLangs where
+ type BoxCoord I18nLangs = I18nLang
+ liveCoords = from _Wrapped
+
+i18nLangMap :: Prism' (Map I18nLang a) (I18n a)
+i18nLangMap = prism' toLangMap fromLangMap
+ where
+ -- ugh.
+ toLangMap I18n{..} = Map.mapKeys I18nLang $ if
+ | Just fLang <- i18nFallbackLang
+ -> Map.insert fLang i18nFallback i18nTranslations
+ | missing : _ <- sortOn langSortProj . toList $ setOf folded appLanguages `Set.difference` Map.keysSet i18nTranslations
+ -> Map.insert missing i18nFallback i18nTranslations
+ | otherwise
+ -> Map.insert (NonEmpty.head appLanguages) i18nFallback i18nTranslations
+ fromLangMap lMap = do
+ (Just -> i18nFallbackLang, i18nFallback) : i18nTranslations' <- return
+ $ Map.toList lMap
+ & over (traverse . _1) (view _Wrapped)
+ & sortOn (views _1 langSortProj)
+ let i18nTranslations = Map.fromList i18nTranslations'
+ return I18n{..}
+
+ langSortProj = NTop . flip elemIndex (toList appLanguages)
+
+i18nForm :: forall a ident handler.
+ ( PathPiece ident
+ , MonadHandler handler, HandlerSite handler ~ UniWorX
+ , MonadThrow handler
+ )
+ => ((Text -> Text) -> Maybe a -> (Markup -> MForm handler (FormResult a, Widget)))
+ -> Bool -- ^ Allow only languages from `appLanguages`?
+ -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+ -> ident
+ -> FieldSettings UniWorX
+ -> Bool
+ -> Maybe (Maybe (I18n a))
+ -> (Markup -> MForm handler (FormResult (Maybe (I18n a)), FieldView UniWorX))
+i18nForm strForm onlyAppLanguages miButtonAction miIdent fSettings fRequired mPrev' csrf'
+ = fmap (over _1 massageFormResult) . ($ csrf') . massInput MassInput{..} fSettings fRequired $ fmap ((), ) . review i18nLangMap <$> join mPrev'
+ where
+ massageFormResult :: FormResult (Map I18nLang ((), a)) -> FormResult (Maybe (I18n a))
+ massageFormResult = fmap $ preview i18nLangMap . map (view _2)
+
+ miAdd :: I18nLang -> Natural -> I18nLangs
+ -> (Text -> Text) -> FieldView UniWorX
+ -> Maybe (Markup -> MForm handler (FormResult (Map I18nLang () -> FormResult (Map I18nLang ())), Widget))
+ miAdd _pos _dimIx liveliness nudge submitBtn = guardOn (not $ onlyAppLanguages && null (missingLangs liveliness)) $ \csrf -> do
+ let langField' :: Field Handler Lang
+ langField'
+ | onlyAppLanguages = selectField langOpts
+ | otherwise = textField
+ & addDatalist langOpts
+ & cfStrip
+ & checkBool langCheck MsgInvalidLangFormat
+ where
+ langOpts = do
+ MsgRenderer mr <- getMsgRenderer
+ let mkOption l = Option
+ { optionDisplay = mr $ MsgLanguage l
+ , optionInternalValue = l
+ , optionExternalValue = l
+ }
+ return OptionList
+ { olOptions = map (views _Wrapped mkOption) $ missingLangs liveliness
+ , olReadExternal = if
+ | onlyAppLanguages -> assertM' (`elem` toList appLanguages)
+ | otherwise -> Just
+ }
+ langCheck (T.splitOn "-" -> lParts)
+ = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts
+ && not (null lParts)
+
+ (langRes, langView) <- mpreq (hoistField liftHandler langField' & isoField _Unwrapped) (def & addName (nudge "lang")) $ missingLangs liveliness ^? _head
+
+ MsgRenderer mr <- getMsgRenderer
+ let res = langRes <&> \newLang oldLangs -> if
+ | newLang `Map.member` oldLangs -> FormFailure . pure . mr . MsgI18nFormLanguageAlreadyExists $ newLang ^. _Wrapped
+ | otherwise -> pure $ Map.singleton newLang ()
+
+ return (res, $(widgetFile "widgets/i18n-form/add"))
+ where
+ missingLangs liveliness' = Set.toAscList $ setOf (folded . re _Wrapped) appLanguages `Set.difference` view _Wrapped liveliness'
+
+ miCell :: I18nLang -> () -> Maybe a
+ -> (Text -> Text)
+ -> (Markup -> MForm handler (FormResult a, Widget))
+ miCell _ _ mPrev nudge csrf = do
+ (strRes, strView) <- strForm nudge mPrev csrf
+ return (strRes, $(widgetFile "widgets/i18n-form/cell"))
+
+ miDelete :: Map I18nLang ()
+ -> I18nLang
+ -> MaybeT (MForm handler) (Map I18nLang I18nLang)
+ miDelete liveliness' coord = return . Map.delete coord . Map.fromSet id $ Map.keysSet liveliness'
+
+ miAddEmpty :: I18nLang
+ -> Natural
+ -> I18nLangs
+ -> Set I18nLang
+ miAddEmpty _ _ _ = Set.empty
+
+ miLayout :: MassInputLayout I18nLangs () a
+ miLayout (I18nLangs langs) _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/i18n-form/layout")
+
+i18nField :: forall a ident handler.
+ ( PathPiece ident
+ , MonadHandler handler, HandlerSite handler ~ UniWorX
+ , MonadThrow handler
+ )
+ => Field handler a
+ -> Bool -- ^ Allow only languages from `appLanguages`?
+ -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+ -> ident
+ -> FieldSettings UniWorX
+ -> Bool
+ -> Maybe (Maybe (I18n a))
+ -> (Markup -> MForm handler (FormResult (Maybe (I18n a)), FieldView UniWorX))
+i18nField strField = i18nForm $ \nudge mPrev csrf -> over _2 ((toWidget csrf <>) . fvWidget) <$> mpreq strField (def & addName (nudge "string")) mPrev
+
+i18nFieldA :: forall a ident handler.
+ ( PathPiece ident
+ , MonadHandler handler, HandlerSite handler ~ UniWorX
+ , MonadThrow handler
+ )
+ => Field handler a
+ -> Bool -- ^ Allow only languages from `appLanguages`?
+ -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+ -> ident
+ -> FieldSettings UniWorX
+ -> Bool
+ -> Maybe (Maybe (I18n a))
+ -> AForm handler (Maybe (I18n a))
+i18nFieldA strField onlyAppLanguages miButtonAction miIdent fSettings fRequired mPrev' = formToAForm $ over _2 pure <$> i18nField strField onlyAppLanguages miButtonAction miIdent fSettings fRequired mPrev' mempty
+
+i18nFieldW :: forall a ident handler.
+ ( PathPiece ident
+ , MonadHandler handler, HandlerSite handler ~ UniWorX
+ , MonadThrow handler
+ )
+ => Field handler a
+ -> Bool -- ^ Allow only languages from `appLanguages`?
+ -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+ -> ident
+ -> FieldSettings UniWorX
+ -> Bool
+ -> Maybe (Maybe (I18n a))
+ -> WForm handler (FormResult (Maybe (I18n a)))
+i18nFieldW strField onlyAppLanguages miButtonAction miIdent fSettings fRequired mPrev' = aFormToWForm $ i18nFieldA strField onlyAppLanguages miButtonAction miIdent fSettings fRequired mPrev'
diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs
index 582e4193f..8de2c3a36 100644
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/src/Handler/Utils/Form/MassInput.hs
@@ -35,6 +35,9 @@ import Text.Hamlet (hamletFile)
import Algebra.Lattice.Ordered (Ordered(..))
+import Control.Monad.Trans.RWS.Lazy (evalRWST)
+import qualified Control.Monad.State.Class as State
+
{-# ANN module ("HLint: ignore Use const" :: String) #-}
@@ -244,10 +247,11 @@ data MassInputException = MassInputInvalidShape
instance Exception MassInputException
data MassInput handler liveliness cellData cellResult = forall i. PathPiece i => MassInput
- { miAdd :: BoxCoord liveliness -- Position (dimensions after @dimIx@ are zero)
- -> Natural -- Zero-based dimension index @dimIx@
- -> (Text -> Text) -- Nudge deterministic field ids
- -> FieldView UniWorX -- Submit button
+ { miAdd :: BoxCoord liveliness -- ^ Position (dimensions after @dimIx@ are zero)
+ -> Natural -- ^ Zero-based dimension index @dimIx@
+ -> liveliness -- ^ Previous liveliness
+ -> (Text -> Text) -- ^ Nudge deterministic field ids
+ -> FieldView UniWorX -- ^ Submit button
-> Maybe (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData)), Widget)) -- ^ Construct a Cell-Addition Widget
, miCell :: BoxCoord liveliness -- Position
-> cellData -- @cellData@ from @miAdd@
@@ -257,10 +261,6 @@ data MassInput handler liveliness cellData cellResult = forall i. PathPiece i =>
, miDelete :: Map (BoxCoord liveliness) cellData
-> BoxCoord liveliness
-> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness)) -- ^ Decide whether a deletion-operation should be permitted and produce a finite map of new coordinates to their old correspondants
- , miAllowAdd :: BoxCoord liveliness
- -> Natural
- -> liveliness
- -> Bool -- ^ Decide whether an addition-operation should be permitted
, miAddEmpty :: BoxCoord liveliness
-> Natural
-> liveliness
@@ -315,74 +315,88 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
| otherwise -> throwM MassInputInvalidShape
sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
- let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
- addForm = addForm' boxOrigin [] . zip [0..]
- where
- addForm' _ _ [] = return Map.empty
- addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
- let nudgeAddWidgetName :: Text -> Text
- nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
- (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
- let btnRes = do
- Just x <- btnRes'
- return x
- wBtnRes res = do
- guard $ isn't _FormMissing btnRes
- res
- miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView
- addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
- addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
- let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes')
- case remDims of
- [] -> return dimRes'
- ((_, BoxDimension dim) : _) -> do
- let miCoords
- = Set.union (miAddEmpty miCoord dimIx sentLiveliness)
- . Set.map (\c -> miCoord & dim .~ (c ^. dim))
- . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
- $ review liveCoords sentLiveliness
- dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
- return $ dimRes' `Map.union` fold dimRess
+ let runTwice :: (Maybe res -> MForm handler res) -> MForm handler res
+ runTwice act = do
+ r <- ask
+ s <- State.get
+ res1 <- fmap (view _1) . lift $ evalRWST (act Nothing) r s
+ local (_1 .~ Nothing) . act $ Just res1
+ replaceWithFirst :: forall k x y. Ord k => Maybe (Map k (x, y)) -> Map k (x, y) -> Map k (x, y)
+ replaceWithFirst Nothing xs = xs
+ replaceWithFirst (Just f) s = Map.unionWith (\(f1, _f2) (_s1, s2) -> (f1, s2)) f s
+
+ (shape, liveliness, delShapeUpdate, addResults, addResults', delResults, shapeChanged) <- runTwice $ \mPrev -> do
+ let sentLiveliness' = maybe sentLiveliness (view _2) mPrev
- addResults <- addForm boxDimensions
- let
- addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
- addResults' = flip Map.mapWithKey (fst <$> addResults) $ \(dimIx, miCoord) -> \case
- FormSuccess (Just mkResult)
- | miAllowAdd miCoord dimIx sentLiveliness -> Just <$> mkResult sentShape'
+ let addForm :: MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
+ addForm = addForm' boxOrigin [] $ zip [0..] boxDimensions
+ where
+ addForm' _ _ [] = return Map.empty
+ addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
+ let nudgeAddWidgetName :: Text -> Text
+ nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
+ (btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
+ let btnRes = do
+ Just x <- btnRes'
+ return x
+ wBtnRes res = do
+ guard $ isn't _FormMissing btnRes
+ res
+ miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx sentLiveliness' nudgeAddWidgetName btnView
+ addRes'' <- miAdd' <&> (_Just . _1) %~ wBtnRes
+ addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
+ let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just . fst) addRes', fmap snd addRes')
+ case remDims of
+ [] -> return dimRes'
+ ((_, BoxDimension dim) : _) -> do
+ let miCoords
+ = Set.union (miAddEmpty miCoord dimIx sentLiveliness')
+ . Set.map (\c -> miCoord & dim .~ (c ^. dim))
+ . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
+ $ review liveCoords sentLiveliness'
+ dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
+ return $ dimRes' `Map.union` fold dimRess
+
+ addResults <- replaceWithFirst (view _4 <$> mPrev) <$> addForm
+ let
+ addResults' :: Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData)))
+ addResults' = fmap (view _1) addResults <&> \case
+ FormSuccess (Just mkShape) -> Just <$> mkShape sentShape'
other -> Nothing <$ other
- let addShape
- | [((dimIx, miCoord), FormSuccess (Just mkResult))] <- Map.toList . Map.filter (is $ _FormSuccess . _Just) $ fmap fst addResults
- = Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape' <* guard (miAllowAdd miCoord dimIx sentLiveliness)) sentShape'
- | otherwise = Nothing
+ let addShape
+ | [FormSuccess (Just mkResult)] <- Map.elems . Map.filter (is $ _FormSuccess . _Just) $ view _1 <$> addResults
+ = Just $ maybe id Map.union (formResultToMaybe $ mkResult sentShape') sentShape'
+ | otherwise = Nothing
- addedShape <- if
- | Just s <- addShape -> return s
- | otherwise -> return sentShape'
+ addedShape <- if
+ | Just s <- addShape -> return s
+ | otherwise -> return sentShape'
- let
- delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
- delForm miCoord = do
- (delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
- shapeUpdate <- miDelete addedShape miCoord
- guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
- return (shapeUpdate <$ assertM (is _Just) delRes, delView)
+ let
+ delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
+ delForm miCoord = do
+ (delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
+ shapeUpdate <- miDelete addedShape miCoord
+ guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
+ return (shapeUpdate <$ assertM (is _Just) delRes, delView)
- delResults <- fmap (Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
- let
- delShapeUpdate
- | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
- | otherwise = Nothing
- delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate
+ delResults <- fmap (replaceWithFirst (view _6 <$> mPrev) . Map.mapMaybe id) . sequence $ Map.fromSet (runMaybeT . delForm) (Map.keysSet addedShape)
+ let
+ delShapeUpdate
+ | [FormSuccess shapeUpdate'] <- Map.elems . Map.filter (is _FormSuccess) $ fmap fst delResults = Just shapeUpdate'
+ | otherwise = Nothing
+ delShape = traverse (`Map.lookup` addedShape) =<< delShapeUpdate
- let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
+ let shapeChanged = Fold.any (hasn't $ _1 . _FormMissing) addResults || Fold.any (has $ _1 . _FormSuccess) delResults
- shape <- if
- | Just s <- addShape -> return s
- | Just s <- delShape -> return s
- | otherwise -> return sentShape'
- liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
+ shape <- if
+ | Just s <- addShape -> return s
+ | Just s <- delShape -> return s
+ | otherwise -> return sentShape'
+ liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
+
+ return (shape, liveliness, delShapeUpdate, addResults, addResults', delResults, shapeChanged)
shapeId <- newIdent
let shapeInput = fieldView shapeField shapeId (toPathPiece shapeName) [] (Right shape) True
@@ -424,7 +438,7 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
(fmap (view _1 &&& view (_2 . _1)) cellResults)
(fmap (view $ _2 . _2) cellResults)
(fmap (view _2) delResults)
- (Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults)
+ (Map.mapMaybe (view _2) addResults)
MsgRenderer mr <- getMsgRenderer
@@ -489,12 +503,11 @@ massInputList :: forall handler cellResult ident msg.
-> Maybe [cellResult]
-> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
massInputList field fieldSettings onMissing miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
- MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
+ MassInput { miAdd = \_ _ _ _ submitBtn -> Just $ \csrf ->
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 (succ . fst) $ Map.lookupMax pRes) (), toWidget csrf >> fvWidget submitBtn)
, miCell = \pos () iRes nudge csrf ->
over _2 (\fv -> $(widgetFile "widgets/massinput/list/cell")) <$> mreqMsg field (fieldSettings pos & addName (nudge "field")) onMissing iRes
, miDelete = miDeleteList
- , miAllowAdd = \_ _ _ -> True
, miAddEmpty = \_ _ _ -> Set.empty
, miButtonAction
, miLayout = listMiLayout
@@ -541,10 +554,10 @@ massInputAccum :: forall handler cellData ident.
massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf
= over (_1 . mapped) (map fst . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (, ()) <$> mPrev) csrf
where
- miAdd :: ListPosition -> Natural
+ miAdd :: ListPosition -> Natural -> ListLength
-> (Text -> Text) -> FieldView UniWorX
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
- miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
+ miAdd _pos _dim _liveliness nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
@@ -559,8 +572,6 @@ massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequire
miDelete :: MassInputDelete ListLength
miDelete = miDeleteList
- miAllowAdd _ _ _ = True
-
miAddEmpty _ _ _ = Set.empty
massInputAccumA :: forall handler cellData ident.
@@ -619,10 +630,10 @@ massInputAccumEdit :: forall handler cellData ident.
massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf
= over (_1 . mapped) (map snd . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (\x -> (x, x)) <$> mPrev) csrf
where
- miAdd :: ListPosition -> Natural
+ miAdd :: ListPosition -> Natural -> ListLength
-> (Text -> Text) -> FieldView UniWorX
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
- miAdd _pos _dim nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
+ miAdd _pos _dim _liveliness nudge submitView = Just (fmap (over (_1 . mapped) doAdd) . miAdd' nudge submitView)
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
@@ -632,13 +643,11 @@ massInputAccumEdit miAdd' miCell' miButtonAction miLayout miIdent fSettings fReq
miCell :: ListPosition -> cellData -> Maybe cellData -> (Text -> Text)
-> (Markup -> MForm handler (FormResult cellData, Widget))
- miCell _pos dat _mPrev nudge = miCell' nudge dat
+ miCell _pos dat mPrev' nudge = miCell' nudge $ fromMaybe dat mPrev'
miDelete :: MassInputDelete ListLength
miDelete = miDeleteList
- miAllowAdd _ _ _ = True
-
miAddEmpty _ _ _ = Set.empty
massInputAccumEditA :: forall handler cellData ident.
diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs
index f6c2d39b4..3718958a0 100644
--- a/src/Handler/Utils/I18n.hs
+++ b/src/Handler/Utils/I18n.hs
@@ -30,7 +30,7 @@ i18nFile includeFile basename = do
-- Construct list of available translations (@de@, @en@, ...) at compile time
let i18nDirectory = "templates" "i18n" basename
availableFiles <- qRunIO $ listDirectory i18nDirectory
- let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . List.nub $ pack . takeBaseName <$> availableFiles
+ let availableTranslations = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . nubOrd $ pack . takeBaseName <$> availableFiles
availableTranslations' <- maybe (fail $ "‘" <> i18nDirectory <> "’ is empty") return $ NonEmpty.nonEmpty availableTranslations
-- Dispatch to correct language (depending on user settings via `selectLanguage`) at run time
diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs
index 9c6436c52..6ec6d7e42 100644
--- a/src/Handler/Utils/Invitations.hs
+++ b/src/Handler/Utils/Invitations.hs
@@ -323,7 +323,7 @@ deleteInvitationsF :: forall junction m mono backend.
-> ReaderT backend m ()
-- | Non-conduit version of `deleteInvitations`
deleteInvitationsF invitationFor (otoList -> emailList)
- = deleteWhere [InvitationEmail <-. nub emailList, InvitationFor ==. invRef @junction invitationFor]
+ = deleteWhere [InvitationEmail <-. nubOrd emailList, InvitationFor ==. invRef @junction invitationFor]
deleteInvitation :: forall junction m backend.
( IsInvitableJunction junction
diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs
index 41dd2aecc..937a26d32 100644
--- a/src/Handler/Utils/Memcached.hs
+++ b/src/Handler/Utils/Memcached.hs
@@ -356,7 +356,8 @@ memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX
=> Maybe Expiry -> m a -> m a
memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x)
-memcachedBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
+memcachedBy :: forall a m k.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m
, Typeable a, Binary a, NFData a
, Binary k
@@ -550,7 +551,7 @@ memcacheAuth k mx = cachedByBinary k $ do
| otherwise
-> evalWriterT mx
-memcacheAuth' :: forall m k a.
+memcacheAuth' :: forall a m k.
( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m
, Typeable a, Binary a, NFData a
diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs
index e89b05c47..ef0d0a2e6 100644
--- a/src/Handler/Utils/StudyFeatures.hs
+++ b/src/Handler/Utils/StudyFeatures.hs
@@ -22,8 +22,6 @@ import Handler.Utils.StudyFeatures.Parse
import qualified Data.Csv as Csv
-import qualified Data.ByteString as ByteString
-
import qualified Data.Set as Set
import Data.RFC5051 (compareUnicode)
@@ -65,7 +63,7 @@ instance Csv.ToField UserTableStudyFeature where
[] $ ShortStudyFieldType userTableFieldType
instance Csv.ToField UserTableStudyFeatures where
- toField = ByteString.intercalate "; " . map Csv.toField . view _UserTableStudyFeatures
+ toField = Csv.toField . CsvSemicolonList . view _UserTableStudyFeatures
userTableStudyFeatureSort :: UserTableStudyFeature
-> UserTableStudyFeature
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 32ed19560..b59d1d723 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -11,6 +11,8 @@ module Handler.Utils.Submission
, submissionMatchesSheet
, submissionDeleteRoute
, correctionInvisibleWidget
+ , AuthorshipStatementSubmissionState(..)
+ , getUserAuthorshipStatement, getSubmissionAuthorshipStatement
) where
import Import hiding (joinPath)
@@ -36,6 +38,7 @@ import Handler.Utils
import qualified Handler.Utils.Rating as Rating (extractRatings)
import Handler.Utils.Delete
+import Database.Persist.Sql (SqlBackendCanRead)
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils.TH as E
@@ -362,7 +365,7 @@ submissionMultiArchive anonymous sft (Set.toList -> ids) = do
E.where_ $ submission E.^. SubmissionId E.==. E.val submissionID
E.where_ $ sheet E.^. SheetCourse E.==. submissionGroup E.^. SubmissionGroupCourse
return $ submissionGroup E.^. SubmissionGroupName
- let asciiGroups = nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) groups
+ let asciiGroups = Set.toList . Set.fromList $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) groups
return . intercalate "_" $ asciiGroups `snoc` fp
| Just feature <- userFeature anonymous
= do
@@ -453,7 +456,9 @@ extractRatingsMsg = do
(Right $(widgetFile "messages/submissionFilesIgnored"))
addMessageWidget Warning ignoredModal
--- | Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
+-- | Needs to *not* be called from within `runDB` so db transaction rollback can happen properly
+--
+-- Nontheless: we do assume elsewhere, that we can call `msgSubmissionErrors` from within `runDB` as long as we do `transactionUndo` iff it returns `Nothing`.
msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
msgSubmissionErrors = flip catches
[ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException)
@@ -974,3 +979,44 @@ correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ d
tellPoint CorrectionInvisibleExamUnfinished
return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible")
+
+
+getUserAuthorshipStatement :: ( MonadResource m
+ , IsSqlBackend backend, SqlBackendCanRead backend
+ )
+ => Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement`
+ -> SubmissionId
+ -> UserId
+ -> ReaderT backend m AuthorshipStatementSubmissionState
+getUserAuthorshipStatement mASDefinition subId uid = runConduit $
+ getStmts
+ .| fmap toRes (execWriterC . C.mapM_ $ tell . toPoint)
+ where
+ getStmts = E.selectSource . E.from $ \authorshipStatementSubmission -> do
+ E.where_ $ authorshipStatementSubmission E.^. AuthorshipStatementSubmissionSubmission E.==. E.val subId
+ E.&&. authorshipStatementSubmission E.^. AuthorshipStatementSubmissionUser E.==. E.val uid
+ return authorshipStatementSubmission
+ toPoint :: Entity AuthorshipStatementSubmission -> Maybe Any
+ toPoint (Entity _ AuthorshipStatementSubmission{..}) = Just . Any $ fmap entityKey mASDefinition == Just authorshipStatementSubmissionStatement
+ toRes :: Maybe Any -> AuthorshipStatementSubmissionState
+ toRes = \case
+ Just (Any True) -> ASExists
+ Just (Any False) -> ASOldStatement
+ Nothing -> ASMissing
+
+getSubmissionAuthorshipStatement :: ( MonadResource m
+ , IsSqlBackend backend, SqlBackendCanRead backend
+ )
+ => Maybe (Entity AuthorshipStatementDefinition) -- ^ Currently expected authorship statement; see `getSheetAuthorshipStatement`
+ -> SubmissionId
+ -> ReaderT backend m AuthorshipStatementSubmissionState
+getSubmissionAuthorshipStatement mASDefinition subId = fmap (fromMaybe ASMissing) . runConduit $
+ sourceSubmissionUsers
+ .| C.map E.unValue
+ .| C.mapM getUserAuthorshipStatement'
+ .| C.maximum
+ where
+ getUserAuthorshipStatement' = getUserAuthorshipStatement mASDefinition subId
+ sourceSubmissionUsers = E.selectSource . E.from $ \submissionUser -> do
+ E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
+ return $ submissionUser E.^. SubmissionUserUser
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index a3471822d..50e666ed0 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -45,7 +45,8 @@ module Handler.Utils.Table.Pagination
, maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
, anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
, cellTooltip
- , listCell, listCell'
+ , listCell, listCell', listCellOf, listCellOf'
+ , ilistCell, ilistCell', ilistCellOf, ilistCellOf'
, formCell, DBFormResult(..), getDBFormResult
, dbSelect
, (&)
@@ -1170,7 +1171,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
&& all (is _Just) filterSql
psLimit' = bool PagesizeAll psLimit selectPagesize
-
rows' <- E.select . E.from $ \t -> do
res <- dbtSQLQuery t
@@ -1183,10 +1183,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
Nothing
| PagesizeLimit l <- psLimit'
, selectPagesize
+ , hasn't (_FormSuccess . _DBCsvExport) csvMode
-> do
- unless (has (_FormSuccess . _DBCsvExport) csvMode) $
- E.limit l
- E.offset (psPage * l)
+ E.limit l
+ E.offset $ psPage * l
Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
_other -> return ()
Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql
@@ -1793,12 +1793,30 @@ listCell :: (IsDBTable m a, MonoFoldable mono) => mono -> (Element mono -> DBCel
listCell = listCell' . return
listCell' :: (IsDBTable m a, MonoFoldable mono) => WriterT a m mono -> (Element mono -> DBCell m a) -> DBCell m a
-listCell' mkXS mkCell = review dbCell . ([], ) $ do
+listCell' mkXS mkCell = ilistCell' (otoList <$> mkXS) $ const mkCell
+
+ilistCell :: (IsDBTable m a, MonoFoldableWithKey mono) => mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
+ilistCell = ilistCell' . return
+
+ilistCell' :: (IsDBTable m a, MonoFoldableWithKey mono) => WriterT a m mono -> (MonoKey mono -> Element mono -> DBCell m a) -> DBCell m a
+ilistCell' mkXS mkCell = review dbCell . ([], ) $ do
xs <- mkXS
- cells <- forM (toList xs) $
- \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
+ cells <- forM (otoKeyedList xs) $
+ \(view dbCell . uncurry mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
return $(widgetFile "table/cell/list")
+listCellOf :: IsDBTable m a' => Getting (Endo [a]) s a -> s -> (a -> DBCell m a') -> DBCell m a'
+listCellOf l x = listCell (x ^.. l)
+
+listCellOf' :: IsDBTable m a' => Getting (Endo [a]) s a -> WriterT a' m s -> (a -> DBCell m a') -> DBCell m a'
+listCellOf' l mkX = listCell' (toListOf l <$> mkX)
+
+ilistCellOf :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> s -> (i -> a -> DBCell m a') -> DBCell m a'
+ilistCellOf l x = listCell (itoListOf l x) . uncurry
+
+ilistCellOf' :: IsDBTable m a' => IndexedGetting i (Endo [(i, a)]) s a -> WriterT a' m s -> (i -> a -> DBCell m a') -> DBCell m a'
+ilistCellOf' l mkX = listCell' (itoListOf l <$> mkX) . uncurry
+
newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a))
instance Functor (DBFormResult i a) where
diff --git a/src/Handler/Utils/TermCandidates.hs b/src/Handler/Utils/TermCandidates.hs
index 652970c1b..d2b2359b1 100644
--- a/src/Handler/Utils/TermCandidates.hs
+++ b/src/Handler/Utils/TermCandidates.hs
@@ -18,7 +18,6 @@ import Import
-- import Control.Monad.Trans.Writer (mapWriterT)
-- import Database.Persist.Sql (fromSqlKey)
import qualified Data.Set as Set
-import qualified Data.List as List
import qualified Data.Map as Map
@@ -112,7 +111,7 @@ removeAmbiguousNames = do
)
E.having $ E.countRows E.!=. E.val (1 :: Int64)
return $ candidate E.^. StudyTermNameCandidateIncidence
- let ambiSet = E.unValue <$> List.nub ambiList
+ let ambiSet = E.unValue <$> nubOrd ambiList
-- Most SQL dialects won't allow deletion and queries on the same table at once, hence we delete in two steps.
deleteWhere [StudyTermNameCandidateIncidence <-. ambiSet]
return ambiSet
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index fc411d16f..f851d4fc9 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -24,6 +24,7 @@ import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.Set as Set
+import qualified Data.List as List
import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto.Legacy as E
@@ -200,6 +201,7 @@ data UserAssimilateExceptionReason
| UserAssimilateExamResultDifferentResult (Entity ExamResult) (Entity ExamResult)
| UserAssimilatePersonalisedSheetFileDifferentContent (Entity PersonalisedSheetFile) (Entity PersonalisedSheetFile)
| UserAssimilateTutorialParticipantCollidingRegGroups (Entity TutorialParticipant) (Entity TutorialParticipant)
+ | UserAssimilateCouldNotDetermineUserIdents
deriving (Eq, Ord, Show, Generic, Typeable)
assimilateUser :: UserId -- ^ @newUserId@
@@ -773,6 +775,17 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
delete oldSFId
in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures
+ userIdents <- E.select . E.from $ \user -> do
+ E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId]
+ return ( user E.^. UserId
+ , user E.^. UserIdent
+ )
+ case (,) <$> List.lookup (E.Value oldUserId) userIdents <*> List.lookup (E.Value newUserId) userIdents of
+ Just (E.Value oldIdent, E.Value newIdent')
+ | oldIdent /= newIdent' -> audit $ TransactionUserIdentChanged oldIdent newIdent'
+ | otherwise -> return ()
+ _other -> tellError UserAssimilateCouldNotDetermineUserIdents
+
delete oldUserId
audit $ TransactionUserAssimilated newUserId oldUserId
where
diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs
index 81e624789..96d21ff20 100644
--- a/src/Handler/Utils/Widgets.hs
+++ b/src/Handler/Utils/Widgets.hs
@@ -31,12 +31,19 @@ visibleUTCTime dtf t = do
-- | Simple link to a known route
-simpleLink :: RedirectUrl UniWorX url => Widget -> url -> Widget
+simpleLink :: HasRoute UniWorX url => Widget -> url -> Widget
simpleLink lbl url = do
- tUrl <- toTextUrl url
- [whamlet|^{lbl}|]
+ isAuth <- hasReadAccessTo $ urlRoute url
+ if | isAuth -> do
+ tUrl <- toTextUrl url
+ [whamlet|
+ $newline never
+
+ ^{lbl}
+ |]
+ | otherwise -> lbl
-simpleLinkI :: (RenderMessage UniWorX msg, RedirectUrl UniWorX url) => msg -> url -> Widget
+simpleLinkI :: (RenderMessage UniWorX msg, HasRoute UniWorX url) => msg -> url -> Widget
simpleLinkI = simpleLink . i18n
-- | toWidget-Version of @nameHtml@, for convenience
@@ -97,6 +104,10 @@ editedByW fmt tm usr = do
ft <- handlerToWidget $ formatTime fmt tm
[whamlet|_{MsgUtilEditedBy usr ft}|]
+boolHeat :: Bool -- ^ @isHot@
+ -> Milli
+boolHeat = bool 0 1
+
heat :: ( Real a, Real b )
=> a -> b -> Milli
-- ^ Distinguishes @full@, zero is mapped to 1, @full@ is mapped to 0
diff --git a/src/Handler/Utils/Workflow.hs b/src/Handler/Utils/Workflow.hs
new file mode 100644
index 000000000..947e0c6d3
--- /dev/null
+++ b/src/Handler/Utils/Workflow.hs
@@ -0,0 +1,29 @@
+module Handler.Utils.Workflow
+ ( workflowsDisabledWarning
+ , module Reexport
+ ) where
+
+import Import
+
+import Handler.Utils.I18n
+
+import Handler.Utils.Workflow.Form as Reexport
+import Handler.Utils.Workflow.EdgeForm as Reexport
+import Handler.Utils.Workflow.Restriction as Reexport
+import Handler.Utils.Workflow.CanonicalRoute as Reexport
+import Handler.Utils.Workflow.Workflow as Reexport
+
+
+workflowsDisabledWarning :: ( MonadHandler m
+ , HandlerSite m ~ UniWorX
+ , RenderMessage UniWorX titleMsg, RenderMessage UniWorX headingMsg
+ )
+ => titleMsg -> headingMsg
+ -> m Html
+ -> m Html
+workflowsDisabledWarning tMsg hMsg = volatileBool clusterVolatileWorkflowsEnabled warningHtml
+ where
+ warningHtml = liftHandler . siteLayoutMsg hMsg $ do
+ setTitleI tMsg
+
+ notificationWidget NotificationBroad Warning $(i18nWidgetFile "workflows-disabled")
diff --git a/src/Handler/Utils/Workflow/CanonicalRoute.hs b/src/Handler/Utils/Workflow/CanonicalRoute.hs
index cb3117475..507da9cee 100644
--- a/src/Handler/Utils/Workflow/CanonicalRoute.hs
+++ b/src/Handler/Utils/Workflow/CanonicalRoute.hs
@@ -16,7 +16,7 @@ data WorkflowScopeRoute
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data WorkflowInstanceR
- = WIEditR | WIDeleteR | WIWorkflowsR | WIInitiateR
+ = WIEditR | WIDeleteR | WIWorkflowsR | WIInitiateR | WIUpdateR
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data WorkflowWorkflowR
@@ -36,6 +36,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
WIDeleteR -> GWIDeleteR
WIWorkflowsR -> GWIWorkflowsR
WIInitiateR -> GWIInitiateR
+ WIUpdateR -> GWIUpdateR
WorkflowWorkflowListR -> GlobalWorkflowWorkflowListR
WorkflowWorkflowR wwCID subRoute -> GlobalWorkflowWorkflowR wwCID $ case subRoute of
WWWorkflowR -> GWWWorkflowR
@@ -50,6 +51,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
WIDeleteR -> SWIDeleteR
WIWorkflowsR -> SWIWorkflowsR
WIInitiateR -> SWIInitiateR
+ WIUpdateR -> SWIUpdateR
WorkflowWorkflowListR -> SchoolWorkflowWorkflowListR
WorkflowWorkflowR wwCID subRoute -> SchoolWorkflowWorkflowR wwCID $ case subRoute of
WWWorkflowR -> SWWWorkflowR
@@ -65,6 +67,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
GWIDeleteR -> WIDeleteR
GWIWorkflowsR -> WIWorkflowsR
GWIInitiateR -> WIInitiateR
+ GWIUpdateR -> WIUpdateR
GlobalWorkflowWorkflowListR -> Just ( WSGlobal, WorkflowWorkflowListR )
GlobalWorkflowWorkflowR wwCID subRoute -> Just . (WSGlobal, ) . WorkflowWorkflowR wwCID $ case subRoute of
GWWWorkflowR -> WWWorkflowR
@@ -79,6 +82,7 @@ _WorkflowScopeRoute = prism' (uncurry toRoute) toWorkflowScopeRoute
SWIDeleteR -> WIDeleteR
SWIWorkflowsR -> WIWorkflowsR
SWIInitiateR -> WIInitiateR
+ SWIUpdateR -> WIUpdateR
SchoolWorkflowWorkflowListR -> Just ( WSSchool ssh, WorkflowWorkflowListR )
SchoolWorkflowWorkflowR wwCID subRoute -> Just . (WSSchool ssh, ) . WorkflowWorkflowR wwCID $ case subRoute of
SWWWorkflowR -> WWWorkflowR
diff --git a/src/Handler/Utils/Workflow/EdgeForm.hs b/src/Handler/Utils/Workflow/EdgeForm.hs
index ce8168f4d..873f158c2 100644
--- a/src/Handler/Utils/Workflow/EdgeForm.hs
+++ b/src/Handler/Utils/Workflow/EdgeForm.hs
@@ -527,10 +527,11 @@ workflowEdgePayloadFields specs = evalRWST (forM specs $ runExceptT . renderSpec
miAdd :: ListPosition
-> Natural
+ -> ListLength
-> (Text -> Text)
-> FieldView UniWorX
-> Maybe (Html -> MForm (ExceptT WorkflowPayloadLabel Handler) (FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)) -> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))), Widget))
- miAdd _pos _dim nudge submitView = Just $ over (mapped . _1 . _FormSuccess) tweakRes . miForm nudge (Left submitView)
+ miAdd pos dim liveliness nudge submitView = guardOn (miAllowAdd pos dim liveliness) $ over (mapped . _1 . _FormSuccess) tweakRes . miForm nudge (Left submitView)
where tweakRes :: Maybe (NonEmpty (WorkflowFieldPayloadW FileReference UserId))
-> Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId))
-> FormResult (Map ListPosition (Maybe (WorkflowFieldPayloadW FileReference UserId)))
diff --git a/src/Handler/Utils/Workflow/Workflow.hs b/src/Handler/Utils/Workflow/Workflow.hs
index 7294810db..383e46377 100644
--- a/src/Handler/Utils/Workflow/Workflow.hs
+++ b/src/Handler/Utils/Workflow/Workflow.hs
@@ -70,7 +70,7 @@ followAutomaticEdges WorkflowGraph{..} = go []
| otherwise = throwM . WorkflowAutomaticEdgeAmbiguity $ Set.fromList automaticEdgeOptions
where
cState = wpTo $ last history
- automaticEdgeOptions = nub $ do
+ automaticEdgeOptions = nubOrd $ do
(nodeLbl, WGN{..}) <- Map.toList wgNodes
(edgeLbl, WorkflowGraphEdgeAutomatic{..}) <- Map.toList wgnEdges
guard $ wgeSource == cState
diff --git a/src/Handler/Workflow/Definition/Edit.hs b/src/Handler/Workflow/Definition/Edit.hs
index 1967fc958..b7865df88 100644
--- a/src/Handler/Workflow/Definition/Edit.hs
+++ b/src/Handler/Workflow/Definition/Edit.hs
@@ -54,22 +54,26 @@ postAWDEditR wds' wdn = do
, workflowDefinitionInstanceCategory = wdfInstanceCategory
}
- when (is _Nothing insConflict) . iforM_ wdfDescriptions $ \wddLang (wddTitle, wddDesc) -> do
+ when (is _Nothing insConflict) $ do
deleteWhere [WorkflowDefinitionDescriptionDefinition ==. wdId]
- insert WorkflowDefinitionDescription
- { workflowDefinitionDescriptionDefinition = wdId
- , workflowDefinitionDescriptionLanguage = wddLang
- , workflowDefinitionDescriptionTitle = wddTitle
- , workflowDefinitionDescriptionDescription = wddDesc
- }
- when (is _Nothing insConflict) . iforM_ wdfInstanceDescriptions $ \wddLang (wddTitle, wddDesc) -> do
+ insertMany_ $ do
+ (wddLang, (wddTitle, wddDesc)) <- Map.toList wdfDescriptions
+ return WorkflowDefinitionDescription
+ { workflowDefinitionDescriptionDefinition = wdId
+ , workflowDefinitionDescriptionLanguage = wddLang
+ , workflowDefinitionDescriptionTitle = wddTitle
+ , workflowDefinitionDescriptionDescription = wddDesc
+ }
+
deleteWhere [WorkflowDefinitionInstanceDescriptionDefinition ==. wdId]
- insert WorkflowDefinitionInstanceDescription
- { workflowDefinitionInstanceDescriptionDefinition = wdId
- , workflowDefinitionInstanceDescriptionLanguage = wddLang
- , workflowDefinitionInstanceDescriptionTitle = wddTitle
- , workflowDefinitionInstanceDescriptionDescription = wddDesc
- }
+ insertMany_ $ do
+ (wddLang, (wddTitle, wddDesc)) <- Map.toList wdfInstanceDescriptions
+ return WorkflowDefinitionInstanceDescription
+ { workflowDefinitionInstanceDescriptionDefinition = wdId
+ , workflowDefinitionInstanceDescriptionLanguage = wddLang
+ , workflowDefinitionInstanceDescriptionTitle = wddTitle
+ , workflowDefinitionInstanceDescriptionDescription = wddDesc
+ }
case insConflict of
Just (UniqueWorkflowDefinition wdn' wds'') -> return . Just $
diff --git a/src/Handler/Workflow/Instance.hs b/src/Handler/Workflow/Instance.hs
index 836fa52be..4c9e1c883 100644
--- a/src/Handler/Workflow/Instance.hs
+++ b/src/Handler/Workflow/Instance.hs
@@ -7,3 +7,4 @@ import Handler.Workflow.Instance.New as Handler.Workflow.Instance
import Handler.Workflow.Instance.Edit as Handler.Workflow.Instance
import Handler.Workflow.Instance.Delete as Handler.Workflow.Instance
import Handler.Workflow.Instance.Initiate as Handler.Workflow.Instance
+import Handler.Workflow.Instance.Update as Handler.Workflow.Instance
diff --git a/src/Handler/Workflow/Instance/Initiate.hs b/src/Handler/Workflow/Instance/Initiate.hs
index 361d675c5..d0046ae91 100644
--- a/src/Handler/Workflow/Instance/Initiate.hs
+++ b/src/Handler/Workflow/Instance/Initiate.hs
@@ -10,9 +10,7 @@ import Utils.Form
import Utils.Workflow
import Handler.Utils
-import Handler.Utils.Workflow.EdgeForm
-import Handler.Utils.Workflow.CanonicalRoute
-import Handler.Utils.Workflow.Workflow (followEdge)
+import Handler.Utils.Workflow
import qualified Data.CaseInsensitive as CI
import qualified Data.List.NonEmpty as NonEmpty
@@ -27,7 +25,7 @@ getSWIInitiateR = postSWIInitiateR
postSWIInitiateR ssh = workflowInstanceInitiateR $ WSSchool ssh
workflowInstanceInitiateR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
-workflowInstanceInitiateR rScope win = do
+workflowInstanceInitiateR rScope win = workflowsDisabledWarning MsgWorkflowInstanceInitiateTitleDisabled MsgWorkflowInstanceInitiateHeadingDisabled $ do
(WorkflowInstance{..}, ((edgeAct, edgeView'), edgeEnc), mDesc) <- runDB $ do
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
Entity wiId wi@WorkflowInstance{..} <- getBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
diff --git a/src/Handler/Workflow/Instance/List.hs b/src/Handler/Workflow/Instance/List.hs
index 944109f1c..e2515faf5 100644
--- a/src/Handler/Workflow/Instance/List.hs
+++ b/src/Handler/Workflow/Instance/List.hs
@@ -12,7 +12,8 @@ import Import
import Handler.Utils
import Utils.Workflow
-import Handler.Utils.Workflow.CanonicalRoute
+import Handler.Utils.Workflow
+import Handler.Workflow.Instance.Update
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
@@ -134,7 +135,7 @@ getSchoolWorkflowInstanceListR = workflowInstanceListR . WSSchool
workflowInstanceListR :: RouteWorkflowScope -> Handler Html
-workflowInstanceListR rScope = do
+workflowInstanceListR rScope = workflowsDisabledWarning title heading $ do
instances <- runDB $ do
dbScope <- maybeT notFound $ view _DBWorkflowScope <$> fromRouteWorkflowScope rScope
@@ -151,31 +152,42 @@ workflowInstanceListR rScope = do
mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute workflowInstanceName
mayEdit <- lift . hasReadAccessTo $ toEditRoute workflowInstanceName
mayList <- lift . hasReadAccessTo $ toListRoute workflowInstanceName
- guard $ mayInitiate || mayEdit || mayList
- return (wi, desc)
+ mayUpdate <- lift . hasWriteAccessTo $ toUpdateRoute workflowInstanceName
+ guard $ mayInitiate || mayEdit || mayList || mayUpdate
+ canUpdate <- lift $ workflowInstanceCanUpdate wiId
+ return (wi, desc, canUpdate)
- return . flip sortOn wis' $ \(Entity _ WorkflowInstance{..}, mDesc)
+ return . flip sortOn wis' $ \(Entity _ WorkflowInstance{..}, mDesc, _)
-> ( NTop workflowInstanceCategory
, workflowInstanceDescriptionTitle <$> mDesc
, workflowInstanceName
)
- (heading, title) <- case rScope of
- WSGlobal -> return (MsgGlobalWorkflowInstancesHeading, MsgGlobalWorkflowInstancesTitle)
- WSSchool ssh -> return (MsgSchoolWorkflowInstancesHeading ssh, MsgSchoolWorkflowInstancesTitle ssh)
- _other -> error "not implemented"
-
siteLayoutMsg heading $ do
setTitleI title
let mPitch = Just $(i18nWidgetFile "workflow-instance-list-explanation")
+ updateForm win = maybeT mempty . guardMOnM (lift . hasWriteAccessTo $ toUpdateRoute win) $ do
+ (updateWdgt, updateEnctype) <- liftHandler . generateFormPost . buttonForm' $ pure BtnWorkflowInstanceUpdate
+ lift $ wrapForm updateWdgt def
+ { formAction = Just . SomeRoute $ toUpdateRoute win
+ , formEncoding = updateEnctype
+ , formSubmit = FormNoSubmit
+ }
$(widgetFile "workflows/instances")
where
toInitiateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
toEditRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR)
toListRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
+ toUpdateRoute win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIUpdateR)
+
+ (heading, title) = case rScope of
+ WSGlobal -> (MsgGlobalWorkflowInstancesHeading, MsgGlobalWorkflowInstancesTitle)
+ WSSchool ssh -> (MsgSchoolWorkflowInstancesHeading ssh, MsgSchoolWorkflowInstancesTitle ssh)
+ _other -> error "not implemented"
+
getTopWorkflowInstanceListR :: Handler Html
-getTopWorkflowInstanceListR = do
+getTopWorkflowInstanceListR = workflowsDisabledWarning title heading $ do
gInstances <- runDB $ do
wis <- selectList [] []
wis' <- fmap catMaybes . forM wis $ \wi@(Entity wiId WorkflowInstance{..}) -> runMaybeT $ do
@@ -192,25 +204,35 @@ getTopWorkflowInstanceListR = do
mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName
mayEdit <- lift . hasReadAccessTo $ toEditRoute' rScope workflowInstanceName
mayList <- lift . hasReadAccessTo $ toListRoute' rScope workflowInstanceName
- guard $ mayInitiate || mayEdit || mayList
- return (rScope, [(wi, desc)])
+ mayUpdate <- lift . hasWriteAccessTo $ toUpdateRoute' rScope workflowInstanceName
+ guard $ mayInitiate || mayEdit || mayList || mayUpdate
+ canUpdate <- lift $ workflowInstanceCanUpdate wiId
+ return (rScope, [(wi, desc, canUpdate)])
- let iSortProj (Entity _ WorkflowInstance{..}, mDesc)
+ let iSortProj (Entity _ WorkflowInstance{..}, mDesc, _)
= ( NTop workflowInstanceCategory
, workflowInstanceDescriptionTitle <$> mDesc
, workflowInstanceName
)
return $ sortOn iSortProj <$> Map.fromListWith (<>) wis'
- siteLayoutMsg MsgTopWorkflowInstancesHeading $ do
- setTitleI MsgTopWorkflowInstancesTitle
+ siteLayoutMsg heading $ do
+ setTitleI title
let instanceList rScope instances = $(widgetFile "workflows/instances")
where
toInitiateRoute = toInitiateRoute' rScope
toEditRoute = toEditRoute' rScope
toListRoute = toListRoute' rScope
+ toUpdateRoute = toUpdateRoute' rScope
mPitch :: Maybe Widget
mPitch = Nothing
+ updateForm win = maybeT mempty . guardMOnM (lift . hasWriteAccessTo $ toUpdateRoute win) $ do
+ (updateWdgt, updateEnctype) <- liftHandler . generateFormPost . buttonForm' $ pure BtnWorkflowInstanceUpdate
+ lift $ wrapForm updateWdgt def
+ { formAction = Just . SomeRoute $ toUpdateRoute win
+ , formEncoding = updateEnctype
+ , formSubmit = FormNoSubmit
+ }
showHeadings = Map.keys gInstances /= [WSGlobal]
pitch = $(i18nWidgetFile "workflow-instance-list-explanation")
@@ -220,3 +242,6 @@ getTopWorkflowInstanceListR = do
toInitiateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIInitiateR)
toEditRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIEditR)
toListRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIWorkflowsR)
+ toUpdateRoute' rScope win = _WorkflowScopeRoute # (rScope, WorkflowInstanceR win WIUpdateR)
+
+ (title, heading) = (MsgTopWorkflowInstancesTitle, MsgTopWorkflowInstancesHeading)
diff --git a/src/Handler/Workflow/Instance/Update.hs b/src/Handler/Workflow/Instance/Update.hs
new file mode 100644
index 000000000..5453fba79
--- /dev/null
+++ b/src/Handler/Workflow/Instance/Update.hs
@@ -0,0 +1,123 @@
+module Handler.Workflow.Instance.Update
+ ( WorkflowInstanceUpdateButton(..)
+ , workflowInstanceCanUpdate
+ , postGWIUpdateR, postSWIUpdateR
+ ) where
+
+import Import
+import Utils.Form
+import Utils.Workflow
+
+import Handler.Utils.Workflow.CanonicalRoute
+
+import qualified Data.CaseInsensitive as CI
+
+import qualified Data.Set as Set
+import qualified Data.Map.Strict as Map
+
+import Handler.Utils.Memcached
+
+
+data WorkflowInstanceUpdateButton
+ = BtnWorkflowInstanceUpdate
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''WorkflowInstanceUpdateButton $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''WorkflowInstanceUpdateButton id
+
+instance Button UniWorX WorkflowInstanceUpdateButton where
+ btnClasses _ = [BCIsButton]
+
+
+data WorkflowInstanceUpdateAction
+ = WIUpdateGraph SharedWorkflowGraphId
+ | WIUpdateCategory (Maybe WorkflowInstanceCategory)
+ | WIUpdateInstanceDescription Lang (Maybe (Text, Maybe StoredMarkup))
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+
+workflowInstanceUpdates :: WorkflowInstanceId
+ -> DB (Set WorkflowInstanceUpdateAction)
+workflowInstanceUpdates wiId = execWriterT . maybeT_ $ do
+ WorkflowInstance{..} <- MaybeT . lift $ get wiId
+ wdId <- hoistMaybe workflowInstanceDefinition
+ WorkflowDefinition{..} <- MaybeT . lift $ get wdId
+
+ when (workflowDefinitionGraph /= workflowInstanceGraph) $
+ tellPoint $ WIUpdateGraph workflowDefinitionGraph
+
+ when (workflowDefinitionInstanceCategory /= workflowInstanceCategory) $
+ tellPoint $ WIUpdateCategory workflowDefinitionInstanceCategory
+
+ iDescs <- lift . lift $ selectList [WorkflowInstanceDescriptionInstance ==. wiId] []
+ dDescs <- lift . lift $ selectList [WorkflowDefinitionInstanceDescriptionDefinition ==. wdId] []
+
+ let iDescs' = Map.fromList $ map (\(Entity _ WorkflowInstanceDescription{..}) -> (CI.mk workflowInstanceDescriptionLanguage, (workflowInstanceDescriptionTitle, workflowInstanceDescriptionDescription))) iDescs
+ dDescs' = Map.fromList $ map (\(Entity _ WorkflowDefinitionInstanceDescription{..}) -> (CI.mk workflowDefinitionInstanceDescriptionLanguage, (workflowDefinitionInstanceDescriptionTitle, workflowDefinitionInstanceDescriptionDescription))) dDescs
+
+ forM_ (Map.keysSet iDescs' `Set.union` Map.keysSet dDescs') $ \lang -> if
+ | Just iDesc <- Map.lookup lang iDescs'
+ , Just dDesc <- Map.lookup lang dDescs'
+ , iDesc /= dDesc
+ -> tellPoint . WIUpdateInstanceDescription (CI.original lang) $ Just dDesc
+ | Just dDesc <- Map.lookup lang dDescs'
+ , not $ Map.member lang iDescs'
+ -> tellPoint . WIUpdateInstanceDescription (CI.original lang) $ Just dDesc
+ | Map.member lang iDescs'
+ , not $ Map.member lang dDescs'
+ -> tellPoint $ WIUpdateInstanceDescription (CI.original lang) Nothing
+ | otherwise
+ -> return ()
+
+workflowInstanceCanUpdate :: WorkflowInstanceId
+ -> DB Bool
+workflowInstanceCanUpdate wiId = not . null <$> workflowInstanceUpdates wiId
+
+
+postGWIUpdateR :: WorkflowInstanceName -> Handler Void
+postGWIUpdateR = updateR WSGlobal
+
+postSWIUpdateR :: SchoolId -> WorkflowInstanceName -> Handler Void
+postSWIUpdateR ssh = updateR $ WSSchool ssh
+
+
+updateR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler a
+updateR rScope win = do
+ runDB $ do
+ scope <- maybeT notFound $ fromRouteWorkflowScope rScope
+ wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
+ updates <- workflowInstanceUpdates wiId
+
+ when (null updates) $
+ addMessageI Warning MsgWorkflowInstanceUpdateNoActions
+
+ forM_ updates $ \case
+ WIUpdateGraph graphId -> do
+ update wiId [ WorkflowInstanceGraph =. graphId ]
+ addMessageI Success MsgWorkflowInstanceUpdateUpdatedGraph
+ WIUpdateCategory iCat -> do
+ update wiId [ WorkflowInstanceCategory =. iCat ]
+ addMessageI Success MsgWorkflowInstanceUpdateUpdatedCategory
+ WIUpdateInstanceDescription lang Nothing -> do
+ deleteBy $ UniqueWorkflowInstanceDescription wiId lang
+ addMessageI Success $ MsgWorkflowInstanceUpdateDeletedDescriptionLanguage lang
+ WIUpdateInstanceDescription lang (Just (title, mDesc)) -> do
+ void $ upsertBy
+ (UniqueWorkflowInstanceDescription wiId lang)
+ WorkflowInstanceDescription
+ { workflowInstanceDescriptionInstance = wiId
+ , workflowInstanceDescriptionLanguage = lang
+ , workflowInstanceDescriptionTitle = title
+ , workflowInstanceDescriptionDescription = mDesc
+ }
+ [ WorkflowInstanceDescriptionTitle =. title
+ , WorkflowInstanceDescriptionDescription =. mDesc
+ ]
+ addMessageI Success $ MsgWorkflowInstanceUpdateUpdatedDescriptionLanguage lang
+ memcachedByInvalidate (AuthCacheWorkflowInstanceInitiators win rScope) $ Proxy @(Set (WorkflowRole UserId))
+ memcachedByInvalidate (AuthCacheWorkflowInstanceWorkflowViewers win rScope) $ Proxy @(WorkflowWorkflowId, Set (WorkflowRole UserId))
+ when (isTopWorkflowScope rScope) $
+ memcachedByInvalidate NavCacheHaveTopWorkflowInstancesRoles $ Proxy @(Set ((RouteWorkflowScope, WorkflowInstanceName), WorkflowRole UserId))
+
+ redirect $ _WorkflowScopeRoute # ( rScope, WorkflowInstanceListR )
diff --git a/src/Handler/Workflow/Workflow/List.hs b/src/Handler/Workflow/Workflow/List.hs
index f48943e3a..a884afb36 100644
--- a/src/Handler/Workflow/Workflow/List.hs
+++ b/src/Handler/Workflow/Workflow/List.hs
@@ -14,8 +14,7 @@ module Handler.Workflow.Workflow.List
import Import hiding (Last(..), WriterT)
import Utils.Workflow
-import Handler.Utils.Workflow.Workflow
-import Handler.Utils.Workflow.CanonicalRoute
+import Handler.Utils.Workflow
import Handler.Workflow.Workflow.Workflow (WorkflowHistoryItemActor'(..), WorkflowHistoryItemActor)
@@ -66,17 +65,16 @@ getSchoolWorkflowWorkflowListR :: SchoolId -> Handler Html
getSchoolWorkflowWorkflowListR = workflowWorkflowListR . WSSchool
workflowWorkflowListR :: RouteWorkflowScope -> Handler Html
-workflowWorkflowListR rScope = do
+workflowWorkflowListR rScope = workflowsDisabledWarning (headings ^. _1) (headings ^. _2) $ do
scope <- runDB . maybeT notFound $ fromRouteWorkflowScope rScope
- MsgRenderer mr <- getMsgRenderer
- workflowWorkflowList (headings mr) columns . runReader $ do
+ workflowWorkflowList headings columns . runReader $ do
workflowWorkflow <- view queryWorkflowWorkflow
return $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
where
columns = def
{ wwListColumnScope = False
}
- headings mr = (MsgWorkflowWorkflowListScopeTitle $ mr rScope, MsgWorkflowWorkflowListScopeHeading $ mr rScope)
+ headings = (MsgWorkflowWorkflowListScopeTitle rScope, MsgWorkflowWorkflowListScopeHeading rScope)
getGWIWorkflowsR :: WorkflowInstanceName -> Handler Html
@@ -86,18 +84,17 @@ getSWIWorkflowsR :: SchoolId -> WorkflowInstanceName -> Handler Html
getSWIWorkflowsR ssh = workflowInstanceWorkflowsR $ WSSchool ssh
workflowInstanceWorkflowsR :: RouteWorkflowScope -> WorkflowInstanceName -> Handler Html
-workflowInstanceWorkflowsR rScope win = do
+workflowInstanceWorkflowsR rScope win = workflowsDisabledWarning (MsgWorkflowWorkflowListNamedInstanceTitleDisabled rScope) (MsgWorkflowWorkflowListNamedInstanceHeadingDisabled rScope) $ do
(scope, desc) <- runDB $ do
scope <- maybeT notFound $ fromRouteWorkflowScope rScope
wiId <- getKeyBy404 . UniqueWorkflowInstance win $ scope ^. _DBWorkflowScope
desc <- selectWorkflowInstanceDescription wiId
return (scope, desc)
- MsgRenderer mr <- getMsgRenderer
let headings = case desc of
Nothing -> (MsgWorkflowWorkflowListInstanceTitle, MsgWorkflowWorkflowListInstanceHeading)
Just (Entity _ WorkflowInstanceDescription{..})
- -> ( MsgWorkflowWorkflowListNamedInstanceTitle (mr rScope) workflowInstanceDescriptionTitle
- , MsgWorkflowWorkflowListNamedInstanceHeading (mr rScope) workflowInstanceDescriptionTitle
+ -> ( MsgWorkflowWorkflowListNamedInstanceTitle rScope workflowInstanceDescriptionTitle
+ , MsgWorkflowWorkflowListNamedInstanceHeading rScope workflowInstanceDescriptionTitle
)
workflowWorkflowList headings columns . runReader $ do
workflowWorkflow <- view queryWorkflowWorkflow
@@ -117,7 +114,7 @@ getAdminWorkflowWorkflowListR = workflowWorkflowList headings def $ const E.true
where headings = (MsgAdminWorkflowWorkflowListTitle, MsgAdminWorkflowWorkflowListHeading)
getTopWorkflowWorkflowListR :: Handler Html
-getTopWorkflowWorkflowListR = workflowWorkflowList headings def . views queryWorkflowWorkflow $ isTopWorkflowScopeSql . (E.^. WorkflowWorkflowScope)
+getTopWorkflowWorkflowListR = workflowsDisabledWarning (headings ^. _1) (headings ^. _2) . workflowWorkflowList headings def . views queryWorkflowWorkflow $ isTopWorkflowScopeSql . (E.^. WorkflowWorkflowScope)
where headings = (MsgWorkflowWorkflowListTopTitle, MsgWorkflowWorkflowListTopHeading)
diff --git a/src/Handler/Workflow/Workflow/Workflow.hs b/src/Handler/Workflow/Workflow/Workflow.hs
index 3a4248245..441fa1d54 100644
--- a/src/Handler/Workflow/Workflow/Workflow.hs
+++ b/src/Handler/Workflow/Workflow/Workflow.hs
@@ -13,9 +13,7 @@ import Utils.Workflow
import Data.Semigroup (Last(..))
import Handler.Utils
-import Handler.Utils.Workflow.EdgeForm
-import Handler.Utils.Workflow.CanonicalRoute
-import Handler.Utils.Workflow.Workflow
+import Handler.Utils.Workflow
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -77,7 +75,7 @@ getSWWFilesR ssh = getWorkflowFilesR $ WSSchool ssh
workflowR :: RouteWorkflowScope -> CryptoFileNameWorkflowWorkflow -> Handler Html
-workflowR rScope cID = do
+workflowR rScope cID = workflowsDisabledWarning title heading $ do
(mEdge, (workflowState, workflowHistory)) <- runDB $ do
wwId <- decrypt cID
WorkflowWorkflow{..} <- get404 wwId
@@ -216,10 +214,6 @@ workflowR rScope cID = do
sequenceOf_ (_Just . _1 . _1 . _Just) mEdge
- (heading, title) <- case rScope of
- WSGlobal -> return (MsgGlobalWorkflowWorkflowWorkflowHeading cID, MsgGlobalWorkflowWorkflowWorkflowTitle cID)
- WSSchool ssh -> return (MsgSchoolWorkflowWorkflowWorkflowHeading ssh cID, MsgSchoolWorkflowWorkflowWorkflowTitle ssh cID)
- _other -> error "not implemented"
let headingWgt
| Just WorkflowCurrentState{..} <- workflowState
, Just (_, Just icn) <- wcsState
@@ -255,6 +249,11 @@ workflowR rScope cID = do
Just (Entity _ User{..}) -> nameWidget userDisplayName userSurname
WorkflowFieldPayloadW (WFPFile v ) -> absurd v
$(widgetFile "workflows/workflow")
+ where
+ (heading, title) = case rScope of
+ WSGlobal -> (MsgGlobalWorkflowWorkflowWorkflowHeading cID, MsgGlobalWorkflowWorkflowWorkflowTitle cID)
+ WSSchool ssh -> (MsgSchoolWorkflowWorkflowWorkflowHeading ssh cID, MsgSchoolWorkflowWorkflowWorkflowTitle ssh cID)
+ _other -> error "not implemented"
getWorkflowFilesR :: RouteWorkflowScope
-> CryptoFileNameWorkflowWorkflow
diff --git a/src/Import.hs b/src/Import.hs
index ac410e50d..5eb5eb363 100644
--- a/src/Import.hs
+++ b/src/Import.hs
@@ -12,5 +12,6 @@ import Utils.Metrics as Import
import Utils.Files as Import
import Utils.PersistentTokenBucket as Import
import Utils.Csv.Mail as Import
+import Utils.VolatileClusterSettings as Import
import Jobs.Types as Import (JobHandler(..))
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 2bd19bc28..ad0ac8f97 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -24,12 +24,14 @@ import ClassyPrelude.Yesod as Import
, authorizationCheck
, mkMessage, mkMessageFor, mkMessageVariant
, YesodBreadcrumbs(..)
+ , MonoZip(..), ozipWith
)
import UnliftIO.Async.Utils as Import
import Model.Types.TH.JSON as Import
import Model.Types.TH.Wordlist as Import
+import Model.Types.TH.Binary as Import
import Mail as Import
@@ -45,6 +47,8 @@ import Utils.Sql as Import
import Utils.Widgets as Import
import Utils.Auth as Import
+import Settings.Cluster.Volatile as Import
+
import Data.Fixed as Import
import Data.UUID as Import (UUID)
@@ -232,6 +236,8 @@ import Data.Scientific as Import (Scientific, formatScientific)
import Data.MultiSet as Import (MultiSet)
+import Data.MonoTraversable.Keys as Import
+
import Control.Monad.Trans.RWS (RWST)
diff --git a/src/Jobs.hs b/src/Jobs.hs
index bbc298877..7fe2fcf9c 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -498,9 +498,12 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker
handleCmd JobCtlTest = $logDebugS logIdent "JobCtlTest"
handleCmd JobCtlFlush = do
$logDebugS logIdent "JobCtlFlush..."
+ maxFlush <- getsYesod $ view _appJobMaxFlush
+ let selectOpts = [ Asc QueuedJobCreationTime ]
+ & maybe id (\maxCount -> (:) (LimitTo $ fromIntegral maxCount)) maxFlush
heldLocks <- asks jobHeldLocks >>= readTVarIO
void . lift . runDB . runConduit
- $ selectKeys [ QueuedJobId /<-. Set.toList heldLocks ] [ Asc QueuedJobCreationTime ]
+ $ selectKeys [ QueuedJobId /<-. Set.toList heldLocks ] selectOpts
.| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod)
lFlushTVar <- asks jobLastFlush
atomically . modifyTVar' lFlushTVar . max . Just =<< liftIO getCurrentTime
diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs
index b1bb1d05a..368daf8de 100644
--- a/src/Jobs/Crontab.hs
+++ b/src/Jobs/Crontab.hs
@@ -179,7 +179,7 @@ determineCrontab = execWriterT $ do
when (isn't _JobsOffload appJobMode) $ do
case appJobFlushInterval of
- Just interval -> tell $ HashMap.singleton
+ Just interval | maybe True (> 0) appJobMaxFlush -> tell $ HashMap.singleton
JobCtlFlush
Cron
{ cronInitial = CronAsap
@@ -187,7 +187,7 @@ determineCrontab = execWriterT $ do
, cronRateLimit = interval
, cronNotAfter = Right CronNotScheduled
}
- Nothing -> return ()
+ _other -> return ()
oldestInvitationMUTC <- lift $ preview (_head . _entityVal . _invitationExpiresAt . _Just) <$> selectList [InvitationExpiresAt !=. Nothing] [Asc InvitationExpiresAt, LimitTo 1]
whenIsJust oldestInvitationMUTC $ \oldestInvUTC -> tell $ HashMap.singleton
@@ -322,7 +322,7 @@ determineCrontab = execWriterT $ do
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
, cronRepeat = CronRepeatNever
, cronRateLimit = appSynchroniseLdapUsersInterval
- , cronNotAfter = Left syncWithin
+ , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appSynchroniseLdapUsersInterval nextIntervalTime
}
| otherwise
-> return ()
@@ -341,7 +341,7 @@ determineCrontab = execWriterT $ do
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
, cronRepeat = CronRepeatNever
, cronRateLimit = appPruneUnreferencedFilesInterval
- , cronNotAfter = Left within
+ , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appPruneUnreferencedFilesInterval nextIntervalTime
}
whenIsJust ((,) <$> appStudyFeaturesRecacheRelevanceWithin <*> appJobCronInterval) $ \(within, cInterval) -> do
@@ -358,7 +358,7 @@ determineCrontab = execWriterT $ do
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
, cronRepeat = CronRepeatNever
, cronRateLimit = appStudyFeaturesRecacheRelevanceInterval
- , cronNotAfter = Left within
+ , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appStudyFeaturesRecacheRelevanceInterval nextIntervalTime
}
let
diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs
index deaedd332..7ab592eb1 100644
--- a/src/Jobs/Handler/Files.hs
+++ b/src/Jobs/Handler/Files.hs
@@ -198,14 +198,14 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
)
E.delete . E.from $ \fileContentChunkUnreferenced -> do
- let unreferencedChunkHash = E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
+ let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
return $ E.any E.exists (fileReferences $ fileContentEntry E.^. FileContentEntryHash)
E.where_ $ chunkIdFilter unreferencedChunkHash
let unmarkWorkflowFiles (otoList -> fRefs) = E.delete . E.from $ \fileContentChunkUnreferenced -> do
- let unreferencedChunkHash = E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
+ let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
return $ fileContentEntry E.^. FileContentEntryHash `E.in_` E.valList fRefs
@@ -216,7 +216,7 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
let
getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do
let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do
- let unreferencedChunkHash = E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
+ let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
E.on $ fileContentEntry' E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash
E.where_ $ chunkIdFilter unreferencedChunkHash
@@ -240,7 +240,7 @@ dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtom
let
getChunkCandidates = E.selectSource . E.from $ \fileContentChunkUnreferenced -> do
- let unreferencedChunkHash = E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
+ let unreferencedChunkHash = E.unKey $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
E.where_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince E.<. E.val (addUTCTime (-keep) now)
E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry ->
E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. unreferencedChunkHash
diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs
index adace86d9..aa3247ccd 100644
--- a/src/Jobs/Handler/QueueNotification.hs
+++ b/src/Jobs/Handler/QueueNotification.hs
@@ -116,7 +116,7 @@ determineNotificationCandidates = awaitForever $ \notif -> do
E.where_ $ admin E.^. UserFunctionSchool `E.in_` E.valList (Set.toList newAdminSchools)
E.&&. admin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
return user
- withNotif . yieldMany . nub $ affectedUser <> affectedAdmins
+ withNotif . yieldMany . nubOrd $ affectedUser <> affectedAdmins
NotificationUserSystemFunctionsUpdate{..}
-> withNotif $ selectSource [UserId ==. nUser] []
NotificationUserAuthModeUpdate{..}
diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs
index 52e7e0a22..b8b9e9fa9 100644
--- a/src/Jobs/Handler/SendNotification/Allocation.hs
+++ b/src/Jobs/Handler/SendNotification/Allocation.hs
@@ -56,7 +56,7 @@ dispatchNotificationAllocationRegister (otoList -> nAllocations) jRecipient = us
dispatchNotificationAllocationAllocation :: Set AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient = do
- courses <- fmap (nubOn $ views _2 entityKey) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do
+ courses <- fmap (nubOrdOn $ views _2 entityKey) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
@@ -73,7 +73,7 @@ dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient =
return (allocation, course)
- let allocations = nubOn entityKey $ courses ^.. folded . _1
+ let allocations = nubOrdOn entityKey $ courses ^.. folded . _1
unless (null courses) . userMailT jRecipient $ do
now <- liftIO getCurrentTime
@@ -95,7 +95,7 @@ dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient =
dispatchNotificationAllocationUnratedApplications :: Set AllocationId -> UserId -> Handler ()
dispatchNotificationAllocationUnratedApplications (otoList -> nAllocations) jRecipient = do
- courses <- fmap (nubOn (views _2 entityKey) . over (traverse . _3) (fromIntegral . E.unValue)) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do
+ courses <- fmap (nubOrdOn (views _2 entityKey) . over (traverse . _3) (fromIntegral . E.unValue)) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
@@ -121,7 +121,7 @@ dispatchNotificationAllocationUnratedApplications (otoList -> nAllocations) jRec
return (allocation, course, unratedAppCount)
- let allocations = nubOn entityKey $ courses ^.. folded . _1
+ let allocations = nubOrdOn entityKey $ courses ^.. folded . _1
unless (null courses) . userMailT jRecipient $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index bbee11bd1..54e0317ec 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -71,6 +71,10 @@ dispatchHealthCheckMatchingClusterConfig
ourSetting <- getsYesod appAuthKey
dbSetting <- clusterSetting @'ClusterAuthKey
return $ Just ourSetting == dbSetting
+ clusterSettingMatches ClusterPersonalisedSheetFilesSeedKey = do
+ ourSetting <- getsYesod appPersonalisedSheetFilesSeedKey
+ dbSetting <- clusterSetting @'ClusterPersonalisedSheetFilesSeedKey
+ return $ Just ourSetting == dbSetting
clusterSetting :: forall key.
diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs
index af7e46791..c2732dd35 100644
--- a/src/Jobs/Queue.hs
+++ b/src/Jobs/Queue.hs
@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+
module Jobs.Queue
( writeJobCtl, writeJobCtlBlock
, writeJobCtl', writeJobCtlBlock'
@@ -18,6 +20,8 @@ import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Aeson as Aeson
+
import Control.Monad.Random (evalRand, mkStdGen, uniform)
import qualified Data.Conduit.List as C
@@ -30,6 +34,9 @@ import Control.Monad.Trans.Resource (register)
import System.Clock (getTime, Clock(Monotonic))
+import qualified Database.Esqueleto.Legacy as E
+import qualified Database.Esqueleto.Utils as E
+
data JobQueueException = JobQueuePoolEmpty
| JobQueueWorkerNotFound
@@ -92,7 +99,14 @@ queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX (Maybe QueuedJobId)
queueJobUnsafe queuedJobWriteLastExec job = do
$logDebugS "queueJob" $ tshow job
- doQueue <- fmap not . and2M (return $ jobNoQueueSame job) $ exists [ QueuedJobContent ==. toJSON job ]
+ doQueue <- maybeT (return True) $ do
+ noQueueSame <- hoistMaybe $ jobNoQueueSame job
+ lift . fmap not . E.selectExists . E.from $ \queuedJob -> case noQueueSame of
+ JobNoQueueSame -> E.where_ $ queuedJob E.^. QueuedJobContent E.==. E.val (toJSON job)
+ JobNoQueueSameTag ->
+ let Aeson.Object obj = toJSON job
+ tag = obj HashMap.! "job"
+ in E.where_ $ (queuedJob E.^. QueuedJobContent) E.->. "job" E.==. E.val tag
if
| doQueue -> Just <$> do
diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs
index 81c741d12..94afb6b53 100644
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@@ -18,7 +18,7 @@ module Jobs.Types
, showWorkerId, newWorkerId
, JobQueue, jqInsert, jqDequeue', jqDequeue, jqDepth, jqContents
, JobPriority(..), prioritiseJob
- , jobNoQueueSame, jobMovable
+ , JobNoQueueSame(..), jobNoQueueSame, jobMovable
, module Cron
) where
@@ -302,21 +302,25 @@ prioritiseJob (JobCtlGenerateHealthReport _) = JobPrioRealtime
prioritiseJob JobCtlDetermineCrontab = JobPrioRealtime
prioritiseJob _ = JobPrioBatch
-jobNoQueueSame :: Job -> Bool
+data JobNoQueueSame = JobNoQueueSame | JobNoQueueSameTag
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite)
+
+jobNoQueueSame :: Job -> Maybe JobNoQueueSame
jobNoQueueSame = \case
- JobSendPasswordReset{} -> True
- JobTruncateTransactionLog{} -> True
- JobPruneInvitations{} -> True
- JobDeleteTransactionLogIPs{} -> True
- JobSynchroniseLdapUser{} -> True
- JobChangeUserDisplayEmail{} -> True
- JobPruneSessionFiles{} -> True
- JobPruneUnreferencedFiles{} -> True
- JobInjectFiles{} -> True
- JobPruneFallbackPersonalisedSheetFilesKeys{} -> True
- JobRechunkFiles{} -> True
- JobDetectMissingFiles{} -> True
- _ -> False
+ JobSendPasswordReset{} -> Just JobNoQueueSame
+ JobTruncateTransactionLog{} -> Just JobNoQueueSame
+ JobPruneInvitations{} -> Just JobNoQueueSame
+ JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame
+ JobSynchroniseLdapUser{} -> Just JobNoQueueSame
+ JobChangeUserDisplayEmail{} -> Just JobNoQueueSame
+ JobPruneSessionFiles{} -> Just JobNoQueueSameTag
+ JobPruneUnreferencedFiles{} -> Just JobNoQueueSameTag
+ JobInjectFiles{} -> Just JobNoQueueSameTag
+ JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag
+ JobRechunkFiles{} -> Just JobNoQueueSameTag
+ JobDetectMissingFiles{} -> Just JobNoQueueSameTag
+ _ -> Nothing
jobMovable :: JobCtl -> Bool
jobMovable = isn't _JobCtlTest
diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs
index 537127fb5..78ac1db9e 100644
--- a/src/Model/Migration/Definitions.hs
+++ b/src/Model/Migration/Definitions.hs
@@ -103,6 +103,9 @@ data ManualMigration
| Migration20210208StudyFeaturesRelevanceCachedUUIDs
| Migration20210318CrontabSubmissionRatedNotification
| Migration20210608SeparateTermActive
+ -- TODO: migration regarding authorship statements
+ -- - apply desired non-default modes for IfI
+ -- - set authorship statement texts for IfI
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite)
diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs
index 76d427ed9..8f9a3bd28 100644
--- a/src/Model/Types/DateTime.hs
+++ b/src/Model/Types/DateTime.hs
@@ -133,6 +133,8 @@ instance ToJSON TermIdentifier where
instance FromJSON TermIdentifier where
parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
+pathPieceCsv ''TermIdentifier
+
{- Must be defined in a later module:
termField :: Field (HandlerT UniWorX IO) TermIdentifier
termField = checkMMap (return . termFromText) termToText textField
diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs
index 137810be8..493d021b0 100644
--- a/src/Model/Types/Health.hs
+++ b/src/Model/Types/Health.hs
@@ -94,6 +94,6 @@ healthReportStatus = \case
HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully?
HealthActiveJobExecutors (Just prop )
| prop <= 0 -> HealthFailure
- HealthDoesFlush (Just prop )
- | prop >= 1 -> HealthFailure
+ HealthDoesFlush mProp
+ | maybe True (>= 2) mProp -> HealthFailure
_other -> maxBound -- Minimum badness
diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs
index c363241e0..ef644c961 100644
--- a/src/Model/Types/Markup.hs
+++ b/src/Model/Types/Markup.hs
@@ -3,6 +3,7 @@ module Model.Types.Markup
, StoredMarkup(..)
, htmlToStoredMarkup, plaintextToStoredMarkup, preEscapedToStoredMarkup
, esqueletoMarkupOutput
+ , I18nStoredMarkup
) where
import Import.NoModel
@@ -30,7 +31,7 @@ data MarkupFormat
| MarkupHtml
| MarkupPlaintext
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
- deriving anyclass (Universe, Finite, NFData)
+ deriving anyclass (Universe, Finite, Binary, Hashable, NFData)
nullaryPathPiece ''MarkupFormat $ camelToPathPiece' 1
pathPieceJSON ''MarkupFormat
@@ -40,7 +41,7 @@ data StoredMarkup = StoredMarkup
, markupOutput :: Html
}
deriving (Read, Show, Generic, Typeable)
- deriving anyclass (NFData)
+ deriving anyclass (Binary, Hashable, NFData)
htmlToStoredMarkup :: Html -> StoredMarkup
htmlToStoredMarkup html = StoredMarkup
@@ -133,3 +134,5 @@ instance PersistField StoredMarkup where
toPersistValue = PersistLiteralEscaped . LBS.toStrict . Aeson.encode
instance PersistFieldSql StoredMarkup where
sqlType _ = SqlOther "jsonb"
+
+type I18nStoredMarkup = I18n StoredMarkup
diff --git a/src/Model/Types/School.hs b/src/Model/Types/School.hs
index 0b9f65634..9fb8820fc 100644
--- a/src/Model/Types/School.hs
+++ b/src/Model/Types/School.hs
@@ -3,6 +3,16 @@ module Model.Types.School where
import Import.NoModel
import Model.Types.TH.PathPiece
+import Database.Persist.Sql (PersistFieldSql(..))
+import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
+import Data.ByteArray (ByteArrayAccess)
+
+import qualified Crypto.Hash as Crypto
+import qualified Data.Binary as Binary
+
+import Model.Types.Markup
+
+
data SchoolFunction
= SchoolAdmin
| SchoolLecturer
@@ -17,3 +27,34 @@ pathPieceJSON ''SchoolFunction
pathPieceJSONKey ''SchoolFunction
derivePersistFieldPathPiece ''SchoolFunction
pathPieceBinary ''SchoolFunction
+
+data SchoolAuthorshipStatementMode
+ = SchoolAuthorshipStatementModeNone
+ | SchoolAuthorshipStatementModeOptional
+ | SchoolAuthorshipStatementModeRequired
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+ deriving anyclass (Universe, Finite, NFData)
+
+finitePathPiece ''SchoolAuthorshipStatementMode [ "no-statement", "optional", "required" ] -- avoid @none@ since it does not play nice with yesod-form (`selectField` etc.)
+pathPieceJSON ''SchoolAuthorshipStatementMode
+pathPieceJSONKey ''SchoolAuthorshipStatementMode
+derivePersistFieldPathPiece ''SchoolAuthorshipStatementMode
+pathPieceBinary ''SchoolAuthorshipStatementMode
+pathPieceHttpApiData ''SchoolAuthorshipStatementMode
+
+newtype AuthorshipStatementReference = AuthorshipStatementReference (Digest SHA3_512)
+ deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
+ deriving newtype ( PersistField
+ , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
+ , Hashable, NFData
+ , ByteArrayAccess
+ , Binary
+ )
+
+instance PersistFieldSql AuthorshipStatementReference where
+ sqlType _ = sqlType $ Proxy @(Digest SHA3_512)
+
+makeWrapped ''AuthorshipStatementReference
+
+toAuthorshipStatementReference :: I18nStoredMarkup -> AuthorshipStatementReference
+toAuthorshipStatementReference = review _Wrapped . Crypto.hashlazy . Binary.encode
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index 5b83645c3..e4793092e 100644
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@@ -77,6 +77,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthRated
| AuthUserSubmissions
| AuthCorrectorSubmissions
+ | AuthCorrectionAnonymous
| AuthSubmissionGroup
| AuthCapacity
| AuthRegisterGroup
diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs
index c9cac4fd9..69f2a0791 100644
--- a/src/Model/Types/Sheet.hs
+++ b/src/Model/Types/Sheet.hs
@@ -12,6 +12,7 @@ module Model.Types.Sheet
import Import.NoModel
import Model.Types.Common
import Utils.Lens.TH
+import Model.Types.TH.PathPiece
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
@@ -406,3 +407,17 @@ instance Csv.ToField (SheetType epid, Maybe Points) where
= Csv.toField res
toField (_, Just _)
= "submitted"
+
+data SheetAuthorshipStatementMode
+ = SheetAuthorshipStatementModeDisabled
+ | SheetAuthorshipStatementModeExam
+ | SheetAuthorshipStatementModeEnabled
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite, NFData)
+
+nullaryPathPiece ''SheetAuthorshipStatementMode $ camelToPathPiece' 4
+derivePersistFieldPathPiece ''SheetAuthorshipStatementMode
+pathPieceJSON ''SheetAuthorshipStatementMode
+pathPieceJSONKey ''SheetAuthorshipStatementMode
+pathPieceBinary ''SheetAuthorshipStatementMode
+pathPieceHttpApiData ''SheetAuthorshipStatementMode
diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs
index 49dfd12ce..676b64776 100644
--- a/src/Model/Types/Submission.hs
+++ b/src/Model/Types/Submission.hs
@@ -130,3 +130,27 @@ pseudonymWords = folding
pseudonymFragments :: Fold Text [PseudonymWord]
pseudonymFragments = folding
$ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)
+
+
+instance PathPiece Pseudonym where
+ toPathPiece = review _PseudonymText
+ fromPathPiece t
+ | Just p <- t ^? _PseudonymText = Just p
+ | Just n <- fromPathPiece t = Just $ Pseudonym n
+ | otherwise = Nothing
+
+pathPieceCsv ''Pseudonym
+
+
+data AuthorshipStatementSubmissionState
+ = ASMissing
+ | ASOldStatement
+ | ASExists
+ deriving (Eq, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite)
+
+deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger roughly encodes better; summaries are taken with `max`
+
+nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1
+pathPieceCsv ''AuthorshipStatementSubmissionState
+pathPieceJSON ''AuthorshipStatementSubmissionState
diff --git a/src/Model/Types/TH/Binary.hs b/src/Model/Types/TH/Binary.hs
new file mode 100644
index 000000000..e896e89e4
--- /dev/null
+++ b/src/Model/Types/TH/Binary.hs
@@ -0,0 +1,103 @@
+module Model.Types.TH.Binary where
+
+import ClassyPrelude.Yesod hiding (Proxy(..))
+import Database.Persist.Sql
+
+import qualified Data.ByteString.Lazy as LBS
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
+import qualified Language.Haskell.TH.Syntax as TH
+
+import Utils.Persist
+import Data.Proxy
+
+import Data.Binary (Binary)
+import qualified Data.Binary as Binary
+
+import Data.List (foldl)
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+
+import qualified Data.ByteString.Base64.URL as Base64
+
+import Control.Monad.Fail
+
+
+toPersistValueBinary :: Binary a => a -> PersistValue
+toPersistValueBinary = PersistByteString . LBS.toStrict . Binary.encode
+
+fromPersistValueBinary :: forall a. (Binary a, PersistFieldSql a, Typeable a) => PersistValue -> Either Text a
+fromPersistValueBinary = \case
+ PersistByteString bs
+ | Right (rest, _, v) <- Binary.decodeOrFail $ fromStrict bs
+ , null rest
+ -> Right v
+ x -> Left $ fromPersistValueErrorSql (Proxy @a) x
+
+sqlTypeBinary :: SqlType
+sqlTypeBinary = SqlBlob
+
+
+derivePersistFieldBinary :: Name -> DecsQ
+derivePersistFieldBinary tName = do
+ DatatypeInfo{..} <- reifyDatatype tName
+ vars <- forM datatypeVars (const $ newName "a")
+ let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
+ iCxt
+ | null vars = cxt []
+ | otherwise = cxt [[t|Binary|] `appT` t, [t|Typeable|] `appT` t]
+ sqlCxt
+ | null vars = cxt []
+ | otherwise = cxt [[t|PersistField|] `appT` t]
+ sequence
+ [ instanceD iCxt ([t|PersistField|] `appT` t)
+ [ funD 'toPersistValue
+ [ clause [] (normalB [e|toPersistValueBinary|]) []
+ ]
+ , funD 'fromPersistValue
+ [ clause [] (normalB [e|fromPersistValueBinary|]) []
+ ]
+ ]
+ , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
+ [ funD 'sqlType
+ [ clause [wildP] (normalB [e|sqlTypeBinary|]) []
+ ]
+ ]
+ ]
+
+
+toJSONBinary :: Binary a => a -> Aeson.Value
+toJSONBinary = Aeson.String . decodeUtf8 . Base64.encode . toStrict . Binary.encode
+
+parseJSONBinary :: Binary a => Name -> Aeson.Value -> Aeson.Parser a
+parseJSONBinary n = Aeson.withText (nameBase n) $ \t -> do
+ bytes <- either fail (return . fromStrict) . Base64.decode $ encodeUtf8 t
+ case Binary.decodeOrFail bytes of
+ Left (_, _, err) -> fail err
+ Right (bs, _, ret)
+ | null bs -> return ret
+ | otherwise -> fail $ show (length bs) ++ " extra bytes"
+
+
+deriveJSONBinary :: Name -> DecsQ
+deriveJSONBinary tName = do
+ DatatypeInfo{..} <- reifyDatatype tName
+ vars <- forM datatypeVars (const $ newName "a")
+ let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
+ iCxt
+ | null vars = cxt []
+ | otherwise = cxt [[t|Binary|] `appT` t, [t|Typeable|] `appT` t]
+ sequence
+ [ instanceD iCxt ([t|ToJSON|] `appT` t)
+ [ funD 'toJSON
+ [ clause [] (normalB [e|toJSONBinary|]) []
+ ]
+ ]
+ , instanceD iCxt ([t|FromJSON|] `appT` t)
+ [ funD 'parseJSON
+ [ clause [] (normalB [e|parseJSONBinary $(TH.lift tName)|]) []
+ ]
+ ]
+ ]
diff --git a/src/Settings.hs b/src/Settings.hs
index dbb414987..c9ab18286 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -222,6 +222,10 @@ data AppSettings = AppSettings
, appFileSourcePrewarmConf :: Maybe PrewarmCacheConf
, appBotMitigations :: Set SettingBotMitigation
+
+ , appVolatileClusterSettingsCacheTime :: DiffTime
+
+ , appJobMaxFlush :: Maybe Natural
} deriving Show
data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
@@ -402,6 +406,10 @@ nullaryPathPiece ''SettingBotMitigation $ camelToPathPiece' 3
pathPieceJSON ''SettingBotMitigation
pathPieceJSONKey ''SettingBotMitigation
+makePrisms ''JobMode
+makeLenses_ ''JobMode
+
+
instance FromJSON LdapConf where
parseJSON = withObject "LdapConf" $ \o -> do
ldapTls <- o .:? "tls"
@@ -562,7 +570,12 @@ instance FromJSON AppSettings where
appBearerExpiration <- o .:? "bearer-expiration"
appBearerEncoding <- o .: "bearer-encoding"
- appHealthCheckInterval <- (assertM' (> 0) . ) <$> o .: "health-check-interval"
+ appJobMode <- o .:? "job-mode" .!= JobsLocal True
+
+ let hciOverride :: HealthCheck -> Maybe NominalDiffTime -> Maybe NominalDiffTime
+ hciOverride HealthCheckDoesFlush _ | is _JobsOffload appJobMode = Nothing
+ hciOverride _ mInterval = mInterval
+ appHealthCheckInterval <- (\f hc -> hciOverride hc . assertM' (> 0) $ f hc) <$> o .: "health-check-interval"
appHealthCheckDelayNotify <- o .: "health-check-delay-notify"
appHealthCheckHTTP <- o .: "health-check-http"
@@ -660,8 +673,6 @@ instance FromJSON AppSettings where
appDownloadTokenExpire <- o .: "download-token-expire"
- appJobMode <- o .:? "job-mode" .!= JobsLocal True
-
appStudyFeaturesRecacheRelevanceWithin <- o .:? "study-features-recache-relevance-within"
appStudyFeaturesRecacheRelevanceInterval <- o .: "study-features-recache-relevance-interval"
@@ -678,6 +689,10 @@ instance FromJSON AppSettings where
appBotMitigations <- o .:? "bot-mitigations" .!= Set.empty
+ appVolatileClusterSettingsCacheTime <- o .: "volatile-cluster-settings-cache-time"
+
+ appJobMaxFlush <- o .:? "job-max-flush"
+
return AppSettings{..}
where isValidARCConf ARCConf{..} = arccMaximumWeight > 0
diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs
index faa409b08..6e3eb1e2a 100644
--- a/src/Settings/Cluster.hs
+++ b/src/Settings/Cluster.hs
@@ -40,6 +40,8 @@ import Model.Types.TH.PathPiece
import Data.ByteArray (ByteArray, ByteArrayAccess)
import qualified Crypto.Random as Crypto
+import Handler.Sheet.PersonalisedFiles.Types (PersonalisedSheetFilesSeedKey, newPersonalisedSheetFilesSeedKey)
+
data ClusterSettingsKey
= ClusterCryptoIDKey
@@ -50,6 +52,7 @@ data ClusterSettingsKey
| ClusterMemcachedKey
| ClusterVerpSecret
| ClusterAuthKey
+ | ClusterPersonalisedSheetFilesSeedKey
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
deriving anyclass (Universe, Finite, NFData)
@@ -160,3 +163,9 @@ instance ClusterSetting 'ClusterAuthKey where
type ClusterSettingValue 'ClusterAuthKey = Auth.Key
initClusterSetting _ = liftIO Auth.newKey
knownClusterSetting _ = ClusterAuthKey
+
+
+instance ClusterSetting 'ClusterPersonalisedSheetFilesSeedKey where
+ type ClusterSettingValue 'ClusterPersonalisedSheetFilesSeedKey = PersonalisedSheetFilesSeedKey
+ initClusterSetting _ = liftIO newPersonalisedSheetFilesSeedKey
+ knownClusterSetting _ = ClusterPersonalisedSheetFilesSeedKey
diff --git a/src/Settings/Cluster/Volatile.hs b/src/Settings/Cluster/Volatile.hs
new file mode 100644
index 000000000..8e357031d
--- /dev/null
+++ b/src/Settings/Cluster/Volatile.hs
@@ -0,0 +1,127 @@
+module Settings.Cluster.Volatile
+ ( VolatileClusterSettingsKey(..)
+ , clusterVolatileWorkflowsEnabled, clusterVolatileQuickActionsEnabled
+ , VolatileClusterSetting(..)
+ , VolatileClusterSettingsCache
+ , mkVolatileClusterSettingsCache
+ , alterVolatileClusterSettingsCacheF, insertVolatileClusterSettingsCache, lookupVolatileClusterSettingsCache
+ ) where
+
+import ClassyPrelude.Yesod hiding (Proxy)
+
+import Data.HashPSQ (HashPSQ)
+import qualified Data.HashPSQ as HashPSQ
+
+import Data.Universe
+import Utils.PathPiece
+import Model.Types.TH.PathPiece
+
+import Data.Kind (Type)
+import Data.Dynamic
+
+import System.Clock (TimeSpec)
+
+import Data.Functor.Const
+
+import Data.Proxy
+
+-- import Control.Lens
+
+
+data VolatileClusterSettingsKey
+ = ClusterVolatileWorkflowsEnabled
+ | ClusterVolatileQuickActionsEnabled
+ deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
+ deriving anyclass (Hashable, Universe, Finite, NFData)
+
+nullaryPathPiece ''VolatileClusterSettingsKey $ camelToPathPiece' 2
+pathPieceJSON ''VolatileClusterSettingsKey
+pathPieceJSONKey ''VolatileClusterSettingsKey
+pathPieceHttpApiData ''VolatileClusterSettingsKey
+derivePersistFieldPathPiece ''VolatileClusterSettingsKey
+
+clusterVolatileWorkflowsEnabled :: Proxy 'ClusterVolatileWorkflowsEnabled
+clusterVolatileWorkflowsEnabled = Proxy
+
+clusterVolatileQuickActionsEnabled :: Proxy 'ClusterVolatileQuickActionsEnabled
+clusterVolatileQuickActionsEnabled = Proxy
+
+
+class ( ToJSON (VolatileClusterSettingValue key)
+ , FromJSON (VolatileClusterSettingValue key)
+ , Typeable (VolatileClusterSettingValue key)
+ , NFData (VolatileClusterSettingValue key)
+ ) => VolatileClusterSetting (key :: VolatileClusterSettingsKey) where
+ type VolatileClusterSettingValue key :: Type
+ initVolatileClusterSetting :: forall m p. MonadIO m => p key -> m (VolatileClusterSettingValue key)
+ knownVolatileClusterSetting :: forall p. p key -> VolatileClusterSettingsKey
+
+instance VolatileClusterSetting 'ClusterVolatileWorkflowsEnabled where
+ type VolatileClusterSettingValue 'ClusterVolatileWorkflowsEnabled = Bool
+ initVolatileClusterSetting _ = return True
+ knownVolatileClusterSetting _ = ClusterVolatileWorkflowsEnabled
+
+instance VolatileClusterSetting 'ClusterVolatileQuickActionsEnabled where
+ type VolatileClusterSettingValue 'ClusterVolatileQuickActionsEnabled = Bool
+ initVolatileClusterSetting _ = return True
+ knownVolatileClusterSetting _ = ClusterVolatileQuickActionsEnabled
+
+
+data SomeVolatileClusterSettingsKey = forall key p. VolatileClusterSetting key => SomeVolatileClusterSettingsKey (p key)
+
+instance Eq SomeVolatileClusterSettingsKey where
+ (SomeVolatileClusterSettingsKey p1) == (SomeVolatileClusterSettingsKey p2) = knownVolatileClusterSetting p1 == knownVolatileClusterSetting p2
+instance Ord SomeVolatileClusterSettingsKey where
+ (SomeVolatileClusterSettingsKey p1) `compare` (SomeVolatileClusterSettingsKey p2) = knownVolatileClusterSetting p1 `compare` knownVolatileClusterSetting p2
+instance Hashable SomeVolatileClusterSettingsKey where
+ hashWithSalt s (SomeVolatileClusterSettingsKey p) = s `hashWithSalt` knownVolatileClusterSetting p
+
+data VolatileClusterSettingsCache = VolatileClusterSettingsCache
+ { volatileClusterSettingsCacheExpiry :: TimeSpec
+ , volatileClusterSettingsCacheCache :: HashPSQ SomeVolatileClusterSettingsKey TimeSpec Dynamic
+ }
+
+-- makePrisms ''VolatileClusterSettingsCache
+
+mkVolatileClusterSettingsCache :: TimeSpec -> VolatileClusterSettingsCache
+mkVolatileClusterSettingsCache volatileClusterSettingsCacheExpiry = VolatileClusterSettingsCache{..}
+ where volatileClusterSettingsCacheCache = HashPSQ.empty
+
+
+alterVolatileClusterSettingsCacheF :: forall key f p.
+ ( VolatileClusterSetting key
+ , Functor f
+ )
+ => p key
+ -> (Maybe (VolatileClusterSettingValue key) -> f (Maybe (VolatileClusterSettingValue key)))
+ -> VolatileClusterSettingsCache
+ -> TimeSpec -- ^ @now@
+ -> f VolatileClusterSettingsCache
+alterVolatileClusterSettingsCacheF p f c now
+ = f current <&> \new -> c { volatileClusterSettingsCacheCache = maybe (HashPSQ.delete k current') (\new' -> HashPSQ.insert k now (toDyn $!! new') current') new }
+ where
+ k = SomeVolatileClusterSettingsKey p
+
+ cutoff = now - volatileClusterSettingsCacheExpiry c
+
+ current' = volatileClusterSettingsCacheCache c
+ current = HashPSQ.lookup k current' >>= \(t, v) -> if
+ | t > cutoff -> fromDynamic v
+ | otherwise -> Nothing
+
+insertVolatileClusterSettingsCache :: forall key p.
+ VolatileClusterSetting key
+ => p key
+ -> Maybe (VolatileClusterSettingValue key)
+ -> VolatileClusterSettingsCache
+ -> TimeSpec
+ -> VolatileClusterSettingsCache
+insertVolatileClusterSettingsCache k newVal = (runIdentity .) . alterVolatileClusterSettingsCacheF k (const $ pure newVal)
+
+lookupVolatileClusterSettingsCache :: forall key p.
+ VolatileClusterSetting key
+ => p key
+ -> VolatileClusterSettingsCache
+ -> TimeSpec
+ -> Maybe (VolatileClusterSettingValue key)
+lookupVolatileClusterSettingsCache k = (getConst .) . alterVolatileClusterSettingsCacheF k Const
diff --git a/src/Settings/StaticFiles/Webpack.hs b/src/Settings/StaticFiles/Webpack.hs
index 999f959ab..3449d1a88 100644
--- a/src/Settings/StaticFiles/Webpack.hs
+++ b/src/Settings/StaticFiles/Webpack.hs
@@ -23,12 +23,13 @@ import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.Writer.Lazy (execWriterT)
import Control.Monad.Catch (MonadThrow(..))
-import Utils (nubOn)
-
import System.FilePath (makeRelative)
import Text.Shakespeare.Text (st)
+import Utils ()
+import Data.Containers.ListUtils
+
mkWebpackEntrypoints :: FilePath -- ^ Path to YAML-manifest
-> [FilePath -> Generator]
@@ -62,7 +63,7 @@ mkWebpackEntrypoints manifest mkGen stDir = do
sequence
[ sigD entryName [t|[(Route EmbeddedStatic, MimeType)]|]
, funD entryName
- [ clause [] (normalB . listE . map (\(n, mime) -> tupE [varE n, TH.lift mime]) $ nubOn fst entries) []
+ [ clause [] (normalB . listE . map (\(n, mime) -> tupE [varE n, TH.lift mime]) $ nubOrdOn fst entries) []
]
, sigD widgetName [t|forall m. (MonadLogger m, MonadWidget m) => (Route EmbeddedStatic -> Route (HandlerSite m)) -> m ()|]
, funD widgetName
diff --git a/src/Text/Blaze/Instances.hs b/src/Text/Blaze/Instances.hs
index 19c479aa9..6b4597576 100644
--- a/src/Text/Blaze/Instances.hs
+++ b/src/Text/Blaze/Instances.hs
@@ -15,6 +15,8 @@ import qualified Data.Aeson as Aeson
import qualified Data.Csv as Csv
+import Data.Binary (Binary(..))
+
instance Eq Markup where
(==) = (==) `on` Text.renderMarkup
@@ -45,3 +47,7 @@ instance Csv.FromField Markup where
instance NFData Markup where
rnf = rnf . Text.renderMarkup
+
+instance Binary Markup where
+ put = put . Text.renderMarkup
+ get = preEscapedText <$> get
diff --git a/src/Utils.hs b/src/Utils.hs
index caa059f5e..70cc0d4d0 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -1,6 +1,6 @@
module Utils
( module Utils
- , List.nub, List.nubBy
+ , module Data.Containers.ListUtils
) where
import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket)
@@ -50,7 +50,6 @@ import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
import qualified Data.Set as Set
import qualified Data.Map as Map
-import qualified Data.List as List
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Vector as V
@@ -149,6 +148,8 @@ import Data.Ratio ((%))
import Data.UUID (UUID)
import qualified Data.UUID as UUID
+import Data.Containers.ListUtils
+
{-# ANN module ("HLint: ignore Use asum" :: String) #-}
@@ -252,6 +253,12 @@ selectRep' cMap' needle = asum
(needleMain, needleSub) = contentTypeTypes needle
noSpaces = CBS.filter (/= ' ')
+
+addAttrsClass :: Text -> [(Text, Text)] -> [(Text, Text)]
+addAttrsClass cl attrs = ("class", cl') : noClAttrs
+ where
+ (clAttrs, noClAttrs) = partition (views _1 $ (== "class") . CI.mk) attrs
+ cl' = Text.intercalate " " . nubOrd . filter (not . null) $ cl : (views _2 (Text.splitOn " ") =<< clAttrs)
---------------------
-- Text and String --
@@ -538,9 +545,6 @@ partitionWith f (x:xs) = case f x of
nonEmpty' :: Alternative f => [a] -> f (NonEmpty a)
nonEmpty' = maybe empty pure . nonEmpty
-nubOn :: Eq b => (a -> b) -> [a] -> [a]
-nubOn = List.nubBy . ((==) `on`)
-
dropWhileM :: (IsSequence seq, Monad m) => (Element seq -> m Bool) -> seq -> m seq
dropWhileM p xs'
| Just (x, xs) <- uncons xs'
@@ -613,6 +617,9 @@ mapFromSetM = (sequenceA .) . Map.fromSet
mapFilterM :: (Monad m, Ord k) => (v -> m Bool) -> Map k v -> m (Map k v)
mapFilterM f m = ($ m) . runKleisli $ foldMap (Kleisli . Map.alterF (runMaybeT . assertMM (lift . f) . hoistMaybe)) (Map.keys m)
+_MapUnit :: Iso' (Map k ()) (Set k)
+_MapUnit = iso Map.keysSet $ Map.fromSet (const ())
+
---------------
-- Functions --
---------------
diff --git a/src/Utils/ARC.hs b/src/Utils/ARC.hs
index 1545ebf08..a5e2a8c76 100644
--- a/src/Utils/ARC.hs
+++ b/src/Utils/ARC.hs
@@ -146,23 +146,35 @@ arcAlterF !(force -> unhashedK@(hashed -> k)) f oldARC@ARC{..} now
| later <= initialARCTick = uncurry (arcAlterF unhashedK f) $ initARC arcMaximumGhost arcMaximumWeight
| otherwise = (, later) <$> if
| Just (_p, x@(_, w), arcFrequent') <- HashPSQ.deleteView k arcFrequent
- -> f (Just x) <&> \(fromMaybe x -> !(force -> x'@(_, w')))
- -> let (arcFrequent'', arcFrequentWeight'', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent' (arcFrequentWeight - w) arcGhostFrequent
- in oldARC
- { arcFrequent = HashPSQ.insert k now x' arcFrequent''
- , arcFrequentWeight = arcFrequentWeight'' + w'
- , arcGhostFrequent = arcGhostFrequent'
- }
+ -> f (Just x) <&> \case
+ Nothing -> oldARC
+ { arcFrequent = arcFrequent'
+ , arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent
+ , arcFrequentWeight = arcFrequentWeight - w
+ }
+ Just !(force -> x'@(_, w'))
+ -> let (arcFrequent'', arcFrequentWeight'', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent' (arcFrequentWeight - w) arcGhostFrequent
+ in oldARC
+ { arcFrequent = HashPSQ.insert k now x' arcFrequent''
+ , arcFrequentWeight = arcFrequentWeight'' + w'
+ , arcGhostFrequent = arcGhostFrequent'
+ }
| Just (_p, x@(_, w), arcRecent') <- HashPSQ.deleteView k arcRecent
- -> f (Just x) <&> \(fromMaybe x -> !(force -> x'@(_, w')))
- -> let (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent arcFrequentWeight arcGhostFrequent
- in oldARC
- { arcRecent = arcRecent'
- , arcRecentWeight = arcRecentWeight - w
- , arcFrequent = HashPSQ.insert k now x' arcFrequent'
- , arcFrequentWeight = arcFrequentWeight' + w'
- , arcGhostFrequent = arcGhostFrequent'
- }
+ -> f (Just x) <&> \case
+ Nothing -> oldARC
+ { arcRecent = arcRecent'
+ , arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent
+ , arcRecentWeight = arcRecentWeight - w
+ }
+ Just !(force -> x'@(_, w'))
+ -> let (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent arcFrequentWeight arcGhostFrequent
+ in oldARC
+ { arcRecent = arcRecent'
+ , arcRecentWeight = arcRecentWeight - w
+ , arcFrequent = HashPSQ.insert k now x' arcFrequent'
+ , arcFrequentWeight = arcFrequentWeight' + w'
+ , arcGhostFrequent = arcGhostFrequent'
+ }
| Just (_p, (), arcGhostRecent') <- HashPSQ.deleteView k arcGhostRecent
-> f Nothing <&> \case
Nothing -> oldARC
@@ -277,20 +289,25 @@ cachedARC' :: forall k w v m.
cachedARC' (ARCHandle arcVar) k f = do
oldVal <- lookupARC k <$> readIORef arcVar
newVal <- f oldVal
- modifyIORef' arcVar $ uncurry (insertARC k newVal)
+ atomicModifyIORef' arcVar $ (, ()) . uncurry (insertARC k newVal)
-- Using `modifyIORef'` instead of `atomicModifyIORef'` might very
-- well drop newer values computed during the update.
--
- -- Currently we accept that to reduce lock contention.
+ -- This was deemed unacceptable due to the risk of cache
+ -- invalidations being silently dropped
--
-- Another alternative would be to use "optimistic locking",
-- i.e. read the current value of `arcVar`, compute an updated
-- version, and write it back atomically iff the `ARCTick` hasn't
-- changed.
--
- -- This was not implemented to avoid the overhead and contention
- -- likely associated with the atomic transaction required for the
- -- "compare and swap"
+ -- This was not implemented in the hopes that atomicModifyIORef'
+ -- already offers sufficient performance.
+ --
+ -- If optimistic locking is implemented there is a risk of
+ -- performance issues due to the overhead and contention likely
+ -- associated with the atomic transaction required for the "compare
+ -- and swap"
return $ view _1 <$> newVal
cachedARC :: forall k w v m.
diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs
index 7070720b1..850ef9af1 100644
--- a/src/Utils/Csv.hs
+++ b/src/Utils/Csv.hs
@@ -10,6 +10,7 @@ module Utils.Csv
, toCsvRendered
, toDefaultOrderedCsvRendered
, csvRenderedToXlsx, Xlsx, Xlsx.fromXlsx
+ , CsvSemicolonList(..)
) where
import ClassyPrelude hiding (lookup)
@@ -39,6 +40,19 @@ import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.CaseInsensitive as CI
+import qualified Data.Binary.Builder as Builder
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Attoparsec.ByteString as Attoparsec
+
+import qualified Data.Csv.Parser as Csv
+import qualified Data.Csv.Builder as Csv
+
+import qualified Data.Vector as Vector
+
+import Data.Char (ord)
+
+import Control.Monad.Fail
+
deriving instance Typeable CsvParseError
instance Exception CsvParseError
@@ -114,3 +128,27 @@ csvRenderedToXlsx sheetName CsvRendered{..} = def & Xlsx.atSheet sheetName ?~ (d
addValues = flip foldMap (zip [2..] csvRenderedData) $ \(r, nr) -> flip foldMap (zip [1..] $ toList csvRenderedHeader) $ \(c, hBS) -> case HashMap.lookup hBS nr of
Nothing -> mempty
Just vBS -> Endo $ Xlsx.cellValueAtRC (r, c) ?~ Xlsx.CellText (decodeUtf8 vBS)
+
+
+newtype CsvSemicolonList a = CsvSemicolonList { unCsvSemicolonList :: [a] }
+ deriving stock (Read, Show, Generic, Typeable)
+ deriving newtype (Eq, Ord)
+
+instance ToField a => ToField (CsvSemicolonList a) where
+ toField (CsvSemicolonList xs) = dropEnd 2 . LBS.toStrict . Builder.toLazyByteString $ Csv.encodeRecordWith encOpts fs
+ where
+ fs = map toField xs
+ encOpts = defaultEncodeOptions
+ { encDelimiter = fromIntegral $ ord ';'
+ , encQuoting = case fs of
+ [fStr] | null fStr -> QuoteAll
+ _other -> QuoteMinimal
+ , encUseCrLf = True
+ }
+
+instance FromField a => FromField (CsvSemicolonList a) where
+ parseField f
+ | null f = pure $ CsvSemicolonList []
+ | otherwise = fmap CsvSemicolonList . mapM parseField . Vector.toList <=< either fail return $ Attoparsec.parseOnly (Csv.record sep) f
+ where
+ sep = fromIntegral $ ord ';'
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 0a1e4d89c..e1083bcc0 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -1250,12 +1250,15 @@ warnValidation msg isValid = unless isValid $ addMessageI Warning msg
-- Form Manipulation --
-----------------------
-aFormToWForm :: Monad m => AForm m a -> WForm m (FormResult a)
-aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
- where
- mFormToWForm' f = do
- ((a, vs), ints, enctype) <- lift f
- writer ((a, ints, enctype), vs)
+aFormToWForm :: (MonadHandler m, HandlerSite m ~ site) => AForm m a -> WForm m (FormResult a)
+aFormToWForm = mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
+
+mFormToWForm' :: (MonadHandler m, HandlerSite m ~ site)
+ => MForm m (a, [FieldView site])
+ -> WForm m a
+mFormToWForm' = mapRWST $ \f -> do
+ ((a, vs), ints, enctype) <- lift f
+ writer ((a, ints, enctype), vs)
infixl 4 `fmapAForm`
@@ -1280,6 +1283,18 @@ aSetTooltip tip = wFormToAForm . wSetTooltip tip . aFormToWForm
data ValueRequired site = forall msg. RenderMessage site msg => ValueRequired msg
+formResultUnOpt :: forall a site msg.
+ ( RenderMessage site msg
+ , RenderMessage site (ValueRequired site)
+ )
+ => MsgRendererS site -> msg -> FormResult (Maybe a) -> FormResult a
+formResultUnOpt (MsgRenderer mr) label = \case
+ FormFailure errs -> FormFailure errs
+ FormMissing -> FormMissing
+ FormSuccess Nothing -> FormFailure . pure $ mr (ValueRequired label :: ValueRequired site)
+ FormSuccess (Just x) -> FormSuccess x
+
+
mreq :: forall m a.
( MonadHandler m
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs
index d7cff02d5..d220f9f7f 100644
--- a/src/Utils/Icon.hs
+++ b/src/Utils/Icon.hs
@@ -99,6 +99,7 @@ data Icon
| IconVideo
| IconSubmissionUserDuplicate
| IconNoAllocationUser
+ | IconSubmissionNoUsers
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
deriving anyclass (Universe, Finite, NFData)
@@ -181,6 +182,7 @@ iconText = \case
IconVideo -> "video"
IconSubmissionUserDuplicate -> "copy"
IconNoAllocationUser -> "user-slash"
+ IconSubmissionNoUsers -> "user-slash"
nullaryPathPiece ''Icon $ camelToPathPiece' 1
deriveLift ''Icon
diff --git a/src/Utils/Lang.hs b/src/Utils/Lang.hs
index 4a5f948f6..ad83921c1 100644
--- a/src/Utils/Lang.hs
+++ b/src/Utils/Lang.hs
@@ -23,6 +23,8 @@ import Control.Monad.Reader.Class (local)
import qualified Data.HashMap.Strict as HashMap
+import Data.Containers.ListUtils
+
selectLanguage :: MonadHandler m
=> NonEmpty Lang -- ^ Available translations, first is default
@@ -39,7 +41,7 @@ selectLanguages (defL :| _) [] = defL :| []
selectLanguages avL (l:ls)
| not $ null l
, Just lParts <- nonEmpty $ matchesFor l
- , found <- List.nub
+ , found <- nubOrd
[ l'' | lParts' <- NonEmpty.toList lParts
, l' <- NonEmpty.toList avL
, l'' <- matchesFor l'
@@ -69,7 +71,7 @@ lowPrioRequestedLangs = maybe [] (mapMaybe (either (const Nothing) Just . Text.d
languagesMiddleware :: forall site a. NonEmpty Lang -> HandlerFor site a -> HandlerFor site a
languagesMiddleware avL act = do
- pLangs <- fmap List.nub $ (<>) <$> highPrioRequestedLangs <*> lowPrioRequestedLangs
+ pLangs <- fmap nubOrd $ (<>) <$> highPrioRequestedLangs <*> lowPrioRequestedLangs
let langs = toList $ selectLanguages avL pLangs
setLangs hData = hData{ handlerRequest = (handlerRequest hData){ reqLangs = langs } }
local setLangs $ ($logDebugS "languages" . tshow . (pLangs,langs,) =<< languages) *> act
diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs
index e48ac5dd5..59f8266fa 100644
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@@ -5,7 +5,6 @@
module Utils.Lens ( module Utils.Lens ) where
import Import.NoModel
-import Settings
import Model
import Model.Rating
import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..))
@@ -176,6 +175,7 @@ makeLenses_ ''StudyTermNameCandidate
makeLenses_ ''StudySubTermParentCandidate
makeLenses_ ''StudyTermStandaloneCandidate
+makeLenses_ ''Field
makeLenses_ ''FieldView
makeLenses_ ''FieldSettings
@@ -276,11 +276,14 @@ makePrisms ''AllocationPriority
makePrisms ''RoomReference
makeLenses_ ''RoomReference
-makePrisms ''JobMode
-makeLenses_ ''JobMode
-
-- makeClassy_ ''Load
+makePrisms ''SchoolAuthorshipStatementMode
+makePrisms ''SheetAuthorshipStatementMode
+
+makeLenses_ ''AuthorshipStatementSubmission
+makeLenses_ ''AuthorshipStatementDefinition
+
--------------------------
-- Fields for `UniWorX` --
--------------------------
diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs
index e1aaa3a9b..3a46b2cff 100644
--- a/src/Utils/PathPiece.hs
+++ b/src/Utils/PathPiece.hs
@@ -29,7 +29,7 @@ import qualified Data.HashMap.Strict as HashMap
import Numeric.Natural
-import Data.List (nub, foldl)
+import Data.List (foldl)
import Data.Aeson.Types
import qualified Data.Aeson.Types as Aeson
@@ -47,6 +47,8 @@ import Web.HttpApiData
import Data.ByteString.Lazy.Base32
import qualified Data.CaseInsensitive as CI
+import Data.Containers.ListUtils
+
mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp)
mkFiniteFromPathPiece finiteType = do
@@ -178,7 +180,7 @@ derivePathPiece adt mangle joinPP = do
usesVar ConstructorInfo{..} n
| n `elem` map tvarName constructorVars = False
| otherwise = any (elemOf types n) constructorFields
- fieldTypes = nub $ concatMap constructorFields datatypeCons
+ fieldTypes = nubOrd $ concatMap constructorFields datatypeCons
tvarName (PlainTV n) = n
tvarName (KindedTV n _) = n
sequence . (finDecs ++ ) . pure $
diff --git a/src/Utils/VolatileClusterSettings.hs b/src/Utils/VolatileClusterSettings.hs
new file mode 100644
index 000000000..7791133b9
--- /dev/null
+++ b/src/Utils/VolatileClusterSettings.hs
@@ -0,0 +1,72 @@
+module Utils.VolatileClusterSettings
+ ( getVolatileClusterSetting
+ , VolatileClusterSettingException(..)
+ , whenVolatile, volatileBool, guardVolatile
+ ) where
+
+import Import.NoModel
+import Model
+import Foundation.Type
+import Foundation.DB
+
+import System.Clock
+
+import qualified Data.Aeson.Types as Aeson
+
+
+data VolatileClusterSettingException = VolatileClusterSettingExceptionNoParse
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ deriving anyclass (Exception)
+
+
+getVolatileClusterSetting :: forall key m p.
+ ( VolatileClusterSetting key
+ , MonadHandler m, HandlerSite m ~ UniWorX
+ )
+ => p key
+ -> m (VolatileClusterSettingValue key)
+getVolatileClusterSetting p = exceptT return return $ do
+ cacheTVar <- getsYesod appVolatileClusterSettingsCache
+ now <- liftIO $ getTime Monotonic
+ oldVal <- flip (lookupVolatileClusterSettingsCache p) now <$> readTVarIO cacheTVar
+ traverse_ throwE oldVal
+ dbVal <- liftHandler . runDBInternal $ do
+ dbVal <- fmap (fmap volatileClusterConfigValue) . get . VolatileClusterConfigKey $ knownVolatileClusterSetting p
+ case dbVal of
+ Just v -> maybe (throwM VolatileClusterSettingExceptionNoParse) return $ Aeson.parseMaybe parseJSON v
+ Nothing -> do
+ newVal <- initVolatileClusterSetting p
+ insert_ $ VolatileClusterConfig (knownVolatileClusterSetting p) (toJSON newVal)
+ return newVal
+ atomically . modifyTVar' cacheTVar $ \c -> insertVolatileClusterSettingsCache p (Just dbVal) c now
+ return dbVal
+
+volatileBool :: forall key m a p.
+ ( VolatileClusterSetting key, VolatileClusterSettingValue key ~ Bool
+ , MonadHandler m, HandlerSite m ~ UniWorX
+ )
+ => p key
+ -> m a
+ -> m a
+ -> m a
+volatileBool p ifFalse ifTrue = do
+ r <- getVolatileClusterSetting p
+ bool ifFalse ifTrue r
+
+whenVolatile :: forall key m p.
+ ( VolatileClusterSetting key, VolatileClusterSettingValue key ~ Bool
+ , MonadHandler m, HandlerSite m ~ UniWorX
+ )
+ => p key
+ -> m ()
+ -> m ()
+whenVolatile p = volatileBool p (return ())
+
+guardVolatile :: forall key m p.
+ ( VolatileClusterSetting key, VolatileClusterSettingValue key ~ Bool
+ , MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadPlus m
+ )
+ => p key
+ -> m ()
+guardVolatile p = volatileBool p mzero (return ())
diff --git a/stack.yaml b/stack.yaml
index dd314a232..3dd0e2dab 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -83,6 +83,9 @@ extra-deps:
- git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptonite.git
commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
+ - git: git@gitlab2.rz.ifi.lmu.de:uni2work/esqueleto.git
+ commit: b9987d94af9d7403eded8ca75ad761eb7fc06e4c
+
- classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
- acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
# - commonmark-0.1.1.2@sha256:c06ab05f0f224ab7982502a96e17952823a9b6dae8505fb35194b0baa9e2a975,3278
diff --git a/stack.yaml.lock b/stack.yaml.lock
index ab8c4dbba..531c27d3f 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -426,6 +426,17 @@ packages:
original:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptonite.git
commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f
+- completed:
+ name: esqueleto
+ version: 3.5.2.0
+ git: git@gitlab2.rz.ifi.lmu.de:uni2work/esqueleto.git
+ pantry-tree:
+ size: 5630
+ sha256: b949af2533893ffd16407825d22c0a524ffa48cdd0eab91644cbe0dc4b2c8319
+ commit: b9987d94af9d7403eded8ca75ad761eb7fc06e4c
+ original:
+ git: git@gitlab2.rz.ifi.lmu.de:uni2work/esqueleto.git
+ commit: b9987d94af9d7403eded8ca75ad761eb7fc06e4c
- completed:
hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330
pantry-tree:
diff --git a/start.sh b/start.sh
index 7f9765589..82015828e 100755
--- a/start.sh
+++ b/start.sh
@@ -20,13 +20,13 @@ export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))}
unset HOST
move-back() {
- mv -v .stack-work .stack-work-run
- [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
+ mv -vT .stack-work .stack-work-run
+ [[ -d .stack-work-build ]] && mv -vT .stack-work-build .stack-work
}
if [[ -d .stack-work-run ]]; then
- [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
- mv -v .stack-work-run .stack-work
+ [[ -d .stack-work ]] && mv -vT .stack-work .stack-work-build
+ mv -vT .stack-work-run .stack-work
trap move-back EXIT
fi
diff --git a/templates/i18n/authorship-statement-submission-explanation/exists.de-de-formal.hamlet b/templates/i18n/authorship-statement-submission-explanation/exists.de-de-formal.hamlet
new file mode 100644
index 000000000..897ec7ade
--- /dev/null
+++ b/templates/i18n/authorship-statement-submission-explanation/exists.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Eigenständigkeitserklärung ist vorhanden und entspricht dem aktuell geforderten Wortlaut.
diff --git a/templates/i18n/authorship-statement-submission-explanation/exists.en-eu.hamlet b/templates/i18n/authorship-statement-submission-explanation/exists.en-eu.hamlet
new file mode 100644
index 000000000..8bd4c7b4b
--- /dev/null
+++ b/templates/i18n/authorship-statement-submission-explanation/exists.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Statement of Authorship exists and matches the wording as currently required.
diff --git a/templates/i18n/authorship-statement-submission-explanation/missing.de-de-formal.hamlet b/templates/i18n/authorship-statement-submission-explanation/missing.de-de-formal.hamlet
new file mode 100644
index 000000000..ad2d01c9d
--- /dev/null
+++ b/templates/i18n/authorship-statement-submission-explanation/missing.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Keine Eigenständigkeitserklärung vorhanden.
diff --git a/templates/i18n/authorship-statement-submission-explanation/missing.en-eu.hamlet b/templates/i18n/authorship-statement-submission-explanation/missing.en-eu.hamlet
new file mode 100644
index 000000000..fb12c3633
--- /dev/null
+++ b/templates/i18n/authorship-statement-submission-explanation/missing.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+No Statement of Authorship exists.
diff --git a/templates/i18n/authorship-statement-submission-explanation/old-statement.de-de-formal.hamlet b/templates/i18n/authorship-statement-submission-explanation/old-statement.de-de-formal.hamlet
new file mode 100644
index 000000000..c3215f2dc
--- /dev/null
+++ b/templates/i18n/authorship-statement-submission-explanation/old-statement.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Eigenständigkeitserklärung ist zwar vorhanden, entspricht aber nicht dem aktuell geforderten Wortlaut.
diff --git a/templates/i18n/authorship-statement-submission-explanation/old-statement.en-eu.hamlet b/templates/i18n/authorship-statement-submission-explanation/old-statement.en-eu.hamlet
new file mode 100644
index 000000000..09ca727fe
--- /dev/null
+++ b/templates/i18n/authorship-statement-submission-explanation/old-statement.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Statement of Authorship exists but does not match the wording as currently required.
diff --git a/templates/i18n/changelog/authorship-statements.de-de-formal.hamlet b/templates/i18n/changelog/authorship-statements.de-de-formal.hamlet
new file mode 100644
index 000000000..679e4a027
--- /dev/null
+++ b/templates/i18n/changelog/authorship-statements.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Es kann die Abgabe einer Eigenständigkeitserklärung bei Anlegen einer Übungsblattabgabe gefordert werden.
diff --git a/templates/i18n/changelog/authorship-statements.en-eu.hamlet b/templates/i18n/changelog/authorship-statements.en-eu.hamlet
new file mode 100644
index 000000000..2172a5abc
--- /dev/null
+++ b/templates/i18n/changelog/authorship-statements.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Submittors can be required to make a Statement of Authorship when creating their submission for an exercise sheet.
diff --git a/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet b/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet
new file mode 100644
index 000000000..8a44b1939
--- /dev/null
+++ b/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Tabellen von Übungsblattabgaben können nun als CSV exportiert werden
diff --git a/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet b/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet
new file mode 100644
index 000000000..70a14aa63
--- /dev/null
+++ b/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Tables of exercise sheet submissions can now be exported as CSV
diff --git a/templates/i18n/changelog/personalised-sheet-files-seeds.de-de-formal.hamlet b/templates/i18n/changelog/personalised-sheet-files-seeds.de-de-formal.hamlet
new file mode 100644
index 000000000..d76ba6826
--- /dev/null
+++ b/templates/i18n/changelog/personalised-sheet-files-seeds.de-de-formal.hamlet
@@ -0,0 +1,3 @@
+$newline never
+
+Die Metainformationsdateien, die zum Anlegen von personalisierten Übungsblattdateien erzeugt werden, enthalten nun einen Seed für Pseudozufallsgeneratoren.
diff --git a/templates/i18n/changelog/personalised-sheet-files-seeds.en-eu.hamlet b/templates/i18n/changelog/personalised-sheet-files-seeds.en-eu.hamlet
new file mode 100644
index 000000000..eea3bacdf
--- /dev/null
+++ b/templates/i18n/changelog/personalised-sheet-files-seeds.en-eu.hamlet
@@ -0,0 +1,3 @@
+$newline never
+
+Metadata files created when adding personalised files to exercise sheets now contain a seed for pseudorandom generators.
diff --git a/templates/i18n/sheet-authorship-statement-mode-tip/disabled/de-de-formal.hamlet b/templates/i18n/sheet-authorship-statement-mode-tip/disabled/de-de-formal.hamlet
new file mode 100644
index 000000000..6b7cea00e
--- /dev/null
+++ b/templates/i18n/sheet-authorship-statement-mode-tip/disabled/de-de-formal.hamlet
@@ -0,0 +1,7 @@
+$newline never
+Es werden keine Eigenständigkeitserklärungen gefordert.
+
+$if is _SchoolAuthorshipStatementModeRequired schoolSheetExamAuthorshipStatementMode
+
+
+ Wegen Regeln des Instituts, unter dem der Kurs angelegt wurde, wird trotz dieser Einstellung eine Eigenständigkeitserklärung gefordert, wenn das Übungsblatt Prüfungsbezug hat.
diff --git a/templates/i18n/sheet-authorship-statement-mode-tip/disabled/en-eu.hamlet b/templates/i18n/sheet-authorship-statement-mode-tip/disabled/en-eu.hamlet
new file mode 100644
index 000000000..c8f61b475
--- /dev/null
+++ b/templates/i18n/sheet-authorship-statement-mode-tip/disabled/en-eu.hamlet
@@ -0,0 +1,7 @@
+$newline never
+No Statements of Authorship will be required.
+
+$if is _SchoolAuthorshipStatementModeRequired schoolSheetExamAuthorshipStatementMode
+
+
+ Due to rules of the school this course is associated with, Statements of Authorship will be required anyways if this exercise sheet is associated with an exam.
diff --git a/templates/i18n/sheet-authorship-statement-mode-tip/enabled/de-de-formal.hamlet b/templates/i18n/sheet-authorship-statement-mode-tip/enabled/de-de-formal.hamlet
new file mode 100644
index 000000000..c1e1be89f
--- /dev/null
+++ b/templates/i18n/sheet-authorship-statement-mode-tip/enabled/de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Alle Abgebende müssen jeweils eine Eigenständigkeitserklärung abgeben.
diff --git a/templates/i18n/sheet-authorship-statement-mode-tip/enabled/en-eu.hamlet b/templates/i18n/sheet-authorship-statement-mode-tip/enabled/en-eu.hamlet
new file mode 100644
index 000000000..503eb4161
--- /dev/null
+++ b/templates/i18n/sheet-authorship-statement-mode-tip/enabled/en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+All submittors are required to make a Statement of Authorship.
diff --git a/templates/i18n/sheet-authorship-statement-mode-tip/exam/de-de-formal.hamlet b/templates/i18n/sheet-authorship-statement-mode-tip/exam/de-de-formal.hamlet
new file mode 100644
index 000000000..a2b443d8b
--- /dev/null
+++ b/templates/i18n/sheet-authorship-statement-mode-tip/exam/de-de-formal.hamlet
@@ -0,0 +1,14 @@
+$newline never
+Falls das Übungsblatt Prüfungsbezug hat, greifen die Einstellungen der jeweiligen Prüfung.
+
+
+
+Ein Übungsblatt steht im Bezug zu einer Prüfung, falls eine der folgenden Bedingungen erfüllt ist:
+
+
+ -
+ Es wird unter „_{MsgSheetAuthorshipStatementExam}“ manuell eine Prüfung eingestellt
+
-
+ Das Übungsblatt wird „_{MsgSheetTypeExamPartPoints}“ gewertet
+
-
+ Die Anmeldung zur Prüfung wird vorausgesetzt um für das Übungsblatt abgeben zu dürfen („_{MsgSheetRequireExam}“)
diff --git a/templates/i18n/sheet-authorship-statement-mode-tip/exam/en-eu.hamlet b/templates/i18n/sheet-authorship-statement-mode-tip/exam/en-eu.hamlet
new file mode 100644
index 000000000..72564a3bc
--- /dev/null
+++ b/templates/i18n/sheet-authorship-statement-mode-tip/exam/en-eu.hamlet
@@ -0,0 +1,14 @@
+$newline never
+If the exercise sheet is associated with an exam, the settings of the exam are applied.
+
+
+
+An exercise sheet is associated with an exam if one of the following is true:
+
+
+ -
+ An exam was manually configured under “_{MsgSheetAuthorshipStatementExam}”
+
-
+ The exercise sheet is valued “_{MsgSheetTypeExamPartPoints}”
+
-
+ Registration for an exam is required to submit for the exercise sheet (“_{MsgSheetRequireExam}”)
diff --git a/templates/i18n/workflows-disabled/de-de-formal.hamlet b/templates/i18n/workflows-disabled/de-de-formal.hamlet
new file mode 100644
index 000000000..86f8f1712
--- /dev/null
+++ b/templates/i18n/workflows-disabled/de-de-formal.hamlet
@@ -0,0 +1,9 @@
+$newline never
+
+ Workflows sind temporär deaktiviert
+
+ Uni2work-Administrator:innen deaktivieren das Workflowsystem gelegentlich manuell um die Last auf das System zu reduzieren.
+
+
+
+ So kann die Performance und Stabilität des Systems in Zeiten erwarteter hoher Last verbessert werden um z.B. Online-Prüfungen reibungsloser ablaufen zu lassen.
diff --git a/templates/i18n/workflows-disabled/en-eu.hamlet b/templates/i18n/workflows-disabled/en-eu.hamlet
new file mode 100644
index 000000000..2d14cfc87
--- /dev/null
+++ b/templates/i18n/workflows-disabled/en-eu.hamlet
@@ -0,0 +1,9 @@
+$newline never
+
+ Workflows are temporarily disabled
+
+ Uni2work-administrators deactivate the workflow system manually on occasion to reduce load on the system.
+
+
+
+ This is done to improve performance and stability of the system when high load is expected to improve the experience during e.g. online exams.
diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet
index 4f18e2ab9..d2b555d9b 100644
--- a/templates/sheetShow.hamlet
+++ b/templates/sheetShow.hamlet
@@ -70,6 +70,16 @@ $maybe descr <- sheetDescription sheet
_{MsgTableSheetType}
-
^{sTypeDesc tr}
+$# $if mayEdit || maySubmit
+$#
-
+$# _{MsgSheetAuthorshipStatementSection}
+$#
-
+$# _{maybe MsgSheetAuthorshipStatementIsRequiredFalse (const MsgSheetAuthorshipStatementIsRequiredTrue) (sheetAuthorshipStatement sheet)}
+ $if authorshipStatementRequired
+
-
+ _{MsgSheetShowAuthorshipStatementsRequired}
+
-
+ _{MsgSheetShowAuthorshipStatementsRequiredYes}
$maybe marktxt <- markingText
diff --git a/templates/submission.hamlet b/templates/submission.hamlet
index a6661c4b5..465efab00 100644
--- a/templates/submission.hamlet
+++ b/templates/submission.hamlet
@@ -1,5 +1,5 @@
$newline never
-$if is _Just mcid
+$maybe subCId <- mcid
$maybe wdgt <- correctionWdgt
_{MsgTableRating}
@@ -9,8 +9,68 @@ $if is _Just mcid
^{wdgt}
- ^{maybeVoid multipleSubmissionWarnWidget}
-
+ $if subUsersVisible
+
+
+ _{MsgSubmissionUserTable}
+
+ ^{maybeVoid multipleSubmissionWarnWidget}
+
+ $if not (null subUsers)
+
+
+
+
+
+
+ _{MsgSubmissionUserDisplayName}
+ $if isLecturer
+
+
+ _{MsgSubmissionUserMatriculation}
+
+
+ _{MsgSubmissionUserEmail}
+ $if doAuthorshipStatements
+
+
+ ^{simpleLinkI MsgSubmissionUserAuthorshipStatementState (CSubmissionR tid ssh csh shn subCId SubAuthorshipStatementsR)}
+ ^{iconTooltip asStatusExplainWdgt Nothing True}
+
+ $forall subUser <- subUsers
+ $case subUser
+ $of Left email
+
+
+ $if isLecturer
+
+
+
+
+ #{email}
+ $if isLecturer && doAuthorshipStatements
+
+ $of Right (uCId, User{userDisplayName, userSurname, userEmail, userMatrikelnummer}, stmt)
+
+
+
+ ^{simpleLink (nameWidget userDisplayName userSurname) (CourseR tid ssh csh (CUserR uCId))}
+ $if isLecturer
+
+
+ $maybe matriculation <- userMatrikelnummer
+ #{matriculation}
+
+
+
+ #{userEmail}
+ $if doAuthorshipStatements
+
+
+ _{stmt}
+ $else
+ ^{notification NotificationBroad =<< messageIconI Error IconSubmissionNoUsers MsgSubmissionNoUsers}
+
$case sheetSubmissionMode
$of SubmissionMode False Nothing
@@ -50,5 +110,5 @@ $if is _Just mcid
_{MsgSubmissionReplace}
^{formWidget}
-$else
+$nothing
^{formWidget}
diff --git a/templates/widgets/authorship-statement-accept.hamlet b/templates/widgets/authorship-statement-accept.hamlet
new file mode 100644
index 000000000..f5c894bca
--- /dev/null
+++ b/templates/widgets/authorship-statement-accept.hamlet
@@ -0,0 +1,11 @@
+$newline never
+
+
+ ^{authorshipStatementWidget asd}
+
+