+ ^{nameEmailWidget userEmail userDisplayName userSurname}
+ |]
+ , sortable (Just "room") (i18nCell MsgTutorialRoom) $ maybe mempty textCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom)
+ , sortable Nothing (i18nCell MsgTutorialTime) $ occurrencesCell . view (_dbrOutput . _1 . _entityVal . _tutorialTime)
+ ]
+ dbtSorting = mconcat
+ [ singletonMap "type" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialType
+ , singletonMap "name" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialName
+ , singletonMap "room" . SortColumn $ \(tutorial `E.InnerJoin` _) -> tutorial E.^. TutorialRoom
+ , singletonMap "tutors" . SortColumn $ \(tutorial `E.InnerJoin` _) -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do
+ E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
+ E.where_ $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
+ return . E.min_ $ user E.^. UserSurname
+ ]
+ dbtFilter = mempty
+ dbtFilterUI _mPrev = mempty
+ dbtStyle = def
+ dbtParams = DBParamsForm
+ { dbParamsFormMethod = POST
+ , dbParamsFormAction = Just . SomeRoute . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
+ , dbParamsFormAttrs = []
+ , dbParamsFormSubmit = FormSubmit
+ , dbParamsFormAdditional = \csrf -> do
+ let
+ actionMap :: Map TutorialAction (AForm Handler TutorialActionData)
+ actionMap = mconcat
+ [ singletonMap TutorialDeregister $
+ pure TutorialDeregisterData
+ ]
+
+ (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
+ let formRes = (, mempty) . First . Just <$> res
+ return (formRes, formWgt)
+ , dbParamsFormEvaluate = liftHandler . runFormPost
+ , dbParamsFormResult = _2
+ , dbParamsFormIdent = def
+ }
+ dbtIdent :: Text
+ dbtIdent = "tutorials"
+ dbtCsvEncode = noCsvEncode
+ dbtCsvDecode = Nothing
+ tutorialDBTableValidator = def & defaultSorting [SortAscBy "type", SortAscBy "name"]
+ postprocess :: FormResult (First TutorialActionData, DBFormResult TutorialParticipantId (Bool, _) _) -> FormResult (TutorialActionData, Map TutorialParticipantId _)
+ postprocess inp = do
+ (First (Just act), regMap) <- inp
+ let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap
+ return (act, regMap')
+ ((Any hasTutorials, actRes), tutorialTable) <- lift . runDB $ over (_1 . _2) postprocess <$> dbTable tutorialDBTableValidator tutorialDBTable
+
+ lift . formResult actRes $ \case
+ (TutorialDeregisterData, Map.keys -> selectedTutParts) -> do
+ nrDel <- runDB $ deleteWhereCount [ TutorialParticipantId <-. selectedTutParts ]
+ if | nrDel > 0 -> addMessageI Success $ MsgCourseUserTutorialsDeregistered nrDel
+ | otherwise -> addMessageI Info MsgCourseUserNoTutorialsDeregistered
+ redirect . CourseR courseTerm courseSchool courseShorthand $ CUserR uCID
+
+ guard hasTutorials
+
+ return $(widgetFile "course/user/tutorials")
diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs
index a3a0ee89b..b50644b09 100644
--- a/src/Handler/Course/Users.hs
+++ b/src/Handler/Course/Users.hs
@@ -11,6 +11,7 @@ import Import
import Utils.Form
import Handler.Utils
+import Handler.Utils.Course
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
@@ -29,6 +30,8 @@ import qualified Data.Conduit.List as C
import qualified Data.CaseInsensitive as CI
+import Database.Persist.Sql (updateWhereCount)
+
type UserTableExpr = ( E.SqlExpr (Entity User)
`E.InnerJoin` E.SqlExpr (Entity CourseParticipant)
@@ -38,6 +41,9 @@ type UserTableExpr = ( E.SqlExpr (Entity User)
`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))
+ )
-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
-- forceUserTableType = id
@@ -45,54 +51,66 @@ 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 3 1)
+queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
-queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
+queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
-queryUserNote = $(sqlLOJproj 3 2)
+queryUserNote = $(sqlLOJproj 4 2)
queryFeaturesStudy :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
-queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
+queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 4 3)
queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
-queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
+queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 4 3)
queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
-queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
+queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 4 3)
+
+querySubmissionGroup :: UserTableExpr -> E.SqlExpr (Maybe (Entity SubmissionGroup))
+querySubmissionGroup = $(sqlIJproj 2 1) . $(sqlLOJproj 4 4)
userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
- , E.SqlExpr (E.Value UTCTime)
+ , E.SqlExpr (Entity CourseParticipant)
, E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
- , StudyFeaturesDescription')
-userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
+ , 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
-- 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 E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)
+ return (user, participant, note E.?. CourseUserNoteId, features, subGroup)
type UserTableData = DBRow ( Entity User
- , UTCTime
+ , Entity CourseParticipant
, Maybe CourseUserNoteId
, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
, ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
+ , [Entity Exam]
+ , Maybe (Entity SubmissionGroup)
)
instance HasEntity UserTableData User where
hasEntity = _dbrOutput . _1
instance HasUser UserTableData where
- -- hasUser = _entityVal
hasUser = _dbrOutput . _1 . _entityVal
+_userTableParticipant :: Lens' UserTableData (Entity CourseParticipant)
+_userTableParticipant = _dbrOutput . _2
+
_userTableRegistration :: Lens' UserTableData UTCTime
-_userTableRegistration = _dbrOutput . _2
+_userTableRegistration = _userTableParticipant . _entityVal . _courseParticipantRegistration
_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
_userTableNote = _dbrOutput . _3
@@ -106,11 +124,17 @@ _rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
_userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
_userTutorials = _dbrOutput . _5
+_userExams :: Lens' UserTableData [Entity Exam]
+_userExams = _dbrOutput . _6
+
+_userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup)
+_userSubmissionGroup = _dbrOutput . _7 . _Just
+
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserComment tid ssh csh =
sortable (Just "note") (i18nCell MsgCourseUserNote)
- $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey, _, _) } ->
+ $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey, _, _, _, _) } ->
maybeEmpty mbNoteKey $ const $
anchorCellM (courseLink <$> encrypt uid) (hasComment True)
where
@@ -124,6 +148,14 @@ colUserTutorials tid ssh csh = sortable (Just "tutorials") (i18nCell MsgCourseUs
(\(Entity _ Tutorial{..}) -> CTutorialR tid ssh csh tutorialName TUsersR)
(tutorialName . entityVal)
+colUserExams :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
+colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams)
+ $ \(view _userExams -> exams') ->
+ let exams = sortOn (examName . entityVal) exams'
+ in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell exams $ anchorCell'
+ (\(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
@@ -147,6 +179,10 @@ colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDeg
colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSex' = colUserSex $ hasUser . _userSex
+colUserSubmissionGroup :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserSubmissionGroup = sortable (Just "submission-group") (i18nCell MsgSubmissionGroup) $
+ foldMap (cell . toWidget) . preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
+
data UserTableCsvStudyFeature = UserTableCsvStudyFeature
{ csvUserField :: Text
@@ -162,9 +198,11 @@ data UserTableCsv = UserTableCsv
, csvUserMatriculation :: Maybe Text
, csvUserEmail :: CI Email
, csvUserStudyFeatures :: Either (Maybe UserTableCsvStudyFeature) (Set UserTableCsvStudyFeature)
+ , csvUserSubmissionGroup :: Maybe SubmissionGroupName
, csvUserRegistration :: UTCTime
, csvUserNote :: Maybe Html
, csvUserTutorials :: ([TutorialName], Map (CI Text) (Maybe TutorialName))
+ , csvUserExams :: [ExamName]
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLenses_ ''UserTableCsv
@@ -187,12 +225,17 @@ instance Csv.ToNamedRecord UserTableCsv where
in [ "study-features" Csv..= featsStr
]
++
+ [ "submission-group" Csv..= csvUserSubmissionGroup
+ ] ++
[ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1
in "tutorial" Csv..= tutsStr
] ++
[ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut)
| (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2
] ++
+ [ let examsStr = Text.intercalate "; " $ map CI.original csvUserExams
+ in "exams" Csv..= examsStr
+ ] ++
[ "registration" Csv..= csvUserRegistration
, "note" Csv..= csvUserNote
]
@@ -206,7 +249,9 @@ instance CsvColumnsExplained UserTableCsv where
, single "field" MsgCsvColumnUserField
, single "degree" MsgCsvColumnUserDegree
, single "semester" MsgCsvColumnUserSemester
+ , single "submission-group" MsgCsvColumnUserSubmissionGroup
, single "tutorial" MsgCsvColumnUserTutorial
+ , single "exams" MsgCsvColumnUserExam
, single "registration" MsgCsvColumnUserRegistration
, single "note" MsgCsvColumnUserNote
]
@@ -228,7 +273,7 @@ userTableCsvHeader showSex UserCsvExportData{..} tuts = Csv.header $
] ++ bool (pure "study-features") ["field", "degree", "semester"] csvUserSimplifiedFeaturesOfStudy ++
[ "tutorial" | hasEmptyRegGroup ] ++
map (encodeUtf8 . CI.foldedCase) regGroups ++
- [ "registration", "note"
+ [ "exams", "registration", "note"
]
where
hasEmptyRegGroup = has (folded . _entityVal . _tutorialRegGroup . _Nothing) tuts
@@ -238,6 +283,9 @@ userTableCsvHeader showSex UserCsvExportData{..} tuts = Csv.header $
data CourseUserAction = CourseUserSendMail
| CourseUserDeregister
| CourseUserRegisterTutorial
+ | CourseUserRegisterExam
+ | CourseUserSetSubmissionGroup
+ | CourseUserReRegister
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe CourseUserAction
@@ -247,11 +295,18 @@ embedRenderMessage ''UniWorX ''CourseUserAction id
data CourseUserActionData = CourseUserSendMailData
| CourseUserDeregisterData
- { deregisterReason :: Maybe Text
+ { deregisterSelfImposed :: Maybe (Text, Bool {- no-show -})
}
| CourseUserRegisterTutorialData
{ registerTutorial :: TutorialId
}
+ | CourseUserRegisterExamData
+ { registerExam :: (ExamId, Maybe ExamOccurrenceId)
+ }
+ | CourseUserSetSubmissionGroupData
+ { setSubmissionGroup :: Maybe SubmissionGroupName
+ }
+ | CourseUserReRegisterData
deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -271,19 +326,22 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
Course{..} <- getJust cid
csvName <- getMessageRender <*> pure (MsgCourseUserCsvName courseTerm courseSchool courseShorthand)
tutorials <- selectList [ TutorialCourse ==. cid ] []
+ exams <- selectList [ ExamCourse ==. cid ] []
-- -- psValidator has default sorting and filtering
showSex <- getShowSex
let dbtIdent = "courseUsers" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
dbtRowKey = queryUser >>> (E.^. UserId)
- dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> do
- tuts'' <- lift $ selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
+ dbtProj = traverse $ \(user, participant, E.Value userNoteId, (feature,degree,terms), subGroup) -> do
+ tuts'' <- selectList [ TutorialParticipantUser ==. entityKey user, TutorialParticipantTutorial <-. map entityKey tutorials ] []
+ exams' <- selectList [ ExamRegistrationUser ==. entityKey user ] []
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'
- return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts)
+ exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams
+ return (user, participant, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts, exs, subGroup)
dbtColonnade = colChoices
dbtSorting = mconcat
[ single $ sortUserNameLink queryUser -- slower sorting through clicking name column header
@@ -310,6 +368,15 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
return . E.min_ $ tutorial E.^. TutorialName
)
+ , single $ ("exams" , SortColumn $ queryUser >>> \user ->
+ E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
+ E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
+ E.&&. exam E.^. ExamCourse E.==. E.val cid
+ E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
+ return . E.min_ $ exam E.^. ExamName
+ )
+ , single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
+ , single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
]
where single = uncurry Map.singleton
dbtFilter = mconcat
@@ -339,18 +406,30 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
)
+ , single $ ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
+ E.from $ \(exam `E.InnerJoin` examRegistration) -> do
+ E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
+ E.where_ $ exam E.^. ExamCourse E.==. E.val cid
+ E.&&. E.hasInfix (exam E.^. ExamName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
+ E.&&. examRegistration E.^. ExamRegistrationUser E.==.queryUser row E.^. UserId
+ )
-- , ("course-registration", error "TODO") -- TODO
-- , ("course-user-note", error "TODO") -- TODO
+ , single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
+ , single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
]
where single = uncurry Map.singleton
dbtFilterUI mPrev = mconcat $
- [ fltrUserNameEmailUI mPrev
+ [ prismAForm (singletonFilter "active" . maybePrism _PathPiece) mPrev $ aopt (courseParticipantStateIsActiveField . Just $ SomeMessage MsgNoFilter) (fslI MsgCourseParticipantStateIsActiveFilter)
+ , fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev
] ++
[ fltrUserSexUI mPrev | showSex ] ++
[ prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
, prismAForm (singletonFilter "field") mPrev $ aopt textField (fslI MsgCourseStudyFeature)
- , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseTutorial)
+ , 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)
]
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
@@ -406,12 +485,16 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, csvUserSemester = studyFeaturesSemester
, csvUserType = studyFeaturesType
}
+ <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
<*> view _userTableRegistration
<*> userNote
<*> (over (_2.traverse._Just) (tutorialName . entityVal) . over (_1.traverse) (tutorialName . entityVal) <$> view _userTutorials)
+ -- <*> (over (_2.traverse._Just) (examName . entityVal) . over (_1.traverse) (examName . entityVal) <$> view _userExams)
+ <*> (over traverse (examName . entityVal) <$> view _userExams)
, dbtCsvName = unpack csvName
, dbtCsvNoExportData = Nothing
, dbtCsvHeader = return . Vector.filter csvColumns' . flip (userTableCsvHeader showSex) tutorials . fromMaybe def
+ , dbtCsvExampleData = Nothing
}
where
userNote = runMaybeT $ do
@@ -432,9 +515,13 @@ courseUserDeregisterForm cid = wFormToAForm $ do
allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated)
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
if | allocated -> do
wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip
- fmap CourseUserDeregisterData <$> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
+ let selfImposedForm = (,)
+ <$> apreq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing
+ <*> apopt checkBoxField (fslI MsgCourseDeregistrationAllocationNoShow & setTooltip MsgCourseDeregistrationAllocationNoShowTip) Nothing
+ fmap CourseUserDeregisterData <$> optionalActionW selfImposedForm (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
| otherwise -> pure . pure $ CourseUserDeregisterData Nothing
getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -445,6 +532,16 @@ postCUsersR tid ssh csh = do
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
hasTutorials <- exists [TutorialCourse ==. cid]
+ examOccurrencesPerExam <- E.select . E.from $ \(exam `E.LeftOuterJoin` examOccurrence) -> do
+ E.on $ E.just (exam E.^. ExamId) E.==. examOccurrence E.?. ExamOccurrenceExam
+ E.where_ $ exam E.^. ExamCourse E.==. E.val cid
+ return (exam, examOccurrence)
+ hasSubmissionGroups <- E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` courseParticipant) -> do
+ E.on $ courseParticipant E.^. CourseParticipantUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser
+ E.&&. courseParticipant E.^. CourseParticipantCourse E.==. submissionGroup E.^. SubmissionGroupCourse
+ E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+ E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
+ let exams = nubOn entityKey $ examOccurrencesPerExam ^.. folded . _1
let colChoices = mconcat $ catMaybes
[ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
@@ -454,24 +551,56 @@ postCUsersR tid ssh csh = do
, pure $ colUserDegreeShort
, pure $ colUserField
, pure $ colUserSemester
+ , guardOn hasSubmissionGroups colUserSubmissionGroup
, guardOn hasTutorials $ colUserTutorials tid ssh csh
- , pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
+ , guardOn hasExams $ colUserExams tid ssh csh
+ , pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (maybe mempty dateCell . preview (_Just . _userTableRegistration) . assertM' (has $ _userTableParticipant . _entityVal . _courseParticipantState . _CourseParticipantActive))
+ , pure $ sortable (Just "state") (i18nCell MsgCourseUserState) (i18nCell . view (_userTableParticipant . _entityVal . _courseParticipantState))
, pure $ colUserComment tid ssh csh
]
psValidator = def & defaultSortingByName
- acts = mconcat
- [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
- , singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData <$>
- apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
- (fslI MsgCourseTutorial)
- Nothing
- , if
- | mayRegister
- -> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
- | otherwise
- -> mempty
+ & defaultFilter (singletonMap "active" [toPathPiece True])
+ hasExams = not $ null exams
+ examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
+ examOccActs = examOccurrencesPerExam
+ & (map (bimap entityKey hoistMaybe))
+ & Map.fromListWith (<>)
+ & imap (\k v -> case v of
+ [] -> pure (k, Nothing)
+ _ -> (k,) <$> aopt (selectField' (Just $ SomeMessage MsgExamNoOccurrence) $ examOccOpts v) (fslI MsgExamOccurrence) (Just Nothing)
+ )
+ where
+ examOccOpts :: [Entity ExamOccurrence] -> Handler (OptionList ExamOccurrenceId)
+ examOccOpts examOccs = fmap mkOptionList . forM examOccs $ \Entity{..} -> do
+ optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExamOccurrence
+ let
+ optionExternalValue = toPathPiece optionExternalValue'
+ optionInternalValue = entityKey
+ optionDisplay = CI.original $ examOccurrenceName entityVal
+ return Option{..}
+ examActs :: Handler (OptionList ExamId)
+ examActs = fmap mkOptionList . forM exams $ \Entity{..} -> do
+ optionExternalValue' <- encrypt entityKey :: Handler CryptoUUIDExam
+ let
+ optionExternalValue = toPathPiece optionExternalValue'
+ optionInternalValue = entityKey
+ optionDisplay = CI.original $ examName entityVal
+ return Option{..}
+ submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal)
+ acts = mconcat $ catMaybes
+ [ pure . singletonMap CourseUserSendMail $ pure CourseUserSendMailData
+ , pure . singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData
+ <$> apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
+ (fslI MsgCourseTutorial)
+ Nothing
+ , pure . singletonMap CourseUserRegisterExam $ CourseUserRegisterExamData <$>
+ multiActionAOpts examOccActs examActs (fslI MsgCourseExam) Nothing
+ , pure . singletonMap CourseUserSetSubmissionGroup $ CourseUserSetSubmissionGroupData . assertM (not . Text.null . CI.original)
+ <$> aopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
+ , guardOn mayRegister . singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
+ , guardOn mayRegister . singletonMap CourseUserReRegister $ pure CourseUserReRegisterData
]
- numParticipants <- count [CourseParticipantCourse ==. cid]
+ numParticipants <- count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator (Just $ const True)
return (ent, numParticipants, table)
formResult participantRes $ \case
@@ -481,12 +610,23 @@ postCUsersR tid ssh csh = do
(CourseUserDeregisterData{..}, selectedUsers) -> do
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
now <- liftIO getCurrentTime
- Entity _ CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid
+ Entity _ CourseParticipant{..} <- MaybeT . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
lift $ deregisterParticipant courseParticipantUser courseParticipantCourse
- case deregisterReason of
- Just reason
- | is _Just courseParticipantAllocated ->
- lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
+ case deregisterSelfImposed of
+ Just (reason, noShow)
+ | is _Just courseParticipantAllocated -> lift $ do
+ insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
+ updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ]
+ let recordNoShow eId = do
+ didRecord <- is _Just <$> insertUnique ExamResult
+ { examResultExam = eId
+ , examResultUser = uid
+ , examResultResult = ExamNoShow
+ , examResultLastChanged = now
+ }
+ when didRecord $
+ audit $ TransactionExamResultEdit eId uid
+ when noShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow
_other -> return ()
return 1
addMessageI Success $ MsgCourseUsersDeregistered nrDel
@@ -496,6 +636,52 @@ postCUsersR tid ssh csh = do
void . insertUnique . TutorialParticipant registerTutorial
addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
redirect $ CourseR tid ssh csh CUsersR
+ (CourseUserRegisterExamData{..}, selectedUsers) -> do
+ Sum nrReg <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> maybeT (return mempty) $ do
+ guardM . lift $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
+ now <- liftIO getCurrentTime
+ let (exam, mOccurrence) = registerExam
+ mExamReg <- lift $ insertUnique ExamRegistration
+ { examRegistrationExam = exam
+ , examRegistrationUser = uid
+ , examRegistrationOccurrence = mOccurrence
+ , examRegistrationTime = now
+ }
+ case mExamReg of
+ Just _ -> do
+ lift . audit $ TransactionExamRegister exam uid
+ return 1
+ Nothing ->
+ return mempty
+ addMessageI Success $ MsgCourseUsersExamRegistered nrReg
+ redirect $ CourseR tid ssh csh CUsersR
+ (CourseUserSetSubmissionGroupData{..}, selectedUsers) -> do
+ nrSet <- runDB $ setUsersSubmissionGroup cid selectedUsers setSubmissionGroup
+
+ case setSubmissionGroup of
+ Nothing -> addMessageI Success $ MsgCourseUsersSubmissionGroupUnset nrSet
+ Just _ -> addMessageI Success $ MsgCourseUsersSubmissionGroupSetNew nrSet
+
+ redirect $ CourseR tid ssh csh CUsersR
+ (CourseUserReRegisterData, selectedUsers) -> do
+ now <- liftIO getCurrentTime
+ Sum nrSet <- runDB . flip foldMapM selectedUsers $ \uid -> maybeT (return mempty) $ do
+ didUpdate <- lift $ updateWhereCount
+ [ CourseParticipantUser ==. uid
+ , CourseParticipantCourse ==. cid
+ , CourseParticipantState !=. CourseParticipantActive
+ ]
+ [ CourseParticipantState =. CourseParticipantActive
+ , CourseParticipantRegistration =. now
+ , CourseParticipantAllocated =. Nothing
+ ]
+ guard $ didUpdate > 0
+ lift $ deleteWhere [ AllocationDeregisterCourse ==. Just cid, AllocationDeregisterUser ==. uid ]
+ lift . audit $ TransactionCourseParticipantEdit cid uid
+ return $ Sum didUpdate
+ addMessageI Success $ MsgCourseUsersStateSet nrSet
+ redirect $ CourseR tid ssh csh CUsersR
+
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]
headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
siteLayout headingLong $ do
diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs
index feee5ddc1..930547721 100644
--- a/src/Handler/Exam/AddUser.hs
+++ b/src/Handler/Exam/AddUser.hs
@@ -127,7 +127,7 @@ postEAddUserR tid ssh csh examn = do
whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
- whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ do
+ whenM (lift . lift $ exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ]) $ do
lift $ lift examRegister
throwError $ mempty { aurSuccess = pure userEmail }
@@ -142,13 +142,20 @@ postEAddUserR tid ssh csh examn = do
| [f] <- features = Just f
| otherwise = Nothing
- lift . lift . insert_ $ CourseParticipant
- { courseParticipantCourse = cid
- , courseParticipantUser = uid
- , courseParticipantRegistration = now
- , courseParticipantAllocated = Nothing
- , ..
- }
+ lift . lift . void $ upsert
+ CourseParticipant
+ { courseParticipantCourse = cid
+ , courseParticipantUser = uid
+ , courseParticipantRegistration = now
+ , courseParticipantAllocated = Nothing
+ , courseParticipantState = CourseParticipantActive
+ , ..
+ }
+ [ CourseParticipantRegistration =. now
+ , CourseParticipantAllocated =. Nothing
+ , CourseParticipantField =. courseParticipantField
+ , CourseParticipantState =. CourseParticipantActive
+ ]
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid
lift $ lift examRegister
diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs
index 2cb691360..c55da69f2 100644
--- a/src/Handler/Exam/CorrectorInvite.hs
+++ b/src/Handler/Exam/CorrectorInvite.hs
@@ -16,6 +16,8 @@ import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..))
+import qualified Data.HashSet as HashSet
+
instance IsInvitableJunction ExamCorrector where
type InvitationFor ExamCorrector = Exam
@@ -67,7 +69,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
invitationTokenConfig _ _ = do
- itAuthority <- Right <$> liftHandler requireAuthId
+ itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionExamCorrector, ())
diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs
index b6df32911..f8953f843 100644
--- a/src/Handler/Exam/Form.hs
+++ b/src/Handler/Exam/Form.hs
@@ -339,7 +339,7 @@ validateExam = do
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
- guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart
+ guardValidation MsgExamFinishedMustBeAfterStart . fromMaybe True $ (>=) <$> efFinished <*> efStart
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs
index 8a8aef894..6b4dae091 100644
--- a/src/Handler/Exam/List.hs
+++ b/src/Handler/Exam/List.hs
@@ -1,5 +1,6 @@
module Handler.Exam.List
- ( getCExamListR
+ ( mkExamTable
+ , getCExamListR
) where
import Import
@@ -9,12 +10,16 @@ import Handler.Utils
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
-getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCExamListR tid ssh csh = do
- Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+mkExamTable :: Entity Course -> DB (Any, Widget)
+mkExamTable (Entity cid Course{..}) = do
+ let tid = courseTerm
+ ssh = courseSchool
+ csh = courseShorthand
now <- liftIO getCurrentTime
+ mbAid <- maybeAuthId
mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
let
@@ -24,15 +29,22 @@ getCExamListR tid ssh csh = do
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
return exam
dbtRowKey = (E.^. ExamId)
- dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do
- guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
- return x
+ dbtProj = return
dbtColonnade = dbColonnade . mconcat $ catMaybes
- [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName
+ [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
, (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
, Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
, Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
+ , Just . sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
+ mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
+ isRegistered <- case mbAid of
+ Nothing -> return False
+ Just uid -> existsBy $ UniqueExamRegistration eId uid
+ let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
+ examUrl = CExamR tid ssh csh examName EShowR
+ if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
+ | otherwise -> return [whamlet|_{label}|]
]
dbtSorting = Map.fromList
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
@@ -40,8 +52,18 @@ getCExamListR tid ssh csh = do
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
+ , ("registered", SortColumn $ \exam ->
+ case mbAid of
+ Nothing -> E.false
+ Just uid ->
+ E.exists $ E.from $ \reg -> do
+ E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
+ E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
+ )
]
- dbtFilter = Map.empty
+ dbtFilter = singletonMap "may-read" . FilterProjected $
+ \(Any b) DBRow{ dbrOutput = Entity _ Exam{..} }
+ -> (== b) <$> hasReadAccessTo (CExamR tid ssh csh examName EShowR) :: DB Bool
dbtFilterUI = const mempty
dbtStyle = def
dbtParams = def
@@ -52,7 +74,17 @@ getCExamListR tid ssh csh = do
examDBTableValidator = def
& defaultSorting [SortAscBy "time"]
- ((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable
+ & forceFilter "may-read" (Any True)
+
+ dbTable examDBTableValidator examDBTable
+
+
+getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCExamListR tid ssh csh = do
+ (Entity _ Course{..}, examTable) <- runDB $ do
+ c <- getBy404 $ TermSchoolCourseShort tid ssh csh
+ (_, examTable) <- mkExamTable c
+ return (c, examTable)
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading
diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs
index ee30db715..5c9e2d2c3 100644
--- a/src/Handler/Exam/New.hs
+++ b/src/Handler/Exam/New.hs
@@ -12,6 +12,8 @@ import Handler.Utils
import Handler.Utils.Invitations
import Jobs.Queue
+
+import qualified Data.Conduit.Combinators as C
getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -26,6 +28,8 @@ postCExamNewR tid ssh csh = do
formResult newExamResult $ \ExamForm{..} -> do
insertRes <- runDBJobs $ do
+ now <- liftIO getCurrentTime
+
insertRes <- insertUnique Exam
{ examName = efName
, examCourse = cid
@@ -75,6 +79,18 @@ postCExamNewR tid ssh csh = do
, examCorrectorUser <- adds
]
sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
+
+ let recordNoShow (Entity _ CourseParticipant{..}) = do
+ didRecord <- is _Just <$> insertUnique ExamResult
+ { examResultExam = examid
+ , examResultUser = courseParticipantUser
+ , examResultResult = ExamNoShow
+ , examResultLastChanged = now
+ }
+ when didRecord $
+ audit $ TransactionExamResultEdit examid courseParticipantUser
+ runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow
+
return insertRes
case insertRes of
Nothing -> addMessageI Error $ MsgExamNameTaken efName
diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs
index be7decbf4..0087c26c0 100644
--- a/src/Handler/Exam/RegistrationInvite.hs
+++ b/src/Handler/Exam/RegistrationInvite.hs
@@ -20,6 +20,8 @@ import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..))
import Jobs.Queue
+
+import qualified Data.HashSet as HashSet
instance IsInvitableJunction ExamRegistration where
@@ -77,7 +79,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
- itAuthority <- Right <$> liftHandler requireAuthId
+ itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
itAddAuth
| not invDBExamRegistrationCourseRegister
@@ -88,7 +90,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandler . wFormToAForm $ do
- isRegistered <- fmap (is _Just) . liftHandler . runDB . getBy $ UniqueParticipant uid examCourse
+ isRegistered <- fmap (is _Just) . liftHandler . runDB . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive). getBy $ UniqueParticipant uid examCourse
now <- liftIO getCurrentTime
case (isRegistered, invDBExamRegistrationCourseRegister) of
@@ -99,7 +101,13 @@ examRegistrationInvitationConfig = InvitationConfig{..}
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
whenIsJust mField $ \cpField -> do
- insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing
+ void $ upsert
+ (CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing CourseParticipantActive)
+ [ CourseParticipantRegistration =. examRegistrationTime
+ , CourseParticipantField =. cpField
+ , CourseParticipantAllocated =. Nothing
+ , CourseParticipantState =. CourseParticipantActive
+ ]
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs
index c99867bc7..56c2e0e33 100644
--- a/src/Handler/Exam/Users.hs
+++ b/src/Handler/Exam/Users.hs
@@ -165,7 +165,7 @@ resultCourseNote = _dbrOutput . _10 . _Just
resultAutomaticExamBonus :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData Points
-resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus'))
+resultAutomaticExamBonus exam examBonus' = resultUser . _entityKey . folding (\uid -> join $ examResultBonus <$> examBonusRule exam <*> pure (examBonusPossible uid examBonus') <*> pure (examBonusAchieved uid examBonus'))
resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultPassedGrade
resultAutomaticExamResult exam@Exam{..} examBonus' = folding . runReader $ do
@@ -471,6 +471,7 @@ postEUsersR tid ssh csh examn = do
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)
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
@@ -485,10 +486,10 @@ postEUsersR tid ssh csh examn = do
<*> getExamParts
<*> view _9
where
- getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
+ getExamParts :: ReaderT _ DB (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
getExamParts = do
uid <- view $ _2 . _entityKey
- rawResults <- lift . lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do
+ rawResults <- lift . E.select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> do
E.on $ examPartResult E.?. ExamPartResultExamPart E.==. E.just (examPart E.^. ExamPartId)
E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (E.val uid)
E.where_ $ examPart E.^. ExamPartExam E.==. E.val eid
@@ -617,6 +618,7 @@ postEUsersR tid ssh csh examn = do
, dbtCsvName = unpack csvName
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
+ , dbtCsvExampleData = Nothing
}
where
doEncode' = ExamUserTableCsv
@@ -757,13 +759,20 @@ postEUsersR tid ssh csh examn = do
C.mapM_ $ \case
ExamUserCsvCourseRegisterData{..} -> do
now <- liftIO getCurrentTime
- insert_ CourseParticipant
- { courseParticipantCourse = examCourse
- , courseParticipantUser = examUserCsvActUser
- , courseParticipantRegistration = now
- , courseParticipantField = examUserCsvActCourseField
- , courseParticipantAllocated = Nothing
- }
+ void $ upsert
+ CourseParticipant
+ { courseParticipantCourse = examCourse
+ , courseParticipantUser = examUserCsvActUser
+ , courseParticipantRegistration = now
+ , courseParticipantField = examUserCsvActCourseField
+ , courseParticipantAllocated = Nothing
+ , courseParticipantState = CourseParticipantActive
+ }
+ [ CourseParticipantRegistration =. now
+ , CourseParticipantField =. examUserCsvActCourseField
+ , CourseParticipantAllocated =. Nothing
+ , CourseParticipantState =. CourseParticipantActive
+ ]
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
insert_ ExamRegistration
@@ -970,7 +979,7 @@ postEUsersR tid ssh csh examn = do
, GuessUserFirstName <$> csvEUserFirstName
]
pid <- maybe (throwM ExamUserCsvExceptionNoMatchingUser) return =<< guessUser criteria
- (,) <$> existsBy (UniqueParticipant pid examCourse) <*> pure pid
+ (,) <$> exists [CourseParticipantCourse ==. examCourse, CourseParticipantUser ==. pid, CourseParticipantState ==. CourseParticipantActive] <*> pure pid
lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId)
lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do
diff --git a/src/Handler/ExamOffice/Exam.hs b/src/Handler/ExamOffice/Exam.hs
index 64d3b78bd..25458c0dd 100644
--- a/src/Handler/ExamOffice/Exam.hs
+++ b/src/Handler/ExamOffice/Exam.hs
@@ -204,8 +204,8 @@ postEGradesR tid ssh csh examn = do
userFunctions <- selectList [ UserFunctionUser ==. uid, UserFunctionFunction ==. SchoolExamOffice ] []
let
- participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
- participantLink partId = do
+ participantLink :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (SomeRoute UniWorX)
+ participantLink partId = liftHandler $ do
cID <- encrypt partId
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
@@ -261,6 +261,7 @@ postEGradesR tid ssh csh examn = do
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)
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
E.&&. occurrence E.?. ExamOccurrenceId E.==. E.joinV (examRegistration E.?. ExamRegistrationOccurrence)
E.on $ examRegistration E.?. ExamRegistrationUser E.==. E.just (user E.^. UserId)
@@ -276,16 +277,16 @@ postEGradesR tid ssh csh examn = do
return (examResult, user, occurrence, studyFeatures, studyDegree, studyField, examRegistration, isSynced)
dbtRowKey = views queryExamResult (E.^. ExamResultId)
- dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamUserTableData
+ 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)
<*> getSynchronised
where
- getSynchronised :: ReaderT _ (MaybeT (YesodDB UniWorX)) [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
+ getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
getSynchronised = do
resId <- view $ _1 . _entityKey
- syncs <- lift . lift . E.select . E.from $ \(examOfficeResultSynced `E.InnerJoin` user) -> do
+ syncs <- lift . E.select . E.from $ \(examOfficeResultSynced `E.InnerJoin` user) -> do
E.on $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. user E.^. UserId
E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedResult E.==. E.val resId
return ( examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice
@@ -412,6 +413,7 @@ postEGradesR tid ssh csh examn = do
, dbtCsvName = unpack csvName
, dbtCsvNoExportData = Nothing
, dbtCsvHeader = const . return $ Csv.headerOrder (error "headerOrder" :: ExamUserTableCsv)
+ , dbtCsvExampleData = Nothing
}
dbtCsvDecode = Nothing
diff --git a/src/Handler/ExamOffice/Exams.hs b/src/Handler/ExamOffice/Exams.hs
index 67e15438c..be99b1737 100644
--- a/src/Handler/ExamOffice/Exams.hs
+++ b/src/Handler/ExamOffice/Exams.hs
@@ -142,21 +142,17 @@ getEOExamsR = do
return (exam, course, externalExam, synchronised, results)
dbtRowKey = views ($(multifocusG 2) queryExam queryExternalExam) (bimap (E.?. ExamId) (E.?. ExternalExamId))
- dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExamsTableData
+ dbtProj :: DBRow _ -> DB ExamsTableData
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
exam <- view _1
course <- view _2
externalExam <- view _3
case (exam, course, externalExam) of
- (Just exam', Just course', Nothing) -> do
- guard =<< hasReadAccessTo (urlRoute $ examLink (entityVal course') (entityVal exam'))
-
+ (Just exam', Just course', Nothing) ->
(,,)
<$> pure (Right (exam', course')) <*> view (_4 . _Value) <*> view (_5 . _Value)
- (Nothing, Nothing, Just externalExam') -> do
- guard =<< hasReadAccessTo (urlRoute $ externalExamLink (entityVal externalExam'))
-
+ (Nothing, Nothing, Just externalExam') ->
(,,)
<$> pure (Left externalExam') <*> view (_4 . _Value) <*> view (_5 . _Value)
_other -> return $ error "Got exam & externalExam in same result"
@@ -216,7 +212,14 @@ getEOExamsR = do
]
dbtFilter = mconcat
- [
+ [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> (== b) <$> if
+ | Just exam <- r ^? resultExam . _entityVal
+ , Just course <- r ^? resultCourse . _entityVal
+ -> hasReadAccessTo . urlRoute $ examLink course exam
+ | Just eexam <- r ^? resultExternalExam . _entityVal
+ -> hasReadAccessTo . urlRoute $ externalExamLink eexam :: DB Bool
+ | otherwise
+ -> return $ error "Got neither exam nor externalExam in result"
]
dbtFilterUI = mconcat
[
@@ -231,7 +234,9 @@ getEOExamsR = do
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
- examsDBTableValidator = def & defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"]
+ examsDBTableValidator = def
+ & defaultSorting [SortAscBy "is-synced", SortAscBy "exam-time"]
+ & forceFilter "may-access" (Any True)
dbTableWidget' examsDBTableValidator examsDBTable
diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs
index ab5588677..9071b269f 100644
--- a/src/Handler/ExamOffice/Users.hs
+++ b/src/Handler/ExamOffice/Users.hs
@@ -19,6 +19,8 @@ import qualified Database.Esqueleto as E
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Map ((!), (!?))
+
+import qualified Data.HashSet as HashSet
instance IsInvitableJunction ExamOfficeUser where
@@ -67,7 +69,7 @@ examOfficeUserInvitationConfig = InvitationConfig{..}
return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
invitationTokenConfig _ _ = do
- itAuthority <- Right <$> liftHandler requireAuthId
+ itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
let itExpiresAt = Nothing
itStartsAt = Nothing
itAddAuth = Nothing
diff --git a/src/Handler/ExternalExam/List.hs b/src/Handler/ExternalExam/List.hs
index ac8f6e0b2..edd02e199 100644
--- a/src/Handler/ExternalExam/List.hs
+++ b/src/Handler/ExternalExam/List.hs
@@ -46,9 +46,7 @@ getEExamListR = do
return (eexam, school)
dbtRowKey = queryEExam >>> (E.^. ExternalExamId)
- dbtProj x@(view resultEExam -> Entity _ ExternalExam{..}) = do
- guardM . hasReadAccessTo $ EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR
- return x
+ dbtProj = return
dbtColonnade = widgetColonnade $ mconcat
[ sortable (Just "term") (i18nCell MsgTerm) $ \(view resultEExam -> Entity _ ExternalExam{..}) -> i18nCell . ShortTermIdentifier $ unTermKey externalExamTerm
, sortable (Just "school") (i18nCell MsgSchool) $ \(view resultSchool -> Entity _ School{..}) -> i18nCell schoolName
@@ -61,7 +59,10 @@ getEExamListR = do
, ("course", SortColumn $ queryEExam >>> (E.^. ExternalExamCourseName))
, ("name", SortColumn $ queryEExam >>> (E.^. ExternalExamExamName))
]
- dbtFilter = Map.empty
+ dbtFilter = mconcat
+ [ singletonMap "may-access" . FilterProjected $ \(Any b) (view resultEExam -> Entity _ ExternalExam{..}) -> (==b) <$>
+ hasReadAccessTo (EExamR externalExamTerm externalExamSchool externalExamCourseName externalExamExamName EEShowR) :: DB Bool
+ ]
dbtFilterUI = const mempty
dbtStyle = def
dbtParams = def
@@ -71,6 +72,7 @@ getEExamListR = do
dbtCsvDecode = Nothing
examDBTableValidator = def
& defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "name"]
+ & forceFilter "may-access" (Any True)
examTable <- runDB $ dbTableWidget' examDBTableValidator examDBTable
diff --git a/src/Handler/ExternalExam/StaffInvite.hs b/src/Handler/ExternalExam/StaffInvite.hs
index 0e9414913..c594b613a 100644
--- a/src/Handler/ExternalExam/StaffInvite.hs
+++ b/src/Handler/ExternalExam/StaffInvite.hs
@@ -13,6 +13,8 @@ import Handler.Utils.Invitations
import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..))
+import qualified Data.HashSet as HashSet
+
instance IsInvitableJunction ExternalExamStaff where
type InvitationFor ExternalExamStaff = ExternalExam
@@ -59,7 +61,7 @@ externalExamStaffInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ ExternalExam{..}) _ = return . SomeMessage $ MsgExternalExamStaffInviteHeading externalExamCourseName externalExamExamName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExternalExamStaffInviteExplanation}|]
invitationTokenConfig _ _ = do
- itAuthority <- Right <$> liftHandler requireAuthId
+ itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing (Just Nothing) Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataExternalExamStaff, _) _ = pure (JunctionExternalExamStaff, ())
diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs
index 94c769b08..28bf3e804 100644
--- a/src/Handler/Help.hs
+++ b/src/Handler/Help.hs
@@ -2,10 +2,16 @@ module Handler.Help where
import Import
import Handler.Utils
+import Handler.Info (faqsWidget)
import Jobs
import qualified Data.Map as Map
+import qualified Data.Yaml as Yaml
+
+import qualified Control.Monad.State.Class as State
+
+
data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
deriving (Eq, Ord, Bounded, Enum, Show, Read)
@@ -19,25 +25,56 @@ data HelpForm = HelpForm
{ hfReferer :: Maybe (Route UniWorX)
, hfUserId :: Either (Maybe Address) UserId
, hfSubject :: Maybe Text
- , hfRequest :: Html
+ , hfRequest :: Maybe Html
+ , hfError :: Maybe ErrorResponse
}
-helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
-helpForm mr mReferer mUid = HelpForm
- <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
- <*> multiActionA identActions (fslI MsgHelpAnswer) (HIUser <$ mUid)
- <*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
- <*> areq htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing
- where
- identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
- identActions = Map.fromList $ case mUid of
- (Just uid) -> (HIUser, pure $ Right uid):defaultActions
- Nothing -> defaultActions
+helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> Form HelpForm
+helpForm mReferer mUid = renderWForm FormStandard $ do
+ MsgRenderer mr <- getMsgRenderer
- defaultActions =
- [ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing))
- , (HIAnonymous, pure $ Left Nothing)
- ]
+ let defaultActions =
+ [ ( HIEmail
+ , Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing)
+ )
+ , ( HIAnonymous
+ , pure $ Left Nothing
+ )
+ ]
+ identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
+ identActions = Map.fromList $ case mUid of
+ (Just uid) -> (HIUser, pure $ Right uid):defaultActions
+ Nothing -> defaultActions
+
+ sessErr <- lookupSessionJson SessionError
+
+ hfReferer' <- wopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
+ hfUserId' <- multiActionW identActions (fslI MsgHelpAnswer) (HIUser <$ mUid)
+ hfSubject' <- wopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
+ hfRequest' <- case sessErr of
+ Nothing -> fmap Just <$> wreq htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing
+ Just _ -> wopt htmlField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing
+ hfError' <- case sessErr of
+ Nothing -> return $ pure Nothing
+ Just err ->
+ let prettyErr = decodeUtf8 $ Yaml.encode err
+ in optionalActionW
+ (err <$ aforced textareaField (fslI MsgHelpError) (Textarea prettyErr))
+ (fslI MsgHelpSendLastError)
+ (Just True)
+
+ return $ HelpForm
+ <$> hfReferer'
+ <*> hfUserId'
+ <*> hfSubject'
+ <*> hfRequest'
+ <*> hfError'
+
+validateHelpForm :: FormValidator HelpForm Handler ()
+validateHelpForm = do
+ HelpForm{..} <- State.get
+
+ guardValidation MsgHelpErrorOrRequestRequired $ is _Just hfRequest || is _Just hfError
getHelpR, postHelpR :: Handler Html
getHelpR = postHelpR
@@ -45,9 +82,8 @@ postHelpR = do
mUid <- maybeAuthId
mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
isModal <- hasCustomHeader HeaderIsModal
- MsgRenderer mr <- getMsgRenderer
- ((res,formWidget'),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid
+ ((res,formWidget'),formEnctype) <- runFormPost . validateForm validateHelpForm $ helpForm mReferer mUid
formResultModal res HelpR $ \HelpForm{..} -> do
now <- liftIO getCurrentTime
@@ -58,7 +94,12 @@ postHelpR = do
, jHelpRequest = hfRequest
, jRequestTime = now
, jReferer = hfReferer'
+ , jError = hfError
}
+
+ whenIsJust hfError $ \error' ->
+ modifySessionJson SessionError $ assertM (/= error')
+
tell . pure =<< messageI Success MsgHelpSent
defaultLayout $ do
@@ -68,4 +109,7 @@ postHelpR = do
, formEncoding = formEnctype
, formAttrs = [ asyncSubmitAttr | isModal ]
}
+
+ mFaqs <- (>>= \(mWgt, truncated) -> (, truncated) <$> mWgt) <$> traverse (faqsWidget $ Just 5) (Just <$> mReferer)
+
$(widgetFile "help")
diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs
index dfc39e730..0414808ca 100644
--- a/src/Handler/Info.hs
+++ b/src/Handler/Info.hs
@@ -85,3 +85,83 @@ getGlossaryR =
where
entries = $(i18nWidgetFiles "glossary")
msgMap = $(glossaryTerms "glossary")
+
+
+mkFaqItems "faq"
+mkMessageFor "UniWorX" "FAQItem" "messages/faq" "de-de-formal"
+
+faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ )
+ => Maybe Natural -> Maybe (Route UniWorX) -> m (Maybe Widget, Bool)
+faqsWidget mLimit route = do
+ faqs <- for route $ \route' -> filterM (showFAQ route') universeF
+ MsgRenderer mr <- getMsgRenderer
+ let
+ rItems' = sortOn (CI.mk . views _1 mr) $ do
+ (k, wgt) <- Map.toList items
+ msg <- maybeToList $ Map.lookup k faqItemMap
+ whenIsJust faqs $ \faqs' ->
+ guard $ msg `elem` faqs'
+ return (msg, wgt)
+
+ rItems <- case (,) <$> route <*> mLimit of
+ Nothing -> return rItems'
+ Just (route', limit) -> do
+ let wIndices = zip [0..] rItems'
+ wPrios <- forM wIndices $ \x@(_, (msg, _)) -> (, x) . Just <$> prioFAQ route' msg
+ let prioLimited = go Nothing [] $ sortOn (views _1 Down) wPrios
+ where
+ go _ acc [] = acc
+ go maxP acc ((p, x) : xs)
+ | maxP == Just p || length acc < fromIntegral limit
+ = go (Just p) (x : acc) xs
+ | otherwise
+ = acc
+ return . map (view _2) $ sortOn (view _1) prioLimited
+
+ let truncated = length rItems < length rItems'
+
+ return ( guardOn (not $ null rItems') $(widgetFile "faq")
+ , truncated
+ )
+ where
+ items = $(i18nWidgetFiles "faq")
+
+ faqLink :: FAQItem -> Widget
+ faqLink = toWidget <=< toTextUrl . (FaqR :#:)
+
+
+getFaqR :: Handler Html
+getFaqR =
+ siteLayoutMsg' MsgFaqTitle $ do
+ setTitleI MsgFaqTitle
+
+ fromMaybe mempty . view _1 =<< faqsWidget Nothing Nothing
+
+showFAQ :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ )
+ => Route UniWorX -> FAQItem -> m Bool
+showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId
+showFAQ (AuthR _) FAQCampusCantLogin = return True
+showFAQ _ FAQCampusCantLogin = is _Nothing <$> maybeAuthId
+showFAQ (AuthR _) FAQForgottenPassword = return True
+showFAQ _ FAQForgottenPassword = is _Nothing <$> maybeAuthId
+showFAQ _ FAQNotLecturerHowToCreateCourses
+ = and2M (is _Just <$> maybeAuthId)
+ (not <$> hasWriteAccessTo CourseNewR)
+showFAQ (CourseR tid ssh csh _) FAQCourseCorrectorsTutors
+ = and2M (is _Just <$> maybeAuthId)
+ (or2M (hasWriteAccessTo $ CourseR tid ssh csh SheetNewR)
+ (hasWriteAccessTo $ CourseR tid ssh csh CTutorialNewR)
+ )
+showFAQ _ _ = return False
+
+prioFAQ :: Monad m
+ => Route UniWorX -> FAQItem -> m Rational
+prioFAQ _ FAQNoCampusAccount = return 1
+prioFAQ _ FAQCampusCantLogin = return 1
+prioFAQ _ FAQForgottenPassword = return 1
+prioFAQ _ FAQNotLecturerHowToCreateCourses = return 1
+prioFAQ _ FAQCourseCorrectorsTutors = return 1
diff --git a/src/Handler/Info/TH.hs b/src/Handler/Info/TH.hs
index 25c55bdb6..a36694c5c 100644
--- a/src/Handler/Info/TH.hs
+++ b/src/Handler/Info/TH.hs
@@ -1,5 +1,6 @@
module Handler.Info.TH
( glossaryTerms
+ , mkFaqItems
) where
import Import
@@ -21,3 +22,52 @@ glossaryTerms basename = do
where
unPathPiece :: Text -> String
unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
+
+mkFaqItems :: FilePath -> DecsQ
+mkFaqItems basename = do
+ itemsAvailable <- i18nWidgetFilesAvailable' basename
+ let items = Map.mapWithKey (\k _ -> "FAQ" <> unPathPiece k) itemsAvailable
+ sequence
+ [ dataD (cxt []) dataName [] Nothing
+ [ normalC (mkName conName) []
+ | (_, conName) <- Map.toAscList items
+ ]
+ [ derivClause (Just StockStrategy)
+ [ conT ''Eq
+ , conT ''Ord
+ , conT ''Read
+ , conT ''Show
+ , conT ''Enum
+ , conT ''Bounded
+ , conT ''Generic
+ , conT ''Typeable
+ ]
+ , derivClause (Just AnyclassStrategy)
+ [ conT ''Universe
+ , conT ''Finite
+ ]
+ ]
+ , instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)
+ [ funD 'toPathPiece
+ [ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) []
+ | (int, con) <- Map.toList items
+ ]
+ , funD 'fromPathPiece
+ [ clause [varP $ mkName "t"]
+ ( guardedB
+ [ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|]
+ | (int, con) <- Map.toList items
+ ]) []
+ , clause [wildP] (normalB [e|Nothing|]) []
+ ]
+ ]
+ , sigD (mkName "faqItemMap") [t|Map Text $(conT dataName)|]
+ , funD (mkName "faqItemMap")
+ [ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) []
+ ]
+ ]
+ where
+ unPathPiece :: Text -> String
+ unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
+
+ dataName = mkName "FAQItem"
diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs
index bf387f85c..968e9f06b 100644
--- a/src/Handler/Material.hs
+++ b/src/Handler/Material.hs
@@ -103,6 +103,7 @@ getMaterialListR tid ssh csh = do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let row2material = view $ _dbrOutput . _1 . _entityVal
psValidator = def & defaultSorting [SortDescBy "last-edit"]
+ & forceFilter "may-access" (Any True)
dbTableWidget' psValidator DBTable
{ dbtIdent = "material-list" :: Text
, dbtStyle = def
@@ -114,8 +115,7 @@ getMaterialListR tid ssh csh = do
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
return (material, filesNum)
, dbtRowKey = (E.^. MaterialId)
- -- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
- , dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->)
+ , dbtProj = return
, dbtColonnade = widgetColonnade $ mconcat
[ -- dbRow,
sortable (Just "type") (i18nCell MsgMaterialType)
@@ -141,7 +141,10 @@ getMaterialListR tid ssh csh = do
, ( "visible-from" , SortColumn (E.^. MaterialVisibleFrom) )
, ( "last-edit" , SortColumn (E.^. MaterialLastEdit) )
]
- , dbtFilter = mempty
+ , dbtFilter = mconcat
+ [ singletonMap "may-access" . FilterProjected $ \(Any b) dbr
+ -> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool
+ ]
, dbtFilterUI = mempty
, dbtCsvEncode = noCsvEncode
, dbtCsvDecode = Nothing
@@ -201,11 +204,10 @@ getMShowR tid ssh csh mnm = do
return (file E.^. FileTitle, file E.^. FileModified)
, dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
, dbtColonnade = widgetColonnade $ mconcat
- [ dbRowIndicator -- important: contains writer to indicate that the tables is not empty
- , colFilePathSimple (view $ _dbrOutput . _1) matLink
+ [ (<> indicatorCell) <$> colFilePathSimple (view $ _dbrOutput . _1) matLink
, materialModDateCol (view $ _dbrOutput . _2)
]
- , dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr
+ , dbtProj = return
, dbtStyle = def
, dbtParams = def
, dbtFilter = mempty
@@ -219,6 +221,8 @@ getMShowR tid ssh csh mnm = do
, dbtCsvDecode = Nothing
}
return (matEnt,fileTable')
+ -- File table has no filtering by access, because we assume that
+ -- access rights to material and material-files are identical.
let matLastEdit = formatTimeW SelFormatDateTime $ materialLastEdit material
let matVisibleFromMB = visibleUTCTime SelFormatDateTime <$> materialVisibleFrom material
@@ -312,7 +316,9 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId)
where
- finsert (Left fileId) = tell $ singleton fileId
+ finsert (Left fid) = do
+ lift . void $ upsertBy (UniqueMaterialFile mid fid) (MaterialFile mid fid) []
+ tell $ singleton fid
finsert (Right file) = lift $ do
fid <- insert file
void . insert $ MaterialFile mid fid -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs
index b9a7ceb7f..92bed0bc1 100644
--- a/src/Handler/Metrics.hs
+++ b/src/Handler/Metrics.hs
@@ -23,11 +23,11 @@ getMetricsR = selectRep $ do
metricsHtml = do
samples <- collectMetrics
- metricsToken <- runMaybeT . hoist runDB $ do
+ metricsBearer <- runMaybeT . hoist runDB $ do
uid <- MaybeT maybeAuthId
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
- encodeToken =<< bearerToken (Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
+ encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
defaultLayout $ do
setTitleI MsgTitleMetrics
diff --git a/src/Handler/News.hs b/src/Handler/News.hs
index e5eab1715..f3ee2f78d 100644
--- a/src/Handler/News.hs
+++ b/src/Handler/News.hs
@@ -3,18 +3,30 @@ module Handler.News where
import Import
import Handler.Utils
+import Handler.Utils.News
+
+import Handler.SystemMessage
import qualified Data.Map as Map
import Database.Esqueleto.Utils.TH
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
+import qualified Data.Conduit.List as C (consume, mapMaybeM)
+import qualified Data.Conduit.Combinators as C
+import qualified Data.Conduit.Lift as C
+
+import qualified Data.HashMap.Strict as HashMap
+
+
getNewsR :: Handler Html
getNewsR = do
muid <- maybeAuthId
defaultLayout $ do
setTitleI MsgNewsHeading
+ newsSystemMessages
+
when (is _Nothing muid) $
notificationWidget NotificationBroad Info $(i18nWidgetFile "pitch")
@@ -26,9 +38,56 @@ getNewsR = do
$(i18nWidgetFile "unauth-news")
+newsSystemMessages :: Widget
+newsSystemMessages = do
+ now <- liftIO getCurrentTime
+
+ showHidden <- isJust <$> lookupGetParam (toPathPiece GetHidden)
+
+ let tellShown smId = liftHandler $ do
+ cID <- encrypt smId :: Handler CryptoUUIDSystemMessage
+ tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
+ HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
+ mkHideForm smId SystemMessage{..} = liftHandler $ do
+ cID <- encrypt smId
+ hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide
+
+ (btnView, btnEnctype) <- generateFormPost . buttonForm' $ bool [BtnSystemMessageHide] [BtnSystemMessageUnhide] hidden
+ return $ wrapForm btnView def
+ { formSubmit = FormNoSubmit
+ , formEncoding = btnEnctype
+ , formAction = Just . SomeRoute $ MessageHideR cID
+ , formAttrs = [("class", "form--inline")]
+ }
+ checkHidden (smId, sm@SystemMessage{..}, trans) = do
+ hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide
+
+ tell $ Any hidden
+
+ return $ guardOn (not hidden || showHidden) (smId, sm, trans, hidden)
+
+ (messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
+ transPipe lift (selectKeys [] [])
+ .| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
+ .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId)
+ .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
+ .| C.mapMaybeM checkHidden
+ .| C.iterM (\(smId, _, _, _) -> tellShown smId)
+ .| C.mapM (\(smId, sm@SystemMessage{..}, trans, hidden) -> (sm, trans, hidden,,) <$> formatTime SelFormatDateTime (maybe id max systemMessageFrom systemMessageLastChanged) <*> mkHideForm smId sm)
+ .| C.consume
+ let messages = sortOn (\(SystemMessage{..}, _, _, _, _) -> (Down $ maybe id max systemMessageFrom systemMessageLastChanged, systemMessageSeverity)) messages'
+
+ hiddenUrl <- toTextUrl (NewsR, [(toPathPiece GetHidden, "")])
+
+ unless (not anyHidden && null messages)
+ $(widgetFile "news/system-messages")
+
+
newsUpcomingSheets :: UserId -> Widget
newsUpcomingSheets uid = do
cTime <- liftIO getCurrentTime
+ let noActiveToCutoff = toMidnight . addGregorianDurationRollOver (scaleCalendarDiffDays (-1) calendarMonth) $ utctDay cTime
+
let tableData :: E.LeftOuterJoin
(E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
(E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser))))
@@ -44,8 +103,17 @@ newsUpcomingSheets uid = do
E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
+
+ let showSheetNoActiveTo =
+ E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetActiveFrom)
+ E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetVisibleFrom)
+ E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetHintFrom)
+ E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom)
+
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
- E.&&. E.maybe E.true (E.>=. E.val cTime) (sheet E.^. SheetActiveTo)
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
+ E.&&. E.maybe showSheetNoActiveTo (E.>=. E.val cTime) (sheet E.^. SheetActiveTo)
+
return
( course E.^. CourseTerm
, course E.^. CourseSchool
@@ -86,12 +154,12 @@ newsUpcomingSheets uid = do
(hasTickmark True)
]
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
+ & forceFilter "may-access" (Any True)
sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable
{ dbtSQLQuery = tableData
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
, dbtColonnade = colonnade
- , dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
- -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
+ , dbtProj = return
, dbtSorting = Map.fromList
[ ( "term"
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
@@ -112,12 +180,17 @@ newsUpcomingSheets uid = do
, SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` _ `E.LeftOuterJoin` (subm `E.InnerJoin` _)) -> E.isNothing $ subm E.?. SubmissionId
)
]
- , dbtFilter = mempty {- [ ( "term"
- , FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
- | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
- | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
- )
- ] -}
+ , dbtFilter = mconcat
+ [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
+ let (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) = dbrOutput :: ( E.Value (Key Term)
+ , E.Value SchoolId
+ , E.Value CourseShorthand
+ , E.Value SheetName
+ , E.Value (Maybe UTCTime)
+ , E.Value (Maybe SubmissionId)
+ )
+ in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn SShowR) :: DB Bool
+ ]
, dbtFilterUI = mempty
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
, dbtParams = def
@@ -152,7 +225,8 @@ newsUpcomingExams uid = do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ E.exists $ E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
- E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+ E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight)
E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now)
E.&&. E.isNothing (register E.?. ExamRegistrationId)
@@ -172,11 +246,7 @@ newsUpcomingExams uid = do
E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
return (course, exam, register, occurrence)
dbtRowKey = queryExam >>> (E.^. ExamId)
- dbtProj r@DBRow{ dbrOutput } = do
- let Entity _ Exam{..} = view lensExam dbrOutput
- Entity _ Course{..} = view lensCourse dbrOutput
- guardM . hasReadAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EShowR -- check access rights
- return r
+ dbtProj = return
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
msgCell courseTerm
@@ -245,7 +315,12 @@ newsUpcomingExams uid = do
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
))
]
- dbtFilter = Map.empty
+ dbtFilter = mconcat
+ [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
+ let Entity _ Exam{..} = view lensExam dbrOutput
+ Entity _ Course{..} = view lensCourse dbrOutput
+ in (==b) <$> hasReadAccessTo (CExamR courseTerm courseSchool courseShorthand examName EShowR) :: DB Bool
+ ]
dbtFilterUI = const mempty
dbtStyle = def
dbtParams = def
@@ -256,6 +331,7 @@ newsUpcomingExams uid = do
examDBTableValidator = def
& defaultSorting [SortAscBy "time"]
+ & forceFilter "may-access" (Any True)
(, userWarningDays) <$> dbTable examDBTableValidator examDBTable
diff --git a/src/Handler/Participants.hs b/src/Handler/Participants.hs
index 5cd14f224..c9af17d51 100644
--- a/src/Handler/Participants.hs
+++ b/src/Handler/Participants.hs
@@ -21,8 +21,6 @@ import qualified Data.Csv as Csv
import qualified Data.Conduit.List as C
-import qualified Data.List as List
-
data ParticipantEntry = ParticipantEntry
{ peCourse :: CourseName
@@ -48,6 +46,7 @@ getParticipantsListR = do
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
E.&&. course E.^. CourseSchool E.==. school E.^. SchoolId
+ E.where_ $ participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (school E.^. SchoolId, term E.^. TermId)
@@ -78,6 +77,7 @@ getParticipantsR tid ssh = do
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
+ E.where_ $ participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (course E.^. CourseName, user E.^. UserEmail)
@@ -87,37 +87,16 @@ getParticipantsIntersectR, postParticipantsIntersectR :: Handler Html
getParticipantsIntersectR = postParticipantsIntersectR
postParticipantsIntersectR = do
let
- miAdd' nudge btn csrf = do
- let
- courseOptions = optionsPersistCryptoId [] [Desc CourseTerm, Asc CourseSchool, Asc CourseName] (\Course{..} -> MsgParticipantsIntersectCourseOption courseTerm courseSchool courseName) >>= fmap (fmap entityKey) . filterCourseOptions
- filterCourseOptions = fmap mkOptionList . filterCourseOptions' . olOptions
- where
- filterCourseOptions' opts = do
- let termSchools = List.nub [ optionInternalValue ^. _entityVal . $(multifocusL 2) _courseTerm _courseSchool | Option{..} <- opts ]
- termSchools' <- Set.fromList <$> filterM (\(tid, ssh) -> hasReadAccessTo $ ParticipantsR tid ssh) termSchools
- return $ opts
- & filter (\Option{ optionInternalValue = Entity _ Course{..} } -> (courseTerm, courseSchool) `Set.member` termSchools')
- (courseRes, addView) <- mpopt (selectField courseOptions) (fslI MsgCourse & addName (nudge "course")) Nothing
- let res = courseRes <&> \newCourse oldCourses -> pure (Set.toList $ Set.singleton newCourse `Set.difference` Set.fromList oldCourses)
- return (res, $(widgetFile "widgets/massinput/participants-intersect/add"))
- miCell' cid = do
- Course{..} <- liftHandler . runDB $ get404 cid
- $(widgetFile "widgets/massinput/participants-intersect/cell")
- miButtonAction' _ = Nothing
- miLayout' :: MassInputLayout ListLength CourseId ()
- miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/participants-intersect/layout")
- miIdent' :: Text
- miIdent' = "participants-intersect"
- fSettings = fslI MsgParticipantsIntersectCourses
- fRequired = False
- mPrev = Nothing
- ((coursesRes, coursesView), coursesEnc) <- runFormPost . renderAForm FormStandard $ massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
+ courseQuery = E.from return
+ termSchoolAccess (Entity _ Course{..}) =
+ hasReadAccessTo $ ParticipantsR courseTerm courseSchool
+ ((coursesRes, coursesView), coursesEnc) <- runFormPost . renderAForm FormStandard $ courseSelectForm courseQuery termSchoolAccess (const Nothing) ("participants-intersect" :: Text) (fslI MsgParticipantsIntersectCourses) False Nothing
let formWidget = wrapForm coursesView def
{ formAction = Just . SomeRoute $ ParticipantsIntersectR :#: ("table" :: Text)
, formEncoding = coursesEnc
}
- intersectionsRes <- formResultMaybe coursesRes . fmap (fmap Just) $ \(Set.fromList -> cids) -> runDB $ do
+ intersectionsRes <- formResultMaybe coursesRes . fmap (fmap Just) $ \cids -> runDB $ do
let coursePairs = do
cid <- Set.toList cids
other <- Set.toList . snd $ Set.split cid cids
@@ -126,11 +105,13 @@ postParticipantsIntersectR = do
E.where_ . E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val lCid
+ E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.where_ . E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val uCid
+ E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
- selfIntersections <- fmap Map.fromList . forM (Set.toList cids) $ \cid -> ((cid, cid), ) <$> count [CourseParticipantCourse ==. cid]
+ selfIntersections <- fmap Map.fromList . forM (Set.toList cids) $ \cid -> ((cid, cid), ) <$> count [CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
let intersections' = Map.union intersections selfIntersections
courses <- sortOn (view $ _entityVal . $(multifocusL 3) _courseTerm _courseSchool _courseShorthand) <$> forM (Set.toList cids) getEntity404
return (courses, intersections')
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index 285517656..21a31b27d 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -159,6 +159,7 @@ notificationForm template = wFormToAForm $ do
, NTKCourseParticipant <- nt
= fmap not . E.selectExists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
+ E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
| Just uid <- mbUid
, NTKSubmissionUser <- nt
= fmap not . E.selectExists . E.from $ \submissionUser ->
@@ -409,8 +410,7 @@ mkOwnedCoursesTable =
dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))
dbtColonnade = mconcat
- [ dbRow
- , sortable (Just "term") (i18nCell MsgTerm & cellAttrs .~ [("priority","0")]) $ do
+ [ sortable (Just "term") (i18nCell MsgTerm & cellAttrs .~ [("priority","0")]) $ do
tid <- view (_dbrOutput . _1)
return $ indicatorCell -- return True if one cell is produced here
`mappend` termCell tid
@@ -455,12 +455,12 @@ mkEnrolledCoursesTable =
, dbtSQLQuery = \(course `E.InnerJoin` participant) -> do
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (course, participant E.^. CourseParticipantRegistration)
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
, dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
, dbtColonnade = mconcat
- [ dbRow
- , sortable (Just "term") (i18nCell MsgTerm) $
+ [ sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
schoolCell <$> view _courseTerm
@@ -527,8 +527,7 @@ mkSubmissionTable =
& _dbrOutput . _4 %~ E.unValue
dbtColonnade = mconcat
- [ dbRow
- , sortable (Just "term") (i18nCell MsgTerm) $
+ [ sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view _1
@@ -595,22 +594,14 @@ mkSubmissionGroupTable =
, course E.^. CourseSchool
, course E.^. CourseShorthand
)
- return (crse, sgroup, lastSGEdit sgroup)
+ return (crse, sgroup)
dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
- lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
- E.subSelectMaybe . E.from $ \(user `E.InnerJoin` sgEdit) -> do
- E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser
- E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
- return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
-
dbtProj x = return $ x
- & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
- & _dbrOutput . _3 %~ E.unValue
+ & _dbrOutput . _1 %~ $(E.unValueN 3)
dbtColonnade = mconcat
- [ dbRow
- , sortable (Just "term") (i18nCell MsgTerm) $
+ [ sortable (Just "term") (i18nCell MsgTerm) $
termCell <$> view (_dbrOutput . _1 . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
schoolCell <$> view _1
@@ -618,21 +609,15 @@ mkSubmissionGroupTable =
, sortable (Just "course") (i18nCell MsgCourse) $
courseCellCL <$> view (_dbrOutput . _1)
, sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
- maybe mempty textCell <$> view _submissionGroupName
- , sortable (Just "edit") (i18nCell MsgLastEdit) $
- maybe mempty dateTimeCell <$> view (_dbrOutput . _3)
+ cell . views _submissionGroupName toWidget
]
- validator = def -- DUPLICATED CODE: Handler.Corrections
- & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
- & restrictSorting (\name _ -> name /= "corrector")
- & defaultSorting [SortDescBy "edit"]
+ validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course"]
dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool )
, ( "submissiongroup" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _) -> sgroup E.^. SubmissionGroupName )
- , ( "edit" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _ ) -> lastSGEdit sgroup)
]
dbtFilter = Map.fromList
[ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
@@ -683,8 +668,7 @@ mkCorrectionsTable =
& _dbrOutput . _2 %~ E.unValue
dbtColonnade = mconcat
- [ dbRow
- , sortable (Just "term") (i18nCell MsgTerm) $
+ [ sortable (Just "term") (i18nCell MsgTerm) $
termCellCL <$> view (_dbrOutput . _1)
, sortable (Just "school") (i18nCell MsgCourseSchool) $
schoolCellCL <$> view (_dbrOutput . _1)
@@ -771,8 +755,8 @@ postUserNotificationR cID = do
uid <- decrypt cID
User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
- ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
- mJwt <- askJwt
+ ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
+ mBearer <- askBearer
isModal <- hasCustomHeader HeaderIsModal
let formWidget = wrapForm nsInnerWdgt def
{ formAction = Just . SomeRoute $ UserNotificationR cID
@@ -780,7 +764,7 @@ postUserNotificationR cID = do
, formAttrs = [ asyncSubmitAttr | isModal ]
}
- formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
+ formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \ns -> do
lift . runDB $ update uid [ UserNotificationSettings =. ns ]
tell . pure =<< messageI Success MsgNotificationSettingsUpdate
@@ -805,12 +789,12 @@ getSetDisplayEmailR, postSetDisplayEmailR :: Handler Html
getSetDisplayEmailR = postSetDisplayEmailR
postSetDisplayEmailR = do
uid <- requireAuthId
- mDisplayEmail <- requireCurrentTokenRestrictions
+ mDisplayEmail <- requireCurrentBearerRestrictions
case mDisplayEmail of
Nothing -> invalidArgs ["Bearer token required"]
Just displayEmail -> do
- ((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedJwtPost buttonForm
+ ((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedBearerPost buttonForm
let btnView' = wrapForm btnView def
{ formSubmit = FormNoSubmit
, formAction = Just $ SomeRoute SetDisplayEmailR
diff --git a/src/Handler/School.hs b/src/Handler/School.hs
index fa0ef7fe1..ba4ebdd22 100644
--- a/src/Handler/School.hs
+++ b/src/Handler/School.hs
@@ -19,7 +19,7 @@ getSchoolListR = do
dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
dbtSQLQuery = return
- dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) (DBRow (Entity School))
+ dbtProj :: DBRow _ -> DB (DBRow (Entity School))
dbtProj = return
dbtRowKey = (E.^. SchoolId)
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index dcc7329fd..833811653 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -30,8 +30,7 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
-- import qualified Database.Esqueleto.Internal.Sql as E
-import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE)
-
+import qualified Data.HashSet as HashSet
import qualified Data.Set as Set
import qualified Data.Map as Map
@@ -44,6 +43,8 @@ import Text.Hamlet (ihamlet)
import Data.Time.Clock.System (systemEpochDay)
+import qualified Control.Monad.State.Class as State
+
{-
* Implement Handlers
@@ -62,11 +63,12 @@ data SheetForm = SheetForm
, sfActiveTo :: Maybe UTCTime
, sfHintFrom :: Maybe UTCTime
, sfSolutionFrom :: Maybe UTCTime
- , sfType :: SheetType
- , sfGrouping :: SheetGroup
, sfSubmissionMode :: SubmissionMode
+ , sfGrouping :: SheetGroup
+ , sfType :: SheetType
, sfAutoDistribute :: Bool
, sfMarkingText :: Maybe Html
+ , sfAnonymousCorrection :: Bool
, sfCorrectors :: Loads
-- Keine SheetId im Formular!
}
@@ -92,13 +94,13 @@ getFtIdMap sId = do
return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
-makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
+makeSheetForm msId template = identifyForm FIDsheet . validateForm validateSheet $ \html -> do
oldFileIds <- (return.) <$> case msId of
Nothing -> return $ partitionFileType mempty
(Just sId) -> liftHandler $ runDB $ getFtIdMap sId
- mr'@(MsgRenderer mr) <- getMsgRenderer
+ MsgRenderer mr <- getMsgRenderer
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
- (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
+ flip (renderAForm FormStandard) html $ SheetForm
<$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
<* aformSection MsgSheetFormFiles
@@ -120,30 +122,26 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder)
& setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
<* aformSection MsgSheetFormType
- <*> sheetTypeAFormReq (fslI MsgSheetType
- & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus, MsgSheetTypeInfoInformational, MsgSheetTypeInfoNotGraded]))
- (sfType <$> template)
- <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
+ <*> sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups)
+ <*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
+ <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
- return $ case result of
- FormSuccess sheetResult
- | errorMsgs <- validateSheet mr' sheetResult
- , not $ null errorMsgs ->
- (FormFailure errorMsgs, widget)
- _ -> (result, widget)
where
- validateSheet :: MsgRenderer -> SheetForm -> [Text]
- validateSheet (MsgRenderer {..}) (SheetForm{..}) =
- [ msg | (False, msg) <-
- [ ( NTop sfVisibleFrom <= NTop sfActiveFrom , render MsgSheetErrVisibility)
- , ( NTop sfActiveFrom <= NTop sfActiveTo , render MsgSheetErrDeadlineEarly)
- , ( NTop sfHintFrom >= NTop sfActiveFrom , render MsgSheetErrHintEarly)
- , ( NTop sfSolutionFrom >= NTop sfActiveTo , render MsgSheetErrSolutionEarly)
- ] ]
+ validateSheet :: FormValidator SheetForm Handler ()
+ validateSheet = do
+ SheetForm{..} <- State.get
+ guardValidation MsgSheetErrVisibility $ NTop sfVisibleFrom <= NTop sfActiveFrom
+ guardValidation MsgSheetErrDeadlineEarly $ NTop sfActiveFrom <= NTop sfActiveTo
+ guardValidation MsgSheetErrHintEarly $ NTop sfHintFrom >= NTop sfActiveFrom
+ guardValidation MsgSheetErrSolutionEarly $ NTop sfSolutionFrom >= NTop sfActiveTo
+
+ guardValidation MsgSheetErrVisibleWithoutActive $ is _Just sfActiveFrom || is _Nothing sfVisibleFrom
+
+ warnValidation MsgSheetWarnNoActiveTo $ is _Just sfActiveTo || is _Nothing sfActiveFrom
getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetCurrentR tid ssh csh = do
@@ -271,6 +269,7 @@ getSheetListR tid ssh csh = do
psValidator = def
& defaultSorting [SortDescBy "submission-until", SortDescBy "submission-since"]
+ & forceFilter "may-access" (Any True)
(raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
{ dbtColonnade = sheetCol
@@ -284,8 +283,7 @@ getSheetListR tid ssh csh = do
)
return (sheet, lastSheetEdit sheet, submission, existFiles)
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
- , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _, _) }
- -> dbr <$ guardM (lift $ sheetFilter sheetName)
+ , dbtProj = return
, dbtSorting = Map.fromList
[ ( "name"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
@@ -312,7 +310,11 @@ getSheetListR tid ssh csh = do
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
-- )
]
- , dbtFilter = mempty
+ , dbtFilter = mconcat
+ [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
+ let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
+ in (==b) <$> sheetFilter sheetName :: DB Bool
+ ]
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams = def
@@ -377,14 +379,18 @@ getSShowR tid ssh csh shn = do
-- , colFileModification (view _2)
]
let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
+ & forceFilter "may-access" (Any True)
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery = fileData
, dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
, dbtColonnade = colonnadeFiles
- , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
- -> guardAuthorizedFor (CSheetR tid ssh csh shn $ SFileR fType fName) dbrOutput
+ , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
, dbtStyle = def
- , dbtFilter = mempty
+ , dbtFilter = mconcat
+ [ singletonMap "may-access" . FilterProjected $ \(Any b) r ->
+ let (E.Value fName, _, E.Value fType) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
+ in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
+ ]
, dbtFilterUI = mempty
, dbtIdent = "files" :: Text
, dbtSorting = Map.fromList
@@ -527,6 +533,7 @@ getSheetNewR tid ssh csh = do
, sfMarkingText = sheetMarkingText
, sfAutoDistribute = sheetAutoDistribute
, sfCorrectors = loads
+ , sfAnonymousCorrection = sheetAnonymousCorrection
}
_other -> Nothing
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
@@ -563,6 +570,7 @@ getSEditR tid ssh csh shn = do
, sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
, sfMarkingText = sheetMarkingText
, sfAutoDistribute = sheetAutoDistribute
+ , sfAnonymousCorrection = sheetAnonymousCorrection
, sfCorrectors = currentLoads
}
@@ -596,15 +604,16 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetSolutionFrom = sfSolutionFrom
, sheetSubmissionMode = sfSubmissionMode
, sheetAutoDistribute = sfAutoDistribute
+ , sheetAnonymousCorrection = sfAnonymousCorrection
}
mbsid <- dbAction newSheet
case mbsid of
Nothing -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
(Just sid) -> do -- save files in DB:
- whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise
- whenIsJust sfHintF $ insertSheetFile' sid SheetHint
- whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
- whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking
+ insertSheetFile' sid SheetExercise $ fromMaybe (return ()) sfSheetF
+ insertSheetFile' sid SheetHint $ fromMaybe (return ()) sfHintF
+ insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF
+ insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF
insert_ $ SheetEdit aid actTime sid
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
-- Sanity checks generating warnings only, but not errors!
@@ -665,14 +674,6 @@ postSDelR tid ssh csh shn = do
}
-insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
-insertSheetFile sid ftype finfo = do
- runConduit $ sourceFiles finfo .| C.mapM_ finsert
- where
- finsert file = do
- fid <- insert file
- void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
-
insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodJobDB UniWorX ()
insertSheetFile' sid ftype fs = do
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
@@ -683,7 +684,9 @@ insertSheetFile' sid ftype fs = do
keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert
mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
where
- finsert (Left fileId) = tell $ singleton fileId
+ finsert (Left fid) = do
+ lift . void $ upsertBy (UniqueSheetFile fid sid ftype) (SheetFile sid fid ftype) []
+ tell $ singleton fid
finsert (Right file) = lift $ do
fid <- insert file
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
@@ -875,7 +878,7 @@ correctorInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
invitationTokenConfig _ _ = do
- itAuthority <- Right <$> liftHandler requireAuthId
+ itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index a89be407d..43be93673 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -37,6 +37,8 @@ import Text.Blaze (Markup)
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
+import qualified Data.HashSet as HashSet
+
-- import Colonnade hiding (bool, fromMaybe)
-- import qualified Yesod.Colonnade as Yesod
-- import qualified Text.Blaze.Html5.Attributes as HA
@@ -104,7 +106,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
invitationTokenConfig (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet
Course{..} <- getJust sheetCourse
- itAuthority <- Right <$> liftHandler requireAuthId
+ itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
let itExpiresAt = Nothing
itStartsAt = Nothing
@@ -150,6 +152,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.orderBy [E.asc $ user E.^. UserEmail]
return user
previousCoSubmittors :: UserId -> E.SqlQuery (E.SqlExpr (Entity User))
@@ -161,6 +164,10 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
E.where_ . E.exists . E.from $ \submissionUser' ->
E.where_ $ submissionUser' E.^. SubmissionUserUser E.==. E.val uid
E.&&. submissionUser' E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+ E.where_ . E.exists . E.from $ \participant ->
+ E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
+ E.&&. participant E.^. CourseParticipantUser E.==. user E.^. UserId
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.orderBy [E.asc $ user E.^. UserEmail]
return user
@@ -356,7 +363,34 @@ submissionHelper tid ssh csh shn mcid = do
, isLecturer
, not isLecturer
)
- (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer) -- TODO: Return registered group members
+ (Nothing, RegisteredGroups) -> do
+ buddies <- E.select . E.from $ \(submissionGroup `E.InnerJoin` user) -> do
+ E.on . E.exists . E.from $ \submissionGroupUser ->
+ E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. user E.^. UserId
+ E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
+ E.where_ . E.exists . E.from $ \submissionGroupUser ->
+ E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
+ E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+ E.where_ $ user E.^. UserId E.!=. E.val uid
+ E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
+ E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+ E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
+ E.&&. submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+
+ E.orderBy [E.asc $ user E.^. UserEmail]
+
+ return $ user E.^. UserId
+
+ return ( csheet
+ , buddies
+ & map (Right . E.unValue)
+ & Set.fromList
+ , []
+ , maySubmit
+ , isLecturer
+ , not isLecturer
+ )
+ (Nothing, _) -> return (csheet, Set.empty, [], maySubmit, isLecturer, not isLecturer)
(Just smid, _) -> do
void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
@@ -423,6 +457,7 @@ submissionHelper tid ssh csh shn mcid = do
isParticipant = E.exists . E.from $ \courseParticipant -> do
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
+ E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
@@ -476,16 +511,24 @@ submissionHelper tid ssh csh shn mcid = do
-- Determine new submission users
subUsers <- if
| isLecturer -> return adhocMembers
- | otherwise -> do
+ | RegisteredGroups <- sheetGrouping -> do
-- Determine members of pre-registered group
groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse
+
+ E.where_ . E.not_ . E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
+ E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+ E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
+ E.&&. submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser' E.^. SubmissionGroupUserUser
+ E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
+
return $ submissionGroupUser' E.^. SubmissionGroupUserUser
-- SubmissionUser for all group members (pre-registered & ad-hoc)
- return $ groupUids `Set.union` adhocMembers
+ return $ Set.insert (Right uid) groupUids
+ | otherwise -> return adhocMembers
-- Since invitations carry no data we only need to consider changes to
-- the set of users/invited emails
@@ -682,7 +725,7 @@ getCorrectionsDownloadR = do -- download all assigned and open submissions
when (null subs) $ do
addMessageI Info MsgNoOpenSubmissions
redirect CorrectionsR
- submissionMultiArchive $ Set.fromList subs
+ submissionMultiArchive SubmissionDownloadAnonymous $ Set.fromList subs
getSubAssignR, postSubAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs
index 13ebabe6d..f4b40496a 100644
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@@ -1,14 +1,21 @@
-module Handler.SystemMessage where
+module Handler.SystemMessage
+ ( getMessageR, postMessageR
+ , getMessageListR, postMessageListR
+ , ButtonSystemMessageHide(..)
+ , postMessageHideR
+ ) where
import Import
import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set
+import qualified Data.HashMap.Strict as HashMap
import qualified Data.List.NonEmpty as NonEmpty
import Handler.Utils
+import Handler.Utils.News
import qualified Database.Esqueleto as E
@@ -24,17 +31,22 @@ postMessageR cID = do
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
MsgRenderer mr <- getMsgRenderer
+ now <- liftIO getCurrentTime
let
mkForm = do
((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
$ SystemMessage
- <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
- <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
- <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
+ <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
+ <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
+ <*> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just systemMessageNewsOnly)
+ <*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
<*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
+ <*> pure systemMessageCreated
+ <*> (bool systemMessageLastChanged now <$> apopt checkBoxField (fslI MsgSystemMessageRecordChanged & setTooltip MsgSystemMessageRecordChangedTip) (Just True))
+ <*> (bool systemMessageLastUnhide now <$> apopt checkBoxField (fslI MsgSystemMessageUnhide & setTooltip MsgSystemMessageUnhideTip) (Just False))
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageDefaultLanguage)
- <*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent)
- <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary)
+ <*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent)
+ <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary)
ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage]
let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts
@@ -53,11 +65,14 @@ postMessageR cID = do
<*> combinedButtonFieldF ""
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
+ nextLang = toList appLanguages
+ & filter (not . langMatches systemMessageDefaultLanguage)
+ & filter (\l -> none (`langMatches` l) $ Map.keys ts')
((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
$ SystemMessageTranslation
<$> pure smId
- <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) Nothing
+ <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
<*> areq htmlField (fslI MsgSystemMessageContent) Nothing
<*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
@@ -122,16 +137,8 @@ postMessageR cID = do
siteLayout' (toWidget <$> summary)
$(widgetFile "system-message")
where
- modifySystemMessage smId SystemMessage{..} = do
- runDB $ update smId
- [ SystemMessageFrom =. systemMessageFrom
- , SystemMessageTo =. systemMessageTo
- , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly
- , SystemMessageSeverity =. systemMessageSeverity
- , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage
- , SystemMessageContent =. systemMessageContent
- , SystemMessageSummary =. systemMessageSummary
- ]
+ modifySystemMessage smId sm = do
+ runDB $ replace smId sm
addMessageI Success MsgSystemMessageEditSuccess
redirect $ MessageR cID
@@ -162,12 +169,15 @@ postMessageListR = do
dbtSQLQuery = return
dbtColonnade = mconcat
[ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
- , dbRow
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR ciphertext
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
, sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
+ , sortable (Just "news-only") (i18nCell MsgSystemMessageNewsOnly) $ \DBRow { dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageNewsOnly
, sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
, sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity
+ , sortable (Just "created") (i18nCell MsgSystemMessageCreated) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageCreated
+ , sortable (Just "last-changed") (i18nCell MsgSystemMessageLastChanged) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageLastChanged
+ , sortable (Just "last-unhide") (i18nCell MsgSystemMessageLastUnhide) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageLastUnhide
, sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let
(summary, content) = case smT of
Nothing -> (systemMessageSummary, systemMessageContent)
@@ -175,7 +185,7 @@ postMessageListR = do
in cell . toWidget $ fromMaybe content summary
]
dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
- Just (_, smT) <- lift $ getSystemMessage appLanguages smId
+ smT <- (>>= view _2) <$> getSystemMessage appLanguages smId
return DBRow
{ dbrOutput = (smE, smT)
, ..
@@ -193,12 +203,24 @@ postMessageListR = do
, ( "to"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageTo
)
+ , ( "news-only"
+ , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageNewsOnly
+ )
, ( "authenticated"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly
)
, ( "severity"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity
)
+ , ( "created"
+ , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageCreated
+ )
+ , ( "last-changed"
+ , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageLastChanged
+ )
+ , ( "last-unhide"
+ , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageLastUnhide
+ )
]
, dbtFilter = mempty
, dbtFilterUI = mempty
@@ -254,14 +276,17 @@ postMessageListR = do
-> addMessageI Error MsgSystemMessageEmptySelection
MsgRenderer mr <- getMsgRenderer
+ now <- liftIO getCurrentTime
((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
- <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
- <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
- <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
- <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) Nothing
+ <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just Nothing)
+ <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just Nothing)
+ <*> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just False)
+ <*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just False)
+ <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just Info)
+ <*> pure now <*> pure now <*> pure now
<*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just $ NonEmpty.head appLanguages)
<*> areq htmlField (fslI MsgSystemMessageContent) Nothing
- <*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing
+ <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just Nothing)
case addRes of
FormMissing -> return ()
@@ -279,3 +304,53 @@ postMessageListR = do
defaultLayout
$(widgetFile "system-message-list")
+
+
+data ButtonSystemMessageHide
+ = BtnSystemMessageHide
+ | BtnSystemMessageUnhide
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite)
+nullaryPathPiece ''ButtonSystemMessageHide $ camelToPathPiece' 3
+embedRenderMessage ''UniWorX ''ButtonSystemMessageHide id
+
+instance Button UniWorX ButtonSystemMessageHide where
+ btnClasses BtnSystemMessageHide = [BCLink]
+ btnClasses BtnSystemMessageUnhide = [BCLink]
+
+
+postMessageHideR :: CryptoUUIDSystemMessage -> Handler Void
+postMessageHideR cID = do
+ now <- liftIO getCurrentTime
+ muid <- maybeAuthId
+ smId <- decrypt cID
+
+ ((btnRes, _), _) <- runFormPost buttonForm
+
+ formResult btnRes $ \case
+ BtnSystemMessageHide -> runDB $ do
+ existsKey404 smId
+
+ whenIsJust muid $ \uid -> void $
+ upsert SystemMessageHidden
+ { systemMessageHiddenMessage = smId
+ , systemMessageHiddenUser = uid
+ , systemMessageHiddenTime = now
+ }
+ [ SystemMessageHiddenTime =. now ]
+
+ modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
+ -> fmap MergeHashMap . assertM' (/= mempty) $
+ HashMap.update (\smSt -> assertM' (/= mempty) $ smSt { userSystemMessageUnhidden = Nothing, userSystemMessageHidden = guardOn (is _Nothing muid) now }) cID hm
+
+ BtnSystemMessageUnhide -> runDB $ do
+ existsKey404 smId
+
+ whenIsJust muid $ \uid ->
+ deleteBy $ UniqueSystemMessageHidden uid smId
+
+ modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
+ -> fmap MergeHashMap . assertM' (/= mempty) $
+ HashMap.update (\smSt -> assertM' (/= mempty) $ smSt { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = guardOn (is _Nothing muid) now }) cID hm
+
+ redirect . (NewsR, ) . bool [] [(toPathPiece GetHidden, "")] $ btnRes == FormSuccess BtnSystemMessageUnhide
diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs
index f43384eac..3be594c33 100644
--- a/src/Handler/Term.hs
+++ b/src/Handler/Term.hs
@@ -197,14 +197,14 @@ data TermFormTemplate = TermFormTemplate
-- | TermFormTemplates form a pointwise-left biased Semigroup
instance Semigroup TermFormTemplate where
- left <> right = TermFormTemplate
- { tftName = tftName left <|> tftName right
- , tftStart = tftStart left <|> tftStart right
- , tftEnd = tftEnd left <|> tftEnd right
- , tftHolidays = tftHolidays left <|> tftHolidays right
- , tftLectureStart = tftLectureStart left <|> tftLectureStart right
- , tftLectureEnd = tftLectureEnd left <|> tftLectureEnd right
- , tftActive = tftActive left <|> tftActive right
+ l <> r = TermFormTemplate
+ { tftName = tftName l <|> tftName r
+ , tftStart = tftStart l <|> tftStart r
+ , tftEnd = tftEnd l <|> tftEnd r
+ , tftHolidays = tftHolidays l <|> tftHolidays r
+ , tftLectureStart = tftLectureStart l <|> tftLectureStart r
+ , tftLectureEnd = tftLectureEnd l <|> tftLectureEnd r
+ , tftActive = tftActive l <|> tftActive r
}
instance Monoid TermFormTemplate where
diff --git a/src/Handler/Tutorial/TutorInvite.hs b/src/Handler/Tutorial/TutorInvite.hs
index bcb002f4d..725cc6e83 100644
--- a/src/Handler/Tutorial/TutorInvite.hs
+++ b/src/Handler/Tutorial/TutorInvite.hs
@@ -13,6 +13,8 @@ import Handler.Utils.Invitations
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
+import qualified Data.HashSet as HashSet
+
instance IsInvitableJunction Tutor where
type InvitationFor Tutor = Tutorial
@@ -64,7 +66,7 @@ tutorInvitationConfig = InvitationConfig{..}
invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
invitationTokenConfig _ _ = do
- itAuthority <- Right <$> liftHandler requireAuthId
+ itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionTutor, ())
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index 27c59d743..bcc916a16 100644
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@@ -36,6 +36,8 @@ import Handler.Users.Add as Handler.Users
import qualified Data.Conduit.List as C
+import qualified Data.HashSet as HashSet
+
hijackUserForm :: Form ()
hijackUserForm csrf = do
@@ -74,8 +76,7 @@ postUsersR = do
MsgRenderer mr <- getMsgRenderer
let
dbtColonnade = mconcat $
- [ dbRow
- , dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey))
+ [ dbSelect (applying _2) id (return . view (_dbrOutput . _entityKey))
, sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
(AdminUserR <$> encrypt uid)
(nameWidget userDisplayName userSurname)
@@ -336,8 +337,8 @@ postAdminUserR uuid = do
campusHandler :: MonadPlus m => Auth.CampusUserException -> m a
campusHandler _ = mzero
campusResult <- runMaybeT . handle campusHandler $ do
- (Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
- void . lift . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
+ Just pool <- getsYesod $ view _appLdapPool
+ void . lift . Auth.campusUser pool FailoverUnlimited $ Creds Auth.apLdap (CI.original userIdent) []
case campusResult of
Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
_other
@@ -477,13 +478,13 @@ postUserPasswordR cID = do
[ False <$ guard (isn't _AuthPWHash userAuthentication)
, False <$ guard isAdmin
, do
- authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentTokenRestrictions
+ authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions
unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
invalidArgsI [MsgUnauthorizedPasswordResetToken]
return False
]
- ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
+ ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
currentResult <- if
| AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication
, requireCurrent
@@ -572,7 +573,7 @@ functionInvitationConfig = InvitationConfig{..}
MsgRenderer mr <- getMsgRenderer
return [ihamlet|_{SomeMessage $ MsgSchoolFunctionInviteExplanation (mr $ SomeMessage invTokenUserFunctionFunction)}|]
invitationTokenConfig _ (InvDBDataUserFunction{..}, _) = do
- itAuthority <- Right <$> liftHandler requireAuthId
+ itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
let itExpiresAt = Just $ Just invDBUserFunctionDeadline
itAddAuth = Nothing
itStartsAt = Nothing
diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs
index 8ba6f99ce..5b4e5f5c0 100644
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@@ -24,6 +24,7 @@ import Handler.Utils.I18n as Handler.Utils
import Handler.Utils.Widgets as Handler.Utils
import Handler.Utils.Database as Handler.Utils
import Handler.Utils.Occurrences as Handler.Utils
+import Handler.Utils.Memcached as Handler.Utils
import Control.Monad.Logger
diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs
index d756228f0..33590a8ac 100644
--- a/src/Handler/Utils/Allocation.hs
+++ b/src/Handler/Utils/Allocation.hs
@@ -1,9 +1,10 @@
module Handler.Utils.Allocation
- ( allocationDone
+ ( allocationStarted
, ordinalPriorities
, sinkAllocationPriorities
+ , MatchingLogRun(..)
, computeAllocation
- , doAllocation
+ -- , doAllocation -- Use `storeAllocationResult`
, ppMatchingLog
, storeAllocationResult
) where
@@ -15,6 +16,7 @@ import qualified Data.Map.Strict as Map
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
+import Control.Monad.Trans.State (execStateT)
import qualified Control.Monad.State.Class as State (get, modify')
import Data.List (genericLength, elemIndex)
@@ -22,7 +24,10 @@ import qualified Data.Vector as Vector
import Data.Vector.Lens (vector)
import qualified Data.Set as Set
-import System.Random (mkStdGen)
+import qualified Data.Binary as Binary
+import Crypto.Hash.Algorithms (SHAKE256)
+import Crypto.Random (drgNewSeed, seedFromBinary)
+import Crypto.Error (onCryptoFailure)
import Utils.Allocation
@@ -31,15 +36,39 @@ import qualified Data.Conduit.List as C
import Data.Generics.Product.Param
import qualified Crypto.Hash as Crypto
-import qualified Data.Binary as Binary
-
-import qualified Data.ByteArray as BA (convert)
+
+import Language.Haskell.TH (nameBase)
-allocationDone :: AllocationId -> DB (Maybe UTCTime)
-allocationDone allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \participant -> do
- E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val allocId)
- return . E.max_ $ participant E.^. CourseParticipantRegistration
+data MatchingExcludedReason
+ = MatchingExcludedParticipationExisted
+ | MatchingExcludedParticipationExists
+ | MatchingExcludedVeto
+ | MatchingExcludedLecturer
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite, NFData)
+
+nullaryPathPiece ''MatchingExcludedReason $ camelToPathPiece' 2
+pathPieceJSON ''MatchingExcludedReason
+
+data MatchingLogRun = MatchingLogRun
+ { matchingLogRunCourseRestriction :: Maybe (Set CourseId)
+ , matchingLogRunCoursesExcluded :: Set CourseId
+ , matchingLogMatchingsExcluded :: Map (UserId, CourseId) (NonNull (Set MatchingExcludedReason))
+ , matchingLogRunLog :: Seq (MatchingLog UserId CourseId Natural)
+ } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ deriving anyclass (NFData)
+
+deriveJSON defaultOptions
+ { fieldLabelModifier = camelToPathPiece' 3
+ } ''MatchingLogRun
+
+
+allocationStarted :: AllocationId -> DB (Maybe UTCTime)
+-- ^ Time the first allocation was made
+allocationStarted allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \allocationMatching -> do
+ E.where_ $ allocationMatching E.^. AllocationMatchingAllocation E.==. E.val allocId
+ return . E.min_ $ allocationMatching E.^. AllocationMatchingTime
ordinalPriorities :: Monad m => ConduitT UserMatriculation (Map UserMatriculation AllocationPriority) m ()
@@ -56,18 +85,27 @@ sinkAllocationPriorities allocId = fmap getSum . C.foldMapM . ifoldMapM $ \matr
E.&&. user E.^. UserMatrikelnummer E.==. E.val (Just matr)
-computeAllocation :: AllocationId
+computeAllocation :: Entity Allocation
-> Maybe (Set CourseId) -- ^ Optionally restrict allocation to only consider the given courses
-> DB ( AllocationFingerprint
, Set (UserId, CourseId)
- , Seq (MatchingLog UserId CourseId Natural)
+ , Seq MatchingLogRun
)
-computeAllocation allocId cRestr = do
- allocations <- selectList [ CourseParticipantAllocated ==. Just allocId ] []
+computeAllocation (Entity allocId Allocation{allocationMatchingSeed}) cRestr = do
+ allocations <- selectList [ CourseParticipantAllocated ==. Just allocId, CourseParticipantState ==. CourseParticipantActive ] []
let allocations' = allocations
& map ((, Sum 1) . courseParticipantUser . entityVal)
& Map.fromListWith (<>)
- & fmap getSum
+
+ deregistrations <- E.select . E.from $ \(allocationDeregister `E.InnerJoin` courseParticipant) -> do
+ E.on $ courseParticipant E.^. CourseParticipantUser E.==. allocationDeregister E.^. AllocationDeregisterUser
+ E.&&. E.just (courseParticipant E.^. CourseParticipantCourse) E.==. allocationDeregister E.^. AllocationDeregisterCourse
+ E.where_ $ courseParticipant E.^. CourseParticipantState E.!=. E.val CourseParticipantActive
+ E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.just (E.val allocId)
+ return $ allocationDeregister E.^. AllocationDeregisterUser
+ let deregistrations' = deregistrations
+ & map ((, Sum 1) . E.unValue)
+ & Map.fromListWith (<>)
users' <- selectList [ AllocationUserAllocation ==. allocId ] []
let users'' = users'
@@ -76,11 +114,11 @@ computeAllocation allocId cRestr = do
totalCourses <- lift $ allocationUserTotalCourses . entityVal
priority <- MaybeT $ allocationUserPriority . entityVal
- let allocated = Map.findWithDefault 0 user allocations'
+ let Sum allocated = Map.findWithDefault 0 user allocations' <> Map.findWithDefault 0 user deregistrations'
guard $ totalCourses > allocated
- return (user, (totalCourses - allocated, priority))
+ return (user, ((allocated, totalCourses - allocated), priority))
)
& Map.fromList
cloneCounts = Map.map (view _1) users''
@@ -92,6 +130,7 @@ computeAllocation allocId cRestr = do
let participants = E.subSelectCount . E.from $ \participant -> do
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.where_ . E.not_ . E.exists . E.from $ \lecturer ->
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser
@@ -106,15 +145,35 @@ computeAllocation allocId cRestr = do
let capacities = Map.filter (maybe True (> 0)) . Map.fromList $ (view (_1 . _entityVal . _allocationCourseCourse) &&& view (_2 . _Value)) <$> courses'
applications' <- selectList [ CourseApplicationAllocation ==. Just allocId ] []
- let alreadyAssigned (Entity _ CourseApplication{..}) = orM
- [ exists [ TransactionLogInfo ==. toJSON (TransactionCourseParticipantDeleted courseApplicationCourse courseApplicationUser) ]
- , exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser ]
- ]
- applications'' <- applications'
- & filter ((\CourseApplication{..} -> not courseApplicationRatingVeto && fromMaybe True (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) . entityVal)
- & filterM (fmap not . alreadyAssigned)
+ excludedMatchings <- flip execStateT mempty . forM_ applications' $ \(Entity _ CourseApplication{..}) -> do
+ let
+ tellExcluded :: MatchingExcludedReason -> StateT _ _ ()
+ tellExcluded reason = State.modify' $ Map.insertWith (<>) (courseApplicationUser, courseApplicationCourse) (opoint reason :: NonNull (Set MatchingExcludedReason))
+
+ when (courseApplicationRatingVeto || maybe False not (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) $
+ tellExcluded MatchingExcludedVeto
+
+ allocStarted <- lift $ allocationStarted allocId
+ whenIsJust allocStarted $ \allocStarted' -> do
+ let partDeleted = lift $ or2M
+ (exists [ TransactionLogInfo ==. toJSON (TransactionCourseParticipantDeleted courseApplicationCourse courseApplicationUser), TransactionLogTime >=. allocStarted' ])
+ (exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser, CourseParticipantState !=. CourseParticipantActive ])
+ whenM partDeleted $
+ tellExcluded MatchingExcludedParticipationExisted
+
+ let partExists :: StateT _ DB Bool
+ partExists = lift $ exists [ CourseParticipantCourse ==. courseApplicationCourse, CourseParticipantUser ==. courseApplicationUser, CourseParticipantState ==. CourseParticipantActive ]
+ whenM partExists $
+ tellExcluded MatchingExcludedParticipationExists
+
+ let lecturerExists = lift $ exists [ LecturerCourse ==. courseApplicationCourse, LecturerUser ==. courseApplicationUser ]
+ whenM lecturerExists $
+ tellExcluded MatchingExcludedLecturer
+ let applications'' = applications'
+ & map entityVal
+ & filter (\CourseApplication{..} -> Map.notMember (courseApplicationUser, courseApplicationCourse) excludedMatchings)
let preferences = Map.fromList $ do
- Entity _ CourseApplication{..} <- applications''
+ CourseApplication{..} <- applications''
guard $ Map.member courseApplicationCourse capacities
return ((courseApplicationUser, courseApplicationCourse), (courseApplicationAllocationPriority, courseApplicationRatingPoints))
@@ -150,53 +209,75 @@ computeAllocation allocId cRestr = do
= id
let
- fingerprint :: AllocationFingerprint
- fingerprint = Crypto.hash . toStrict $ Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces)
+ inputs = Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces)
- g = mkStdGen $ hash (BA.convert fingerprint :: ByteString)
+ fingerprint :: AllocationFingerprint
+ fingerprint = Crypto.hashlazy inputs
+
+ g = onCryptoFailure (\_ -> error "Could not create DRG") id . fmap drgNewSeed . seedFromBinary $ kmaclazy @(SHAKE256 320) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'computeAllocation) allocationMatchingSeed inputs
let
- doAllocationWithout cs = runWriter $ computeMatchingLog g cloneCounts capacities' preferences' centralNudge
+ doAllocationWithout :: Set CourseId -> Writer (Seq (MatchingLog UserId CourseId Natural)) (Set (UserId, CourseId))
+ doAllocationWithout cs = computeMatchingLog g cloneCounts capacities' preferences' centralNudge
where
capacities' = Map.filterWithKey (\ c _ -> Set.notMember c cs) capacities
preferences' = Map.filterWithKey (\(_, c) _ -> Set.notMember c cs) preferences
- allocationLoop cs
- | not $ null belowMin = doAllocationWithout $ cs <> Set.fromList belowMin
- | otherwise = (allocs, mLog)
- where
- (allocs, mLog) = doAllocationWithout cs
- belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) ->
- guardOn (Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap) allocationCourseCourse
+ allocationLoop :: Set CourseId -> Writer (Seq MatchingLogRun) (Set (UserId, CourseId))
+ allocationLoop cs = do
+ allocs <- mapWriter (over _2 $ pure . MatchingLogRun cRestr cs excludedMatchings) $ doAllocationWithout cs
+ let
+ belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) -> do
+ guard . not $ Set.member allocationCourseCourse cs
+ guard $ Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap
+ return allocationCourseCourse
+ if
+ | not $ null belowMin -> allocationLoop $ cs <> Set.fromList belowMin
+ | otherwise -> return allocs
- return . (\(ms, mLog) -> (fingerprint, ms, mLog)) $!! allocationLoop Set.empty
+ return . (\(ms, mLog) -> (fingerprint, ms, mLog)) $!! runWriter (allocationLoop Set.empty)
doAllocation :: AllocationId
+ -> UTCTime
-> Set (UserId, CourseId)
-> DB ()
-doAllocation allocId regs = do
- now <- liftIO getCurrentTime
+doAllocation allocId now regs =
forM_ regs $ \(uid, cid) -> do
mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
- void . insertUnique $ CourseParticipant cid uid now mField (Just allocId)
+ void $ upsert
+ (CourseParticipant cid uid now mField (Just allocId) CourseParticipantActive)
+ [ CourseParticipantRegistration =. now
+ , CourseParticipantField =. mField
+ , CourseParticipantAllocated =. Just allocId
+ , CourseParticipantState =. CourseParticipantActive
+ ]
+ audit $ TransactionCourseParticipantEdit cid uid
-ppMatchingLog :: forall mono.
- ( MonoFoldable mono
- , Element mono ~ MatchingLog UserId CourseId Natural
- )
- => mono -> Text
-ppMatchingLog = unlines . map (tshow . pretty) . otoList
+ppMatchingLog :: Seq MatchingLogRun -> Text
+ppMatchingLog = unlines . map prettyRun . otoList
where
+ prettyRun MatchingLogRun{..} = unlines
+ [ "----- STARTING RUN -----"
+ , "Course restriction: " <> tshow (Set.toAscList <$> matchingLogRunCourseRestriction)
+ , "Courses excluded: " <> tshow (Set.toAscList matchingLogRunCoursesExcluded)
+ , "Matchings excluded (user, course): "
+ , unlines . map (" " <>) . flip ifoldMap matchingLogMatchingsExcluded $ \(uid, cid) (otoList -> reasons) -> pure $
+ "(" <> tshow (fromSqlKey uid) <> ", " <> tshow (fromSqlKey cid) <> ") " <> intercalate ", " (map tshow reasons) :: [Text]
+ , "------------------------"
+ , unlines . map (tshow . pretty) $ otoList matchingLogRunLog
+ , "------ RUN ENDED -------"
+ ]
+
pretty :: MatchingLog UserId CourseId Natural -> MatchingLog Int64 Int64 Natural
pretty = over (param @1) fromSqlKey
. over (param @2) fromSqlKey
storeAllocationResult :: AllocationId
- -> (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
+ -> UTCTime
+ -> (AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun)
-> DB ()
-storeAllocationResult allocId (allocFp, allocMatchings, ppMatchingLog -> allocLog) = do
- now <- liftIO getCurrentTime
- insert_ . AllocationMatching allocId allocFp <=< insert $ File "matchings.log" (Just $ encodeUtf8 allocLog) now
+storeAllocationResult allocId now (allocFp, allocMatchings, ppMatchingLog -> allocLog) = do
+ insert_ . AllocationMatching allocId allocFp now <=< insert $ File "matchings.log" (Just $ encodeUtf8 allocLog) now
- doAllocation allocId allocMatchings
+ doAllocation allocId now allocMatchings
diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs
index 197f795d5..88560a5c3 100644
--- a/src/Handler/Utils/Communication.hs
+++ b/src/Handler/Utils/Communication.hs
@@ -56,7 +56,8 @@ instance PathPiece RecipientCategory where
toPathPiece RecipientCustom = "custom"
toPathPiece (RecipientGroup g) = toPathPiece g
- fromPathPiece = finiteFromPathPiece
+ fromPathPiece "custom" = Just RecipientCustom
+ fromPathPiece t = RecipientGroup <$> fromPathPiece t
instance RenderMessage UniWorX RecipientCategory where
renderMessage foundation ls = \case
diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs
index cb16f7d20..a595c37ca 100644
--- a/src/Handler/Utils/Course.hs
+++ b/src/Handler/Utils/Course.hs
@@ -4,6 +4,8 @@ import Import
import Handler.Utils.Delete
import qualified Database.Esqueleto as E
+
+import qualified Data.Set as Set
courseDeleteRoute :: Set CourseId -> DeleteRoute Course
@@ -27,3 +29,44 @@ courseDeleteRoute drRecords = DeleteRoute
, drSuccess = error "drSuccess undefined"
, drDelete = const id -- TODO: audit
}
+
+setUserSubmissionGroup :: ( MonadHandler m
+ , HandlerSite m ~ UniWorX
+ , backend ~ SqlBackend
+ , MonadCatch m
+ ) => CourseId -> UserId -> Maybe SubmissionGroupName -> ReaderT backend m Bool
+setUserSubmissionGroup cid uid = fmap (> 0) . setUsersSubmissionGroup cid (Set.singleton uid)
+
+setUsersSubmissionGroup :: ( MonadHandler m
+ , HandlerSite m ~ UniWorX
+ , backend ~ SqlBackend
+ , MonadCatch m
+ ) => CourseId -> Set UserId -> Maybe SubmissionGroupName -> ReaderT backend m Int64
+setUsersSubmissionGroup cid uids Nothing = do
+ didDelete <- fmap getSum . flip foldMapM uids $ \uid -> do
+ didDelete <- fmap (> 0) . E.deleteCount . E.from $ \submissionGroupUser ->
+ E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
+ E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid
+ when didDelete $
+ audit $ TransactionSubmissionGroupUnset cid uid
+ return $ bool mempty (Sum 1) didDelete
+ E.delete . E.from $ \submissionGroup ->
+ E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
+ E.&&. E.not_ (E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId)
+ return didDelete
+setUsersSubmissionGroup cid uids (Just grp) = do
+ Entity gId _ <- upsert (SubmissionGroup cid grp) [ SubmissionGroupName =. grp ]
+
+ E.delete . E.from $ \submissionGroupUser ->
+ E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (Set.toList uids)
+ E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid
+ E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.!=. E.val gId
+ E.delete . E.from $ \submissionGroup ->
+ E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
+ E.&&. E.not_ (E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId)
+ E.&&. submissionGroup E.^. SubmissionGroupId E.!=. E.val gId
+ fmap getSum . flip foldMapM uids $ \uid -> do
+ didSet <- fmap (is _Just) . insertUnique $ SubmissionGroupUser gId uid
+ when didSet $
+ audit $ TransactionSubmissionGroupSet cid uid grp
+ return $ bool mempty (Sum 1) didSet
diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs
index b192a1c4f..4b2d9dcf4 100644
--- a/src/Handler/Utils/Csv.hs
+++ b/src/Handler/Utils/Csv.hs
@@ -20,6 +20,8 @@ import Import hiding (Header, mapM_)
import Data.Csv
import Data.Csv.Conduit
+import Handler.Utils.Form (uploadContents)
+
import Control.Monad (mapM_)
-- import qualified Data.Csv.Util as Csv
@@ -36,11 +38,11 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.Attoparsec.ByteString.Lazy as A
-import Control.Monad.Except (ExceptT)
-
import Handler.Utils.DateTime
import Data.Time.Format (iso8601DateFormat)
+import qualified Data.Char as Char
+
decodeCsv :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv) => ConduitT ByteString csv m ()
decodeCsv = decodeCsv' fromNamedCsv
@@ -71,6 +73,7 @@ decodeCsv' fromCsv' = do
let decodeOptions = defaultDecodeOptions
& guessDelimiter testBuffer
+ & noAlphaNumDelimiters
$logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|]
fromCsv' decodeOptions
@@ -106,6 +109,12 @@ decodeCsv' fromCsv' = do
| otherwise
= id
+ noAlphaNumDelimiters opts
+ | Char.isAlphaNum . Char.chr . fromIntegral $ decDelimiter opts
+ = opts { decDelimiter = decDelimiter defaultDecodeOptions }
+ | otherwise
+ = opts
+
quotedField :: A.Parser () -- We don't care about the return value
quotedField = void . Csv.field $ Csv.decDelimiter defaultDecodeOptions -- We can use comma as a separator, because we know that the field we're trying to parse is quoted and so does not rely on the delimiter
@@ -206,9 +215,8 @@ fileSourceCsv :: ( FromNamedRecord csv
, MonadHandler m
, HandlerSite m ~ UniWorX
)
- => FileInfo
- -> ConduitT () csv m ()
-fileSourceCsv = (.| decodeCsv) . fileSource
+ => ConduitT (Either FileId File) csv m ()
+fileSourceCsv = uploadContents .| decodeCsv
fileSourceCsvPositional :: ( MonadHandler m
, HandlerSite m ~ UniWorX
@@ -216,9 +224,8 @@ fileSourceCsvPositional :: ( MonadHandler m
, FromRecord csv
)
=> HasHeader
- -> FileInfo
- -> ConduitT () csv m ()
-fileSourceCsvPositional hdr = (.| decodeCsvPositional hdr) . fileSource
+ -> ConduitT (Either FileId File) csv m ()
+fileSourceCsvPositional hdr = uploadContents .| decodeCsvPositional hdr
instance ToWidget UniWorX CsvRendered where
diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs
index 64afdc7ef..419788526 100644
--- a/src/Handler/Utils/DateTime.hs
+++ b/src/Handler/Utils/DateTime.hs
@@ -1,6 +1,9 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
module Handler.Utils.DateTime
( utcToLocalTime, utcToZonedTime
, localTimeToUTC, TZ.LocalToUTCResult(..)
+ , toTimeOfDay
, toMidnight, beforeMidnight, toMidday, toMorning
, formatDiffDays
, formatTime'
@@ -23,11 +26,16 @@ import qualified Data.Time.Zones as TZ
import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime, utcToZonedTime)
-- import Data.Time.Clock (addUTCTime,nominalDay)
import qualified Data.Time.Format as Time
+import Data.Time.Format.ISO8601 (iso8601Show)
import qualified Data.Set as Set
import Data.Time.Clock.System (systemEpochDay)
+import qualified Data.Csv as Csv
+
+import qualified Data.Char as Char
+
-------------
-- UTCTime --
@@ -44,19 +52,22 @@ localTimeToUTC = TZ.localTimeToUTCFull appTZ
-- | Local midnight of given day
toMidnight :: Day -> UTCTime
-toMidnight d = localTimeToUTCTZ appTZ $ LocalTime d midnight
+toMidnight = toTimeOfDay 0 0 0
--- | Local midnight of given day
+-- | Local midday of given day
toMidday :: Day -> UTCTime
-toMidday d = localTimeToUTCTZ appTZ $ LocalTime d midday
+toMidday = toTimeOfDay 12 0 0
-- | One second before the end of day
beforeMidnight :: Day -> UTCTime
-beforeMidnight d = localTimeToUTCTZ appTZ $ LocalTime d $ TimeOfDay 23 59 59
+beforeMidnight = toTimeOfDay 23 59 59
-- | 6am in the morning
toMorning :: Day -> UTCTime
-toMorning d = localTimeToUTCTZ appTZ $ LocalTime d $ TimeOfDay 6 0 0
+toMorning = toTimeOfDay 6 0 0
+
+toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime
+toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..}
class FormatTime t => HasLocalTime t where
@@ -75,7 +86,7 @@ instance HasLocalTime TimeOfDay where
toLocalTime = LocalTime systemEpochDay
formatTime' :: (HasLocalTime t, MonadHandler m) => String -> t -> m Text
-formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
+formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (utcToZonedTime . localTimeToUTCTZ appTZ $ toLocalTime t)
-- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str
-- Restricted type for safety
@@ -114,33 +125,50 @@ getDateTimeFormat sel = do
validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat
-- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon
-validDateTimeFormats _ SelFormatDateTime = Set.fromList
- [ DateTimeFormat "%a %d %b %Y %R"
- , DateTimeFormat "%a %b %d %Y %R"
- , DateTimeFormat "%A, %d %B %Y %R"
- , DateTimeFormat "%A, %B %d %Y %R"
- , DateTimeFormat "%a %d %b %Y %T"
- , DateTimeFormat "%a %b %d %Y %T"
- , DateTimeFormat "%A, %d %B %Y %T"
- , DateTimeFormat "%A, %B %d %Y %T"
- , DateTimeFormat "%d.%m.%Y %R"
- , DateTimeFormat "%d.%m.%Y %T"
- , DateTimeFormat "%a %d.%m.%y %R"
- , DateTimeFormat "%R %d.%m.%Y"
- , DateTimeFormat "%T %d.%m.%Y"
- , DateTimeFormat "%Y-%m-%d %R"
- , DateTimeFormat "%Y-%m-%d %T"
+validDateTimeFormats tl SelFormatDateTime = Set.fromList $
+ [ DateTimeFormat "%Y-%m-%dT%R"
, DateTimeFormat "%Y-%m-%dT%T"
+ ] ++
+ [ DateTimeFormat $ unwords [firstF, secondF]
+ | DateTimeFormat tFormat <- Set.toList $ validDateTimeFormats tl SelFormatTime
+ , DateTimeFormat dFormat <- Set.toList $ validDateTimeFormats tl SelFormatDate
+ , (firstF, secondF) <- [(tFormat, dFormat), (dFormat, tFormat)]
+ ] ++
+ [ DateTimeFormat $ unwords [dayFmt, timeFmt, yearFmt]
+ | dayFmt <- [ "%a %d %b"
+ , "%a %b %d"
+ , "%A, %d %B"
+ , "%A, %B %d"
+ , "%d.%m"
+ , "%a %d.%m"
+ , "%A %d.%m"
+ ]
+ , timeFmt <- [ "%R"
+ , "%T"
+ ]
+ , yearFmt <- [ "%y", "%Y" ]
]
validDateTimeFormats _ SelFormatDate = Set.fromList
[ DateTimeFormat "%a %d %b %Y"
, DateTimeFormat "%a %b %d %Y"
+ , DateTimeFormat "%d %b %Y"
+ , DateTimeFormat "%b %d %Y"
+ , DateTimeFormat "%d %B %Y"
+ , DateTimeFormat "%B %d %Y"
+ , DateTimeFormat "%d %b %y"
+ , DateTimeFormat "%b %d %y"
+ , DateTimeFormat "%d %B %y"
+ , DateTimeFormat "%B %d %y"
, DateTimeFormat "%A, %d %B %Y"
, DateTimeFormat "%A, %B %d %Y"
+ , DateTimeFormat "%A, %d %b %Y"
+ , DateTimeFormat "%A, %b %d %Y"
, DateTimeFormat "%d.%m.%y"
, DateTimeFormat "%d.%m.%Y"
, DateTimeFormat "%a %d.%m.%y"
, DateTimeFormat "%a %d.%m.%Y"
+ , DateTimeFormat "%A %d.%m.%y"
+ , DateTimeFormat "%A %d.%m.%Y"
, DateTimeFormat "%Y-%m-%d"
, DateTimeFormat "%y-%m-%d"
]
@@ -153,8 +181,13 @@ validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catM
guard $ uncurry (/=) amPm
Just
[ DateTimeFormat "%I:%M %p"
- , DateTimeFormat "%I:%M %P"
, DateTimeFormat "%I:%M:%S %p"
+ ]
+ , do
+ guard $ uncurry (/=) amPm
+ guard $ any (any $ not . Char.isLower) [fst amPm, snd amPm]
+ Just
+ [ DateTimeFormat "%I:%M %P"
, DateTimeFormat "%I:%M:%S %P"
]
]
@@ -270,3 +303,30 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail
formatGregorianW :: Integer -> Int -> Int -> Widget
formatGregorianW year month day = formatTimeW SelFormatDate $ fromGregorian year month day
+
+instance Csv.ToField ZonedTime where
+ toField = Csv.toField . iso8601Show
+
+instance Csv.FromField ZonedTime where
+ parseField = parse <=< Csv.parseField
+ where
+ parse t = asum $ do
+ (doZone, fmt) <- parseFormats
+ return $ do
+ zonedRes <- parseTimeM False defaultTimeLocale fmt t
+ if | doZone -> return zonedRes
+ | otherwise -> do
+ let localRes = zonedTimeToLocalTime zonedRes
+ utcRes = localTimeToUTC localRes
+ LTUUnique{_ltuResult} <- pure utcRes
+ return $ utcToZonedTime _ltuResult
+
+ parseFormats = do
+ date <- ["%Y-%m-%d", "%d.%m.%Y"]
+ sep <- ["T", " "]
+ doZone <- [True, False]
+ let zone = bool "" "%z" doZone
+ time <- ["%H:%M:%S", "%H:%M", ""]
+
+ return . (doZone, ) $ date <> sep <> time <> zone
+
diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs
index cac40a135..8ba5f5584 100644
--- a/src/Handler/Utils/Exam.hs
+++ b/src/Handler/Utils/Exam.hs
@@ -5,13 +5,14 @@ module Handler.Utils.Exam
, fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
, examBonus, examBonusPossible, examBonusAchieved
, examResultBonus, examGrade
+ , getRelevantSheetsUpTo, examBonusGrade
, ExamAutoOccurrenceConfig
, eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
, _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
, examAutoOccurrence
) where
-import Import.NoFoundation
+import Import
import Database.Persist.Sql (SqlBackendCanRead)
import qualified Database.Esqueleto as E
@@ -114,16 +115,41 @@ examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary ->
examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap
examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap
+getRelevantSheetsUpTo :: CourseId
+ -> UserId
+ -> Maybe UTCTime
+ -> DB (Map SheetId (SheetType, Maybe Points))
+getRelevantSheetsUpTo cid uid mCutoff
+ = fmap postprocess . E.select . E.from $ \(sheet `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ sheet E.^. SheetId ] $ do
+ E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId)
+ E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
+ E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId
+ )
+ E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+ case mCutoff of
+ Just cutoff -> E.where_ $ E.maybe E.true (E.<=. E.val cutoff) (sheet E.^. SheetActiveTo)
+ E.&&. E.maybe E.false (E.<=. E.val cutoff) (sheet E.^. SheetVisibleFrom)
+ Nothing -> E.where_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
+ return (sheet E.^. SheetId, sheet E.^. SheetType, submission)
+ where
+ postprocess :: [(E.Value SheetId, E.Value SheetType, Maybe (Entity Submission))]
+ -> Map SheetId (SheetType, Maybe Points)
+ postprocess = Map.fromList . map postprocess'
+ where postprocess' (E.Value sId, E.Value sType, fmap entityVal -> sub)
+ = (sId, ) . (sType, ) $ assertM submissionRatingDone sub >>= submissionRatingPoints
+
+
+
examResultBonus :: ExamBonusRule
-> SheetGradeSummary -- ^ `examBonusPossible`
-> SheetGradeSummary -- ^ `examBonusAchieved`
- -> Points
+ -> Maybe Points
examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of
ExamBonusManual{}
- -> 0
+ -> Nothing
ExamBonusPoints{..}
- -> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp
+ -> Just . roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp
where
bonusProp :: Rational
bonusProp
@@ -190,6 +216,27 @@ examGrade Exam{..} mBonus (otoList -> results)
lowerBounds :: [(ExamGrade, Points)]
lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'
+examBonusGrade :: ( MonoFoldable sheets
+ , Element sheets ~ (SheetType, Maybe Points)
+ , MonoFoldable results
+ , Element results ~ ExamResultPoints
+ )
+ => Exam
+ -> Either Points sheets -- ^ `Points` retrieved from relevant `ExamBonus`, iff it exists
+ -> results
+ -> (Maybe Points, Maybe ExamResultGrade)
+examBonusGrade exam@Exam{..} bonusInp = (mBonus, ) . examGrade exam mBonus
+ where mBonus = asum
+ [ bonusInp ^? _Left
+ , join $ examResultBonus <$> examBonusRule <*> bonusPossible <*> bonusAchieved
+ ]
+ sheetSummary = flip (previews _Right) bonusInp . ofoldMap $ uncurry sheetTypeSum
+ bonusPossible = normalSummary <$> sheetSummary
+ bonusAchieved = (<>) <$> fmap normalSummary sheetSummary <*> fmap bonusSummary sheetSummary
+
+
+
+
data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig
{ eaocMinimizeRooms :: Bool
, eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms
diff --git a/src/Handler/Utils/ExternalExam/Users.hs b/src/Handler/Utils/ExternalExam/Users.hs
index 9f0a022ed..0df3df9e9 100644
--- a/src/Handler/Utils/ExternalExam/Users.hs
+++ b/src/Handler/Utils/ExternalExam/Users.hs
@@ -26,6 +26,8 @@ import qualified Data.Text.Lens as Text
import qualified Data.Conduit.List as C
+import Data.List (cycle)
+
data ExternalExamUserMode = EEUMUsers | EEUMGrades
deriving (Eq, Ord, Read, Show, Bounded, Enum, Generic, Typeable)
@@ -70,7 +72,7 @@ data ExternalExamUserTableCsv = ExternalExamUserTableCsv
, csvEUserFirstName :: Maybe Text
, csvEUserName :: Maybe Text
, csvEUserMatriculation :: Maybe Text
- , csvEUserOccurrenceStart :: ZonedTime
+ , csvEUserOccurrenceStart :: Maybe ZonedTime
, csvEUserExamResult :: ExamResultPassedGrade
} deriving (Generic)
makeLenses_ ''ExternalExamUserTableCsv
@@ -91,7 +93,7 @@ instance FromNamedRecord ExternalExamUserTableCsv where
<*> csv .:?? "first-name"
<*> csv .:?? "name"
<*> csv .:?? "matriculation"
- <*> csv .: "occurrence-start"
+ <*> csv .:?? "occurrence-start"
<*> csv .: "exam-result"
@@ -129,6 +131,7 @@ newtype ExternalExamUserCsvExportDataGrades = ExternalExamUserCsvExportDataGrade
data ExamUserCsvException
= ExamUserCsvExceptionNoMatchingUser
+ | ExamUserCsvExceptionNoOccurrenceTime
deriving (Show, Generic, Typeable)
instance Exception ExamUserCsvException
@@ -182,6 +185,8 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
csvName <- getMessageRender <*> pure (MsgExternalExamUserCsvName tid ssh coursen examn)
isLecturer <- hasReadAccessTo $ EExamR tid ssh coursen examn EEUsersR
currentRoute <- fromMaybe (error "makeExternalExamUsersTable called from 404-handler") <$> getCurrentRoute
+ MsgRenderer mr <- getMsgRenderer
+ exampleTime <- over _utctDayTime (fromInteger . round . toRational) <$> liftIO getCurrentTime
let
dbtSQLQuery = runReaderT $ do
@@ -200,16 +205,16 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
return (result, user, isSynced)
dbtRowKey = views queryResult (E.^. ExternalExamResultId)
- dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) ExternalExamUserTableData
+ dbtProj :: DBRow _ -> DB ExternalExamUserTableData
dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
(,,,)
<$> view _1 <*> view _2 <*> view (_3 . _Value)
<*> getSynchronised
where
- getSynchronised :: ReaderT _ (MaybeT (YesodDB UniWorX)) [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
+ getSynchronised :: ReaderT _ DB [(UserDisplayName, UserSurname, UTCTime, Set SchoolShorthand)]
getSynchronised = do
resId <- view $ _1 . _entityKey
- syncs <- lift . lift . E.select . E.from $ \(examOfficeExternalResultSynced `E.InnerJoin` user) -> do
+ syncs <- lift . E.select . E.from $ \(examOfficeExternalResultSynced `E.InnerJoin` user) -> do
E.on $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. user E.^. UserId
E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedResult E.==. E.val resId
return ( examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice
@@ -344,8 +349,46 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
, dbtCsvName = unpack csvName
, dbtCsvNoExportData = Nothing
, dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: ExternalExamUserTableCsv)
+ , dbtCsvExampleData = Nothing
}
- EEUMUsers -> simpleCsvEncode csvName encodeCsv'
+ EEUMUsers ->
+ let baseEncode = simpleCsvEncode csvName encodeCsv'
+ in baseEncode <&> \enc -> enc
+ { dbtCsvExampleData = Just
+ [ ExternalExamUserTableCsv{..}
+ | (csvEUserSurname, csvEUserFirstName, csvEUserName, csvEUserMatriculation) <-
+ [ ( Just $ mr MsgExampleUser1Surname
+ , Just $ mr MsgExampleUser1FirstName
+ , Just $ mr MsgExampleUser1DisplayName
+ , Just "12345678"
+ )
+ , ( Nothing
+ , Nothing
+ , Nothing
+ , Just "87654321"
+ )
+ , ( Nothing
+ , Nothing
+ , Just $ mr MsgExampleUser2DisplayName
+ , Nothing
+ )
+ , ( Just $ mr MsgExampleUser3Surname
+ , Nothing
+ , Nothing
+ , Nothing
+ )
+ ]
+ | csvEUserOccurrenceStart <- catMaybes $
+ guardOn (is _Just externalExamDefaultTime) Nothing
+ : repeat (Just . Just $ utcToZonedTime exampleTime)
+ | csvEUserExamResult <- cycle . catMaybes $
+ [ guardOn (hasExamGradingPass externalExamGradingMode) $ ExamAttended (Left $ ExamPassed True)
+ , guardOn (hasExamGradingGrades externalExamGradingMode) $ ExamAttended (Right Grade50)
+ , pure ExamVoided
+ , pure ExamNoShow
+ ]
+ ]
+ }
where
encodeCsv' :: ExternalExamUserTableData -> ExternalExamUserTableCsv
encodeCsv' row = ExternalExamUserTableCsv
@@ -353,7 +396,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
, csvEUserFirstName = row ^? resultUser . _entityVal . _userFirstName
, csvEUserName = row ^? resultUser . _entityVal . _userDisplayName
, csvEUserMatriculation = row ^? resultUser . _entityVal . _userMatrikelnummer . _Just
- , csvEUserOccurrenceStart = row ^. resultResult . _entityVal . _externalExamResultTime . to utcToZonedTime
+ , csvEUserOccurrenceStart = row ^? resultResult . _entityVal . _externalExamResultTime . to utcToZonedTime
, csvEUserExamResult = row ^. resultResult . _entityVal . _externalExamResultResult
}
dbtCsvDecode
@@ -369,11 +412,13 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
pid <- lift $ guessUser' dbCsvNew
let ExternalExamUserTableCsv{..} = dbCsvNew
- yield $ ExternalExamUserCsvRegisterData pid (zonedTimeToUTC csvEUserOccurrenceStart) csvEUserExamResult
+ occTime <- maybe (throwM ExamUserCsvExceptionNoOccurrenceTime) return $ fmap zonedTimeToUTC csvEUserOccurrenceStart <|> externalExamDefaultTime
+ yield $ ExternalExamUserCsvRegisterData pid occTime csvEUserExamResult
DBCsvDiffExisting{..} -> do
let ExternalExamUserTableCsv{..} = dbCsvNew
- when (zonedTimeToUTC csvEUserOccurrenceStart /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultTime) $
- yield $ ExternalExamUserCsvSetTimeData (E.unValue dbCsvOldKey) (zonedTimeToUTC csvEUserOccurrenceStart)
+ whenIsJust (zonedTimeToUTC <$> csvEUserOccurrenceStart) $ \occTime ->
+ when (occTime /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultTime) $
+ yield $ ExternalExamUserCsvSetTimeData (E.unValue dbCsvOldKey) occTime
when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult) $
yield $ ExternalExamUserCsvSetResultData (E.unValue dbCsvOldKey) csvEUserExamResult
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index fb68b9105..c9e0a314c 100644
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@@ -16,6 +16,8 @@ import Handler.Utils.DateTime
import Handler.Utils.Widgets
+import Handler.Utils.I18n
+
import Import
import Data.Char (chr, ord)
import qualified Data.Char as Char
@@ -35,10 +37,11 @@ import qualified Database.Esqueleto.Utils as E
import qualified Data.Set as Set
-import Data.Map ((!))
+import Data.Map ((!), (!?))
import qualified Data.Map as Map
-import Control.Monad.Trans.Except (throwE, runExceptT)
+import qualified Data.HashMap.Lazy as HashMap
+
import Control.Monad.Writer.Class
import Control.Monad.Error.Class (MonadError(..))
@@ -47,8 +50,6 @@ import Data.Aeson.Text (encodeToLazyText)
import qualified Text.Email.Validate as Email
-import Yesod.Core.Types (FileInfo(..))
-
import Data.Text.Lens (unpacked)
import Data.Char (isDigit)
@@ -56,6 +57,12 @@ import Text.Blaze (toMarkup)
import Handler.Utils.Form.MassInput
+import qualified Data.Binary as Binary
+import qualified Data.ByteString.Base64.URL as Base64
+
+import Data.Time.Clock.System (systemEpochDay)
+
+
----------------------------
-- Buttons (new version ) --
----------------------------
@@ -240,6 +247,34 @@ multiAction' :: forall action a.
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiAction' minp acts = multiActionOpts' minp acts (optionsF $ Map.keysSet acts)
+multiActionField :: forall action a.
+ Ord action
+ => (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
+ -> Map action (AForm Handler a)
+ -> (Field Handler action, action -> Maybe Text, action -> Maybe (SomeMessage UniWorX))
+ -> FieldSettings UniWorX
+ -> Maybe action
+ -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
+multiActionField minp acts (actField, actExternal, actMessage) fs@FieldSettings{..} defAction csrf = do
+ (actionRes, actionView) <- minp (checkBool (`Map.member` acts) MsgMultiActionUnknownAction actField) fs defAction
+ results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
+
+ MsgRenderer mr <- getMsgRenderer
+ let actionResults = view _1 <$> results
+
+ actionViews = Map.foldrWithKey accViews [] results
+
+ accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
+ accViews act
+ | Just optionExternalValue <- actExternal act
+ , Just (mr -> optionDisplay) <- actMessage act
+ = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
+ | otherwise
+ = flip const
+
+ return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
+
+
multiActionOpts' :: forall action a.
Ord action
=> (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
@@ -255,22 +290,12 @@ multiActionOpts' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do
, olReadExternal = assertM (flip Map.member acts) . olReadExternal actsOpts
}
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts
-
- (actionRes, actionView) <- minp (selectField $ return actsOpts') fs defAction
- results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts'
- let actionResults = view _1 <$> results
-
- actionViews = Map.foldrWithKey accViews [] results
+ actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
+ actExternal = fmap optionExternalValue . actOption
+ actMessage = fmap (SomeMessage . optionDisplay) . actOption
- accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
- accViews act
- | Option{..} : _ <- filter ((== act) . optionInternalValue) $ olOptions actsOpts'
- = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
- | otherwise
- = flip const
-
- return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
+ multiActionField minp acts' (selectField $ return actsOpts', actExternal, actMessage) fs defAction csrf
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action)
=> Map action (AForm Handler a)
@@ -317,6 +342,88 @@ multiActionMOpts :: Ord action
-> (Html -> MForm Handler (FormResult a, Widget))
multiActionMOpts acts opts fSettings defAction = renderAForm FormStandard $ multiActionAOpts acts opts fSettings defAction
+-------------------------
+-- Explained selection --
+-------------------------
+
+explainedSelectionField :: forall m a.
+ ( MonadHandler m
+ , HandlerSite m ~ UniWorX
+ , Eq a
+ )
+ => Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for none option
+ -> Handler ([(Option a, Maybe Widget)], Text -> Maybe a)
+ -> Field m a
+explainedSelectionField optMsg' mkOpts = Field{..}
+ where
+ fieldEnctype = UrlEncoded
+ fieldParse ts _ = do
+ (_, parser) <- liftHandler mkOpts
+ if
+ | t : _ <- ts
+ , Just t' <- parser t
+ -> return . Right $ Just t'
+ | t : _ <- ts
+ , null t
+ -> return $ Right Nothing
+ | t : _ <- ts
+ -> return . Left . SomeMessage $ MsgInvalidEntry t
+ | otherwise
+ -> return $ Right Nothing
+ fieldView theId name attrs val isReq = do
+ (opts, _) <- liftHandler mkOpts
+ let optMsg = guardOnM (not isReq) optMsg'
+ inputId optExternal = [st|#{theId}__input--#{optExternal}|]
+ matchesVal Nothing = is _Left val
+ matchesVal (Just x) = val == Right x
+ $(widgetFile "widgets/explained-selection-field")
+
+explainOptionList :: forall a.
+ Handler (OptionList a)
+ -> (a -> MaybeT Handler Widget)
+ -> Handler ([(Option a, Maybe Widget)], Text -> Maybe a)
+explainOptionList ol mkExplanation = do
+ OptionList{..} <- ol
+ olOptions' <- forM olOptions $ \opt@Option{..} -> (opt, ) <$> runMaybeT (mkExplanation optionInternalValue)
+ return (olOptions', olReadExternal)
+
+explainedMultiAction' :: forall action a.
+ Ord action
+ => (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
+ -> Map action (AForm Handler a)
+ -> Handler ([(Option action, Maybe Widget)], Text -> Maybe action)
+ -> FieldSettings UniWorX
+ -> Maybe action
+ -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
+explainedMultiAction' minp acts mActsOpts fs@FieldSettings{..} defAction csrf = do
+ (actsOpts, actsReadExternal) <- liftHandler mActsOpts
+ let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts
+ actsReadExternal' = assertM (flip Map.member acts) . actsReadExternal
+ acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue . view _1) actsOpts') acts
+
+ actOption act = listToMaybe . filter (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
+ actExternal = fmap optionExternalValue . actOption
+ actMessage = fmap (SomeMessage . optionDisplay) . actOption
+
+ multiActionField minp acts' (explainedSelectionField Nothing $ return (actsOpts', actsReadExternal'), actExternal, actMessage) fs defAction csrf
+
+explainedMultiAction :: forall action a.
+ Ord action
+ => Map action (AForm Handler a)
+ -> Handler ([(Option action, Maybe Widget)], Text -> Maybe action)
+ -> FieldSettings UniWorX
+ -> Maybe action
+ -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
+explainedMultiAction = explainedMultiAction' mpopt
+
+explainedMultiActionA :: forall action a.
+ Ord action
+ => Map action (AForm Handler a)
+ -> Handler ([(Option action, Maybe Widget)], Text -> Maybe action)
+ -> FieldSettings UniWorX
+ -> Maybe action
+ -> AForm Handler a
+explainedMultiActionA acts mActsOpts fSettings defAction = formToAForm $ explainedMultiAction acts mActsOpts fSettings defAction mempty
------------
-- Fields --
@@ -556,7 +663,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
-submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
+submissionModeForm prev = explainedMultiActionA actions opts (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
where
actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
actions = Map.fromList
@@ -574,6 +681,12 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c
)
]
+ opts = explainOptionList optionsFinite $ \case
+ SubmissionModeNone -> mzero
+ SubmissionModeCorrector -> return $(i18nWidgetFile "submission-mode-explanation/corrector")
+ SubmissionModeUser -> return $(i18nWidgetFile "submission-mode-explanation/user")
+ SubmissionModeBoth -> return $ i18n MsgBothSubmissionsTip
+
data ExamBonusRule' = ExamBonusManual'
| ExamBonusPoints'
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@@ -717,42 +830,258 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp
type FileUploads = ConduitT () (Either FileId File) Handler ()
-
-specificFileField :: UploadSpecificFile -> Field Handler FileUploads
-specificFileField UploadSpecificFile{..} = Field{..}
+uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT (Either FileId File) ByteString m ()
+uploadContents = C.mapMaybeM $ either dbContents (return . fileContent)
+ where dbContents = fmap (fileContent =<<) . liftHandler . runDB . get
+
+data FileFieldUserOption a = FileFieldUserOption
+ { fieldOptionForce :: Bool
+ , fieldOptionDefault :: a
+ } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+data FileField = FileField
+ { fieldIdent :: Maybe Text
+ , fieldUnpackZips :: FileFieldUserOption Bool
+ , fieldMultiple :: Bool
+ , fieldRestrictExtensions :: Maybe (NonNull (Set Extension))
+ , fieldAdditionalFiles :: Map FileId (FileFieldUserOption Bool)
+ } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+genericFileField :: forall m.
+ ( MonadHandler m
+ , HandlerSite m ~ UniWorX
+ )
+ => Handler FileField -> Field m FileUploads
+genericFileField mkOpts = Field{..}
where
+ permittedExtension :: FileField -> FileName -> Bool
+ permittedExtension FileField{..} fTitle
+ | Just exts <- fieldRestrictExtensions
+ = anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fTitle) exts
+ | otherwise
+ = True
+
+ getIdent :: forall m'. (MonadHandler m', RenderRoute (HandlerSite m')) => FileField -> m' (Maybe Text)
+ getIdent FileField{..} = do
+ ident <- case fieldIdent of
+ Just ident -> return $ Just ident
+ Nothing -> runMaybeT $ do
+ cRoute <- MaybeT getCurrentRoute
+ pos <- newIdent
+ $logDebugS "genericFileField.getIdent" pos
+ return $ hash (cRoute, pos)
+ & toStrict . Binary.encode
+ & decodeUtf8 . Base64.encode
+ & Text.dropWhileEnd (== '=')
+ $logDebugS "genericFileField.getIdent" $ tshow ident
+ return ident
+
+ getPermittedFiles :: Maybe Text -> FileField -> DB (Map FileId (FileFieldUserOption Bool))
+ getPermittedFiles mIdent opts@FileField{..} = do
+ sessionFiles <- fmap fold . for mIdent $ \fieldIdent' ->
+ fold . (HashMap.lookup fieldIdent' . unMergeHashMap =<<) <$> lookupSessionJson @_ @(MergeHashMap Text (Set SessionFileId)) @_ SessionFiles
+ sessionFiles' <- flip foldMapM sessionFiles $ \sfId -> maybeT (return Map.empty) $ do
+ SessionFile{..} <- MaybeT $ get sfId
+ when (is _Just fieldRestrictExtensions) $ do
+ (fTitle, isDirectory) <- MaybeT . fmap (getFirst . foldMap (First . Just . $(E.unValueN 2))) . E.select . E.from $ \file -> do
+ E.where_ $ file E.^. FileId E.==. E.val sessionFileFile
+ return $ (file E.^. FileTitle, E.isNothing $ file E.^. FileContent)
+ guard $ isDirectory || permittedExtension opts (pack fTitle)
+ return . Map.singleton sessionFileFile $ FileFieldUserOption False True
+ $logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles
+ $logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles'
+ return $ fieldAdditionalFiles <> sessionFiles'
+
+ handleUpload :: Maybe Text -> File -> DB (Maybe FileId)
+ handleUpload mIdent file = do
+ for mIdent $ \ident -> do
+ now <- liftIO getCurrentTime
+ oldSFIds <- fmap (Set.fromList . map E.unValue) . E.select . E.from $ \sessionFile -> do
+ E.where_ $ E.subSelectForeign sessionFile SessionFileFile (E.^. FileTitle) E.==. E.val (fileTitle file)
+ E.&&. sessionFile E.^. SessionFileTouched E.<=. E.val now
+ return $ sessionFile E.^. SessionFileId
+ fId <- insert file
+ sfId <- insert $ SessionFile fId now
+ modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
+ Just . MergeHashMap $ HashMap.insert ident (Set.insert sfId . maybe Set.empty (`Set.difference` oldSFIds) $ HashMap.lookup ident old) old
+ return fId
+
fieldEnctype = Multipart
- fieldParse _ files
- | [f] <- files
- = return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName) .| C.map Right
- | null files = return $ Right Nothing
- | otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
- fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/specificFileField")
+ fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads))
+ fieldParse vals files = do
+ opts@FileField{..} <- liftHandler mkOpts
- extensions = fileNameExtensions specificFileName
- acceptRestricted = not $ null extensions
- accept = Text.intercalate "," . map ("." <>) $ extensions
+ mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
+ fmap First . runMaybeT . exceptTMaybe $ encodedSecretBoxOpen v
+ let
+ decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
+ decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
+
+ let uploadedFilenames = fileName <$> bool (take 1) id fieldMultiple files
+
+ let
+ doUnpack
+ | fieldOptionForce fieldUnpackZips = fieldOptionDefault fieldUnpackZips
+ | otherwise = unpackZips `elem` vals
+ handleFile :: FileInfo -> ConduitT () File Handler ()
+ handleFile
+ | doUnpack = sourceFiles
+ | otherwise = yieldM . acceptFile
+
+ if | invExt : _ <- filter (not . permittedExtension opts) uploadedFilenames
+ -> do
+ liftHandler . runDB . runConduit $
+ mapM_ (transPipe lift . handleFile) files
+ .| C.mapM_ (void . handleUpload mIdent)
+ return . Left . SomeMessage . MsgGenericFileFieldInvalidExtension $ unpack invExt
+ | otherwise
+ -> do
+ let fSrc = do
+ permittedFiles <- liftHandler . runDB $ getPermittedFiles mIdent opts
+ yieldMany [ Left fId
+ | (fId, FileFieldUserOption{..}) <- Map.toList permittedFiles
+ , fieldOptionForce, fieldOptionDefault
+ ]
+ yieldMany vals
+ .| C.mapMaybe fromPathPiece
+ .| C.mapMaybeM (\enc -> fmap (, enc) <$> decrypt' enc)
+ .| C.filter (\(fId, _) -> maybe False (not . fieldOptionForce) $ Map.lookup fId permittedFiles)
+ .| C.filter (\(_, enc) -> fieldMultiple
+ || ( (bool (\n h -> [n] == h) elem fieldMultiple) enc (mapMaybe fromPathPiece vals)
+ && null files
+ )
+ )
+ .| C.map (\(fId, _) -> Left fId)
+ mapM_ handleFile (bool (take 1) id fieldMultiple files) .| C.map Right
+ (unsealConduitT -> fSrc', length -> nFiles) <- liftHandler $ fSrc $$+ peekN 2
+ $logDebugS "genericFileField.fieldParse" $ tshow nFiles
+ if
+ | nFiles <= 0 -> return $ Right Nothing
+ | nFiles <= 1 -> return . Right $ Just fSrc'
+ | not fieldMultiple -> do
+ liftHandler . runDB . runConduit $
+ mapM_ (transPipe lift . handleFile) files
+ .| C.mapM_ (void . handleUpload mIdent)
+ return . Left $ SomeMessage MsgOnlyUploadOneFile
+ | otherwise -> return . Right $ Just fSrc'
+
+ fieldView :: FieldViewFunc m FileUploads
+ fieldView fieldId fieldName _attrs val req = do
+ opts@FileField{..} <- liftHandler mkOpts
+ mIdent <- getIdent opts
+ identSecret <- for mIdent $ encodedSecretBox SecretBoxShort
+
+ fileInfos <- liftHandler . runDB $ do
+ (uploads, references) <- runWriterT . for val $ \src -> do
+ fmap Set.fromList . sourceToList
+ $ transPipe (lift . lift) src
+ .| C.mapMaybeM (either (\fId -> Nothing <$ tell (Set.singleton fId)) $ lift . handleUpload mIdent)
+
+ permittedFiles <- getPermittedFiles mIdent opts
+
+ let
+ sentVals :: Either Text (Set FileId)
+ sentVals = uploads <&> Set.union (references `Set.intersection` Map.keysSet permittedFiles)
+
+ let
+ toFUI (E.Value fuiId', E.Value fuiTitle) = do
+ fuiId <- encrypt fuiId'
+ let fuiHtmlId = [st|#{fieldId}--#{toPathPiece fuiId}|]
+ fuiChecked
+ | Right sentVals' <- sentVals
+ = fuiId' `Set.member` sentVals'
+ | Just FileFieldUserOption{..} <- Map.lookup fuiId' fieldAdditionalFiles
+ = fieldOptionDefault
+ | otherwise = False
+ fuiSession = fuiId' `Map.notMember` fieldAdditionalFiles
+ fuiForced
+ | Just FileFieldUserOption{..} <- Map.lookup fuiId' permittedFiles
+ = fieldOptionForce
+ | otherwise
+ = False
+ return FileUploadInfo{..}
+ fileInfos' <- mapM toFUI <=< E.select . E.from $ \file -> do
+ E.where_ $ file E.^. FileId `E.in_` E.valList (Set.toList $ fold sentVals <> Map.keysSet permittedFiles)
+ E.orderBy [E.asc $ file E.^. FileTitle]
+ return (file E.^. FileId, file E.^. FileTitle)
+
+ return $ sortOn (splitPath . fuiTitle) fileInfos'
+
+ let
+ mayUnpack = not (fieldOptionForce fieldUnpackZips) || fieldOptionDefault fieldUnpackZips
+
+ zipExtensions = mimeExtensions typeZip
+
+ acceptRestricted = isJust fieldRestrictExtensions
+ accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) mayUnpack ++ toListOf (_Just . re _nullable . folded) fieldRestrictExtensions
+
+ uploadOnlySessionMessage <- messageIconI Warning IconFileUploadSession MsgFileUploadOnlySessionTip
+
+ $(widgetFile "widgets/genericFileField")
+ unpackZips :: Text
+ unpackZips = "unpack-zip"
+
+
+
+fileFieldMultiple :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads
+fileFieldMultiple = genericFileField $ return FileField
+ { fieldIdent = Nothing
+ , fieldUnpackZips = FileFieldUserOption True False
+ , fieldMultiple = True
+ , fieldRestrictExtensions = Nothing
+ , fieldAdditionalFiles = Map.empty
+ }
+
+fileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads
+fileField = genericFileField $ return FileField
+ { fieldIdent = Nothing
+ , fieldUnpackZips = FileFieldUserOption True False
+ , fieldMultiple = False
+ , fieldRestrictExtensions = Nothing
+ , fieldAdditionalFiles = Map.empty
+ }
+
+specificFileField :: UploadSpecificFile -> Field Handler FileUploads
+specificFileField UploadSpecificFile{..} = convertField fixupFileTitles id . genericFileField $ return FileField
+ { fieldIdent = Nothing
+ , fieldUnpackZips = FileFieldUserOption True False
+ , fieldMultiple = False
+ , fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName
+ , fieldAdditionalFiles = Map.empty
+ }
+ where
+ fixupFileTitles = flip (.|) . C.mapM $ either (fmap Left . updateFileReference) (fmap Right . updateFile)
+ where updateFileReference fId = runDB . maybeT (return fId) $ do
+ oldTitle <- MaybeT . fmap (getFirst . foldMap (First . Just)) . E.select . E.from $ \file -> do
+ E.where_ $ file E.^. FileId E.==. E.val fId
+ return $ file E.^. FileTitle
+ if | oldTitle == E.Value (unpack specificFileName)
+ -> return fId
+ | otherwise -> lift $ do
+ fId' <- insert $ File (unpack specificFileName) Nothing (toMidnight systemEpochDay) {- temporary -}
+ E.update $ \file' -> do
+ let newModified = E.subSelect . E.from $ \file -> do
+ E.where_ $ file E.^. FileId E.==. E.val fId
+ return $ file E.^. FileModified
+ newContent = E.subSelect . E.from $ \file -> do
+ E.where_ $ file E.^. FileId E.==. E.val fId
+ return $ file E.^. FileContent
+ E.set file' [ FileModified E.=. E.maybe (E.val $ toMidnight systemEpochDay) id newModified, FileContent E.=. E.joinV newContent ]
+ return fId'
+ updateFile = return . set _fileTitle (unpack specificFileName)
zipFileField :: Bool -- ^ Unpack zips?
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
-> Field Handler FileUploads
-zipFileField doUnpack permittedExtensions = Field{..}
- where
- fieldEnctype = Multipart
- fieldParse _ files
- | [f@FileInfo{..}] <- files
- , maybe True (anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fileName)) permittedExtensions || doUnpack
- = return . Right . Just $ bool (yieldM . fmap Right . acceptFile) ((.| C.map Right) . sourceFiles) doUnpack f
- | null files = return $ Right Nothing
- | otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
- fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")
-
- zipExtensions = mimeExtensions typeZip
-
- acceptRestricted = isJust permittedExtensions
- accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions
+zipFileField doUnpack permittedExtensions = genericFileField $ return FileField
+ { fieldIdent = Nothing
+ , fieldUnpackZips = FileFieldUserOption True doUnpack
+ , fieldMultiple = doUnpack
+ , fieldRestrictExtensions = permittedExtensions
+ , fieldAdditionalFiles = Map.empty
+ }
fileUploadForm :: Bool -- ^ Required?
-> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny`
@@ -780,53 +1109,14 @@ multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .|
multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference
-> Field Handler FileUploads
-multiFileField permittedFiles' = Field{..}
- where
- fieldEnctype = Multipart
- fieldParse vals files = return . Right . Just $ do
- pVals <- lift permittedFiles'
- let
- decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
- decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
- yieldMany vals
- .| C.filter (/= unpackZips)
- .| C.map fromPathPiece .| C.catMaybes
- .| C.mapMaybeM decrypt'
- .| C.filter (`elem` pVals)
- .| C.map Left
- let
- handleFile :: FileInfo -> ConduitT () File Handler ()
- handleFile
- | doUnpack = sourceFiles
- | otherwise = yieldM . acceptFile
- mapM_ handleFile files .| C.map Right
- where
- doUnpack = unpackZips `elem` vals
- fieldView fieldId fieldName _attrs val req = do
- pVals <- handlerToWidget permittedFiles'
- sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts
- let
- toFUI (E.Value fuiId', E.Value fuiTitle) = do
- fuiId <- encrypt fuiId'
- fuiHtmlId <- newIdent
- let fuiChecked
- | Right sentVals' <- sentVals = fuiId' `elem` sentVals'
- | otherwise = True
- return FileUploadInfo{..}
- autoUnzipInfo :: Widget
- autoUnzipInfo = i18n MsgAutoUnzipInfo
- fileInfos' <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
- E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
- E.orderBy [E.asc $ file E.^. FileTitle]
- return (file E.^. FileId, file E.^. FileTitle)
- let fileInfos = sortOn fuiTitle fileInfos'
- $(widgetFile "widgets/multiFileField")
- unpackZips :: Text
- unpackZips = "unpack-zip"
- takeLefts :: Monad m => ConduitT (Either b a) b m ()
- takeLefts = awaitForever $ \case
- Right _ -> return ()
- Left r -> yield r
+multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted
+ where mkField permitted = FileField
+ { fieldIdent = Nothing
+ , fieldUnpackZips = FileFieldUserOption False False
+ , fieldMultiple = True
+ , fieldRestrictExtensions = Nothing
+ , fieldAdditionalFiles = Map.fromSet (const $ FileFieldUserOption False True) permitted
+ }
data SheetGrading' = Points' | PassPoints' | PassBinary'
deriving (Eq, Ord, Read, Show, Enum, Bounded)
@@ -848,7 +1138,7 @@ nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)
-data SheetGroup' = NoGroups' | Arbitrary' | RegisteredGroups'
+data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance Universe SheetGroup'
@@ -876,9 +1166,9 @@ sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> tem
sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
-sheetTypeAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
+sheetTypeAFormReq fs template = explainedMultiActionA acts opts fs (classify' <$> template)
where
- selOptions = Map.fromList
+ acts = Map.fromList
[ ( Normal', Normal <$> gradingReq )
, ( Bonus' , Bonus <$> gradingReq )
, ( Informational', Informational <$> gradingReq )
@@ -887,6 +1177,12 @@ sheetTypeAFormReq fs template = multiActionA selOptions fs (classify' <$> templa
gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
& setTooltip MsgSheetGradingInfo) (template >>= preview _grading)
+ opts = explainOptionList optionsFinite $ \case
+ Normal' -> return $ i18n MsgSheetTypeInfoNormalLecturer
+ Bonus' -> return $ i18n MsgSheetTypeInfoBonus
+ Informational' -> return $ i18n MsgSheetTypeInfoInformational
+ NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded
+
classify' :: SheetType -> SheetType'
classify' = \case
Bonus {} -> Bonus'
@@ -895,15 +1191,19 @@ sheetTypeAFormReq fs template = multiActionA selOptions fs (classify' <$> templa
NotGraded -> NotGraded'
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
-sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
+sheetGroupAFormReq fs template = explainedMultiActionA acts opts fs (classify' <$> template)
where
- selOptions = Map.fromList
+ acts = Map.fromList
[ ( Arbitrary', Arbitrary
<$> apreq (natFieldI MsgGroupSizeNotNatural) (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
)
, ( RegisteredGroups', pure RegisteredGroups )
, ( NoGroups', pure NoGroups )
]
+ opts = explainOptionList optionsFinite $ \case
+ Arbitrary' -> return $(i18nWidgetFile "sheet-grouping-explanation/arbitrary")
+ RegisteredGroups' -> return $(i18nWidgetFile "sheet-grouping-explanation/registered")
+ NoGroups' -> mzero
classify' :: SheetGroup -> SheetGroup'
classify' = \case
Arbitrary _ -> Arbitrary'
@@ -994,24 +1294,20 @@ boolField :: ( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Maybe (SomeMessage UniWorX) -> Field m Bool
-boolField mkNone = Field
- { fieldParse = \e _ -> return $ boolParser e
- , fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool")
- , fieldEnctype = UrlEncoded
- }
- where
- boolParser [] = Right Nothing
- boolParser (x:_) = case x of
- "" -> Right Nothing
- "none" -> Right Nothing
- "yes" -> Right $ Just True
- "on" -> Right $ Just True
- "no" -> Right $ Just False
- "true" -> Right $ Just True
- "false" -> Right $ Just False
- t -> Left $ SomeMessage $ MsgInvalidBool t
- showVal = either $ const False
-
+boolField mkNone = radioGroupField mkNone $ do
+ mr <- getMessageRender
+ return OptionList
+ { olOptions = [ Option (mr MsgBoolNo ) False "no"
+ , Option (mr MsgBoolYes) True "yes"
+ ]
+ , olReadExternal = \case
+ "yes" -> Just True
+ "on" -> Just True
+ "no" -> Just False
+ "true" -> Just True
+ "false" -> Just False
+ _other -> Nothing
+ }
@@ -1083,23 +1379,60 @@ optionsPersistCryptoId :: forall site backend a msg.
( YesodPersist site
, PersistQueryRead backend
, HasCryptoUUID (Key a) (HandlerFor site)
+ , KnownSymbol (CryptoIDNamespace UUID (Key a))
, RenderMessage site msg
, YesodPersistBackend site ~ backend
, PersistRecordBackend a backend
+ , PathPiece (Key a)
)
=> [Filter a]
-> [SelectOpt a]
-> (a -> msg)
-> HandlerFor site (OptionList (Entity a))
-optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
- mr <- getMessageRender
- pairs <- runDB $ selectList filts ords
- cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e
- return $ map (\(cId, e@(Entity _key value)) -> Option
- { optionDisplay = mr (toDisplay value)
- , optionInternalValue = e
- , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
- }) cPairs
+optionsPersistCryptoId filts ords toDisplay = do
+ ents <- runDB $ selectList filts ords
+ optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal)
+
+optionsCryptoIdE :: forall site backend a msg.
+ ( YesodPersist site
+ , PersistQueryRead backend, PersistUniqueRead backend
+ , HasCryptoUUID (Key a) (HandlerFor site)
+ , KnownSymbol (CryptoIDNamespace UUID (Key a))
+ , RenderMessage site msg
+ , YesodPersistBackend site ~ backend
+ , PersistRecordBackend a backend
+ , BackendCompatible SqlBackend backend
+ , PathPiece (Key a)
+ )
+ => E.SqlQuery (E.SqlExpr (Entity a))
+ -> (a -> msg)
+ -> HandlerFor site (OptionList (Entity a))
+optionsCryptoIdE query toDisplay = do
+ ents <- runDB $ E.select query
+ optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal)
+
+optionsCryptoIdF :: forall m mono k msg.
+ ( HasCryptoUUID k m
+ , KnownSymbol (CryptoIDNamespace UUID k)
+ , RenderMessage (HandlerSite m) msg
+ , MonoFoldable mono
+ , MonadHandler m
+ , PathPiece k
+ )
+ => mono
+ -> (Element mono -> m k)
+ -> (Element mono -> m msg)
+ -> m (OptionList (Element mono))
+optionsCryptoIdF (otoList -> iVals) toExtVal toMsg
+ = fmap mkOptionList . forM iVals $ \optionInternalValue -> do
+ cID <- encrypt =<< toExtVal optionInternalValue
+ optionDisplay <- getMessageRender <*> toMsg optionInternalValue
+ return Option
+ { optionDisplay
+ , optionExternalValue = toPathPiece (cID :: CryptoUUID k)
+ , optionInternalValue
+ }
+
examOccurrenceField :: ( MonadHandler m
, HandlerSite m ~ UniWorX
@@ -1480,45 +1813,61 @@ csvOptionsForm mPrev = hoistAForm liftHandler $ CsvOptions
<$> csvFormatOptionsForm (fslI MsgCsvFormatOptions & setTooltip MsgCsvOptionsTip) (csvFormat <$> mPrev)
<*> apopt checkBoxField (fslI MsgCsvTimestamp & setTooltip MsgCsvTimestampTip) (csvTimestamp <$> mPrev)
-
-explainedSelectionField :: forall m a.
- ( MonadHandler m
- , HandlerSite m ~ UniWorX
- , Eq a
- )
- => Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for none option
- -> Handler ([(Option a, Maybe Widget)], Text -> Maybe a)
- -> Field m a
-explainedSelectionField optMsg' mkOpts = Field{..}
- where
- fieldEnctype = UrlEncoded
- fieldParse ts _ = do
- (_, parser) <- liftHandler mkOpts
- if
- | t : _ <- ts
- , Just t' <- parser t
- -> return . Right $ Just t'
- | t : _ <- ts
- , null t
- -> return $ Right Nothing
- | t : _ <- ts
- -> return . Left . SomeMessage $ MsgInvalidEntry t
- | otherwise
- -> return $ Right Nothing
- fieldView theId name attrs val isReq = do
- (opts, _) <- liftHandler mkOpts
- let optMsg = guardOnM (not isReq) optMsg'
- inputId optExternal = [st|#{theId}__input--#{optExternal}|]
- matchesVal Nothing = is _Left val
- matchesVal (Just x) = val == Right x
- $(widgetFile "widgets/explained-selection-field")
-
-explainOptionList :: forall a.
- Handler (OptionList a)
- -> (a -> MaybeT Handler Widget)
- -> Handler ([(Option a, Maybe Widget)], Text -> Maybe a)
-explainOptionList ol mkExplanation = do
- OptionList{..} <- ol
- olOptions' <- forM olOptions $ \opt@Option{..} -> (opt, ) <$> runMaybeT (mkExplanation optionInternalValue)
- return (olOptions', olReadExternal)
+courseSelectForm :: forall ident handler.
+ ( PathPiece ident
+ , MonadHandler handler, HandlerSite handler ~ UniWorX
+ , MonadThrow handler
+ )
+ => E.SqlQuery (E.SqlExpr (Entity Course))
+ -> (Entity Course -> Handler Bool)
+ -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+ -> ident
+ -> FieldSettings UniWorX
+ -> Bool
+ -> Maybe (Set CourseId)
+ -> AForm handler (Set CourseId)
+courseSelectForm query coursePred miButtonAction' miIdent' fSettings fRequired mPrev
+ = fmap Set.fromList . massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired $ Set.toList <$> mPrev
+ where
+ query' = do
+ course <- query
+ E.orderBy [ E.desc $ course E.^. CourseTerm
+ , E.asc $ course E.^. CourseSchool
+ , E.asc $ course E.^. CourseName
+ ]
+ return course
+
+ miAdd' nudge btn csrf = do
+ let courseOptions = optionsCryptoIdE query' (\Course{..} -> MsgCourseOption courseTerm courseSchool courseName) >>= fmap (fmap entityKey . mkOptionList) . filterM (coursePred . optionInternalValue) . olOptions
+
+ (courseRes, addView) <- mpopt (hoistField liftHandler $ selectField courseOptions) (fslI MsgCourse & addName (nudge "course")) Nothing
+ let res = courseRes <&> \newCourse oldCourses -> pure (Set.toList $ Set.singleton newCourse `Set.difference` Set.fromList oldCourses)
+ return (res, $(widgetFile "widgets/massinput/courses/add"))
+ miCell' cid = do
+ Course{..} <- liftHandler . runDB $ get404 cid
+ $(widgetFile "widgets/massinput/courses/cell")
+ miLayout' :: MassInputLayout ListLength CourseId ()
+ miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/courses/layout")
+
+labeledCheckBoxView :: Widget
+ -> Text -> Text -> [(Text, Text)] -> Either Text Bool -> Bool -> Widget
+labeledCheckBoxView label theId name attrs val isReq = $(widgetFile "widgets/fields/labeled-checkbox")
+ where
+ checkBoxView = fieldView (checkBoxField :: Field Handler Bool) theId name attrs val isReq
+
+
+newtype CourseParticipantStateIsActive = CourseParticipantStateIsActive { getCourseParticipantStateIsActive :: Bool }
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ deriving newtype (Universe, Finite)
+
+embedRenderMessageVariant ''UniWorX ''CourseParticipantStateIsActive $ \case
+ "True" -> "CourseParticipantStateIsActive"
+ "False" -> "CourseParticipantStateIsInactive"
+ _ -> error "Unexpected constructor for Bool"
+finitePathPiece ''CourseParticipantStateIsActive
+ ["inactive", "active"]
+makeWrapped ''CourseParticipantStateIsActive
+
+courseParticipantStateIsActiveField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (SomeMessage UniWorX) -> Field m Bool
+courseParticipantStateIsActiveField optMsg = hoistField liftHandler . isoField (_Wrapped @CourseParticipantStateIsActive) $ radioGroupField optMsg optionsFinite
diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs
index ef53aeb4d..e612b5fe7 100644
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/src/Handler/Utils/Form/MassInput.hs
@@ -118,13 +118,13 @@ newtype MapLiveliness l1 l2 = MapLiveliness { unMapLiveliness :: Map (BoxCoord l
makeWrapped ''MapLiveliness
-deriving instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2)
-deriving instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2)
-deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2)
-deriving instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2)
-deriving instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2)
-deriving instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2)
-deriving instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2)
+deriving newtype instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2)
+deriving newtype instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2)
+deriving newtype instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2)
+deriving newtype instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2)
+deriving newtype instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2)
+deriving newtype instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2)
+deriving newtype instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2)
instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) where
type BoxCoord (MapLiveliness l1 l2) = (BoxCoord l1, BoxCoord l2)
diff --git a/src/Handler/Utils/Form/Types.hs b/src/Handler/Utils/Form/Types.hs
index 16c8f0af6..9adb7e83c 100644
--- a/src/Handler/Utils/Form/Types.hs
+++ b/src/Handler/Utils/Form/Types.hs
@@ -6,5 +6,5 @@ data FileUploadInfo = FileUploadInfo
{ fuiId :: CryptoUUIDFile
, fuiTitle :: FilePath
, fuiHtmlId :: Text
- , fuiChecked :: Bool
+ , fuiChecked, fuiSession, fuiForced :: Bool
}
diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs
index 2da19bd90..47873d036 100644
--- a/src/Handler/Utils/Invitations.hs
+++ b/src/Handler/Utils/Invitations.hs
@@ -140,7 +140,7 @@ data InvitationConfig junction = forall formCtx. InvitationConfig
-- | Additional configuration needed for an invocation of `bearerToken`
data InvitationTokenConfig = InvitationTokenConfig
- { itAuthority :: Either Value UserId
+ { itAuthority :: HashSet (Either Value UserId)
, itAddAuth :: Maybe AuthDNF
, itExpiresAt :: Maybe (Maybe UTCTime)
, itStartsAt :: Maybe UTCTime
@@ -218,9 +218,9 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
route <- mapReaderT liftHandler $ invitationRoute fEnt dat
InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat
protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
- let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
- jwt <- encodeToken token
- jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
+ let token = protoToken & bearerRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
+ bearer <- encodeBearer token
+ jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece bearer)])
jInvitationSubject <- fmap mr . mapReaderT liftHandler $ invitationSubject fEnt dat
jInvitationExplanation <- (\ihtml -> ihtml (toHtml . mr) ur) <$> mapReaderT liftHandler (invitationExplanation fEnt dat)
@@ -228,7 +228,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
{ invitationEmail = jInvitee
, invitationFor = invRef @junction fid
, invitationData = toJSON $ dat ^. _invitationDBData
- , invitationExpiresAt = tokenExpiresAt token
+ , invitationExpiresAt = bearerExpiresAt token
}
queueDBJob JobInvitation{..}
@@ -362,7 +362,7 @@ invitationR' :: forall junction m.
-> m Html
-- | Generic handler for incoming invitations
invitationR' InvitationConfig{..} = liftHandler $ do
- InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
+ InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentBearerRestrictions :: Handler (InvitationTokenRestriction junction)
invitee <- requireAuthId
cRoute <- fromMaybe (error "invitationR' called from 404-handler") <$> getCurrentRoute
@@ -379,7 +379,7 @@ invitationR' InvitationConfig{..} = liftHandler $ do
iData :: InvitationData junction
iData = review _InvitationData (dbData, itData)
guardAuthResult =<< hoist lift (invitationRestriction fEnt iData)
- ((dataRes, dataWidget), dataEnctype) <- hoist lift . runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
+ ((dataRes, dataWidget), dataEnctype) <- hoist lift . runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
dataRes <- aFormToWForm $ invitationForm fEnt iData invitee
btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction))
case btnRes of
diff --git a/src/Handler/Utils/Memcached.hs b/src/Handler/Utils/Memcached.hs
new file mode 100644
index 000000000..8a9efb46d
--- /dev/null
+++ b/src/Handler/Utils/Memcached.hs
@@ -0,0 +1,565 @@
+module Handler.Utils.Memcached
+ ( memcachedAvailable
+ , memcached, memcachedBy
+ , memcachedHere, memcachedByHere
+ , memcachedSet, memcachedGet
+ , memcachedInvalidate, memcachedByInvalidate
+ , memcachedByGet, memcachedBySet
+ , memcachedTimeout, memcachedTimeoutBy
+ , memcachedTimeoutHere, memcachedTimeoutByHere
+ , memcachedLimited, memcachedLimitedKey, memcachedLimitedBy, memcachedLimitedKeyBy
+ , memcachedLimitedHere, memcachedLimitedKeyHere, memcachedLimitedByHere, memcachedLimitedKeyByHere
+ , memcachedLimitedTimeout, memcachedLimitedKeyTimeout, memcachedLimitedTimeoutBy, memcachedLimitedKeyTimeoutBy
+ , memcachedLimitedTimeoutHere, memcachedLimitedKeyTimeoutHere, memcachedLimitedTimeoutByHere, memcachedLimitedKeyTimeoutByHere
+ , Expiry
+ , MemcachedException(..), AsyncTimeoutException(..)
+ ) where
+
+import Import.NoFoundation hiding (utc, exp)
+import Foundation.Type
+
+
+import qualified Database.Memcached.Binary.IO as Memcached
+import Data.Bits (Bits(zeroBits), toIntegralSized)
+
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)
+
+import qualified Data.Binary as Binary
+
+import Crypto.Hash.Algorithms (SHAKE256)
+
+import qualified Data.ByteArray as BA
+
+import Language.Haskell.TH
+
+import Data.Typeable (typeRep)
+import Type.Reflection (typeOf, TypeRep)
+import qualified Type.Reflection as Refl (typeRep)
+import Data.Type.Equality (TestEquality(..))
+
+import qualified Data.HashMap.Strict as HashMap
+
+import Control.Concurrent.TokenBucket (TokenBucket, newTokenBucket, tokenBucketTryAlloc)
+
+import System.IO.Unsafe (unsafePerformIO)
+
+import Control.Concurrent.STM.Delay
+
+import qualified Crypto.Saltine.Class as Saltine
+import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
+import qualified Crypto.Saltine.Core.AEAD as AEAD
+
+import qualified Control.Monad.State.Class as State
+
+
+type Expiry = (Either UTCTime DiffTime)
+
+_MemcachedExpiry :: Prism' Expiry Memcached.Expiry
+_MemcachedExpiry = prism' fromExpiry toExpiry
+ where toExpiry (Left utc)
+ | posix > 2592000 = toIntegralSized posix
+ | otherwise = Nothing
+ where posix :: Integer
+ posix = ceiling $ utcTimeToPOSIXSeconds utc
+ toExpiry (Right dTime)
+ | 0 < dTime
+ , dTime <= 2592000
+ = Just $ ceiling dTime
+ | otherwise
+ = Nothing
+
+ fromExpiry n
+ | n <= 2592000
+ = Right $ fromIntegral n
+ | otherwise
+ = Left . posixSecondsToUTCTime $ fromIntegral n
+
+
+memcachedAvailable :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ )
+ => m Bool
+memcachedAvailable = getsYesod $ is _Just . appMemcached
+
+
+data MemcachedException = MemcachedException Memcached.MemcachedException
+ | MemcachedInvalidExpiry Expiry
+ deriving (Show, Typeable)
+ deriving anyclass (Exception)
+
+
+memcachedKey :: ( Typeable a
+ , Binary k
+ )
+ => AEAD.Key -> Proxy a -> k -> ByteString
+memcachedKey (Saltine.encode -> kmacKey) p k = Binary.encode k
+ & kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey
+ & BA.convert
+
+memcachedByGet :: forall a k m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , Typeable a, Binary a
+ , Binary k
+ )
+ => k -> m (Maybe a)
+memcachedByGet k = runMaybeT $ do
+ (aeadKey, conn) <- MaybeT $ getsYesod appMemcached
+ let cKey = memcachedKey aeadKey (Proxy @a) k
+
+ encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey conn
+
+ $logDebugS "memcached" "Cache hit"
+
+ guard $ length encVal >= Saltine.secretBoxNonce + Saltine.secretBoxMac
+ let (nonceBS, encrypted) = splitAt Saltine.secretBoxNonce encVal
+ nonce <- hoistMaybe $ Saltine.decode nonceBS
+ decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey nonce encrypted cKey
+
+ $logDebugS "memcached" "Decryption valid"
+
+ case Binary.decodeOrFail $ fromStrict decrypted of
+ Right (unconsumed, _, v)
+ | null unconsumed -> do
+ $logDebugS "memcached" "Deserialization valid"
+ return v
+ _other -> mzero
+
+memcachedBySet :: forall a k m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , Typeable a, Binary a
+ , Binary k
+ )
+ => Maybe Expiry -> k -> a -> m ()
+memcachedBySet mExp k v = do
+ mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry
+ mConn <- getsYesod appMemcached
+ for_ mConn $ \(aeadKey, conn) -> do
+ nonce <- liftIO AEAD.newNonce
+ let cKey = memcachedKey aeadKey (Proxy @a) k
+ encVal = Saltine.encode nonce <> AEAD.aead aeadKey nonce (toStrict $ Binary.encode v) cKey
+ liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (fromStrict encVal) conn
+ $logDebugS "memcached" "Cache store"
+
+memcachedByInvalidate :: forall a k m p.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , Typeable a
+ , Binary k
+ )
+ => k -> p a -> m ()
+memcachedByInvalidate k _ = maybeT_ $ do
+ (aeadKey, conn) <- MaybeT $ getsYesod appMemcached
+ let cKey = memcachedKey aeadKey (Proxy @a) k
+ hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey conn
+
+
+newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a }
+ deriving (Typeable)
+ deriving newtype (Eq, Ord, Show, Binary)
+
+memcachedGet :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ , Typeable a, Binary a
+ )
+ => m (Maybe a)
+memcachedGet = fmap unMemcachedUnkeyed <$> memcachedByGet ()
+
+memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , Typeable a, Binary a
+ )
+ => Maybe Expiry -> a -> m ()
+memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed
+
+memcachedInvalidate :: forall (a :: *) m p.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , Typeable a
+ )
+ => p a -> m ()
+memcachedInvalidate _ = memcachedByInvalidate () $ Proxy @(MemcachedUnkeyed a)
+
+
+memcachedWith :: Monad m
+ => (m (Maybe a), a -> m ()) -> m a -> m a
+memcachedWith (doGet, doSet) act = do
+ pRes <- doGet
+ maybe id (const . return) pRes $ do
+ res <- act
+ doSet res
+ return res
+
+memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , Typeable a, Binary a
+ )
+ => Maybe Expiry -> m a -> m a
+memcached mExp = memcachedWith (memcachedGet, memcachedSet mExp)
+
+memcachedBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , Typeable a, Binary a
+ , Binary k
+ )
+ => Maybe Expiry -> k -> m a -> m a
+memcachedBy mExp k = memcachedWith (memcachedByGet k, memcachedBySet mExp k)
+
+
+newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a }
+ deriving (Typeable)
+ deriving newtype (Eq, Ord, Show, Binary)
+
+memcachedHere :: Q Exp
+memcachedHere = do
+ loc <- location
+ [e| \mExp -> fmap unMemcachedUnkeyedLoc . memcachedBy mExp loc . fmap MemcachedUnkeyedLoc |]
+
+newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a }
+ deriving (Typeable)
+ deriving newtype (Eq, Ord, Show, Binary)
+
+memcachedByHere :: Q Exp
+memcachedByHere = do
+ loc <- location
+ [e| \mExp k -> fmap unMemcachedKeyedLoc . memcachedBy mExp (loc, k) . fmap MemcachedKeyedLoc |]
+
+
+data HashableDynamic = forall a. (Hashable a, Eq a) => HashableDynamic !(TypeRep a) !a
+
+instance Hashable HashableDynamic where
+ hashWithSalt s (HashableDynamic tRep v) = s `hashWithSalt` tRep `hashWithSalt` v
+instance Eq HashableDynamic where
+ (HashableDynamic tRep v) == (HashableDynamic tRep' v') = case testEquality tRep tRep' of
+ Just Refl -> v == v'
+ Nothing -> False
+
+hashableDynamic :: forall a.
+ ( Typeable a, Hashable a, Eq a )
+ => a -> HashableDynamic
+hashableDynamic v = HashableDynamic (typeOf v) v
+
+memcachedLimit :: TVar (HashMap HashableDynamic TokenBucket)
+memcachedLimit = unsafePerformIO . newTVarIO $ HashMap.empty
+{-# NOINLINE memcachedLimit #-}
+
+memcachedLimitedWith :: ( MonadIO m
+ , MonadLogger m
+ , Typeable k', Hashable k', Eq k'
+ )
+ => (m (Maybe a), a -> m ())
+ -> (m a -> MaybeT m a) -- ^ Wrap execution on cache miss
+ -> k' -- ^ Key for limiting
+ -> Word64 -- ^ burst-size (tokens)
+ -> Word64 -- ^ avg. inverse rate (usec/token)
+ -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
+ -> m a
+ -> m (Maybe a)
+memcachedLimitedWith (doGet, doSet) liftAct (hashableDynamic -> lK) burst rate tokens act = runMaybeT $ do
+ pRes <- lift doGet
+ maybe id (const . return) pRes $ do
+ mBucket <- fmap (HashMap.lookup lK) . liftIO $ readTVarIO memcachedLimit
+ bucket <- case mBucket of
+ Just bucket -> return bucket
+ Nothing -> liftIO $ do
+ bucket <- newTokenBucket
+ atomically $ do
+ hm <- readTVar memcachedLimit
+ let hm' = HashMap.insertWith (flip const) lK bucket hm
+ writeTVar memcachedLimit $! hm'
+ return $ HashMap.lookupDefault (error "could not insert new token bucket") lK hm'
+ sufficientTokens <- liftIO $ tokenBucketTryAlloc bucket burst rate tokens
+ $logDebugS "memcachedLimitedWith" $ "Sufficient tokens: " <> tshow sufficientTokens
+ guard sufficientTokens
+
+ liftAct $ do
+ res <- act
+ doSet res
+ return res
+
+memcachedLimited :: forall a m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , Typeable a, Binary a
+ )
+ => Word64 -- ^ burst-size (tokens)
+ -> Word64 -- ^ avg. inverse rate (usec/token)
+ -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
+ -> Maybe Expiry
+ -> m a
+ -> m (Maybe a)
+memcachedLimited burst rate tokens mExp = memcachedLimitedWith (memcachedGet, memcachedSet mExp) lift (Proxy @a) burst rate tokens
+
+memcachedLimitedKey :: forall a k' m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , Typeable a, Binary a
+ , Typeable k', Hashable k', Eq k'
+ )
+ => k'
+ -> Word64 -- ^ burst-size (tokens)
+ -> Word64 -- ^ avg. inverse rate (usec/token)
+ -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
+ -> Maybe Expiry
+ -> m a
+ -> m (Maybe a)
+memcachedLimitedKey lK burst rate tokens mExp = memcachedLimitedWith (memcachedGet, memcachedSet mExp) lift lK burst rate tokens
+
+memcachedLimitedBy :: forall a k m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , Typeable a, Binary a
+ , Binary k
+ )
+ => Word64 -- ^ burst-size (tokens)
+ -> Word64 -- ^ avg. inverse rate (usec/token)
+ -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
+ -> Maybe Expiry
+ -> k
+ -> m a
+ -> m (Maybe a)
+memcachedLimitedBy burst rate tokens mExp k = memcachedLimitedWith (memcachedByGet k, memcachedBySet mExp k) lift (Proxy @a) burst rate tokens
+
+memcachedLimitedKeyBy :: forall a k' k m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , Typeable a, Binary a
+ , Typeable k', Hashable k', Eq k'
+ , Binary k
+ )
+ => k'
+ -> Word64 -- ^ burst-size (tokens)
+ -> Word64 -- ^ avg. inverse rate (usec/token)
+ -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
+ -> Maybe Expiry
+ -> k
+ -> m a
+ -> m (Maybe a)
+memcachedLimitedKeyBy lK burst rate tokens mExp k = memcachedLimitedWith (memcachedByGet k, memcachedBySet mExp k) lift lK burst rate tokens
+
+memcachedLimitedHere :: Q Exp
+memcachedLimitedHere = do
+ loc <- location
+ [e| \burst rate tokens mExp -> fmap (fmap unMemcachedUnkeyedLoc) . memcachedLimitedBy burst rate tokens mExp loc . fmap MemcachedUnkeyedLoc |]
+
+memcachedLimitedKeyHere :: Q Exp
+memcachedLimitedKeyHere = do
+ loc <- location
+ [e| \lK burst rate tokens mExp -> fmap (fmap unMemcachedUnkeyedLoc) . memcachedLimitedKeyBy lK burst rate tokens mExp loc . fmap MemcachedUnkeyedLoc |]
+
+memcachedLimitedByHere :: Q Exp
+memcachedLimitedByHere = do
+ loc <- location
+ [e| \burst rate tokens mExp k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedBy burst rate tokens mExp (loc, k) . fmap MemcachedKeyedLoc |]
+
+memcachedLimitedKeyByHere :: Q Exp
+memcachedLimitedKeyByHere = do
+ loc <- location
+ [e| \lK burst rate tokens mExp k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedKeyBy lK burst rate tokens mExp (loc, k) . fmap MemcachedKeyedLoc |]
+
+
+data AsyncTimeoutException = AsyncTimeoutReturnTypeDoesNotMatchComputationKey
+ deriving (Show, Typeable)
+ deriving anyclass (Exception)
+
+data DynamicAsync = forall a. DynamicAsync !(TypeRep a) !(Async a)
+
+instance Eq DynamicAsync where
+ (DynamicAsync tRep v) == (DynamicAsync tRep' v') = case testEquality tRep tRep' of
+ Just Refl -> v == v'
+ Nothing -> False
+
+memcachedAsync :: TVar (HashMap HashableDynamic DynamicAsync)
+memcachedAsync = unsafePerformIO . newTVarIO $ HashMap.empty
+{-# NOINLINE memcachedAsync #-}
+
+liftAsyncTimeout :: forall k'' a m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadUnliftIO m
+ , MonadThrow m
+ , Typeable k'', Hashable k'', Eq k''
+ , Typeable a
+ )
+ => DiffTime
+ -> k''
+ -> m a -> MaybeT m a
+liftAsyncTimeout dt (hashableDynamic -> cK) act = ifNotM memcachedAvailable (lift act) $ do
+ delay <- liftIO . newDelay . round $ toRational dt * 1e6
+
+ act' <- lift $ do
+ existing <- traverse castDynamicAsync . HashMap.lookup cK <=< liftIO $ readTVarIO memcachedAsync
+ case existing of
+ Just act' -> return act'
+ Nothing -> do
+ startAct <- liftIO newEmptyTMVarIO
+ act' <- async $ do
+ $logDebugS "liftAsyncTimeout" $ "Waiting for confirmation..."
+ atomically $ takeTMVar startAct
+ $logDebugS "liftAsyncTimeout" $ "Confirmed."
+ act
+ act'' <- atomically $ do
+ hm <- readTVar memcachedAsync
+ let new = DynamicAsync (Refl.typeRep @a) act'
+ go mOld = case mOld of
+ Just old' -> do
+ old <- castDynamicAsync old'
+ resolved <- lift $ is _Just <$> pollSTM old
+
+ if | resolved -> return $ Just new
+ | otherwise -> do
+ State.put old
+ return $ Just old'
+ Nothing -> return $ Just new
+
+ (hm', act'') <- runStateT (HashMap.alterF go cK hm) act'
+ writeTVar memcachedAsync $! hm'
+ return act''
+ if | act' == act'' -> atomically $ putTMVar startAct ()
+ | otherwise -> cancel act'
+ return act''
+
+ MaybeT . atomically $ (Nothing <$ waitDelay delay) <|> (Just <$> waitSTM act')
+ where
+ castDynamicAsync :: forall m'. MonadThrow m' => DynamicAsync -> m' (Async a)
+ castDynamicAsync (DynamicAsync tRep v)
+ | Just Refl <- testEquality tRep (Refl.typeRep @a)
+ = return v
+ | otherwise
+ = throwM AsyncTimeoutReturnTypeDoesNotMatchComputationKey
+
+memcachedTimeoutWith :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadUnliftIO m
+ , MonadThrow m
+ , Typeable k'', Hashable k'', Eq k''
+ , Typeable a
+ )
+ => (m (Maybe a), a -> m ()) -> DiffTime -> k'' -> m a -> m (Maybe a)
+memcachedTimeoutWith (doGet, doSet) dt cK act = runMaybeT $ do
+ pRes <- lift doGet
+ maybe id (const . return) pRes $
+ liftAsyncTimeout dt cK $ do
+ res <- act
+ doSet res
+ return res
+
+memcachedTimeout :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , MonadUnliftIO m
+ , Typeable k'', Hashable k'', Eq k''
+ , Typeable a, Binary a
+ )
+ => Maybe Expiry -> DiffTime -> k'' -> m a -> m (Maybe a)
+memcachedTimeout mExp = memcachedTimeoutWith (memcachedGet, memcachedSet mExp)
+
+memcachedTimeoutBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , MonadUnliftIO m
+ , Typeable k'', Hashable k'', Eq k''
+ , Typeable a, Binary a
+ , Binary k
+ )
+ => Maybe Expiry -> DiffTime -> k'' -> k -> m a -> m (Maybe a)
+memcachedTimeoutBy mExp dt cK k = memcachedTimeoutWith (memcachedByGet k, memcachedBySet mExp k) dt cK
+
+memcachedTimeoutHere :: Q Exp
+memcachedTimeoutHere = do
+ loc <- location
+ [e| \mExp dt cK -> fmap unMemcachedUnkeyedLoc . memcachedTimeoutBy mExp dt cK loc . fmap MemcachedUnkeyedLoc |]
+
+memcachedTimeoutByHere :: Q Exp
+memcachedTimeoutByHere = do
+ loc <- location
+ [e| \mExp dt cK k -> fmap unMemcachedKeyedLoc . memcachedBy mExp dt cK (loc, k) . fmap MemcachedKeyedLoc |]
+
+memcachedLimitedTimeout :: forall a k'' m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , MonadUnliftIO m
+ , Typeable k'', Hashable k'', Eq k''
+ , Typeable a, Binary a
+ )
+ => Word64 -- ^ burst-size (tokens)
+ -> Word64 -- ^ avg. inverse rate (usec/token)
+ -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
+ -> Maybe Expiry
+ -> DiffTime
+ -> k''
+ -> m a
+ -> m (Maybe a)
+memcachedLimitedTimeout burst rate tokens mExp dt cK = memcachedLimitedWith (memcachedGet, memcachedSet mExp) (liftAsyncTimeout dt cK) (Proxy @a) burst rate tokens
+
+memcachedLimitedKeyTimeout :: forall a k' k'' m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , MonadUnliftIO m
+ , Typeable k'', Hashable k'', Eq k''
+ , Typeable a, Binary a
+ , Typeable k', Hashable k', Eq k'
+ )
+ => k'
+ -> Word64 -- ^ burst-size (tokens)
+ -> Word64 -- ^ avg. inverse rate (usec/token)
+ -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
+ -> Maybe Expiry
+ -> DiffTime
+ -> k''
+ -> m a
+ -> m (Maybe a)
+memcachedLimitedKeyTimeout lK burst rate tokens mExp dt cK = memcachedLimitedWith (memcachedGet, memcachedSet mExp) (liftAsyncTimeout dt cK) lK burst rate tokens
+
+memcachedLimitedTimeoutBy :: forall a k'' k m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , MonadUnliftIO m
+ , Typeable k'', Hashable k'', Eq k''
+ , Typeable a, Binary a
+ , Binary k
+ )
+ => Word64 -- ^ burst-size (tokens)
+ -> Word64 -- ^ avg. inverse rate (usec/token)
+ -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
+ -> Maybe Expiry
+ -> DiffTime
+ -> k''
+ -> k
+ -> m a
+ -> m (Maybe a)
+memcachedLimitedTimeoutBy burst rate tokens mExp dt cK k = memcachedLimitedWith (memcachedByGet k, memcachedBySet mExp k) (liftAsyncTimeout dt cK) (Proxy @a) burst rate tokens
+
+memcachedLimitedKeyTimeoutBy :: forall a k' k'' k m.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , MonadThrow m
+ , MonadUnliftIO m
+ , Typeable k'', Hashable k'', Eq k''
+ , Typeable a, Binary a
+ , Typeable k', Hashable k', Eq k'
+ , Binary k
+ )
+ => k'
+ -> Word64 -- ^ burst-size (tokens)
+ -> Word64 -- ^ avg. inverse rate (usec/token)
+ -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
+ -> Maybe Expiry
+ -> DiffTime
+ -> k''
+ -> k
+ -> m a
+ -> m (Maybe a)
+memcachedLimitedKeyTimeoutBy lK burst rate tokens mExp dt cK k = memcachedLimitedWith (memcachedByGet k, memcachedBySet mExp k) (liftAsyncTimeout dt cK) lK burst rate tokens
+
+memcachedLimitedTimeoutHere :: Q Exp
+memcachedLimitedTimeoutHere = do
+ loc <- location
+ [e| \burst rate tokens mExp dt cK -> fmap (fmap unMemcachedUnkeyedLoc) . memcachedLimitedTimeoutBy burst rate tokens mExp dt cK loc . fmap MemcachedUnkeyedLoc |]
+
+memcachedLimitedKeyTimeoutHere :: Q Exp
+memcachedLimitedKeyTimeoutHere = do
+ loc <- location
+ [e| \lK burst rate tokens mExp dt cK -> fmap (fmap unMemcachedUnkeyedLoc) . memcachedLimitedKeyTimeoutBy lK burst rate tokens mExp dt cK loc . fmap MemcachedUnkeyedLoc |]
+
+memcachedLimitedTimeoutByHere :: Q Exp
+memcachedLimitedTimeoutByHere = do
+ loc <- location
+ [e| \burst rate tokens mExp dt cK k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedTimeoutBy burst rate tokens mExp dt cK (loc, k) . fmap MemcachedKeyedLoc |]
+
+memcachedLimitedKeyTimeoutByHere :: Q Exp
+memcachedLimitedKeyTimeoutByHere = do
+ loc <- location
+ [e| \lK burst rate tokens mExp dt cK k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedKeyTimeoutBy lK burst rate tokens mExp dt cK (loc, k) . fmap MemcachedKeyedLoc |]
+
diff --git a/src/Handler/Utils/News.hs b/src/Handler/Utils/News.hs
new file mode 100644
index 000000000..f514aca75
--- /dev/null
+++ b/src/Handler/Utils/News.hs
@@ -0,0 +1,11 @@
+module Handler.Utils.News
+ ( NewsGetParam(..)
+ ) where
+
+import Import
+
+
+data NewsGetParam = GetHidden
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+ deriving anyclass (Universe, Finite)
+nullaryPathPiece ''NewsGetParam $ camelToPathPiece' 1
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index ee7e7fc56..32ba42074 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -3,6 +3,7 @@ module Handler.Utils.Submission
, assignSubmissions, writeSubmissionPlan, planSubmissions
, submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
, submissionFileSource, submissionFileQuery
+ , SubmissionDownloadAnonymous(..)
, submissionMultiArchive
, SubmissionSinkException(..)
, msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB!
@@ -48,6 +49,10 @@ import qualified Control.Monad.Catch as E (Handler(..))
import qualified Data.CaseInsensitive as CI
+import Text.Unidecode (unidecode)
+import Data.Char (isAlphaNum)
+
+
data AssignSubmissionException = NoCorrectors
| NoCorrectorsByProportion
| SubmissionsNotFound (NonNull (Set SubmissionId))
@@ -256,14 +261,29 @@ submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery
submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
-> E.SqlQuery (E.SqlExpr (Entity SubmissionFile), E.SqlExpr (Entity File))
submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
- E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+ E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
- E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
+ E.where_ . E.not_ . E.exists . E.from $ \(sf' `E.InnerJoin` f') -> do
+ E.on $ f' E.^. FileId E.==. sf' E.^. SubmissionFileFile
+ E.where_ $ sf' E.^. SubmissionFileIsDeletion
+ E.&&. sf' E.^. SubmissionFileSubmission E.==. sf E.^. SubmissionFileSubmission
+ E.&&. f' E.^. FileTitle E.==. f E.^. FileTitle
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
return (sf, f)
-submissionMultiArchive :: Set SubmissionId -> Handler TypedContent
-submissionMultiArchive (Set.toList -> ids) = do
+data SubmissionDownloadAnonymous = SubmissionDownloadAnonymous
+ | SubmissionDownloadSurnames
+ | SubmissionDownloadMatriculations
+ | SubmissionDownloadGroups
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+ deriving anyclass (Universe, Finite)
+
+nullaryPathPiece ''SubmissionDownloadAnonymous $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''SubmissionDownloadAnonymous id
+makePrisms ''SubmissionDownloadAnonymous
+
+submissionMultiArchive :: SubmissionDownloadAnonymous -> Set SubmissionId -> Handler TypedContent
+submissionMultiArchive anonymous (Set.toList -> ids) = do
(dbrunner, cleanup) <- getDBRunner
ratedSubmissions <- runDBRunner dbrunner $ do
@@ -271,26 +291,58 @@ submissionMultiArchive (Set.toList -> ids) = do
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ submission E.^. SubmissionId `E.in_` E.valList ids
- return (submission, (sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseSchool, course E.^. CourseTerm))
+ return (submission, (sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseSchool, course E.^. CourseTerm, sheet E.^. SheetAnonymousCorrection))
forM submissions $ \(s@(Entity submissionId _), courseSheetInfo) ->
- maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s, $(E.unValueN 4) courseSheetInfo)) =<< getRating submissionId
+ maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s, $(E.unValueN 5) courseSheetInfo)) =<< getRating submissionId
let (setSheet,setCourse,setSchool,setTerm) =
- execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid)) ->
+ execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid,_anon)) ->
tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid)
archiveName <- ap getMessageRender $ pure MsgSubmissionArchiveName
setContentDisposition' $ Just ((addExtension `on` unpack) archiveName extensionZip)
(<* cleanup) . respondSource typeZip . transPipe (runDBRunner dbrunner) $ do
let
- fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> ConduitT () File (YesodDB UniWorX) ()
- fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do
+ fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId,Bool)) -> ConduitT () File (YesodDB UniWorX) ()
+ fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid,sheetAnonymous)) = do
cID <- encrypt submissionID
let
dirFrag :: PathPiece p => p -> FilePath
dirFrag = Text.unpack . toPathPiece
- submissionDirectory = dirFrag (cID :: CryptoFileNameSubmission)
+
+ userFeature :: SubmissionDownloadAnonymous -> Maybe (E.SqlExpr (Entity User) -> E.SqlExpr (E.Value (Maybe Text)))
+ userFeature SubmissionDownloadSurnames = Just $ E.just . (E.^. UserSurname)
+ userFeature SubmissionDownloadMatriculations = Just $ E.castString . (E.^. UserMatrikelnummer)
+ userFeature _ = Nothing
+
+ withNames fp
+ | is _SubmissionDownloadGroups anonymous = do
+ groups <- lift . E.select . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser `E.InnerJoin` submissionUser) -> do
+ E.on $ submissionUser E.^. SubmissionUserUser E.==. submissionGroupUser E.^. SubmissionGroupUserUser
+ E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
+ E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val submissionID
+ E.where_ $ E.subSelectForeign submissionUser SubmissionUserSubmission (\submission -> E.subSelectForeign submission SubmissionSheet (E.^. SheetGrouping)) E.==. E.val RegisteredGroups
+ return $ submissionGroup E.^. SubmissionGroupName
+ let asciiGroups = nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) groups
+ return . intercalate "_" $ asciiGroups `snoc` fp
+ | Just feature <- userFeature anonymous
+ = do
+ features <- lift . E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
+ E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+ E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val submissionID
+ return $ feature user
+ let asciiFeatures = sort $ mapMaybe (fmap (filter isAlphaNum . foldMap unidecode . unpack) . E.unValue) features
+ return . intercalate "_" $ asciiFeatures `snoc` fp
+ | otherwise = return fp
+
+ notAnonymized' <- and2M
+ (return $ isn't _SubmissionDownloadAnonymous anonymous)
+ (or2M (return $ not sheetAnonymous) (hasReadAccessTo $ CourseR tid ssh csh CCorrectionsR))
+
+ submissionDirectory <- bool return withNames notAnonymized' $ dirFrag (cID :: CryptoFileNameSubmission)
+
+ let
directoryName
| Set.size setTerm > 1 = dirFrag tid dirFrag ssh dirFrag csh dirFrag shn submissionDirectory
| Set.size setSchool > 1 = dirFrag ssh dirFrag csh dirFrag shn submissionDirectory
@@ -678,12 +730,13 @@ sinkMultiSubmission userId isUpdate = do
acc (Just sId, fp) segment = return (Just sId, fp ++ [segment])
acc (Nothing , fp) segment = do
let
- tryDecrypt (Text.pack -> ciphertext)
+ segments' = filter (not . Text.null) . Text.split (flip Set.notMember cryptoIdChars . CI.mk) $ Text.pack segment
+ tryDecrypt ciphertext
| Just cID <- fromPathPiece ciphertext = do
sId <- decrypt (cID :: CryptoFileNameSubmission)
Just sId <$ get404 sId
| otherwise = return Nothing
- msId <- lift (lift (tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ])
+ Dual (Alt msId) <- lift . flip foldMapM segments' $ \seg -> Dual . Alt <$> lift (tryDecrypt seg) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
return (msId, fp)
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
case msId of
@@ -708,6 +761,9 @@ sinkMultiSubmission userId isUpdate = do
handleCryptoID :: CryptoIDError -> _ (Maybe a)
handleCryptoID _ = return Nothing
+ cryptoIdChars :: Set (CI Char)
+ cryptoIdChars = Set.fromList . map CI.mk $ "uwa" ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"
+
submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
submissionMatchesSheet tid ssh csh shn cid = do
diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs
index 61ed1ce07..10a939e95 100644
--- a/src/Handler/Utils/Table/Columns.hs
+++ b/src/Handler/Utils/Table/Columns.hs
@@ -58,10 +58,10 @@ type OpticColonnade focus
-> Colonnade h r' (DBCell m x)
type OpticSortColumn' focus
- = forall t sortingMap.
+ = forall t r' sortingMap.
( IsMap sortingMap
, ContainerKey sortingMap ~ SortingKey
- , MapValue sortingMap ~ SortColumn t
+ , MapValue sortingMap ~ SortColumn t r'
)
=> (forall focus'. Getting focus' t focus)
-> sortingMap
@@ -69,10 +69,10 @@ type OpticSortColumn' focus
type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val))
type OpticFilterColumn' t inp focus
- = forall filterMap.
+ = forall r' filterMap.
( IsMap filterMap
, ContainerKey filterMap ~ FilterKey
- , MapValue filterMap ~ FilterColumn t
+ , MapValue filterMap ~ FilterColumn t r'
, IsFilterColumn t (t -> inp -> E.SqlExpr (E.Value Bool))
)
=> (forall focus'. Getting focus' t focus)
@@ -80,14 +80,6 @@ type OpticFilterColumn' t inp focus
type OpticFilterColumn t focus = OpticFilterColumn' t (Set focus) (E.SqlExpr (E.Value focus))
------------------------
--- Numbers and Indices
-
--- | Simple index column, also indicating whether there is a row at all
--- For a version without indication, use `Handler.Utils.Pagination.dbRow` instead.
-dbRowIndicator :: IsDBTable m Any => Colonnade Sortable (DBRow r) (DBCell m Any)
-dbRowIndicator = sortable Nothing (i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> tellCell (Any True) $ textCell $ tshow dbrIndex
-
-----------
-- Terms --
-----------
@@ -425,10 +417,10 @@ colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell Ms
where conDTCell = ifCell condition dateTimeCell $ const mempty
-sortFilePath :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r)
+sortFilePath :: IsString s => (t -> E.SqlExpr (Entity File)) -> (s, SortColumn t r')
sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle))
-sortFileModification :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r)
+sortFileModification :: IsString s => (t -> E.SqlExpr (Entity File)) -> (s, SortColumn t r')
sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. FileModified))
defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x
@@ -484,7 +476,7 @@ colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route
colUserNameLink userLink = sortable (Just "user-name") (i18nCell MsgCourseMembers) (cellHasUserLink userLink)
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
-sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
sortUserName queryUser = ("user-name", SortColumns $ queryUser >>> \user ->
[ SomeExprValue $ user E.^. UserSurname
, SomeExprValue $ user E.^. UserDisplayName
@@ -492,13 +484,13 @@ sortUserName queryUser = ("user-name", SortColumns $ queryUser >>> \user ->
)
-- | Alias for sortUserName for consistency, since column comes in two variants
-sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
sortUserNameLink = sortUserName
-sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
sortUserSurname queryUser = ("user-surname", SortColumn $ queryUser >>> (E.^. UserSurname))
-sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
+sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t r')
sortUserDisplayName queryUser = ("user-display-name", SortColumn $ queryUser >>> (E.^. UserDisplayName))
defaultSortingByName :: PSValidator m x -> PSValidator m x
@@ -507,37 +499,37 @@ defaultSortingByName =
defaultSorting [SortAscBy "user-name"] -- new way, working with single sorter
-- | Alias for sortUserName for consistency
-fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t)
+fltrUserNameLink :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d) => (a -> E.SqlExpr (Entity User)) -> (d, FilterColumn t r')
fltrUserNameLink = fltrUserName
fltrUserName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
- -> (d, FilterColumn t)
+ -> (d, FilterColumn t r')
fltrUserName queryUser = ( "user-name", FilterColumn $ mkContainsFilter queryName )
where
queryName = queryUser >>> (E.^. UserDisplayName)
fltrUserNameExact :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
- -> (d, FilterColumn t)
+ -> (d, FilterColumn t r')
fltrUserNameExact queryUser = ( "user-name", FilterColumn $ mkExactFilter queryName )
where
queryName = queryUser >>> (E.^. UserDisplayName)
fltrUserSurname :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
- -> (d, FilterColumn t)
+ -> (d, FilterColumn t r')
fltrUserSurname queryUser = ( "user-surname", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserSurname))
fltrUserDisplayName :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
- -> (d, FilterColumn t)
+ -> (d, FilterColumn t r')
fltrUserDisplayName queryUser = ( "user-display-name", FilterColumn $ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName))
-- | Search all names, i.e. DisplayName, Surname, EMail
fltrUserNameEmail :: (IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool)), IsString d)
=> (a -> E.SqlExpr (Entity User))
- -> (d, FilterColumn t)
+ -> (d, FilterColumn t r')
fltrUserNameEmail queryUser = ( "user-name-email", FilterColumn $ anyFilter
[ mkContainsFilter $ queryUser >>> (E.^. UserDisplayName)
, mkContainsFilter $ queryUser >>> (E.^. UserSurname)
@@ -579,14 +571,14 @@ fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation"
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
-sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
+sortUserMatriclenr :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
sortUserMatriclenr queryUser = ("user-matriclenumber", SortColumn $ queryUser >>> (E.^. UserMatrikelnummer))
fltrUserMatriclenr :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
, IsString d
)
=> (a -> E.SqlExpr (Entity User))
- -> (d, FilterColumn t)
+ -> (d, FilterColumn t r')
fltrUserMatriclenr queryUser = ("user-matriclenumber", FilterColumn . mkContainsFilterWith Just $ queryUser >>> (E.^. UserMatrikelnummer))
fltrUserMatriclenrUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
@@ -599,14 +591,14 @@ fltrUserMatriclenrUI mPrev =
colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
colUserEmail = sortable (Just "user-email") (i18nCell MsgEMail) cellHasEMail
-sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t)
+sortUserEmail :: IsString d => (t -> E.SqlExpr (Entity User)) -> (d, SortColumn t r')
sortUserEmail queryUser = ( "user-email", SortColumn $ queryUser >>> (E.^. UserEmail))
fltrUserEmail :: ( IsFilterColumn t (a -> Set (CI Text) -> E.SqlExpr (E.Value Bool))
, IsString d
)
=> (a -> E.SqlExpr (Entity User))
- -> (d, FilterColumn t)
+ -> (d, FilterColumn t r')
fltrUserEmail queryUser = ("user-email", FilterColumn . mkContainsFilter $ queryUser >>> (E.^. UserEmail))
fltrUserEmailUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
@@ -724,14 +716,14 @@ fltrStudyFeaturesSemesterUI mPrev = prismAForm (singletonFilter "features-semest
colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature
-sortFeaturesSemester :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (d, SortColumn t)
+sortFeaturesSemester :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyFeatures))) -> (d, SortColumn t r')
sortFeaturesSemester queryFeatures = ("features-semester", SortColumn $ queryFeatures >>> (E.?. StudyFeaturesSemester))
fltrFeaturesSemester :: ( IsFilterColumn t (a -> Set Int -> E.SqlExpr (E.Value Bool))
, IsString d
)
=> (a -> E.SqlExpr (Maybe (Entity StudyFeatures)))
- -> (d, FilterColumn t)
+ -> (d, FilterColumn t r')
fltrFeaturesSemester queryFeatures = ("features-semester", FilterColumn . mkExactFilterWith Just $ queryFeatures >>> (E.?. StudyFeaturesSemester))
fltrFeaturesSemesterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
@@ -742,14 +734,14 @@ fltrFeaturesSemesterUI mPrev =
colField :: (IsDBTable m c, HasStudyTerms x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
colField terms = sortable (Just "terms") (i18nCell MsgStudyTerm) $ maybe mempty cellHasField . firstOf terms
-sortField :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (d, SortColumn t)
+sortField :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyTerms))) -> (d, SortColumn t r')
sortField queryTerms = ("terms", SortColumn $ queryTerms >>> (E.?. StudyTermsName))
fltrField :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
, IsString d
)
=> (a -> E.SqlExpr (Maybe (Entity StudyTerms)))
- -> (d, FilterColumn t)
+ -> (d, FilterColumn t r')
fltrField queryFeatures = ( "terms"
, FilterColumn $ anyFilter
[ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyTermsName)
@@ -766,14 +758,14 @@ fltrFieldUI mPrev =
colDegreeShort :: (IsDBTable m c, HasStudyDegree x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
colDegreeShort terms = sortable (Just "degree-short") (i18nCell MsgDegreeShort) $ maybe mempty cellHasDegreeShort . firstOf terms
-sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (d, SortColumn t)
+sortDegreeShort :: IsString d => (t -> E.SqlExpr (Maybe (Entity StudyDegree))) -> (d, SortColumn t r')
sortDegreeShort queryTerms = ("degree-short", SortColumn $ queryTerms >>> (E.?. StudyDegreeShorthand))
fltrDegree :: ( IsFilterColumn t (a -> Set Text -> E.SqlExpr (E.Value Bool))
, IsString d
)
=> (a -> E.SqlExpr (Maybe (Entity StudyDegree)))
- -> (d, FilterColumn t)
+ -> (d, FilterColumn t r')
fltrDegree queryFeatures = ( "degree"
, FilterColumn $ anyFilter
[ mkContainsFilterWith Just $ queryFeatures >>> E.joinV . (E.?. StudyDegreeName)
diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs
index a967a9347..ccd00621d 100644
--- a/src/Handler/Utils/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@@ -8,7 +8,7 @@ module Handler.Utils.Table.Pagination
, SortingSetting(..)
, pattern SortAscBy, pattern SortDescBy
, FilterColumn(..), IsFilterColumn
- , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
+ , DBRow(..), _dbrOutput, _dbrCount
, DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
, module Handler.Utils.Table.Pagination.CsvColumnExplanations
, DBCsvActionMode(..)
@@ -26,6 +26,7 @@ module Handler.Utils.Table.Pagination
, defaultPagesize
, defaultFilter, defaultSorting
, restrictFilter, restrictSorting
+ , forceFilter
, ToSortable(..), Sortable(..)
, dbTable
, dbTableWidget, dbTableWidget'
@@ -35,10 +36,11 @@ module Handler.Utils.Table.Pagination
, anchorCell, anchorCell', anchorCellM, anchorCellM'
, linkEitherCell, linkEitherCellM, linkEitherCellM'
, maybeAnchorCellM, maybeAnchorCellM', maybeLinkEitherCellM'
+ , anchorCellC, anchorCellCM, anchorCellCM', linkEitherCellCM', maybeLinkEitherCellCM'
, cellTooltip
- , listCell
+ , listCell, listCell'
, formCell, DBFormResult(..), getDBFormResult
- , dbRow, dbSelect
+ , dbSelect
, (&)
, module Control.Monad.Trans.Maybe
, module Colonnade
@@ -144,8 +146,9 @@ dbFilterKey ident = toPathPiece . WithIdent ident
data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }
-data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
- | SortColumns { getSortColumns :: t -> [SomeExprValue] }
+data SortColumn t r' = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
+ | SortColumns { getSortColumns :: t -> [SomeExprValue] }
+ | SortProjected { sortProjected :: r' -> r' -> Ordering }
data SortDirection = SortAsc | SortDesc
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
@@ -153,20 +156,21 @@ data SortDirection = SortAsc | SortDesc
instance Universe SortDirection
instance Finite SortDirection
-instance PathPiece SortDirection where
- toPathPiece SortAsc = "asc"
- toPathPiece SortDesc = "desc"
- fromPathPiece = finiteFromPathPiece
+nullaryPathPiece ''SortDirection $ camelToPathPiece' 1
+pathPieceJSON ''SortDirection
-deriveJSON defaultOptions
- { constructorTagModifier = camelToPathPiece' 1
- } ''SortDirection
+sqlSortDirection :: SortColumn t r' -> Maybe (SortDirection -> t -> [E.SqlExpr E.OrderBy])
+sqlSortDirection (SortColumn e ) = Just $ \case
+ SortAsc -> pure . E.asc . e
+ SortDesc -> pure . E.desc . e
+sqlSortDirection (SortColumns es) = Just $ \case
+ SortAsc -> fmap (\(SomeExprValue v) -> E.asc v) . es
+ SortDesc -> fmap (\(SomeExprValue v) -> E.desc v) . es
+sqlSortDirection _ = Nothing
-sqlSortDirection :: t -> (SortColumn t, SortDirection) -> [E.SqlExpr E.OrderBy]
-sqlSortDirection t (SortColumn e , SortAsc ) = pure . E.asc $ e t
-sqlSortDirection t (SortColumn e , SortDesc) = pure . E.desc $ e t
-sqlSortDirection t (SortColumns es, SortAsc ) = es t <&> \(SomeExprValue v) -> E.asc v
-sqlSortDirection t (SortColumns es, SortDesc) = es t <&> \(SomeExprValue v) -> E.desc v
+sortDirectionProjected :: SortColumn t r' -> r' -> r' -> Ordering
+sortDirectionProjected SortProjected{..} = sortProjected
+sortDirectionProjected _ = \_ _ -> EQ
data SortingSetting = SortingSetting
@@ -193,10 +197,16 @@ pattern SortDescBy :: SortingKey -> SortingSetting
pattern SortDescBy key = SortingSetting key SortDesc
-data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a
+data FilterColumn t r' = forall a. IsFilterColumn t a => FilterColumn a
+ | forall a. IsFilterProjected r' a => FilterProjected a
-filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
-filterColumn (FilterColumn f) = filterColumn' f
+filterColumn :: FilterColumn t r' -> Maybe ([Text] -> t -> E.SqlExpr (E.Value Bool))
+filterColumn (FilterColumn f) = Just $ filterColumn' f
+filterColumn _ = Nothing
+
+filterProjected :: FilterColumn t r' -> r' -> [Text] -> DB Bool
+filterProjected (FilterProjected f) = flip $ filterProjected' f
+filterProjected _ = \_ _ -> return True
class IsFilterColumn t a where
filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)
@@ -208,13 +218,22 @@ instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
filterColumn' cont is' t = filterColumn' (cont t) is' t
instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
- filterColumn' cont is0 = filterColumn' (cont input) is'
- where
- (input, ($ []) -> is') = go (mempty, id) is0
- go acc [] = acc
- go (acc, is3) (i:is2)
- | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2
- | otherwise = go (acc, is3 . (i:)) is2
+ filterColumn' cont is' = filterColumn' (cont $ is' ^. mono' _PathPiece) is'
+
+class IsFilterProjected r' a where
+ filterProjected' :: a -> [Text] -> r' -> DB Bool
+
+instance IsFilterProjected r' (ReaderT SqlBackend (HandlerFor UniWorX) Bool) where
+ filterProjected' fin _ _ = fin
+
+instance IsFilterProjected r' Bool where
+ filterProjected' fin _ _ = return fin
+
+instance IsFilterProjected r' cont => IsFilterProjected r' (r' -> cont) where
+ filterProjected' cont is' r = filterProjected' (cont r) is' r
+
+instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterProjected r' cont, MonoPointed l, Monoid l) => IsFilterProjected r' (l -> cont) where
+ filterProjected' cont is' = filterProjected' (cont $ is' ^. mono' _PathPiece) is'
data PagesizeLimit = PagesizeLimit !Int64 | PagesizeAll
@@ -314,6 +333,14 @@ piIsUnset PaginationInput{..} = and
, isNothing piPage
]
+psToPi :: PaginationSettings -> PaginationInput
+psToPi PaginationSettings{..} = PaginationInput
+ { piSorting = Just psSorting
+ , piFilter = Just psFilter
+ , piLimit = Just psLimit
+ , piPage = Just psPage
+ }
+
data DBCsvActionMode = DBCsvActionNew | DBCsvActionExisting | DBCsvActionMissing
deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, Typeable)
@@ -326,7 +353,7 @@ deriveJSON defaultOptions
} ''DBCsvActionMode
-data ButtonCsvMode = BtnCsvExport | BtnCsvImport | BtnCsvImportConfirm
+data ButtonCsvMode = BtnCsvExport | BtnCsvImport | BtnCsvImportConfirm | BtnCsvImportAbort
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCsvMode
instance Finite ButtonCsvMode
@@ -344,6 +371,13 @@ instance Button UniWorX ButtonCsvMode where
|]
btnLabel x = [whamlet|_{x}|]
+ btnClasses BtnCsvImportAbort = [BCIsButton, BCDanger]
+ btnClasses BtnCsvImportConfirm = [BCIsButton, BCPrimary]
+ btnClasses _ = [BCIsButton]
+
+ btnValidate _ BtnCsvImportAbort = False
+ btnValidate _ _ = True
+
data DBCsvMode
= DBCsvNormal
@@ -351,8 +385,10 @@ data DBCsvMode
{ dbCsvExportData :: Dynamic
}
| DBCsvImport
- { dbCsvFiles :: [FileInfo]
+ { dbCsvFiles :: FileUploads
}
+ | DBCsvExportExample
+ | DBCsvAbort
data DBCsvDiff r' csv k'
= DBCsvDiffNew
@@ -392,7 +428,7 @@ type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeab
data DBRow r = forall k'. DBTableKey k' => DBRow
{ dbrKey :: k'
, dbrOutput :: r
- , dbrIndex, dbrCount :: Int64
+ , dbrCount :: Int64
}
makeLenses_ ''DBRow
@@ -404,7 +440,7 @@ instance Foldable DBRow where
foldMap f DBRow{..} = f dbrOutput
instance Traversable DBRow where
- traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrIndex <*> pure dbrCount
+ traverse f DBRow{..} = DBRow <$> pure dbrKey <*> f dbrOutput <*> pure dbrCount
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
@@ -437,8 +473,8 @@ defaultSorting :: [SortingSetting] -> PSValidator m x -> PSValidator m x
defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
where
injectDefault x = case x >>= piSorting of
- Just _ -> id
- Nothing -> set (_2._psSorting) psSorting
+ Just prev -> _2 . _psSorting <>~ filter (\ss -> none (((==) `on` sortKey) ss) prev) psSorting
+ Nothing -> set (_2 . _psSorting) psSorting
defaultPagesize :: PagesizeLimit -> PSValidator m x -> PSValidator m x
defaultPagesize psLimit (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
@@ -452,6 +488,16 @@ restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> ov
where
restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
+forceFilter :: ( MonoFoldable mono
+ , MonoPointed mono
+ , Monoid mono
+ , PathPiece (Element mono)
+ )
+ => FilterKey -> mono -> PSValidator m x -> PSValidator m x
+forceFilter key args (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 inject $ f dbTable' ps
+ where
+ inject p = p { psFilter = psFilter p <> Map.singleton key (review monoPathPieces args) }
+
restrictSorting :: (SortingKey -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
where
@@ -477,7 +523,7 @@ data DBStyle r = DBStyle
, dbsTemplate :: DBSTemplateMode r
}
-data DBSTemplateMode r = DBSTDefault
+data DBSTemplateMode r = DBSTDefault { dbstmNumber :: Int64 -> Bool, dbstmShowNumber :: Int64 -> Bool }
| DBSTCourse (Lens' r (Entity Course)) (Lens' r [Entity User]) (Lens' r Bool) (Lens' r (Entity School)) (Traversal' r (Entity Allocation))
instance Default (DBStyle r) where
@@ -491,7 +537,7 @@ instance Default (DBStyle r) where
^{scrolltable}
|]
- , dbsTemplate = DBSTDefault
+ , dbsTemplate = DBSTDefault (>= 10) (\n -> n `mod` 5 == 0)
}
defaultDBSFilterLayout :: Widget -- ^ Filter UI
@@ -506,7 +552,7 @@ defaultDBSFilterLayout filterWdgt filterEnctype filterAction scrolltable
{ formMethod = GET
, formAction = Just filterAction
, formEncoding = filterEnctype
- , formAttrs = [("class", "table-filter-form")]
+ , formAttrs = [("class", "table-filter-form"), ("autocomplete", "off")]
, formSubmit = FormAutoSubmit
, formAnchor = Nothing :: Maybe Text
}
@@ -525,9 +571,10 @@ data DBTCsvEncode r' k' csv = forall exportData.
, DBTableKey k'
, Typeable exportData
) => DBTCsvEncode
- { dbtCsvExportForm :: AForm (YesodDB UniWorX) exportData
- , dbtCsvHeader :: Maybe exportData -> YesodDB UniWorX Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error
- , dbtCsvDoEncode :: exportData -> ConduitT (k', r') csv (YesodDB UniWorX) ()
+ { dbtCsvExportForm :: AForm DB exportData
+ , dbtCsvHeader :: Maybe exportData -> DB Csv.Header -- ^ @exportData@ is @Nothing@, if we're reporting an error or exporting example data
+ , dbtCsvExampleData :: Maybe [csv]
+ , dbtCsvDoEncode :: exportData -> ConduitT (k', r') csv DB ()
, dbtCsvName :: FilePath
, dbtCsvNoExportData :: Maybe (AnIso' exportData ())
}
@@ -540,14 +587,14 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException
, Ord csvActionClass
, Exception csvException
) => DBTCsvDecode
- { dbtCsvRowKey :: csv -> MaybeT (YesodDB UniWorX) k'
- , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction (YesodDB UniWorX) ()
+ { dbtCsvRowKey :: csv -> MaybeT DB k'
+ , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction DB ()
, dbtCsvClassifyAction :: csvAction -> csvActionClass
, dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
, dbtCsvExecuteActions :: ConduitT csvAction Void (YesodJobDB UniWorX) route
, dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget
, dbtCsvRenderActionClass :: csvActionClass -> Widget
- , dbtCsvRenderException :: csvException -> YesodDB UniWorX Text
+ , dbtCsvRenderException :: csvException -> DB Text
}
data DBTable m x = forall a r r' h i t k k' csv.
@@ -558,10 +605,10 @@ data DBTable m x = forall a r r' h i t k k' csv.
) => DBTable
{ dbtSQLQuery :: t -> E.SqlQuery a
, dbtRowKey :: t -> k -- ^ required for table forms; always same key for repeated requests. For joins: return unique tuples.
- , dbtProj :: DBRow r -> MaybeT (YesodDB UniWorX) r'
+ , dbtProj :: DBRow r -> DB r'
, dbtColonnade :: Colonnade h r' (DBCell m x)
- , dbtSorting :: Map SortingKey (SortColumn t)
- , dbtFilter :: Map FilterKey (FilterColumn t)
+ , dbtSorting :: Map SortingKey (SortColumn t r')
+ , dbtFilter :: Map FilterKey (FilterColumn t r')
, dbtFilterUI :: DBFilterUI
, dbtStyle :: DBStyle r'
, dbtParams :: DBParams m x
@@ -570,7 +617,7 @@ data DBTable m x = forall a r r' h i t k k' csv.
, dbtIdent :: i
}
-type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
+type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm DB (Map FilterKey [Text])
noCsvEncode :: Maybe (DBTCsvEncode r' k' Void)
noCsvEncode = Nothing
@@ -587,6 +634,7 @@ simpleCsvEncode fName f = Just DBTCsvEncode
, dbtCsvName = unpack fName
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: csv)
+ , dbtCsvExampleData = Nothing
}
simpleCsvEncodeM :: forall fp r' k' csv.
@@ -594,13 +642,14 @@ simpleCsvEncodeM :: forall fp r' k' csv.
, DBTableKey k'
, Textual fp
)
- => fp -> ReaderT r' (YesodDB UniWorX) csv -> Maybe (DBTCsvEncode r' k' csv)
+ => fp -> ReaderT r' DB csv -> Maybe (DBTCsvEncode r' k' csv)
simpleCsvEncodeM fName f = Just DBTCsvEncode
{ dbtCsvExportForm = pure ()
, dbtCsvDoEncode = \() -> C.mapM (runReaderT f . view _2)
, dbtCsvName = unpack fName
, dbtCsvNoExportData = Just id
, dbtCsvHeader = const . return $ headerOrder (error "headerOrder" :: csv)
+ , dbtCsvExampleData = Nothing
}
@@ -737,8 +786,8 @@ instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) En
= fmap ((\(res, (wdgt, x)) -> (x & dbParamsFormResult .~ res, wdgt)) . view _1)
. dbParamsFormEvaluate
. fmap (fmap $ \(x, wdgt) -> (x ^. dbParamsFormResult, (wdgt, x)))
- . dbParamsFormWrap dbtable dbtParams
. maybe id (identifyForm' dbParamsFormResult) (unDBParamsFormIdent dbtable dbParamsFormIdent)
+ . dbParamsFormWrap dbtable dbtParams
. addPIHiddenField dbtable pi
. addPreviousHiddenField dbtable pKeys
. withFragment
@@ -845,23 +894,20 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
<*> iopt intField (wIdent "page")
let prevPi
- | FormSuccess pi <- piPreviousRes <|> piInput
- = pi
- | otherwise
- = def
+ = views _2 psToPi . runPSValidator dbtable . formResultToMaybe $ piPreviousRes <|> piInput
referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
(((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
- (filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
+ (filterRes'@((filterRes, _), _)) <- runFormGet . identifyForm (FIDDBTableFilter dbtIdent) . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
- (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
+ (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identifyForm (FIDDBTablePagesize dbtIdent) . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addName (wIdent "pagesize") & addClass ("select--pagesize" :: Text)) (Just referencePagesize)
return (filterRes', pagesizeRes')
let
- piResult = (\fSettings -> prevPi & _piFilter .~ Just fSettings) <$> filterRes
- <|> (\ps -> prevPi & _piLimit .~ Just ps) <$> pagesizeRes
+ piResult = (prevPi &) . (_piFilter ?~) <$> filterRes
+ <|> (prevPi &) . (_piLimit ?~) <$> pagesizeRes
<|> piPreviousRes
<|> piInput
@@ -878,13 +924,16 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
= (, def) $ runPSValidator dbtable Nothing
psSorting' = map (\SortingSetting{..} -> (Map.findWithDefault (error $ "Invalid sorting key: " <> show sortKey) sortKey dbtSorting, sortDir)) psSorting
- mapM_ (addMessageI Warning) errs
+ forM_ errs $ \err -> do
+ mr <- getMessageRender
+ $logDebugS "dbTable paginationSettings" $ mr err
+ addMessageI Warning err
currentRoute <- fromMaybe (error "dbTable called from 404-handler") <$> getCurrentRoute
getParams <- liftHandler $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
let
tblLink :: (QueryText -> QueryText) -> SomeRoute UniWorX
- tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
+ tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing . setParam (toPathPiece PostFormIdentifier) Nothing) getParams
substPi = foldr (.) id
[ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
, foldr (.) id . map (\k -> setParams (dbFilterKey dbtIdent' k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
@@ -901,7 +950,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
| otherwise
= True
- ((csvExportRes, csvExportWdgt), csvExportEnctype) <- bool runFormPost runFormGet noExportData . identifyForm FIDDBTableCsvExport . renderAForm FormDBTableCsvExport . fmap DBCsvExport $ case dbtCsvEncode of
+ ((csvExportRes, csvExportWdgt), csvExportEnctype) <- bool runFormPost runFormGet noExportData . addPIHiddenField dbtable paginationInput . identifyForm (FIDDBTableCsvExport dbtIdent) . renderAForm FormDBTableCsvExport . fmap DBCsvExport $ case dbtCsvEncode of
Just DBTCsvEncode{..}
| Just (cloneIso -> noExportData') <- dbtCsvNoExportData
-> toDyn . view (noExportData' . from noExportData') <$> dbtCsvExportForm
@@ -909,12 +958,22 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
-> toDyn <$> dbtCsvExportForm
Nothing
-> pure $ toDyn ()
- ((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . identifyForm FIDDBTableCsvImport . renderAForm FormDBTableCsvImport $ DBCsvImport
+ let importButtons prevRes = do
+ isReImport <- hasGlobalPostParamForm PostDBCsvReImport
+ if | is _FormSuccess prevRes || isReImport
+ -> return [BtnCsvImport, BtnCsvImportAbort]
+ | otherwise
+ -> return [BtnCsvImport]
+ handleBtnAbort _ (FormSuccess BtnCsvImportAbort) = pure DBCsvAbort
+ handleBtnAbort x btn = x <* btn
+ ((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . withGlobalPostParam PostDBCsvReImport () . withButtonFormCombM' handleBtnAbort importButtons . identifyForm (FIDDBTableCsvImport dbtIdent) . renderAForm FormDBTableCsvImport $ DBCsvImport
<$> areq fileFieldMultiple (fslI MsgCsvFile) Nothing
+ exportExampleRes <- guardOn <$> hasGlobalGetParam GetCsvExampleData <*> pure DBCsvExportExample
let
csvMode = asum
- [ csvExportRes <* guard (is _Just dbtCsvEncode)
+ [ maybe FormMissing FormSuccess exportExampleRes
+ , csvExportRes <* guard (is _Just dbtCsvEncode)
, csvImportRes <* guard (is _Just dbtCsvDecode)
, FormSuccess DBCsvNormal
]
@@ -926,12 +985,12 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
, formSubmit = FormSubmit
, formAnchor = Just $ wIdent "csv-export"
}
- csvImportWdgt' = wrapForm' BtnCsvImport csvImportWdgt FormSettings
+ csvImportWdgt' = wrapForm csvImportWdgt FormSettings
{ formMethod = POST
, formAction = Just $ tblLink id
, formEncoding = csvImportEnctype
, formAttrs = []
- , formSubmit = FormSubmit
+ , formSubmit = FormNoSubmit
, formAnchor = Just $ wIdent "csv-import"
}
csvImportExplanation :: Widget
@@ -943,29 +1002,45 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
Just csvColExplanations'' -> modal [whamlet|_{MsgCsvColumnsExplanationsLabel}|] $ Right $(widgetFile "table/csv-column-explanations")
Nothing -> mempty
+ psFilter' = imap (\key args -> (, args) $ Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) psFilter
+
+ primarySortSql = flip has psSorting' $ _head . _1 . to sqlSortDirection . _Just
+
+ sortSql :: _ -> [E.SqlExpr E.OrderBy]
+ sortSql t = concatMap (\(f, d) -> f d t) $ mapMaybe (\(c, d) -> (, d) <$> sqlSortDirection c) psSorting'
+
+ filterSql :: Map FilterKey (Maybe (_ -> E.SqlExpr (E.Value Bool)))
+ filterSql = map (\(fc, args) -> ($ args) <$> filterColumn fc) $ psFilter'
+
+ selectPagesize = primarySortSql
+ && all (is _Just) filterSql
+
+ psLimit' = bool PagesizeAll psLimit selectPagesize
+
rows' <- E.select . E.from $ \t -> do
res <- dbtSQLQuery t
- E.orderBy $ concatMap (sqlSortDirection t) psSorting'
+ E.orderBy $ sortSql t
case csvMode of
- FormSuccess DBCsvExport{} -> return ()
- FormSuccess DBCsvImport{} -> return ()
+ -- FormSuccess DBCsvExport{} -> return ()
+ FormSuccess DBCsvImport{} -> return () -- don't apply filter and sorting for csv _import_; we expect all rows to be available for matching with provided csv
_other -> do
case previousKeys of
Nothing
- | PagesizeLimit l <- psLimit
+ | PagesizeLimit l <- psLimit'
+ , selectPagesize
-> do
E.limit l
E.offset (psPage * l)
Just ps -> E.where_ $ dbtRowKey t `E.sqlIn` ps
_other -> return ()
- Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter
+ Map.foldr (\fc expr -> maybe (return ()) (E.where_ . ($ t)) fc >> expr) (return ()) filterSql
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v
firstRow :: Int64
firstRow
- | PagesizeLimit l <- psLimit
+ | PagesizeLimit l <- psLimit'
= succ (psPage * l)
| otherwise
= 1
@@ -975,10 +1050,39 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
| otherwise
= id
- (currentKeys, rows) <- fmap unzip . mapMaybeM' dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
+ allFilterProjected r' = lift $ getAll <$> foldMapM (\(f, args) -> All <$> filterProjected f r' args) psFilter'
+ sortProjected
+ | is _Just previousKeys
+ = id
+ | primarySortSql
+ = id
+ | otherwise
+ = sortBy $ concatMap (\(c, d) (_, r) (_, r') -> adjustOrder d $ sortDirectionProjected c r r') psSorting'
+ where
+ adjustOrder SortAsc x = x
+ adjustOrder SortDesc LT = GT
+ adjustOrder SortDesc EQ = EQ
+ adjustOrder SortDesc GT = LT
+
+ (currentKeys, rows) <- fmap (unzip . sortProjected) . mapMaybeM' (assertMM allFilterProjected . lift . dbtProj) . map (\(E.Value dbrCount, dbrKey, dbrOutput) -> (dbrKey, DBRow{..})) $ reproduceSorting rows'
+
+ csvExample <- runMaybeT $ do
+ DBTCsvEncode{..} <- hoistMaybe dbtCsvEncode
+ exData <- hoistMaybe dbtCsvExampleData
+ hdr <- lift $ dbtCsvHeader Nothing
+ exportUrl <- toTextUrl (currentRoute, [(toPathPiece GetCsvExampleData, "")])
+ return $(widgetFile "table/csv-example")
formResult csvMode $ \case
+ DBCsvAbort{} -> do
+ addMessageI Info MsgCsvImportAborted
+ redirect $ tblLink id
+ DBCsvExportExample{}
+ | Just DBTCsvEncode{..} <- dbtCsvEncode
+ , Just exData <- dbtCsvExampleData -> do
+ hdr <- dbtCsvHeader Nothing
+ sendResponse <=< liftHandler . respondCsv hdr $ C.sourceList exData
DBCsvExport{..}
| Just DBTCsvEncode{..} <- dbtCsvEncode
, Just exportData <- fromDynamic dbCsvExportData -> do
@@ -993,10 +1097,10 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
, ..
} :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do
let existing = Map.fromList $ zip currentKeys rows
- sourceDiff :: ConduitT () (DBCsvDiff r' csv k') (StateT (Map k' csv) (YesodDB UniWorX)) ()
+ sourceDiff :: ConduitT () (DBCsvDiff r' csv k') (StateT (Map k' csv) DB) ()
sourceDiff = do
let
- toDiff :: csv -> StateT (Map k' csv) (YesodDB UniWorX) (DBCsvDiff r' csv k')
+ toDiff :: csv -> StateT (Map k' csv) DB (DBCsvDiff r' csv k')
toDiff row = do
rowKey <- lift $
handle (throwM . (DBCsvException (toNamedRecord row) :: Text -> DBCsvException k') <=< dbtCsvRenderException) . runMaybeT $ dbtCsvRowKey row
@@ -1010,7 +1114,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
-> return $ DBCsvDiffExisting rowKey' oldRow row
| otherwise
-> return $ DBCsvDiffNew rowKey row
- mapM_ fileSourceCsv dbCsvFiles .| C.mapM toDiff
+ transPipe liftHandler dbCsvFiles .| fileSourceCsv .| C.mapM toDiff
seen <- State.get
forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if
@@ -1022,7 +1126,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
importCsv = do
let
- dbtCsvComputeActions' :: ConduitT (DBCsvDiff r' csv k') Void (YesodDB UniWorX) (Map csvActionClass (Set csvAction))
+ dbtCsvComputeActions' :: ConduitT (DBCsvDiff r' csv k') Void DB (Map csvActionClass (Set csvAction))
dbtCsvComputeActions' = do
let innerAct = awaitForever $ \x
-> let doHandle
@@ -1038,6 +1142,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
addMessageI Info MsgCsvImportUnnecessary
redirect $ tblLink id
+ E.transactionSave -- If dbtCsvComputeActions has side-effects, commit those
+
liftHandler . (>>= sendResponse) $
siteLayoutMsg MsgCsvImportConfirmationHeading $ do
setTitleI MsgCsvImportConfirmationHeading
@@ -1061,18 +1167,20 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|]
fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False
- (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
- let csvImportConfirmForm = wrapForm' BtnCsvImportConfirm csvImportConfirmForm' FormSettings
+ (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
+ let csvImportConfirmForm = wrapForm csvImportConfirmForm' FormSettings
{ formMethod = POST
, formAction = Just $ tblLink id
, formEncoding = csvImportConfirmEnctype
, formAttrs = []
- , formSubmit = FormSubmit
+ , formSubmit = FormNoSubmit
, formAnchor = Nothing :: Maybe Text
}
$(widgetFile "csv-import-confirmation-wrapper")
+ csvReImport = $(widgetFile "table/csv-reimport")
+
hdr <- dbtCsvHeader Nothing
catches importCsv
[ Catch.Handler $ \case
@@ -1086,9 +1194,13 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
siteLayoutMsg heading $ do
setTitleI heading
[whamlet|
- _{MsgDBCsvDuplicateKey}
-
_{MsgDBCsvDuplicateKeyTip}
- ^{offendingCsv}
+ $newline never
+
+ _{MsgDBCsvDuplicateKey}
+
_{MsgDBCsvDuplicateKeyTip}
+ ^{offendingCsv}
+
+ ^{csvReImport}
|]
(DBCsvException{..} :: DBCsvException k')
-> liftHandler $ sendResponseStatus badRequest400 =<< do
@@ -1100,18 +1212,43 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
siteLayoutMsg heading $ do
setTitleI heading
[whamlet|
- _{MsgDBCsvException}
- $if not (Text.null dbCsvException)
-
#{dbCsvException}
- ^{ offendingCsv}
+ $newline never
+
+ _{MsgDBCsvException}
+ $if not (Text.null dbCsvException)
+
#{dbCsvException}
+ ^{offendingCsv}
+
+ ^{csvReImport}
|]
+ , Catch.Handler $ \(csvParseError :: CsvParseError)
+ -> liftHandler $ sendResponseStatus badRequest400 =<< do
+ mr <- getMessageRender
+
+ let heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvParseError]
+
+ siteLayoutMsg heading $ do
+ setTitleI heading
+ [whamlet|
+ $newline never
+
+ _{MsgDBCsvParseErrorTip}
+
+ $case csvParseError
+ $of CsvParseError _ errMsg
+ #{errMsg}
+ $of IncrementalError errMsg
+ #{errMsg}
+
+ ^{csvReImport}
+ |]
]
_other -> return ()
let
rowCount
- | (E.Value n, _, _):_ <- rows' = n
- | otherwise = 0
+ | selectPagesize = fromMaybe 0 $ rows' ^? _head . _1 . _Value
+ | otherwise = olength64 rows
rawAction = tblLink
$ setParam (wIdent "sorting") Nothing
@@ -1133,8 +1270,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
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")
+ DBSTCourse{} -> return $(widgetFile "table/course/header")
+ DBSTDefault{} -> return $(widgetFile "table/cell/header")
in do
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
case dbsTemplate of
@@ -1149,15 +1286,17 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
courseAllocation = row' ^? a
in return $(widgetFile "table/course/course-teaser")
return $(widgetFile "table/course/colonnade")
- DBSTDefault -> do
- wRows <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
+ DBSTDefault{..} -> do
+ wRows' <- forM rows $ \row' -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row') -> cell') -> do
widget <- cell' ^. cellContents
let attrs = cell' ^. cellAttrs
return $(widgetFile "table/cell/body")
+ let numberColumn = dbstmNumber rowCount
+ wRows = zip [firstRow..] wRows'
return $(widgetFile "table/colonnade")
pageCount
- | PagesizeLimit l <- psLimit
+ | PagesizeLimit l <- psLimit'
= max 1 . ceiling $ rowCount % l
| otherwise
= 1
@@ -1167,14 +1306,17 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
{ formMethod = GET
, formAction = Just . SomeRoute $ rawAction :#: wIdent "table-wrapper"
, formEncoding = pagesizeEnc
- , formAttrs = [("class", "pagesize")]
+ , formAttrs = [("class", "pagesize"), ("autocomplete", "off")]
, formSubmit = FormAutoSubmit
, formAnchor = Just $ wIdent "pagesize-form"
}
+ showPagesizeWdgt = toEnum (fromIntegral rowCount) > minimum (pagesizeOptions referencePagesize)
+ && selectPagesize
csvWdgt = $(widgetFile "table/csv-transcode")
- uiLayout table = csvWdgt <> dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout")
+ uiLayout :: Widget -> Widget
+ uiLayout table = dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout")
dbInvalidateResult' = foldr (<=<) return . catMaybes $
[ do
@@ -1183,11 +1325,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
return . dbInvalidateResult dbtParams . DBTIRowsMissing $ length previousKeys - length currentKeys
]
- ((csvImportConfirmRes, ()), _enctype) <- case dbtCsvDecode of
+ ((csvImportConfirmRes, _confirmView), _enctype) <- case dbtCsvDecode of
Just (DBTCsvDecode{dbtCsvExecuteActions} :: DBTCsvDecode r' k' csv) -> do
- lift . runFormPost . identifyForm FIDDBTableCsvImportConfirm $ \_csrf -> do
+ lift . runFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \_csrf -> do
acts <- globalPostParamFields PostDBCsvImportAction secretJsonField
- return . (, ()) $ if
+ return . (, mempty) $ if
| null acts -> FormSuccess $ do
addMessageI Info MsgCsvImportAborted
redirect $ tblLink id
@@ -1196,10 +1338,21 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
addMessageI Success . MsgCsvImportSuccessful $ length acts
E.transactionSave
redirect finalDest
- _other -> return ((FormMissing, ()), mempty)
- formResult csvImportConfirmRes id
+ _other -> return ((FormMissing, mempty), mempty)
+ formResult csvImportConfirmRes $ \case
+ (_, BtnCsvImportAbort) -> do
+ addMessageI Info MsgCsvImportAborted
+ redirect $ tblLink id
+ (act, _) -> act
- dbInvalidateResult' <=< bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout) (sendResponse <=< tblLayout . uiLayout <=< dbWidget (Proxy @m) (Proxy @x)) psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table'
+ let
+ wrapLayout :: DBResult m x -> DB (DBResult m x)
+ wrapLayout = dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout
+ shortcircuit :: forall void. DBResult m x -> DB void
+ shortcircuit res = do
+ addCustomHeader HeaderDBTableCanonicalURL =<< toTextUrl (tblLink substPi)
+ sendResponse =<< tblLayout . uiLayout =<< dbWidget (Proxy @m) (Proxy @x) res
+ dbInvalidateResult' <=< bool wrapLayout shortcircuit psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table'
where
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
tblLayout tbl' = do
@@ -1211,6 +1364,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
setParam :: Text -> Maybe Text -> QueryText -> QueryText
setParam key = setParams key . maybeToList
+
dbTableWidget :: Monoid x
=> PSValidator (HandlerFor UniWorX) x
@@ -1291,11 +1445,15 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
_{msg}
|]
+
-- | Always display widget; maybe a link if user is Authorized.
-- Also see variant `linkEmptyCell`
anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a
anchorCell = anchorCellM . return
+anchorCellC :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> url -> wgt -> DBCell m a
+anchorCellC cache = anchorCellCM cache . return
+
anchorCell' :: ( IsDBTable m a
, ToWidget UniWorX wgt
, HasRoute UniWorX url
@@ -1308,8 +1466,14 @@ anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX url -> wgt -> DBCell m a
anchorCellM routeM widget = anchorCellM' routeM id (const widget)
+anchorCellCM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX url -> wgt -> DBCell m a
+anchorCellCM cache routeM widget = anchorCellCM' cache routeM id (const widget)
+
anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget)
+
+anchorCellCM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, Binary cache) => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt) -> DBCell m a
+anchorCellCM' cache xM x2route x2widget = linkEitherCellCM' cache xM x2route (x2widget, x2widget)
maybeAnchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => MaybeT (WidgetFor UniWorX) url -> wgt -> DBCell m a
maybeAnchorCellM routeM widget = maybeAnchorCellM' routeM id (const widget)
@@ -1333,6 +1497,16 @@ linkEitherCellM' :: forall m url wgt wgt' a x.
=> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellM' (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust)
+linkEitherCellCM' :: forall m url wgt wgt' a x cache.
+ ( HasRoute UniWorX url
+ , ToWidget UniWorX wgt
+ , ToWidget UniWorX wgt'
+ , IsDBTable m a
+ , Binary cache
+ )
+ => cache -> WidgetFor UniWorX x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a
+linkEitherCellCM' cache xM x2route (x2widgetAuth,x2widgetUnauth) = maybeLinkEitherCellCM' (Just . toStrict $ B.encode cache) (lift xM) x2route (x2widgetAuth, x2widgetUnauth . fromJust)
+
maybeLinkEitherCellM' :: forall m url wgt wgt' a x.
( HasRoute UniWorX url
, ToWidget UniWorX wgt
@@ -1340,7 +1514,16 @@ maybeLinkEitherCellM' :: forall m url wgt wgt' a x.
, IsDBTable m a
)
=> MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a
-maybeLinkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
+maybeLinkEitherCellM' = maybeLinkEitherCellCM' Nothing
+
+maybeLinkEitherCellCM' :: forall m url wgt wgt' a x.
+ ( HasRoute UniWorX url
+ , ToWidget UniWorX wgt
+ , ToWidget UniWorX wgt'
+ , IsDBTable m a
+ )
+ => Maybe ByteString -> MaybeT (WidgetFor UniWorX) x -> (x -> url) -> (x -> wgt, Maybe x -> wgt') -> DBCell m a
+maybeLinkEitherCellCM' mCache xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
x' <- runMaybeT xM
case x' of
Just x -> do
@@ -1348,19 +1531,21 @@ maybeLinkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do
widget, widgetUnauth :: Widget
widget = toWidget $ x2widgetAuth x
widgetUnauth = toWidget . x2widgetUnauth $ Just x
- authResult <- liftHandler $ isAuthorized (urlRoute route) False
+ authResult <- liftHandler . maybe id $cachedHereBinary mCache . hasReadAccessTo $ urlRoute route
linkUrl <- toTextUrl route
- case authResult of
- Authorized -> $(widgetFile "table/cell/link") -- show allowed link
- _otherwise -> widgetUnauth -- show alternative widget
+ if
+ | authResult -> $(widgetFile "table/cell/link") -- show allowed link
+ | otherwise -> widgetUnauth
_otherwise -> do
toWidget $ x2widgetUnauth Nothing
-
-
listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
-listCell xs mkCell = review dbCell . ([], ) $ do
+listCell = listCell' . return
+
+listCell' :: (IsDBTable m a, Traversable f) => WriterT a m (f r') -> (r' -> DBCell m a) -> DBCell m a
+listCell' mkXS mkCell = review dbCell . ([], ) $ do
+ xs <- mkXS
cells <- forM xs $
\(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
return $(widgetFile "table/cell/list")
@@ -1403,10 +1588,6 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
-- Predefined colonnades
--- | Simple number column, also see Handler.Utils.Table.Columns.dbRowIndicator
-dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
-dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
-
dbSelect :: forall x h r i a. (Headedness h, Monoid' x)
=> Lens' x (FormResult (DBFormResult i a (DBRow r)))
-> Setter' a Bool
diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs
index e7d831cba..83266119f 100644
--- a/src/Handler/Utils/Tokens.hs
+++ b/src/Handler/Utils/Tokens.hs
@@ -1,6 +1,6 @@
module Handler.Utils.Tokens
( maybeBearerToken, requireBearerToken
- , maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions
+ , maybeCurrentBearerRestrictions, requireCurrentBearerRestrictions
) where
import Import
@@ -16,32 +16,32 @@ maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
requireBearerToken = liftHandler $ do
- token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askTokenUnsafe
+ bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe
mAuthId <- maybeAuthId
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- isWriteRequest currentRoute
- guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
- return token
+ guardAuthResult <=< runDB $ validateBearer mAuthId currentRoute isWrite bearer
+ return bearer
-requireCurrentTokenRestrictions :: ( MonadHandler m
+requireCurrentBearerRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
-requireCurrentTokenRestrictions = runMaybeT $ do
- token <- requireBearerToken
+requireCurrentBearerRestrictions = runMaybeT $ do
+ bearer <- requireBearerToken
route <- MaybeT getCurrentRoute
- hoistMaybe $ token ^? _tokenRestrictionIx route
+ hoistMaybe $ bearer ^? _bearerRestrictionIx route
-maybeCurrentTokenRestrictions :: ( MonadHandler m
+maybeCurrentBearerRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
-maybeCurrentTokenRestrictions = runMaybeT $ do
- token <- MaybeT maybeBearerToken
+maybeCurrentBearerRestrictions = runMaybeT $ do
+ bearer <- MaybeT maybeBearerToken
route <- MaybeT getCurrentRoute
- hoistMaybe $ token ^? _tokenRestrictionIx route
+ hoistMaybe $ bearer ^? _bearerRestrictionIx route
diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs
index dc23e8739..be010ee94 100644
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@@ -2,6 +2,8 @@ module Handler.Utils.Users
( computeUserAuthenticationDigest
, Digest, SHA3_256
, constEq
+ , NameMatchQuality(..)
+ , matchesName
, GuessUserInfo(..)
, guessUser
) where
@@ -21,6 +23,10 @@ import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
+import qualified Data.MultiSet as MultiSet
+import qualified Data.Map as Map
+import qualified Data.Text as Text
+
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
computeUserAuthenticationDigest = hashlazy . JSON.encode
@@ -36,14 +42,44 @@ instance Binary GuessUserInfo
makeLenses_ ''GuessUserInfo
+data NameMatchQuality
+ = NameMatchSuffix
+ | NameMatchPrefix
+ | NameMatchPermutation
+ | NameMatchEqual
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+matchesName :: Textual t
+ => t -- ^ haystack
+ -> t -- ^ needle
+ -> Maybe NameMatchQuality
+matchesName (repack -> haystack) (repack -> needle)
+ = fmap (view _1) . Map.lookupMax $ Map.filter id tests
+ where
+ asWords :: Text -> [CI Text]
+ asWords = map CI.mk . filter (not . Text.null) . Text.words . Text.strip
+
+ tests :: Map NameMatchQuality Bool
+ tests = mconcat
+ [ singletonMap NameMatchEqual $ asWords needle == asWords haystack
+ , singletonMap NameMatchPrefix $ asWords needle `isPrefixOf` asWords haystack
+ , singletonMap NameMatchSuffix $ asWords needle `isSuffixOf` asWords haystack
+ , singletonMap NameMatchPermutation $ ((==) `on` MultiSet.fromList) (asWords needle) (asWords haystack)
+ ]
+
guessUser :: Set GuessUserInfo -> DB (Maybe UserId)
guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
where
+ asWords :: Text -> [Text]
+ asWords = filter (not . Text.null) . Text.words . Text.strip
+
+ containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y
+
toSql user = \case
- GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
- GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `E.hasInfix` E.val userDisplayName'
- GuessUserSurname userSurname' -> user E.^. UserSurname `E.hasInfix` E.val userSurname'
- GuessUserFirstName userFirstName' -> user E.^. UserFirstName `E.hasInfix` E.val userFirstName'
+ GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
+ GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName'
+ GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname'
+ GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName'
go didLdap = do
let retrieveUsers = E.select . E.from $ \user -> do
@@ -58,31 +94,28 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
closeness :: Entity User -> Entity User -> Ordering
closeness = mconcat $ concat
[ pure $ comparing (fmap Down . matchesMatriculation)
- , (criteria ^.. folded . _guessUserSurname) <&> \surn -> comparing (preview $ _entityVal . _userSurname . to CI.mk . only (CI.mk surn))
- , (criteria ^.. folded . _guessUserFirstName) <&> \firstn -> comparing (preview $ _entityVal . _userFirstName . to CI.mk . only (CI.mk firstn))
- , (criteria ^.. folded . _guessUserDisplayName) <&> \dispn -> comparing (preview $ _entityVal . _userDisplayName . to CI.mk . only (CI.mk dispn))
+ , (criteria ^.. folded . _guessUserSurname) <&> \surn -> comparing (view $ _entityVal . _userSurname . to (`matchesName` surn))
+ , (criteria ^.. folded . _guessUserFirstName) <&> \firstn -> comparing (view $ _entityVal . _userFirstName . to (`matchesName` firstn))
+ , (criteria ^.. folded . _guessUserDisplayName) <&> \dispn -> comparing (view $ _entityVal . _userDisplayName . to (`matchesName` dispn))
]
doLdap userMatr = do
- app <- getYesod
- let ldap = (,) <$> app ^. _appLdapConf <*> app ^. _appLdapPool
- fmap (fmap entityKey . join) . for ldap $ \(ldapConf, ldapPool) -> do
- ldapData <- campusUserMatr' ldapConf ldapPool userMatr
+ ldapPool' <- getsYesod $ view _appLdapPool
+ fmap (fmap entityKey . join) . for ldapPool' $ \ldapPool -> do
+ ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
for ldapData $ upsertCampusUser UpsertCampusUser
-
- case users' of
- x@(Entity pid _) : xs
- | [] <- xs
- , fromMaybe False (matchesMatriculation x) || didLdap
- -> return $ Just pid
- | x' : _ <- xs
- , fromMaybe False (matchesMatriculation x) || didLdap
- , GT <- x `closeness` x'
- -> return $ Just pid
- | not didLdap
- , userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer
- , all (== userMatr) userMatrs'
- -> doLdap userMatr >>= maybe (go True) (return . Just)
- _other
+ if
+ | x@(Entity pid _) : [] <- users'
+ , fromMaybe False (matchesMatriculation x) || didLdap
+ -> return $ Just pid
+ | x@(Entity pid _) : x' : _ <- users'
+ , fromMaybe False (matchesMatriculation x) || didLdap
+ , GT <- x `closeness` x'
+ -> return $ Just pid
+ | not didLdap
+ , userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer
+ , all (== userMatr) userMatrs'
+ -> doLdap userMatr >>= maybe (go True) (return . Just)
+ | otherwise
-> return Nothing
diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs
index b9e5b5f95..1e1f1ea76 100644
--- a/src/Handler/Utils/Widgets.hs
+++ b/src/Handler/Utils/Widgets.hs
@@ -95,9 +95,58 @@ editedByW fmt tm usr = do
ft <- handlerToWidget $ formatTime fmt tm
[whamlet|_{MsgEditedBy usr ft}|]
-heat :: Integral a => a -> a -> Double
-heat (toInteger -> full) (toInteger -> achieved)
- = roundToDigits 3 $ cutOffPercent 0.3 (fromIntegral full^2) (fromIntegral achieved^2)
+heat :: ( Real a, Real b )
+ => a -> b -> Milli
+-- ^ Distinguishes @full@, zero is mapped to 1, @full@ is mapped to 0
+heat (realToFrac -> full) (realToFrac -> achieved)
+ = fromRational $ cutOffCoPercent 0.3 (full^2) (achieved^2)
+
+invHeat :: ( Real a, Real b )
+ => a -> b -> Milli
+-- ^ Distinguishes @full@, zero is mapped to 0, @full@ is mapped to 1
+invHeat full achieved = 1 - heat full achieved
+
+coHeat :: ( Real a, Real b)
+ => a -> b -> Milli
+-- ^ Distinguishes zero, zero is mapped to 1, @full@ is mapped to 0
+coHeat full achieved = 1 - invCoHeat full achieved
+
+invCoHeat :: ( Real a, Real b)
+ => a -> b -> Milli
+-- ^ Distinguishes zero, zero is mapped to 0, @full@ is mapped to 1
+invCoHeat (realToFrac -> full) (realToFrac -> achieved)
+ = fromRational $ cutOffPercent 0.3 (full^2) (achieved^2)
+
+
+dualHeat :: ( Real a, Real b, Real c )
+ => a -> b -> c -> Milli
+-- ^ Distinguishes zero, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2
+--
+-- Falls back to `invCoHeat` if @full <= optimal@
+dualHeat (realToFrac -> optimal) (realToFrac -> full) (realToFrac -> achieved)
+ | full <= optimal = 2 * invCoHeat full achieved
+ | achieved <= optimal = invCoHeat optimal achieved
+ | otherwise = fromRational $ 1 + cutOffPercent 0 ((full - optimal) ^ 2) ((achieved - optimal) ^ 2)
+
+dualCoHeat :: ( Real a, Real b, Real c )
+ => a -> b -> c -> Milli
+-- ^ Distinguishes @full@, zero is mapped to 0, @optimal@ is mapped to 1, @full@ is mapped to 2
+--
+-- Falls back to `invHeat` if @full <= optimal@
+dualCoHeat (realToFrac -> optimal) (realToFrac -> full) (realToFrac -> achieved)
+ | full <= optimal = 2 * invHeat full achieved
+ | achieved <= optimal = fromRational $ cutOffPercent 0 (optimal ^ 2) (achieved ^ 2)
+ | otherwise = 1 + invHeat (full - optimal) (achieved - optimal)
+
+invDualHeat :: ( Real a, Real b, Real c )
+ => a -> b -> c -> Milli
+-- ^ Distinguishes zero, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
+invDualHeat optimal full achieved = 2 - dualHeat optimal full achieved
+
+invDualCoHeat :: ( Real a, Real b, Real c )
+ => a -> b -> c -> Milli
+-- ^ Distinguishes @full@, zero is mapped to 2, @optimal@ is mapped to 1, @full@ is mapped to 0
+invDualCoHeat optimal full achieved = 2 - dualCoHeat optimal full achieved
i18n :: forall m msg.
( MonadWidget m
diff --git a/src/Import.hs b/src/Import.hs
index cf2787a10..b93336ae8 100644
--- a/src/Import.hs
+++ b/src/Import.hs
@@ -7,3 +7,5 @@ import Import.NoFoundation as Import
import Utils.SystemMessage as Import
import Utils.Metrics as Import
+
+import Jobs.Types as Import (JobHandler(..))
diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs
index c2f083f37..1e3925395 100644
--- a/src/Import/NoFoundation.hs
+++ b/src/Import/NoFoundation.hs
@@ -12,6 +12,7 @@ import Utils.Tokens as Import
import Utils.Frontend.Modal as Import
import Utils.Frontend.Notification as Import
import Utils.Lens as Import
+import Utils.Failover as Import
import Settings as Import
import Settings.StaticFiles as Import
@@ -19,3 +20,6 @@ import Settings.WellKnownFiles as Import
import CryptoID as Import
import Audit as Import
+
+import Web.ServerSession.Backend.Persistent.Memcached as Import
+import Web.ServerSession.Backend.Acid as Import (AcidStorage(..))
diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs
index 04d714ef3..4103d5595 100644
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@@ -59,8 +59,9 @@ import Data.Hashable as Import
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Min(..), Max(..))
-import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..))
+import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..))
import Data.Binary as Import (Binary)
+import Data.Binary.Instances as Import ()
import System.FilePath as Import hiding (joinPath, normalise, isValid, makeValid)
@@ -69,7 +70,7 @@ import Data.Ratio as Import ((%))
import Net.IP as Import (IP)
-import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey)
+import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, IsSqlBackend, fromSqlKey, toSqlKey)
import Ldap.Client.Pool as Import
@@ -90,12 +91,17 @@ import Control.Monad.Trans.Writer.Lazy as Import
( writer, Writer, runWriter, mapWriter, execWriter
, WriterT(..), mapWriterT, execWriterT
)
+import Control.Monad.Trans.Except as Import
+ ( except, Except, runExcept, mapExcept
+ , ExceptT(..), runExceptT, mapExceptT, throwE
+ )
import Control.Monad.Base as Import
import Control.Monad.Catch as Import hiding (Handler(..))
import Control.Monad.Trans.Control as Import hiding (embed)
import Control.Monad.Fail as Import
-import Jose.Jwt as Import (Jwt)
+import Jose.Jwk as Import (JwkSet, Jwk(..))
+import Jose.Jwt as Import (Jwt(..))
import Data.Time.Calendar as Import
import Data.Time.Clock as Import
@@ -112,6 +118,8 @@ import Algebra.Lattice as Import
import Data.Proxy as Import (Proxy(..))
+import Data.List.PointedList as Import (PointedList)
+
import Language.Haskell.TH.Instances as Import ()
import Data.NonNull.Instances as Import ()
import Data.Monoid.Instances as Import ()
@@ -121,9 +129,6 @@ import Data.Sum.Instances as Import ()
import Data.Fixed.Instances as Import ()
import Data.Scientific.Instances as Import ()
import Data.Set.Instances as Import ()
-import Data.HashMap.Strict.Instances as Import ()
-import Data.HashSet.Instances as Import ()
-import Data.Vector.Instances as Import ()
import Data.Time.Clock.Instances as Import ()
import Data.Time.LocalTime.Instances as Import ()
import Data.Time.Calendar.Instances as Import ()
@@ -150,8 +155,13 @@ import Data.Bool.Instances as Import ()
import Data.Encoding.Instances as Import ()
import Prometheus.Instances as Import ()
import Yesod.Form.Fields.Instances as Import ()
+import Data.MonoTraversable.Instances as Import ()
+import Web.Cookie.Instances as Import ()
+import Network.HTTP.Types.Method.Instances as Import ()
+import Crypto.Random.Instances as Import ()
import Crypto.Hash as Import (Digest, SHA3_256)
+import Crypto.Random as Import (ChaChaDRG, Seed)
import Control.Lens as Import
hiding ( (<.>)
@@ -162,11 +172,13 @@ import Control.Lens as Import
import Control.Lens.Extras as Import (is)
import Data.Set.Lens as Import
-import Control.Arrow as Import (Kleisli(..))
+import Control.Arrow as Import (left, right, Kleisli(..))
import Data.Encoding as Import (DynEncoding, decodeLazyByteString, encodeLazyByteString)
import Data.Encoding.UTF8 as Import (UTF8(UTF8))
+import GHC.TypeLits as Import (KnownSymbol)
+
import Control.Monad.Trans.RWS (RWST)
diff --git a/src/Jobs.hs b/src/Jobs.hs
index 600294731..65e0335e2 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -85,11 +85,9 @@ handleJobs :: ( MonadResource m
handleJobs foundation@UniWorX{..}
| foundation ^. _appJobWorkers == 0 = return ()
| otherwise = do
- UnliftIO{..} <- askUnliftIO
+ jobPoolManager <- allocateLinkedAsyncWithUnmask $ \unmask -> manageJobPool foundation unmask
- jobPoolManager <- allocateLinkedAsyncWithUnmask $ \unmask -> unliftIO $ manageJobPool foundation unmask
-
- jobCron <- allocateLinkedAsync . unliftIO $ manageCrontab foundation
+ jobCron <- allocateLinkedAsync $ manageCrontab foundation
let jobWorkers = Map.empty
jobWorkerName = const $ error "Unknown worker"
@@ -121,7 +119,7 @@ manageJobPool :: forall m.
, MonadUnliftIO m
, MonadMask m
)
- => UniWorX -> (forall a. IO a -> IO a) -> m ()
+ => UniWorX -> (forall a. m a -> m a) -> m ()
manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $
flip runContT return . forever . join . atomically $ asum
[ spawnMissingWorkers
@@ -131,9 +129,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $
where
shutdownOnException :: m a -> m a
shutdownOnException act = do
- UnliftIO{..} <- askUnliftIO
-
- actAsync <- allocateLinkedAsyncMasked $ unliftIO act
+ actAsync <- allocateLinkedAsyncMasked act
let handleExc e = do
atomically $ do
@@ -143,7 +139,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $
void $ wait actAsync
throwM e
- liftIO (unmask $ wait actAsync) `catchAll` handleExc
+ unmask (wait actAsync) `catchAll` handleExc
num :: Int
num = fromIntegral $ foundation ^. _appJobWorkers
@@ -174,11 +170,11 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $
Nothing -> retry
Just (j, q) -> j <$ writeTVar chan q
return $ yield nextVal >> streamChan
- runWorker = unsafeHandler foundation . flip runReaderT (jobContext oldState) . withJobWorkerState workerId Nothing JobWorkerIdle $ do
+ runWorker = unsafeHandler foundation . flip runReaderT (jobContext oldState) $ do
$logInfoS logIdent "Started"
runConduit $ streamChan .| handleJobs' workerId
$logInfoS logIdent "Stopped"
- worker <- lift . lift $ allocateLinkedAsync runWorker
+ worker <- lift . lift . allocateLinkedAsync $ liftIO runWorker
tell . Endo $ \cSt -> cSt
{ jobWorkers = Map.insert worker chan $ jobWorkers cSt
@@ -357,9 +353,9 @@ mkLogIdent :: JobWorkerId -> Text
mkLogIdent wId = "Job-Executor " <> showWorkerId wId
handleJobs' :: JobWorkerId -> ConduitT JobCtl Void (ReaderT JobContext Handler) ()
-handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum (Just JobWorkerIdle) JobWorkerBusy $ do
+handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum JobWorkerBusy $ do
$logDebugS logIdent $ tshow jctl
- res <- fmap (either Just $ const Nothing) . withJobWorkerState wNum (Just JobWorkerBusy) (JobWorkerExecJobCtl jctl) . try $ handleCmd jctl
+ res <- fmap (either Just $ const Nothing) . withJobWorkerState wNum (JobWorkerExecJobCtl jctl) . try $ handleCmd jctl
sentRes <- mapReaderT (liftIO . atomically) $ do
resVars <- HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm)
lift $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars)
@@ -378,7 +374,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum (Just JobWorkerIdl
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 jctl@(JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do
+ handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do
content <- case fromJSON queuedJobContent of
Aeson.Success c -> return c
Aeson.Error t -> do
@@ -389,25 +385,28 @@ handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum (Just JobWorkerIdl
instanceID' <- getsYesod $ view instanceID
now <- liftIO getCurrentTime
-
- performJob content
- & withJobDuration (classifyJob content)
- & withJobWorkerState wNum (Just $ JobWorkerExecJobCtl jctl) (JobWorkerExecJob content)
- -- `performJob` is expected to throw an exception if it detects that the job was not done
- runDB . setSerializable $ do
- when queuedJobWriteLastExec $
- void $ upsertBy
- (UniqueCronLastExec queuedJobContent)
- CronLastExec
- { cronLastExecJob = queuedJobContent
- , cronLastExecTime = now
- , cronLastExecInstance = instanceID'
- }
- [ CronLastExecTime =. now
- , CronLastExecInstance =. instanceID'
- ]
- delete jId
+ let cleanup = do
+ when queuedJobWriteLastExec $
+ void $ upsertBy
+ (UniqueCronLastExec queuedJobContent)
+ CronLastExec
+ { cronLastExecJob = queuedJobContent
+ , cronLastExecTime = now
+ , cronLastExecInstance = instanceID'
+ }
+ [ CronLastExecTime =. now
+ , CronLastExecInstance =. instanceID'
+ ]
+ delete jId
+
+ case performJob content of
+ JobHandlerAtomic act -> runDBJobs . setSerializable $ do
+ act & withJobWorkerState wNum (JobWorkerExecJob content)
+ hoist lift cleanup
+ JobHandlerException act -> do
+ act & withJobWorkerState wNum (JobWorkerExecJob content)
+ runDB $ setSerializable cleanup
handleCmd JobCtlDetermineCrontab = do
newCTab <- liftHandler . runDB $ setSerializable determineCrontab'
-- logDebugS logIdent $ tshow newCTab
@@ -484,5 +483,5 @@ determineCrontab' :: DB (Crontab JobCtl)
determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab
-performJob :: Job -> HandlerFor UniWorX ()
+performJob :: Job -> JobHandler UniWorX
performJob = $(dispatchTH ''Job)
diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs
index b631b052e..c087a1b3a 100644
--- a/src/Jobs/Crontab.hs
+++ b/src/Jobs/Crontab.hs
@@ -16,7 +16,6 @@ import Data.Time.Zones
import Data.Time.Clock.POSIX
import Handler.Utils.DateTime
-import Handler.Utils.Allocation (allocationDone)
import Control.Monad.Writer.Class (MonadWriter(..))
@@ -379,7 +378,9 @@ determineCrontab = execWriterT $ do
}
_other
-> return ()
- doneSince <- lift $ allocationDone nAllocation
+ doneSince <- lift $ fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \participant -> do
+ E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
+ return . E.max_ $ participant E.^. CourseParticipantRegistration
whenIsJust doneSince $ \doneSince' ->
tell $ HashMap.singleton
diff --git a/src/Jobs/Handler/ChangeUserDisplayEmail.hs b/src/Jobs/Handler/ChangeUserDisplayEmail.hs
index 1e2627b84..52daa4188 100644
--- a/src/Jobs/Handler/ChangeUserDisplayEmail.hs
+++ b/src/Jobs/Handler/ChangeUserDisplayEmail.hs
@@ -10,10 +10,10 @@ import qualified Data.CaseInsensitive as CI
import Text.Hamlet
-dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> Handler ()
-dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = do
- token <- tokenRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
- jwt <- encodeToken token
+dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> JobHandler UniWorX
+dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = JobHandlerException $ do
+ bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (HashSet.singleton $ Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
+ jwt <- encodeBearer bearer
let
setDisplayEmailUrl :: SomeRoute UniWorX
setDisplayEmailUrl = SomeRoute (SetDisplayEmailR, [(toPathPiece GetBearer, toPathPiece jwt)])
diff --git a/src/Jobs/Handler/DistributeCorrections.hs b/src/Jobs/Handler/DistributeCorrections.hs
index af61ddfb7..21e91d905 100644
--- a/src/Jobs/Handler/DistributeCorrections.hs
+++ b/src/Jobs/Handler/DistributeCorrections.hs
@@ -12,8 +12,8 @@ import qualified Data.Set as Set
dispatchJobDistributeCorrections :: SheetId
- -> Handler ()
-dispatchJobDistributeCorrections jSheet = runDBJobs $ do
- (_, unassigned) <- mapReaderT lift $ assignSubmissions jSheet Nothing
- unless (Set.null unassigned) $
+ -> JobHandler UniWorX
+dispatchJobDistributeCorrections jSheet = JobHandlerAtomic $ do
+ unassigned <- runMaybeT . catchMaybeT (Proxy @AssignSubmissionException) . fmap (view _2) . hoist lift $ assignSubmissions jSheet Nothing
+ unless (maybe False Set.null unassigned) $
queueDBJob . JobQueueNotification $ NotificationCorrectionsNotDistributed jSheet
diff --git a/src/Jobs/Handler/HelpRequest.hs b/src/Jobs/Handler/HelpRequest.hs
index b4e9c5b69..ca07dee2b 100644
--- a/src/Jobs/Handler/HelpRequest.hs
+++ b/src/Jobs/Handler/HelpRequest.hs
@@ -15,10 +15,11 @@ import Data.Bitraversable
dispatchJobHelpRequest :: Either (Maybe Address) UserId
-> UTCTime
-> Maybe Text -- ^ Help Subject
- -> Html -- ^ Help Request
+ -> Maybe Html -- ^ Help Request
-> Maybe Text -- ^ Referer
- -> Handler ()
-dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
+ -> Maybe ErrorResponse
+ -> JobHandler UniWorX
+dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer jError = JobHandlerException $ do
supportAddress <- getsYesod $ view _appMailSupport
userInfo <- bitraverse return (runDB . getEntity) jSender
let senderAddress = either
@@ -32,4 +33,15 @@ dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer =
setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject
setDate jRequestTime
rtime <- formatTimeMail SelFormatDateTime jRequestTime
+
+ errPartName <- for jError $ \_ -> do
+ objId <- setMailObjectIdRandom
+ mr <- getMailMessageRender
+ return . mr $ MsgHelpErrorYamlFilename objId
+
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+
+ whenIsJust ((,) <$> jError <*> errPartName) $ \(err, partName) -> addPart' $ do
+ toMailPart $ toYAML err
+ _partDisposition .= InlineDisposition partName
+
diff --git a/src/Jobs/Handler/Invitation.hs b/src/Jobs/Handler/Invitation.hs
index 01339cffd..56d7203c9 100644
--- a/src/Jobs/Handler/Invitation.hs
+++ b/src/Jobs/Handler/Invitation.hs
@@ -14,8 +14,8 @@ dispatchJobInvitation :: UserId
-> Text
-> Text
-> Html
- -> Handler ()
-dispatchJobInvitation jInviter jInvitee jInvitationUrl jInvitationSubject jInvitationExplanation = do
+ -> JobHandler UniWorX
+dispatchJobInvitation jInviter jInvitee jInvitationUrl jInvitationSubject jInvitationExplanation = JobHandlerException $ do
mInviter <- runDB $ get jInviter
whenIsJust mInviter $ \jInviter' -> mailT def $ do
diff --git a/src/Jobs/Handler/PruneFiles.hs b/src/Jobs/Handler/PruneFiles.hs
index 43289dab6..d49b198dc 100644
--- a/src/Jobs/Handler/PruneFiles.hs
+++ b/src/Jobs/Handler/PruneFiles.hs
@@ -11,28 +11,28 @@ import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
-dispatchJobPruneSessionFiles :: Handler ()
-dispatchJobPruneSessionFiles = do
+dispatchJobPruneSessionFiles :: JobHandler UniWorX
+dispatchJobPruneSessionFiles = JobHandlerAtomic . hoist lift $ do
now <- liftIO getCurrentTime
expires <- getsYesod $ view _appSessionFilesExpire
- n <- runDB $ deleteWhereCount [ SessionFileTouched <. addUTCTime (- expires) now ]
+ n <- deleteWhereCount [ SessionFileTouched <. addUTCTime (- expires) now ]
$logInfoS "PruneSessionFiles" [st|Deleted #{n} expired session files|]
-dispatchJobPruneUnreferencedFiles :: Handler ()
-dispatchJobPruneUnreferencedFiles = do
- n <- runDB . E.deleteCount . E.from $ \file ->
+dispatchJobPruneUnreferencedFiles :: JobHandler UniWorX
+dispatchJobPruneUnreferencedFiles = JobHandlerAtomic . hoist lift $ do
+ n <- E.deleteCount . E.from $ \file ->
E.where_ . E.not_ . E.any E.exists $ references file
$logInfoS "PruneUnreferencedFiles" [st|Deleted #{n} unreferenced files|]
where
references :: E.SqlExpr (Entity File) -> [E.SqlQuery ()]
references ((E.^. FileId) -> fId) =
- [ E.from $ \matching -> E.where_ $ matching E.^. AllocationMatchingLog E.==. fId
- , E.from $ \appInstr -> E.where_ $ appInstr E.^. CourseAppInstructionFileFile E.==. fId
- , E.from $ \appFile -> E.where_ $ appFile E.^. CourseApplicationFileFile E.==. fId
+ [ E.from $ \appFile -> E.where_ $ appFile E.^. CourseApplicationFileFile E.==. fId
, E.from $ \matFile -> E.where_ $ matFile E.^. MaterialFileFile E.==. fId
, E.from $ \newsFile -> E.where_ $ newsFile E.^. CourseNewsFileFile E.==. fId
- , E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileFile E.==. fId
, E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileFile E.==. fId
+ , E.from $ \appInstr -> E.where_ $ appInstr E.^. CourseAppInstructionFileFile E.==. fId
+ , E.from $ \matching -> E.where_ $ matching E.^. AllocationMatchingLog E.==. fId
, E.from $ \subFile -> E.where_ $ subFile E.^. SubmissionFileFile E.==. fId
+ , E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileFile E.==. fId
]
diff --git a/src/Jobs/Handler/PruneInvitations.hs b/src/Jobs/Handler/PruneInvitations.hs
index c9456454c..e7516f204 100644
--- a/src/Jobs/Handler/PruneInvitations.hs
+++ b/src/Jobs/Handler/PruneInvitations.hs
@@ -6,8 +6,8 @@ import Import
import Database.Persist.Sql (deleteWhereCount)
-dispatchJobPruneInvitations :: Handler ()
-dispatchJobPruneInvitations = do
+dispatchJobPruneInvitations :: JobHandler UniWorX
+dispatchJobPruneInvitations = JobHandlerAtomic . hoist lift $ do
now <- liftIO getCurrentTime
- n <- runDB $ deleteWhereCount [ InvitationExpiresAt <. Just now ]
- $logInfoS "PruneInvitations" [st|Deleted #{n} expired invitations|]
\ No newline at end of file
+ n <- deleteWhereCount [ InvitationExpiresAt <. Just now ]
+ $logInfoS "PruneInvitations" [st|Deleted #{n} expired invitations|]
diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs
index 394516dac..cb62e91ed 100644
--- a/src/Jobs/Handler/QueueNotification.hs
+++ b/src/Jobs/Handler/QueueNotification.hs
@@ -8,7 +8,6 @@ import Jobs.Types
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
-import Utils.Sql
import Jobs.Queue
import qualified Data.Set as Set
@@ -17,8 +16,8 @@ import Handler.Utils.ExamOffice.Exam
import Handler.Utils.ExamOffice.ExternalExam
-dispatchJobQueueNotification :: Notification -> Handler ()
-dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
+dispatchJobQueueNotification :: Notification -> JobHandler UniWorX
+dispatchJobQueueNotification jNotification = JobHandlerAtomic $ do
candidates <- hoist lift $ determineNotificationCandidates jNotification
nClass <- hoist lift $ classifyNotification jNotification
mapM_ (queueDBJob . flip JobSendNotification jNotification) $ do
@@ -37,12 +36,14 @@ determineNotificationCandidates NotificationSheetActive{..}
= E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+ E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetSoonInactive{..}
= E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+ E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetInactive{..}
@@ -82,6 +83,7 @@ determineNotificationCandidates NotificationExamRegistrationActive{..} =
E.where_ . E.not_ . E.exists . E.from $ \examRegistration ->
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val nExam
+ E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return user
determineNotificationCandidates NotificationExamRegistrationSoonInactive{..} =
E.select . E.from $ \(exam `E.InnerJoin` courseParticipant `E.InnerJoin` user) -> do
@@ -91,6 +93,7 @@ determineNotificationCandidates NotificationExamRegistrationSoonInactive{..} =
E.where_ . E.not_ . E.exists . E.from $ \examRegistration ->
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val nExam
+ E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return user
determineNotificationCandidates NotificationExamDeregistrationSoonInactive{..} =
E.select . E.from $ \(examRegistration `E.InnerJoin` user) -> do
@@ -218,11 +221,13 @@ determineNotificationCandidates notif@NotificationAllocationResults{..} = do
E.where_ $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
E.&&. participant E.^. CourseParticipantRegistration E.>. E.val t
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
hasAllocations t = E.exists . E.from $ \(lecturer `E.InnerJoin` participant) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.&&. lecturer E.^. LecturerCourse E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
E.&&. participant E.^. CourseParticipantRegistration E.>. E.val t
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
case lastExec of
Nothing -> E.where_ $ isStudent E.||. isLecturer
Just t -> E.where_ $ wasAllocated t E.||. hasAllocations t
diff --git a/src/Jobs/Handler/SendCourseCommunication.hs b/src/Jobs/Handler/SendCourseCommunication.hs
index 2030d0c29..cff458364 100644
--- a/src/Jobs/Handler/SendCourseCommunication.hs
+++ b/src/Jobs/Handler/SendCourseCommunication.hs
@@ -22,8 +22,8 @@ dispatchJobSendCourseCommunication :: Either UserEmail UserId
-> UUID
-> Maybe Text
-> Html
- -> Handler ()
-dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID jSubject jMailContent = do
+ -> JobHandler UniWorX
+dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID jSubject jMailContent = JobHandlerException $ do
(sender, Course{..}) <- runDB $ (,)
<$> getJust jSender
<*> getJust jCourse
diff --git a/src/Jobs/Handler/SendNotification.hs b/src/Jobs/Handler/SendNotification.hs
index cec2387bd..32e7c71e5 100644
--- a/src/Jobs/Handler/SendNotification.hs
+++ b/src/Jobs/Handler/SendNotification.hs
@@ -22,8 +22,8 @@ import Jobs.Handler.SendNotification.CourseRegistered
import Jobs.Handler.SendNotification.SubmissionEdited
-dispatchJobSendNotification :: UserId -> Notification -> Handler ()
-dispatchJobSendNotification jRecipient jNotification = do
+dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX
+dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ do
$(dispatchTH ''Notification) jNotification jRecipient
instanceID' <- getsYesod $ view instanceID
diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs
index c96ee4bb9..9932fef7c 100644
--- a/src/Jobs/Handler/SendNotification/Allocation.hs
+++ b/src/Jobs/Handler/SendNotification/Allocation.hs
@@ -167,9 +167,11 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi
allocatedCount = E.subSelectCount . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
let participantCount :: E.SqlExpr (E.Value Int64)
participantCount = E.subSelectCount . E.from $ \participant ->
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return (course, allocatedCount, participantCount)
let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value allocCount, E.Value partCount) -> SomeMessage $ if
| allocCount == partCount -> MsgAllocationResultLecturerAll courseShorthand allocCount
@@ -183,6 +185,7 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi
E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
E.&&. participant E.^. CourseParticipantUser E.==. E.val jRecipient
+ E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
return course
let participantResults = case participantResults' of
[] | doParticipantResults -> Just []
diff --git a/src/Jobs/Handler/SendNotification/Utils.hs b/src/Jobs/Handler/SendNotification/Utils.hs
index 111b43382..e60d20cfd 100644
--- a/src/Jobs/Handler/SendNotification/Utils.hs
+++ b/src/Jobs/Handler/SendNotification/Utils.hs
@@ -16,7 +16,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
mkEditNotifications uid = liftHandler $ do
cID <- encrypt uid
- jwt <- encodeToken =<< bearerToken (Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
+ jwt <- encodeBearer =<< bearerToken (HashSet.singleton $ Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
let
editNotificationsUrl :: SomeRoute UniWorX
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
diff --git a/src/Jobs/Handler/SendPasswordReset.hs b/src/Jobs/Handler/SendPasswordReset.hs
index ed1f10a6b..ce2aadd93 100644
--- a/src/Jobs/Handler/SendPasswordReset.hs
+++ b/src/Jobs/Handler/SendPasswordReset.hs
@@ -14,8 +14,8 @@ import qualified Data.HashSet as HashSet
import Text.Hamlet
dispatchJobSendPasswordReset :: UserId
- -> Handler ()
-dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
+ -> JobHandler UniWorX
+dispatchJobSendPasswordReset jRecipient = JobHandlerException . userMailT jRecipient $ do
cID <- encrypt jRecipient
User{..} <- liftHandler . runDB $ getJust jRecipient
@@ -29,11 +29,11 @@ dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
LTUUnique utc' _ -> utc'
_other -> UTCTime (addDays 2 $ utctDay now) 0
- resetToken' <- bearerToken (Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
- let resetToken = resetToken'
- & tokenRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
- encodedToken <- encodeToken resetToken
+ resetBearer' <- bearerToken (HashSet.singleton $ Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
+ let resetBearer = resetBearer'
+ & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
+ encodedBearer <- encodeBearer resetBearer
- resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedToken)])
+ resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedBearer)])
addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/passwordReset.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
diff --git a/src/Jobs/Handler/SendTestEmail.hs b/src/Jobs/Handler/SendTestEmail.hs
index b37264906..d396cc7c1 100644
--- a/src/Jobs/Handler/SendTestEmail.hs
+++ b/src/Jobs/Handler/SendTestEmail.hs
@@ -7,8 +7,8 @@ import Import
import Handler.Utils.Mail
import Handler.Utils.DateTime
-dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
-dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
+dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX
+dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do
_mailTo .= [Address Nothing jEmail]
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI MsgMailTestSubject
diff --git a/src/Jobs/Handler/SetLogSettings.hs b/src/Jobs/Handler/SetLogSettings.hs
index 8d7ecbbff..5aef4aebc 100644
--- a/src/Jobs/Handler/SetLogSettings.hs
+++ b/src/Jobs/Handler/SetLogSettings.hs
@@ -4,8 +4,8 @@ module Jobs.Handler.SetLogSettings
import Import
-dispatchJobSetLogSettings :: InstanceId -> LogSettings -> Handler ()
-dispatchJobSetLogSettings jInstance jLogSettings = do
+dispatchJobSetLogSettings :: InstanceId -> LogSettings -> JobHandler UniWorX
+dispatchJobSetLogSettings jInstance jLogSettings = JobHandlerException $ do
instanceId <- getsYesod appInstanceID
unless (instanceId == jInstance) . liftIO $ fail "Incorrect instance"
lSettings <- getsYesod appLogSettings
diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs
index 1c82569ed..26dcf2b82 100644
--- a/src/Jobs/Handler/SynchroniseLdap.hs
+++ b/src/Jobs/Handler/SynchroniseLdap.hs
@@ -17,9 +17,9 @@ data SynchroniseLdapException
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Exception SynchroniseLdapException
-dispatchJobSynchroniseLdap :: Natural -> Natural -> Natural -> Handler ()
+dispatchJobSynchroniseLdap :: Natural -> Natural -> Natural -> JobHandler UniWorX
dispatchJobSynchroniseLdap numIterations epoch iteration
- = runDBJobs . runConduit $
+ = JobHandlerAtomic . runConduit $
readUsers .| filterIteration .| sinkDBJobs
where
readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
@@ -36,17 +36,18 @@ dispatchJobSynchroniseLdap numIterations epoch iteration
return $ JobSynchroniseLdapUser userId
-dispatchJobSynchroniseLdapUser :: UserId -> Handler ()
-dispatchJobSynchroniseLdapUser jUser = do
+dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX
+dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
- case (,) <$> appLdapConf <*> appLdapPool of
- Just (ldapConf, ldapPool) ->
+ case appLdapPool of
+ Just ldapPool ->
runDB . void . runMaybeT . handleExc $ do
user@User{userIdent} <- MaybeT $ get jUser
$logInfoS "SynchroniseLdap" [st|Synchronising #{userIdent}|]
- ldapAttrs <- MaybeT $ campusUser' ldapConf ldapPool user
+ reTestAfter <- getsYesod $ view _appLdapReTestFailover
+ ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user
void . lift $ upsertCampusUser UpsertCampusUser ldapAttrs
Nothing ->
throwM SynchroniseLdapNoLdap
diff --git a/src/Jobs/Handler/TransactionLog.hs b/src/Jobs/Handler/TransactionLog.hs
index 0e131b05f..fb856ba2c 100644
--- a/src/Jobs/Handler/TransactionLog.hs
+++ b/src/Jobs/Handler/TransactionLog.hs
@@ -8,8 +8,8 @@ import Handler.Utils.DateTime
import Database.Persist.Sql (updateWhereCount, deleteWhereCount)
-dispatchJobTruncateTransactionLog, dispatchJobDeleteTransactionLogIPs :: Handler ()
-dispatchJobTruncateTransactionLog = do
+dispatchJobTruncateTransactionLog, dispatchJobDeleteTransactionLogIPs :: JobHandler UniWorX
+dispatchJobTruncateTransactionLog = JobHandlerAtomic . hoist lift $ do
now <- liftIO getCurrentTime
let localNow = utcToLocalTime now
(localCurrentYear, _, _) = toGregorian $ localDay localNow
@@ -20,12 +20,12 @@ dispatchJobTruncateTransactionLog = do
LTUUnique utc' _ -> utc'
_other -> startOfPreviousYear
- n <- runDB $ deleteWhereCount [ TransactionLogTime <. startOfPreviousYear' ]
+ n <- deleteWhereCount [ TransactionLogTime <. startOfPreviousYear' ]
$logInfoS "TruncateTransactionLog" [st|Deleted #{n} transaction log entries|]
-dispatchJobDeleteTransactionLogIPs = do
+dispatchJobDeleteTransactionLogIPs = JobHandlerAtomic . hoist lift $ do
now <- liftIO getCurrentTime
retentionTime <- getsYesod $ view _appTransactionLogIPRetentionTime
let cutoff = addUTCTime (- retentionTime) now
- n <- runDB $ updateWhereCount [ TransactionLogTime <. cutoff ] [ TransactionLogRemote =. Nothing ]
+ n <- updateWhereCount [ TransactionLogTime <. cutoff ] [ 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 97fc6e229..64d90d692 100644
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@@ -43,10 +43,10 @@ dispatchHealthCheckMatchingClusterConfig
ourSetting <- getsYesod appCryptoIDKey
dbSetting <- clusterSetting @'ClusterCryptoIDKey
return $ ((==) `on` fmap (ByteArray.convert :: CryptoIDKey -> ByteString)) (Just ourSetting) dbSetting
- clusterSettingMatches ClusterClientSessionKey = do
- ourSetting <- getsYesod appSessionKey
- dbSetting <- clusterSetting @'ClusterClientSessionKey
- return $ Just ourSetting == dbSetting
+ clusterSettingMatches ClusterServerSessionKey = do
+ ourSetting <- getsYesod . preview $ _appSessionStore . _SessionStorageMemcachedSql . _mcdSqlMemcachedKey
+ dbSetting <- clusterSetting @'ClusterServerSessionKey
+ return $ maybe True ((== dbSetting) . Just) ourSetting
clusterSettingMatches ClusterSecretBoxKey = do
ourSetting <- getsYesod appSecretBoxKey
dbSetting <- clusterSetting @'ClusterSecretBoxKey
@@ -59,6 +59,10 @@ dispatchHealthCheckMatchingClusterConfig
ourSetting <- getsYesod appClusterID
dbSetting <- clusterSetting @'ClusterId
return $ Just ourSetting == dbSetting
+ clusterSettingMatches ClusterMemcachedKey = do
+ ourSetting <- getsYesod $ fmap fst . appMemcached
+ dbSetting <- clusterSetting @'ClusterMemcachedKey
+ return $ maybe True ((== dbSetting) . Just) ourSetting
clusterSetting :: forall key.
@@ -89,21 +93,21 @@ dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _
dispatchHealthCheckLDAPAdmins :: Handler HealthReport
dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do
ldapPool' <- getsYesod appLdapPool
- ldapConf' <- getsYesod $ view _appLdapConf
- ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
- E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
- E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
- return $ user E.^. UserIdent
- case (,) <$> ldapPool' <*> ldapConf' of
- Just (ldapPool, ldapConf)
- | not $ null ldapAdminUsers
- -> do
- let numAdmins = genericLength ldapAdminUsers
- hCampusExc :: CampusUserException -> Handler (Sum Integer)
- hCampusExc _ = return $ Sum 0
- Sum numResolved <- fmap fold . forM ldapAdminUsers $
- \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUser ldapConf ldapPool (Creds "LDAP" adminIdent [])
- return . Just $ numResolved % numAdmins
+ reTestAfter <- getsYesod $ view _appLdapReTestFailover
+ case ldapPool' of
+ Just ldapPool -> do
+ ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` userFunction) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
+ E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
+ E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
+ E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
+ return $ user E.^. UserIdent
+ for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
+ let numAdmins = genericLength ldapAdminUsers
+ hCampusExc :: CampusUserException -> Handler (Sum Integer)
+ hCampusExc _ = return $ Sum 0
+ Sum numResolved <- fmap fold . forM ldapAdminUsers $
+ \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent [])
+ return $ numResolved % numAdmins
_other -> return Nothing
diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs
index 38158efe0..5275304d7 100644
--- a/src/Jobs/Queue.hs
+++ b/src/Jobs/Queue.hs
@@ -2,7 +2,7 @@ module Jobs.Queue
( writeJobCtl, writeJobCtlBlock
, writeJobCtl', writeJobCtlBlock'
, queueJob, queueJob'
- , YesodJobDB, JobDB
+ , JobDB
, runDBJobs, queueDBJob, sinkDBJobs
, runDBJobs'
, queueDBJobCron
@@ -108,9 +108,6 @@ queueJob' job = do
app <- getYesod
queueJob job >>= flip runReaderT app . writeJobCtl . JobCtlPerform
--- | Slightly modified Version of `YesodDB` for `runDBJobs`
-type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerFor site))
-
-- | Slightly modified Version of `DB` for `runDBJobs`
type JobDB = YesodJobDB UniWorX
diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs
index 54bb430cc..98f824381 100644
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@@ -6,6 +6,8 @@ module Jobs.Types
, classifyJob
, JobCtl(..)
, classifyJobCtl
+ , YesodJobDB
+ , JobHandler(..), _JobHandlerAtomic, _JobHandlerException
, JobContext(..)
, JobState(..)
, jobWorkerNames
@@ -42,8 +44,9 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
| JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
, jRequestTime :: UTCTime
, jSubject :: Maybe Text
- , jHelpRequest :: Html
+ , jHelpRequest :: Maybe Html
, jReferer :: Maybe Text
+ , jError :: Maybe ErrorResponse
}
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
| JobDistributeCorrections { jSheet :: SheetId }
@@ -148,16 +151,26 @@ deriveJSON defaultOptions
, sumEncoding = TaggedObject "instruction" "data"
} ''JobCtl
-
classifyJobCtl :: JobCtl -> String
classifyJobCtl jobctl = unpack tag
where
Aeson.Object obj = Aeson.toJSON jobctl
Aeson.String tag = obj HashMap.! "instruction"
+
+-- | Slightly modified Version of `YesodDB` for `runDBJobs`
+type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerFor site))
+
+data JobHandler site
+ = JobHandlerAtomic (YesodJobDB site ())
+ | JobHandlerException (HandlerFor site ())
+ deriving (Generic, Typeable)
+
+makePrisms ''JobHandler
+
+
data JobWorkerState
- = JobWorkerIdle
- | JobWorkerBusy
+ = JobWorkerBusy
| JobWorkerExecJobCtl { jobWorkerJobCtl :: JobCtl }
| JobWorkerExecJob { jobWorkerJob :: Job }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -182,9 +195,8 @@ classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCt
]
mJob = classifyJob <$> jws ^? _jobWorkerJob
-withJobWorkerState :: (MonadIO m, MonadMask m) => JobWorkerId -> Maybe JobWorkerState -> JobWorkerState -> m a -> m a
-withJobWorkerState wId oldSt newSt
- = withJobWorkerStateLbls (classifyJobWorkerState wId <$> oldSt) (classifyJobWorkerState wId newSt)
+withJobWorkerState :: (MonadIO m, MonadMask m) => JobWorkerId -> JobWorkerState -> m a -> m a
+withJobWorkerState wId newSt = withJobWorkerStateLbls $ classifyJobWorkerState wId newSt
newtype JobWorkerId = JobWorkerId { jobWorkerUnique :: Unique }
diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs
index 9a33e9e0f..d85028187 100644
--- a/src/Ldap/Client/Pool.hs
+++ b/src/Ldap/Client/Pool.hs
@@ -4,12 +4,14 @@ module Ldap.Client.Pool
( LdapPool
, LdapExecutor, Ldap, LdapError
, LdapPoolError(..)
- , withLdap
+ , withLdap, withLdapFailover, withLdapFailoverReTest
, createLdapPool
) where
import ClassyPrelude hiding (Handler, catches, try)
+import Utils.Failover
+
import Control.Lens
import Ldap.Client (Ldap, LdapError)
@@ -27,6 +29,9 @@ import Control.Monad.Trans.Resource (MonadResource)
import qualified Control.Monad.Trans.Resource as Resource
import Control.Monad.Catch
+import Control.Monad.Trans.Except (throwE)
+import Data.Fixed (Nano)
+
type LdapPool = Pool LdapExecutor
data LdapExecutor = LdapExecutor
@@ -41,8 +46,14 @@ data LdapPoolError = LdapPoolTimeout | LdapError LdapError
instance Exception LdapPoolError
-withLdap :: (MonadUnliftIO m, Typeable a) => LdapPool -> (Ldap -> m a) -> m (Either LdapPoolError a)
-withLdap pool act = withResource pool $ \LdapExecutor{..} -> ldapExec act
+withLdap :: (MonadUnliftIO m, MonadCatch m, Typeable a) => LdapPool -> (Ldap -> m a) -> m (Either LdapPoolError a)
+withLdap pool act = fmap join . try . withResource pool $ \LdapExecutor{..} -> ldapExec act
+
+withLdapFailover :: (MonadUnliftIO m, MonadCatch m, Typeable a) => Lens p p' LdapPool Ldap -> Failover p -> FailoverMode -> (p' -> m a) -> m (Either LdapPoolError a)
+withLdapFailover l@(flip withLens const -> proj) pool' mode act = try . withFailover pool' mode (either throwE return) $ \x -> withLdap (proj x) (\c -> act $ x & l .~ c)
+
+withLdapFailoverReTest :: (MonadUnliftIO m, MonadCatch m, Typeable a) => Lens p p' LdapPool Ldap -> Failover p -> (Nano -> Bool) -> FailoverMode -> (p' -> m a) -> m (Either LdapPoolError a)
+withLdapFailoverReTest l@(flip withLens const -> proj) pool' doTest mode act = try . withFailoverReTest pool' doTest mode (either throwE return) $ \x -> withLdap (proj x) (\c -> act $ x & l .~ c)
createLdapPool :: ( MonadLoggerIO m, MonadResource m )
diff --git a/src/Mail.hs b/src/Mail.hs
index c472a75f2..36ae4146d 100644
--- a/src/Mail.hs
+++ b/src/Mail.hs
@@ -67,8 +67,9 @@ import qualified Data.Foldable as Foldable
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LTB
import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString as BS
-import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT)
+import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT, YamlValue)
import Utils.Lens.TH
import Control.Lens hiding (from)
@@ -97,6 +98,7 @@ import qualified Text.Shakespeare as Shakespeare (RenderUrl)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
+import qualified Data.Yaml as Yaml
import Data.Aeson.TH
import Utils.PathPiece (splitCamel)
import Utils.DateTime
@@ -110,12 +112,15 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
-import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen)
+import Control.Monad.Random (MonadRandom(..))
import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..))
import qualified Data.ByteArray as ByteArray (convert)
-import Crypto.MAC.HMAC (hmac, HMAC)
+import Crypto.MAC.KMAC (KMAC)
+import qualified Crypto.MAC.KMAC as KMAC
import Crypto.Hash.Algorithms (SHAKE128)
+import Language.Haskell.TH (nameBase)
+
makeLenses_ ''Address
makeLenses_ ''Mail
@@ -370,6 +375,12 @@ instance YesodMail site => ToMailPart site Aeson.Value where
_partEncoding .= QuotedPrintableText
_partContent .= PartContent (Aeson.encodePretty val)
+instance YesodMail site => ToMailPart site YamlValue where
+ toMailPart val = do
+ _partType .= "text/vnd.yaml"
+ _partEncoding .= QuotedPrintableText
+ _partContent .= PartContent (fromStrict $ Yaml.encode val)
+
addAlternatives :: (MonadMail m)
=> Writer (PrioritisedAlternatives m) ()
@@ -495,9 +506,9 @@ setMailObjectIdPseudorandom :: ( MonadHeader m
setMailObjectIdPseudorandom obj = do
sbKey <- secretBoxKey
let
- seed :: HMAC (SHAKE128 64)
- seed = hmac (Saltine.encode sbKey) . toStrict $ Binary.encode obj
- setMailObjectUUID . evalRand getRandom . mkStdGen $ hash (ByteArray.convert seed :: ByteString)
+ seed :: KMAC (SHAKE128 128)
+ seed = KMAC.finalize . KMAC.updates (KMAC.initialize (BS.pack . encodeUtf8 $ nameBase 'setMailObjectIdPseudorandom) $ Saltine.encode sbKey) . LBS.toChunks $ Binary.encode obj
+ setMailObjectUUID . fromMaybe (error "Could not convert hash to UUID") . UUID.fromByteString $ fromStrict (ByteArray.convert seed :: ByteString)
setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
diff --git a/src/Model.hs b/src/Model.hs
index 48c5aa8db..56132c831 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -26,7 +26,7 @@ import Text.Blaze (ToMarkup(..))
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
-share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
+share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateUniWorX", mkSave "currentModel"]
$(persistDirectoryWith lowerCaseSettings "models")
@@ -38,6 +38,8 @@ deriving newtype instance ToJSONKey UserId
deriving newtype instance FromJSONKey UserId
deriving newtype instance ToJSONKey ExamOccurrenceId
deriving newtype instance FromJSONKey ExamOccurrenceId
+deriving newtype instance ToJSONKey FileId
+deriving newtype instance FromJSONKey FileId
-- ToMarkup and ToMessage instances for displaying selected database primary keys
diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs
index 4fd3bbd83..e041bfd7b 100644
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@@ -34,6 +34,10 @@ import qualified Net.IPv6 as IPv6
import qualified Data.Char as Char
import qualified Data.CaseInsensitive as CI
+import qualified Data.Aeson as Aeson
+
+import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage)
+
-- 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)
-- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
@@ -63,6 +67,12 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
deriving Show Eq Ord
|]
+migrateAll' :: Migration
+migrateAll' = sequence_
+ [ migrateUniWorX
+ , migrateMemcachedSqlStorage
+ ]
+
migrateAll :: ( MonadLogger m
, MonadResource m
, MonadUnliftIO m
@@ -620,6 +630,35 @@ customMigrations = Map.fromListWith (>>)
ALTER TABLE "external_exam" ALTER COLUMN "grading_mode" SET NOT NULL;
|]
)
+ , ( AppliedMigrationKey [migrationVersion|33.0.0|] [version|34.0.0|]
+ , whenM (tableExists "allocation_matching") $
+ tableDropEmpty "allocation_matching"
+ )
+ , ( AppliedMigrationKey [migrationVersion|34.0.0|] [version|35.0.0|]
+ , do
+ whenM (tableExists "submission_group") $
+ tableDropEmpty "submission_group"
+ whenM (tableExists "submission_group_edit") $
+ tableDropEmpty "submission_group_edit"
+ )
+ , ( AppliedMigrationKey [migrationVersion|35.0.0|] [version|36.0.0|]
+ , whenM (tableExists "course_participant") $ do
+ [executeQQ|
+ ALTER TABLE "course_participant" ADD COLUMN "state" text NOT NULL DEFAULT 'active';
+ ALTER TABLE "course_participant" ALTER COLUMN "state" DROP DEFAULT;
+ |]
+ let getAuditLog = rawQuery [st|SELECT DISTINCT ON ("info") "info", max("time") FROM "transaction_log" GROUP BY "info" ORDER BY "info";|] []
+ ensureParticipant :: [PersistValue] -> ReaderT SqlBackend m ()
+ ensureParticipant [fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success TransactionCourseParticipantEdit{..}), fromPersistValue -> Right (time :: UTCTime)] = do
+ let toAllocated :: [[PersistValue]] -> Maybe AllocationId
+ toAllocated = either (const Nothing) Just . fromPersistValue <=< listToMaybe <=< listToMaybe
+ allocated <- toAllocated <$> sourceToList [queryQQ|SELECT "allocation_course".allocation FROM "allocation_deregister" INNER JOIN "allocation_course" ON "allocation_course".course = "allocation_deregister".course WHERE "user" = #{transactionUser} AND "allocation_course"."course" = #{transactionCourse} LIMIT 1;|]
+ whenM (existsKey transactionCourse `and2M` existsKey transactionUser)
+ [executeQQ|INSERT INTO "course_participant" ("course", "user", "registration", "state", "allocated") VALUES (#{transactionCourse}, #{transactionUser}, #{time}, #{CourseParticipantInactive False}, #{allocated}) ON CONFLICT DO NOTHING;|]
+ ensureParticipant _ = return ()
+ runConduit $ getAuditLog .| C.mapM_ ensureParticipant
+ )
+
]
diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs
index 69226bf76..23f4e6a17 100644
--- a/src/Model/Migration/Types.hs
+++ b/src/Model/Migration/Types.hs
@@ -10,6 +10,7 @@ import qualified Model as Current
import qualified Model.Types.TH.JSON as Current
import Data.Universe
+import Data.Universe.TH
data SheetType
@@ -32,16 +33,8 @@ data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriveJSON defaultOptions ''UploadMode
Current.derivePersistFieldJSON ''UploadMode
-instance Universe UploadMode where
- universe = NoUpload : (Upload <$> universe)
-instance Finite UploadMode
-
-instance PathPiece UploadMode where
- toPathPiece = \case
- NoUpload -> "no-upload"
- Upload True -> "unpack"
- Upload False -> "no-unpack"
- fromPathPiece = finiteFromPathPiece
+deriveFinite ''UploadMode
+finitePathPiece ''UploadMode ["no-upload", "no-unpack", "unpack"]
data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions
diff --git a/src/Model/Tokens.hs b/src/Model/Tokens.hs
index 613e5ce0d..3486f9eab 100644
--- a/src/Model/Tokens.hs
+++ b/src/Model/Tokens.hs
@@ -1,148 +1,7 @@
-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-{-# LANGUAGE UndecidableInstances #-}
-
module Model.Tokens
- ( BearerToken(..)
- , _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
- , tokenRestrict
- , tokenToJSON, tokenParseJSON
+ ( module Model.Tokens
) where
-import ClassyPrelude.Yesod
-import Yesod.Core.Instances ()
-
-import Model
-import Utils (assertM')
-import Utils.Lens hiding ((.=))
-import Data.Aeson.Lens (AsJSON(..))
-
-import Yesod.Auth (AuthId)
-
-import Jose.Jwt (IntDate(..))
-import qualified Jose.Jwt as Jose
-
-import Jose.Jwt.Instances ()
-import Data.Aeson.Types.Instances ()
-
-import qualified Data.HashMap.Strict as HashMap
-import Data.HashMap.Strict.Instances ()
-import Data.HashSet.Instances ()
-import Data.Time.Clock.Instances ()
-
-import Data.Aeson.Types (Parser, (.:?), (.!=))
-import qualified Data.Aeson as JSON
-import qualified Data.Aeson.Types as JSON
-
-import CryptoID
-
-import Data.Time.Clock.POSIX
-
-import Data.Binary (Binary)
-
-
-
--- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
-data BearerToken site = BearerToken
- { tokenIdentifier :: TokenId
- -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
- , tokenAuthority :: Either Value (AuthId site)
- -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
- , tokenRoutes :: Maybe (HashSet (Route site))
- -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
- , tokenAddAuth :: Maybe AuthDNF
- -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
- , tokenRestrictions :: HashMap (Route site) Value
- -- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
- --
- -- In general this is not encrypted; some care is required to not expose sensitive information to the bearer of the token
- , tokenIssuedAt :: UTCTime
- , tokenIssuedBy :: InstanceId
- , tokenExpiresAt
- , tokenStartsAt :: Maybe UTCTime
- } deriving (Generic, Typeable)
-
-deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
-deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
-deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
-
-instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
-
-makeLenses_ ''BearerToken
-
-_tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
--- ^ Focus a singular restriction (by route) if it exists
---
--- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` or `tokenRestrict` instead
-_tokenRestrictionIx route = _tokenRestrictions . ix route . _JSON
-
-_tokenRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
--- ^ Focus a singular restriction (by route) whether it exists, or not
-_tokenRestrictionAt route = _tokenRestrictions . at route . maybePrism _JSON
-
-tokenRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site
--- ^ Add a restriction to a `BearerToken`
---
--- If a restriction already exists for the targeted route, it's silently overwritten
-tokenRestrict route (toJSON -> resVal) = over _tokenRestrictions $ HashMap.insert route resVal
-
-
-
-tokenToJSON :: forall m.
- ( MonadHandler m
- , HasCryptoUUID (AuthId (HandlerSite m)) m
- , RenderRoute (HandlerSite m)
- ) => BearerToken (HandlerSite m) -> m Value
--- ^ Encode a `BearerToken` analogously to `toJSON`
---
--- Monadic context is needed because `AuthId`s are encrypted during encoding
-tokenToJSON BearerToken{..} = do
- cID <- either (return . Left) (fmap Right . encrypt) tokenAuthority :: m (Either Value (CryptoUUID (AuthId (HandlerSite m))))
- let stdPayload = Jose.JwtClaims
- { jwtIss = Just $ toPathPiece tokenIssuedBy
- , jwtSub = Nothing
- , jwtAud = Nothing
- , jwtExp = IntDate . utcTimeToPOSIXSeconds <$> tokenExpiresAt
- , jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> tokenStartsAt
- , jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds tokenIssuedAt
- , jwtJti = Just $ toPathPiece tokenIdentifier
- }
- return . JSON.object $
- catMaybes [ Just $ "authority" .= either id toJSON cID
- , ("routes" .=) <$> tokenRoutes
- , ("add-auth" .=) <$> tokenAddAuth
- , ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
- ]
- ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
-
-tokenParseJSON :: forall site.
- ( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
- , ParseRoute site
- , Hashable (Route site)
- )
- => Value
- -> ReaderT CryptoIDKey Parser (BearerToken site)
--- ^ Decode a `Value` to a `BearerToken` analogously to `parseJSON`
---
--- Monadic context is needed because `AuthId`s are encrypted during encoding
---
--- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
-tokenParseJSON v@(Object o) = do
- tokenAuthority' <- lift $ (Right <$> o .: "authority") <|> (Left <$> o .: "authority") :: ReaderT CryptoIDKey Parser (Either Value (CryptoUUID (AuthId site)))
- tokenAuthority <- either (return . Left) (fmap Right . decrypt) tokenAuthority'
-
- tokenRoutes <- lift $ o .:? "routes"
- tokenAddAuth <- lift $ o .:? "add-auth"
- tokenRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty
- Jose.JwtClaims{..} <- lift $ parseJSON v
-
- let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
-
- Just tokenIssuedBy <- return $ jwtIss >>= fromPathPiece
- Just tokenIdentifier <- return $ jwtJti >>= fromPathPiece
- Just tokenIssuedAt <- return $ unIntDate <$> jwtIat
- let tokenExpiresAt = unIntDate <$> jwtExp
- tokenStartsAt = unIntDate <$> jwtNbf
-
- return BearerToken{..}
-tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
-
+import Model.Tokens.Lens as Model.Tokens
+import Model.Tokens.Bearer as Model.Tokens
+import Model.Tokens.Session as Model.Tokens
diff --git a/src/Model/Tokens/Bearer.hs b/src/Model/Tokens/Bearer.hs
new file mode 100644
index 000000000..c2231f0f9
--- /dev/null
+++ b/src/Model/Tokens/Bearer.hs
@@ -0,0 +1,175 @@
+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Model.Tokens.Bearer
+ ( BearerToken(..)
+ , _bearerIdentifier, _bearerAuthority, _bearerRoutes, _bearerAddAuth, _bearerRestrictions, _bearerRestrictionIx, _bearerRestrictionAt, _bearerIssuedAt, _bearerIssuedBy, _bearerExpiresAt, _bearerStartsAt
+ , bearerRestrict
+ , bearerToJSON, bearerParseJSON
+ ) where
+
+import ClassyPrelude.Yesod
+import Yesod.Core.Instances ()
+
+import Model
+import Model.Tokens.Lens
+import Utils (assertM', foldMapM)
+import Utils.Lens hiding ((.=))
+import Data.Aeson.Lens (AsJSON(..))
+
+import Yesod.Auth (AuthId)
+
+import Jose.Jwt (IntDate(..))
+import qualified Jose.Jwt as Jose
+
+import Jose.Jwt.Instances ()
+
+import qualified Data.HashSet as HashSet
+import qualified Data.HashMap.Strict as HashMap
+import Data.Time.Clock.Instances ()
+
+import Data.Aeson.Types (Parser, (.:?), (.!=))
+import qualified Data.Aeson as JSON
+import qualified Data.Aeson.Types as JSON
+
+import CryptoID
+
+import Data.Time.Clock.POSIX
+
+import Data.Binary (Binary)
+
+import qualified Data.CryptoID.Class.ImplicitNamespace as I
+
+
+
+-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
+data BearerToken site = BearerToken
+ { bearerIdentifier :: TokenId
+ -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
+ , bearerAuthority :: HashSet (Either Value (AuthId site))
+ -- ^ Tokens only grant rights the `bearerAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `bearerAuthority`)
+ , bearerRoutes :: Maybe (HashSet (Route site))
+ -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
+ , bearerAddAuth :: Maybe AuthDNF
+ -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
+ , bearerRestrictions :: HashMap (Route site) Value
+ -- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
+ --
+ -- In general this is not encrypted; some care is required to not expose sensitive information to the bearer of the token
+ , bearerIssuedAt :: UTCTime
+ , bearerIssuedBy :: InstanceId
+ , bearerIssuedFor :: ClusterId
+ , bearerExpiresAt
+ , bearerStartsAt :: Maybe UTCTime
+ } deriving (Generic, Typeable)
+
+deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
+deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site), Hashable (AuthId site), Eq (AuthId site)) => Read (BearerToken site)
+deriving instance (Show (AuthId site), Show (Route site), Hashable (AuthId site)) => Show (BearerToken site)
+
+instance (Hashable (AuthId site), Hashable (Route site)) => Hashable (BearerToken site)
+
+instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site), Hashable (AuthId site), Eq (AuthId site)) => Binary (BearerToken site)
+
+makeLenses_ ''BearerToken
+instance HasTokenIdentifier (BearerToken site) TokenId where
+ _tokenIdentifier = _bearerIdentifier
+instance HasTokenIssuedBy (BearerToken site) InstanceId where
+ _tokenIssuedBy = _bearerIssuedBy
+instance HasTokenIssuedFor (BearerToken site) ClusterId where
+ _tokenIssuedFor = _bearerIssuedFor
+instance HasTokenIssuedAt (BearerToken site) UTCTime where
+ _tokenIssuedAt = _bearerIssuedAt
+instance HasTokenExpiresAt (BearerToken site) (Maybe UTCTime) where
+ _tokenExpiresAt = _bearerExpiresAt
+instance HasTokenStartsAt (BearerToken site) (Maybe UTCTime) where
+ _tokenStartsAt = _bearerStartsAt
+
+_bearerRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
+-- ^ Focus a singular restriction (by route) if it exists
+--
+-- This /cannot/ be used to add restrictions, use `_bearerRestrictionAt` or `bearerRestrict` instead
+_bearerRestrictionIx route = _bearerRestrictions . ix route . _JSON
+
+_bearerRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
+-- ^ Focus a singular restriction (by route) whether it exists, or not
+_bearerRestrictionAt route = _bearerRestrictions . at route . maybePrism _JSON
+
+bearerRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site
+-- ^ Add a restriction to a `BearerToken`
+--
+-- If a restriction already exists for the targeted route, it's silently overwritten
+bearerRestrict route (toJSON -> resVal) = over _bearerRestrictions $ HashMap.insert route resVal
+
+
+
+bearerToJSON :: forall m.
+ ( MonadHandler m
+ , HasCryptoUUID (AuthId (HandlerSite m)) m
+ , RenderRoute (HandlerSite m)
+ ) => BearerToken (HandlerSite m) -> m Value
+-- ^ Encode a `BearerToken` analogously to `toJSON`
+--
+-- Monadic context is needed because `AuthId`s are encrypted during encoding
+bearerToJSON BearerToken{..} = do
+ cID <- foldMapM (fmap HashSet.singleton . either (return . Left) (fmap Right . I.encrypt)) bearerAuthority :: m (HashSet (Either Value (CryptoUUID (AuthId (HandlerSite m)))))
+ let stdPayload = Jose.JwtClaims
+ { jwtIss = Just $ toPathPiece bearerIssuedBy
+ , jwtSub = Nothing
+ , jwtAud = Just . pure $ toPathPiece bearerIssuedFor
+ , jwtExp = IntDate . utcTimeToPOSIXSeconds <$> bearerExpiresAt
+ , jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> bearerStartsAt
+ , jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds bearerIssuedAt
+ , jwtJti = Just $ toPathPiece bearerIdentifier
+ }
+
+ authorityToJSON auths | [auth] <- otoList auths = either toJSON toJSON auth
+ | otherwise = toJSON $ HashSet.map (either toJSON toJSON) auths
+ return . JSON.object $
+ catMaybes [ Just $ "authority" .= authorityToJSON cID
+ , ("routes" .=) <$> bearerRoutes
+ , ("add-auth" .=) <$> bearerAddAuth
+ , ("restrictions" .=) <$> assertM' (not . HashMap.null) bearerRestrictions
+ ]
+ ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
+
+bearerParseJSON :: forall site.
+ ( Hashable (AuthId site), Eq (AuthId site)
+ , HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
+ , ParseRoute site
+ , Hashable (Route site)
+ )
+ => Value
+ -> ReaderT CryptoIDKey Parser (BearerToken site)
+-- ^ Decode a `Value` to a `BearerToken` analogously to `parseJSON`
+--
+-- Monadic context is needed because `AuthId`s are encrypted during encoding
+--
+-- It's usually easier to use `Utils.Tokens.bearerParseJSON'`
+bearerParseJSON v@(Object o) = do
+ bearerAuthority' <- lift $ asum
+ [ HashSet.singleton . Right <$> o .: "authority"
+ , (o .: "authority" :: Parser (HashSet Value)) >>= foldMapM (\v' -> fmap HashSet.singleton $ (Right <$> parseJSON v') <|> return (Left v'))
+ , HashSet.singleton . Left <$> o .: "authority"
+ ] :: ReaderT CryptoIDKey Parser (HashSet (Either Value (CryptoUUID (AuthId site))))
+ bearerAuthority <- foldMapM (fmap HashSet.singleton . either (return . Left) (fmap Right . I.decrypt)) bearerAuthority'
+
+ bearerRoutes <- lift $ o .:? "routes"
+ bearerAddAuth <- lift $ o .:? "add-auth"
+ bearerRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty
+ Jose.JwtClaims{..} <- lift $ parseJSON v
+
+ let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
+
+ Just bearerIssuedBy <- return $ jwtIss >>= fromPathPiece
+ Just bearerIssuedFor <- return $ do
+ [aud] <- jwtAud
+ fromPathPiece aud
+ Just bearerIdentifier <- return $ jwtJti >>= fromPathPiece
+ Just bearerIssuedAt <- return $ unIntDate <$> jwtIat
+ let bearerExpiresAt = unIntDate <$> jwtExp
+ bearerStartsAt = unIntDate <$> jwtNbf
+
+ return BearerToken{..}
+bearerParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
+
diff --git a/src/Model/Tokens/Lens.hs b/src/Model/Tokens/Lens.hs
new file mode 100644
index 000000000..2f2a95571
--- /dev/null
+++ b/src/Model/Tokens/Lens.hs
@@ -0,0 +1,24 @@
+module Model.Tokens.Lens
+ ( module Model.Tokens.Lens
+ ) where
+
+import Control.Lens
+
+
+class HasTokenIdentifier s a | s -> a where
+ _tokenIdentifier :: Lens' s a
+
+class HasTokenIssuedBy s a | s -> a where
+ _tokenIssuedBy :: Lens' s a
+
+class HasTokenIssuedFor s a | s -> a where
+ _tokenIssuedFor :: Lens' s a
+
+class HasTokenIssuedAt s a | s -> a where
+ _tokenIssuedAt :: Lens' s a
+
+class HasTokenExpiresAt s a | s -> a where
+ _tokenExpiresAt :: Lens' s a
+
+class HasTokenStartsAt s a | s -> a where
+ _tokenStartsAt :: Lens' s a
diff --git a/src/Model/Tokens/Session.hs b/src/Model/Tokens/Session.hs
new file mode 100644
index 000000000..4f0180491
--- /dev/null
+++ b/src/Model/Tokens/Session.hs
@@ -0,0 +1,77 @@
+module Model.Tokens.Session
+ ( SessionToken(..)
+ , _sessionIdentifier, _sessionId, _sessionIssuedBy, _sessionIssuedAt, _sessionExpiresAt, _sessionStartsAt
+ ) where
+
+import ClassyPrelude.Yesod
+
+import Model.Tokens.Lens
+import Model
+import Utils.Lens
+
+import Web.ServerSession.Core
+
+import Jose.Jwt (IntDate(..))
+import qualified Jose.Jwt as Jose
+
+import Data.Time.Clock.POSIX
+
+import Control.Monad.Fail
+
+
+data SessionToken sess = SessionToken
+ { sessionIdentifier :: TokenId
+ , sessionId :: SessionId sess
+ , sessionIssuedAt :: UTCTime
+ , sessionIssuedBy :: InstanceId
+ , sessionIssuedFor :: ClusterId
+ , sessionExpiresAt
+ , sessionStartsAt :: Maybe UTCTime
+ } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+makeLenses_ ''SessionToken
+instance HasTokenIdentifier (SessionToken sess) TokenId where
+ _tokenIdentifier = _sessionIdentifier
+instance HasTokenIssuedBy (SessionToken sess) InstanceId where
+ _tokenIssuedBy = _sessionIssuedBy
+instance HasTokenIssuedFor (SessionToken sess) ClusterId where
+ _tokenIssuedFor = _sessionIssuedFor
+instance HasTokenIssuedAt (SessionToken sess) UTCTime where
+ _tokenIssuedAt = _sessionIssuedAt
+instance HasTokenExpiresAt (SessionToken sess) (Maybe UTCTime) where
+ _tokenExpiresAt = _sessionExpiresAt
+instance HasTokenStartsAt (SessionToken sess) (Maybe UTCTime) where
+ _tokenStartsAt = _sessionStartsAt
+
+instance ToJSON (SessionToken sess) where
+ toJSON SessionToken{..} = toJSON Jose.JwtClaims{..}
+ where jwtIss = Just $ toPathPiece sessionIssuedBy
+ jwtSub = Just $ toPathPiece sessionId
+ jwtAud = Just . pure $ toPathPiece sessionIssuedFor
+ jwtExp = IntDate . utcTimeToPOSIXSeconds <$> sessionExpiresAt
+ jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> sessionStartsAt
+ jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds sessionIssuedAt
+ jwtJti = Just $ toPathPiece sessionIdentifier
+
+instance FromJSON (SessionToken sess) where
+ parseJSON val = do
+ Jose.JwtClaims{..} <- parseJSON val
+
+ sessionIdentifier <- parseMaybe "sessionIdentfier" $
+ fromPathPiece =<< jwtIss
+ sessionId <- parseMaybe "sessionId" $
+ fromPathPiece =<< jwtSub
+ sessionIssuedAt <- parseMaybe "sessionIssuedAt" $
+ unIntDate <$> jwtIat
+ sessionIssuedBy <- parseMaybe "sessionIssuedBy" $
+ fromPathPiece =<< jwtIss
+ sessionIssuedFor <- parseMaybe "sessionIssuedFor" $ do
+ [aud] <- jwtAud
+ fromPathPiece aud
+ let sessionExpiresAt = unIntDate <$> jwtExp
+ sessionStartsAt = unIntDate <$> jwtNbf
+
+ return SessionToken{..}
+ where
+ parseMaybe errId = maybe (fail $ "Could not parse " <> errId) return
+ unIntDate (IntDate posix) = posixSecondsToUTCTime posix
diff --git a/src/Model/Types/Allocation.hs b/src/Model/Types/Allocation.hs
index b918deab0..f03b5ce69 100644
--- a/src/Model/Types/Allocation.hs
+++ b/src/Model/Types/Allocation.hs
@@ -4,6 +4,8 @@ module Model.Types.Allocation
, AllocationPriorityComparison(..)
, AllocationFingerprint
, module Utils.Allocation
+ , AllocationPriorityNumericRecord(..)
+ , allocationPriorityNumericMap
) where
import Import.NoModel
@@ -44,13 +46,36 @@ deriving via E.JSONB AllocationPriority instance E.PersistFieldSql AllocationPri
instance Binary AllocationPriority
-instance Csv.FromRecord (Map UserMatriculation AllocationPriority) where
+data AllocationPriorityNumericRecord = AllocationPriorityNumericRecord
+ { apmrMatrikelnummer :: UserMatriculation
+ , apmrPriority :: Vector Integer
+ } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+allocationPriorityNumericMap :: Prism' (Map UserMatriculation AllocationPriority) AllocationPriorityNumericRecord
+allocationPriorityNumericMap = prism' fromPrioRecord toPrioRecord
+ where
+ fromPrioRecord AllocationPriorityNumericRecord{..}
+ = Map.singleton apmrMatrikelnummer $ AllocationPriorityNumeric apmrPriority
+
+ toPrioRecord recordMap = do
+ [(matr, AllocationPriorityNumeric{..})] <- pure $ Map.toList recordMap
+ return $ AllocationPriorityNumericRecord matr allocationPriorities
+
+instance Csv.FromRecord AllocationPriorityNumericRecord where
parseRecord v = parseNumeric
where
parseNumeric
- | Vector.length v >= 1 = Map.singleton <$> v Csv..! 0 <*> (AllocationPriorityNumeric <$> mapM Csv.parseField (Vector.tail v))
+ | Vector.length v >= 1 = AllocationPriorityNumericRecord <$> v Csv..! 0 <*> mapM Csv.parseField (Vector.tail v)
| otherwise = mzero
+instance Csv.ToRecord AllocationPriorityNumericRecord where
+ toRecord AllocationPriorityNumericRecord{..} = Csv.record $
+ Csv.toField apmrMatrikelnummer
+ : map Csv.toField (otoList apmrPriority)
+
+instance Csv.FromRecord (Map UserMatriculation AllocationPriority) where
+ parseRecord = fmap (review allocationPriorityNumericMap) . Csv.parseRecord
+
instance Csv.ToField AllocationPriority where
toField (AllocationPriorityOrdinal n ) = Csv.toField n
diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs
index 54d6d5b00..692b939b7 100644
--- a/src/Model/Types/Common.hs
+++ b/src/Model/Types/Common.hs
@@ -47,6 +47,8 @@ type ExamOccurrenceName = CI Text
type AllocationName = CI Text
type AllocationShorthand = CI Text
+type SubmissionGroupName = CI Text
+
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
type InstanceId = UUID
type ClusterId = UUID
diff --git a/src/Model/Types/Course.hs b/src/Model/Types/Course.hs
index 4a1a08b3c..e7a991d29 100644
--- a/src/Model/Types/Course.hs
+++ b/src/Model/Types/Course.hs
@@ -10,6 +10,9 @@ module Model.Types.Course
import Import.NoModel
+import Model.Types.TH.PathPiece
+import Utils.Lens.TH
+
data LecturerType = CourseLecturer | CourseAssistant
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@@ -24,3 +27,20 @@ deriveJSON defaultOptions
derivePersistFieldJSON ''LecturerType
instance Hashable LecturerType
+
+
+data CourseParticipantState
+ = CourseParticipantActive
+ | CourseParticipantInactive { courseParticipantNoShow :: Bool }
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ deriving anyclass (Hashable)
+
+makePrisms ''CourseParticipantState
+makeLenses_ ''CourseParticipantState
+
+deriveFinite ''CourseParticipantState
+finitePathPiece ''CourseParticipantState
+ ["active", "inactive", "no-show"]
+pathPieceJSON ''CourseParticipantState
+pathPieceJSONKey ''CourseParticipantState
+derivePersistFieldPathPiece ''CourseParticipantState
diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs
index 265686c14..25cb813a5 100644
--- a/src/Model/Types/Exam.hs
+++ b/src/Model/Types/Exam.hs
@@ -29,6 +29,7 @@ module Model.Types.Exam
, ExamResultPassedGrade
, ExamGradingMode(..)
, _ExamGradingPass, _ExamGradingGrades, _ExamGradingMixed
+ , hasExamGradingPass, hasExamGradingGrades
, ExamPartNumber
, _ExamPartNumber, _ExamPartNumber'
) where
@@ -365,6 +366,12 @@ pathPieceJSONKey ''ExamGradingMode
derivePersistFieldPathPiece ''ExamGradingMode
makePrisms ''ExamGradingMode
+hasExamGradingPass, hasExamGradingGrades :: ExamGradingMode -> Bool
+hasExamGradingPass ExamGradingGrades = False
+hasExamGradingPass _ = True
+hasExamGradingGrades ExamGradingPass = False
+hasExamGradingGrades _ = True
+
newtype ExamPartNumber = ExamPartNumber { examPartNumberFragments :: [Either (CI Text) Natural] }
deriving (Eq, Ord, Generic, Typeable)
diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs
index 89de617ab..af2a14147 100644
--- a/src/Model/Types/Health.hs
+++ b/src/Model/Types/Health.hs
@@ -90,5 +90,5 @@ healthReportStatus = \case
HealthSMTPConnect (Just False) -> HealthFailure
HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully?
HealthActiveJobExecutors (Just prop )
- | prop < 1 -> HealthFailure
+ | prop <= 0 -> HealthFailure
_other -> maxBound -- Minimum badness
diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs
index 71e35fbdf..0cd47cc69 100644
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@@ -12,18 +12,21 @@ module Model.Types.Security
import Import.NoModel
import qualified Data.Text as Text
+import qualified Data.Set as Set
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Aeson.Types as Aeson
-import qualified Data.Binary as Binary
-
import qualified Data.CaseInsensitive as CI
import Model.Types.TH.PathPiece
import Database.Persist.Sql
+import Utils.Lens.TH
+
+import qualified Data.Binary as Binary
+
data AuthenticationMode = AuthLDAP
| AuthPWHash { authPWHash :: Text }
@@ -68,6 +71,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthRated
| AuthUserSubmissions
| AuthCorrectorSubmissions
+ | AuthSubmissionGroup
| AuthCapacity
| AuthRegisterGroup
| AuthEmpty
@@ -83,16 +87,12 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthDevelopment
| AuthFree
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
-
-instance Universe AuthTag
-instance Finite AuthTag
-instance Hashable AuthTag
+ deriving anyclass (Universe, Finite, Hashable)
nullaryPathPiece ''AuthTag $ camelToPathPiece' 1
pathPieceJSON ''AuthTag
pathPieceJSONKey ''AuthTag
-
-instance Binary AuthTag
+pathPieceBinary ''AuthTag
newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
@@ -112,13 +112,20 @@ instance FromJSON AuthTagActive where
o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool)
return . AuthTagActive $ \n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n o'
+instance Hashable AuthTagActive where
+ hashWithSalt s = foldl' hashWithSalt s . authTagIsActive
+
+instance Binary AuthTagActive where
+ put v = Binary.put . HashMap.fromList $ map (id &&& authTagIsActive v) universeF
+ get = Binary.get <&> \hm -> AuthTagActive (\n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n hm)
+
derivePersistFieldJSON ''AuthTagActive
data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ deriving anyclass (Hashable, Binary)
-instance Hashable a => Hashable (PredLiteral a)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
, sumEncoding = TaggedObject "val" "var"
@@ -131,12 +138,11 @@ instance PathPiece a => PathPiece (PredLiteral a) where
fromPathPiece t = PLVariable <$> fromPathPiece t
<|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
-instance Binary a => Binary (PredLiteral a)
-
newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (Semigroup, Monoid)
+ deriving anyclass (Binary, Hashable)
$(return [])
@@ -145,9 +151,9 @@ instance ToJSON a => ToJSON (PredDNF a) where
instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
-instance (Ord a, Binary a) => Binary (PredDNF a) where
- get = PredDNF <$> Binary.get
- put = Binary.put . dnfTerms
+instance (Ord a, PathPiece a) => PathPiece (PredDNF a) where
+ toPathPiece = Text.unwords . map (Text.intercalate "AND") . map (map toPathPiece . otoList) . otoList . dnfTerms
+ fromPathPiece = fmap (PredDNF . Set.fromList) . mapM (fromNullable <=< foldMapM (fmap Set.singleton . fromPathPiece) . Text.splitOn "AND") . concatMap (Text.splitOn "OR") . Text.words
type AuthLiteral = PredLiteral AuthTag
@@ -158,6 +164,7 @@ data UserGroupName
= UserGroupMetrics
| UserGroupCustom { userGroupCustomName :: CI Text }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ deriving anyclass (Hashable)
instance PathPiece UserGroupName where
toPathPiece UserGroupMetrics = "metrics"
@@ -171,3 +178,4 @@ instance PathPiece UserGroupName where
pathPieceJSON ''UserGroupName
derivePersistFieldPathPiece' (sqlType (Proxy @(CI Text))) ''UserGroupName
+makeLenses_ ''UserGroupName
diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs
index 26e4bb291..0ef6f6ae8 100644
--- a/src/Model/Types/Sheet.hs
+++ b/src/Model/Types/Sheet.hs
@@ -118,6 +118,8 @@ deriveJSON defaultOptions
} ''SheetType
derivePersistFieldJSON ''SheetType
+makePrisms ''SheetType
+
data SheetTypeSummary = SheetTypeSummary
{ normalSummary
, bonusSummary
@@ -157,12 +159,7 @@ derivePersistField "SheetFileType"
instance Universe SheetFileType
instance Finite SheetFileType
-instance PathPiece SheetFileType where
- toPathPiece SheetExercise = "file"
- toPathPiece SheetHint = "hint"
- toPathPiece SheetSolution = "solution"
- toPathPiece SheetMarking = "marking"
- fromPathPiece = finiteFromPathPiece
+finitePathPiece ''SheetFileType ["file", "hint", "solution", "marking"]
sheetFile2markup :: SheetFileType -> Markup
sheetFile2markup SheetExercise = iconSFTQuestion
@@ -211,9 +208,9 @@ deriveJSON defaultOptions
}''UploadMode
derivePersistFieldJSON ''UploadMode
-data UploadModeDescr = UploadModeNone
- | UploadModeAny
+data UploadModeDescr = UploadModeAny
| UploadModeSpecific
+ | UploadModeNone
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe UploadModeDescr
instance Finite UploadModeDescr
@@ -240,10 +237,10 @@ deriveJSON defaultOptions
} ''SubmissionMode
derivePersistFieldJSON ''SubmissionMode
-data SubmissionModeDescr = SubmissionModeNone
- | SubmissionModeCorrector
+data SubmissionModeDescr = SubmissionModeCorrector
| SubmissionModeUser
| SubmissionModeBoth
+ | SubmissionModeNone
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe SubmissionModeDescr
instance Finite SubmissionModeDescr
diff --git a/src/Network/HTTP/Types/Method/Instances.hs b/src/Network/HTTP/Types/Method/Instances.hs
new file mode 100644
index 000000000..b71b009ea
--- /dev/null
+++ b/src/Network/HTTP/Types/Method/Instances.hs
@@ -0,0 +1,25 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Network.HTTP.Types.Method.Instances
+ (
+ ) where
+
+import ClassyPrelude
+import Data.Binary (Binary)
+
+import Network.HTTP.Types.Method
+
+import Utils.PathPiece (pathPieceJSON, pathPieceJSONKey)
+
+import Web.PathPieces
+
+
+deriving instance Generic StdMethod
+instance Binary StdMethod
+
+instance PathPiece Method where
+ toPathPiece = decodeUtf8
+ fromPathPiece = Just . encodeUtf8
+
+pathPieceJSON ''Method
+pathPieceJSONKey ''Method
diff --git a/src/Settings.hs b/src/Settings.hs
index 63238163b..22454a0df 100644
--- a/src/Settings.hs
+++ b/src/Settings.hs
@@ -10,12 +10,13 @@ module Settings
( module Settings
, module Settings.Cluster
, module Settings.Mime
+ , module Settings.Cookies
) where
import Import.NoModel
import qualified Control.Exception as Exception
-import Data.Aeson (fromJSON, withObject
- ,(.!=), (.:?), withScientific
+import Data.Aeson (fromJSON, withObject, withScientific
+ ,(.!=), (.:?)
)
import qualified Data.Aeson.Types as Aeson
import Data.FileEmbed (embedFile)
@@ -51,6 +52,7 @@ import qualified Database.Memcached.Binary.Types as Memcached
import Model
import Settings.Cluster
import Settings.Mime
+import Settings.Cookies
import qualified System.FilePath as FilePath
@@ -59,6 +61,12 @@ import Jose.Jwt (JwtEncoding(..))
import System.FilePath.Glob
import Handler.Utils.Submission.TH
+import qualified Web.ServerSession.Core as ServerSession
+
+import Text.Show (showParen, showString)
+
+import qualified Data.List.PointedList as P
+
-- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files,
@@ -72,7 +80,7 @@ data AppSettings = AppSettings
, appDatabaseConf :: PostgresConf
-- ^ Configuration settings for accessing the database.
, appAutoDbMigrate :: Bool
- , appLdapConf :: Maybe LdapConf
+ , appLdapConf :: Maybe (PointedList LdapConf)
-- ^ Configuration settings for accessing the LDAP-directory
, appSmtpConf :: Maybe SmtpConf
-- ^ Configuration settings for accessing a SMTP Mailserver
@@ -88,6 +96,13 @@ data AppSettings = AppSettings
, appIpFromHeader :: Bool
-- ^ Get the IP address from the header when logging. Useful when sitting
-- behind a reverse proxy.
+
+ , appServerSessionConfig :: ServerSessionSettings
+ , appServerSessionAcidFallback :: Bool
+ , appSessionMemcachedConf :: Maybe MemcachedConf
+ , appSessionTokenExpiration :: Maybe NominalDiffTime
+ , appSessionTokenEncoding :: JwtEncoding
+
, appMailFrom :: Address
, appMailObjectDomain :: Text
, appMailVerp :: VerpMode
@@ -101,8 +116,8 @@ data AppSettings = AppSettings
, appNotificationExpiration :: NominalDiffTime
, appSessionTimeout :: NominalDiffTime
, appMaximumContentLength :: Maybe Word64
- , appJwtExpiration :: Maybe NominalDiffTime
- , appJwtEncoding :: JwtEncoding
+ , appBearerExpiration :: Maybe NominalDiffTime
+ , appBearerEncoding :: JwtEncoding
, appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime
, appHealthCheckDelayNotify :: Bool
@@ -118,6 +133,8 @@ data AppSettings = AppSettings
, appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime
, appSynchroniseLdapUsersInterval :: NominalDiffTime
+ , appLdapReTestFailover :: DiffTime
+
, appSessionFilesExpire :: NominalDiffTime
, appPruneUnreferencedFiles :: Maybe NominalDiffTime
@@ -143,9 +160,25 @@ data AppSettings = AppSettings
, appUserDefaults :: UserDefaultConf
, appAuthPWHash :: PWHashConf
+ , appCookieSettings :: RegisteredCookie -> CookieSettings
+
+ , appMemcachedConf :: Maybe MemcachedConf
+
+ , appFavouritesQuickActionsBurstsize
+ , appFavouritesQuickActionsAvgInverseRate :: Word64
+ , appFavouritesQuickActionsTimeout :: DiffTime
+ , appFavouritesQuickActionsCacheTTL :: Maybe DiffTime
+
, appInitialInstanceID :: Maybe (Either FilePath UUID)
, appRibbon :: Maybe Text
- } deriving (Show)
+ } deriving Show
+
+
+newtype ServerSessionSettings
+ = ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
+
+instance Show ServerSessionSettings where
+ showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _"
data LogSettings = LogSettings
{ logAll, logDetailed :: Bool
@@ -211,25 +244,34 @@ data SmtpConf = SmtpConf
} deriving (Show)
data WidgetMemcachedConf = WidgetMemcachedConf
- { widgetMemcachedConnectInfo :: Memcached.ConnectInfo
- , widgetMemcachedBaseUrl :: Text
- , widgetMemcachedExpiry :: Maybe NominalDiffTime
+ { widgetMemcachedConf :: MemcachedConf
+ , widgetMemcachedBaseUrl :: Text
+ } deriving (Show)
+
+data MemcachedConf = MemcachedConf
+ { memcachedConnectInfo :: Memcached.ConnectInfo
+ , memcachedExpiry :: Maybe NominalDiffTime
} deriving (Show)
instance FromJSON Memcached.Auth where
parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw
-instance FromJSON WidgetMemcachedConf where
- parseJSON = withObject "WidgetMemcachedConf" $ \o -> do
+instance FromJSON MemcachedConf where
+ parseJSON = withObject "MemcachedConf" $ \o -> do
connectHost <- o .:? "host" .!= ""
connectPort <- o .: "port"
connectAuth <- o .: "auth"
numConnection <- o .: "limit"
connectionIdleTime <- o .: "timeout"
- widgetMemcachedBaseUrl <- o .:? "base-url" .!= ""
- widgetMemcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
+ memcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
- return WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
+ return MemcachedConf{ memcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
+
+instance FromJSON WidgetMemcachedConf where
+ parseJSON v = flip (withObject "WidgetMemcachedConf") v $ \o -> do
+ widgetMemcachedConf <- parseJSON v
+ widgetMemcachedBaseUrl <- o .:? "base-url" .!= ""
+ return WidgetMemcachedConf{..}
data ResourcePoolConf = ResourcePoolConf
{ poolStripes :: Int
@@ -343,6 +385,19 @@ instance FromJSON JwtEncoding where
return $ JweEncoding alg enc
]
+instance FromJSON ServerSessionSettings where
+ parseJSON = withObject "ServerSession.State" $ \o -> do
+ idleTimeout <- o .:? "idle-timeout"
+ absoluteTimeout <- o .:? "absolute-timeout"
+ timeoutResolution <- o .:? "timeout-resolution"
+ persistentCookies <- o .:? "persistent-cookies"
+ return $ ServerSessionSettings (appEndo . foldMap Endo $ catMaybes
+ [ pure $ ServerSession.setIdleTimeout idleTimeout
+ , pure $ ServerSession.setAbsoluteTimeout absoluteTimeout
+ , pure $ ServerSession.setTimeoutResolution timeoutResolution
+ , ServerSession.setPersistentCookies <$> persistentCookies
+ ])
+
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
@@ -361,15 +416,20 @@ instance FromJSON AppSettings where
let nonEmptyHost LdapConf{..} = case ldapHost of
Ldap.Tls host _ -> not $ null host
Ldap.Plain host -> not $ null host
- appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
+ appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
- let validWidgetMemcachedConf WidgetMemcachedConf{ widgetMemcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
+ let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
[ not $ null connectHost
- , not $ null widgetMemcachedBaseUrl
, numConnection > 0
, connectionIdleTime >= 0
]
+ validWidgetMemcachedConf WidgetMemcachedConf{..} = and
+ [ not $ null widgetMemcachedBaseUrl
+ , validMemcachedConf widgetMemcachedConf
+ ]
appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached"
+ appSessionMemcachedConf <- assertM validMemcachedConf <$> o .:? "session-memcached"
+ appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached"
appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host"
appPort <- o .: "port"
@@ -387,8 +447,8 @@ instance FromJSON AppSettings where
appNotificationRateLimit <- o .: "notification-rate-limit"
appNotificationCollateDelay <- o .: "notification-collate-delay"
appNotificationExpiration <- o .: "notification-expiration"
- appJwtExpiration <- o .:? "jwt-expiration"
- appJwtEncoding <- o .: "jwt-encoding"
+ appBearerExpiration <- o .:? "bearer-expiration"
+ appBearerEncoding <- o .: "bearer-encoding"
appHealthCheckInterval <- (assertM' (> 0) . ) <$> o .: "health-check-interval"
appHealthCheckDelayNotify <- o .: "health-check-delay-notify"
@@ -406,6 +466,8 @@ instance FromJSON AppSettings where
appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within"
appSynchroniseLdapUsersInterval <- o .: "synchronise-ldap-users-interval"
+ appLdapReTestFailover <- o .: "ldap-re-test-failover"
+
appSessionFilesExpire <- o .: "session-files-expire"
appPruneUnreferencedFiles <- o .:? "prune-unreferenced-files"
@@ -417,6 +479,7 @@ instance FromJSON AppSettings where
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
appEncryptErrors <- o .:? "encrypt-errors" .!= not defaultDev
+ appServerSessionAcidFallback <- o .:? "server-session-acid-fallback" .!= defaultDev
appInitialLogSettings <- o .: "log-settings"
@@ -438,7 +501,23 @@ instance FromJSON AppSettings where
appRibbon <- assertM (not . Text.null) . fmap Text.strip <$> o.:? "ribbon"
- return AppSettings {..}
+ appCookieSettings <- o .: "cookies"
+
+ appServerSessionConfig' <- o .: "server-sessions"
+ let appServerSessionConfig = ServerSessionSettings $ httpOnlyCookie . secureCookie . applyServerSessionSettings appServerSessionConfig'
+ where httpOnlyCookie :: forall a. ServerSession.State a -> ServerSession.State a
+ httpOnlyCookie = maybe id ServerSession.setHttpOnlyCookies . cookieHttpOnly $ appCookieSettings CookieSession
+ secureCookie :: forall a. ServerSession.State a -> ServerSession.State a
+ secureCookie = maybe id ServerSession.setSecureCookies . cookieSecure $ appCookieSettings CookieSession
+ appSessionTokenExpiration <- o .:? "session-token-expiration"
+ appSessionTokenEncoding <- o .: "session-token-encoding"
+
+ appFavouritesQuickActionsBurstsize <- o .: "favourites-quick-actions-burstsize"
+ appFavouritesQuickActionsAvgInverseRate <- o .: "favourites-quick-actions-avg-inverse-rate"
+ appFavouritesQuickActionsTimeout <- o .: "favourites-quick-actions-timeout"
+ appFavouritesQuickActionsCacheTTL <- o .: "favourites-quick-actions-cache-ttl"
+
+ return AppSettings{..}
makeClassy_ ''AppSettings
diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs
index 6b4d0e836..bc72857ea 100644
--- a/src/Settings/Cluster.hs
+++ b/src/Settings/Cluster.hs
@@ -9,20 +9,18 @@ import ClassyPrelude.Yesod
import Web.HttpApiData
import Utils
-import Control.Lens
import Data.Universe
import qualified Data.Aeson as Aeson
-import qualified Web.ClientSession as ClientSession
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
+import qualified Crypto.Saltine.Core.AEAD as AEAD
import qualified Crypto.Saltine.Class as Saltine
import Data.CryptoID.ByteString (CryptoIDKey)
import qualified Data.CryptoID.ByteString as CryptoID
import qualified Data.Binary as Binary
-import qualified Data.Serialize as Serialize
import qualified Data.ByteString.Base64.URL as Base64
import qualified Jose.Jwa as Jose
@@ -39,10 +37,11 @@ import Model.Types.TH.PathPiece
data ClusterSettingsKey
= ClusterCryptoIDKey
- | ClusterClientSessionKey
+ | ClusterServerSessionKey
| ClusterSecretBoxKey
| ClusterJSONWebKeySet
| ClusterId
+ | ClusterMemcachedKey
deriving (Eq, Ord, Enum, Bounded, Show, Read)
instance Universe ClusterSettingsKey
@@ -83,18 +82,18 @@ instance FromJSON CryptoIDKey where
| otherwise -> fail $ show (length bs) ++ " extra bytes"
-instance ClusterSetting 'ClusterClientSessionKey where
- type ClusterSettingValue 'ClusterClientSessionKey = ClientSession.Key
- initClusterSetting _ = liftIO $ view _2 <$> ClientSession.randomKey
- knownClusterSetting _ = ClusterClientSessionKey
+instance ClusterSetting 'ClusterServerSessionKey where
+ type ClusterSettingValue 'ClusterServerSessionKey = AEAD.Key
+ initClusterSetting _ = liftIO AEAD.newKey
+ knownClusterSetting _ = ClusterServerSessionKey
+
+instance ToJSON AEAD.Key where
+ toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode
-instance ToJSON ClientSession.Key where
- toJSON = Aeson.String . decodeUtf8 . Base64.encode . Serialize.encode
-
-instance FromJSON ClientSession.Key where
+instance FromJSON AEAD.Key where
parseJSON = Aeson.withText "Key" $ \t -> do
bytes <- either fail return . Base64.decode $ encodeUtf8 t
- either fail return $ Serialize.decode bytes
+ maybe (fail "Could not parse key") return $ Saltine.decode bytes
instance ClusterSetting 'ClusterSecretBoxKey where
@@ -124,3 +123,9 @@ instance ClusterSetting 'ClusterId where
type ClusterSettingValue 'ClusterId = UUID
initClusterSetting _ = liftIO getRandom
knownClusterSetting _ = ClusterId
+
+
+instance ClusterSetting 'ClusterMemcachedKey where
+ type ClusterSettingValue 'ClusterMemcachedKey = AEAD.Key
+ initClusterSetting _ = liftIO AEAD.newKey
+ knownClusterSetting _ = ClusterMemcachedKey
diff --git a/src/Settings/Cookies.hs b/src/Settings/Cookies.hs
new file mode 100644
index 000000000..c0cce32de
--- /dev/null
+++ b/src/Settings/Cookies.hs
@@ -0,0 +1,68 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Settings.Cookies
+ ( CookieSettings(..)
+ , HasCookieSettings(..)
+ , cookieSettingsToSetCookie
+ ) where
+
+import ClassyPrelude
+
+import Web.Cookie
+import Web.Cookie.Instances ()
+
+import Utils.PathPiece
+
+import Data.Time.Clock
+import Data.Time.Clock.Instances ()
+
+import qualified Data.Text as Text
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.CaseInsensitive as CI
+
+import Data.Aeson
+import Data.Aeson.TH
+
+import Control.Lens ((&))
+import Control.Monad.Fail
+
+
+data CookieSettings = CookieSettings
+ { cookieExpires :: Maybe NominalDiffTime
+ , cookieSameSite :: Maybe SameSiteOption
+ , cookieHttpOnly
+ , cookieSecure :: Maybe Bool
+ } deriving (Eq, Show, Generic, Typeable)
+ deriving anyclass (Hashable)
+
+instance FromJSON SameSiteOption where
+ parseJSON = withText "SameSiteOption" $ \(CI.mk -> ciT) -> HashMap.lookup ciT options
+ & maybe (fail . unpack $ "Expected one of: " <> Text.intercalate ", " (map CI.original $ HashMap.keys options)) return
+ where options = mconcat
+ [ singletonMap "Lax" sameSiteLax
+ , singletonMap "Strict" sameSiteStrict
+ , singletonMap "None" sameSiteNone
+ ]
+
+deriveFromJSON defaultOptions
+ { omitNothingFields = True
+ , fieldLabelModifier = camelToPathPiece' 1
+ } ''CookieSettings
+
+
+class HasCookieSettings ident app | app -> ident where
+ getCookieSettings :: app -> ident -> CookieSettings
+
+instance HasCookieSettings ident (ident -> CookieSettings) where
+ getCookieSettings = id
+
+
+cookieSettingsToSetCookie :: MonadIO m => CookieSettings -> m SetCookie
+cookieSettingsToSetCookie CookieSettings{..} = do
+ now <- liftIO getCurrentTime
+ return def
+ { setCookieExpires = addUTCTime <$> cookieExpires <*> pure now
+ , setCookieSameSite = cookieSameSite
+ , setCookieHttpOnly = fromMaybe (setCookieHttpOnly def) cookieHttpOnly
+ , setCookieSecure = fromMaybe (setCookieSecure def) cookieSecure
+ }
diff --git a/src/UnliftIO/Async/Utils.hs b/src/UnliftIO/Async/Utils.hs
index fb1dbc978..4b775e807 100644
--- a/src/UnliftIO/Async/Utils.hs
+++ b/src/UnliftIO/Async/Utils.hs
@@ -7,33 +7,34 @@ module UnliftIO.Async.Utils
import ClassyPrelude hiding (cancel, async, link)
import Control.Lens
-import UnliftIO.Async
+import qualified UnliftIO.Async as UnliftIO
+import qualified Control.Concurrent.Async as A
import Control.Monad.Trans.Resource
allocateAsync :: forall m a.
- MonadResource m
- => IO a -> m (Async a)
-allocateAsync = fmap (view _2) . flip allocate cancel . liftIO . async
+ ( MonadUnliftIO m, MonadResource m )
+ => m a -> m (Async a)
+allocateAsync act = withRunInIO $ \run -> run . fmap (view _2) . flip allocate A.cancel . A.async $ run act
-allocateLinkedAsync :: forall m a. (MonadUnliftIO m, MonadResource m) => IO a -> m (Async a)
-allocateLinkedAsync = uncurry (<$) . (id &&& link) <=< allocateAsync
+allocateLinkedAsync :: forall m a. (MonadUnliftIO m, MonadResource m) => m a -> m (Async a)
+allocateLinkedAsync = uncurry (<$) . (id &&& UnliftIO.link) <=< allocateAsync
allocateAsyncWithUnmask :: forall m a.
- MonadResource m
- => ((forall b. IO b -> IO b) -> IO a) -> m (Async a)
-allocateAsyncWithUnmask act = fmap (view _2) . flip allocate cancel . liftIO $ asyncWithUnmask act
+ ( MonadUnliftIO m, MonadResource m )
+ => ((forall b. m b -> m b) -> m a) -> m (Async a)
+allocateAsyncWithUnmask act = withRunInIO $ \run -> run . fmap (view _2) . flip allocate A.cancel $ A.asyncWithUnmask $ \unmask -> run $ act (liftIO . unmask . run)
-allocateLinkedAsyncWithUnmask :: forall m a. (MonadUnliftIO m, MonadResource m) => ((forall b. IO b -> IO b) -> IO a) -> m (Async a)
-allocateLinkedAsyncWithUnmask act = uncurry (<$) . (id &&& link) =<< allocateAsyncWithUnmask act
+allocateLinkedAsyncWithUnmask :: forall m a. (MonadUnliftIO m, MonadResource m) => ((forall b. m b -> m b) -> m a) -> m (Async a)
+allocateLinkedAsyncWithUnmask act = uncurry (<$) . (id &&& UnliftIO.link) =<< allocateAsyncWithUnmask act
allocateAsyncMasked :: forall m a.
- MonadResource m
- => IO a -> m (Async a)
-allocateAsyncMasked act = fmap (view _2) . flip allocate cancel . liftIO $ asyncWithUnmask (const act)
+ ( MonadUnliftIO m, MonadResource m )
+ => m a -> m (Async a)
+allocateAsyncMasked act = allocateAsyncWithUnmask (const act)
-allocateLinkedAsyncMasked :: forall m a. (MonadUnliftIO m, MonadResource m) => IO a -> m (Async a)
-allocateLinkedAsyncMasked = uncurry (<$) . (id &&& link) <=< allocateAsyncMasked
+allocateLinkedAsyncMasked :: forall m a. (MonadUnliftIO m, MonadResource m) => m a -> m (Async a)
+allocateLinkedAsyncMasked act = allocateLinkedAsyncWithUnmask (const act)
diff --git a/src/Utils.hs b/src/Utils.hs
index 97e13c70a..513f38e68 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -15,7 +15,6 @@ import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
@@ -28,6 +27,9 @@ import Utils.Icon as Utils
import Utils.Message as Utils
import Utils.Lang as Utils
import Utils.Parameters as Utils
+import Utils.Cookies as Utils
+import Utils.Cookies.Registered as Utils
+import Utils.Session as Utils
import Utils.Csv as Utils
import Text.Blaze (Markup, ToMarkup)
@@ -38,11 +40,14 @@ import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.List as List
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Vector as V
import qualified Data.Conduit.List as C
import Control.Lens
import Control.Lens as Utils (none)
+import Control.Lens.Extras (is)
import Data.Set.Lens
import Control.Arrow as Utils ((>>>))
@@ -52,14 +57,20 @@ import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
import Control.Monad.Trans.Writer.Lazy (execWriterT, tell)
import Control.Monad.Catch
import Control.Monad.Morph (hoist)
+import Control.Monad.Fail
import Language.Haskell.TH
import Language.Haskell.TH.Instances ()
import Instances.TH.Lift ()
+import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
import Text.Shakespeare.Text (st)
+import Data.Aeson (FromJSONKey)
import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
+import qualified Data.Yaml as Yaml
import Data.Universe
@@ -68,6 +79,10 @@ import qualified Data.ByteString.Base64.URL as Base64
import qualified Crypto.Saltine.Core.SecretBox as SecretBox
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 Data.ByteArray (ByteArrayAccess)
import Data.Fixed
-- import Data.Ratio ((%))
@@ -88,10 +103,15 @@ import Data.Constraint (Dict(..))
import Control.Monad.Random.Class (MonadRandom)
import qualified System.Random.Shuffle as Rand (shuffleM)
+import Data.Data (Data)
+import qualified Data.Text.Lazy.Builder as Builder
+
+import Unsafe.Coerce
+
{-# ANN module ("HLint: ignore Use asum" :: String) #-}
-$(iconShortcuts) -- declares constants for all known icons
+iconShortcuts -- declares constants for all known icons
-----------
-- Yesod --
@@ -128,6 +148,36 @@ maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)]
maybeAttribute _ _ Nothing = []
maybeAttribute a c (Just v) = [(a,c v)]
+
+newtype PrettyValue = PrettyValue { unPrettyValue :: Value }
+ deriving (Eq, Read, Show, Generic, Typeable, Data)
+ deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
+
+instance ToContent PrettyValue where
+ toContent = toContent . Builder.toLazyText . Aeson.encodePrettyToTextBuilder
+instance ToTypedContent PrettyValue where
+ toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
+instance HasContentType PrettyValue where
+ getContentType _ = typeJson
+
+toPrettyJSON :: ToJSON a => a -> PrettyValue
+toPrettyJSON = PrettyValue . toJSON
+
+
+newtype YamlValue = YamlValue { unYamlValue :: Value }
+ deriving (Eq, Read, Show, Generic, Typeable, Data)
+ deriving newtype (Hashable, IsString, TH.Lift, FromJSON, ToJSON, NFData)
+
+instance ToContent YamlValue where
+ toContent = toContent . Yaml.encode
+instance ToTypedContent YamlValue where
+ toTypedContent = TypedContent <$> getContentType . (return @Proxy) <*> toContent
+instance HasContentType YamlValue where
+ getContentType _ = "text/vnd.yaml"
+
+toYAML :: ToJSON a => a -> YamlValue
+toYAML = YamlValue . toJSON
+
---------------------
-- Text and String --
@@ -275,18 +325,35 @@ roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c
roundDiv digits numerator denominator
= roundToDigits digits $ fromIntegral numerator / fromIntegral denominator
--- | A value between 0 and 1, measuring how close `achieved` is to `full`; 0 meaning very and 1 meaning not at all
--- `offset` specifies minimum result value, unless the goal is already achieved )i.e. full <= max(0,achieved)
--- Useful for heat maps, with offset giving a visual step between completed and not yet completed
-cutOffPercent :: Double -> Double -> Double -> Double
-cutOffPercent offset full achieved
+-- | @cutOffCoPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@; 0 meaning very and 1 meaning not at all
+--
+-- @offset@ specifies minimum result value, unless the @full@ is equal to @achieved@
+--
+-- Useful for heat maps, with offset giving a visual step between completed and not yet completed
+cutOffCoPercent :: Rational -> Rational -> Rational -> Rational
+cutOffCoPercent (abs -> offset) (abs -> full) (abs -> achieved)
+ | 0 <= achieved, achieved < full
+ , full /= 0
+ = offset + (1-offset) * (1 - percent)
| full <= achieved = 0
- | full <= 0 = 0
- | otherwise = offset + (1-offset) * (1 - percent)
+ | otherwise = 1
+ where
+ percent = achieved / full
+
+-- | @cutOffPercent offset full achieved@ returns a value between 0 and 1, measuring how close @achieved@ is to @full@@; 1 meaning very and 0 meaning not at all
+--
+-- @offset@ specifies minimum result value, unless @achieved@ is zero
+--
+-- Useful for heat maps, with offset giving a visual step between zero and nonzero
+cutOffPercent :: Rational -> Rational -> Rational -> Rational
+cutOffPercent (abs -> offset) (abs -> full) (abs -> achieved)
+ | 0 < achieved, achieved <= full
+ , full /= 0
+ = offset + (1-offset) * percent
+ | achieved <= 0 = 0
+ | otherwise = 1
where
percent = achieved / full
-
-
------------
-- Monoid --
@@ -415,6 +482,9 @@ assocsSet = setOf folded . imap (,)
mapF :: (Ord k, Finite k) => (k -> v) -> Map k v
mapF = flip Map.fromSet $ Set.fromList universeF
+partitionKeysEither :: Map (Either k1 k2) v -> (Map k1 v, Map k2 v)
+partitionKeysEither = over _2 (Map.mapKeysMonotonic . view $ singular _Right) . over _1 (Map.mapKeysMonotonic . view $ singular _Left) . Map.partitionWithKey (\k _ -> is _Left k)
+
---------------
-- Functions --
---------------
@@ -595,6 +665,9 @@ guardMExceptT b err = unless b $ lift err >>= throwE
exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
exceptT f g = either f g <=< runExceptT
+catchIfExceptT :: (MonadCatch m, Exception e) => (e -> e') -> (e -> Bool) -> m a -> ExceptT e' m a
+catchIfExceptT err p act = catchIf p (lift act) (throwE . err)
+
catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
@@ -620,13 +693,19 @@ guardM f = guard =<< f
assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
assertM f x = x >>= assertM' f
+assertMM :: MonadPlus m => (a -> m Bool) -> m a -> m a
+assertMM f x = do
+ x' <- x
+ guardM $ f x'
+ return x'
+
assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m ()
assertM_ f x = guard . f =<< x
assertM' :: Alternative m => (a -> Bool) -> a -> m a
assertM' f x = x <$ guard (f x)
-guardOn :: Alternative m => Bool -> a -> m a
+guardOn :: forall m a. Alternative m => Bool -> a -> m a
guardOn b x = x <$ guard b
guardOnM :: Alternative m => Bool -> m a -> m a
@@ -744,30 +823,13 @@ choice = foldr (<|>) empty
-- Sessions --
--------------
-data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
- | SessionNewStudyTerms | SessionConflictingStudyTerms
- | SessionBearer
- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
-instance Universe SessionKey
-instance Finite SessionKey
+-- Moved to Utils.Session
-nullaryPathPiece ''SessionKey $ camelToPathPiece' 1
-
-setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
-setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
-
-lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
-lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key
-
-modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m ()
-modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f
-
-tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m ()
-tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty
-
-takeSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
--- ^ `lookupSessionJson` followed by `deleteSession`
-takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
+-------------
+-- Cookies --
+-------------
+
+-- Moved to Utils.Cookies.Registered
--------------------
-- GET Parameters --
@@ -779,7 +841,7 @@ takeSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)
-- Custom HTTP Headers --
---------------------------------
-data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit | HeaderMassInputShortcircuit | HeaderAlerts
+data CustomHeader = HeaderIsModal | HeaderDBTableShortcircuit | HeaderMassInputShortcircuit | HeaderAlerts | HeaderDBTableCanonicalURL
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe CustomHeader
@@ -909,6 +971,20 @@ encodedSecretBoxOpen ciphertext = do
sKey <- secretBoxKey
encodedSecretBoxOpen' sKey ciphertext
+
+kmaclazy :: forall a string key ba chunk.
+ ( HashSHAKE a
+ , ByteArrayAccess string
+ , ByteArrayAccess key
+ , ByteArrayAccess chunk
+ , LazySequence ba chunk
+ )
+ => string
+ -> key
+ -> ba
+ -> KMAC a
+kmaclazy str k = KMAC.finalize . KMAC.updates (KMAC.initialize @a str k) . toChunks
+
-------------
-- Caching --
-------------
@@ -916,6 +992,9 @@ encodedSecretBoxOpen ciphertext = do
cachedByBinary :: (Binary a, Typeable b, MonadHandler m) => a -> m b -> m b
cachedByBinary k = cachedBy (toStrict $ Binary.encode k)
+cacheIdentHere :: Q Exp
+cacheIdentHere = TH.lift =<< location
+
cachedHere :: Q Exp
cachedHere = do
loc <- location
@@ -1009,3 +1088,58 @@ mpreview = hoistMaybe <=< preview
mpreviews :: (MonadPlus m, MonadReader s m) => Getting (First b) s a -> (a -> b) -> m b
mpreviews a f = hoistMaybe =<< previews a f
+
+-------------
+-- HashMap --
+-------------
+
+newtype MergeHashMap k v = MergeHashMap { unMergeHashMap :: HashMap k v }
+ deriving (Show, Generic, Typeable, Data)
+ deriving newtype ( Eq, Ord, Hashable
+ , Functor, Foldable, NFData
+ , ToJSON
+ )
+
+makePrisms ''MergeHashMap
+makeWrapped ''MergeHashMap
+
+instance Traversable (MergeHashMap k) where
+ traverse = _MergeHashMap . traverse
+
+instance FunctorWithIndex k (MergeHashMap k)
+instance TraversableWithIndex k (MergeHashMap k) where
+ itraverse = _MergeHashMap .> itraverse
+instance FoldableWithIndex k (MergeHashMap k)
+
+instance (Eq k, Hashable k, Semigroup v) => Semigroup (MergeHashMap k v) where
+ (MergeHashMap a) <> (MergeHashMap b) = MergeHashMap $ HashMap.unionWith (<>) a b
+instance (Eq k, Hashable k, Semigroup v) => Monoid (MergeHashMap k v) where
+ mempty = MergeHashMap HashMap.empty
+instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeHashMap k v) where
+ parseJSON = case Aeson.fromJSONKey of
+ Aeson.FromJSONKeyCoerce _ -> Aeson.withObject "HashMap ~Text" $
+ uc . HashMap.traverseWithKey (\k v -> parseJSON v Aeson. Aeson.Key k)
+ Aeson.FromJSONKeyText f -> Aeson.withObject "HashMap" $
+ fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) (f k) <$> parseJSON v Aeson. Aeson.Key k <*> m) (pure mempty)
+ Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
+ fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) <$> f k Aeson. Aeson.Key k <*> parseJSON v Aeson. Aeson.Key k <*> m) (pure mempty)
+ Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
+ fmap (MergeHashMap . HashMap.fromListWith (<>)) . sequence .
+ zipWith (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
+ where
+ uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v)
+ uc = unsafeCoerce
+
+ parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b)
+ parseIndexedJSONPair keyParser valParser idx value = p value Aeson. Aeson.Index idx
+ where
+ p = Aeson.withArray "(k, v)" $ \ab ->
+ let n = V.length ab
+ in if n == 2
+ then (,) <$> parseJSONElemAtIndex keyParser 0 ab
+ <*> parseJSONElemAtIndex valParser 1 ab
+ else fail $ "cannot unpack array of length " ++
+ show n ++ " into a pair"
+
+ parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
+ parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson. Aeson.Index idx
diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs
index ffdd3684d..323985f6a 100644
--- a/src/Utils/Allocation.hs
+++ b/src/Utils/Allocation.hs
@@ -39,16 +39,21 @@ data MatchingLog student course cloneIndex
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance (NFData student, NFData course, NFData cloneIndex) => NFData (MatchingLog student course cloneIndex)
+deriveJSON defaultOptions
+ { constructorTagModifier = camelToPathPiece' 1
+ , fieldLabelModifier = camelToPathPiece' 1
+ } ''MatchingLog
+
computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'.
( RandomGen randomGen
, Ord student, Ord course
, NFData student
, Ord studentRatingCourse
, Ord courseRatingStudent'
- , Integral cloneCount, Integral capacity, Num cloneIndex
+ , Integral cloneCount, Integral capacity, Integral cloneIndex
)
=> randomGen -- ^ Source of randomness
- -> Map student cloneCount -- ^ requested number of placements per student
+ -> Map student (cloneIndex, cloneCount) -- ^ requested number of placements per student
-> Map course (Maybe capacity) -- ^ capacity of courses
-> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@
-> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority)
@@ -62,10 +67,10 @@ computeMatchingLog :: forall randomGen student course cloneCount cloneIndex capa
, NFData student
, Ord studentRatingCourse
, Ord courseRatingStudent'
- , Integral cloneCount, Integral capacity, Num cloneIndex
+ , Integral cloneCount, Integral capacity, Integral cloneIndex
)
=> randomGen -- ^ Source of randomness
- -> Map student cloneCount -- ^ requested number of placements per student
+ -> Map student (cloneIndex, cloneCount) -- ^ requested number of placements and first cloneIndex per student
-> Map course (Maybe capacity) -- ^ capacity of courses
-> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@
-> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority)
@@ -231,11 +236,14 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
courseRating c (st, cn) = do
(_, courseRating') <- preferences Map.!? (st, c)
return $ centralNudge st (fromIntegral cn) courseRating'
+
+ cloneIndices :: cloneIndex -> cloneCount -> Set CloneIndex
+ cloneIndices firstClone clones = Set.fromList $ map fromIntegral [firstClone, pred $ firstClone + fromIntegral clones]
clonedStudents :: Set (student, CloneIndex)
clonedStudents = Set.fromDistinctAscList $ do
- (student, clones) <- Map.toAscList cloneCounts
- clone <- [0,1..pred $ fromIntegral clones]
+ (student, (firstClone, clones)) <- Map.toAscList cloneCounts
+ clone <- Set.toAscList $ cloneIndices firstClone clones
return (student, clone)
contStudents :: Iso' student StudentIndex
@@ -247,7 +255,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
fromInt = (!!) students'
studentBounds :: ((StudentIndex, CloneIndex), (StudentIndex, CloneIndex))
- studentBounds = ((0, 0), (pred $ Map.size cloneCounts, maybe 0 maximum . fromNullable $ pred . fromIntegral <$> cloneCounts))
+ studentBounds = ((0, 0), (pred $ Map.size cloneCounts, fromMaybe 0 $ maximumOf (folded . to (uncurry cloneIndices) . folded) cloneCounts))
courses :: Set course
courses = Set.fromDistinctAscList . map (view _1) . filter (maybe True (> 0) . view _2) $ Map.toAscList capacities
diff --git a/src/Utils/Cookies.hs b/src/Utils/Cookies.hs
new file mode 100644
index 000000000..1d96e43e4
--- /dev/null
+++ b/src/Utils/Cookies.hs
@@ -0,0 +1,27 @@
+module Utils.Cookies
+ ( getCookiePath
+ , siteApproot
+ , cookiePath
+ ) where
+
+import ClassyPrelude.Yesod
+
+import qualified Network.Wai as Wai
+
+
+cookiePath :: Maybe Text -> ByteString
+cookiePath = maybe "/" $ extractPath . encodeUtf8
+
+siteApproot :: Yesod site => site -> Wai.Request -> Maybe Text
+siteApproot master req = case approot of
+ ApprootRelative -> Nothing
+ ApprootStatic t -> Just t
+ ApprootMaster f -> Just $ f master
+ ApprootRequest f -> Just $ f master req
+
+getCookiePath :: (MonadHandler m, Yesod (HandlerSite m)) => m ByteString
+getCookiePath = do
+ app <- getYesod
+ req <- reqWaiRequest <$> getRequest
+
+ return . cookiePath $ siteApproot app req
diff --git a/src/Utils/Cookies/Registered.hs b/src/Utils/Cookies/Registered.hs
new file mode 100644
index 000000000..e94afb763
--- /dev/null
+++ b/src/Utils/Cookies/Registered.hs
@@ -0,0 +1,133 @@
+module Utils.Cookies.Registered
+ ( RegisteredCookie(..)
+ , lookupRegisteredCookie, lookupRegisteredCookies
+ , lookupRegisteredCookieJson, lookupRegisteredCookiesJson
+ , setRegisteredCookie, setRegisteredCookie'
+ , setRegisteredCookieJson, setRegisteredCookieJson'
+ , modifyRegisteredCookieJson, modifyRegisteredCookieJson'
+ , tellRegisteredCookieJson, tellRegisteredCookieJson'
+ , deleteRegisteredCookie, deleteRegisteredCookie'
+ ) where
+
+import ClassyPrelude.Yesod
+
+import Settings.Cookies
+
+import Utils.Cookies
+import Utils.PathPiece
+
+import Data.Universe
+import Control.Lens
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Text as Aeson
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Data.ByteString.Base64.URL as Base64
+
+import Web.Cookie (SetCookie(..))
+
+import Data.Char (isAscii)
+import Data.Monoid (Last(..))
+
+
+data RegisteredCookie = CookieSession | CookieXSRFToken | CookieLang | CookieSystemMessageState
+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+ deriving anyclass (Universe, Finite, Hashable)
+
+nullaryPathPiece ''RegisteredCookie $ toUpper . camelToPathPiece' 1
+pathPieceJSON ''RegisteredCookie
+pathPieceJSONKey ''RegisteredCookie
+
+
+_CookieEncoded :: Prism' Text Text
+_CookieEncoded = prism' cEncode cDecode
+ where
+ b64Prefix = "base64url:"
+
+ cDecode t
+ | Just encoded <- Text.stripPrefix b64Prefix t
+ = either (const Nothing) Just . Text.decodeUtf8' <=< either (const Nothing) Just . Base64.decode $ Text.encodeUtf8 encoded
+ | Text.all isAscii t = Just t
+ | otherwise = Nothing
+
+ cEncode t
+ | Text.all isAscii t
+ , not $ b64Prefix `Text.isPrefixOf` t
+ = t
+ | otherwise
+ = b64Prefix <> Text.decodeUtf8 (Base64.encode $ Text.encodeUtf8 t)
+
+newtype RegisteredCookieCurrentValue = RegisteredCookieCurrentValue { getRegisteredCookieCurrentValue :: Maybe Text }
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+
+-- Primitive
+setRegisteredCookie' :: (Textual t, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => (SetCookie -> SetCookie) -> RegisteredCookie -> t -> m ()
+setRegisteredCookie' modSet ident@(toPathPiece -> name) (review _CookieEncoded . repack -> content) = do
+ path <- getCookiePath
+ defSetCookie <- cookieSettingsToSetCookie . ($ ident) =<< getsYesod getCookieSettings
+
+ setCookie $ modSet defSetCookie
+ { setCookieName = Text.encodeUtf8 name
+ , setCookieValue = Text.encodeUtf8 content
+ , setCookiePath = Just path
+ }
+
+ cacheBySet (Text.encodeUtf8 name) . RegisteredCookieCurrentValue $ Just content
+
+setRegisteredCookie :: (Textual t, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => RegisteredCookie -> t -> m ()
+setRegisteredCookie = setRegisteredCookie' id
+
+setRegisteredCookieJson' :: (ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => (SetCookie -> SetCookie) -> RegisteredCookie -> v -> m ()
+setRegisteredCookieJson' modSet name = setRegisteredCookie' modSet name . Aeson.encodeToLazyText
+
+setRegisteredCookieJson :: (ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => RegisteredCookie -> v -> m ()
+setRegisteredCookieJson = setRegisteredCookieJson' id
+
+modifyRegisteredCookieJson' :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => (SetCookie -> SetCookie) -> RegisteredCookie -> ([v] -> Maybe v) -> m ()
+modifyRegisteredCookieJson' modSet name modVal = lookupRegisteredCookiesJson pure name >>= maybe deleteRegisteredCookie'' (setRegisteredCookieJson' modSet name) . modVal
+ where deleteRegisteredCookie'' = do
+ path <- getCookiePath
+ let cookieSettings = modSet def{ setCookiePath = Just path }
+ deleteRegisteredCookie' name . maybe "/" Text.decodeUtf8 $ setCookiePath cookieSettings
+
+modifyRegisteredCookieJson :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m)) => RegisteredCookie -> ([v] -> Maybe v) -> m ()
+modifyRegisteredCookieJson = modifyRegisteredCookieJson' id
+
+tellRegisteredCookieJson' :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m), Monoid v) => (SetCookie -> SetCookie) -> RegisteredCookie -> v -> m ()
+tellRegisteredCookieJson' modSet name x = modifyRegisteredCookieJson' modSet name $ pure . (<> x) . fold
+
+tellRegisteredCookieJson :: (FromJSON v, ToJSON v, MonadHandler m, Yesod (HandlerSite m), HasCookieSettings RegisteredCookie (HandlerSite m), Monoid v) => RegisteredCookie -> v -> m ()
+tellRegisteredCookieJson = tellRegisteredCookieJson' id
+
+-- Primitive
+deleteRegisteredCookie' :: MonadHandler m
+ => RegisteredCookie -- ^ key
+ -> Text -- ^ path
+ -> m ()
+deleteRegisteredCookie' (toPathPiece -> name) path = do
+ deleteCookie name path
+ cacheBySet (Text.encodeUtf8 name) $ RegisteredCookieCurrentValue Nothing
+
+deleteRegisteredCookie :: (MonadHandler m, Yesod (HandlerSite m)) => RegisteredCookie -> m ()
+deleteRegisteredCookie name = deleteRegisteredCookie' name . Text.decodeUtf8 =<< getCookiePath
+
+-- Primitive
+lookupRegisteredCookies :: (Textual t, Monoid m, MonadHandler f) => (t -> m) -> RegisteredCookie -> f m
+lookupRegisteredCookies toM (toPathPiece -> name) = do
+ cachedVal <- cacheByGet (Text.encodeUtf8 name)
+ case cachedVal of
+ Nothing
+ -> foldMap (toM . repack) . mapMaybe (preview _CookieEncoded) <$> lookupCookies name
+ Just (RegisteredCookieCurrentValue v)
+ -> return . maybe mempty (toM . repack) $ v ^? _Just . _CookieEncoded
+
+lookupRegisteredCookie :: (Textual t, MonadHandler m) => RegisteredCookie -> m (Maybe t)
+lookupRegisteredCookie = fmap getLast . lookupRegisteredCookies pure
+
+lookupRegisteredCookiesJson :: (FromJSON v, Monoid m, MonadHandler f) => (v -> m) -> RegisteredCookie -> f m
+lookupRegisteredCookiesJson toM = fmap (fromMaybe mempty) . lookupRegisteredCookies (fmap toM . Aeson.decodeStrict' . Text.encodeUtf8)
+
+lookupRegisteredCookieJson :: (FromJSON v, MonadHandler m) => RegisteredCookie -> m (Maybe v)
+lookupRegisteredCookieJson = fmap getLast . lookupRegisteredCookiesJson pure
diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs
index fffdc8c51..5b514261b 100644
--- a/src/Utils/DB.hs
+++ b/src/Utils/DB.hs
@@ -56,9 +56,9 @@ existsBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity
=> Unique record -> ReaderT backend m ()
existsBy404 = bool notFound (return ()) <=< fmap (is _Just) . getKeyBy
-existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
+existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
=> Key record -> ReaderT backend m Bool
-existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
+existsKey = exists . pure . (persistIdField ==.)
exists :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadIO m)
=> [Filter record] -> ReaderT backend m Bool
@@ -68,6 +68,10 @@ exists404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity r
=> [Filter record] -> ReaderT backend m ()
exists404 = bool (return ()) notFound <=< fmap null . flip selectKeysList [LimitTo 1]
+existsKey404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistQueryRead backend, MonadHandler m)
+ => Key record -> ReaderT backend m ()
+existsKey404 = bool notFound (return ()) <=< existsKey
+
updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
=> Unique record -> [Update record] -> ReaderT backend m ()
updateBy uniq updates = do
diff --git a/src/Utils/Failover.hs b/src/Utils/Failover.hs
new file mode 100644
index 000000000..112ceab53
--- /dev/null
+++ b/src/Utils/Failover.hs
@@ -0,0 +1,131 @@
+module Utils.Failover
+ ( Failover
+ , mkFailover
+ , FailoverMode(..)
+ , withFailover, withFailoverReTest
+ ) where
+
+import ClassyPrelude hiding (try)
+import Utils (foldMapM)
+
+import Data.List.PointedList (PointedList)
+import qualified Data.List.PointedList as P
+
+import Numeric.Natural
+
+import System.Clock
+
+import Control.Lens hiding (failover)
+import Utils.Lens.TH
+
+import Data.List (unfoldr, genericTake)
+
+import Control.Monad.Catch
+import Control.Monad.Trans.Except (ExceptT, runExceptT)
+import Control.Monad.Trans.Cont (runContT)
+import Control.Monad.Cont.Class (MonadCont(..))
+
+import Control.Concurrent.STM.TVar (stateTVar)
+
+import Data.Void (vacuous)
+
+import Data.Fixed
+
+
+data FailoverItem a = FailoverItem
+ { failoverValue :: a
+ , failoverLastTest :: Maybe TimeSpec
+ }
+makeLenses_ ''FailoverItem
+
+newtype Failover a = Failover { failover :: TVar (PointedList (FailoverItem a)) }
+ deriving (Eq)
+
+data FailoverMode
+ = FailoverUnlimited
+ | FailoverLimited Natural
+ | FailoverNone
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+
+mkFailover :: MonadIO m
+ => PointedList a
+ -> m (Failover a)
+mkFailover opts = fmap Failover . liftIO $ newTVarIO opts'
+ where opts' = opts <&> \failoverValue -> FailoverItem{ failoverLastTest = Nothing, .. }
+
+
+withFailover :: ( MonadIO m, MonadCatch m
+ , Exception e
+ )
+ => Failover a
+ -> FailoverMode
+ -> (b -> ExceptT e m c)
+ -> (a -> m b)
+ -> m c
+withFailover f@Failover{..} mode detAcceptable act = do
+ now <- liftIO $ getTime Monotonic
+
+ FailoverItem{failoverValue} <- fmap (view P.focus) . liftIO $ readTVarIO failover
+
+ res <- act failoverValue
+ res' <- runExceptT $ detAcceptable res
+
+ let
+ recordFailure =
+ atomically . stateTVar failover $ \failover' -> case P.next $ failover' & P.focus . _failoverLastTest ?~ now of
+ Just failover'' -> (True, failover'')
+ Nothing -> (False, failover')
+ doRetry err = do
+ didNext <- recordFailure
+ let newMode = case mode of
+ FailoverLimited n -> FailoverLimited $ pred n
+ other -> other
+ if | didNext -> withFailover f newMode detAcceptable act
+ | otherwise -> throwM err
+
+ case (res', mode) of
+ (Left err, FailoverUnlimited)
+ -> doRetry err
+ (Left err, FailoverLimited n)
+ | n > 0
+ -> doRetry err
+ _other
+ -> void recordFailure >> either throwM return res'
+
+withFailoverReTest :: ( MonadIO m, MonadCatch m
+ , Exception e
+ )
+ => Failover a
+ -> (Nano -> Bool)
+ -> FailoverMode
+ -> (b -> ExceptT e m c)
+ -> (a -> m b)
+ -> m c
+withFailoverReTest f@Failover{..} doTest mode detAcceptable act = do
+ now <- liftIO $ getTime Monotonic
+
+ let filterFailover = filter $ \(view $ _2 . P.focus -> FailoverItem{failoverLastTest}) -> maybe True (\lT -> doTest . MkFixed . toNanoSecs $ now - lT) failoverLastTest
+
+ failover' <- fmap (reverse . filterFailover . unfoldr (\(i, l) -> ((i, ) &&& (succ i, )) <$> P.previous l) . (0,)) . liftIO $ readTVarIO failover
+
+ let failover'' = case mode of
+ FailoverUnlimited -> failover'
+ FailoverLimited n -> genericTake (succ n) failover'
+ FailoverNone -> take 1 failover'
+
+ reTestRes <- flip runContT return . callCC $ \((. Just) -> retRes) -> fmap vacuous . flip foldMapM failover'' $ \failover'''@(over _2 (view P.focus) -> (i, FailoverItem{failoverValue})) -> do
+ res <- lift $ act failoverValue
+ res' <- lift . runExceptT $ detAcceptable res
+
+ case res' of
+ Left _ -> do
+ atomically . modifyTVar failover $ P.reversedPrefix . ix i . _failoverLastTest ?~ now
+ return Nothing
+ Right res'' -> do
+ atomically . writeTVar failover $ view _2 failover''' & P.focus . _failoverLastTest ?~ now
+ retRes res''
+
+ case reTestRes of
+ Nothing -> withFailover f mode detAcceptable act
+ Just r -> return r
diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs
index 4ca0e17e9..6df3f8492 100644
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@@ -206,12 +206,11 @@ data FormIdentifier
| FIDSystemMessageModify
| FIDSystemMessageModifyTranslation UUID
| FIDSystemMessageAddTranslation
- | FIDDBTableFilter
- | FIDDBTablePagesize
- | FIDDBTable
- | FIDDBTableCsvExport
- | FIDDBTableCsvImport
- | FIDDBTableCsvImportConfirm
+ | FIDDBTableFilter Text
+ | FIDDBTablePagesize Text
+ | FIDDBTableCsvExport Text
+ | FIDDBTableCsvImport Text
+ | FIDDBTableCsvImportConfirm Text
| FIDDelete
| FIDCourseRegister
| FIDuserRights
@@ -226,6 +225,7 @@ data FormIdentifier
| FIDAllUsersAction
| FIDLanguage
| FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID
+ | FIDAllocationAccept
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where
@@ -233,7 +233,7 @@ instance PathPiece FormIdentifier where
toPathPiece = showToPathPiece
-identifyForm' :: (Monad m, PathPiece ident, Eq ident)
+identifyForm' :: (MonadLogger m, PathPiece ident, Eq ident)
=> Lens' x (FormResult a)
-> ident -- ^ Form identification
-> (Html -> MForm m (x, widget))
@@ -242,12 +242,16 @@ identifyForm' resLens identVal form fragment = do
-- Create hidden
.
let fragment' =
[shamlet|
+ $newline never
#{fragment}
|]
-- Check if we got its value back.
- hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier
+ identVal' <- lookupGlobalPostParamForm PostFormIdentifier
+ let hasIdent = identVal' == Just identVal
+
+ $logDebugS "identifyForm'" $ tshow (toPathPiece <$> identVal', toPathPiece identVal, hasIdent)
-- Run the form proper (with our hidden
). If the
-- data is missing, then do not provide any params to the
@@ -255,9 +259,9 @@ identifyForm' resLens identVal form fragment = do
-- doing this avoids having lots of fields with red errors.
let eraseParams | not hasIdent = local (\(_, h, l) -> (Nothing, h, l))
| otherwise = id
- fmap (over (_1 . resLens) $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment'
+ bool (set (mapped . _1 . resLens) FormMissing . eraseParams) id hasIdent $ form fragment'
-identifyForm :: (Monad m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget))
+identifyForm :: (MonadLogger m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget))
identifyForm = identifyForm' id
@@ -393,11 +397,11 @@ buttonView btn = do
-- | generate a form that only shows a finite amount of buttons
-buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
+buttonForm :: (MonadHandler m, Button (HandlerSite m) a, Finite a) => Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
buttonForm = buttonForm' universeF
-- | like `buttonForm`, but for a given list of buttons, i.e. a subset or for buttons outside the Finite typeclass
-buttonForm' :: Button site a => [a] -> Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
+buttonForm' :: (MonadHandler m, Button (HandlerSite m) a) => [a] -> Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
buttonForm' btns csrf = do
(res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns ""
return (res, [whamlet|
@@ -407,6 +411,36 @@ buttonForm' btns csrf = do
^{fvInput bView}
|])
+withButtonForm' :: (MonadHandler m, Button (HandlerSite m) btn)
+ => [btn]
+ -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+ -> (Html -> MForm m (FormResult (a, btn), WidgetT (HandlerSite m) IO ()))
+withButtonForm' = withButtonFormM' . const . return
+
+withButtonFormComb' :: (MonadHandler m, Button (HandlerSite m) btn)
+ => (FormResult a -> FormResult btn -> FormResult b)
+ -> [btn]
+ -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+ -> (Html -> MForm m (FormResult b, WidgetT (HandlerSite m) IO ()))
+withButtonFormComb' f = withButtonFormCombM' f . const . return
+
+withButtonFormM' :: (MonadHandler m, Button (HandlerSite m) btn)
+ => (FormResult a -> MForm m [btn])
+ -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+ -> (Html -> MForm m (FormResult (a, btn), WidgetT (HandlerSite m) IO ()))
+withButtonFormM' = withButtonFormCombM' (\x btn -> (,) <$> x <*> btn)
+
+withButtonFormCombM' :: (MonadHandler m, Button (HandlerSite m) btn)
+ => (FormResult a -> FormResult btn -> FormResult b)
+ -> (FormResult a -> MForm m [btn])
+ -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+ -> (Html -> MForm m (FormResult b, WidgetT (HandlerSite m) IO ()))
+withButtonFormCombM' combF mkBtns innerForm csrf = do
+ (innerRes, innerView) <- innerForm csrf
+ btns <- mkBtns innerRes
+ (buttonRes, btnView) <- buttonForm' btns mempty
+ return (combF innerRes buttonRes, innerView <> btnView)
+
-- | buttons-only form complete with widget-generation and evaluation; return type determines buttons shown.
runButtonForm ::(PathPiece ident, Eq ident, RenderMessage site FormMessage,
Button site ButtonSubmit, Button site a, Finite a)
@@ -638,32 +672,6 @@ secretJsonField :: forall m a.
=> Field m a
secretJsonField = secretJsonField' $ fieldView (hiddenField :: Field m Text)
-fileFieldMultiple :: Monad m => Field m [FileInfo]
-fileFieldMultiple = Field{..}
- where
- fieldEnctype = Multipart
- fieldParse _ files = return $ case files of
- [] -> Right Nothing
- fs -> Right $ Just fs
- fieldView id' name attrs _ isReq =
- [whamlet|
- $newline never
-
- |]
-
-fileField :: Monad m => Field m FileInfo
-fileField = Field{..}
- where
- fieldEnctype = Multipart
- fieldParse _ files = return $ case files of
- [] -> Right Nothing
- f : _ -> Right $ Just f
- fieldView id' name attrs _ isReq =
- [whamlet|
- $newline never
-
- |]
-
guardField :: Functor m => (a -> Bool) -> Field m a -> Field m a
guardField p field = field { fieldParse = \ts fs -> fieldParse field ts fs <&> \case
Right (Just x)
@@ -724,7 +732,94 @@ selectField' optMsg mkOpts = Field{..}
#{optionDisplay opt}
|]
+radioField' :: ( Eq a
+ , RenderMessage (HandlerSite m) FormMessage
+ , MonadHandler m
+ )
+ => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option
+ -> HandlerT (HandlerSite m) IO (OptionList a)
+ -> Field m a
+-- ^ Like @radioField@, but with more control over the @Nothing@-Option, if Field is optional
+radioField' optMsg mkOpts = Field{..}
+ where
+ fieldEnctype = UrlEncoded
+ fieldParse [] _ = return $ Right Nothing
+ fieldParse (s:_) _
+ | s == "" = return $ Right Nothing
+ | otherwise = do
+ OptionList{olReadExternal} <- liftHandler mkOpts
+ return . maybe (Left . SomeMessage $ MsgInvalidEntry s) (Right . Just) $ olReadExternal s
+
+ fieldView theId name attrs val isReq = do
+ OptionList{olOptions} <- liftHandler mkOpts
+ let
+ rendered = case val of
+ Left _ -> ""
+ Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
+
+ isSel Nothing = not $ rendered `elem` map optionExternalValue olOptions
+ isSel (Just opt) = rendered == optionExternalValue opt
+ [whamlet|
+ $newline never
+
+ $maybe optMsgM <- assertM (const $ not isReq) optMsg
+