#{err}
$of FormSuccess res
-
+
#{tshow res}
|]
diff --git a/src/Handler/Admin/Test/Download.hs b/src/Handler/Admin/Test/Download.hs
index dc02ae8e0..9bf85419d 100644
--- a/src/Handler/Admin/Test/Download.hs
+++ b/src/Handler/Admin/Test/Download.hs
@@ -80,12 +80,12 @@ testDownload = do
sourceDBChunks :: ConduitT () Int DB ()
sourceDBChunks = forever sourceDBFiles
.| C.mapM (\x -> x <$ $logDebugS "testDownload.sourceDBChunks" (tshow $ entityKey x))
- .| C.map ((length $!!) . fileContentContent . entityVal)
+ .| C.map ((length $!!) . fileContentChunkContent . entityVal)
.| takeLimit dlMaxSize
where
- sourceDBFiles = E.selectSource . E.from $ \fileContent -> do
+ sourceDBFiles = E.selectSource . E.from $ \fileContentChunk -> do
E.orderBy [E.asc $ E.random_ @Int64]
- return fileContent
+ return fileContentChunk
takeLimit n | n <= 0 = return ()
takeLimit n = do
diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs
index 7f0a6154e..f48db411e 100644
--- a/src/Handler/Allocation/Application.hs
+++ b/src/Handler/Allocation/Application.hs
@@ -44,7 +44,6 @@ data ApplicationFormView = ApplicationFormView
data ApplicationForm = ApplicationForm
{ afPriority :: Maybe Natural
- , afField :: Maybe StudyFeaturesId
, afText :: Maybe Text
, afFiles :: Maybe FileUploads
, afRatingVeto :: Bool
@@ -118,12 +117,6 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
(False, _ , _ , _ )
-> pure (FormSuccess Nothing, Nothing)
- (fieldRes, fieldView') <- if
- | afmApplicantEdit || afmLecturer
- -> mreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (courseApplicationField . entityVal <$> mApp)
- | otherwise
- -> mforced (studyFeaturesFieldFor Nothing True (maybeToList $ mApp >>= courseApplicationField . entityVal) $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) (mApp >>= courseApplicationField . entityVal)
-
let textField' = convertField (Text.strip . unTextarea) Textarea textareaField
textFs
| is _Just courseApplicationsInstructions
@@ -216,7 +209,6 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
return ( ApplicationForm
<$> prioRes
- <*> fieldRes
<*> textRes
<*> filesRes
<*> vetoRes
@@ -226,8 +218,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
, ApplicationFormView
{ afvPriority = prioView
, afvForm = catMaybes $
- [ Just fieldView'
- , textView
+ [ textView
, filesLinkView
, filesWarningView
] ++ maybe [] (map Just) filesView ++
@@ -274,7 +265,6 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
appId <- insert CourseApplication
{ courseApplicationCourse = cid
, courseApplicationUser = uid
- , courseApplicationField = afField
, courseApplicationText = afText
, courseApplicationRatingVeto = afRatingVeto
, courseApplicationRatingPoints = afRatingPoints
@@ -303,8 +293,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
oldApp <- get404 appId
let newApp = oldApp
- { courseApplicationField = afField
- , courseApplicationText = afText
+ { courseApplicationText = afText
, courseApplicationRatingVeto = afRatingVeto
, courseApplicationRatingPoints = afRatingPoints
, courseApplicationRatingComment = afRatingComment
@@ -323,8 +312,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
]
appChanged = any (\f -> f oldApp newApp)
- [ (/=) `on` courseApplicationField
- , (/=) `on` courseApplicationText
+ [ (/=) `on` courseApplicationText
, \_ _ -> not $ Set.null changes
]
diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs
index b2b7200b4..57ed2f2db 100644
--- a/src/Handler/Course/Application/List.hs
+++ b/src/Handler/Course/Application/List.hs
@@ -25,6 +25,7 @@ import qualified Data.Map as Map
import qualified Data.Conduit.List as C
import Handler.Course.ParticipantInvite
+import Handler.Utils.StudyFeatures
import Jobs.Queue
@@ -33,53 +34,38 @@ type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplic
`E.InnerJoin` E.SqlExpr (Entity User)
)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation))
- `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
- `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
- `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
- )
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
, Entity User
, Bool -- hasFiles
, Maybe (Entity Allocation)
- , Maybe (Entity StudyFeatures)
- , Maybe (Entity StudyTerms)
- , Maybe (Entity StudyDegree)
, Bool -- isParticipant
+ , UserTableStudyFeatures
)
courseApplicationsIdent :: Text
courseApplicationsIdent = "applications"
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
-queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
+queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
-queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
+queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
-queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
+queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
where
hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
-queryAllocation = to $(sqlLOJproj 4 2)
-
-queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
-queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 4 3)
-
-queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
-queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 4 3)
-
-queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
-queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 4 3)
+queryAllocation = to $(sqlLOJproj 3 2)
queryCourseParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant)))
-queryCourseParticipant = to $(sqlLOJproj 4 4)
+queryCourseParticipant = to $(sqlLOJproj 3 3)
queryIsParticipant :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
-queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 4 4)
+queryIsParticipant = to $ E.not_ . E.isNothing . (E.?. CourseParticipantId) . $(sqlLOJproj 3 3)
resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
resultCourseApplication = _dbrOutput . _1
@@ -93,17 +79,11 @@ resultHasFiles = _dbrOutput . _3
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
resultAllocation = _dbrOutput . _4 . _Just
-resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures)
-resultStudyFeatures = _dbrOutput . _5 . _Just
-
-resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms)
-resultStudyTerms = _dbrOutput . _6 . _Just
-
-resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
-resultStudyDegree = _dbrOutput . _7 . _Just
-
resultIsParticipant :: Lens' CourseApplicationsTableData Bool
-resultIsParticipant = _dbrOutput . _8
+resultIsParticipant = _dbrOutput . _5
+
+resultStudyFeatures :: Lens' CourseApplicationsTableData UserTableStudyFeatures
+resultStudyFeatures = _dbrOutput . _6
newtype CourseApplicationsTableVeto = CourseApplicationsTableVeto Bool
@@ -127,9 +107,7 @@ data CourseApplicationsTableCsv = CourseApplicationsTableCsv
, csvCAName :: Maybe Text
, csvCAEmail :: Maybe UserEmail
, csvCAMatriculation :: Maybe Text
- , csvCAField :: Maybe Text
- , csvCADegree :: Maybe Text
- , csvCASemester :: Maybe Int
+ , csvCAStudyFeatures :: UserTableStudyFeatures
, csvCAText :: Maybe Text
, csvCAHasFiles :: Maybe Bool
, csvCAVeto :: Maybe CourseApplicationsTableVeto
@@ -152,9 +130,7 @@ instance Csv.FromNamedRecord CourseApplicationsTableCsv where
<*> csv .:?? "name"
<*> csv .:?? "email"
<*> csv .:?? "matriculation"
- <*> csv .:?? "field"
- <*> csv .:?? "degree"
- <*> csv .:?? "semester"
+ <*> pure mempty
<*> csv .:?? "text"
<*> csv .:?? "has-files"
<*> csv .:?? "veto"
@@ -171,9 +147,7 @@ instance CsvColumnsExplained CourseApplicationsTableCsv where
, ('csvCAName , MsgCsvColumnApplicationsName )
, ('csvCAEmail , MsgCsvColumnApplicationsEmail )
, ('csvCAMatriculation, MsgCsvColumnApplicationsMatriculation)
- , ('csvCAField , MsgCsvColumnApplicationsField )
- , ('csvCADegree , MsgCsvColumnApplicationsDegree )
- , ('csvCASemester , MsgCsvColumnApplicationsSemester )
+ , ('csvCAStudyFeatures, MsgCsvColumnUserStudyFeatures )
, ('csvCAText , MsgCsvColumnApplicationsText )
, ('csvCAHasFiles , MsgCsvColumnApplicationsHasFiles )
, ('csvCAVeto , MsgCsvColumnApplicationsVeto )
@@ -182,19 +156,14 @@ instance CsvColumnsExplained CourseApplicationsTableCsv where
]
data CourseApplicationsTableCsvActionClass
- = CourseApplicationsTableCsvSetField
- | CourseApplicationsTableCsvSetVeto
+ = CourseApplicationsTableCsvSetVeto
| CourseApplicationsTableCsvSetRating
| CourseApplicationsTableCsvSetComment
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvActionClass id
data CourseApplicationsTableCsvAction
- = CourseApplicationsTableCsvSetFieldData
- { caCsvActApplication :: CourseApplicationId
- , caCsvActField :: Maybe StudyFeaturesId
- }
- | CourseApplicationsTableCsvSetVetoData
+ = CourseApplicationsTableCsvSetVetoData
{ caCsvActApplication :: CourseApplicationId
, caCsvActVeto :: Bool
}
@@ -284,18 +253,12 @@ postCApplicationsR tid ssh csh = do
hasFiles <- view queryHasFiles
user <- view queryUser
allocation <- view queryAllocation
- studyFeatures <- view queryStudyFeatures
- studyTerms <- view queryStudyTerms
- studyDegree <- view queryStudyDegree
courseParticipant <- view queryCourseParticipant
lift $ do
E.on $ E.just (user E.^. UserId) E.==. courseParticipant E.?. CourseParticipantUser
E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val cid)
E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
- E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
- E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
- E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
E.&&. courseApplication E.^. CourseApplicationCourse E.==. E.val cid
@@ -306,34 +269,38 @@ postCApplicationsR tid ssh csh = do
, user
, hasFiles
, allocation
- , studyFeatures
- , studyTerms
- , studyDegree
, E.not_ . E.isNothing $ courseParticipant E.?. CourseParticipantId
)
dbtProj :: DBRow _ -> DB CourseApplicationsTableData
- dbtProj = traverse $ return . over _3 E.unValue . over _8 E.unValue
+ dbtProj = traverse $ \(application, user, E.Value hasFiles, allocation, E.Value isParticipant) -> do
+ feats <- courseUserStudyFeatures (application ^. _entityVal . _courseApplicationCourse) (user ^. _entityKey)
+ return (application, user, hasFiles, allocation, isParticipant, feats)
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
- dbtColonnade :: Colonnade Sortable _ _
+ dbtColonnade :: Cornice Sortable ('Cap 'Base) _ _
dbtColonnade = mconcat
- [ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant
- , emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
- , anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey)
- , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
- , lmap (view $ resultUser . _entityVal) colUserEmail
- , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
- , emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms
- , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
- , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
- , colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
- , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
- , colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
- , colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
- , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
+ [ cap (Sortable Nothing generatedColumnsHeader) $ mconcat
+ [ sortable (Just "participant") (i18nCell MsgCourseApplicationIsParticipant) $ bool mempty (cell $ toWidget iconOK) . view resultIsParticipant
+ , emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
+ , anchorColonnadeM (views (resultCourseApplication . _entityKey) applicationLink) $ colApplicationId (resultCourseApplication . _entityKey)
+ , anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
+ , lmap (view $ resultUser . _entityVal) colUserEmail
+ , colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
+ , colStudyFeatures resultStudyFeatures
+ ]
+ , cap (Sortable Nothing $ i18nCell MsgApplicationUserColumns) $ mconcat
+ [ colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
+ , lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusG 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
+ ]
+ , cap (Sortable Nothing $ i18nCell MsgApplicationRatingColumns) $ mconcat
+ [ colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
+ , colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
+ , colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
+ ]
]
+ where generatedColumnsHeader = cell $ i18n MsgApplicationGeneratedColumns <> (messageTooltip =<< messageI Info MsgApplicationGeneratedColumnsTip)
dbtSorting = mconcat
[ singletonMap "participant" . SortColumn $ view queryIsParticipant
@@ -341,9 +308,6 @@ postCApplicationsR tid ssh csh = do
, sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
, uncurry singletonMap . sortUserEmail $ view queryUser
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
- , sortStudyTerms queryStudyTerms
- , sortStudyDegree queryStudyDegree
- , sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
, sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
, sortApplicationFiles queryHasFiles
, sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
@@ -356,28 +320,37 @@ postCApplicationsR tid ssh csh = do
, fltrUserName' $ queryUser . to (E.^. UserDisplayName)
, uncurry singletonMap . fltrUserEmail $ view queryUser
, fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
- , fltrStudyTerms queryStudyTerms
- , fltrStudyDegree queryStudyDegree
- , fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
, fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
, fltrApplicationFiles queryHasFiles
, fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
, fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
, fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
+ , fltrRelevantStudyFeaturesTerms (to $
+ \t -> ( E.val courseTerm
+ , views queryUser (E.^. UserId) t
+ ))
+ , fltrRelevantStudyFeaturesDegree (to $
+ \t -> ( E.val courseTerm
+ , views queryUser (E.^. UserId) t
+ ))
+ , fltrRelevantStudyFeaturesSemester (to $
+ \t -> ( E.val courseTerm
+ , views queryUser (E.^. UserId) t
+ ))
]
dbtFilterUI = mconcat
[ fltrAllocationUI
, fltrUserNameUI'
, fltrUserMatriculationUI
, fltrUserEmailUI
- , fltrStudyTermsUI
- , fltrStudyDegreeUI
- , fltrStudyFeaturesSemesterUI
, fltrApplicationTextUI
, fltrApplicationFilesUI
, fltrApplicationVetoUI
, fltrApplicationRatingPointsUI
, fltrApplicationRatingCommentUI
+ , fltrRelevantStudyFeaturesTermsUI
+ , fltrRelevantStudyFeaturesDegreeUI
+ , fltrRelevantStudyFeaturesSemesterUI
]
dbtStyle = def
@@ -391,9 +364,7 @@ postCApplicationsR tid ssh csh = do
<*> preview (resultUser . _entityVal . _userDisplayName)
<*> preview (resultUser . _entityVal . _userEmail)
<*> preview (resultUser . _entityVal . _userMatrikelnummer . _Just)
- <*> preview (resultStudyTerms . _entityVal . (_studyTermsName . _Just <> _studyTermsShorthand . _Just <> to (tshow . studyTermsKey)))
- <*> preview (resultStudyDegree . _entityVal . (_studyDegreeName . _Just <> _studyDegreeShorthand . _Just <> to (tshow . studyDegreeKey)))
- <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+ <*> view resultStudyFeatures
<*> preview (resultCourseApplication . _entityVal . _courseApplicationText . _Just)
<*> preview resultHasFiles
<*> preview (resultCourseApplication . _entityVal . _courseApplicationRatingVeto . re _CourseApplicationsTableVeto)
@@ -416,10 +387,6 @@ postCApplicationsR tid ssh csh = do
DBCsvDiffExisting{..} -> do
let appId = dbCsvOld ^. resultCourseApplication . _entityKey
- newFeatures <- lift $ lookupStudyFeatures dbCsvNew
- when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $
- yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures
-
let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto
whenIsJust mVeto $ \veto ->
when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $
@@ -431,18 +398,12 @@ postCApplicationsR tid ssh csh = do
when (dbCsvNew ^. _csvCAComment /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingComment) $
yield $ CourseApplicationsTableCsvSetCommentData appId (dbCsvNew ^. _csvCAComment)
, dbtCsvClassifyAction = \case
- CourseApplicationsTableCsvSetFieldData{} -> CourseApplicationsTableCsvSetField
CourseApplicationsTableCsvSetVetoData{} -> CourseApplicationsTableCsvSetVeto
CourseApplicationsTableCsvSetRatingData{} -> CourseApplicationsTableCsvSetRating
CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
, dbtCsvCoarsenActionClass = const DBCsvActionExisting
, dbtCsvExecuteActions = do
C.mapM_ $ \case
- CourseApplicationsTableCsvSetFieldData{..} -> do
- CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationField =. caCsvActField
- , CourseApplicationTime =. now
- ]
- audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
CourseApplicationsTableCsvSetVetoData{..} -> do
CourseApplication{..} <- updateGet caCsvActApplication [ CourseApplicationRatingVeto =. caCsvActVeto
, CourseApplicationRatingTime =. Just now
@@ -460,15 +421,6 @@ postCApplicationsR tid ssh csh = do
audit $ TransactionCourseApplicationEdit cid courseApplicationUser caCsvActApplication
return $ CourseR tid ssh csh CApplicationsR
, dbtCsvRenderKey = \(existingApplicantName -> existingApplicantName') -> \case
- CourseApplicationsTableCsvSetFieldData{..} ->
- [whamlet|
- $newline never
- ^{existingApplicantName' caCsvActApplication}
- $maybe features <- caCsvActField
- , ^{studyFeaturesWidget features}
- $nothing
- , _{MsgCourseStudyFeatureNone}
- |]
CourseApplicationsTableCsvSetVetoData{..} ->
[whamlet|
$newline never
@@ -538,59 +490,6 @@ postCApplicationsR tid ssh csh = do
where
Entity _ User{..} = existing ^. singular (ix appId . resultUser)
- lookupStudyFeatures :: CourseApplicationsTableCsv -> DB (Maybe StudyFeaturesId)
- lookupStudyFeatures csv@CourseApplicationsTableCsv{..} = do
- appRes <- guessUser csv
- (uid, oldFeatures) <- case appRes of
- Left uid -> (uid, ) <$> selectList [ CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid ] []
- Right appId -> (courseApplicationUser . entityVal &&& pure) <$> getJustEntity appId
- studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
- E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
- , E.asc (studyFeatures E.^. StudyFeaturesDegree)
- , E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do
- E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
- E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
- E.where_ . E.and $ catMaybes
- [ do
- field <- csvCAField
- return . E.or $ catMaybes
- [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
- , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
- , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
- ]
- , do
- degree <- csvCADegree
- return . E.or $ catMaybes
- [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
- , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
- , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
- ]
- , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvCASemester
- ]
- E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
- let isActiveOrPrevious = E.or
- $ (studyFeatures E.^. StudyFeaturesValid)
- : [ E.val sfid E.==. studyFeatures E.^. StudyFeaturesId
- | Entity _ CourseApplication{ courseApplicationField = Just sfid } <- oldFeatures
- ]
- E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
- E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
- return $ studyFeatures E.^. StudyFeaturesId
- case studyFeatures of
- [E.Value fid] -> return $ Just fid
- _other
- | is _Nothing csvCAField
- , is _Nothing csvCADegree
- , is _Nothing csvCASemester
- -> return Nothing
- _other
- | [Entity _ CourseApplication{..}] <- oldFeatures
- , Just sfid <- courseApplicationField
- , E.Value sfid `elem` studyFeatures
- -> return $ Just sfid
- _other -> throwM CourseApplicationsTableCsvExceptionNoMatchingStudyFeatures
-
-
dbtIdent = courseApplicationsIdent
psValidator :: PSValidator _ _
diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs
index dab5b62e2..f7c9ea350 100644
--- a/src/Handler/Course/ParticipantInvite.hs
+++ b/src/Handler/Course/ParticipantInvite.hs
@@ -40,7 +40,6 @@ instance IsInvitableJunction CourseParticipant where
type InvitationFor CourseParticipant = Course
data InvitableJunction CourseParticipant = JunctionParticipant
{ jParticipantRegistration :: UTCTime
- , jParticipantField :: Maybe StudyFeaturesId
, jParticipantAllocated :: Maybe AllocationId
, jParticipantState :: CourseParticipantState
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -53,8 +52,8 @@ instance IsInvitableJunction CourseParticipant where
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso
- (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState))
- (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated courseParticipantState) -> CourseParticipant{..})
+ (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState))
+ (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantAllocated courseParticipantState) -> CourseParticipant{..})
instance ToJSON (InvitableJunction CourseParticipant) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
@@ -92,11 +91,9 @@ participantInvitationConfig = InvitationConfig{..}
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
- invitationForm _ _ uid = hoistAForm lift . wFormToAForm $ do
+ invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do
now <- liftIO getCurrentTime
- studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
- (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
- return . fmap (, ()) $ JunctionParticipant now <$> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
+ return . pure . (, ()) $ JunctionParticipant now Nothing CourseParticipantActive
invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
res <- act -- insertUnique
@@ -109,7 +106,6 @@ participantInvitationConfig = InvitationConfig{..}
data AddParticipantsResult = AddParticipantsResult
{ aurAlreadyRegistered
- , aurNoUniquePrimaryField
, aurSuccess :: Set UserId
} deriving (Read, Show, Generic, Typeable)
@@ -169,20 +165,14 @@ addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> AddParticipantsResult
-> ReaderT (YesodPersistBackend UniWorX) m [Message]
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
- (aurAlreadyRegistered', aurNoUniquePrimaryField') <-
- (,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
- <*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField)
+ aurAlreadyRegistered' <-
+ fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
unless (null aurAlreadyRegistered) $ do
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
- unless (null aurNoUniquePrimaryField) $ do
- let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
- modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
- tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
-
unless (null aurSuccess) $
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
@@ -200,18 +190,6 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do
whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $
throwError $ mempty { aurAlreadyRegistered = Set.singleton uid }
- features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
- applications <- lift . lift $ selectList [ CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
-
- let courseParticipantField
- | [f] <- features
- = Just f
- | [f'] <- nub $ mapMaybe (courseApplicationField . entityVal) applications
- , f' `elem` features
- = Just f'
- | otherwise
- = Nothing
-
courseParticipantRegistration <- liftIO getCurrentTime
void . lift . lift $ upsert
CourseParticipant
@@ -222,7 +200,6 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do
, ..
}
[ CourseParticipantRegistration =. courseParticipantRegistration
- , CourseParticipantField =. courseParticipantField
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
@@ -231,9 +208,7 @@ registerUser' cid uid mbGrp = exceptT tell tell $ do
void . lift . lift $ setUserSubmissionGroup cid uid mbGrp
- return $ case courseParticipantField of
- Nothing -> mempty { aurNoUniquePrimaryField = Set.singleton uid }
- Just _ -> mempty { aurSuccess = Set.singleton uid }
+ return $ mempty { aurSuccess = Set.singleton uid }
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs
index e0cd7f593..92297d3d9 100644
--- a/src/Handler/Course/Register.hs
+++ b/src/Handler/Course/Register.hs
@@ -9,6 +9,7 @@ module Handler.Course.Register
import Import
import Handler.Utils
+import Handler.Utils.Exam
import Utils.Course
@@ -41,8 +42,7 @@ instance Button UniWorX ButtonCourseRegister where
data CourseRegisterForm = CourseRegisterForm
- { crfStudyFeatures :: Maybe StudyFeaturesId
- , crfApplicationText :: Maybe Text
+ { crfApplicationText :: Maybe Text
, crfApplicationFiles :: Maybe FileUploads
}
@@ -82,17 +82,6 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
| otherwise
-> return $ FormSuccess ()
- fieldRes <- if
- | is _Nothing muid
- -> return $ FormSuccess Nothing
- | is _Just muid
- , isRegistered
- , Just mFeature <- courseApplicationField . entityVal <$> application
- <|> courseParticipantField . entityVal <$> registration
- -> wforced (studyFeaturesFieldFor Nothing True (maybeToList mFeature) muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) mFeature
- | otherwise
- -> wreq (studyFeaturesFieldFor Nothing False [] muid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
-
appTextRes <- let fs | courseApplicationsRequired
, is _Just courseApplicationsInstructions
= fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationFollowInstructions
@@ -167,7 +156,6 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
return $ CourseRegisterForm
<$ secretRes
- <*> fieldRes
<*> appTextRes
<*> appFilesRes
@@ -200,7 +188,7 @@ postCRegisterR tid ssh csh = do
= void <$> do
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
appRes <- case appIds of
- [] -> insertUnique $ CourseApplication cid uid crfStudyFeatures crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing
+ [] -> insertUnique $ CourseApplication cid uid crfApplicationText False Nothing Nothing Nothing Nothing cTime Nothing
(prevId:ps) -> do
forM_ ps $ \appId -> do
deleteApplicationFiles appId
@@ -208,7 +196,7 @@ postCRegisterR tid ssh csh = do
audit $ TransactionCourseApplicationDeleted cid uid appId
deleteApplicationFiles prevId
- update prevId [ CourseApplicationField =. crfStudyFeatures, CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ]
+ update prevId [ CourseApplicationText =. crfApplicationText, CourseApplicationTime =. cTime ]
return $ Just prevId
@@ -222,9 +210,8 @@ postCRegisterR tid ssh csh = do
mkRegistration = do
audit $ TransactionCourseParticipantEdit cid uid
entityKey <$> upsert
- (CourseParticipant cid uid cTime crfStudyFeatures Nothing CourseParticipantActive)
+ (CourseParticipant cid uid cTime Nothing CourseParticipantActive)
[ CourseParticipantRegistration =. cTime
- , CourseParticipantField =. crfStudyFeatures
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
@@ -297,9 +284,8 @@ deregisterParticipant uid cid = do
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
return examRegistration
- forM_ examRegistrations $ \(Entity erId ExamRegistration{..}) -> do
- delete erId
- audit $ TransactionExamDeregister examRegistrationExam uid
+ forM_ examRegistrations $ \(Entity _ ExamRegistration{..}) -> do
+ deregisterExamUsers examRegistrationExam $ pure examRegistrationUser
E.delete . E.from $ \tutorialParticipant -> do
let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse)
diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs
index e7ad89d12..de8747fc4 100644
--- a/src/Handler/Course/User.hs
+++ b/src/Handler/Course/User.hs
@@ -22,6 +22,8 @@ import Jobs.Queue
import Handler.Submission.List
+import Handler.Utils.StudyFeatures
+
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
@@ -93,36 +95,15 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
(mRegistration, studies) <- lift . runDB $ do
registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
- studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
- E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
+ studies <- E.select $ E.from $ \(course `E.InnerJoin` studyfeat `E.InnerJoin` studydegree `E.InnerJoin` studyterms) -> do
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
+ E.on $ isCourseStudyFeature course studyfeat
+ E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
+ E.where_ $ course E.^. CourseId E.==. E.val cid
return (studyfeat, studydegree, studyterms)
return (registration, studies)
- ((regFieldRes, regFieldView), regFieldEnctype) <- lift . runFormPost . identifyForm FIDcRegField $ \csrf ->
- let currentField :: Maybe (Maybe StudyFeaturesId)
- currentField = courseParticipantField . entityVal <$> mRegistration
- in over _2 ((toWidget csrf <>) . fvWidget) <$> mreq (studyFeaturesFieldFor Nothing True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
-
- let registrationFieldFrag :: Text
- registrationFieldFrag = "registration-field"
- regFieldWidget = wrapForm regFieldView FormSettings
- { formMethod = POST
- , formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
- , formEncoding = regFieldEnctype
- , formAttrs = []
- , formSubmit = FormAutoSubmit
- , formAnchor = Just registrationFieldFrag
- }
- for_ mRegistration $ \(Entity pId CourseParticipant{}) ->
- formResult regFieldRes $ \courseParticipantField' -> do
- lift . runDB $ do
- update pId [ CourseParticipantField =. courseParticipantField' ]
- audit $ TransactionCourseParticipantEdit cid uid
- addMessageI Success MsgCourseStudyFeatureUpdated
- redirect $ currentRoute :#: registrationFieldFrag
-
mayRegister <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR
let regButton
| is _Just mRegistration = BtnCourseDeregister
@@ -179,16 +160,10 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
-> invalidArgs ["User not registered"]
(BtnCourseRegister, _) -> do
now <- liftIO getCurrentTime
- let field
- | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies
- = Just featId
- | otherwise
- = Nothing
lift . runDBJobs $ do
void $ upsert
- (CourseParticipant cid uid now field Nothing CourseParticipantActive)
+ (CourseParticipant cid uid now Nothing CourseParticipantActive)
[ CourseParticipantRegistration =. now
- , CourseParticipantField =. field
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs
index f12e7993d..f6c31ef4e 100644
--- a/src/Handler/Course/Users.hs
+++ b/src/Handler/Course/Users.hs
@@ -4,7 +4,7 @@ module Handler.Course.Users
( queryUser
, makeCourseUserTable
, postCUsersR, getCUsersR
- , colUserDegreeShort, colUserField, colUserSemester, colUserSex'
+ , colUserSex', _userStudyFeatures
) where
import Import
@@ -16,6 +16,7 @@ import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import Handler.Course.Register (deregisterParticipant)
+import Handler.Utils.StudyFeatures
import qualified Data.Set as Set
import qualified Data.Map as Map
@@ -39,10 +40,6 @@ type UserTableExpr = ( E.SqlExpr (Entity User)
`E.InnerJoin` E.SqlExpr (Entity CourseParticipant)
)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
- `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
- `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
- `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
- )
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity SubmissionGroup))
`E.InnerJoin` E.SqlExpr (Maybe (Entity SubmissionGroupUser))
)
@@ -53,54 +50,43 @@ type UserTableExpr = ( E.SqlExpr (Entity User)
-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
-- This ought to ease refactoring the query
queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
-queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
+queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
-queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
+queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
-queryUserNote = $(sqlLOJproj 4 2)
-
-queryFeaturesStudy :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
-queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 4 3)
-
-queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
-queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 4 3)
-
-queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
-queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 4 3)
+queryUserNote = $(sqlLOJproj 3 2)
querySubmissionGroup :: UserTableExpr -> E.SqlExpr (Maybe (Entity SubmissionGroup))
-querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 4 4)
+querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 3 3)
userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
, E.SqlExpr (Entity CourseParticipant)
, E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
- , StudyFeaturesDescription'
, E.SqlExpr (Maybe (Entity SubmissionGroup))
)
-userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures `E.LeftOuterJoin` (subGroup `E.InnerJoin` subGroupUser)) = do
+userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` (subGroup `E.InnerJoin` subGroupUser)) = do
-- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
E.on $ subGroup E.?. SubmissionGroupId E.==. subGroupUser E.?. SubmissionGroupUserSubmissionGroup
E.on $ subGroupUser E.?. SubmissionGroupUserUser E.==. E.just (user E.^. UserId)
E.&&. subGroup E.?. SubmissionGroupCourse E.==. E.just (E.val cid)
- features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
E.on $ (note E.?. CourseUserNoteUser E.==. E.just (participant E.^. CourseParticipantUser))
E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
- return (user, participant, note E.?. CourseUserNoteId, features, subGroup)
+ return (user, participant, note E.?. CourseUserNoteId, subGroup)
type UserTableData = DBRow ( Entity User
, Entity CourseParticipant
, Maybe CourseUserNoteId
- , (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
, ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
, [Entity Exam]
, Maybe (Entity SubmissionGroup)
, Map SheetName (SheetType, Maybe Points)
+ , UserTableStudyFeatures
)
instance HasEntity UserTableData User where
@@ -118,23 +104,20 @@ _userTableRegistration = _userTableParticipant . _entityVal . _courseParticipant
_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
_userTableNote = _dbrOutput . _3
-_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
-_userTableFeatures = _dbrOutput . _4
-
-_rowUserSemester :: Traversal' UserTableData Int
-_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
-
_userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
-_userTutorials = _dbrOutput . _5
+_userTutorials = _dbrOutput . _4
_userExams :: Lens' UserTableData [Entity Exam]
-_userExams = _dbrOutput . _6
+_userExams = _dbrOutput . _5
_userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup)
-_userSubmissionGroup = _dbrOutput . _7 . _Just
+_userSubmissionGroup = _dbrOutput . _6 . _Just
_userSheets :: Lens' UserTableData (Map SheetName (SheetType, Maybe Points))
-_userSheets = _dbrOutput . _8
+_userSheets = _dbrOutput . _7
+
+_userStudyFeatures :: Lens' UserTableData UserTableStudyFeatures
+_userStudyFeatures = _dbrOutput . _8
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
@@ -161,26 +144,6 @@ colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams)
(\(Entity _ Exam{..}) -> CExamR tid ssh csh examName EUsersR)
(examName . entityVal)
-colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
- foldMap numCell . preview _rowUserSemester
-
-colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $
- foldMap i18nCell . view (_userTableFeatures . _3)
-
--- colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
--- colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
--- foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3)
-
--- colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
--- colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
--- foldMap i18nCell . preview (_userTableFeatures . _2 . _Just)
-
-colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
- foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
-
colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSex' = colUserSex $ hasUser . _userSex
@@ -203,20 +166,12 @@ colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
_other -> mempty
-data UserTableCsvStudyFeature = UserTableCsvStudyFeature
- { csvUserField :: Text
- , csvUserDegree :: Text
- , csvUserSemester :: Int
- , csvUserType :: StudyFieldType
- } deriving (Eq, Ord, Read, Show, Generic, Typeable)
-makeLenses_ ''UserTableCsvStudyFeature
-
data UserTableCsv = UserTableCsv
{ csvUserName :: Text
, csvUserSex :: Maybe Sex
, csvUserMatriculation :: Maybe Text
, csvUserEmail :: CI Email
- , csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature)
+ , csvUserStudyFeatures :: UserTableStudyFeatures
, csvUserSubmissionGroup :: Maybe SubmissionGroupName
, csvUserRegistration :: UTCTime
, csvUserNote :: Maybe Html
@@ -232,20 +187,8 @@ instance Csv.ToNamedRecord UserTableCsv where
, "sex" Csv..= csvUserSex
, "matriculation" Csv..= csvUserMatriculation
, "email" Csv..= csvUserEmail
- ] ++ case csvUserStudyFeatures of
- Left feats
- -> [ "field" Csv..= (csvUserField <$> feats)
- , "degree" Csv..= (csvUserDegree <$> feats)
- , "semester" Csv..= (csvUserSemester <$> feats)
- ]
- Right feats
- -> let featsStr = Text.intercalate "; " . flip map (Set.toList feats) $ \UserTableCsvStudyFeature{..}
- -> let csvUserType' = renderMessage (error "no foundation needed" :: UniWorX) [] $ ShortStudyFieldType csvUserType
- in [st|#{csvUserField} #{csvUserDegree} (#{csvUserType'} #{tshow csvUserSemester})|]
- in [ "study-features" Csv..= featsStr
- ]
- ++
- [ "submission-group" Csv..= csvUserSubmissionGroup
+ , "study-features" Csv..= csvUserStudyFeatures
+ , "submission-group" Csv..= csvUserSubmissionGroup
] ++
[ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1
in "tutorial" Csv..= tutsStr
@@ -270,9 +213,6 @@ instance CsvColumnsExplained UserTableCsv where
, single "matriculation" MsgCsvColumnUserMatriculation
, single "email" MsgCsvColumnUserEmail
, single "study-features" MsgCsvColumnUserStudyFeatures
- , single "field" MsgCsvColumnUserField
- , single "degree" MsgCsvColumnUserDegree
- , single "semester" MsgCsvColumnUserSemester
, single "submission-group" MsgCsvColumnUserSubmissionGroup
, single "tutorial" MsgCsvColumnUserTutorial
, single "exams" MsgCsvColumnUserExam
@@ -283,19 +223,17 @@ instance CsvColumnsExplained UserTableCsv where
single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
single k v = singletonMap k [whamlet|_{v}|]
-data UserCsvExportData = UserCsvExportData
- { csvUserSimplifiedFeaturesOfStudy :: Bool
- , csvUserIncludeSheets :: Bool
+newtype UserCsvExportData = UserCsvExportData
+ { csvUserIncludeSheets :: Bool
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Default UserCsvExportData where
- def = UserCsvExportData True False
+ def = UserCsvExportData False
userTableCsvHeader :: Bool -> [Entity Tutorial] -> [Entity Sheet] -> UserCsvExportData -> Csv.Header
userTableCsvHeader showSex tuts sheets UserCsvExportData{..} = Csv.header $
[ "name" ] ++
[ "sex" | showSex ] ++
- [ "matriculation", "email"
- ] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++
+ [ "matriculation", "email", "study-features"] ++
[ "tutorial" | hasEmptyRegGroup ] ++
map (encodeUtf8 . CI.foldedCase) regGroups ++
[ "exams", "registration" ] ++
@@ -376,7 +314,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
dbtRowKey = queryUser >>> (E.^. UserId)
- dbtProj = traverse $ \(user, participant, E.Value userNoteId, (feature,degree,terms), subGroup) -> do
+ dbtProj = traverse $ \(user, participant, E.Value userNoteId, subGroup) -> do
tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] []
subs' <- E.select . E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
@@ -389,13 +327,14 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, submission
)
)
+ feats <- courseUserStudyFeatures (participant ^. _entityVal . _courseParticipantCourse) (participant ^. _entityVal . _courseParticipantUser)
let
regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials
tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts'
exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams
subs = Map.fromList $ map (over (_2 . _2) (views _entityVal submissionRatingPoints <=< assertM (views _entityVal submissionRatingDone)) . over _1 E.unValue . over (_2 . _1) E.unValue) subs'
- return (user, participant, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts, exs, subGroup, subs)
+ return (user, participant, userNoteId, tuts, exs, subGroup, subs, feats)
dbtColonnade = colChoices
dbtSorting = mconcat
[ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header
@@ -404,11 +343,6 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser
, sortUserSex (to queryUser . to (E.^. UserSex))
- , single ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
- , single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
- , single ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
- , single ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
- , single ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
, single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
E.subSelectMaybe . E.from $ \edit -> do
@@ -450,20 +384,6 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, single $ fltrUserMatriclenr queryUser
, single $ fltrUserNameEmail queryUser
, fltrUserSex (to queryUser . to (E.^. UserSex))
- , single ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
- , single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
- , single ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
- , single ("field" , FilterColumn $ E.anyFilter
- [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
- , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
- , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
- ] )
- , single ("degree" , FilterColumn $ E.anyFilter
- [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
- , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
- , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
- ] )
- , single ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
@@ -489,6 +409,18 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.&&. sheet E.^. SheetName E.==. E.val shn
)
+ , fltrRelevantStudyFeaturesTerms (to $
+ \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
+ , queryUser t E.^. UserId
+ ))
+ , fltrRelevantStudyFeaturesDegree (to $
+ \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
+ , queryUser t E.^. UserId
+ ))
+ , fltrRelevantStudyFeaturesSemester (to $
+ \t -> ( E.subSelectForeign (queryParticipant t) CourseParticipantCourse (E.^. CourseTerm)
+ , queryUser t E.^. UserId
+ ))
]
where single = uncurry Map.singleton
dbtFilterUI mPrev = mconcat $
@@ -497,11 +429,12 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, fltrUserMatriclenrUI mPrev
] ++
[ fltrUserSexUI mPrev | showSex ] ++
- [ prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
- , prismAForm (singletonFilter "field") mPrev $ aopt textField (fslI MsgCourseStudyFeature)
- , prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
+ [ prismAForm (singletonFilter "submission-group") mPrev $ aopt textField (fslI MsgSubmissionGroup)
, prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseUserTutorial)
, prismAForm (singletonFilter "exam") mPrev $ aopt textField (fslI MsgCourseUserExam)
+ , fltrRelevantStudyFeaturesDegreeUI mPrev
+ , fltrRelevantStudyFeaturesTermsUI mPrev
+ , fltrRelevantStudyFeaturesSemesterUI mPrev
] ++
[ prismAForm (singletonFilter "has-personalised-sheet-files". maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) . optionsF $ map E.unValue personalisedSheets) (fslI MsgCourseUserHasPersonalisedSheetFilesFilter)
| not $ null personalisedSheets
@@ -523,44 +456,14 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
csvColumns' <- csvColumns
return $ DBTCsvEncode
{ dbtCsvExportForm = UserCsvExportData
- <$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def)
- <*> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def)
- , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $
+ <$> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def)
+ , dbtCsvDoEncode = \UserCsvExportData{} -> C.mapM $ \(_, row) -> flip runReaderT row $
UserTableCsv
<$> view (hasUser . _userDisplayName)
<*> view (hasUser . _userSex)
<*> view (hasUser . _userMatrikelnummer)
<*> view (hasUser . _userEmail)
- <*> if
- | csvUserSimplifiedFeaturesOfStudy -> fmap Left . runMaybeT $
- UserTableCsvStudyFeature
- <$> MaybeT (preview $ _userTableFeatures . _3 . _Just . _studyTermsName . _Just
- <> _userTableFeatures . _3 . _Just . _studyTermsKey . to tshow
- )
- <*> MaybeT (preview $ _userTableFeatures . _2 . _Just . _studyDegreeName . _Just
- <> _userTableFeatures . _2 . _Just . _studyDegreeKey . to tshow
- )
- <*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesSemester)
- <*> MaybeT (preview $ _userTableFeatures . _1 . _Just . _studyFeaturesType)
- | otherwise -> Right <$> do
- feats <- lift . E.select . E.from $ \(feat `E.InnerJoin` terms `E.InnerJoin` degree) -> do
- E.on $ degree E.^. StudyDegreeId E.==. feat E.^. StudyFeaturesDegree
- E.on $ terms E.^. StudyTermsId E.==. feat E.^. StudyFeaturesField
- let registered = E.exists . E.from $ \participant ->
- E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
- E.&&. participant E.^. CourseParticipantUser E.==. E.val uid
- E.&&. participant E.^. CourseParticipantField E.==. E.just (feat E.^. StudyFeaturesId)
- E.where_ $ registered
- E.||. feat E.^. StudyFeaturesValid
- E.where_ $ feat E.^. StudyFeaturesUser E.==. E.val uid
- return (terms, degree, feat)
- return . Set.fromList . flip map feats $ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) ->
- UserTableCsvStudyFeature
- { csvUserField = fromMaybe (tshow studyTermsKey) studyTermsName
- , csvUserDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
- , csvUserSemester = studyFeaturesSemester
- , csvUserType = studyFeaturesType
- }
+ <*> view _userStudyFeatures
<*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
<*> view _userTableRegistration
<*> userNote
@@ -636,9 +539,7 @@ postCUsersR tid ssh csh = do
, guardOn showSex . cap' $ colUserSex'
, pure . cap' $ colUserEmail
, pure . cap' $ colUserMatriclenr
- , pure . cap' $ colUserDegreeShort
- , pure . cap' $ colUserField
- , pure . cap' $ colUserSemester
+ , pure . cap' $ colStudyFeatures _userStudyFeatures
, guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
, guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
, guardOn hasExams . cap' $ colUserExams tid ssh csh
diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs
index 912e52054..a833073f6 100644
--- a/src/Handler/Exam/AddUser.hs
+++ b/src/Handler/Exam/AddUser.hs
@@ -22,7 +22,6 @@ import Generics.Deriving.Monoid
data AddRecipientsResult = AddRecipientsResult
{ aurAlreadyRegistered
- , aurNoUniquePrimaryField
, aurNoCourseRegistration
, aurSuccess
, aurSuccessCourse :: [UserEmail]
@@ -101,11 +100,6 @@ postEAddUserR tid ssh csh examn = do
unless (null aurSuccess) $
tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length aurSuccess
- unless (null aurNoUniquePrimaryField) $ do
- let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
- modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField")
- tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
-
unless (null aurNoCourseRegistration) $ do
let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}|]
modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse")
@@ -137,11 +131,6 @@ postEAddUserR tid ssh csh examn = do
guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True)
- features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
-
- let courseParticipantField
- | [f] <- features = Just f
- | otherwise = Nothing
lift . lift . void $ upsert
CourseParticipant
@@ -154,15 +143,12 @@ postEAddUserR tid ssh csh examn = do
}
[ CourseParticipantRegistration =. now
, CourseParticipantAllocated =. Nothing
- , CourseParticipantField =. courseParticipantField
, CourseParticipantState =. CourseParticipantActive
]
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
lift $ lift examRegister
- return $ case courseParticipantField of
- Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
- Just _ -> mempty { aurSuccessCourse = pure userEmail }
+ return $ mempty { aurSuccessCourse = pure userEmail }
diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs
index 05703e42a..3b721ec26 100644
--- a/src/Handler/Exam/RegistrationInvite.hs
+++ b/src/Handler/Exam/RegistrationInvite.hs
@@ -95,16 +95,13 @@ examRegistrationInvitationConfig = InvitationConfig{..}
case (isRegistered, invDBExamRegistrationCourseRegister) of
(False, False) -> permissionDeniedI MsgUnauthorizedParticipant
- (False, True ) -> do
- fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
- return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
- (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
- invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
- whenIsJust mField $ \cpField -> do
+ (False, True ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, True)
+ (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, False)
+ invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} doReg act = do
+ when doReg $ do
void $ upsert
- (CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing CourseParticipantActive)
+ (CourseParticipant examCourse examRegistrationUser examRegistrationTime Nothing CourseParticipantActive)
[ CourseParticipantRegistration =. examRegistrationTime
- , CourseParticipantField =. cpField
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs
index e8b306d85..e206bc17b 100644
--- a/src/Handler/Exam/Show.hs
+++ b/src/Handler/Exam/Show.hs
@@ -124,6 +124,7 @@ getEShowR tid ssh csh examn = do
, mayRegister' (entityKey <$> mOcc) = Just $ do
(examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
[whamlet|
+ $newline never
$if isRegistered
_{MsgExamRegistered}
@@ -147,11 +148,12 @@ getEShowR tid ssh csh examn = do
}
| is _Nothing mOcc
, is _Nothing registered
- = Just [whamlet|_{MsgExamLoginToRegister}|]
+ = Just $ i18n MsgExamLoginToRegister
| is _Nothing mOcc
, isRegistered <- is _Just $ join registered
= Just
[whamlet|
+ $newline never
$if isRegistered
_{MsgExamRegistered}
diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs
index 9fcf76c04..30b351113 100644
--- a/src/Handler/Exam/Users.hs
+++ b/src/Handler/Exam/Users.hs
@@ -10,6 +10,7 @@ import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Users
import Handler.Utils.Csv
+import Handler.Utils.StudyFeatures
import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget)
@@ -36,7 +37,7 @@ import qualified Data.CaseInsensitive as CI
import Numeric.Lens (integral)
-import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
+import Database.Persist.Sql (updateWhereCount)
import Control.Lens.Indexed ((<.), (.>))
@@ -47,25 +48,18 @@ type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration)
`E.InnerJoin` E.SqlExpr (Entity User)
)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
- `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity CourseParticipant))
- `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
- `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
- `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
- )
- )
+ `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamBonus))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
type ExamUserTableData = DBRow ( Entity ExamRegistration
, Entity User
, Maybe (Entity ExamOccurrence)
- , Maybe (Entity StudyFeatures)
- , Maybe (Entity StudyDegree)
- , Maybe (Entity StudyTerms)
, Maybe (Entity ExamBonus)
, Maybe (Entity ExamResult)
, Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))
, Maybe (Entity CourseUserNote)
+ , UserTableStudyFeatures
)
instance HasEntity ExamUserTableData User where
@@ -87,16 +81,7 @@ queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurre
queryExamOccurrence = $(sqlLOJproj 6 2)
queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant))
-queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3)
-
-queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
-queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
-
-queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
-queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
-
-queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
-queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
+queryCourseParticipant = $(sqlLOJproj 6 3)
queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus))
queryExamBonus = $(sqlLOJproj 6 4)
@@ -130,38 +115,32 @@ resultExamRegistration = _dbrOutput . _1
resultUser :: Lens' ExamUserTableData (Entity User)
resultUser = _dbrOutput . _2
-resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
-resultStudyFeatures = _dbrOutput . _4 . _Just
-
-resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
-resultStudyDegree = _dbrOutput . _5 . _Just
-
-resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
-resultStudyField = _dbrOutput . _6 . _Just
-
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
resultExamOccurrence = _dbrOutput . _3 . _Just
resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus)
-resultExamBonus = _dbrOutput . _7 . _Just
+resultExamBonus = _dbrOutput . _4 . _Just
resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
-resultExamResult = _dbrOutput . _8 . _Just
+resultExamResult = _dbrOutput . _5 . _Just
resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult))
-resultExamParts = _dbrOutput . _9 . itraversed
+resultExamParts = _dbrOutput . _6 . itraversed
-- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart)
-- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity
resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult))
-resultExamPartResult epId = _dbrOutput . _9 . unsafeSingular (ix epId) . _2
+resultExamPartResult epId = _dbrOutput . _6 . unsafeSingular (ix epId) . _2
resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
resultExamPartResults = resultExamParts <. _2
resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
-resultCourseNote = _dbrOutput . _10 . _Just
+resultCourseNote = _dbrOutput . _7 . _Just
+
+resultStudyFeatures :: Lens' ExamUserTableData UserTableStudyFeatures
+resultStudyFeatures = _dbrOutput . _8
resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points
@@ -191,9 +170,7 @@ data ExamUserTableCsv = ExamUserTableCsv
, csvEUserFirstName :: Maybe Text
, csvEUserName :: Maybe Text
, csvEUserMatriculation :: Maybe Text
- , csvEUserField :: Maybe Text
- , csvEUserDegree :: Maybe Text
- , csvEUserSemester :: Maybe Int
+ , csvEUserStudyFeatures :: UserTableStudyFeatures
, csvEUserOccurrence :: Maybe (CI Text)
, csvEUserExercisePoints :: Maybe (Maybe Points)
, csvEUserExerciseNumPasses :: Maybe (Maybe Int)
@@ -213,9 +190,7 @@ instance ToNamedRecord ExamUserTableCsv where
, "first-name" Csv..= csvEUserFirstName
, "name" Csv..= csvEUserName
, "matriculation" Csv..= csvEUserMatriculation
- , "field" Csv..= csvEUserField
- , "degree" Csv..= csvEUserDegree
- , "semester" Csv..= csvEUserSemester
+ , "study-features" Csv..= csvEUserStudyFeatures
, "occurrence" Csv..= csvEUserOccurrence
] ++ catMaybes
[ fmap ("exercise-points" Csv..=) csvEUserExercisePoints
@@ -240,9 +215,7 @@ instance FromNamedRecord ExamUserTableCsv where
<*> csv .:?? "first-name"
<*> csv .:?? "name"
<*> csv .:?? "matriculation"
- <*> csv .:?? "field"
- <*> csv .:?? "degree"
- <*> csv .:?? "semester"
+ <*> pure mempty
<*> csv .:?? "occurrence"
<*> fmap Just (csv .:?? "exercise-points")
<*> fmap Just (csv .:?? "exercise-num-passes")
@@ -263,9 +236,7 @@ instance CsvColumnsExplained ExamUserTableCsv where
, single "first-name" MsgCsvColumnExamUserFirstName
, single "name" MsgCsvColumnExamUserName
, single "matriculation" MsgCsvColumnExamUserMatriculation
- , single "field" MsgCsvColumnExamUserField
- , single "degree" MsgCsvColumnExamUserDegree
- , single "semester" MsgCsvColumnExamUserSemester
+ , single "study-features" MsgCsvColumnUserStudyFeatures
, single "occurrence" MsgCsvColumnExamUserOccurrence
, single "exercise-points" MsgCsvColumnExamUserExercisePoints
, single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses
@@ -287,7 +258,7 @@ examUserTableCsvHeader :: ( MonoFoldable mono
examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
[ "surname", "first-name", "name"
, "matriculation"
- , "field", "degree", "semester"
+ , "study-features"
, "course-note"
, "occurrence"
] ++ bool mempty ["exercise-points", "exercise-points-max"] (doBonus && showPoints)
@@ -329,7 +300,6 @@ data ExamUserCsvActionClass
= ExamUserCsvCourseRegister
| ExamUserCsvRegister
| ExamUserCsvAssignOccurrence
- | ExamUserCsvSetCourseField
| ExamUserCsvSetPartResult
| ExamUserCsvSetBonus
| ExamUserCsvOverrideBonus
@@ -343,7 +313,6 @@ embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id
data ExamUserCsvAction
= ExamUserCsvCourseRegisterData
{ examUserCsvActUser :: UserId
- , examUserCsvActCourseField :: Maybe StudyFeaturesId
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
}
| ExamUserCsvRegisterData
@@ -354,10 +323,6 @@ data ExamUserCsvAction
{ examUserCsvActRegistration :: ExamRegistrationId
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
}
- | ExamUserCsvSetCourseFieldData
- { examUserCsvActCourseParticipant :: CourseParticipantId
- , examUserCsvActCourseField :: Maybe StudyFeaturesId
- }
| ExamUserCsvDeregisterData
{ examUserCsvActRegistration :: ExamRegistrationId
}
@@ -404,6 +369,7 @@ getEUsersR = postEUsersR
postEUsersR tid ssh csh examn = do
(((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do
exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
+ Course{..} <- getJust examCourse
occurrences <- selectList [ExamOccurrenceExam ==. eid] [Asc ExamOccurrenceName]
examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
bonus <- examBonus exam
@@ -453,9 +419,6 @@ postEUsersR tid ssh csh examn = do
user <- asks queryUser
occurrence <- asks queryExamOccurrence
courseParticipant <- asks queryCourseParticipant
- studyFeatures <- asks queryStudyFeatures
- studyDegree <- asks queryStudyDegree
- studyField <- asks queryStudyField
examBonus' <- asks queryExamBonus
examResult <- asks queryExamResult
courseUserNote <- asks queryCourseNote
@@ -467,9 +430,6 @@ postEUsersR tid ssh csh examn = do
E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
E.on $ examBonus' E.?. ExamBonusUser E.==. E.just (user E.^. UserId)
E.&&. examBonus' E.?. ExamBonusExam E.==. E.just (E.val eid)
- E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
- E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
- E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
@@ -479,13 +439,14 @@ postEUsersR tid ssh csh examn = do
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
- return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examBonus', examResult, courseUserNote)
+ return (examRegistration, user, occurrence, examBonus', examResult, courseUserNote)
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
- (,,,,,,,,,)
- <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view _8
+ (,,,,,,,)
+ <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5
<*> getExamParts
- <*> view _9
+ <*> view _6
+ <*> (lift . courseUserStudyFeatures examCourse =<< view (_2 . _entityKey))
where
getExamParts :: ReaderT _ DB (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
getExamParts = do
@@ -504,9 +465,7 @@ postEUsersR tid ssh csh examn = do
[ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
, pure colUserMatriclenr
- , pure $ colField resultStudyField
- , pure $ colDegreeShort resultStudyDegree
- , pure $ colFeaturesSemester resultStudyFeatures
+ , pure $ colStudyFeatures resultStudyFeatures
, pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus
@@ -528,9 +487,6 @@ postEUsersR tid ssh csh examn = do
dbtSorting = mconcat
[ uncurry singletonMap $ sortUserNameLink queryUser
, uncurry singletonMap $ sortUserMatriclenr queryUser
- , uncurry singletonMap $ sortField queryStudyField
- , uncurry singletonMap $ sortDegreeShort queryStudyDegree
- , uncurry singletonMap $ sortFeaturesSemester queryStudyFeatures
, mconcat
[ singletonMap (fromText [st|part-#{toPathPiece examPartNumber}|]) . SortColumn . queryExamPart epId $ \_ examPartResult -> return $ examPartResult E.?. ExamPartResultResult
| Entity epId ExamPart{..} <- examParts
@@ -546,20 +502,29 @@ postEUsersR tid ssh csh examn = do
dbtFilter = mconcat
[ uncurry singletonMap $ fltrUserNameEmail queryUser
, uncurry singletonMap $ fltrUserMatriclenr queryUser
- , uncurry singletonMap $ fltrField queryStudyField
- , uncurry singletonMap $ fltrDegree queryStudyDegree
- , uncurry singletonMap $ fltrFeaturesSemester queryStudyFeatures
, uncurry singletonMap ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
, fltrExamResultPoints (to $ queryExamResult >>> (E.?. ExamResultResult))
+ , fltrRelevantStudyFeaturesTerms (to $
+ \t -> ( E.val courseTerm
+ , queryUser t E.^. UserId
+ ))
+ , fltrRelevantStudyFeaturesDegree (to $
+ \t -> ( E.val courseTerm
+ , queryUser t E.^. UserId
+ ))
+ , fltrRelevantStudyFeaturesSemester (to $
+ \t -> ( E.val courseTerm
+ , queryUser t E.^. UserId
+ ))
]
dbtFilterUI mPrev = mconcat $ catMaybes
[ Just $ fltrUserNameEmailUI mPrev
, Just $ fltrUserMatriclenrUI mPrev
- , Just $ fltrFieldUI mPrev
- , Just $ fltrDegreeUI mPrev
- , Just $ fltrFeaturesSemesterUI mPrev
, Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt (selectField' (Just $ SomeMessage MsgNoFilter) $ optionsF [CI.original examOccurrenceName | Entity _ ExamOccurrence{..} <- occurrences]) (fslI MsgExamOccurrence)
, Just $ fltrExamResultPointsUI mPrev
+ , Just $ fltrRelevantStudyFeaturesTermsUI mPrev
+ , Just $ fltrRelevantStudyFeaturesDegreeUI mPrev
+ , Just $ fltrRelevantStudyFeaturesSemesterUI mPrev
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = DBParamsForm
@@ -627,9 +592,7 @@ postEUsersR tid ssh csh examn = do
<*> view (resultUser . _entityVal . _userFirstName . to Just)
<*> view (resultUser . _entityVal . _userDisplayName . to Just)
<*> view (resultUser . _entityVal . _userMatrikelnummer)
- <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
- <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
- <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+ <*> view resultStudyFeatures
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
<*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped)
<*> fmap (bool (const Nothing) Just showPasses) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral)
@@ -650,15 +613,8 @@ postEUsersR tid ssh csh examn = do
-> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
(isPart, uid) <- lift $ guessUser' dbCsvNew
- if
- | isPart -> do
- yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew
- newFeatures <- lift $ lookupStudyFeatures dbCsvNew
- Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
- when (newFeatures /= oldFeatures) $
- yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
- | otherwise ->
- yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
+ unless isPart $
+ yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupOccurrence dbCsvNew
iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
when (epNumber `elem` examPartNumbers) $
@@ -679,11 +635,6 @@ postEUsersR tid ssh csh examn = do
when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $
yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence
- newFeatures <- lift $ lookupStudyFeatures dbCsvNew
- when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
- Entity cpId _ <- lift . getJustBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
- yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
-
let uid = dbCsvOld ^. resultUser . _entityKey
forM_ examPartNumbers $ \epNumber ->
@@ -742,7 +693,6 @@ postEUsersR tid ssh csh examn = do
ExamUserCsvRegisterData{} -> ExamUserCsvRegister
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
- ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult
ExamUserCsvSetBonusData{..}
| examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus
@@ -765,12 +715,10 @@ postEUsersR tid ssh csh examn = do
{ courseParticipantCourse = examCourse
, courseParticipantUser = examUserCsvActUser
, courseParticipantRegistration = now
- , courseParticipantField = examUserCsvActCourseField
, courseParticipantAllocated = Nothing
, courseParticipantState = CourseParticipantActive
}
[ CourseParticipantRegistration =. now
- , CourseParticipantField =. examUserCsvActCourseField
, CourseParticipantAllocated =. Nothing
, CourseParticipantState =. CourseParticipantActive
]
@@ -794,10 +742,6 @@ postEUsersR tid ssh csh examn = do
audit $ TransactionExamRegister eid examUserCsvActUser
ExamUserCsvAssignOccurrenceData{..} ->
update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ]
- ExamUserCsvSetCourseFieldData{..} -> do
- update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
- CourseParticipant{..} <- getJust examUserCsvActCourseParticipant
- audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser
ExamUserCsvSetPartResultData{..} -> do
epid <- getKeyJustBy $ UniqueExamPartNumber eid examUserCsvActExamPart
case examUserCsvActExamPartResult of
@@ -840,13 +784,8 @@ postEUsersR tid ssh csh examn = do
]
audit $ TransactionExamResultEdit eid examUserCsvActUser
ExamUserCsvDeregisterData{..} -> do
- ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration
- audit $ TransactionExamDeregister eid examRegistrationUser
- delete examUserCsvActRegistration
- result <- getBy $ UniqueExamResult eid examRegistrationUser
- forM_ result $ \(Entity erId _) -> do
- delete erId
- audit $ TransactionExamResultDeleted eid examRegistrationUser
+ ExamRegistration{..} <- getJust examUserCsvActRegistration
+ deregisterExamUsers examRegistrationExam $ pure examRegistrationUser
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do
noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse
whenIsJust noteId $ \nid -> do
@@ -864,10 +803,6 @@ postEUsersR tid ssh csh examn = do
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
- $maybe features <- examUserCsvActCourseField
- , ^{studyFeaturesWidget features}
- $nothing
- , _{MsgCourseStudyFeatureNone}
$maybe ExamOccurrence{examOccurrenceName} <- occ
\ (#{examOccurrenceName})
$nothing
@@ -893,16 +828,6 @@ postEUsersR tid ssh csh examn = do
$nothing
\ (_{MsgExamNoOccurrence})
|]
- ExamUserCsvSetCourseFieldData{..} -> do
- User{..} <- liftHandler . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
- [whamlet|
- $newline never
- ^{nameWidget userDisplayName userSurname}
- $maybe features <- examUserCsvActCourseField
- , ^{studyFeaturesWidget features}
- $nothing
- , _{MsgCourseStudyFeatureNone}
- |]
ExamUserCsvSetPartResultData{..} -> do
(User{..}, Entity _ ExamPart{..}) <- liftHandler . runDB $
(,) <$> getJust examUserCsvActUser
@@ -990,56 +915,6 @@ postEUsersR tid ssh csh examn = do
[occId] -> return occId
_other -> throwM ExamUserCsvExceptionNoMatchingOccurrence
- lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
- lookupStudyFeatures csv@ExamUserTableCsv{..} = do
- uid <- view _2 <$> guessUser' csv
- oldFeatures <- getBy $ UniqueParticipant uid examCourse
- studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) ->
- E.distinctOnOrderBy [ E.asc (studyFeatures E.^. StudyFeaturesField)
- , E.asc (studyFeatures E.^. StudyFeaturesDegree)
- , E.asc (studyFeatures E.^. StudyFeaturesSemester)] $ do
- E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
- E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
- E.where_ . E.and $ catMaybes
- [ do
- field <- csvEUserField
- return . E.or $ catMaybes
- [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
- , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
- , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
- ]
- , do
- degree <- csvEUserDegree
- return . E.or $ catMaybes
- [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
- , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
- , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
- ]
- , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
- ]
- E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
- let isActive = studyFeatures E.^. StudyFeaturesValid E.==. E.val True
- isActiveOrPrevious = case oldFeatures of
- Just (Entity _ CourseParticipant{courseParticipantField = Just sfid})
- -> isActive E.||. (E.val sfid E.==. studyFeatures E.^. StudyFeaturesId)
- _ -> isActive
- E.where_ isActiveOrPrevious -- either active studyFeature or the one previously associated with this course
- E.orderBy [E.desc isActiveOrPrevious, E.asc (E.orderByOrd $ studyFeatures E.^. StudyFeaturesType)]
- return $ studyFeatures E.^. StudyFeaturesId
- case studyFeatures of
- [E.Value fid] -> return $ Just fid
- _other
- | is _Nothing csvEUserField
- , is _Nothing csvEUserDegree
- , is _Nothing csvEUserSemester
- -> return Nothing
- _other
- | Just (Entity _ CourseParticipant{..}) <- oldFeatures
- , Just sfid <- courseParticipantField
- , E.Value sfid `elem` studyFeatures
- -> return $ Just sfid
- _other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
-
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
& defaultPagesize PagesizeAll
@@ -1051,10 +926,9 @@ postEUsersR tid ssh csh examn = do
(, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
formResult registrationResult $ \case
- (ExamUserDeregisterData, Map.keysSet -> selectedRegistrations) -> do
- nrDel <- runDB $ deleteWhereCount
- [ ExamRegistrationId <-. Set.toList selectedRegistrations
- ]
+ (ExamUserDeregisterData, Map.elems -> selectedRegistrations) -> do
+ nrDel <- runDB . setSerializable . deregisterExamUsersCount eId $ map (view $ resultUser . _entityKey) selectedRegistrations
+
addMessageI Success $ MsgExamUsersDeregistered nrDel
redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserAssignOccurrenceData occId, Map.keysSet -> selectedRegistrations) -> do
diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs
index e5be277ea..4364079c7 100644
--- a/src/Handler/ExamOffice/Exam.hs
+++ b/src/Handler/ExamOffice/Exam.hs
@@ -22,6 +22,8 @@ import qualified Data.Map as Map
import qualified Data.Conduit.List as C
import qualified Colonnade
+import Handler.Utils.StudyFeatures
+
data ButtonCloseExam = BtnCloseExam
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
@@ -68,21 +70,14 @@ type ExamUserTableExpr = ( E.SqlExpr (Entity ExamResult)
)
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamRegistration))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
- `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity CourseParticipant))
- `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
- `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
- `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
- )
- )
+ `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseParticipant))
type ExamUserTableData = DBRow ( Entity ExamResult
, Entity User
, Maybe (Entity ExamOccurrence)
- , Maybe (Entity StudyFeatures)
- , Maybe (Entity StudyDegree)
- , Maybe (Entity StudyTerms)
, Maybe (Entity ExamRegistration)
, Bool
, [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
+ , UserTableStudyFeatures
)
queryExamRegistration :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamRegistration)))
@@ -95,16 +90,7 @@ queryExamOccurrence :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity ExamOc
queryExamOccurrence = to $(E.sqlLOJproj 4 3)
queryCourseParticipant :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity CourseParticipant)))
-queryCourseParticipant = to $ $(E.sqlLOJproj 2 1) . $(E.sqlLOJproj 4 4)
-
-queryStudyFeatures :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
-queryStudyFeatures = to $ $(E.sqlIJproj 3 1) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
-
-queryStudyDegree :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
-queryStudyDegree = to $ $(E.sqlIJproj 3 2) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
-
-queryStudyField :: Getter ExamUserTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
-queryStudyField = to $ $(E.sqlIJproj 3 3) . $(E.sqlLOJproj 2 2) . $(E.sqlLOJproj 4 4)
+queryCourseParticipant = to $(E.sqlLOJproj 4 4)
queryExamResult :: Getter ExamUserTableExpr (E.SqlExpr (Entity ExamResult))
queryExamResult = to $ $(E.sqlIJproj 2 1) . $(E.sqlLOJproj 4 1)
@@ -118,15 +104,6 @@ queryIsSynced authId = to $ Exam.resultIsSynced authId <$> view queryExamResult
resultUser :: Lens' ExamUserTableData (Entity User)
resultUser = _dbrOutput . _2
-resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
-resultStudyFeatures = _dbrOutput . _4 . _Just
-
-resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
-resultStudyDegree = _dbrOutput . _5 . _Just
-
-resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
-resultStudyField = _dbrOutput . _6 . _Just
-
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
resultExamOccurrence = _dbrOutput . _3 . _Just
@@ -134,19 +111,20 @@ resultExamResult :: Lens' ExamUserTableData (Entity ExamResult)
resultExamResult = _dbrOutput . _1
resultIsSynced :: Lens' ExamUserTableData Bool
-resultIsSynced = _dbrOutput . _8
+resultIsSynced = _dbrOutput . _5
resultSynchronised :: Traversal' ExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)
-resultSynchronised = _dbrOutput . _9 . traverse
+resultSynchronised = _dbrOutput . _6 . traverse
+
+resultStudyFeatures :: Lens' ExamUserTableData UserTableStudyFeatures
+resultStudyFeatures = _dbrOutput . _7
data ExamUserTableCsv = ExamUserTableCsv
{ csvEUserSurname :: Text
, csvEUserFirstName :: Text
, csvEUserName :: Text
, csvEUserMatriculation :: Maybe Text
- , csvEUserField :: Maybe Text
- , csvEUserDegree :: Maybe Text
- , csvEUserSemester :: Maybe Int
+ , csvEUserStudyFeatures :: UserTableStudyFeatures
, csvEUserOccurrenceStart :: Maybe ZonedTime
, csvEUserExamResult :: ExamResultPassedGrade
}
@@ -168,9 +146,7 @@ instance CsvColumnsExplained ExamUserTableCsv where
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
, ('csvEUserName , MsgCsvColumnExamUserName )
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
- , ('csvEUserField , MsgCsvColumnExamUserField )
- , ('csvEUserDegree , MsgCsvColumnExamUserDegree )
- , ('csvEUserSemester , MsgCsvColumnExamUserSemester )
+ , ('csvEUserStudyFeatures , MsgCsvColumnUserStudyFeatures )
, ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart )
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
]
@@ -198,6 +174,7 @@ postEGradesR tid ssh csh examn = do
now <- liftIO getCurrentTime
((usersResult, examUsersTable), Entity eId _) <- runDB $ do
exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
+ Course{..} <- getJust examCourse
csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
isLecturer <- hasReadAccessTo $ CExamR tid ssh csh examn EUsersR
@@ -249,16 +226,10 @@ postEGradesR tid ssh csh examn = do
examRegistration <- view queryExamRegistration
occurrence <- view queryExamOccurrence
courseParticipant <- view queryCourseParticipant
- studyFeatures <- view queryStudyFeatures
- studyDegree <- view queryStudyDegree
- studyField <- view queryStudyField
isSynced <- view . queryIsSynced $ E.val uid
lift $ do
- E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
- E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
- E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
E.&&. courseParticipant E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
@@ -274,14 +245,15 @@ postEGradesR tid ssh csh examn = do
unless isLecturer $
E.where_ $ Exam.examOfficeExamResultAuth (E.val uid) examResult
- return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
+ return (examResult, user, occurrence, examRegistration, isSynced)
dbtRowKey = views queryExamResult (E.^. ExamResultId)
dbtProj :: DBRow _ -> DB ExamUserTableData
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
- (,,,,,,,,)
- <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view (_8 . _Value)
+ (,,,,,,)
+ <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view (_5 . _Value)
<*> getSynchronised
+ <*> (lift . courseUserStudyFeatures examCourse =<< view (_2 . _entityKey))
where
getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
getSynchronised = do
@@ -335,9 +307,7 @@ postEGradesR tid ssh csh examn = do
, colSynced
, imapColonnade participantAnchor . anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
- , emptyOpticColonnade (resultStudyField . _entityVal) colStudyTerms
- , emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
- , emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
+ , colStudyFeatures resultStudyFeatures
, Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do
start <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just
end <- preview $ resultExamOccurrence . _entityVal . _examOccurrenceEnd . _Just <> like examEnd . _Just
@@ -347,9 +317,6 @@ postEGradesR tid ssh csh examn = do
dbtSorting = mconcat
[ sortUserName' (queryUser . to ((,) <$> (E.^. UserDisplayName) <*> (E.^. UserSurname)))
, sortUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
- , sortStudyTerms queryStudyField
- , sortStudyDegree queryStudyDegree
- , sortStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
, sortOccurrenceStart (queryExamOccurrence . to (E.maybe (E.val examStart) E.just . (E.?. ExamOccurrenceStart)))
, maybeOpticSortColumn sortExamResult (queryExamResult . to (E.^. ExamResultResult))
, singletonMap "is-synced" . SortColumn $ view (queryIsSynced $ E.val uid)
@@ -357,20 +324,30 @@ postEGradesR tid ssh csh examn = do
dbtFilter = mconcat
[ fltrUserName' (queryUser . to (E.^. UserDisplayName))
, fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
- , fltrStudyTerms queryStudyField
- , fltrStudyDegree queryStudyDegree
- , fltrStudyFeaturesSemester (queryStudyFeatures . to (E.?. StudyFeaturesSemester))
, fltrExamResultPoints (queryExamResult . to (E.^. ExamResultResult) . to E.just)
, singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
+ , fltrRelevantStudyFeaturesTerms (to $
+ \t -> ( E.val courseTerm
+ , views queryUser (E.^. UserId) t
+ ))
+ , fltrRelevantStudyFeaturesDegree (to $
+ \t -> ( E.val courseTerm
+ , views queryUser (E.^. UserId) t
+ ))
+ , fltrRelevantStudyFeaturesSemester (to $
+ \t -> ( E.val courseTerm
+ , views queryUser (E.^. UserId) t
+ ))
+
]
dbtFilterUI = mconcat
[ fltrUserNameUI'
, fltrUserMatriculationUI
- , fltrStudyTermsUI
- , fltrStudyDegreeUI
- , fltrStudyFeaturesSemesterUI
, fltrExamResultPointsUI
, \mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
+ , fltrRelevantStudyFeaturesTermsUI
+ , fltrRelevantStudyFeaturesDegreeUI
+ , fltrRelevantStudyFeaturesSemesterUI
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = DBParamsForm
@@ -405,9 +382,7 @@ postEGradesR tid ssh csh examn = do
(row ^. resultUser . _entityVal . _userFirstName)
(row ^. resultUser . _entityVal . _userDisplayName)
(row ^. resultUser . _entityVal . _userMatrikelnummer)
- (row ^? resultStudyField . _entityVal . to (\StudyTerms{..} -> fromMaybe (tshow studyTermsKey) $ studyTermsName <|> studyTermsShorthand))
- (row ^? resultStudyDegree . _entityVal . to (\StudyDegree{..} -> fromMaybe (tshow studyDegreeKey) $ studyDegreeName <|> studyDegreeShorthand))
- (row ^? resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+ (row ^. resultStudyFeatures)
(row ^? (resultExamOccurrence . _entityVal . _examOccurrenceStart <> like examStart . _Just) . to utcToZonedTime)
(row ^. resultExamResult . _entityVal . _examResultResult)
, dbtCsvName = unpack csvName
diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs
index 72a04eee4..050644330 100644
--- a/src/Handler/Health.hs
+++ b/src/Handler/Health.hs
@@ -88,9 +88,9 @@ getInstanceR = do
$newline never
- _{MsgClusterId}
-
- #{UUID.toText clusterId}
+
- #{UUID.toText clusterId}
- _{MsgInstanceId}
-
- #{UUID.toText instanceId}
+
- #{UUID.toText instanceId}
|]
provideJson instanceInfo
provideRep . return $ tshow instanceInfo
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 1f4aa9606..04518240d 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -373,7 +373,8 @@ getProfileDataR :: Handler Html
getProfileDataR = do
userEnt <- requireAuth
dataWidget <- runDB $ makeProfileData userEnt
- defaultLayout
+ defaultLayout $ do
+ setTitleI MsgMenuProfileData
dataWidget
makeProfileData :: Entity User -> DB Widget
@@ -396,10 +397,17 @@ makeProfileData (Entity uid User{..}) = do
submissionTable <- mkSubmissionTable uid -- Tabelle mit allen Abgaben und Abgabe-Gruppen
submissionGroupTable <- mkSubmissionGroupTable uid -- Tabelle mit allen Abgabegruppen
correctionsTable <- mkCorrectionsTable uid -- Tabelle mit allen Korrektor-Aufgaben
- let examTable = [whamlet|_{MsgPersonalInfoExamAchievementsWip}|]
- let ownTutorialTable = [whamlet|_{MsgPersonalInfoOwnTutorialsWip}|]
- let tutorialTable = [whamlet|_{MsgPersonalInfoTutorialsWip}|]
+ let examTable, ownTutorialTable, tutorialTable :: Widget
+ examTable = i18n MsgPersonalInfoExamAchievementsWip
+ ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
+ tutorialTable = i18n MsgPersonalInfoTutorialsWip
lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication
+ lastLdapSync <- traverse (formatTime SelFormatDateTime) userLastLdapSynchronisation
+
+ cID <- encrypt uid
+ mCRoute <- getCurrentRoute
+ showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID)
+
let profileRemarks = $(i18nWidgetFile "profile-remarks")
return $(widgetFile "profileData")
diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs
index 2705f7762..23f80effa 100644
--- a/src/Handler/Sheet/Form.hs
+++ b/src/Handler/Sheet/Form.hs
@@ -152,6 +152,10 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
warnValidation MsgSheetWarnNoActiveTo $ is _Just sfActiveTo || is _Nothing sfActiveFrom
+ warnValidation MsgSheetSubmissionModeNoneWithoutNotGraded
+ $ classifySubmissionMode sfSubmissionMode /= SubmissionModeNone
+ || sfType == NotGraded
+
correctorForm :: Loads -> AForm Handler Loads
correctorForm loads' = wFormToAForm $ do
currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
diff --git a/src/Handler/Sheet/PersonalisedFiles.hs b/src/Handler/Sheet/PersonalisedFiles.hs
index 362c73d29..91da0bcc2 100644
--- a/src/Handler/Sheet/PersonalisedFiles.hs
+++ b/src/Handler/Sheet/PersonalisedFiles.hs
@@ -55,7 +55,7 @@ data PersonalisedSheetFileUnresolved a
= PSFUnresolvedDirectory a
| PSFUnresolvedCollatable Text a
| PSFUnresolved a
- deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Generic, Typeable)
makePrisms ''PersonalisedSheetFileUnresolved
@@ -195,7 +195,7 @@ sourcePersonalisedSheetFiles :: forall m.
-> Maybe SheetId
-> Maybe (Set UserId)
-> PersonalisedSheetFilesDownloadAnonymous
- -> ConduitT () (Either PersonalisedSheetFile File) (SqlPersistT m) ()
+ -> ConduitT () (Either PersonalisedSheetFile DBFile) (SqlPersistT m) ()
sourcePersonalisedSheetFiles cId mbsid mbuids anonMode = do
(mbIdx, cIDKey) <- lift . newPersonalisedFilesKey $ maybe (Left cId) Right mbsid
let
@@ -255,9 +255,10 @@ sourcePersonalisedSheetFiles cId mbsid mbuids anonMode = do
, fileModified = courseParticipantRegistration
}
yieldM . fmap Right $ do
- fileContent <- lift $ Just . toStrict <$> formatPersonalisedSheetFilesMeta anonMode cPart cID
+ fileContent' <- lift $ formatPersonalisedSheetFilesMeta anonMode cPart cID
let fileTitle = (dirName ) . ensureExtension "yaml" . unpack . mr $ MsgPersonalisedSheetFilesMetaFilename cID
fileModified = courseParticipantRegistration
+ fileContent = Just $ C.sourceLazy fileContent'
return File{..}
_dirCache %= Set.insert dirName
whenIsJust mbPFile $ \(Entity _ pFile@PersonalisedSheetFile{..}) -> do
diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs
index 00f38c092..e4dea05ad 100644
--- a/src/Handler/Sheet/Show.hs
+++ b/src/Handler/Sheet/Show.hs
@@ -143,6 +143,12 @@ getSShowR tid ssh csh shn = do
E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. E.val uid
E.&&. psFile E.^. PersonalisedSheetFileSheet E.==. E.val sid
+ submissionModeNoneWithoutNotGradedWarning <- runMaybeT $ do
+ guard $ classifySubmissionMode (sheetSubmissionMode sheet) == SubmissionModeNone
+ && sheetType sheet /= NotGraded
+ guardM . hasWriteAccessTo $ CSheetR tid ssh csh shn SEditR
+ return $ notification NotificationBroad =<< messageI Warning MsgSheetSubmissionModeNoneWithoutNotGraded
+
defaultLayout $ do
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
let zipLink = CSheetR tid ssh csh shn SArchiveR
diff --git a/src/Handler/Submission/Download.hs b/src/Handler/Submission/Download.hs
index 99f2f4457..6d55dfa62 100644
--- a/src/Handler/Submission/Download.hs
+++ b/src/Handler/Submission/Download.hs
@@ -11,8 +11,6 @@ import Handler.Utils.Submission
import qualified Data.Set as Set
-import qualified Data.Text.Encoding as Text
-
import qualified Database.Esqueleto as E
import qualified Data.Conduit.Combinators as Conduit
@@ -32,9 +30,8 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat
case isRating of
True
- | isUpdate -> runDB $ do
- file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
- maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
+ | isUpdate -> maybe notFound sendThisFile <=< runDB . runMaybeT $
+ lift . ratingFile cID =<< MaybeT (getRating submissionID)
| otherwise -> notFound
False -> do
let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \sf -> do
diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs
index 90a0cb1d2..5e91ce386 100644
--- a/src/Handler/Tutorial/Users.hs
+++ b/src/Handler/Tutorial/Users.hs
@@ -41,17 +41,16 @@ postTUsersR tid ssh csh tutn = do
, guardOn showSex colUserSex'
, pure colUserEmail
, pure colUserMatriclenr
- , pure colUserDegreeShort
- , pure colUserField
- , pure colUserSemester
+ , pure $ colStudyFeatures _userStudyFeatures
]
psValidator = def
& defaultSortingByName
- & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
+ & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
+ & restrictFilter (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
isInTut q = E.exists . E.from $ \tutorialParticipant ->
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
- csvColChoices = flip elem ["name", "matriculation", "email", "field", "degree", "semester", "study-features"]
+ csvColChoices = flip elem ["name", "matriculation", "email", "study-features"]
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
table <- makeCourseUserTable cid (Map.fromList $ map (id &&& pure) universeF) isInTut colChoices psValidator (Just csvColChoices)
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index 88d0340fd..96a285ce0 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -37,6 +37,8 @@ import qualified Data.Conduit.List as C
import qualified Data.HashSet as HashSet
+import Auth.Dummy (apDummy)
+
hijackUserForm :: Form ()
hijackUserForm csrf = do
@@ -101,6 +103,9 @@ postUsersR = do
$forall (E.Value sh) <- schools
- #{sh}
|]
+ , sortable Nothing (i18nCell MsgUserSystemFunctions) $ \DBRow{ dbrOutput = Entity uid _ } ->
+ let getFunctions = fmap (map $ userSystemFunctionFunction . entityVal) . liftHandler . runDB $ selectList [ UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False ] [ Asc UserSystemFunctionFunction ]
+ in listCell' getFunctions i18nCell
, sortable Nothing (mempty & cellAttrs <>~ pure ("hide-columns--hider-label", mr MsgActionsHead)) $ \inp@DBRow{ dbrOutput = Entity uid _ } -> FormCell
{ formCellAttrs = []
, formCellLens = id
@@ -248,7 +253,7 @@ postUsersR = do
hijackUser :: UserId -> Handler TypedContent
hijackUser uid = do
User{userIdent} <- runDB $ get404 uid
- setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
+ setCredsRedirect $ Creds apDummy (CI.original userIdent) []
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
postAdminHijackUserR cID = do
@@ -277,7 +282,7 @@ getAdminUserR = postAdminUserR
postAdminUserR uuid = do
adminId <- requireAuthId
uid <- decrypt uuid
- (user@User{..}, adminSchools, functions, schools) <- runDB $ do
+ (user@User{..}, adminSchools, functions, schools, systemFunctions) <- runDB $ do
user <- get404 uid
schools <- E.select . E.from $ \(school `E.LeftOuterJoin` userFunction) -> do
@@ -289,10 +294,14 @@ postAdminUserR uuid = do
E.&&. adminFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
return (school, userFunction E.?. UserFunctionFunction, isAdmin)
+ systemFunctionsF <- Set.fromList . map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. uid, UserSystemFunctionIsOptOut ==. False] []
+ let systemFunctions = (`Set.member` systemFunctionsF)
+
return ( user
, setOf (folded . filtered (view $ _3 . _Value) . _1 . _entityKey) schools
, setOf (folded . folding (\x -> (,) <$> preview (_2 . _Value . _Just) x <*> preview (_1 . _entityKey) x)) schools
, setOf (folded . _1) schools
+ , systemFunctions
)
let allFunctions = Set.fromList universeF
allSchools = Set.mapMonotonic entityKey schools
@@ -311,6 +320,8 @@ postAdminUserR uuid = do
userAuthenticationForm = buttonForm' $ if
| userAuthentication == AuthLDAP -> [BtnAuthPWHash]
| otherwise -> [BtnAuthLDAP, BtnPasswordReset]
+ systemFunctionsForm' = funcForm systemFuncForm (fslI MsgUserSystemFunctions) False
+ where systemFuncForm func = apopt checkBoxField (fslI func) . Just $ systemFunctions func
let userRightsAction changes = do
let symDiff = (changes `Set.difference` functions) `Set.union` (functions `Set.difference` changes)
updates = (allFunctions `setProduct` adminSchools) `Set.intersection` symDiff
@@ -367,8 +378,24 @@ postAdminUserR uuid = do
queueJob' $ JobSendPasswordReset uid
addMessageI Success MsgPasswordResetQueued
redirect $ AdminUserR uuid
+
+ userSystemFunctionsAction newFuncs = do
+ let symmDiff = setFromFunc newFuncs `setSymmDiff` setFromFunc systemFunctions
+ if
+ | not $ Set.null symmDiff -> runDBJobs $ do
+ forM_ symmDiff $ \func -> if
+ | newFuncs func
+ -> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ]
+ | otherwise
+ -> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ]
+ queueDBJob . JobQueueNotification . NotificationUserSystemFunctionsUpdate uid $ setFromFunc systemFunctions
+ addMessageI Success MsgUserSystemFunctionsSaved
+ | otherwise
+ -> addMessageI Info MsgUserSystemFunctionsNotChanged
+ redirect $ AdminUserR uuid
((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm
((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm
+ ((systemFunctionsResult, systemFunctionsWidget),systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'
let rightsForm = wrapForm rightsFormWidget def
{ formAction = Just . SomeRoute $ AdminUserR uuid
, formEncoding = rightsFormEnctype
@@ -378,8 +405,13 @@ postAdminUserR uuid = do
, formEncoding = authFormEnctype
, formSubmit = FormNoSubmit
}
+ systemFunctionsForm = wrapForm systemFunctionsWidget def
+ { formAction = Just . SomeRoute $ AdminUserR uuid
+ , formEncoding = systemFunctionsEnctype
+ }
formResult rightsResult userRightsAction
formResult authResult userAuthenticationAction
+ formResult systemFunctionsResult userSystemFunctionsAction
let heading =
[whamlet|_{MsgAdminUserHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|]
-- Delete Button needed in data-delete
diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs
index bcdd889ce..ab7364388 100644
--- a/src/Handler/Users/Add.hs
+++ b/src/Handler/Users/Add.hs
@@ -81,6 +81,7 @@ postAdminUserAddR = do
, userTokensIssuedAfter = Nothing
, userCreated = now
, userLastLdapSynchronisation = Nothing
+ , userLdapPrimaryKey = Nothing
, userLastAuthentication = Nothing
, userEmail = aufEmail
, userDisplayName = aufDisplayName
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index b2b99ac45..c4ddd7db3 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -34,11 +34,13 @@ import Control.Monad.Logger
-- | Simply send a `File`-Value
-sendThisFile :: File -> Handler TypedContent
+sendThisFile :: DBFile -> Handler TypedContent
sendThisFile File{..}
| Just fileContent' <- fileContent = do
setContentDisposition' . Just $ takeFileName fileTitle
- return $ TypedContent (simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
+ let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8"
+ respondSourceDB cType $
+ fileContent' .| Conduit.map toFlushBuilder
| otherwise = sendResponseStatus noContent204 ()
-- | Serve a single file, identified through a given DB query
@@ -46,7 +48,7 @@ serveOneFile :: forall file. HasFileReference file => ConduitT () file (YesodDB
serveOneFile source = do
results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
case results of
- [file] -> sendThisFile =<< runDB (sourceFile' file)
+ [file] -> sendThisFile $ sourceFile' file
[] -> notFound
_other -> do
$logErrorS "SFileR" "Multiple matching files found."
@@ -58,7 +60,7 @@ serveOneFile source = do
serveSomeFiles :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left
-serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent
+serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> Handler TypedContent
serveSomeFiles' archiveName source = do
(source', results) <- runDB $ runPeekN 2 source
@@ -66,7 +68,7 @@ serveSomeFiles' archiveName source = do
case results of
[] -> notFound
- [file] -> sendThisFile =<< either (runDB . sourceFile') return file
+ [file] -> sendThisFile $ either sourceFile' id file
_moreFiles -> do
setContentDisposition' $ Just archiveName
respondSourceDB typeZip $ do
@@ -79,7 +81,7 @@ serveSomeFiles' archiveName source = do
serveZipArchive :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
serveZipArchive archiveName source = serveZipArchive' archiveName $ source .| C.map Left
-serveZipArchive' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file File) (YesodDB UniWorX) () -> Handler TypedContent
+serveZipArchive' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> Handler TypedContent
serveZipArchive' archiveName source = do
(source', results) <- runDB $ runPeekN 1 source
diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs
index be5ef5a57..db512e25a 100644
--- a/src/Handler/Utils/Allocation.hs
+++ b/src/Handler/Utils/Allocation.hs
@@ -244,11 +244,9 @@ doAllocation :: AllocationId
-> DB ()
doAllocation allocId now regs =
forM_ regs $ \(uid, cid) -> do
- mField <- (courseApplicationField . entityVal <=< listToMaybe) <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
void $ upsert
- (CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive)
+ (CourseParticipant cid uid now (Just allocId) CourseParticipantActive)
[ CourseParticipantRegistration =. now
- , CourseParticipantField =. mField
, CourseParticipantAllocated =. Just allocId
, CourseParticipantState =. CourseParticipantActive
]
@@ -278,7 +276,7 @@ storeAllocationResult :: AllocationId
-> (AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun)
-> DB ()
storeAllocationResult allocId now (allocFp, allocMatchings, ppMatchingLog -> allocLog) = do
- FileReference{..} <- sinkFile $ File "matchings.log" (Just $ encodeUtf8 allocLog) now
+ FileReference{..} <- sinkFile $ File "matchings.log" (Just . yield $ encodeUtf8 allocLog) now
insert_ . AllocationMatching allocId allocFp now $ fromMaybe (error "allocation result stored without fileReferenceContent") fileReferenceContent
doAllocation allocId now allocMatchings
diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs
index 7fd3c4c54..a321bebff 100644
--- a/src/Handler/Utils/DateTime.hs
+++ b/src/Handler/Utils/DateTime.hs
@@ -2,7 +2,7 @@
module Handler.Utils.DateTime
( utcToLocalTime, utcToZonedTime
- , localTimeToUTC, TZ.LocalToUTCResult(..)
+ , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple
, toTimeOfDay
, toMidnight, beforeMidnight, toMidday, toMorning
, formatDiffDays
@@ -47,6 +47,9 @@ utcToZonedTime = ZonedTime <$> TZ.utcToLocalTimeTZ appTZ <*> TZ.timeZoneForUTCTi
localTimeToUTC :: LocalTime -> LocalToUTCResult
localTimeToUTC = TZ.localTimeToUTCFull appTZ
+localTimeToUTCSimple :: LocalTime -> UTCTime
+localTimeToUTCSimple = TZ.localTimeToUTCTZ appTZ
+
-- | Local midnight of given day
toMidnight :: Day -> UTCTime
toMidnight = toTimeOfDay 0 0 0
diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs
index e192dc688..54632cde6 100644
--- a/src/Handler/Utils/Exam.hs
+++ b/src/Handler/Utils/Exam.hs
@@ -10,6 +10,7 @@ module Handler.Utils.Exam
, eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
, _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
, examAutoOccurrence
+ , deregisterExamUsersCount, deregisterExamUsers
) where
import Import
@@ -609,3 +610,34 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
in Set.map (appEndo $ foldMap Endo [ over l padSuff | l <- [_eaomrStart, _eaomrEnd, _eaomrSpecial]]) <$> res
| otherwise
= res
+
+
+deregisterExamUsersCount :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m Int64
+deregisterExamUsersCount eId uids = do
+ partResults <- E.select . E.from $ \(examPart `E.InnerJoin` examPartResult) -> do
+ E.on $ examPart E.^. ExamPartId E.==. examPartResult E.^. ExamPartResultExamPart
+ E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId
+ E.&&. examPartResult E.^. ExamPartResultUser `E.in_` E.valList uids
+ return examPartResult
+ forM_ partResults $ \(Entity resId ExamPartResult{..}) -> do
+ delete resId
+ audit $ TransactionExamPartResultDeleted examPartResultExamPart examPartResultUser
+
+ results <- selectList [ ExamResultExam ==. eId, ExamResultUser <-. uids ] []
+ forM_ results $ \(Entity resId ExamResult{..}) -> do
+ delete resId
+ audit $ TransactionExamResultDeleted examResultExam examResultUser
+
+ boni <- selectList [ ExamBonusExam ==. eId, ExamBonusUser <-. uids ] []
+ forM_ boni $ \(Entity bonusId ExamBonus{..}) -> do
+ delete bonusId
+ audit $ TransactionExamBonusDeleted examBonusExam examBonusUser
+
+ regs <- selectList [ ExamRegistrationExam ==. eId, ExamRegistrationUser <-. uids ] []
+ fmap (ala Sum foldMap) . forM regs $ \(Entity regId ExamRegistration{..}) -> do
+ delete regId
+ audit $ TransactionExamDeregister examRegistrationExam examRegistrationUser
+ return 1
+
+deregisterExamUsers :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m ()
+deregisterExamUsers eId uids = void $ deregisterExamUsersCount eId uids
diff --git a/src/Handler/Utils/ExamOffice/Exam.hs b/src/Handler/Utils/ExamOffice/Exam.hs
index 2a21e24c7..9d8d1b50c 100644
--- a/src/Handler/Utils/ExamOffice/Exam.hs
+++ b/src/Handler/Utils/ExamOffice/Exam.hs
@@ -5,7 +5,10 @@ module Handler.Utils.ExamOffice.Exam
import Import.NoFoundation
+import Handler.Utils.StudyFeatures
+
import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
resultIsSynced :: E.SqlExpr (E.Value UserId) -- ^ office
-> E.SqlExpr (Entity ExamResult)
@@ -33,8 +36,13 @@ examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office
-> E.SqlExpr (E.Value Bool)
examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. authBySchool
where
+ cId = E.subSelectForeign examResult ExamResultExam (\exam -> E.subSelectForeign exam ExamCourse (E.^. CourseId))
+
authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do
E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField
+ E.where_ . E.maybe E.false id . E.subSelectMaybe . E.from $ \course -> do
+ E.where_ $ course E.^. CourseId E.==. cId
+ return . E.just $ isCourseStudyFeature course studyFeatures
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. examResult E.^. ExamResultUser
E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId
E.&&. examOfficeField E.^. ExamOfficeFieldField E.==. studyFeatures E.^. StudyFeaturesField
@@ -42,12 +50,10 @@ examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||.
E.||. E.exists (E.from $ \userFunction ->
E.where_ $ userFunction E.^. UserFunctionUser E.==. authId
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
- E.&&. E.not_ (E.exists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` courseUserExamOfficeOptOut) -> do
- E.on $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. course E.^. CourseId
- E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
- E.where_ $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam
- E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. examResult E.^. ExamResultUser
- E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool E.==. userFunction E.^. UserFunctionSchool
+ E.&&. E.not_ (E.exists . E.from $ \courseUserExamOfficeOptOut -> do
+ E.where_ $ courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse E.==. cId
+ E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. examResult E.^. ExamResultUser
+ E.&&. courseUserExamOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool E.==. userFunction E.^. UserFunctionSchool
)
)
diff --git a/src/Handler/Utils/ExamOffice/ExternalExam.hs b/src/Handler/Utils/ExamOffice/ExternalExam.hs
index 9dcac4d84..ed7be4aba 100644
--- a/src/Handler/Utils/ExamOffice/ExternalExam.hs
+++ b/src/Handler/Utils/ExamOffice/ExternalExam.hs
@@ -4,8 +4,10 @@ module Handler.Utils.ExamOffice.ExternalExam
) where
import Import.NoFoundation
+import Handler.Utils.StudyFeatures
import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
resultIsSynced :: E.SqlExpr (E.Value UserId) -- ^ office
@@ -36,6 +38,9 @@ examOfficeExternalExamResultAuth authId eexamResult = authByUser E.||. authByFie
where
authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do
E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField
+ E.where_ . E.maybe E.false id . E.subSelectMaybe . E.from $ \externalExam -> do
+ E.where_ $ externalExam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam
+ return . E.just $ isExternalExamStudyFeature externalExam studyFeatures
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. eexamResult E.^. ExternalExamResultUser
E.&&. examOfficeField E.^. ExamOfficeFieldOffice E.==. authId
E.&&. examOfficeField E.^. ExamOfficeFieldField E.==. studyFeatures E.^. StudyFeaturesField
diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs
index 68d6a5875..a64df671f 100644
--- a/src/Handler/Utils/ExternalExam/Users.hs
+++ b/src/Handler/Utils/ExternalExam/Users.hs
@@ -29,6 +29,8 @@ import qualified Data.Conduit.List as C
import Data.List (cycle)
+import Handler.Utils.StudyFeatures
+
data ExternalExamUserMode = EEUMUsers | EEUMGrades
deriving (Eq, Ord, Read, Show, Bounded, Enum, Generic, Typeable)
@@ -45,6 +47,7 @@ type ExternalExamUserTableData = DBRow ( Entity ExternalExamResult
, Entity User
, Bool
, [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
+ , UserTableStudyFeatures
)
queryUser :: Getter ExternalExamUserTableExpr (E.SqlExpr (Entity User))
@@ -68,12 +71,16 @@ resultIsSynced = _dbrOutput . _3
resultSynchronised :: Traversal' ExternalExamUserTableData (UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)
resultSynchronised = _dbrOutput . _4 . traverse
+resultStudyFeatures :: Lens' ExternalExamUserTableData UserTableStudyFeatures
+resultStudyFeatures = _dbrOutput . _5
+
data ExternalExamUserTableCsv = ExternalExamUserTableCsv
{ csvEUserSurname :: Maybe Text
, csvEUserFirstName :: Maybe Text
, csvEUserName :: Maybe Text
, csvEUserMatriculation :: Maybe Text
+ , csvEUserStudyFeatures :: UserTableStudyFeatures
, csvEUserOccurrenceStart :: Maybe ZonedTime
, csvEUserExamResult :: ExamResultPassedGrade
} deriving (Generic)
@@ -95,6 +102,7 @@ instance FromNamedRecord ExternalExamUserTableCsv where
<*> csv .:?? "first-name"
<*> csv .:?? "name"
<*> csv .:?? "matriculation"
+ <*> pure mempty
<*> csv .:?? "occurrence-start"
<*> csv .: "exam-result"
@@ -105,6 +113,7 @@ instance CsvColumnsExplained ExternalExamUserTableCsv where
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
, ('csvEUserName , MsgCsvColumnExamUserName )
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
+ , ('csvEUserStudyFeatures , MsgCsvColumnUserStudyFeatures )
, ('csvEUserOccurrenceStart , MsgCsvColumnExamOfficeExamUserOccurrenceStart )
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
]
@@ -209,9 +218,10 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
dbtProj :: DBRow _ -> DB ExternalExamUserTableData
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
- (,,,)
+ (,,,,)
<$> view _1 <*> view _2 <*> view (_3 . _Value)
<*> getSynchronised
+ <*> (lift . externalExamUserStudyFeatures eeId =<< view (_2 . _entityKey))
where
getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
getSynchronised = do
@@ -265,6 +275,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
, fromMaybe mempty . guardOn (is _EEUMGrades mode) $ colSynced
, colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
+ , colStudyFeatures resultStudyFeatures
, Colonnade.singleton (fromSortable . Sortable (Just "occurrence-start") $ i18nCell MsgExamTime) $ \x -> cell . flip runReaderT x $ do
t <- view $ resultResult . _entityVal . _externalExamResultTime
lift $ formatTimeW SelFormatDateTime t
@@ -282,6 +293,19 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
, fltrUserMatriculation (queryUser . to (E.^. UserMatrikelnummer))
, fltrExamResultPoints (queryResult . to (E.^. ExternalExamResultResult) . to E.just)
, singletonMap "is-synced" . FilterColumn $ E.mkExactFilter (view . queryIsSynced $ E.val uid)
+ , fltrRelevantStudyFeaturesTerms (to $
+ \t -> ( E.val externalExamTerm
+ , views queryUser (E.^. UserId) t
+ ))
+ , fltrRelevantStudyFeaturesDegree (to $
+ \t -> ( E.val externalExamTerm
+ , views queryUser (E.^. UserId) t
+ ))
+ , fltrRelevantStudyFeaturesSemester (to $
+ \t -> ( E.val externalExamTerm
+ , views queryUser (E.^. UserId) t
+ ))
+
]
dbtFilterUI = mconcat
[ fltrUserNameUI'
@@ -291,6 +315,9 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
EEUMGrades ->
\mPrev -> prismAForm (singletonFilter "is-synced" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgExamUserSynchronised)
_other -> mempty
+ , fltrRelevantStudyFeaturesTermsUI
+ , fltrRelevantStudyFeaturesDegreeUI
+ , fltrRelevantStudyFeaturesSemesterUI
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = DBParamsForm
@@ -345,6 +372,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
}
EEUMUsers ->
let baseEncode = simpleCsvEncode csvName encodeCsv'
+ csvEUserStudyFeatures = mempty
in baseEncode <&> \enc -> enc
{ dbtCsvExampleData = Just
[ ExternalExamUserTableCsv{..}
@@ -388,6 +416,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
, csvEUserFirstName = row ^? resultUser . _entityVal . _userFirstName
, csvEUserName = row ^? resultUser . _entityVal . _userDisplayName
, csvEUserMatriculation = row ^? resultUser . _entityVal . _userMatrikelnummer . _Just
+ , csvEUserStudyFeatures = row ^. resultStudyFeatures
, csvEUserOccurrenceStart = row ^? resultResult . _entityVal . _externalExamResultTime . to utcToZonedTime
, csvEUserExamResult = row ^. resultResult . _entityVal . _externalExamResultResult
}
diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs
index 9400a9a4b..aa0d280bc 100644
--- a/src/Handler/Utils/Files.hs
+++ b/src/Handler/Utils/Files.hs
@@ -2,17 +2,23 @@ module Handler.Utils.Files
( sourceFile, sourceFile'
, sourceFiles, sourceFiles'
, SourceFilesException(..)
+ , sourceFileDB, sourceFileMinio
+ , acceptFile
) where
import Import
import qualified Data.Conduit.Combinators as C
+import qualified Data.Conduit.List as C (unfoldM)
import Handler.Utils.Minio
import qualified Network.Minio as Minio
-import qualified Data.ByteString.Base64.URL as Base64
-import qualified Data.ByteArray as ByteArray
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import System.FilePath (normalise, makeValid)
+import Data.List (dropWhileEnd)
data SourceFilesException
@@ -22,36 +28,82 @@ data SourceFilesException
deriving anyclass (Exception)
-sourceFiles :: ConduitT FileReference File (YesodDB UniWorX) ()
-sourceFiles = C.mapM sourceFile
+sourceFileDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX)
+ => FileContentReference -> ConduitT () ByteString (SqlPersistT m) ()
+sourceFileDB fileReference = do
+ dbChunksize <- getsYesod $ view _appFileUploadDBChunksize
+ let retrieveChunk chunkHash = \case
+ Nothing -> return Nothing
+ Just start -> do
+ chunk <- E.selectMaybe . E.from $ \fileContentChunk -> do
+ E.where_ $ fileContentChunk E.^. FileContentChunkId E.==. E.val chunkHash
+ return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize)
+ case chunk of
+ Nothing -> throwM SourceFilesContentUnavailable
+ Just (E.Value c) -> return . Just . (c, ) $ if
+ | olength c >= dbChunksize -> Just $ start + dbChunksize
+ | otherwise -> Nothing
+ chunkHashes = E.selectSource . E.from $ \fileContentEntry -> do
+ E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference
+ E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryIx ]
+ return $ fileContentEntry E.^. FileContentEntryChunkHash
+ chunkHashes .| C.map E.unValue .| awaitForever (\chunkHash -> C.unfoldM (retrieveChunk chunkHash) $ Just (1 :: Int))
-sourceFile :: FileReference -> DB File
-sourceFile FileReference{..} = do
- mFileContent <- traverse get $ FileContentKey <$> fileReferenceContent
- fileContent <- if
- | is (_Just . _Nothing) mFileContent
- , Just fileContentHash <- fileReferenceContent -- Not a restriction
- -> maybeT (throwM SourceFilesContentUnavailable) $ do
- let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
- uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
- fmap Just . hoistMaybe <=< runAppMinio . runMaybeT $ do
- objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions
- lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
- | fmap (fmap fileContentHash) mFileContent /= fmap Just fileReferenceContent
- -> throwM SourceFilesMismatchedHashes
- | Just fileContent' <- fileContentContent <$> join mFileContent
- -> return $ Just fileContent'
- | otherwise
- -> return Nothing
- return File
- { fileTitle = fileReferenceTitle
- , fileContent
- , fileModified = fileReferenceModified
- }
+sourceFileMinio :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
+ => FileContentReference -> ConduitT () ByteString m ()
+sourceFileMinio fileReference = do
+ chunkVar <- newEmptyTMVarIO
+ minioAsync <- lift . allocateLinkedAsync $
+ maybeT (throwM SourceFilesContentUnavailable) $ do
+ let uploadName = minioFileReference # fileReference
+ uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
+ hoistMaybe <=< runAppMinio . runMaybeT $ do
+ objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket uploadName Minio.defaultGetObjectOptions
+ lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar)
+ let go = do
+ mChunk <- atomically $ Right <$> takeTMVar chunkVar
+ <|> Left <$> waitCatchSTM minioAsync
+ case mChunk of
+ Right chunk -> yield chunk >> go
+ Left (Right ()) -> return ()
+ Left (Left exc) -> throwM exc
+ in go
-sourceFiles' :: forall file. HasFileReference file => ConduitT file File (YesodDB UniWorX) ()
-sourceFiles' = C.mapM sourceFile'
-sourceFile' :: forall file. HasFileReference file => file -> DB File
+sourceFiles :: Monad m => ConduitT FileReference DBFile m ()
+sourceFiles = C.map sourceFile
+
+sourceFile :: FileReference -> DBFile
+sourceFile FileReference{..} = File
+ { fileTitle = fileReferenceTitle
+ , fileModified = fileReferenceModified
+ , fileContent = toFileContent <$> fileReferenceContent
+ }
+ where
+ toFileContent fileReference
+ | fileReference == $$(liftTyped $ FileContentReference $$(emptyHash))
+ = return ()
+ toFileContent fileReference = do
+ inDB <- lift . E.selectExists . E.from $ \fileContentEntry -> E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference
+ bool sourceFileMinio sourceFileDB inDB fileReference
+
+sourceFiles' :: forall file m. (HasFileReference file, Monad m) => ConduitT file DBFile m ()
+sourceFiles' = C.map sourceFile'
+
+sourceFile' :: forall file. HasFileReference file => file -> DBFile
sourceFile' = sourceFile . view (_FileReference . _1)
+
+
+acceptFile :: (MonadResource m, MonadResource m') => FileInfo -> m (File m')
+acceptFile fInfo = do
+ let fileTitle = "." unpack (fileName fInfo)
+ & normalise
+ & makeValid
+ & dropWhile isPathSeparator
+ & dropWhileEnd isPathSeparator
+ & normalise
+ & makeValid
+ fileContent = Just $ fileSource fInfo
+ fileModified <- liftIO getCurrentTime
+ return File{..}
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 68f9f68a0..4be16133b 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -32,7 +32,7 @@ import Yesod.Form.Bootstrap3
import Handler.Utils.Zip
import qualified Data.Conduit.Combinators as C
-import qualified Data.Conduit.List as C (mapMaybe)
+import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
@@ -831,7 +831,10 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp
uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT FileReference ByteString m ()
-uploadContents = transPipe (liftHandler . runDB) sourceFiles .| C.mapMaybe fileContent
+uploadContents = transPipe (liftHandler . runDB) sourceFiles .| C.mapMaybeM fileContent'
+ where fileContent' f = runMaybeT $ do
+ File{fileContent = Just fc} <- return f
+ liftHandler . runDB . runConduit $ fc .| C.fold
data FileFieldUserOption a = FileFieldUserOption
{ fieldOptionForce :: Bool
@@ -893,11 +896,21 @@ genericFileField mkOpts = Field{..}
, Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) fieldAdditionalFiles
]
- handleUpload :: FileField -> Maybe Text -> ConduitT File FileReference (YesodDB UniWorX) ()
+ handleUpload :: FileField -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) ()
handleUpload FileField{fieldMaxFileSize} mIdent
- = C.filter (\File{..} -> maybe (const True) (>) fieldMaxFileSize $ maybe 0 (fromIntegral . olength) fileContent)
- .| sinkFiles
- .| C.mapM mkSessionFile
+ = C.map (transFile liftHandler)
+ .| C.mapMaybeM (\f@File{..} -> maybeT (return $ Just f) $ do
+ maxSize <- fromIntegral <$> hoistMaybe fieldMaxFileSize
+ fc <- hoistMaybe fileContent
+ let peekNE n = do
+ str <- C.takeE n .| C.fold
+ leftover str
+ yield str
+ (unsealConduitT -> fc', size) <- lift $ fc $$+ peekNE (succ maxSize) .| C.lengthE
+ return . guardOn (size <= maxSize) $ f { fileContent = Just fc' }
+ )
+ .| sinkFiles
+ .| C.mapM mkSessionFile
where
mkSessionFile fRef@FileReference{..} = fRef <$ do
now <- liftIO getCurrentTime
@@ -924,7 +937,7 @@ genericFileField mkOpts = Field{..}
doUnpack
| fieldOptionForce fieldUnpackZips = fieldOptionDefault fieldUnpackZips
| otherwise = unpackZips `elem` vals
- handleFile :: FileInfo -> ConduitT () File Handler ()
+ handleFile :: FileInfo -> ConduitT () (File Handler) Handler ()
handleFile
| doUnpack = receiveFiles
| otherwise = yieldM . acceptFile
diff --git a/src/Handler/Utils/LdapSystemFunctions.hs b/src/Handler/Utils/LdapSystemFunctions.hs
new file mode 100644
index 000000000..c87b3f252
--- /dev/null
+++ b/src/Handler/Utils/LdapSystemFunctions.hs
@@ -0,0 +1,13 @@
+module Handler.Utils.LdapSystemFunctions
+ ( determineSystemFunctions
+ ) where
+
+import Import.NoFoundation
+
+import qualified Data.Set as Set
+
+
+determineSystemFunctions :: Set (CI Text) -> (SystemFunction -> Bool)
+determineSystemFunctions ldapFuncs = \case
+ SystemExamOffice -> False
+ SystemFaculty -> "faculty" `Set.member` ldapFuncs
diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs
index 85038a894..18785044c 100644
--- a/src/Handler/Utils/Mail.hs
+++ b/src/Handler/Utils/Mail.hs
@@ -12,9 +12,7 @@ import Handler.Utils.Files
import qualified Data.CaseInsensitive as CI
-import qualified Data.ByteString.Lazy as LBS
-
-import qualified Data.Conduit.List as C
+import qualified Data.Conduit.Combinators as C
import qualified Text.Pandoc as P
@@ -72,12 +70,13 @@ addFileDB :: ( MonadMail m
, HandlerSite m ~ UniWorX
) => FileReference -> m (Maybe MailObjectId)
addFileDB fRef = runMaybeT $ do
- File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- lift . liftHandler . runDB $ sourceFile fRef
+ File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent'} <- return $ sourceFile fRef
+ fileContent <- liftHandler . runDB . runConduit $ fileContent' .| C.sinkLazy
lift . addPart $ do
_partType .= decodeUtf8 (mimeLookup fileName)
_partEncoding .= Base64
_partDisposition .= AttachmentDisposition fileName
- _partContent .= PartContent (LBS.fromStrict fileContent)
+ _partContent .= PartContent fileContent
setMailObjectIdPseudorandom (fileName, fileContent) :: StateT Part (HandlerFor UniWorX) MailObjectId
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index 5a82c8921..ef65892b0 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -16,11 +16,9 @@ import Handler.Utils.DateTime (getDateTimeFormatter)
import qualified Data.Text as Text
-import qualified Data.ByteString.Lazy as Lazy.ByteString
-
import qualified Database.Esqueleto as E
-import qualified Data.Conduit.List as Conduit
+import qualified Data.Conduit.Combinators as C
import Handler.Utils.Rating.Format
@@ -91,15 +89,16 @@ extensionRating = "txt"
ratingFile :: ( MonadHandler m
, HandlerSite m ~ UniWorX
+ , Monad m'
)
- => CryptoFileNameSubmission -> Rating -> m File
+ => CryptoFileNameSubmission -> Rating -> m (File m')
ratingFile cID rating@Rating{ ratingValues = Rating'{..} } = do
mr'@(MsgRenderer mr) <- getMsgRenderer
dtFmt <- getDateTimeFormatter
fileModified <- maybe (liftIO getCurrentTime) return ratingTime
let
fileTitle = ensureExtension extensionRating . unpack . mr $ MsgRatingFileTitle cID
- fileContent = Just . Lazy.ByteString.toStrict $ formatRating mr' dtFmt cID rating
+ fileContent = Just . C.sourceLazy $ formatRating mr' dtFmt cID rating
return File{..}
type SubmissionContent = Either FileReference (SubmissionId, Rating')
@@ -107,13 +106,12 @@ type SubmissionContent = Either FileReference (SubmissionId, Rating')
extractRatings :: ( MonadHandler m
, HandlerSite m ~ UniWorX
) => ConduitT FileReference SubmissionContent m ()
-extractRatings = Conduit.mapM $ \fRef@FileReference{..} -> liftHandler $ do
+extractRatings = C.mapM $ \fRef@FileReference{..} -> liftHandler $ do
msId <- isRatingFile fileReferenceTitle
if
| Just sId <- msId
, isJust fileReferenceContent -> do
- f <- runDB $ sourceFile fRef
- (rating, cID) <- handle (throwM . RatingFileException fileReferenceTitle) $ parseRating f
+ (rating, cID) <- handle (throwM . RatingFileException fileReferenceTitle) . runDB . parseRating $ sourceFile fRef
sId' <- traverse decrypt cID
unless (maybe (const True) (==) sId' sId) $
throwM $ RatingFileException fileReferenceTitle RatingSubmissionIDIncorrect
diff --git a/src/Handler/Utils/Rating/Format.hs b/src/Handler/Utils/Rating/Format.hs
index fd8ab2fb5..e7cd03568 100644
--- a/src/Handler/Utils/Rating/Format.hs
+++ b/src/Handler/Utils/Rating/Format.hs
@@ -35,6 +35,8 @@ import qualified System.FilePath.Cryptographic as Explicit
import Control.Exception (ErrorCall(..))
+import qualified Data.Conduit.Combinators as C
+
data PrettifyState
= PrettifyInitial
@@ -195,8 +197,9 @@ instance ns ~ CryptoIDNamespace (CI FilePath) SubmissionId => YAML.FromYAML (May
)
-parseRating :: MonadCatch m => File -> m (Rating', Maybe CryptoFileNameSubmission)
-parseRating f@File{ fileContent = Just (fromStrict -> input), .. } = handle onFailure . handle (throwM . RatingParseException) . handleIf isYAMLUnicodeError (\(ErrorCall msg) -> throwM $ RatingYAMLNotUnicode msg) $ do
+parseRating :: MonadCatch m => File m -> m (Rating', Maybe CryptoFileNameSubmission)
+parseRating f@File{ fileContent = Just input', .. } = handle onFailure . handle (throwM . RatingParseException) . handleIf isYAMLUnicodeError (\(ErrorCall msg) -> throwM $ RatingYAMLNotUnicode msg) $ do
+ input <- runConduit $ input' .| C.sinkLazy
let evStream = YAML.Event.parseEvents input
delimitDocument = do
ev <- maybe (throwM RatingYAMLStreamTerminatedUnexpectedly) return =<< await
diff --git a/src/Handler/Utils/Rating/Format/Legacy.hs b/src/Handler/Utils/Rating/Format/Legacy.hs
index bd523d06a..c027e1b07 100644
--- a/src/Handler/Utils/Rating/Format/Legacy.hs
+++ b/src/Handler/Utils/Rating/Format/Legacy.hs
@@ -16,6 +16,8 @@ import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.CaseInsensitive as CI
+import qualified Data.Conduit.Combinators as C
+
import Text.Read (readEither)
@@ -55,9 +57,9 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
]
in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc
-parseRating :: MonadCatch m => File -> m Rating'
+parseRating :: MonadCatch m => File m -> m Rating'
parseRating File{ fileContent = Just input, .. } = handle (throwM . RatingParseLegacyException) $ do
- inputText <- either (throwM . RatingNotUnicode) return $ Text.decodeUtf8' input
+ inputText <- either (throwM . RatingNotUnicode) return . Text.decodeUtf8' =<< runConduit (input .| C.fold)
let
(headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText
(reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs
index 52d59082f..f4d146d11 100644
--- a/src/Handler/Utils/StudyFeatures.hs
+++ b/src/Handler/Utils/StudyFeatures.hs
@@ -1,68 +1,150 @@
module Handler.Utils.StudyFeatures
- ( parseStudyFeatures
- , parseSubTermsSemester
+ ( module Handler.Utils.StudyFeatures.Parse
+ , UserTableStudyFeature(..)
+ , _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType
+ , UserTableStudyFeatures(..)
+ , _UserTableStudyFeatures
+ , isRelevantStudyFeature
+ , isCourseStudyFeature, courseUserStudyFeatures
+ , isExternalExamStudyFeature, externalExamUserStudyFeatures
) where
-import Import.NoFoundation hiding (try, (<|>))
+import Import.NoFoundation
+import Foundation.Type
+import Foundation.I18n
-import Text.Parsec
-import Text.Parsec.Text
+import Handler.Utils.StudyFeatures.Parse
-import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures)
-import qualified Ldap.Client as Ldap
+import qualified Data.Csv as Csv
+
+import qualified Data.ByteString as ByteString
+
+import qualified Data.Set as Set
+
+import Data.RFC5051 (compareUnicode)
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
-parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures]
-parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key)
- where
- Ldap.Attr key = ldapUserStudyFeatures
+data UserTableStudyFeature = UserTableStudyFeature
+ { userTableField
+ , userTableDegree :: Text
+ , userTableSemester :: Int
+ , userTableFieldType :: StudyFieldType
+ } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+makeLenses_ ''UserTableStudyFeature
-parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int)
-parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key)
- where
- Ldap.Attr key = ldapUserSubTermsSemester
+deriveJSON defaultOptions
+ { fieldLabelModifier = camelToPathPiece' 2
+ } ''UserTableStudyFeature
+
+newtype UserTableStudyFeatures = UserTableStudyFeatures (Set UserTableStudyFeature)
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ deriving newtype ( ToJSON, FromJSON
+ , Semigroup, Monoid
+ )
+makeWrapped ''UserTableStudyFeatures
+
+_UserTableStudyFeatures :: Iso' UserTableStudyFeatures [UserTableStudyFeature]
+_UserTableStudyFeatures = iso (sortBy userTableStudyFeatureSort . Set.toList . view _Wrapped) (UserTableStudyFeatures . Set.fromList)
+
+instance Csv.ToField UserTableStudyFeature where
+ toField UserTableStudyFeature{..} = encodeUtf8
+ [st|#{userTableField} #{userTableDegree} (#{userTableFieldType'} #{tshow userTableSemester})|]
+ where userTableFieldType' = renderMessage
+ (error "Foundation inspected during renderMessage" :: UniWorX)
+ [] $ ShortStudyFieldType userTableFieldType
+
+instance Csv.ToField UserTableStudyFeatures where
+ toField = ByteString.intercalate "; " . map Csv.toField . view _UserTableStudyFeatures
+
+userTableStudyFeatureSort :: UserTableStudyFeature
+ -> UserTableStudyFeature
+ -> Ordering
+userTableStudyFeatureSort = mconcat
+ [ compareUnicode `on` userTableDegree
+ , comparing userTableSemester
+ , comparing userTableFieldType
+ , compareUnicode `on` userTableField
+ ]
-pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
-pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
- studyFeaturesDegree <- StudyDegreeKey' <$> pKey
- void $ string "$$"
+isRelevantStudyFeature :: PersistEntity record
+ => EntityField record TermId
+ -> E.SqlExpr (Entity record)
+ -> E.SqlExpr (Entity StudyFeatures)
+ -> E.SqlExpr (E.Value Bool)
+isRelevantStudyFeature termField record studyFeatures
+ = ( ( overlap studyFeatures E.>. E.val 0
+ E.||. ( E.just (studyFeatures E.^. StudyFeaturesLastObserved) E.==. studyFeatures E.^. StudyFeaturesFirstObserved
+ E.&&. termStart E.<=. E.day (studyFeatures E.^. StudyFeaturesLastObserved)
+ E.&&. E.day (studyFeatures E.^. StudyFeaturesLastObserved) E.<=. termEnd
+ )
+ )
+ E.&&. E.not_ (E.exists betterOverlap)
+ )
+ E.||. ( E.subSelectForeign record termField (E.^. TermActive)
+ E.&&. E.not_ (E.exists anyOverlap)
+ E.&&. studyFeatures E.^. StudyFeaturesValid
+ )
+ where termEnd = E.subSelectForeign record termField (E.^. TermEnd)
+ termStart = E.subSelectForeign record termField (E.^. TermStart)
- let
- pStudyFeature = do
- _ <- pKey -- "Fächergruppe"
- void $ char '!'
- _ <- pKey -- "Studienbereich"
- void $ char '!'
- studyFeaturesField <- StudyTermsKey' <$> pKey
- void $ char '!'
- studyFeaturesType <- pType
- void $ char '!'
- studyFeaturesSemester <- decimal
- let studyFeaturesValid = True
- studyFeaturesSuperField = Nothing
- return StudyFeatures{..}
+ overlap :: E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Int)
+ overlap studyFeatures'
+ = E.min (E.day $ studyFeatures' E.^. StudyFeaturesLastObserved) termEnd
+ `E.diffDays` E.maybe termStart (E.max termStart . E.day) (studyFeatures' E.^. StudyFeaturesFirstObserved)
- pStudyFeature `sepBy1` char '#'
+ anyOverlap = E.from $ \studyFeatures' -> do
+ E.where_ $ studyFeatures' E.^. StudyFeaturesUser E.==. studyFeatures E.^. StudyFeaturesUser
+ E.where_ $ overlap studyFeatures' E.>. E.val 0
-pKey :: Parser Int
-pKey = decimal
+ betterOverlap = E.from $ \studyFeatures' -> do
+ E.where_ $ studyFeatures' E.^. StudyFeaturesUser E.==. studyFeatures E.^. StudyFeaturesUser
+ E.&&. studyFeatures' E.^. StudyFeaturesDegree E.==. studyFeatures E.^. StudyFeaturesDegree
+ E.&&. studyFeatures' E.^. StudyFeaturesField E.==. studyFeatures E.^. StudyFeaturesField
+ E.&&. studyFeatures' E.^. StudyFeaturesSuperField `E.maybeEq` studyFeatures E.^. StudyFeaturesSuperField
+ E.&&. studyFeatures' E.^. StudyFeaturesType E.==. studyFeatures E.^. StudyFeaturesType
+ E.where_ $ E.abs (studyFeatures' E.^. StudyFeaturesSemester E.-. studyFeatures E.^. StudyFeaturesSemester) E.==. E.val 1
+ E.&&. overlap studyFeatures' E.>. overlap studyFeatures
-pType :: Parser StudyFieldType
-pType = FieldPrimary <$ try (string "HF")
- <|> FieldSecondary <$ try (string "NF")
+isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
+isCourseStudyFeature = isRelevantStudyFeature CourseTerm
-decimal :: Parser Int
-decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'
- where
- digit' = dVal <$> digit
- dVal c = fromEnum c - fromEnum '0'
+courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures
+courseUserStudyFeatures cId uid = do
+ feats <- E.select . E.from $ \(course `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do
+ E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
+ E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
+ E.on $ isCourseStudyFeature course studyFeatures
+ E.where_ $ course E.^. CourseId E.==. E.val cId
+ E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
+ return (terms, degree, studyFeatures)
+ return . UserTableStudyFeatures . Set.fromList . flip map feats $
+ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature
+ { userTableField = fromMaybe (tshow studyTermsKey) studyTermsName
+ , userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
+ , userTableSemester = studyFeaturesSemester
+ , userTableFieldType = studyFeaturesType
+ }
+isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
+isExternalExamStudyFeature = isRelevantStudyFeature ExternalExamTerm
-pLMUTermsSemester :: Parser (StudyTermsId, Int)
-pLMUTermsSemester = do
- subTermsKey <- StudyTermsKey' <$> pKey
- void $ char '$'
- semester <- decimal
-
- return (subTermsKey, semester)
+externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures
+externalExamUserStudyFeatures eeId uid = do
+ feats <- E.select . E.from $ \(externalExam `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do
+ E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
+ E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
+ E.on $ isExternalExamStudyFeature externalExam studyFeatures
+ E.where_ $ externalExam E.^. ExternalExamId E.==. E.val eeId
+ E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
+ return (terms, degree, studyFeatures)
+ return . UserTableStudyFeatures . Set.fromList . flip map feats $
+ \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature
+ { userTableField = fromMaybe (tshow studyTermsKey) studyTermsName
+ , userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
+ , userTableSemester = studyFeaturesSemester
+ , userTableFieldType = studyFeaturesType
+ }
diff --git a/src/Handler/Utils/StudyFeatures/Parse.hs b/src/Handler/Utils/StudyFeatures/Parse.hs
new file mode 100644
index 000000000..3001c258f
--- /dev/null
+++ b/src/Handler/Utils/StudyFeatures/Parse.hs
@@ -0,0 +1,70 @@
+module Handler.Utils.StudyFeatures.Parse
+ ( parseStudyFeatures
+ , parseSubTermsSemester
+ ) where
+
+import Import.NoFoundation hiding (try, (<|>))
+
+import Text.Parsec
+import Text.Parsec.Text
+
+import Auth.LDAP (ldapUserSubTermsSemester, ldapUserStudyFeatures)
+import qualified Ldap.Client as Ldap
+
+
+parseStudyFeatures :: UserId -> UTCTime -> Text -> Either ParseError [StudyFeatures]
+parseStudyFeatures uId now = parse (pStudyFeatures uId now <* eof) (unpack key)
+ where
+ Ldap.Attr key = ldapUserStudyFeatures
+
+parseSubTermsSemester :: Text -> Either ParseError (StudyTermsId, Int)
+parseSubTermsSemester = parse (pLMUTermsSemester <* eof) (unpack key)
+ where
+ Ldap.Attr key = ldapUserSubTermsSemester
+
+
+pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
+pStudyFeatures studyFeaturesUser now = do
+ studyFeaturesDegree <- StudyDegreeKey' <$> pKey
+ void $ string "$$"
+
+ let
+ pStudyFeature = do
+ _ <- pKey -- "Fächergruppe"
+ void $ char '!'
+ _ <- pKey -- "Studienbereich"
+ void $ char '!'
+ studyFeaturesField <- StudyTermsKey' <$> pKey
+ void $ char '!'
+ studyFeaturesType <- pType
+ void $ char '!'
+ studyFeaturesSemester <- decimal
+ let studyFeaturesValid = True
+ studyFeaturesSuperField = Nothing
+ studyFeaturesFirstObserved = Just now
+ studyFeaturesLastObserved = now
+ return StudyFeatures{..}
+
+ pStudyFeature `sepBy1` char '#'
+
+pKey :: Parser Int
+pKey = decimal
+
+pType :: Parser StudyFieldType
+pType = FieldPrimary <$ try (string "HF")
+ <|> FieldSecondary <$ try (string "NF")
+
+decimal :: Parser Int
+decimal = foldl' (\now next -> now * 10 + next) 0 <$> many1 digit'
+ where
+ digit' = dVal <$> digit
+ dVal c = fromEnum c - fromEnum '0'
+
+
+pLMUTermsSemester :: Parser (StudyTermsId, Int)
+pLMUTermsSemester = do
+ subTermsKey <- StudyTermsKey' <$> pKey
+ void $ char '$'
+ semester <- decimal
+
+ return (subTermsKey, semester)
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 13ac4d067..2dcac8f28 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -256,7 +256,7 @@ planSubmissions sid restriction = do
maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs
-submissionFileSource :: SubmissionId -> ConduitT () File (YesodDB UniWorX) ()
+submissionFileSource :: SubmissionId -> ConduitT () DBFile (YesodDB UniWorX) ()
submissionFileSource subId = E.selectSource (E.from $ submissionFileQuery subId)
.| C.map entityVal
.| sourceFiles'
@@ -319,7 +319,7 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
setContentDisposition' $ Just ((addExtension `on` unpack) (mr archiveName) extensionZip)
respondSource typeZip . (<* lift cleanup) . transPipe (runDBRunner dbrunner) $ do
let
- fileEntitySource' :: (Rating, Entity Submission, Maybe UTCTime, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) ()
+ fileEntitySource' :: (Rating, Entity Submission, Maybe UTCTime, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () DBFile (YesodDB UniWorX) ()
fileEntitySource' (rating, Entity submissionID Submission{}, subTime, (shn,csh,ssh,tid,sheetAnonymous)) = do
cID <- encrypt submissionID
diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs
index b3329f0c5..3d66fcace 100644
--- a/src/Handler/Utils/Table/Columns.hs
+++ b/src/Handler/Utils/Table/Columns.hs
@@ -24,6 +24,7 @@ import Handler.Utils.Table.Pagination
import Handler.Utils.Form
import Handler.Utils.Widgets
import Handler.Utils.DateTime
+import Handler.Utils.StudyFeatures
import qualified Data.CaseInsensitive as CI
@@ -778,6 +779,64 @@ fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map Fil
fltrDegreeUI mPrev =
prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName)
+
+colStudyFeatures :: OpticColonnade UserTableStudyFeatures
+colStudyFeatures resultFeatures = Colonnade.singleton (fromSortable header) body
+ where
+ header = Sortable Nothing (i18nCell MsgColumnStudyFeatures)
+ body = views (resultFeatures . _UserTableStudyFeatures) . flip listCell $ \UserTableStudyFeature{..} -> cell $(widgetFile "table/cell/user-study-feature")
+
+fltrRelevantStudyFeaturesTerms :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
+fltrRelevantStudyFeaturesTerms queryTermUser = singletonMap "features-terms" . FilterColumn $ \t criterias ->
+ E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do
+ E.on $ isRelevantStudyFeature TermId term studyFeatures
+
+ let (tid, uid) = t ^. queryTermUser
+ E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid
+ E.&&. term E.^. TermId E.==. tid
+
+ return $ anyFilter
+ [ mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesField (E.^. StudyTermsName)
+ , mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesField (E.^. StudyTermsShorthand)
+ , mkExactFilterWith readMay $ \t' -> E.subSelectForeign t' StudyFeaturesField $ E.just . (E.^. StudyTermsKey)
+ ] studyFeatures criterias
+
+fltrRelevantStudyFeaturesTermsUI :: DBFilterUI
+fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI
+
+fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
+fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias ->
+ E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do
+ E.on $ isRelevantStudyFeature TermId term studyFeatures
+
+ let (tid, uid) = t ^. queryTermUser
+ E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid
+ E.&&. term E.^. TermId E.==. tid
+
+ return $ anyFilter
+ [ mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesDegree (E.^. StudyDegreeName)
+ , mkContainsFilterWith Just $ \t' -> E.subSelectForeign t' StudyFeaturesDegree (E.^. StudyDegreeShorthand)
+ , mkExactFilterWith readMay $ \t' -> E.subSelectForeign t' StudyFeaturesDegree $ E.just . (E.^. StudyDegreeKey)
+ ] studyFeatures criterias
+
+fltrRelevantStudyFeaturesDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+fltrRelevantStudyFeaturesDegreeUI mPrev =
+ prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgDegreeName)
+
+fltrRelevantStudyFeaturesSemester :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId))
+fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias ->
+ E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do
+ E.on $ isRelevantStudyFeature TermId term studyFeatures
+
+ let (tid, uid) = t ^. queryTermUser
+ E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid
+ E.&&. term E.^. TermId E.==. tid
+
+ return $ mkExactFilterWith (readMay :: Text -> Maybe Int) (E.just . (E.^. StudyFeaturesSemester)) studyFeatures criterias
+
+fltrRelevantStudyFeaturesSemesterUI :: DBFilterUI
+fltrRelevantStudyFeaturesSemesterUI = fltrFeaturesSemesterUI
+
-----------------
-- Allocations --
-----------------
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index ce1767303..0bba1059d 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -74,7 +74,6 @@ import Control.Monad.State (evalStateT, execStateT)
import Control.Monad.Trans.Maybe
import Control.Monad.State.Class (modify)
import qualified Control.Monad.State.Class as State
-import Control.Monad.Trans.Writer.Lazy (censor)
import Data.Map ((!))
import qualified Data.Map as Map
@@ -1277,22 +1276,22 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
_other -> False
genHeaders :: forall h. Cornice h _ _ (DBCell m x) -> SortableP h -> WriterT x m Widget
- genHeaders cornice SortableP{..} = execWriterT . go mempty $ annotate cornice
+ genHeaders cornice SortableP{..} = fmap wrap' . execWriterT . go mempty $ annotate cornice
where
go :: forall (p' :: Pillar) r'.
[(Int, Int, Int)]
-> AnnotatedCornice (Maybe Int) h p' r' (DBCell m x)
- -> WriterT Widget (WriterT x m) ()
- go rowspanAcc (AnnotatedCorniceBase _ (Colonnade (toList -> v))) = censor wrap . forM_ (zip (inits v) v) $ \(before, OneColonnade Sized{..} _) -> do
+ -> WriterT (Seq (Seq (Widget, Int))) (WriterT x m) ()
+ go rowspanAcc (AnnotatedCorniceBase _ (Colonnade (toList -> v))) = mapWriterT (over (mapped . _2) pure) . forM_ (zip (inits v) v) $ \(before, OneColonnade Sized{..} _) -> do
let (_, cellSize') = compCellSize rowspanAcc (map oneColonnadeHead before) Sized{..}
- whenIsJust cellSize' $ \cellSize -> tellM $ fromContent Sized { sizedSize = cellSize, sizedContent }
+ whenIsJust cellSize' $ \cellSize -> tellM . fmap pure $ fromContent Sized { sizedSize = cellSize, sizedContent }
go rowspanAcc (AnnotatedCorniceCap _ v@(toList -> oneCornices)) = do
- rowspanAcc' <- (execStateT ?? rowspanAcc) . hoist (censor wrap) . forM_ (zip (inits oneCornices) oneCornices) $ \(before, OneCornice h (size -> sz')) -> do
+ rowspanAcc' <- (execStateT ?? rowspanAcc) . hoist (mapWriterT $ over (mapped . _2) pure) . forM_ (zip (inits oneCornices) oneCornices) $ \(before, OneCornice h (size -> sz')) -> do
let sz = Sized sz' h
let (beforeSize, cellSize') = compCellSize rowspanAcc (concatMap (map oneColonnadeHead . toList . getColonnade . uncapAnnotated . oneCorniceBody) before) sz
whenIsJust cellSize' $ \cellSize -> do
let Sized{..} = sz
- lift . tellM $ fromContent Sized { sizedSize = cellSize, sizedContent }
+ lift . tellM . fmap pure $ fromContent Sized { sizedSize = cellSize, sizedContent }
if | [n] <- mapMaybe (\(key, val) -> guardOnM (is _Rowspan key) $ readMay val) (toSortable sizedContent ^. _sortableContent . cellAttrs)
-> State.modify $ (:) (n, beforeSize, cellSize)
| otherwise -> return ()
@@ -1309,11 +1308,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
guard $ beforeSize < firstCol + sz
return . Sum $ sz - (beforeSize - firstCol)
- wrap :: Widget -> Widget
- wrap row = case dbsTemplate of
+ wrap' :: Seq (Seq (Widget, Int)) -> Widget
+ wrap' wRows = view _2 $ Foldable.foldl (\(stackHeight', acc) row -> (Nothing, (acc <>) . wrap stackHeight' $ foldOf (folded . _1) row)) (stackHeight, mempty) wRows
+ where stackHeight = Just $ length wRows
+ wrap :: Maybe Int -> Widget -> Widget
+ wrap stackHeight row = case dbsTemplate of
DBSTCourse{} -> row
DBSTDefault{} -> $(widgetFile "table/header")
- fromContent :: Sized Int h (DBCell m x) -> WriterT x m Widget
+ fromContent :: Sized Int h (DBCell m x) -> WriterT x m (Widget, Int)
fromContent Sized{ sizedSize = cellSize, sizedContent = toSortable -> Sortable{..} } = do
widget <- sortableContent ^. cellContents
let
@@ -1322,9 +1324,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
isSorted dir = fromMaybe False $ (==) <$> (SortingSetting <$> sortableKey <*> pure dir) <*> listToMaybe psSorting
attrs = sortableContent ^. cellAttrs
piSorting' = [ sSet | sSet <- fromMaybe [] piSorting, Just (sortKey sSet) /= sortableKey ]
- case dbsTemplate of
- DBSTCourse{} -> return $(widgetFile "table/course/header")
- DBSTDefault{} -> return $(widgetFile "table/cell/header")
+ rowspan = preview _head $ do
+ (key, val) <- attrs
+ guard $ is _Rowspan key
+ hoistMaybe $ readMay val
+ return . (, fromMaybe 1 rowspan) $ case dbsTemplate of
+ DBSTCourse{} -> $(widgetFile "table/course/header")
+ DBSTDefault{} -> $(widgetFile "table/cell/header")
in do
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders (dbtColonnade ^. _Cornice)) pSortable
now <- liftIO getCurrentTime
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index 9e55182cf..210a45b06 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -135,7 +135,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
ldapPool' <- getsYesod $ view _appLdapPool
fmap join . for ldapPool' $ \ldapPool -> do
ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
- for ldapData $ upsertCampusUser UpsertCampusUser
+ for ldapData $ upsertCampusUser UpsertCampusUserGuessUser
let
getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation
diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs
index 255d8f93b..70147cbd2 100644
--- a/src/Handler/Utils/Zip.hs
+++ b/src/Handler/Utils/Zip.hs
@@ -13,17 +13,14 @@ module Handler.Utils.Zip
import Import
+import Handler.Utils.Files (acceptFile)
+import Handler.Utils.DateTime (localTimeToUTCSimple, utcToLocalTime)
+
import Codec.Archive.Zip.Conduit.Types
import Codec.Archive.Zip.Conduit.UnZip
import Codec.Archive.Zip.Conduit.Zip
--- import qualified Data.ByteString.Lazy as Lazy (ByteString)
-import qualified Data.ByteString.Lazy as Lazy.ByteString
-
-import qualified Data.ByteString as ByteString
-
import System.FilePath
-import Data.Time.LocalTime (localTimeToUTC, utcToLocalTime)
import Data.List (dropWhileEnd)
@@ -38,6 +35,10 @@ import Data.Encoding ( decodeStrictByteStringExplicit
import Data.Encoding.CP437
import qualified Data.Char as Char
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.State.Strict (evalStateT)
+import qualified Control.Monad.State.Class as State
+
typeZip :: ContentType
typeZip = "application/zip"
@@ -53,94 +54,157 @@ instance Default ZipInfo where
}
-consumeZip :: forall b m.
- ( MonadThrow b
- , MonadThrow m
- , MonadBase b m
- , PrimMonad b
- )
- => ConduitT ByteString File m ZipInfo
-consumeZip = transPipe liftBase unZipStream `fuseUpstream` consumeZip'
- where
- consumeZip' :: ConduitT (Either ZipEntry ByteString) File m ()
- consumeZip' = do
- input <- await
- case input of
- Nothing -> return ()
- Just (Right _) -> throwM $ userError "Data chunk in unexpected place when parsing ZIP"
- Just (Left ZipEntry{..}) -> do
- contentChunks <- toConsumer accContents
- zipEntryName' <- decodeZipEntryName zipEntryName
- let
- fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise $ makeValid zipEntryName'
- fileModified = localTimeToUTC utc zipEntryTime
- fileContent
- | hasTrailingPathSeparator zipEntryName' = Nothing
- | otherwise = Just $ mconcat contentChunks
- yield File{..}
- consumeZip'
- accContents :: ConduitT (Either a b') Void m [b']
- accContents = do
- input <- await
- case input of
- Just (Right x) -> (x :) <$> accContents
- Just (Left x) -> [] <$ leftover (Left x)
- _ -> return []
+data ConsumeZipException
+ = ConsumeZipUnZipException SomeException
+ | ConsumeZipUnexpectedContent
+ deriving (Show, Generic, Typeable)
+ deriving anyclass (Exception)
-produceZip :: forall b m.
- ( MonadThrow b
- , MonadThrow m
- , MonadBase b m
- , PrimMonad b
+
+consumeZip :: forall m m'.
+ ( MonadThrow m
+ , PrimMonad m
+ , MonadUnliftIO m
+ , MonadResource m
+ , MonadIO m'
+ , MonadThrow m'
+ )
+ => ConduitT () ByteString m () -> ConduitT () (File m') m ZipInfo
+consumeZip inpBS = do
+ inpChunk <- liftIO newEmptyTMVarIO
+ zipAsync <- lift . allocateLinkedAsync $
+ runConduit $ (inpBS .| unZipStream) `fuseUpstream` C.mapM_ (atomically . putTMVar inpChunk)
+
+ flip evalStateT Nothing . evalContT . callCC $ \finishConsume -> forever $ do
+ inpChunk' <- atomically $
+ Right <$> takeTMVar inpChunk
+ <|> Left <$> waitCatchSTM zipAsync
+
+ fileSink <- State.get
+ case (fileSink, inpChunk') of
+ (mFSink , Left (Left unzipExc) ) -> do
+ for_ mFSink $ \fSink' -> atomically $ do
+ writeTMChan fSink' $ Left unzipExc
+ closeTMChan fSink'
+ throwM unzipExc
+
+ (mFSink , Left (Right zInfo) ) -> do
+ for_ mFSink $ atomically . closeTMChan
+ finishConsume zInfo
+
+ (Just fSink, Right (Right bs) ) ->
+ atomically . writeTMChan fSink $ Right bs
+
+ (Nothing , Right (Right _) ) ->
+ throwM ConsumeZipUnexpectedContent
+
+ (mFSink , Right (Left ZipEntry{..})) -> do
+ for_ mFSink $ atomically . closeTMChan
+ State.put Nothing
+
+ zipEntryName' <- decodeZipEntryName zipEntryName
+ let
+ fileTitle = "." zipEntryName'
+ & normalise
+ & makeValid
+ & dropWhile isPathSeparator
+ & dropWhileEnd isPathSeparator
+ & normalise
+ & makeValid
+ fileModified = localTimeToUTCSimple zipEntryTime
+ isDirectory = hasTrailingPathSeparator zipEntryName'
+ fileContent <- if
+ | isDirectory -> return Nothing
+ | otherwise -> do
+ fileChan <- liftIO newTMChanIO
+ State.put $ Just fileChan
+ return . Just . evalContT . callCC $ \finishFileContent -> forever $ do
+ nextVal <- atomically $ asum
+ [ readTMChan fileChan
+ , do
+ inpChunk'' <- Right <$> takeTMVar inpChunk
+ <|> Left <$> waitCatchSTM zipAsync
+ case inpChunk'' of
+ Left (Left unzipExc) -> return . Just $ Left unzipExc
+ Left (Right _ ) -> return Nothing
+ Right (Left zInfo ) -> Nothing <$ putTMVar inpChunk (Left zInfo)
+ Right (Right bs ) -> return . Just $ Right bs
+ ]
+ case nextVal of
+ Nothing -> finishFileContent ()
+ Just (Right bs) -> lift $ yield bs
+ Just (Left exc) -> throwM $ ConsumeZipUnZipException exc
+ lift . lift $ yield File{..}
+
+produceZip :: forall m.
+ ( MonadThrow m
+ , PrimMonad m
)
=> ZipInfo
- -> ConduitT File ByteString m ()
-produceZip info = C.map toZipData .| transPipe liftBase (void $ zipStream zipOptions)
+ -> ConduitT (File m) ByteString m ()
+produceZip info = C.map toZipData .| void (zipStream zipOptions)
where
zipOptions = ZipOptions
- { zipOpt64 = True
- , zipOptCompressLevel = -1 -- This is passed through all the way to the C zlib, where it means "default level"
+ { zipOpt64 = False
+ , zipOptCompressLevel = defaultCompression
, zipOptInfo = info
}
- toZipData :: File -> (ZipEntry, ZipData b)
- toZipData f@File{..} =
- let zData = maybe mempty (ZipDataByteString . Lazy.ByteString.fromStrict) fileContent
- zEntry = (toZipEntry f){ zipEntrySize = fromIntegral . ByteString.length <$> fileContent }
- in (zEntry, zData)
+ -- toZipData :: forall v. File m -> ConduitT v (ZipEntry, ZipData m) m ()
+ -- toZipData f
+ -- | Just fc <- fileContent f = do
+ -- outpChunk <- newEmptyTMVarIO
+ -- outpAsync <- lift . allocateLinkedAsync $
+ -- runConduit $ fc .| C.mapM_ (atomically . putTMVar outpChunk)
+ -- yield ( toZipEntry f
+ -- , ZipDataSource . evalContT . callCC $ \finishContent -> forever $ do
+ -- nextVal <- atomically $
+ -- Right <$> takeTMVar outpChunk
+ -- <|> Left <$> waitCatchSTM outpAsync
+ -- case nextVal of
+ -- Right chunk -> lift $ yield chunk
+ -- Left (Right () ) -> finishContent ()
+ -- Left (Left exc) -> throwM exc
+ -- )
+ -- | otherwise = yield (toZipEntry f, mempty)
- toZipEntry :: File -> ZipEntry
+ toZipData :: File m -> (ZipEntry, ZipData m)
+ toZipData f@File{..}
+ = (toZipEntry f, maybe mempty ZipDataSource fileContent)
+
+ toZipEntry :: File m -> ZipEntry
toZipEntry File{..} = ZipEntry{..}
where
- isDir = isNothing fileContent
+ isDir = is _Nothing fileContent
- zipEntryName = encodeZipEntryName . bool (dropWhileEnd isPathSeparator) addTrailingPathSeparator isDir . normalise $ makeValid fileTitle
- zipEntryTime = utcToLocalTime utc fileModified
+ zipEntryName = "." fileTitle
+ & normalise
+ & makeValid
+ & dropWhile isPathSeparator
+ & dropWhileEnd isPathSeparator
+ & bool id addTrailingPathSeparator isDir
+ & normalise
+ & makeValid
+ & encodeZipEntryName
+ zipEntryTime = utcToLocalTime fileModified
zipEntrySize = Nothing
zipEntryExternalAttributes = Nothing
-modifyFileTitle :: Monad m => (FilePath -> FilePath) -> ConduitT File File m ()
+modifyFileTitle :: Monad m => (FilePath -> FilePath) -> ConduitT (File m') (File m') m ()
modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
-- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
-receiveFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadBase IO m) => FileInfo -> ConduitT () File m ()
+receiveFiles :: (MonadLogger m, MonadResource m, MonadThrow m, PrimMonad m, MonadUnliftIO m, MonadResource m', MonadThrow m') => FileInfo -> ConduitT () (File m') m ()
receiveFiles fInfo
| ((==) `on` simpleContentType) mimeType typeZip = do
$logInfoS "sourceFiles" "Unpacking ZIP"
- fileSource fInfo .| void consumeZip
+ void . consumeZip $ fileSource fInfo
| otherwise = do
$logDebugS "sourceFiles" [st|Not unpacking file of type #{decodeUtf8 mimeType}|]
yieldM $ acceptFile fInfo
where
mimeType = mimeLookup $ fileName fInfo
-acceptFile :: MonadResource m => FileInfo -> m File
-acceptFile fInfo = do
- let fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise . unpack $ fileName fInfo
- fileModified <- liftIO getCurrentTime
- fileContent <- fmap Just . runConduit $ fileSource fInfo .| foldC
- return File{..}
-
decodeZipEntryName :: MonadThrow m => Either Text ByteString -> m FilePath
-- ^ Extract the filename from a 'ZipEntry' doing decoding along the way.
diff --git a/src/Import.hs b/src/Import.hs
index b387f44ad..b18a9fe1e 100644
--- a/src/Import.hs
+++ b/src/Import.hs
@@ -4,6 +4,7 @@ module Import
import Foundation as Import
import Import.NoFoundation as Import
+import Model.Migration as Import
import Utils.SystemMessage as Import
import Utils.Metrics as Import
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index 0fdedc192..b86de7350 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -4,7 +4,6 @@ module Import.NoFoundation
import Import.NoModel as Import
import Model as Import
-import Model.Migration as Import
import Model.Rating as Import
import Model.Submission as Import
import Model.Tokens as Import
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index ed39106a0..7c03533a4 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -128,6 +128,8 @@ import Data.Proxy as Import (Proxy(..))
import Data.List.PointedList as Import (PointedList)
+import Language.Haskell.TH.Syntax as Import (Lift(liftTyped))
+
import Language.Haskell.TH.Instances as Import ()
import Data.NonNull.Instances as Import ()
import Data.Monoid.Instances as Import ()
diff --git a/src/Jobs.hs b/src/Jobs.hs
index 320b9f56a..7e849400f 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -5,7 +5,7 @@ module Jobs
, stopJobCtl
) where
-import Import
+import Import hiding (StateT)
import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
import Jobs.Queue
import Jobs.Crontab
@@ -30,6 +30,7 @@ import qualified Data.Map.Strict as Map
import Data.Map.Strict ((!))
import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST, evalRWST)
+import Control.Monad.Trans.State.Strict (StateT, evalStateT)
import qualified Control.Monad.State.Class as State
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.Cont (ContT(..), callCC)
@@ -99,6 +100,7 @@ handleJobs foundation@UniWorX{..}
jobConfirm <- liftIO $ newTVarIO HashMap.empty
jobShutdown <- liftIO newEmptyTMVarIO
jobCurrentCrontab <- liftIO $ newTVarIO Nothing
+ jobHeldLocks <- liftIO $ newTVarIO Set.empty
atomically $ putTMVar appJobState JobState
{ jobContext = JobContext{..}
, ..
@@ -114,8 +116,9 @@ manageCrontab foundation@UniWorX{..} unmask = do
jState <- atomically $ readTMVar appJobState
liftIO . unsafeHandler foundation . void $ do
atomically . assertM_ (not . Map.null . jobWorkers) $ readTMVar appJobState
- runReaderT ?? foundation $
- writeJobCtlBlock JobCtlDetermineCrontab
+ when (has (_appJobCronInterval . _Just) foundation) $
+ runReaderT ?? foundation $
+ writeJobCtlBlock JobCtlDetermineCrontab
void $ evalRWST (forever execCrontab) jState HashMap.empty
let awaitTermination = guardM $
@@ -414,13 +417,14 @@ handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum JobWorkerBusy $ do
handleCmd JobCtlTest = return ()
handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod)
handleCmd (JobCtlQueue job) = lift $ queueJob' job
- handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do
+ handleCmd (JobCtlPerform jId) = handle handleQueueException . jLocked jId $ \(Entity _ j@QueuedJob{..}) -> lift $ do
content <- case fromJSON queuedJobContent of
Aeson.Success c -> return c
Aeson.Error t -> do
$logErrorS logIdent $ "Aeson decoding error: " <> pack t
throwM $ JInvalid jId j
+ $logInfoS logIdent $ tshow content
$logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content
instanceID' <- getsYesod $ view instanceID
@@ -466,40 +470,45 @@ handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum JobWorkerBusy $ do
. Set.filter (((/=) `on` classifyHealthReport) newReport . snd)
atomically . modifyTVar' hrStorage $ force . updateReports
-jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
-jLocked jId act = do
- hasLock <- liftIO $ newTVarIO False
-
+jLocked :: QueuedJobId -> (Entity QueuedJob -> ReaderT JobContext Handler a) -> ReaderT JobContext Handler a
+jLocked jId act = flip evalStateT False $ do
let
- lock = runDB . setSerializable $ do
- qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
+ lock :: StateT Bool (ReaderT JobContext Handler) (Entity QueuedJob)
+ lock = hoist (hoist $ runDB . setSerializable) $ do
+ qj@QueuedJob{..} <- lift . lift $ maybe (throwM $ JNonexistant jId) return =<< get jId
instanceID' <- getsYesod $ view instanceID
threshold <- getsYesod $ view _appJobStaleThreshold
now <- liftIO getCurrentTime
+ heldLocks <- asks jobHeldLocks
+ isHeld <- (jId `Set.member`) <$> readTVarIO heldLocks
hadStale <- maybeT (return False) $ do
lockTime <- MaybeT $ return queuedJobLockTime
lockInstance <- MaybeT $ return queuedJobLockInstance
if
| lockInstance == instanceID'
, diffUTCTime now lockTime >= threshold
+ , not isHeld
-> return True
| otherwise
-> throwM $ JLocked jId lockInstance lockTime
when hadStale .
$logWarnS "Jobs" $ "Ignored stale lock: " <> tshow (Entity jId qj)
- val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID'
- , QueuedJobLockTime =. Just now
- ]
- liftIO . atomically $ writeTVar hasLock True
- return val
+ State.put True
+ val <- lift . lift $ updateGet jId [ QueuedJobLockInstance =. Just instanceID'
+ , QueuedJobLockTime =. Just now
+ ]
+ atomically . modifyTVar' heldLocks $ Set.insert jId
+ return $ Entity jId val
- unlock = whenM (readTVarIO hasLock) $
- runDB . setSerializable $
- update jId [ QueuedJobLockInstance =. Nothing
- , QueuedJobLockTime =. Nothing
- ]
+ unlock :: Entity QueuedJob -> StateT Bool (ReaderT JobContext Handler) ()
+ unlock (Entity jId' _) = whenM State.get $ do
+ atomically . flip modifyTVar' (Set.delete jId') =<< asks jobHeldLocks
+ lift . lift . runDB . setSerializable $
+ update jId' [ QueuedJobLockInstance =. Nothing
+ , QueuedJobLockTime =. Nothing
+ ]
- bracket lock (const unlock) act
+ bracket lock unlock $ lift . act
pruneLastExecs :: Crontab JobCtl -> DB ()
diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs
index 1624060c2..8127e16e8 100644
--- a/src/Jobs/Crontab.hs
+++ b/src/Jobs/Crontab.hs
@@ -40,22 +40,14 @@ determineCrontab = execWriterT $ do
}
Nothing -> return ()
- tell $ HashMap.singleton
- JobCtlDetermineCrontab
- Cron
- { cronInitial = CronAsap
- , cronRepeat = CronRepeatScheduled CronAsap
- , cronRateLimit = appJobCronInterval
- , cronNotAfter = Right CronNotScheduled
- }
- whenIsJust appPruneUnreferencedFiles $ \pInterval ->
+ whenIsJust appJobCronInterval $ \interval ->
tell $ HashMap.singleton
- (JobCtlQueue JobPruneUnreferencedFiles)
+ JobCtlDetermineCrontab
Cron
- { cronInitial = CronAsap
- , cronRepeat = CronRepeatScheduled CronAsap
- , cronRateLimit = pInterval
- , cronNotAfter = Right CronNotScheduled
+ { cronInitial = CronAsap
+ , cronRepeat = CronRepeatScheduled CronAsap
+ , cronRateLimit = interval
+ , cronNotAfter = Right CronNotScheduled
}
oldestInvitationMUTC <- lift $ preview (_head . _entityVal . _invitationExpiresAt . _Just) <$> selectList [InvitationExpiresAt !=. Nothing] [Asc InvitationExpiresAt, LimitTo 1]
@@ -98,6 +90,15 @@ determineCrontab = execWriterT $ do
, cronRateLimit = iInterval
, cronNotAfter = Right CronNotScheduled
}
+ whenIsJust appRechunkFiles $ \rInterval ->
+ tell $ HashMap.singleton
+ (JobCtlQueue JobRechunkFiles)
+ Cron
+ { cronInitial = CronAsap
+ , cronRepeat = CronRepeatScheduled CronAsap
+ , cronRateLimit = rInterval
+ , cronNotAfter = Right CronNotScheduled
+ }
tell . flip foldMap universeF $ \kind ->
case appHealthCheckInterval kind of
@@ -138,33 +139,31 @@ determineCrontab = execWriterT $ do
, cronNotAfter = Right CronNotScheduled
}
+ let
+ getNextIntervals within interval cInterval = do
+ now <- liftIO getPOSIXTime
+ return $ do
+ let
+ epochInterval = within / 2
+ (currEpoch, epochNow) = now `divMod'` epochInterval
+ currInterval = epochNow `div'` interval
+ numIntervals = floor $ epochInterval / interval
+ n = ceiling $ 4 * cInterval / interval
+ i <- [ negate (ceiling $ n % 2) .. ceiling $ n % 2 ]
+ let
+ ((+ currEpoch) -> nextEpoch, nextInterval) = (currInterval + i) `divMod` numIntervals
+ nextIntervalTime
+ = posixSecondsToUTCTime $ fromInteger nextEpoch * epochInterval + fromInteger nextInterval * interval
+ return (nextEpoch, nextInterval, nextIntervalTime, numIntervals)
if
| is _Just appLdapConf
- , is _Just appLdapConf
, Just syncWithin <- appSynchroniseLdapUsersWithin
+ , Just cInterval <- appJobCronInterval
-> do
- now <- liftIO getPOSIXTime
- let
- epochInterval = syncWithin / 2
- interval = appSynchroniseLdapUsersInterval
+ nextIntervals <- getNextIntervals syncWithin appSynchroniseLdapUsersInterval cInterval
- (ldapEpoch, epochNow) = now `divMod'` epochInterval
- ldapInterval = epochNow `div'` interval
- numIntervals = floor $ epochInterval / interval
-
- nextIntervals = do
- let
- n = ceiling $ 4 * appJobCronInterval / appSynchroniseLdapUsersInterval
- i <- [negate (ceiling $ n % 2) .. ceiling $ n % 2]
- let
- ((+ ldapEpoch) -> nextEpoch, nextInterval) = (ldapInterval + i) `divMod` numIntervals
- nextIntervalTime
- = posixSecondsToUTCTime $ fromInteger nextEpoch * epochInterval + fromInteger nextInterval * interval
- return (nextEpoch, nextInterval, nextIntervalTime)
-
- forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime) -> do
- $logDebugS "SynchroniseLdap" [st|currentTime: #{tshow ldapEpoch}.#{tshow epochNow}; upcomingSync: #{tshow nextEpoch}.#{tshow (fromInteger nextInterval * interval)}; upcomingData: #{tshow (numIntervals, nextEpoch, nextInterval)}|]
+ forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
tell $ HashMap.singleton
(JobCtlQueue JobSynchroniseLdap
{ jEpoch = fromInteger nextEpoch
@@ -180,6 +179,22 @@ determineCrontab = execWriterT $ do
| otherwise
-> return ()
+ whenIsJust ((,) <$> appPruneUnreferencedFilesWithin <*> appJobCronInterval) $ \(within, cInterval) -> do
+ nextIntervals <- getNextIntervals within appPruneUnreferencedFilesInterval cInterval
+ forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
+ tell $ HashMap.singleton
+ (JobCtlQueue JobPruneUnreferencedFiles
+ { jEpoch = fromInteger nextEpoch
+ , jNumIterations = fromInteger numIntervals
+ , jIteration = fromInteger nextInterval
+ }
+ )
+ Cron
+ { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ nextIntervalTime
+ , cronRepeat = CronRepeatNever
+ , cronRateLimit = appPruneUnreferencedFilesInterval
+ , cronNotAfter = Left within
+ }
let
sheetJobs (Entity nSheet Sheet{..}) = do
diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs
index 77e6337e2..55218e170 100644
--- a/src/Jobs/Handler/Files.hs
+++ b/src/Jobs/Handler/Files.hs
@@ -1,27 +1,36 @@
module Jobs.Handler.Files
( dispatchJobPruneSessionFiles
, dispatchJobPruneUnreferencedFiles
- , dispatchJobInjectFiles
+ , dispatchJobInjectFiles, dispatchJobRechunkFiles
) where
-import Import hiding (matching)
+import Import hiding (matching, maximumBy, init)
import Database.Persist.Sql (deleteWhereCount)
import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
-import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlCastAs)
import qualified Data.Conduit.Combinators as C
-import qualified Data.Conduit.List as C (mapMaybe)
+import qualified Data.Conduit.List as C (mapMaybe, unfoldM)
import Handler.Utils.Minio
import qualified Network.Minio as Minio
-import qualified Crypto.Hash as Crypto
-import qualified Data.ByteString.Base64.URL as Base64
+import Crypto.Hash (hashDigestSize, digestFromByteString)
-import Control.Monad.Memo (startEvalMemoT, memo)
+import Data.List ((!!), unfoldr, maximumBy, init, genericLength)
+import qualified Data.ByteString as ByteString
+import Data.Bits (Bits(shiftR))
+
+import qualified Data.Map.Strict as Map
+
+import Control.Monad.Random.Lazy
+import System.Random.Shuffle (shuffleM)
+import System.IO.Unsafe
+
+import Handler.Utils.Files (sourceFileDB)
dispatchJobPruneSessionFiles :: JobHandler UniWorX
@@ -44,72 +53,190 @@ fileReferences (E.just -> fHash)
, E.from $ \subFile -> E.where_ $ subFile E.^. SubmissionFileContent E.==. fHash
, E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileContent E.==. fHash
, E.from $ \lock -> E.where_ $ E.just (lock E.^. FileLockContent) E.==. fHash
+ , E.from $ \chunkLock -> E.where_ . E.exists . E.from $ \fileContentEntry ->
+ E.where_ $ E.just (fileContentEntry E.^. FileContentEntryHash) E.==. fHash
+ E.&&. chunkLock E.^. FileChunkLockHash E.==. E.subSelectForeign fileContentEntry FileContentEntryChunkHash (E.^. FileContentChunkHash)
]
+{-# NOINLINE pruneUnreferencedFilesIntervalsCache #-}
+pruneUnreferencedFilesIntervalsCache :: TVar (Map Natural [(Maybe FileContentChunkReference, Maybe FileContentChunkReference)])
+pruneUnreferencedFilesIntervalsCache = unsafePerformIO $ newTVarIO Map.empty
-dispatchJobPruneUnreferencedFiles :: JobHandler UniWorX
-dispatchJobPruneUnreferencedFiles = JobHandlerAtomic . hoist lift $ do
+dispatchJobPruneUnreferencedFiles :: Natural -> Natural -> Natural -> JobHandler UniWorX
+dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtomic . hoist lift $ do
now <- liftIO getCurrentTime
- interval <- fmap (fmap $ max 0) . getsYesod $ view _appPruneUnreferencedFiles
+ interval <- getsYesod $ view _appPruneUnreferencedFilesInterval
keep <- fmap (max 0) . getsYesod $ view _appKeepUnreferencedFiles
- E.update $ \fileContent -> do
- let isReferenced = E.any E.exists . fileReferences $ fileContent E.^. FileContentHash
- now' = E.unsafeSqlCastAs "TIMESTAMP WITH TIME ZONE" $ E.val now
- shouldBe = E.bool (E.just . E.maybe now' (E.min now') $ fileContent E.^. FileContentUnreferencedSince) E.nothing isReferenced
- E.set fileContent [ FileContentUnreferencedSince E.=. shouldBe ]
+ let
+ chunkHashBytes :: forall h.
+ ( Unwrapped FileContentChunkReference ~ Digest h )
+ => Integer
+ chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h))
+ chunkHashBits = chunkHashBytes * 8
+ base :: Integer
+ base = 2 ^ chunkHashBits
+ intervals :: [Integer]
+ -- | Exclusive upper bounds
+ intervals
+ | numIterations <= 0 = pure base
+ | otherwise = go protoIntervals ^.. folded . _1
+ where
+ go [] = []
+ go ints
+ | maximumOf (folded . _1) ints == Just base = ints
+ | otherwise = go $ lts ++ over _1 succ (over _2 (subtract $ toInteger numIterations) closest) : map (over _1 succ) gts
+ where
+ closest = maximumBy (comparing $ view _2) ints
+ (lts, geqs) = partition (((>) `on` view _1) closest) ints
+ gts = filter (((<) `on` view _1) closest) geqs
+ -- | Exclusive upper bounds
+ protoIntervals :: [(Integer, Integer)]
+ protoIntervals = [ over _1 (i *) $ base `divMod` toInteger numIterations
+ | i <- [1 .. toInteger numIterations]
+ ]
+
+ intervalsDgsts' = zipWith (curry . over both $ toDigest <=< assertM' (> 0)) (0 : init intervals) intervals
+
+ toDigest :: Integer -> Maybe FileContentChunkReference
+ toDigest = fmap (review _Wrapped) . digestFromByteString . pad . ByteString.pack . reverse . unfoldr step
+ where step i
+ | i <= 0 = Nothing
+ | otherwise = Just (fromIntegral i, i `shiftR` 8)
+ pad bs
+ | toInteger (ByteString.length bs) >= chunkHashBytes = bs
+ | otherwise = pad $ ByteString.cons 0 bs
+
+ intervalsDgsts <- atomically $ do
+ cachedDgsts <- readTVar pruneUnreferencedFilesIntervalsCache
+ case Map.lookup numIterations cachedDgsts of
+ Just c -> return c
+ Nothing -> do
+ modifyTVar' pruneUnreferencedFilesIntervalsCache $ force . Map.insert numIterations intervalsDgsts'
+ return intervalsDgsts'
let
- getCandidates = E.selectSource . E.from $ \fileContent -> do
- E.where_ . E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) $ fileContent E.^. FileContentUnreferencedSince
- return ( fileContent E.^. FileContentHash
- , E.length_ $ fileContent E.^. FileContentContent
+ permIntervalsDgsts = shuffleM intervalsDgsts `evalRand` mkStdGen (hash epoch)
+
+ (minBoundDgst, maxBoundDgst) = permIntervalsDgsts !! fromIntegral (toInteger iteration `mod` genericLength permIntervalsDgsts)
+ chunkIdFilter :: E.SqlExpr (E.Value FileContentChunkReference) -> E.SqlExpr (E.Value Bool)
+ chunkIdFilter cRef = E.and $ catMaybes
+ [ minBoundDgst <&> \b -> cRef E.>=. E.val b
+ , maxBoundDgst <&> \b -> cRef E.<. E.val b
+ ]
+
+ $logDebugS "PruneUnreferencedFiles" . tshow $ (minBoundDgst, maxBoundDgst)
+
+ E.insertSelectWithConflict
+ (UniqueFileContentChunkUnreferenced $ error "insertSelectWithConflict inspected constraint")
+ (E.from $ \fileContentChunk -> do
+ E.where_ . E.not_ . E.subSelectOr . E.from $ \fileContentEntry -> do
+ E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkId
+ return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash
+ E.where_ . chunkIdFilter $ fileContentChunk E.^. FileContentChunkHash
+ return $ FileContentChunkUnreferenced E.<# (fileContentChunk E.^. FileContentChunkId) E.<&> E.val now
+ )
+ (\current excluded ->
+ [ FileContentChunkUnreferencedSince E.=. E.min (current E.^. FileContentChunkUnreferencedSince) (excluded E.^. FileContentChunkUnreferencedSince) ]
+ )
+
+ E.delete . E.from $ \fileContentChunkUnreferenced -> do
+ E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do
+ E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
+ return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash
+ E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
+
+ let
+ getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do
+ let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do
+ E.on $ fileContentEntry' E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
+ E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash
+ E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
+ return . E.max_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince
+ E.where_ $ E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) unreferencedSince
+
+ E.groupBy $ fileContentEntry E.^. FileContentEntryHash
+ E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryHash ]
+
+ return $ fileContentEntry E.^. FileContentEntryHash
+
+ deleteEntry :: _ -> DB (Sum Natural)
+ deleteEntry (E.Value fRef) =
+ bool 0 1 . (> 0) <$> deleteWhereCount [FileContentEntryHash ==. fRef]
+
+ Sum deletedEntries <- runConduit $
+ getEntryCandidates
+ .| takeWhileTime (interval / 3)
+ .| C.mapM deleteEntry
+ .| C.fold
+
+ when (deletedEntries > 0) $
+ $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedEntries} long-unreferenced files|]
+
+ let
+ getChunkCandidates = E.selectSource . E.from $ \fileContentChunkUnreferenced -> do
+ 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.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
+
+ E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash)
+
+ return ( fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash
+ , E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash $ E.length_ . (E.^. FileContentChunkContent)
)
- Sum deleted <- runConduit $
- getCandidates
- .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
+ deleteChunk :: _ -> DB (Sum Natural, Sum Word64)
+ deleteChunk (E.Value cRef, E.Value size) = do
+ deleteWhere [ FileContentChunkUnreferencedHash ==. cRef ]
+ (, Sum size) . fromIntegral <$> deleteWhereCount [FileContentChunkHash ==. unFileContentChunkKey cRef]
+
+ (Sum deletedChunks, Sum deletedChunkSize) <- runConduit $
+ getChunkCandidates
+ .| takeWhileTime (interval / 3)
.| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64)
- .| C.map (view $ _1 . _Value)
- .| C.mapM (\fRef -> Sum <$> deleteWhereCount [FileContentHash ==. fRef])
+ .| C.mapM deleteChunk
.| C.fold
- when (deleted > 0) $
- $logInfoS "PruneUnreferencedFiles" [st|Deleted #{deleted} long-unreferenced files|]
+
+ when (deletedChunks > 0) $
+ $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedChunks} chunks (#{tshow deletedChunkSize} bytes)|]
dispatchJobInjectFiles :: JobHandler UniWorX
dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do
uploadBucket <- getsYesod $ view _appUploadCacheBucket
interval <- getsYesod $ view _appInjectFiles
- now <- liftIO getCurrentTime
let
- extractReference (Minio.ListItemObject oi)
- | Right bs <- Base64.decodeUnpadded . encodeUtf8 $ Minio.oiObject oi
- , Just fRef <- Crypto.digestFromByteString bs
- = Just (oi, fRef)
+ extractReference (Minio.ListItemObject oi) = (oi, ) <$> Minio.oiObject oi ^? minioFileReference
extractReference _ = Nothing
injectOrDelete :: (Minio.Object, FileContentReference)
- -> Handler (Sum Int64, Sum Int64) -- ^ Injected, Already existed
- injectOrDelete (obj, fRef) = maybeT (return mempty) $ do
- res <- hoist (startEvalMemoT . hoistStateCache (runDB . setSerializable)) $ do
- alreadyInjected <- lift . lift $ exists [ FileContentHash ==. fRef ]
- if | alreadyInjected -> return (mempty, Sum 1)
- | otherwise -> do
- content <- flip memo obj $ \obj' -> hoistMaybeM . runAppMinio . runMaybeT $ do
- objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj' Minio.defaultGetObjectOptions
- lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
+ -> Handler (Sum Int64) -- ^ Injected
+ injectOrDelete (obj, fRef) = do
+ fRef' <- runDB . setSerializable $ do
+ chunkVar <- newEmptyTMVarIO
+ dbAsync <- allocateLinkedAsync $ do
+ atomically $ isEmptyTMVar chunkVar >>= guard . not
+ sinkFileDB False $ C.unfoldM (\x -> fmap (, x) <$> atomically (takeTMVar chunkVar)) ()
- fmap ((, mempty) . Sum) . lift. lift . E.insertSelectCount $
- let isReferenced = E.any E.exists $ fileReferences (E.val fRef)
- now' = E.unsafeSqlCastAs "TIMESTAMP WITH TIME ZONE" $ E.val now
- in return $ FileContent E.<# E.val fRef E.<&> E.val content E.<&> E.bool (E.just now') E.nothing isReferenced
- runAppMinio . maybeT (return ()) . catchIfMaybeT minioIsDoesNotExist $ Minio.removeObject uploadBucket obj
- return res
+ didSend <- maybeT (return False) . hoistMaybeM . runAppMinio . runMaybeT $ do
+ objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions
+ lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar . Just)
+ return True
+ if
+ | not didSend -> Nothing <$ cancel dbAsync
+ | otherwise -> do
+ atomically $ putTMVar chunkVar Nothing
+ Just <$> waitAsync dbAsync
+ let matchesFRef = is _Just $ assertM (== fRef) fRef'
+ if | matchesFRef ->
+ maybeT (return ()) . runAppMinio . handleIf minioIsDoesNotExist (const $ return ()) $ Minio.removeObject uploadBucket obj
+ | otherwise ->
+ $logErrorS "InjectFiles" [st|Minio object “#{obj}”'s content does not match it's name (content hash: #{tshow fRef'} /= name hash: #{tshow fRef})|]
+ return . bool mempty (Sum 1) $ is _Just fRef'
- (Sum inj, Sum exc) <-
+ Sum inj <-
runConduit $ transPipe runAppMinio (Minio.listObjects uploadBucket Nothing True)
.| C.mapMaybe extractReference
.| maybe (C.map id) (takeWhileTime . (/ 2)) interval
@@ -118,7 +245,49 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do
.| transPipe lift (C.mapM injectOrDelete)
.| C.fold
- when (exc > 0) $
- $logInfoS "InjectFiles" [st|Deleted #{exc} files from upload cache because they were already injected|]
when (inj > 0) $
$logInfoS "InjectFiles" [st|Injected #{inj} files from upload cache into database|]
+
+
+data RechunkFileException
+ = RechunkFileExceptionHashMismatch
+ { oldHash, newHash :: FileContentReference }
+ deriving (Eq, Ord, Show, Generic, Typeable)
+ deriving anyclass (Exception)
+
+dispatchJobRechunkFiles :: JobHandler UniWorX
+dispatchJobRechunkFiles = JobHandlerAtomic . hoist lift $ do
+ interval <- getsYesod $ view _appRechunkFiles
+ let
+ getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> E.distinctOnOrderBy [E.asc $ fileContentEntry E.^. FileContentEntryHash] $ do
+ E.where_ . E.exists . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do
+ E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash
+ E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash
+ E.where_ . E.not_ $ fileContentChunk E.^. FileContentChunkContentBased
+
+ let size = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do
+ E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash
+ E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash
+ return $ E.sum_ (E.length_ $ fileContentChunk E.^. FileContentChunkContent:: E.SqlExpr (E.Value Word64))
+
+ return ( fileContentEntry E.^. FileContentEntryHash
+ , size
+ )
+
+ rechunkFile :: FileContentReference -> Word64 -> DB (Sum Natural, Sum Word64)
+ rechunkFile fRef sz = do
+ fRef' <- sinkFileDB True $ sourceFileDB fRef
+ unless (fRef == fRef') $
+ throwM $ RechunkFileExceptionHashMismatch fRef fRef'
+ return (Sum 1, Sum sz)
+
+ (Sum rechunkedEntries, Sum rechunkedSize) <- runConduit $
+ getEntryCandidates
+ .| C.mapMaybe (\(E.Value fRef, E.Value sz) -> (fRef, ) <$> sz)
+ .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
+ .| persistentTokenBucketTakeC' TokenBucketRechunkFiles (view _2 :: _ -> Word64)
+ .| C.mapM (uncurry rechunkFile)
+ .| C.fold
+
+ when (rechunkedEntries > 0 || rechunkedSize > 0) $
+ $logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedEntries} files in database (#{tshow rechunkedSize} bytes)|]
diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs
index fb225b98f..38fa2a3f0 100644
--- a/src/Jobs/Handler/QueueNotification.hs
+++ b/src/Jobs/Handler/QueueNotification.hs
@@ -113,6 +113,8 @@ determineNotificationCandidates = awaitForever $ \notif -> do
E.&&. admin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
return user
withNotif . yieldMany . nub $ affectedUser <> affectedAdmins
+ NotificationUserSystemFunctionsUpdate{..}
+ -> withNotif $ selectSource [UserId ==. nUser] []
NotificationUserAuthModeUpdate{..}
-> withNotif $ selectSource [UserId ==. nUser] []
NotificationExamRegistrationActive{..}
@@ -295,6 +297,7 @@ classifyNotification NotificationSheetInactive{} = return NTShe
classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned
classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed
classifyNotification NotificationUserRightsUpdate{} = return NTUserRightsUpdate
+classifyNotification NotificationUserSystemFunctionsUpdate{} = return NTUserRightsUpdate
classifyNotification NotificationUserAuthModeUpdate{} = return NTUserAuthModeUpdate
classifyNotification NotificationExamRegistrationActive{} = return NTExamRegistrationActive
classifyNotification NotificationExamRegistrationSoonInactive{} = return NTExamRegistrationSoonInactive
diff --git a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
index aec3f2a42..f2a7ba935 100644
--- a/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
+++ b/src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
@@ -2,6 +2,7 @@
module Jobs.Handler.SendNotification.UserRightsUpdate
( dispatchNotificationUserRightsUpdate
+ , dispatchNotificationUserSystemFunctionsUpdate
) where
import Import
@@ -27,3 +28,16 @@ dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMai
editNotifications <- mkEditNotifications jRecipient
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
+
+dispatchNotificationUserSystemFunctionsUpdate :: UserId -> Set SystemFunction -> UserId -> Handler ()
+dispatchNotificationUserSystemFunctionsUpdate nUser _originalSystemFunctions jRecipient = userMailT jRecipient $ do
+ (User{..}, functions) <- liftHandler . runDB $ do
+ user <- getJust nUser
+ functions <- map (userSystemFunctionFunction . entityVal) <$> selectList [UserSystemFunctionUser ==. nUser] []
+ return (user, Set.fromList functions)
+ replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+ setSubjectI $ MsgMailSubjectUserSystemFunctionsUpdate userDisplayName
+ -- MsgRenderer mr <- getMailMsgRenderer
+ editNotifications <- mkEditNotifications jRecipient
+ addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userSystemFunctionsUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
+
diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs
index cd1765f25..45a32b8dc 100644
--- a/src/Jobs/Handler/SynchroniseLdap.hs
+++ b/src/Jobs/Handler/SynchroniseLdap.hs
@@ -49,7 +49,7 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
reTestAfter <- getsYesod $ view _appLdapReTestFailover
ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user
- void . lift $ upsertCampusUser UpsertCampusUser ldapAttrs
+ void . lift $ upsertCampusUser (UpsertCampusUserLdapSync userIdent) ldapAttrs
Nothing ->
throwM SynchroniseLdapNoLdap
where
diff --git a/src/Jobs/Handler/TransactionLog.hs b/src/Jobs/Handler/TransactionLog.hs
index fb856ba2c..131ba2491 100644
--- a/src/Jobs/Handler/TransactionLog.hs
+++ b/src/Jobs/Handler/TransactionLog.hs
@@ -27,5 +27,5 @@ dispatchJobDeleteTransactionLogIPs = JobHandlerAtomic . hoist lift $ do
retentionTime <- getsYesod $ view _appTransactionLogIPRetentionTime
let cutoff = addUTCTime (- retentionTime) now
- n <- updateWhereCount [ TransactionLogTime <. cutoff ] [ TransactionLogRemote =. Nothing ]
+ n <- updateWhereCount [ TransactionLogTime <. cutoff, TransactionLogRemote !=. Nothing ] [ TransactionLogRemote =. Nothing ]
$logInfoS "DeleteTransactionLogIPs" [st|Deleted #{n} IP entries from transaction log|]
diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs
index 67ee78717..de297d339 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -106,7 +106,7 @@ dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHea
Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) ->
let hCampusExc :: CampusUserException -> Handler (Sum Integer)
hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err)
- in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent [])
+ in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds apLdap adminIdent [])
return $ numResolved % numAdmins
_other -> return Nothing
diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs
index b5483a8c6..bb2faf762 100644
--- a/src/Jobs/Queue.hs
+++ b/src/Jobs/Queue.hs
@@ -82,7 +82,7 @@ writeJobCtlBlock = writeJobCtlBlock' writeJobCtl
queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX (Maybe QueuedJobId)
queueJobUnsafe queuedJobWriteLastExec job = do
- $logInfoS "queueJob" $ tshow job
+ $logDebugS "queueJob" $ tshow job
doQueue <- fmap not . and2M (return $ jobNoQueueSame job) $ exists [ QueuedJobContent ==. toJSON job ]
diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs
index 729cd356b..59a15c99a 100644
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@@ -86,9 +86,13 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
, jDisplayEmail :: UserEmail
}
| JobPruneSessionFiles
- | JobPruneUnreferencedFiles
+ | JobPruneUnreferencedFiles { jNumIterations
+ , jEpoch
+ , jIteration :: Natural
+ }
| JobInjectFiles
| JobPruneFallbackPersonalisedSheetFilesKeys
+ | JobRechunkFiles
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }
@@ -99,6 +103,7 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
| NotificationCorrectionsNotDistributed { nSheet :: SheetId }
| NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
+ | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction }
| NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
| NotificationExamRegistrationActive { nExam :: ExamId }
| NotificationExamRegistrationSoonInactive { nExam :: ExamId }
@@ -222,6 +227,7 @@ newWorkerId = JobWorkerId <$> liftIO newUnique
data JobContext = JobContext
{ jobCrontab :: TVar (Crontab JobCtl)
, jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException))))
+ , jobHeldLocks :: TVar (Set QueuedJobId)
}
@@ -250,6 +256,8 @@ jobNoQueueSame = \case
JobPruneSessionFiles{} -> True
JobPruneUnreferencedFiles{} -> True
JobInjectFiles{} -> True
+ JobPruneFallbackPersonalisedSheetFilesKeys{} -> True
+ JobRechunkFiles{} -> True
_ -> False
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index 5ebd46b6f..0d77f6da3 100644
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@@ -7,6 +7,8 @@ module Model.Migration
import Import.NoModel hiding (Max(..), Last(..))
import Model
+import Settings
+import Foundation.Type
import Jobs.Types
import Audit.Types
import Model.Migration.Version
@@ -40,6 +42,8 @@ import qualified Data.CaseInsensitive as CI
import qualified Data.Aeson as Aeson
import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage)
+
+import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize))
-- Database versions must follow https://pvp.haskell.org:
-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
@@ -80,6 +84,7 @@ migrateAll' = sequence_
migrateAll :: ( MonadLogger m
, MonadResource m
, MonadUnliftIO m
+ , MonadReader UniWorX m
)
=> ReaderT SqlBackend m ()
migrateAll = do
@@ -112,7 +117,7 @@ requiresMigration = mapReaderT (exceptT return return) $ do
$logInfoS "Migration" $ intercalate "; " initial
throwError True
- customs <- mapReaderT lift $ getMissingMigrations @_ @m
+ customs <- mapReaderT lift $ getMissingMigrations @_ @(ReaderT UniWorX m)
unless (Map.null customs) $ do
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
throwError True
@@ -134,6 +139,7 @@ getMissingMigrations :: forall m m'.
( MonadLogger m
, MonadIO m
, MonadResource m'
+ , MonadReader UniWorX m'
)
=> ReaderT SqlBackend m (Map (Key AppliedMigration) (ReaderT SqlBackend m' ()))
getMissingMigrations = do
@@ -159,6 +165,7 @@ migrateManual = do
, ("user_lower_ident", "CREATE INDEX user_lower_ident ON \"user\" (lower(ident))" )
, ("submission_sheet", "CREATE INDEX submission_sheet ON submission (sheet)" )
, ("submission_edit_submission", "CREATE INDEX submission_edit_submission ON submission_edit (submission)" )
+ , ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" )
]
where
addIndex :: Text -> Sql -> Migration
@@ -179,7 +186,9 @@ migrateManual = do
-}
customMigrations :: forall m.
- MonadResource m
+ ( MonadResource m
+ , MonadReader UniWorX m
+ )
=> Map (Key AppliedMigration) (ReaderT SqlBackend m ())
customMigrations = Map.fromListWith (>>)
[ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
@@ -913,6 +922,33 @@ customMigrations = Map.fromListWith (>>)
insert_ CronLastExec{ cronLastExecJob = toJSON $ JobQueueNotification NotificationAllocationUnratedApplications{..}, .. }
)
+ , ( AppliedMigrationKey [migrationVersion|39.0.0|] [version|40.0.0|]
+ , whenM (tableExists "study_features")
+ [executeQQ|
+ ALTER TABLE study_features RENAME updated TO last_observed;
+ ALTER TABLE study_features ADD COLUMN first_observed timestamp with time zone;
+ UPDATE study_features SET first_observed = (SELECT MAX(last_observed) FROM study_features as other WHERE other."user" = study_features."user" AND other.degree = study_features.degree AND other.field = study_features.field AND other.type = study_features.type AND other.semester = study_features.semester - 1);
+ |]
+ )
+ , ( AppliedMigrationKey [migrationVersion|40.0.0|] [version|41.0.0|]
+ , whenM (tableExists "file_content") $ do
+ chunkingParams <- lift $ view _appFileChunkingParams
+
+ [executeQQ|
+ ALTER TABLE file_content RENAME TO file_content_chunk;
+ ALTER INDEX file_content_pkey RENAME TO file_content_chunk_pkey;
+
+ CREATE TABLE file_content_chunk_unreferenced (id bigserial, hash bytea NOT NULL, since timestamp with time zone NOT NULL);
+ INSERT INTO file_content_chunk_unreferenced (since, hash) (SELECT unreferenced_since as since, hash FROM file_content_chunk WHERE NOT (unreferenced_since IS NULL));
+ ALTER TABLE file_content_chunk DROP COLUMN unreferenced_since;
+
+ ALTER TABLE file_content_chunk ADD COLUMN content_based boolean NOT NULL DEFAULT false;
+ UPDATE file_content_chunk SET content_based = true WHERE length(content) <= #{fastCDCMinBlockSize chunkingParams};
+
+ CREATE TABLE file_content_entry (hash bytea NOT NULL, ix bigint NOT NULL, chunk_hash bytea NOT NULL);
+ INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk);
+ |]
+ )
]
diff --git a/src/Model/Types.hs b/src/Model/Types.hs
index fc3b1662f..b40e5c912 100644
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@@ -16,3 +16,4 @@ import Model.Types.School as Types
import Model.Types.Allocation as Types
import Model.Types.Languages as Types
import Model.Types.File as Types
+import Model.Types.User as Types
diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs
index d7dd3ab56..543e1dfa8 100644
--- a/src/Model/Types/Common.hs
+++ b/src/Model/Types/Common.hs
@@ -58,5 +58,3 @@ type InstanceId = UUID
type ClusterId = UUID
type TokenId = UUID
type TermCandidateIncidence = UUID
-
-type FileContentReference = Digest SHA3_512
diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs
index 33bdadbb7..5da04921b 100644
--- a/src/Model/Types/File.hs
+++ b/src/Model/Types/File.hs
@@ -1,23 +1,129 @@
module Model.Types.File
- ( File(..), _fileTitle, _fileContent, _fileModified
+ ( FileContentChunkReference(..), FileContentReference(..)
+ , File(..), _fileTitle, _fileContent, _fileModified
+ , PureFile, toPureFile, fromPureFile, pureFileToFileReference, _pureFileContent
+ , transFile
+ , minioFileReference
, FileReference(..), _fileReferenceTitle, _fileReferenceContent, _fileReferenceModified
- , HasFileReference(..), IsFileReference(..), FileReferenceResidual(..)
+ , HasFileReference(..), IsFileReference(..), FileReferenceResidual(FileReferenceResidual, FileReferenceResidualEither, unFileReferenceResidualEither, FileReferenceResidualEntity, fileReferenceResidualEntityKey, fileReferenceResidualEntityResidual, unPureFileResidual)
) where
import Import.NoModel
-import Model.Types.Common (FileContentReference)
+
+import Database.Persist.Sql (PersistFieldSql)
+import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
+import Data.ByteArray (ByteArrayAccess)
+
+import qualified Data.ByteString.Base64.URL as Base64
+import qualified Data.ByteArray as ByteArray
+import qualified Network.Minio as Minio (Object)
+import qualified Crypto.Hash as Crypto (digestFromByteString)
+import qualified Crypto.Hash.Conduit as Crypto (sinkHash)
import Utils.Lens.TH
+import qualified Data.Conduit.Combinators as C
-data File = File
+import Text.Show
+
+
+
+newtype FileContentChunkReference = FileContentChunkReference (Digest SHA3_512)
+ deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
+ deriving newtype ( PersistField, PersistFieldSql
+ , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
+ , Hashable, NFData
+ , ByteArrayAccess
+ )
+
+makeWrapped ''FileContentChunkReference
+
+newtype FileContentReference = FileContentReference (Digest SHA3_512)
+ deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
+ deriving newtype ( PersistField, PersistFieldSql
+ , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
+ , Hashable, NFData
+ , ByteArrayAccess
+ )
+
+makeWrapped ''FileContentReference
+
+
+minioFileReference :: Prism' Minio.Object FileContentReference
+minioFileReference = prism' toObjectName fromObjectName
+ where toObjectName = decodeUtf8 . Base64.encodeUnpadded . ByteArray.convert
+ fromObjectName = fmap (review _Wrapped) . Crypto.digestFromByteString <=< preview _Right . Base64.decodeUnpadded . encodeUtf8
+
+
+data File m = File
{ fileTitle :: FilePath
- , fileContent :: Maybe ByteString
+ , fileContent :: Maybe (ConduitT () ByteString m ())
, fileModified :: UTCTime
- } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ } deriving (Generic, Typeable)
makeLenses_ ''File
+type PureFile = File Identity
+
+_pureFileContent :: forall bs.
+ ( IsSequence bs
+ , Element bs ~ Word8
+ )
+ => Lens' PureFile (Maybe bs)
+_pureFileContent = lens getPureFileContent setPureFileContent
+ where
+ getPureFileContent = fmap (repack . runIdentity . runConduit . (.| C.fold)) . fileContent
+ setPureFileContent f bs = f { fileContent = yield . repack <$> bs }
+
+toPureFile :: Monad m => File m -> m PureFile
+toPureFile File{..} = do
+ c <- for fileContent $ runConduit . (.| C.fold)
+ return File
+ { fileContent = fmap yield c
+ , ..
+ }
+
+fromPureFile :: Monad m => PureFile -> File m
+fromPureFile = transFile generalize
+
+pureFileToFileReference :: PureFile -> FileReference
+pureFileToFileReference File{..} = FileReference
+ { fileReferenceTitle = fileTitle
+ , fileReferenceContent = review _Wrapped . runIdentity . runConduit . (.| Crypto.sinkHash) <$> fileContent
+ , fileReferenceModified = fileModified
+ }
+
+instance Eq PureFile where
+ a == b = all (\f -> f a b)
+ [ (==) `on` fileTitle
+ , (==) `on` fileModified
+ , (==) `on` (view _pureFileContent :: PureFile -> Maybe ByteString)
+ ]
+instance Ord PureFile where
+ compare = mconcat
+ [ comparing fileTitle
+ , comparing (view _pureFileContent :: PureFile -> Maybe ByteString)
+ , comparing fileModified
+ ]
+instance Show PureFile where
+ showsPrec _ f@File{..}
+ = showString "File{"
+ . showString "fileTitle = "
+ . shows fileTitle
+ . showString ", "
+ . showString "fileContent = "
+ . (case f ^. _pureFileContent of
+ Nothing -> showString "Nothing"
+ Just c -> showString "Just $ yield " . showsPrec 11 (c :: ByteString)
+ )
+ . showString ", "
+ . showString "fileModified = "
+ . shows fileModified
+ . showString "}"
+
+transFile :: Monad m => (forall a. m a -> n a) -> (File m -> File n)
+transFile l File{..} = File{ fileContent = transPipe l <$> fileContent, .. }
+
data FileReference = FileReference
{ fileReferenceTitle :: FilePath
, fileReferenceContent :: Maybe FileContentReference
@@ -36,6 +142,24 @@ instance HasFileReference FileReference where
data FileReferenceResidual FileReference = FileReferenceResidual
_FileReference = iso (, FileReferenceResidual) $ view _1
+instance HasFileReference PureFile where
+ newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString }
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+ _FileReference = iso toFileReference fromFileReference
+ where
+ toFileReference File{..} = (FileReference{..}, PureFileResidual{..})
+ where
+ fileReferenceTitle = fileTitle
+ (fileReferenceContent, unPureFileResidual) = ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) $
+ over _1 (review _Wrapped) . runIdentity . runConduit . (.| getZipConduit ((,) <$> ZipConduit Crypto.sinkHash <*> ZipConduit C.fold)) <$> fileContent
+ fileReferenceModified = fileModified
+ fromFileReference (FileReference{..}, PureFileResidual{..}) = File
+ { fileTitle = fileReferenceTitle
+ , fileContent = yield <$> unPureFileResidual
+ , fileModified = fileReferenceModified
+ }
+
instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where
newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) }
_FileReference = iso doSplit doJoin
diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs
index bc8e1c23d..7eee837b9 100644
--- a/src/Model/Types/Misc.hs
+++ b/src/Model/Types/Misc.hs
@@ -34,10 +34,13 @@ import Web.HttpApiData
data StudyFieldType = FieldPrimary | FieldSecondary
deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
+ deriving anyclass (Universe, Finite)
+
derivePersistField "StudyFieldType"
-instance Universe StudyFieldType
-instance Finite StudyFieldType
nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1
+pathPieceJSON ''StudyFieldType
+pathPieceJSONKey ''StudyFieldType
+
data Theme
@@ -264,6 +267,7 @@ instance Csv.FromField Sex where
data TokenBucketIdent = TokenBucketInjectFiles
| TokenBucketPruneFiles
+ | TokenBucketRechunkFiles
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite, Hashable)
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index 8fa709687..9df7be8ab 100644
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@@ -52,6 +52,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthTutor
| AuthTutorControl
| AuthExamOffice
+ | AuthSystemExamOffice
| AuthEvaluation
| AuthAllocationAdmin
| AuthAllocationRegistered
diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs
new file mode 100644
index 000000000..09eba6393
--- /dev/null
+++ b/src/Model/Types/User.hs
@@ -0,0 +1,16 @@
+module Model.Types.User where
+
+import Import.NoModel
+import Model.Types.TH.PathPiece
+
+
+data SystemFunction
+ = SystemExamOffice
+ | SystemFaculty
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite, Hashable, NFData)
+
+nullaryPathPiece ''SystemFunction $ camelToPathPiece' 1
+pathPieceJSON ''SystemFunction
+pathPieceJSONKey ''SystemFunction
+derivePersistFieldPathPiece ''SystemFunction
diff --git a/src/Settings.hs b/src/Settings.hs
index 56bead944..acedff5c4 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -70,6 +70,8 @@ import Text.Show (showParen, showString)
import qualified Data.List.PointedList as P
import qualified Network.Minio as Minio
+
+import Data.Conduit.Algorithms.FastCDC
-- | Runtime settings to configure this application. These settings can be
@@ -113,7 +115,7 @@ data AppSettings = AppSettings
, appMailSupport :: Address
, appJobWorkers :: Natural
, appJobFlushInterval :: Maybe NominalDiffTime
- , appJobCronInterval :: NominalDiffTime
+ , appJobCronInterval :: Maybe NominalDiffTime
, appJobStaleThreshold :: NominalDiffTime
, appNotificationRateLimit :: NominalDiffTime
, appNotificationCollateDelay :: NominalDiffTime
@@ -140,8 +142,10 @@ data AppSettings = AppSettings
, appLdapReTestFailover :: DiffTime
, appSessionFilesExpire :: NominalDiffTime
- , appPruneUnreferencedFiles :: Maybe NominalDiffTime
, appKeepUnreferencedFiles :: NominalDiffTime
+
+ , appPruneUnreferencedFilesWithin :: Maybe NominalDiffTime
+ , appPruneUnreferencedFilesInterval :: NominalDiffTime
, appInitialLogSettings :: LogSettings
@@ -172,6 +176,10 @@ data AppSettings = AppSettings
, appUploadCacheConf :: Maybe Minio.ConnectInfo
, appUploadCacheBucket :: Minio.Bucket
, appInjectFiles :: Maybe NominalDiffTime
+ , appRechunkFiles :: Maybe NominalDiffTime
+ , appFileUploadDBChunksize :: Int
+
+ , appFileChunkingParams :: FastCDCParameters
, appFavouritesQuickActionsBurstsize
, appFavouritesQuickActionsAvgInverseRate :: Word64
@@ -444,7 +452,7 @@ instance FromJSON AppSettings where
appJobWorkers <- o .: "job-workers"
appJobFlushInterval <- o .:? "job-flush-interval"
- appJobCronInterval <- o .: "job-cron-interval"
+ appJobCronInterval <- o .:? "job-cron-interval"
appJobStaleThreshold <- o .: "job-stale-threshold"
appNotificationRateLimit <- o .: "notification-rate-limit"
appNotificationCollateDelay <- o .: "notification-collate-delay"
@@ -471,9 +479,17 @@ instance FromJSON AppSettings where
appLdapReTestFailover <- o .: "ldap-re-test-failover"
appSessionFilesExpire <- o .: "session-files-expire"
- appPruneUnreferencedFiles <- o .:? "prune-unreferenced-files"
appKeepUnreferencedFiles <- o .:? "keep-unreferenced-files" .!= 0
appInjectFiles <- o .:? "inject-files"
+ appRechunkFiles <- o .:? "rechunk-files"
+ appFileUploadDBChunksize <- o .: "file-upload-db-chunksize"
+
+ appFileChunkingTargetExponent <- o .: "file-chunking-target-exponent"
+ appFileChunkingHashWindow <- o .: "file-chunking-hash-window"
+ appFileChunkingParams <- maybe (fail "Could not recommend FastCDCParameters") return $ recommendFastCDCParameters appFileChunkingTargetExponent appFileChunkingHashWindow
+
+ appPruneUnreferencedFilesWithin <- o .: "prune-unreferenced-files-within"
+ appPruneUnreferencedFilesInterval <- o .: "prune-unreferenced-files-interval"
appMaximumContentLength <- o .: "maximum-content-length"
diff --git a/src/Utils.hs b/src/Utils.hs
index 6a5bd9105..5f25e1ac3 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -56,7 +56,8 @@ import Control.Arrow as Utils ((>>>))
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
-import Control.Monad.Trans.Writer.Lazy (WriterT, execWriterT, tell)
+import Control.Monad.Trans.Writer.Strict (execWriterT)
+import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Catch
import Control.Monad.Morph (hoist)
import Control.Monad.Fail
@@ -83,6 +84,9 @@ import qualified Crypto.Saltine.Class as Saltine
import qualified Crypto.Data.PKCS7 as PKCS7
import Crypto.MAC.KMAC (KMAC, HashSHAKE)
import qualified Crypto.MAC.KMAC as KMAC
+import qualified Crypto.Hash as Crypto
+import Crypto.Hash (HashAlgorithm, Digest)
+import Crypto.Hash.Instances ()
import Data.ByteArray (ByteArrayAccess)
@@ -483,6 +487,9 @@ setProduct (Set.toAscList -> as) (Set.toAscList -> bs) = Set.fromDistinctAscList
setPartitionEithers :: (Ord a, Ord b) => Set (Either a b) -> (Set a, Set b)
setPartitionEithers = (,) <$> setMapMaybe (preview _Left) <*> setMapMaybe (preview _Right)
+setFromFunc :: (Finite k, Ord k) => (k -> Bool) -> Set k
+setFromFunc = Set.fromList . flip filter universeF
+
----------
-- Maps --
----------
@@ -840,7 +847,7 @@ diffTimeout timeoutLength timeoutRes act = fromMaybe timeoutRes <$> timeout time
= let (MkFixed micro :: Micro) = realToFrac timeoutLength
in fromInteger micro
-tellM :: (Monad m, Monoid x) => m x -> WriterT x m ()
+tellM :: (MonadTrans t, MonadWriter x (t m), Monad m) => m x -> t m ()
tellM = tell <=< lift
-------------
@@ -853,6 +860,19 @@ peekN n = do
mapM_ leftover peeked
return peeked
+peekWhile :: forall a o m. Monad m => (a -> Bool) -> ConduitT a o m [a]
+peekWhile p = do
+ let go acc = do
+ next <- await
+ case next of
+ Nothing -> return (reverse acc, Nothing)
+ Just x
+ | p x -> go $ x : acc
+ | otherwise -> return (reverse acc, Just x)
+ (peeked, failed) <- go []
+ mapM_ leftover $ peeked ++ hoistMaybe failed
+ return peeked
+
anyMC, allMC :: forall a o m. Monad m => (a -> m Bool) -> ConduitT a o m Bool
anyMC f = C.mapM f .| orC
allMC f = C.mapM f .| andC
@@ -1054,6 +1074,12 @@ kmaclazy :: forall a string key ba chunk.
-> KMAC a
kmaclazy str k = KMAC.finalize . KMAC.updates (KMAC.initialize @a str k) . toChunks
+emptyHash :: forall a. HashAlgorithm a => Q (TExp (Digest a))
+-- ^ Hash of `mempty`
+--
+-- Computationally preferrable to computing the hash at runtime
+emptyHash = TH.liftTyped $ Crypto.hashFinalize Crypto.hashInit
+
-------------
-- Caching --
-------------
diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs
index 08a70924e..6847ea0cf 100644
--- a/src/Utils/DB.hs
+++ b/src/Utils/DB.hs
@@ -78,6 +78,9 @@ updateBy uniq updates = do
key <- getKeyBy uniq
for_ key $ flip update updates
+updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record)
+updateGetEntity k = fmap (Entity k) . updateGet k
+
-- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible,
-- and 'Just key' for the successfully replaced record
uniqueReplace :: ( MonadIO m
diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs
index 0138a93c4..3119313da 100644
--- a/src/Utils/Files.hs
+++ b/src/Utils/Files.hs
@@ -3,6 +3,7 @@ module Utils.Files
, sinkFile', sinkFiles'
, FileUploads
, replaceFileReferences, replaceFileReferences'
+ , sinkFileDB, sinkFileMinio
) where
import Import.NoFoundation
@@ -11,31 +12,54 @@ import Handler.Utils.Minio
import qualified Network.Minio as Minio
import qualified Crypto.Hash as Crypto (hash)
+import qualified Crypto.Hash.Conduit as Crypto (sinkHash)
import qualified Data.Conduit.Combinators as C
-
-import qualified Data.ByteString.Base64.URL as Base64
-import qualified Data.ByteArray as ByteArray
+import qualified Data.Conduit.List as C (unfoldM)
import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set
import Control.Monad.State.Class (modify)
+import qualified Data.Sequence as Seq
+
import Database.Persist.Sql (deleteWhereCount)
import Control.Monad.Trans.Resource (allocate)
+import qualified Data.UUID.V4 as UUID
-sinkFiles :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT File FileReference (SqlPersistT m) ()
-sinkFiles = C.mapM sinkFile
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import Data.Conduit.Algorithms.FastCDC (fastCDC)
+
+
+sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX)
+ => Bool -- ^ Replace? Use only in serializable transaction
+ -> ConduitT () ByteString (SqlPersistT m) ()
+ -> SqlPersistT m FileContentReference
+sinkFileDB doReplace fileContentContent = do
+ chunkingParams <- getsYesod $ view _appFileChunkingParams
+
+ let sinkChunk fileContentChunkContent = do
+ fileChunkLockTime <- liftIO getCurrentTime
+ fileChunkLockInstance <- getsYesod appInstanceID
+
+ tellM $ Set.singleton <$> insert FileChunkLock{ fileChunkLockHash = fileContentChunkHash, .. }
+ existsChunk <- lift $ exists [FileContentChunkHash ==. fileContentChunkHash]
+ let setContentBased = updateWhere [FileContentChunkHash ==. fileContentChunkHash] [FileContentChunkContentBased =. fileContentChunkContentBased]
+ if | existsChunk -> lift setContentBased
+ | otherwise -> lift . handleIfSql isUniqueConstraintViolation (const setContentBased) $
+ insert_ FileContentChunk{..}
+ return $ FileContentChunkKey fileContentChunkHash
+ where fileContentChunkHash = _Wrapped # Crypto.hash fileContentChunkContent
+ ((review _Wrapped -> fileContentHash, fileContentChunks), chunkLocks) <- runConduit . runWriterC $
+ transPipe lift fileContentContent
+ .| fastCDC chunkingParams
+ .| C.mapM (\c -> (c, ) <$> sinkChunk c)
+ .| transPipe lift (getZipConduit $ (,) <$> ZipConduit (C.map (view _1) .| Crypto.sinkHash) <*> ZipConduit (C.foldMap $ views _2 Seq.singleton))
-sinkFile :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => File -> SqlPersistT m FileReference
-sinkFile File{ fileContent = Nothing, .. } = return FileReference
- { fileReferenceContent = Nothing
- , fileReferenceTitle = fileTitle
- , fileReferenceModified = fileModified
- }
-sinkFile File{ fileContent = Just fileContentContent, .. } = do
void . withUnliftIO $ \UnliftIO{..} ->
let takeLock = do
fileLockTime <- liftIO getCurrentTime
@@ -44,35 +68,93 @@ sinkFile File{ fileContent = Just fileContentContent, .. } = do
releaseLock lId = liftHandler . runDB $ (withReaderT projectBackend $ setSerializable (delete lId :: SqlPersistT (HandlerFor UniWorX) ()) :: YesodDB UniWorX ())
in unliftIO $ allocate (unliftIO takeLock) (unliftIO . releaseLock)
- inDB <- exists [ FileContentHash ==. fileContentHash ]
+ deleteWhere [ FileChunkLockId <-. Set.toList chunkLocks ]
- let sinkFileDB = unless inDB $ repsert (FileContentKey fileContentHash) FileContent{ fileContentUnreferencedSince = Nothing, .. }
- maybeT sinkFileDB $ do
- let uploadName = decodeUtf8 . Base64.encodeUnpadded $ ByteArray.convert fileContentHash
- uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
- unless inDB . runAppMinio $ do
- uploadExists <- handleIf minioIsDoesNotExist (const $ return False) $ True <$ Minio.statObject uploadBucket uploadName Minio.defaultGetObjectOptions
- unless uploadExists $ do
- let
- pooOptions = Minio.defaultPutObjectOptions
- { Minio.pooCacheControl = Just "immutable"
- }
- Minio.putObject uploadBucket uploadName (C.sourceLazy $ fromStrict fileContentContent) (Just . fromIntegral $ olength fileContentContent) pooOptions
- -- Note that MinIO does not accept length zero uploads without an explicit length specification (not `Nothing` in the line above for the api we use)
+ let entryExists = E.selectExists . E.from $ \fileContentEntry -> E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileContentHash
+ insertEntries = handleIfSql isUniqueConstraintViolation (const $ return ()) . void $ insertMany_
+ [ FileContentEntry{ fileContentEntryHash = fileContentHash, .. }
+ | fileContentEntryChunkHash <- otoList fileContentChunks
+ | fileContentEntryIx <- [0..]
+ ]
+ if | not doReplace -> unlessM entryExists insertEntries
+ | otherwise -> do
+ deleteWhere [ FileContentEntryHash ==. fileContentHash ]
+ insertEntries
+
+
+ return fileContentHash
+ where fileContentChunkContentBased = True
+
+
+sinkFileMinio :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m)
+ => ConduitT () ByteString m ()
+ -> MaybeT m FileContentReference
+-- ^ Cannot deal with zero length uploads
+sinkFileMinio fileContentContent = do
+ uploadBucket <- getsYesod $ views appSettings appUploadCacheBucket
+ chunk <- liftIO newEmptyMVar
+ let putChunks = do
+ nextChunk <- await
+ case nextChunk of
+ Nothing
+ -> putMVar chunk Nothing
+ Just nextChunk'
+ -> putMVar chunk (Just nextChunk') >> yield nextChunk' >> putChunks
+ sinkAsync <- lift . allocateLinkedAsync . runConduit
+ $ fileContentContent
+ .| putChunks
+ .| Crypto.sinkHash
+
+ runAppMinio $ do
+ tmpUUID <- liftIO UUID.nextRandom
+ let uploadName = ".tmp." <> toPathPiece tmpUUID
+ pooOptions = Minio.defaultPutObjectOptions
+ { Minio.pooCacheControl = Just "immutable"
+ }
+ Minio.putObject uploadBucket uploadName (C.unfoldM (\x -> fmap (, x) <$> takeMVar chunk) ()) Nothing pooOptions
+ fileContentHash <- review _Wrapped <$> waitAsync sinkAsync
+ let dstName = minioFileReference # fileContentHash
+ copySrc = Minio.defaultSourceInfo
+ { Minio.srcBucket = uploadBucket, Minio.srcObject = uploadName
+ }
+ copyDst = Minio.defaultDestinationInfo
+ { Minio.dstBucket = uploadBucket
+ , Minio.dstObject = dstName
+ }
+ uploadExists <- handleIf minioIsDoesNotExist (const $ return False) $ True <$ Minio.statObject uploadBucket dstName Minio.defaultGetObjectOptions
+ unless uploadExists $
+ Minio.copyObject copyDst copySrc
+ Minio.removeObject uploadBucket uploadName
+ return fileContentHash
+
+
+sinkFiles :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT (File (SqlPersistT m)) FileReference (SqlPersistT m) ()
+sinkFiles = C.mapM sinkFile
+
+sinkFile :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => File (SqlPersistT m) -> SqlPersistT m FileReference
+sinkFile File{ fileContent = Nothing, .. } = return FileReference
+ { fileReferenceContent = Nothing
+ , fileReferenceTitle = fileTitle
+ , fileReferenceModified = fileModified
+ }
+sinkFile File{ fileContent = Just fileContentContent, .. } = do
+ (unsealConduitT -> fileContentContent', isEmpty) <- fileContentContent $$+ is _Nothing <$> C.peekE
+
+ fileContentHash <- if
+ | not isEmpty -> maybeT (sinkFileDB False fileContentContent') $ sinkFileMinio fileContentContent'
+ | otherwise -> return $$(liftTyped $ FileContentReference $$(emptyHash))
return FileReference
{ fileReferenceContent = Just fileContentHash
, fileReferenceTitle = fileTitle
, fileReferenceModified = fileModified
}
- where
- fileContentHash = Crypto.hash fileContentContent
-sinkFiles' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) ()
+sinkFiles' :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => ConduitT (File (SqlPersistT m), FileReferenceResidual record) record (SqlPersistT m) ()
sinkFiles' = C.mapM $ uncurry sinkFile'
-sinkFile' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => File -> FileReferenceResidual record -> SqlPersistT m record
+sinkFile' :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => File (SqlPersistT m) -> FileReferenceResidual record -> SqlPersistT m record
sinkFile' file residual = do
reference <- sinkFile file
return $ _FileReference # (reference, residual)
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index b894c3137..2fa06586a 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -215,6 +215,7 @@ data FormIdentifier
| FIDDelete
| FIDCourseRegister
| FIDuserRights
+ | FIDUserSystemFunctions
| FIDcUserNote
| FIDcRegField
| FIDcRegButton
diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs
index 2a03a76da..ad51820d0 100644
--- a/src/Utils/Sql.hs
+++ b/src/Utils/Sql.hs
@@ -1,22 +1,32 @@
module Utils.Sql
( setSerializable, setSerializable'
+ , catchSql, handleSql
+ , isUniqueConstraintViolation
+ , catchIfSql, handleIfSql
) where
-import ClassyPrelude.Yesod
+import ClassyPrelude.Yesod hiding (handle)
import Numeric.Natural
import Settings.Log
-import Database.PostgreSQL.Simple (SqlError)
+import Database.PostgreSQL.Simple (SqlError(..))
import Database.PostgreSQL.Simple.Errors (isSerializationError)
-import Control.Monad.Catch (MonadMask)
+import Control.Monad.Catch
import Database.Persist.Sql
import Database.Persist.Sql.Raw.QQ
+import qualified Data.ByteString as ByteString
+
import Control.Retry
import Control.Lens ((&))
+import qualified Data.UUID as UUID
+import Control.Monad.Random.Class (MonadRandom(getRandom))
+
+import Text.Shakespeare.Text (st)
+
setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => SqlPersistT m a -> SqlPersistT m a
setSerializable = setSerializable' $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6
@@ -54,5 +64,29 @@ setSerializable' policy act = do
transactionSaveWithIsolation ReadCommitted
return res
+catchSql :: forall m a. (MonadCatch m, MonadIO m) => SqlPersistT m a -> (SqlError -> SqlPersistT m a) -> SqlPersistT m a
+catchSql = flip handleSql
+handleSql :: forall m a. (MonadCatch m, MonadIO m) => (SqlError -> SqlPersistT m a) -> SqlPersistT m a -> SqlPersistT m a
+handleSql recover act = do
+ savepointName <- liftIO $ UUID.toString <$> getRandom
+ let recover' :: SqlError -> SqlPersistT m a
+ recover' exc = do
+ rawExecute [st|ROLLBACK TO SAVEPOINT "#{savepointName}"|] []
+ recover exc
+
+ handle recover' $ do
+ rawExecute [st|SAVEPOINT "#{savepointName}"|] []
+ res <- act
+ rawExecute [st|RELEASE SAVEPOINT "#{savepointName}"|] []
+ return res
+
+catchIfSql :: forall m a. (MonadCatch m, MonadIO m) => (SqlError -> Bool) -> SqlPersistT m a -> (SqlError -> SqlPersistT m a) -> SqlPersistT m a
+catchIfSql p = flip $ handleIfSql p
+
+handleIfSql :: forall m a. (MonadCatch m, MonadIO m) => (SqlError -> Bool) -> (SqlError -> SqlPersistT m a) -> SqlPersistT m a -> SqlPersistT m a
+handleIfSql p recover = handleSql (\err -> bool throwM recover (p err) err)
+
+isUniqueConstraintViolation :: SqlError -> Bool
+isUniqueConstraintViolation SqlError{..} = "duplicate key value violates unique constraint" `ByteString.isPrefixOf` sqlErrorMsg
diff --git a/stack.yaml b/stack.yaml
index bedc224c5..fbbcd4aaa 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -47,6 +47,15 @@ extra-deps:
- filepath-crypto
- uuid-crypto
+ - git: https://github.com/gkleen/FastCDC.git
+ commit: 7326e2931454282df9081105dad812845db5c530
+ subdirs:
+ - gearhash
+ - fastcdc
+
+ - git: git@gitlab2.rz.ifi.lmu.de:uni2work/zip-stream.git
+ commit: 843683d024f767de236f74d24a3348f69181a720
+
- generic-lens-1.2.0.0@sha256:b19e7970c93743a46bc3702331512a96d163de4356472f2d51a2945887aefe8c,6524 # manual downgrade; won't compile with >=2.0.0.0
- acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
@@ -65,6 +74,7 @@ extra-deps:
- tz-0.1.3.4@sha256:bd311e202b8bdd15bcd6a4ca182e69794949d3b3b9f4aa835e9ccff011284979,5086
- unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
- wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
+ - primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604
resolver: nightly-2020-08-08
compiler: ghc-8.10.2
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 9dd64cf44..053ebc2d9 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -5,9 +5,6 @@
packages:
- completed:
- cabal-file:
- size: 4229
- sha256: 0dcfe3c4a67be4e96e1ae2e3c4b8744bc11e094853005a32f6074ab776caa3a9
name: encoding
version: 0.8.2
git: git@gitlab2.rz.ifi.lmu.de:uni2work/encoding.git
@@ -19,9 +16,6 @@ packages:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/encoding.git
commit: 22fc3bb14841d8d50997aa47f1be3852e666f787
- completed:
- cabal-file:
- size: 2399
- sha256: 20cdf97602abb8fd7356c1a64c69fa857e34ab4cfe7834460d2ad783f7e4e4e3
name: memcached-binary
version: 0.2.0
git: git@gitlab2.rz.ifi.lmu.de:uni2work/memcached-binary.git
@@ -33,9 +27,6 @@ packages:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/memcached-binary.git
commit: b7071df50bad3a251a544b984e4bf98fa09b8fae
- completed:
- cabal-file:
- size: 1423
- sha256: 49818ee0de2d55cbfbc15ca4de1761c3adac6ba3dfcdda960b413cad4f4fa47f
name: conduit-resumablesink
version: '0.3'
git: git@gitlab2.rz.ifi.lmu.de:uni2work/conduit-resumablesink.git
@@ -47,9 +38,6 @@ packages:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/conduit-resumablesink.git
commit: cbea6159c2975d42f948525e03e12fc390da53c5
- completed:
- cabal-file:
- size: 2069
- sha256: 9192ac19ea5da3cd4b8c86a4266592aff7b9256311aa5f42ae6de94ccacf1366
name: HaskellNet
version: 0.5.1
git: git://github.com/jtdaugherty/HaskellNet.git
@@ -61,9 +49,6 @@ packages:
git: git://github.com/jtdaugherty/HaskellNet.git
commit: 5aa1f3b009253b02c4822005ac59ee208a10a347
- completed:
- cabal-file:
- size: 1934
- sha256: 9fbe7c3681e963eea213ab38be17966bb690788c1c55a67257916b677d7d2ec2
name: HaskellNet-SSL
version: 0.3.4.1
git: git@gitlab2.rz.ifi.lmu.de:uni2work/HaskellNet-SSL.git
@@ -75,9 +60,6 @@ packages:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/HaskellNet-SSL.git
commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8
- completed:
- cabal-file:
- size: 2208
- sha256: 48f6e03d8f812bd24e2601497ffe9c8a78907fa2266ba05abeefdfe99221617d
name: ldap-client
version: 0.4.0
git: git@gitlab2.rz.ifi.lmu.de:uni2work/ldap-client.git
@@ -90,9 +72,6 @@ packages:
commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0
- completed:
subdir: serversession
- cabal-file:
- size: 2081
- sha256: a958ff0007e5084e3e4c2a33acc9860c31186105f02f8ab99ecb847a7a8f9497
name: serversession
version: 1.0.1
git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
@@ -106,9 +85,6 @@ packages:
commit: 1c95b0100471279413485411032d639881012a5e
- completed:
subdir: serversession-backend-acid-state
- cabal-file:
- size: 1875
- sha256: 6cc9d29e788334670bc102213a8aae73bc1b8b0a00c416f06d232376750443b7
name: serversession-backend-acid-state
version: 1.0.3
git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
@@ -121,9 +97,6 @@ packages:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/serversession.git
commit: 1c95b0100471279413485411032d639881012a5e
- completed:
- cabal-file:
- size: 1966
- sha256: 92d6d7be95a1ee6cb9783deb35e0d4e4959c7de20d518a45370084b57e20ba51
name: xss-sanitize
version: 0.3.6
git: git@gitlab2.rz.ifi.lmu.de:uni2work/xss-sanitize.git
@@ -136,9 +109,6 @@ packages:
commit: 074ed7c8810aca81f60f2c535f9e7bad67e9d95a
- completed:
subdir: colonnade
- cabal-file:
- size: 2020
- sha256: 28f603d097aee65ddf8fe032e7e0f87523a58c516253cba196922027c8fd54d5
name: colonnade
version: 1.2.0.2
git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git
@@ -151,9 +121,6 @@ packages:
git: git@gitlab2.rz.ifi.lmu.de:uni2work/colonnade.git
commit: f8170266ab25b533576e96715bedffc5aa4f19fa
- completed:
- cabal-file:
- size: 9845
- sha256: 674630347209bc5f7984e8e9d93293510489921f2d2d6092ad1c9b8c61b6560a
name: minio-hs
version: 1.5.2
git: git@gitlab2.rz.ifi.lmu.de:uni2work/minio-hs.git
@@ -166,9 +133,6 @@ packages:
commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1
- completed:
subdir: cryptoids-class
- cabal-file:
- size: 1155
- sha256: 1fa96858ded816798f8e1c77d7945185c0d7ceb2536185d39fc72496da8a0125
name: cryptoids-class
version: 0.0.0
git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
@@ -182,9 +146,6 @@ packages:
commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f
- completed:
subdir: cryptoids-types
- cabal-file:
- size: 1214
- sha256: ee8966212554a156f2de236d4f005ff3a9d3098778ff6cc3f114ccaa0aff8825
name: cryptoids-types
version: 1.0.0
git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
@@ -198,9 +159,6 @@ packages:
commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f
- completed:
subdir: cryptoids
- cabal-file:
- size: 1505
- sha256: fcf07cd0dca21db976c25cbdf4dcc5c747cebcb7bf14c05804c8ae14223f6046
name: cryptoids
version: 0.5.1.0
git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
@@ -214,9 +172,6 @@ packages:
commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f
- completed:
subdir: filepath-crypto
- cabal-file:
- size: 1716
- sha256: 218da063bb7b00e3728deebf830904174b2b78bc29b3f203e6824b8caac92788
name: filepath-crypto
version: 0.1.0.0
git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
@@ -230,9 +185,6 @@ packages:
commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f
- completed:
subdir: uuid-crypto
- cabal-file:
- size: 1460
- sha256: 1db54db1b85303e50cec3c99ddb8de6c9bedc388fa9ce5a1fce61520023b9ee5
name: uuid-crypto
version: 1.4.0.0
git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
@@ -244,6 +196,43 @@ packages:
subdir: uuid-crypto
git: git@gitlab2.rz.ifi.lmu.de:uni2work/cryptoids.git
commit: 4d91394475b144ea5bf7ba111f93756cc0de8a3f
+- completed:
+ subdir: gearhash
+ name: gearhash
+ version: 0.0.0
+ git: https://github.com/gkleen/FastCDC.git
+ pantry-tree:
+ size: 504
+ sha256: 61a08cdd003dc8a418f410dacbcc3a91adea4c23864f8ddbaba3b762e4c2924d
+ commit: 7326e2931454282df9081105dad812845db5c530
+ original:
+ subdir: gearhash
+ git: https://github.com/gkleen/FastCDC.git
+ commit: 7326e2931454282df9081105dad812845db5c530
+- completed:
+ subdir: fastcdc
+ name: fastcdc
+ version: 0.0.0
+ git: https://github.com/gkleen/FastCDC.git
+ pantry-tree:
+ size: 244
+ sha256: 80ae3d79344f7c6a73a8d7adf07ff2b7f0736fd34760b4b8a15e26f32d9773f6
+ commit: 7326e2931454282df9081105dad812845db5c530
+ original:
+ subdir: fastcdc
+ git: https://github.com/gkleen/FastCDC.git
+ commit: 7326e2931454282df9081105dad812845db5c530
+- completed:
+ name: zip-stream
+ version: 0.2.0.1
+ git: git@gitlab2.rz.ifi.lmu.de:uni2work/zip-stream.git
+ pantry-tree:
+ size: 812
+ sha256: 0da8bc38d73034962d2e2d1a7586b6dee848a629319fce9cbbf578348c61118c
+ commit: 843683d024f767de236f74d24a3348f69181a720
+ original:
+ git: git@gitlab2.rz.ifi.lmu.de:uni2work/zip-stream.git
+ commit: 843683d024f767de236f74d24a3348f69181a720
- completed:
hackage: generic-lens-1.2.0.0@sha256:b19e7970c93743a46bc3702331512a96d163de4356472f2d51a2945887aefe8c,6524
pantry-tree:
@@ -363,6 +352,13 @@ packages:
sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402
original:
hackage: wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
+- completed:
+ hackage: primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604
+ pantry-tree:
+ size: 1376
+ sha256: 924e88629b493abb6b2f3c3029cef076554a2b627091e3bb6887ec03487a707d
+ original:
+ hackage: primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604
snapshots:
- completed:
size: 524392
diff --git a/templates/adminUser.hamlet b/templates/adminUser.hamlet
index af9c9f5c2..6012e38d7 100644
--- a/templates/adminUser.hamlet
+++ b/templates/adminUser.hamlet
@@ -4,6 +4,7 @@ $newline never
_{MsgAdminUserRightsHeading}
+ ^{systemFunctionsForm}
^{rightsForm}
diff --git a/templates/course/lecturerMassInput/cellInvitation.hamlet b/templates/course/lecturerMassInput/cellInvitation.hamlet
index 6e95bcf1f..24e43a5a7 100644
--- a/templates/course/lecturerMassInput/cellInvitation.hamlet
+++ b/templates/course/lecturerMassInput/cellInvitation.hamlet
@@ -1,7 +1,7 @@
$newline never
|
#{csrf}
-
+
#{lEmail}
|
^{messageTooltip invWarnMsg}
diff --git a/templates/course/user/profile.hamlet b/templates/course/user/profile.hamlet
index 20b3417e0..7fb7dee81 100644
--- a/templates/course/user/profile.hamlet
+++ b/templates/course/user/profile.hamlet
@@ -44,14 +44,15 @@ $newline never
| _{MsgStudyFeatureAge}
| _{MsgStudyFeatureValid}
| _{MsgStudyFeatureUpdate}
- $forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesUpdated}), (Entity _ degree), (Entity _ field)) <- studies
+ $forall ((Entity _ StudyFeatures{studyFeaturesType, studyFeaturesSemester, studyFeaturesValid, studyFeaturesFirstObserved, studyFeaturesLastObserved}), (Entity _ degree), (Entity _ field)) <- studies
|
| _{field}
| _{degree}
| _{studyFeaturesType}
| #{studyFeaturesSemester}
| #{hasTickmark studyFeaturesValid}
- | ^{formatTimeW SelFormatDate studyFeaturesUpdated}
- $maybe _ <- mRegistration
- - _{MsgCourseStudyFeature}
-
- ^{regFieldWidget}
+
+ $maybe fObs <- studyFeaturesFirstObserved
+ ^{formatTimeRangeW SelFormatDate fObs $ Just studyFeaturesLastObserved}
+ $nothing
+ ^{formatTimeW SelFormatDate studyFeaturesLastObserved}
diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet
index efb7f534d..176cf01fd 100644
--- a/templates/exam-show.hamlet
+++ b/templates/exam-show.hamlet
@@ -87,8 +87,8 @@ $maybe desc <- examDescription
$maybe registerWdgt <- registerWidget Nothing
-
_{MsgExamRegistration}
- \ ^{isVisible False}
-
- ^{registerWdgt}
+
-
+ ^{registerWdgt}
$if showCloseWidget && is _Nothing examClosed
diff --git a/templates/external-exam-show.hamlet b/templates/external-exam-show.hamlet
index e9fbf5c95..9604f7be4 100644
--- a/templates/external-exam-show.hamlet
+++ b/templates/external-exam-show.hamlet
@@ -51,6 +51,6 @@ $maybe ExternalExamResult{externalExamResultResult} <- mResult
-
^{nameEmailWidget userDisplayEmail userDisplayName userSurname}
$of Left email
-
-
+
-
#{email}
diff --git a/templates/external-exam/staffMassInput/cellInvitation.hamlet b/templates/external-exam/staffMassInput/cellInvitation.hamlet
index df7df418a..284762127 100644
--- a/templates/external-exam/staffMassInput/cellInvitation.hamlet
+++ b/templates/external-exam/staffMassInput/cellInvitation.hamlet
@@ -1,6 +1,6 @@
$newline never
|
-
+
#{email}
|
^{messageTooltip invWarnMsg}
diff --git a/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet
index ea82247c6..e0e41fb22 100644
--- a/templates/i18n/changelog/de-de-formal.hamlet
+++ b/templates/i18n/changelog/de-de-formal.hamlet
@@ -1,5 +1,14 @@
$newline never
+ -
+ ^{formatGregorianW 2020 08 28}
+
-
+
+ -
+ Kursassoziierte Studienfächer wurden abgeschafft.
+
+ Es werden nun an allen kursbezogenen Stellen jene Studiendaten angezeigt, die während des entsprechenden Semesters aktuell waren.
+
-
^{formatGregorianW 2020 08 10}
-
diff --git a/templates/i18n/changelog/en-eu.hamlet b/templates/i18n/changelog/en-eu.hamlet
index fb9f04bbe..ef3f6e194 100644
--- a/templates/i18n/changelog/en-eu.hamlet
+++ b/templates/i18n/changelog/en-eu.hamlet
@@ -1,5 +1,14 @@
$newline never
+ -
+ ^{formatGregorianW 2020 08 28}
+
-
+
+ -
+ Abolished course-associated features of study.
+
+ In course-related contexts now all study features which were up to date during the relevant term are displayed.
+
-
^{formatGregorianW 2020 08 10}
-
diff --git a/templates/mail/support.hamlet b/templates/mail/support.hamlet
index 623ba907f..f85790925 100644
--- a/templates/mail/support.hamlet
+++ b/templates/mail/support.hamlet
@@ -3,6 +3,10 @@ $newline never
+
| | |