$if isRegistered
@@ -86,6 +105,9 @@ getEShowR tid ssh csh examn = do
| fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
| otherwise = Nothing
+ showMaxPoints = any (has $ _entityVal . _examPartMaxPoints . _Just) examParts
+ showAchievedPoints = not $ null results
+
let heading = prependCourseTitle tid ssh csh $ CI.original examName
siteLayoutMsg heading $ do
diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs
index 692a69c3c..a5f49fb46 100644
--- a/src/Handler/Exam/Users.hs
+++ b/src/Handler/Exam/Users.hs
@@ -4,25 +4,27 @@ module Handler.Exam.Users
( getEUsersR, postEUsersR
) where
-import Import
+import Import hiding ((<.), (.>))
import Handler.Utils
import Handler.Utils.Exam
-import Handler.Utils.Table.Columns
-import Handler.Utils.Table.Cells
import Handler.Utils.Csv
+import Handler.ExamOffice.Exam (examCloseWidget)
+
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import qualified Data.Csv as Csv
-import Data.Map ((!))
+import Data.Map ((!), (!?))
import qualified Data.Map as Map
import qualified Data.Set as Set
+import qualified Data.HashMap.Lazy as HashMap
import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
import qualified Data.Text.Lens as Text
import qualified Data.Conduit.List as C
@@ -33,9 +35,35 @@ import Numeric.Lens (integral)
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
+import Control.Lens.Indexed ((<.), (.>))
-type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
-type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult), Maybe (Entity CourseUserNote))
+import Jobs.Queue
+
+
+type ExamUserTableExpr = ( E.SqlExpr (Entity ExamRegistration)
+ `E.InnerJoin` E.SqlExpr (Entity User)
+ )
+ `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence))
+ `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity CourseParticipant))
+ `E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
+ `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
+ `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
+ )
+ )
+ `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamBonus))
+ `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult))
+ `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
+type ExamUserTableData = DBRow ( Entity ExamRegistration
+ , Entity User
+ , Maybe (Entity ExamOccurrence)
+ , Maybe (Entity StudyFeatures)
+ , Maybe (Entity StudyDegree)
+ , Maybe (Entity StudyTerms)
+ , Maybe (Entity ExamBonus)
+ , Maybe (Entity ExamResult)
+ , Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult))
+ , Maybe (Entity CourseUserNote)
+ )
instance HasEntity ExamUserTableData User where
hasEntity = _dbrOutput . _2
@@ -47,28 +75,51 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
_userTableOccurrence = _dbrOutput . _3
queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
-queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1)
-
-queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
-queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
+queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 6 1)
queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
-queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1)
+queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 6 1)
queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
-queryExamOccurrence = $(sqlLOJproj 5 2)
+queryExamOccurrence = $(sqlLOJproj 6 2)
+
+queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant))
+queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3)
+
+queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
+queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
-queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
+queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
-queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
+queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
+
+queryExamBonus :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamBonus))
+queryExamBonus = $(sqlLOJproj 6 4)
queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
-queryExamResult = $(sqlLOJproj 5 4)
+queryExamResult = $(sqlLOJproj 6 5)
queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
-queryCourseNote = $(sqlLOJproj 5 5)
+queryCourseNote = $(sqlLOJproj 6 6)
+
+queryExamPart :: forall a.
+ PersistField a
+ => ExamPartId
+ -> (E.SqlExpr (Entity ExamPart) -> E.SqlExpr (Maybe (Entity ExamPartResult)) -> E.SqlQuery (E.SqlExpr (E.Value a)))
+ -> ExamUserTableExpr
+ -> E.SqlExpr (E.Value a)
+queryExamPart epId cont inp = E.sub_select . E.from $ \(examPart `E.LeftOuterJoin` examPartResult) -> flip runReaderT inp $ do
+ examRegistration <- asks queryExamRegistration
+
+ lift $ do
+ E.on $ E.just (examPart E.^. ExamPartId) E.==. examPartResult E.?. ExamPartResultExamPart
+ E.&&. examPartResult E.?. ExamPartResultUser E.==. E.just (examRegistration E.^. ExamRegistrationUser)
+ E.where_ $ examPart E.^. ExamPartExam E.==. examRegistration E.^. ExamRegistrationExam
+ E.&&. examPart E.^. ExamPartId E.==. E.val epId
+
+ cont examPart examPartResult
resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
resultExamRegistration = _dbrOutput . _1
@@ -88,11 +139,48 @@ resultStudyField = _dbrOutput . _6 . _Just
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
resultExamOccurrence = _dbrOutput . _3 . _Just
+resultExamBonus :: Traversal' ExamUserTableData (Entity ExamBonus)
+resultExamBonus = _dbrOutput . _7 . _Just
+
resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
-resultExamResult = _dbrOutput . _7 . _Just
+resultExamResult = _dbrOutput . _8 . _Just
+
+resultExamParts :: IndexedTraversal' ExamPartId ExamUserTableData (ExamPart, Maybe (Entity ExamPartResult))
+resultExamParts = _dbrOutput . _9 . itraversed
+
+-- resultExamParts' :: Traversal' ExamUserTableData (Entity ExamPart)
+-- resultExamParts' = (resultExamParts <. _1) . withIndex . from _Entity
+
+resultExamPartResult :: ExamPartId -> Lens' ExamUserTableData (Maybe (Entity ExamPartResult))
+resultExamPartResult epId = _dbrOutput . _9 . unsafeSingular (ix epId) . _2
+
+resultExamPartResults :: IndexedTraversal' ExamPartId ExamUserTableData (Maybe (Entity ExamPartResult))
+resultExamPartResults = resultExamParts <. _2
resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
-resultCourseNote = _dbrOutput . _8 . _Just
+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'))
+
+resultAutomaticExamResult :: Exam -> Map UserId SheetTypeSummary -> Fold ExamUserTableData ExamResultGrade
+resultAutomaticExamResult exam examBonus' = folding . runReader $ do
+ parts' <- asks $ sequence . toListOf (resultExamPartResults . to (^? _Just . _entityVal . _examPartResultResult))
+ bonus <- preview $ resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus exam examBonus'
+ return $ examGrade exam bonus =<< parts'
+
+
+csvExamPartHeader :: Prism' Csv.Name ExamPartNumber
+csvExamPartHeader = prism' toHeader fromHeader
+ where
+ toHeader pName = encodeUtf8 $ partPrefix <> CI.foldedCase (pName ^. _ExamPartNumber)
+ fromHeader hdr = do
+ tHdr <- either (const Nothing) Just $ Text.decodeUtf8' hdr
+ review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr
+
+ partPrefix = "part-"
+
data ExamUserTableCsv = ExamUserTableCsv
{ csvEUserSurname :: Maybe Text
@@ -103,24 +191,46 @@ data ExamUserTableCsv = ExamUserTableCsv
, csvEUserDegree :: Maybe Text
, csvEUserSemester :: Maybe Int
, csvEUserOccurrence :: Maybe (CI Text)
- , csvEUserExercisePoints :: Maybe Points
- , csvEUserExerciseNumPasses :: Maybe Int
- , csvEUserExercisePointsMax :: Maybe Points
- , csvEUserExerciseNumPassesMax :: Maybe Int
+ , csvEUserExercisePoints :: Maybe (Maybe Points)
+ , csvEUserExerciseNumPasses :: Maybe (Maybe Int)
+ , csvEUserExercisePointsMax :: Maybe (Maybe Points)
+ , csvEUserExerciseNumPassesMax :: Maybe (Maybe Int)
+ , csvEUserBonus :: Maybe (Maybe Points)
+ , csvEUserExamPartResults :: Map ExamPartNumber (Maybe ExamResultPoints)
, csvEUserExamResult :: Maybe ExamResultPassedGrade
, csvEUserCourseNote :: Maybe Html
}
deriving (Generic)
makeLenses_ ''ExamUserTableCsv
-examUserTableCsvOptions :: Csv.Options
-examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
-
instance ToNamedRecord ExamUserTableCsv where
- toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
+ toNamedRecord ExamUserTableCsv{..} = Csv.namedRecord $
+ [ "surname" Csv..= csvEUserSurname
+ , "first-name" Csv..= csvEUserFirstName
+ , "name" Csv..= csvEUserName
+ , "matriculation" Csv..= csvEUserMatriculation
+ , "field" Csv..= csvEUserField
+ , "degree" Csv..= csvEUserDegree
+ , "semester" Csv..= csvEUserSemester
+ , "occurrence" Csv..= csvEUserOccurrence
+ ] ++ catMaybes
+ [ fmap ("exercise-points" Csv..=) csvEUserExercisePoints
+ , fmap ("exercise-num-passes" Csv..=) csvEUserExerciseNumPasses
+ , fmap ("exercise-points-max" Csv..=) csvEUserExercisePointsMax
+ , fmap ("exercise-num-passes-max" Csv..=) csvEUserExerciseNumPassesMax
+ , fmap ("bonus" Csv..=) csvEUserBonus
+ ]
+ ++ examPartResults ++
+ [ "exam-result" Csv..= csvEUserExamResult
+ , "course-note" Csv..= csvEUserCourseNote
+ ]
+ where
+ examPartResults
+ = flip ifoldMap csvEUserExamPartResults $
+ \pNumber pResult -> pure $ (csvExamPartHeader # pNumber) Csv..= pResult
instance FromNamedRecord ExamUserTableCsv where
- parseNamedRecord csv -- Manually defined awaiting issue #427
+ parseNamedRecord csv
= ExamUserTableCsv
<$> csv .:?? "surname"
<*> csv .:?? "first-name"
@@ -130,36 +240,66 @@ instance FromNamedRecord ExamUserTableCsv where
<*> csv .:?? "degree"
<*> csv .:?? "semester"
<*> csv .:?? "occurrence"
- <*> csv .:?? "exercise-points"
- <*> csv .:?? "exercise-num-passes"
- <*> csv .:?? "exercise-points-max"
- <*> csv .:?? "exercise-num-passes-max"
+ <*> fmap Just (csv .:?? "exercise-points")
+ <*> fmap Just (csv .:?? "exercise-num-passes")
+ <*> fmap Just (csv .:?? "exercise-points-max")
+ <*> fmap Just (csv .:?? "exercise-num-passes-max")
+ <*> fmap Just (csv .:?? "bonus")
+ <*> examPartResults
<*> csv .:?? "exam-result"
<*> csv .:?? "course-note"
-
-instance DefaultOrdered ExamUserTableCsv where
- headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
+ where
+ examPartResults = fmap fold . sequence . flip HashMap.mapMaybeWithKey csv $ \pNumber' _ -> do
+ pNumber <- pNumber' ^? csvExamPartHeader
+ return . fmap (singletonMap pNumber ) $ csv .:?? pNumber'
instance CsvColumnsExplained ExamUserTableCsv where
- csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
- [ ('csvEUserSurname , MsgCsvColumnExamUserSurname )
- , ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
- , ('csvEUserName , MsgCsvColumnExamUserName )
- , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
- , ('csvEUserField , MsgCsvColumnExamUserField )
- , ('csvEUserDegree , MsgCsvColumnExamUserDegree )
- , ('csvEUserSemester , MsgCsvColumnExamUserSemester )
- , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence )
- , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints )
- , ('csvEUserExerciseNumPasses , MsgCsvColumnExamUserExercisePasses )
- , ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax )
- , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax )
- , ('csvEUserExamResult , MsgCsvColumnExamUserResult )
- , ('csvEUserCourseNote , MsgCsvColumnExamUserCourseNote )
+ csvColumnsExplanations _ = mconcat
+ [ single "surname" MsgCsvColumnExamUserSurname
+ , single "first-name" MsgCsvColumnExamUserFirstName
+ , single "name" MsgCsvColumnExamUserName
+ , single "matriculation" MsgCsvColumnExamUserMatriculation
+ , single "field" MsgCsvColumnExamUserField
+ , single "degree" MsgCsvColumnExamUserDegree
+ , single "semester" MsgCsvColumnExamUserSemester
+ , single "occurrence" MsgCsvColumnExamUserOccurrence
+ , single "exercise-points" MsgCsvColumnExamUserExercisePoints
+ , single "exercise-num-passes" MsgCsvColumnExamUserExercisePasses
+ , single "exercise-points-max" MsgCsvColumnExamUserExercisePointsMax
+ , single "exercise-num-passes-max" MsgCsvColumnExamUserExercisePassesMax
+ , single "bonus" MsgCsvColumnExamUserBonus
+ , single "part-*" MsgCsvColumnExamUserParts
+ , single "exam-result" MsgCsvColumnExamUserResult
+ , single "course-note" MsgCsvColumnExamUserCourseNote
]
+ where
+ single :: RenderMessage UniWorX msg => Csv.Name -> msg -> Map Csv.Name Widget
+ single k v = singletonMap k [whamlet|_{v}|]
+
+examUserTableCsvHeader :: ( MonoFoldable mono
+ , Element mono ~ ExamPartNumber
+ )
+ => SheetGradeSummary -> Bool -> mono -> Csv.Header
+examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
+ [ "surname", "first-name", "name"
+ , "matriculation"
+ , "field", "degree", "semester"
+ , "course-note"
+ , "occurrence"
+ ] ++ bool mempty ["exercise-points", "exercise-points-max"] (doBonus && showPoints)
+ ++ bool mempty ["exercise-num-passes", "exercise-num-passes-max"] (doBonus && showPasses)
+ ++ bool mempty ["bonus"] doBonus
+ ++ map (review csvExamPartHeader) (sort $ otoList pNames) ++
+ [ "exam-result"
+ ]
+ where
+ showPasses = numSheetsPasses allBoni /= 0
+ showPoints = getSum (numSheetsPoints allBoni) /= 0
data ExamUserAction = ExamUserDeregister
| ExamUserAssignOccurrence
+ | ExamUserAcceptComputedResult
+ | ExamUserResetToComputedResult
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ExamUserAction
@@ -169,13 +309,21 @@ embedRenderMessage ''UniWorX ''ExamUserAction id
data ExamUserActionData = ExamUserDeregisterData
| ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
+ | ExamUserAcceptComputedResultData
+ | ExamUserResetToComputedResultData
+ { examUserResetBonus :: Bool
+ }
data ExamUserCsvActionClass
= ExamUserCsvCourseRegister
| ExamUserCsvRegister
| ExamUserCsvAssignOccurrence
| ExamUserCsvSetCourseField
+ | ExamUserCsvSetPartResult
+ | ExamUserCsvSetBonus
+ | ExamUserCsvOverrideBonus
| ExamUserCsvSetResult
+ | ExamUserCsvOverrideResult
| ExamUserCsvSetCourseNote
| ExamUserCsvDeregister
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@@ -202,8 +350,19 @@ data ExamUserCsvAction
| ExamUserCsvDeregisterData
{ examUserCsvActRegistration :: ExamRegistrationId
}
- | ExamUserCsvSetResultData
+ | ExamUserCsvSetPartResultData
{ examUserCsvActUser :: UserId
+ , examUserCsvActExamPart :: ExamPartNumber
+ , examUserCsvActExamPartResult :: Maybe ExamResultPoints
+ }
+ | ExamUserCsvSetBonusData
+ { examUserCsvIsBonusOverride :: Bool
+ , examUserCsvActUser :: UserId
+ , examUserCsvActExamBonus :: Maybe Points
+ }
+ | ExamUserCsvSetResultData
+ { examUserCsvIsResultOverride :: Bool
+ , examUserCsvActUser :: UserId
, examUserCsvActExamResult :: Maybe ExamResultPassedGrade
}
| ExamUserCsvSetCourseNoteData
@@ -230,73 +389,148 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEUsersR = postEUsersR
postEUsersR tid ssh csh examn = do
- (registrationResult, examUsersTable) <- runDB $ do
- exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
+ (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal, bonus) <- runDB $ do
+ exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn
+ examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName]
bonus <- examBonus exam
let
+ allBoni :: SheetGradeSummary
allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
- showPasses = numSheetsPasses allBoni /= 0
- showPoints = getSum (numSheetsPoints allBoni) /= 0
+
+ doBonus = is _Just examBonusRule
+ showPasses = doBonus && numSheetsPasses allBoni /= 0
+ showPoints = doBonus && getSum (numSheetsPoints allBoni) /= 0
resultView :: ExamResultGrade -> ExamResultPassedGrade
resultView = fmap $ bool (Left . view passingGrade) Right examShowGrades
+ examPartNumbers = examParts ^.. folded . _entityVal . _examPartNumber
+
+ resultAutomaticExamBonus' :: Fold ExamUserTableData Points
+ resultAutomaticExamBonus' = resultAutomaticExamBonus examVal bonus
+ resultAutomaticExamResult' :: Fold ExamUserTableData ExamResultGrade
+ resultAutomaticExamResult' = resultAutomaticExamResult examVal bonus
+
+ automaticCell :: forall msg m a b r.
+ ( RenderMessage UniWorX msg
+ , IsDBTable m a
+ , Eq msg
+ , Monoid b
+ , a ~ (Any, b)
+ )
+ => Getting (Endo [Either msg msg]) r (Either msg msg)
+ -> r
+ -> DBCell m a
+ automaticCell l r = case toListOf l r of
+ [] -> mempty
+ (Left auto : _)
+ -> i18nCell auto & cellAttrs <>~ [("class", "table__td--automatic")] & tellCell (Any True, mempty)
+ (Right man : others)
+ | all ((== man) . either id id) others
+ -> i18nCell man
+ | otherwise
+ -> i18nCell man & cellAttrs <>~ [("class", "table__td--overriden")] & tellCell (Any True, mempty)
+
+ csvName <- getMessageRender <*> pure (MsgExamUserCsvName tid ssh csh examn)
+
let
examUsersDBTable = DBTable{..}
where
- dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = do
- E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
- E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse)
- E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
- E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
- E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
- E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
- E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
- E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
- E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
- E.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
- E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
- return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote)
+ dbtSQLQuery = runReaderT $ do
+ examRegistration <- asks queryExamRegistration
+ user <- asks queryUser
+ occurrence <- asks queryExamOccurrence
+ courseParticipant <- asks queryCourseParticipant
+ studyFeatures <- asks queryStudyFeatures
+ studyDegree <- asks queryStudyDegree
+ studyField <- asks queryStudyField
+ examBonus' <- asks queryExamBonus
+ examResult <- asks queryExamResult
+ courseUserNote <- asks queryCourseNote
+
+ lift $ do
+ E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
+ E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse)
+ E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
+ E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
+ E.on $ examBonus' E.?. ExamBonusUser E.==. E.just (user E.^. UserId)
+ E.&&. examBonus' E.?. ExamBonusExam E.==. E.just (E.val eid)
+ E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
+ E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
+ E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
+ E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
+ E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
+ E.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
+
+ E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
+
+ return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examBonus', examResult, courseUserNote)
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
- dbtProj = return
+ dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
+ (,,,,,,,,,)
+ <$> view _1 <*> view _2 <*> view _3 <*> view _4 <*> view _5 <*> view _6 <*> view _7 <*> view _8
+ <*> getExamParts
+ <*> view _9
+ where
+ getExamParts :: ReaderT _ (MaybeT (YesodDB UniWorX)) (Map ExamPartId (ExamPart, Maybe (Entity ExamPartResult)))
+ getExamParts = do
+ uid <- view $ _2 . _entityKey
+ rawResults <- lift . 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
+ return (examPart, examPartResult)
+ return $ Map.fromList
+ [ (epId, (examPart, mbRes))
+ | (Entity epId examPart, mbRes) <- rawResults
+ ]
+
dbtColonnade = mconcat $ catMaybes
- [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey)
+ [ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
, pure colUserMatriclenr
, pure $ colField resultStudyField
, pure $ colDegreeShort resultStudyDegree
, pure $ colFeaturesSemester resultStudyFeatures
, pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
- , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
- SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus
- SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus
- return $ propCell (getSum achievedPasses) (getSum numSheetsPasses)
- , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
- SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
- SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
- return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
- , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult)
- , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade))
+ , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
+ let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus
+ SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus
+ in propCell (getSum achievedPasses) (getSum numSheetsPasses)
+ , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) ->
+ let SheetGradeSummary{achievedPoints} = examBonusAchieved uid bonus
+ SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus
+ in propCell (getSum achievedPoints) (getSum sumSheetsPoints)
+ , guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left
+ , pure $ mconcat
+ [ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
+ | Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
+ ]
+ , pure $ sortable (Just $ bool "result-bool" "result" examShowGrades) (i18nCell MsgExamResult) . automaticCell $ (resultExamResult . _entityVal . _examResultResult . to Right <> resultAutomaticExamResult' . to Left) . to (bimap resultView resultView)
, pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote))
-> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote
]
- dbtSorting = Map.fromList
- [ sortUserNameLink queryUser
- , sortUserMatriclenr queryUser
- , sortField queryStudyField
- , sortDegreeShort queryStudyDegree
- , sortFeaturesSemester queryStudyFeatures
- , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
- , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult))
- , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50])
- , ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
+ dbtSorting = mconcat
+ [ uncurry singletonMap $ sortUserNameLink queryUser
+ , uncurry singletonMap $ sortUserMatriclenr queryUser
+ , uncurry singletonMap $ sortField queryStudyField
+ , uncurry singletonMap $ sortDegreeShort queryStudyDegree
+ , uncurry singletonMap $ sortFeaturesSemester queryStudyFeatures
+ , mconcat
+ [ singletonMap (fromText [st|part-#{toPathPiece examPartNumber}|]) . SortColumn . queryExamPart epId $ \_ examPartResult -> return $ examPartResult E.?. ExamPartResultResult
+ | Entity epId ExamPart{..} <- examParts
+ ]
+ , singletonMap "occurrence" . SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)
+ , singletonMap "bonus" . SortColumn $ queryExamBonus >>> (E.?. ExamBonusBonus)
+ , singletonMap "result" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult)
+ , singletonMap "result-bool" . SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50]
+ , singletonMap "note" . SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
E.sub_select . E.from $ \edit -> do
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
return . E.max_ $ edit E.^. CourseUserNoteEditTime
- )
]
dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser
@@ -339,40 +573,55 @@ postEUsersR tid ssh csh examn = do
, dbParamsFormAdditional = \csrf -> do
let
actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
- actionMap = Map.fromList
- [ ( ExamUserDeregister
- , pure ExamUserDeregisterData
- )
- , ( ExamUserAssignOccurrence
- , ExamUserAssignOccurrenceData
+ actionMap = mconcat
+ [ singletonMap ExamUserDeregister $
+ pure ExamUserDeregisterData
+ , singletonMap ExamUserAssignOccurrence $
+ ExamUserAssignOccurrenceData
<$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
- )
+ , bool mempty computeActionMap $ is _Just examGradingRule
+ ]
+ computeActionMap = mconcat
+ [ singletonMap ExamUserAcceptComputedResult $
+ pure ExamUserAcceptComputedResultData
+ , singletonMap ExamUserResetToComputedResult $
+ ExamUserResetToComputedResultData
+ <$> bool (pure True) (apopt checkBoxField (fslI MsgExamUserResetBonus) (Just True)) (is _Just examBonusRule)
]
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
let formRes = (, mempty) . First . Just <$> res
return (formRes, formWgt)
- , dbParamsFormEvaluate = liftHandlerT . runFormPost
- , dbParamsFormResult = id
+ , dbParamsFormEvaluate = liftHandler . runFormPost
+ , dbParamsFormResult = _2
, dbParamsFormIdent = def
}
dbtIdent :: Text
dbtIdent = "exam-users"
- dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
- dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
- <$> view (resultUser . _entityVal . _userSurname . to Just)
- <*> view (resultUser . _entityVal . _userFirstName . to Just)
- <*> view (resultUser . _entityVal . _userDisplayName . to Just)
- <*> view (resultUser . _entityVal . _userMatrikelnummer)
- <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
- <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
- <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
- <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
- <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
- <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
- <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
- <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
- <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView)
- <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
+ dbtCsvEncode = Just DBTCsvEncode
+ { dbtCsvExportForm = pure ()
+ , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
+ , dbtCsvName = unpack csvName
+ , dbtCsvNoExportData = Just id
+ , dbtCsvHeader = const . return . examUserTableCsvHeader allBoni doBonus $ examParts ^.. folded . _entityVal . _examPartNumber
+ }
+ where
+ doEncode' = ExamUserTableCsv
+ <$> view (resultUser . _entityVal . _userSurname . to Just)
+ <*> view (resultUser . _entityVal . _userFirstName . to Just)
+ <*> view (resultUser . _entityVal . _userDisplayName . to Just)
+ <*> view (resultUser . _entityVal . _userMatrikelnummer)
+ <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
+ <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
+ <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+ <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
+ <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped) (bool (const Nothing) Just showPoints)
+ <*> previews (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
+ <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _sumSheetsPoints . _Wrapped) (bool (const Nothing) Just showPoints)
+ <*> previews (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _numSheetsPasses . _Wrapped . integral) (bool (const Nothing) Just showPasses)
+ <*> previews (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus') (bool (const Nothing) Just doBonus)
+ <*> (Map.fromList . map (over _1 examPartNumber . over (_2 . _Just) (examPartResultResult . entityVal)) <$> asks (toListOf resultExamParts))
+ <*> previews (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') resultView
+ <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
dbtCsvDecode = Just DBTCsvDecode
{ dbtCsvRowKey = \csv -> do
uid <- lift $ view _2 <$> guessUser csv
@@ -381,20 +630,28 @@ postEUsersR tid ssh csh examn = do
DBCsvDiffMissing{dbCsvOldKey}
-> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
DBCsvDiffNew{dbCsvNewKey = Just _}
- -> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
+ -> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
(isPart, uid) <- lift $ guessUser dbCsvNew
if
| isPart -> do
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
- Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse
+ Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
when (newFeatures /= oldFeatures) $
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
| otherwise ->
yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
+
+ iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
+ when (epNumber `elem` examPartNumbers) $
+ yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes)
+
+ when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $
+ yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew
+
when (is _Just $ csvEUserExamResult dbCsvNew) $
- yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew
+ yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
note <- lift . getBy $ UniqueCourseUserNote uid examCourse
when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $
@@ -406,11 +663,56 @@ postEUsersR tid ssh csh examn = do
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
- Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
+ Entity cpId _ <- lift . getJustBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
- when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $
- yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew
+ let uid = dbCsvOld ^. resultUser . _entityKey
+
+ forM_ examPartNumbers $ \epNumber ->
+ let oldPartResult = dbCsvOld ^? resultExamParts . filtered (views (_1 . _examPartNumber) (== epNumber)) . _2 . _Just . _entityVal . _examPartResultResult
+ in whenIsJust (csvEUserExamPartResults dbCsvNew !? epNumber) $ \epRes ->
+ when (epRes /= oldPartResult) $
+ yield $ ExamUserCsvSetPartResultData uid epNumber epRes
+
+ let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
+ newResults = sequence (csvEUserExamPartResults dbCsvNew)
+ <|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
+
+ newBonus, oldBonus :: Maybe Points
+ newBonus = join (csvEUserBonus dbCsvNew)
+ oldBonus = dbCsvOld ^? (resultExamBonus . _entityVal . _examBonusBonus <> resultAutomaticExamBonus')
+
+ newResult, oldResult :: Maybe ExamResultPassedGrade
+ newResult = fmap resultView <$> examGrade examVal (newBonus <|> oldBonus) =<< newResults
+ oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult') . to resultView
+
+ when doBonus $
+ case newBonus of
+ _ | newBonus == oldBonus
+ -> return ()
+ _ | is _Nothing newBonus
+ -> return ()
+ _ | Just ExamBonusManual{} <- examBonusRule
+ -> yield $ ExamUserCsvSetBonusData False uid newBonus
+ Nothing
+ -> yield $ ExamUserCsvSetBonusData False uid newBonus
+ Just _
+ -> yield $ ExamUserCsvSetBonusData True uid newBonus
+
+ case newResult of
+ _ | csvEUserExamResult dbCsvNew == oldResult
+ -> return ()
+ _ | is _Nothing $ csvEUserExamResult dbCsvNew
+ -> return ()
+ Nothing
+ -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
+ Just _
+ | csvEUserExamResult dbCsvNew /= newResult
+ -> yield . ExamUserCsvSetResultData True uid $ csvEUserExamResult dbCsvNew
+ | oldResult /= newResult
+ -> yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
+ | otherwise
+ -> return ()
when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $
yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew
@@ -420,7 +722,13 @@ postEUsersR tid ssh csh examn = do
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
- ExamUserCsvSetResultData{} -> ExamUserCsvSetResult
+ ExamUserCsvSetPartResultData{} -> ExamUserCsvSetPartResult
+ ExamUserCsvSetBonusData{..}
+ | examUserCsvIsBonusOverride -> ExamUserCsvOverrideBonus
+ | otherwise -> ExamUserCsvSetBonus
+ ExamUserCsvSetResultData{..}
+ | examUserCsvIsResultOverride -> ExamUserCsvOverrideResult
+ | otherwise -> ExamUserCsvSetResult
ExamUserCsvSetCourseNoteData{} -> ExamUserCsvSetCourseNote
, dbtCsvCoarsenActionClass = \case
ExamUserCsvCourseRegister -> DBCsvActionNew
@@ -436,8 +744,9 @@ postEUsersR tid ssh csh examn = do
, courseParticipantUser = examUserCsvActUser
, courseParticipantRegistration = now
, courseParticipantField = examUserCsvActCourseField
- , courseParticipantAllocated = False
+ , courseParticipantAllocated = Nothing
}
+ queueDBJob . JobQueueNotification $ NotificationCourseRegistered examUserCsvActUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
insert_ ExamRegistration
{ examRegistrationExam = eid
@@ -461,6 +770,34 @@ postEUsersR tid ssh csh examn = do
update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
CourseParticipant{..} <- getJust examUserCsvActCourseParticipant
audit $ TransactionCourseParticipantEdit examCourse courseParticipantUser
+ ExamUserCsvSetPartResultData{..} -> do
+ epid <- getKeyJustBy $ UniqueExamPartNumber eid examUserCsvActExamPart
+ case examUserCsvActExamPartResult of
+ Nothing -> do
+ deleteBy $ UniqueExamPartResult epid examUserCsvActUser
+ audit $ TransactionExamPartResultDeleted epid examUserCsvActUser
+ Just res -> do
+ now <- liftIO getCurrentTime
+ void $ upsertBy
+ (UniqueExamPartResult epid examUserCsvActUser)
+ (ExamPartResult epid examUserCsvActUser res now)
+ [ ExamPartResultResult =. res
+ , ExamPartResultLastChanged =. now
+ ]
+ audit $ TransactionExamPartResultEdit epid examUserCsvActUser
+ ExamUserCsvSetBonusData{..} -> case examUserCsvActExamBonus of
+ Nothing -> do
+ deleteBy $ UniqueExamBonus eid examUserCsvActUser
+ audit $ TransactionExamBonusDeleted eid examUserCsvActUser
+ Just res -> do
+ now <- liftIO getCurrentTime
+ void $ upsertBy
+ (UniqueExamBonus eid examUserCsvActUser)
+ (ExamBonus eid examUserCsvActUser res now)
+ [ ExamBonusBonus =. res
+ , ExamBonusLastChanged =. now
+ ]
+ audit $ TransactionExamBonusEdit eid examUserCsvActUser
ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
Nothing -> do
deleteBy $ UniqueExamResult eid examUserCsvActUser
@@ -490,13 +827,13 @@ postEUsersR tid ssh csh examn = do
delete nid
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do
now <- liftIO getCurrentTime
- uid <- liftHandlerT requireAuthId
+ uid <- liftHandler requireAuthId
Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ]
insert_ $ CourseUserNoteEdit uid now nid
return $ CExamR tid ssh csh examn EUsersR
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
ExamUserCsvCourseRegisterData{..} -> do
- (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
+ (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
@@ -510,7 +847,7 @@ postEUsersR tid ssh csh examn = do
\ (_{MsgExamNoOccurrence})
|]
ExamUserCsvRegisterData{..} -> do
- (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
+ (User{..}, occ) <- liftHandler . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
@@ -520,7 +857,7 @@ postEUsersR tid ssh csh examn = do
\ (_{MsgExamNoOccurrence})
|]
ExamUserCsvAssignOccurrenceData{..} -> do
- occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
+ occ <- for examUserCsvActOccurrence $ liftHandler . runDB . getJust
[whamlet|
$newline never
^{registeredUserName' examUserCsvActRegistration}
@@ -530,7 +867,7 @@ postEUsersR tid ssh csh examn = do
\ (_{MsgExamNoOccurrence})
|]
ExamUserCsvSetCourseFieldData{..} -> do
- User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
+ User{..} <- liftHandler . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
@@ -539,8 +876,34 @@ postEUsersR tid ssh csh examn = do
$nothing
, _{MsgCourseStudyFeatureNone}
|]
+ ExamUserCsvSetPartResultData{..} -> do
+ (User{..}, Entity _ ExamPart{..}) <- liftHandler . runDB $
+ (,) <$> getJust examUserCsvActUser
+ <*> getJustBy (UniqueExamPartNumber eid examUserCsvActExamPart)
+ [whamlet|
+ $newline never
+ ^{nameWidget userDisplayName userSurname}
+ $maybe pName <- examPartName
+ , „#{pName}“
+ $nothing
+ , _{MsgExamPartNumbered examPartNumber}
+ $maybe newResult <- examUserCsvActExamPartResult
+ , _{newResult}
+ $nothing
+ , _{MsgExamResultNone}
+ |]
+ ExamUserCsvSetBonusData{..} -> do
+ User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
+ [whamlet|
+ $newline never
+ ^{nameWidget userDisplayName userSurname}
+ $maybe newBonus <- examUserCsvActExamBonus
+ , _{newBonus}
+ $nothing
+ , _{MsgExamBonusNone}
+ |]
ExamUserCsvSetResultData{..} -> do
- User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
+ User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
@@ -550,7 +913,7 @@ postEUsersR tid ssh csh examn = do
, _{MsgExamResultNone}
|]
ExamUserCsvSetCourseNoteData{..} -> do
- User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
+ User{..} <- liftHandler . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
@@ -571,22 +934,31 @@ postEUsersR tid ssh csh examn = do
guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
users <- E.select . E.from $ \user -> do
- E.where_ . E.and $ catMaybes
+ E.where_ . E.or $ catMaybes
[ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
- , (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName
- , (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname
- , (user E.^. UserFirstName E.==.) . E.val <$> csvEUserFirstName
+ , (user E.^. UserDisplayName `E.hasInfix`) . E.val <$> csvEUserName
+ , (user E.^. UserSurname `E.hasInfix`) . E.val <$> csvEUserSurname
+ , (user E.^. UserFirstName `E.hasInfix`) . E.val <$> csvEUserFirstName
]
let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
- E.limit 2
- return (isCourseParticipant, user E.^. UserId)
- case users of
- (filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)])
- -> return (isPart, uid)
- [(E.Value isPart, E.Value uid)]
- -> return (isPart, uid)
+ return (isCourseParticipant, user)
+ let users' = reverse $ sortBy closeness users
+ closeness :: (E.Value Bool, Entity User) -> (E.Value Bool, Entity User) -> Ordering
+ closeness = mconcat $ catMaybes
+ [ pure $ comparing (preview $ _2 . _entityVal . _userMatrikelnummer . only csvEUserMatriculation)
+ , pure $ comparing (view _1)
+ , csvEUserSurname <&> \surn -> comparing (preview $ _2 . _entityVal . _userSurname . to CI.mk . only (CI.mk surn))
+ , csvEUserFirstName <&> \firstn -> comparing (preview $ _2 . _entityVal . _userFirstName . to CI.mk . only (CI.mk firstn))
+ , csvEUserName <&> \dispn -> comparing (preview $ _2 . _entityVal . _userDisplayName . to CI.mk . only (CI.mk dispn))
+ ]
+ case users' of
+ [(E.Value isPart, Entity uid _)]
+ -> return (isPart, uid)
+ (x@(E.Value isPart, Entity uid _) : x' : _)
+ | GT <- x `closeness` x'
+ -> return (isPart, uid)
_other
-> throwM ExamUserCsvExceptionNoMatchingUser
@@ -650,21 +1022,21 @@ postEUsersR tid ssh csh examn = do
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
& defaultPagesize PagesizeAll
- postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId)
+ postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId (Bool, ExamUserTableData) ExamUserTableData) -> FormResult (ExamUserActionData, Map ExamRegistrationId ExamUserTableData)
postprocess inp = do
(First (Just act), regMap) <- inp
- let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
- return (act, regSet)
- over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
+ let regMap' = Map.mapMaybe (uncurry guardOn) $ getDBFormResult (False,) regMap
+ return (act, regMap')
+ (, exam, bonus) . over (_1 . _2) postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
formResult registrationResult $ \case
- (ExamUserDeregisterData, selectedRegistrations) -> do
+ (ExamUserDeregisterData, Map.keysSet -> selectedRegistrations) -> do
nrDel <- runDB $ deleteWhereCount
[ ExamRegistrationId <-. Set.toList selectedRegistrations
]
addMessageI Success $ MsgExamUsersDeregistered nrDel
redirect $ CExamR tid ssh csh examn EUsersR
- (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do
+ (ExamUserAssignOccurrenceData occId, Map.keysSet -> selectedRegistrations) -> do
nrUpdated <- runDB $ updateWhereCount
[ ExamRegistrationId <-. Set.toList selectedRegistrations
]
@@ -672,7 +1044,67 @@ postEUsersR tid ssh csh examn = do
]
addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
redirect $ CExamR tid ssh csh examn EUsersR
+ (ExamUserAcceptComputedResultData, Map.elems -> rows) -> do
+ nrAccepted <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do
+ now <- liftIO getCurrentTime
+ uid <- view $ resultUser . _entityKey
+ hasResult <- asks $ has resultExamResult
+ hasBonus <- asks $ has resultExamBonus
+ autoResult <- preview $ resultAutomaticExamResult examVal bonus
+ autoBonus <- preview $ resultAutomaticExamBonus examVal bonus
+ lift $ if
+ | not hasResult
+ , Just examResultResult <- autoResult
+ -> do
+ if
+ | Just examBonusBonus <- autoBonus
+ , not hasBonus
+ -> do
+ insert_ ExamBonus
+ { examBonusExam = eId
+ , examBonusUser = uid
+ , examBonusLastChanged = now
+ , ..
+ }
+ audit $ TransactionExamBonusEdit eId uid
+ | otherwise
+ -> return ()
+
+ insert_ ExamResult
+ { examResultExam = eId
+ , examResultUser = uid
+ , examResultLastChanged = now
+ , ..
+ }
+ audit $ TransactionExamResultEdit eId uid
+ return $ Sum 1
+ | otherwise
+ -> return mempty
+ addMessageI Success $ MsgExamUsersResultsAccepted nrAccepted
+ redirect $ CExamR tid ssh csh examn EUsersR
+ (ExamUserResetToComputedResultData{..}, Map.elems -> rows) -> do
+ nrReset <- fmap (getSum . fold) . runDB . forM rows . runReaderT $ do
+ uid <- view $ resultUser . _entityKey
+ lift $ do
+ when examUserResetBonus $ do
+ bonusId' <- getKeyBy $ UniqueExamBonus eId uid
+ whenIsJust bonusId' $ \bonusId -> do
+ delete bonusId
+ audit $ TransactionExamBonusDeleted eId uid
+
+ result <- getKeyBy $ UniqueExamResult eId uid
+ case result of
+ Just resId -> do
+ delete resId
+ audit $ TransactionExamResultDeleted eId uid
+ return $ Sum 1
+ Nothing -> return mempty
+ addMessageI Success $ MsgExamUsersResultsReset nrReset
+ redirect $ CExamR tid ssh csh examn EUsersR
+
+ closeWgt <- examCloseWidget (SomeRoute $ CExamR tid ssh csh examn EUsersR) eId
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
+ let computedValuesTip = $(i18nWidgetFile "exam-users/computed-values-tip")
$(widgetFile "exam-users")
diff --git a/src/Handler/ExamOffice.hs b/src/Handler/ExamOffice.hs
new file mode 100644
index 000000000..5ad3a8bda
--- /dev/null
+++ b/src/Handler/ExamOffice.hs
@@ -0,0 +1,8 @@
+module Handler.ExamOffice
+ ( module Handler.ExamOffice
+ ) where
+
+import Handler.ExamOffice.Exams as Handler.ExamOffice
+import Handler.ExamOffice.Fields as Handler.ExamOffice
+import Handler.ExamOffice.Users as Handler.ExamOffice
+import Handler.ExamOffice.Exam as Handler.ExamOffice
diff --git a/src/Handler/ExamOffice/Course.hs b/src/Handler/ExamOffice/Course.hs
new file mode 100644
index 000000000..2db5ecf76
--- /dev/null
+++ b/src/Handler/ExamOffice/Course.hs
@@ -0,0 +1,75 @@
+module Handler.ExamOffice.Course
+ ( getCExamOfficeR, postCExamOfficeR
+ ) where
+
+import Import
+
+import qualified Data.Set as Set
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import Handler.Utils.ExamOffice.Course
+import Handler.Utils
+
+
+examOfficeOptOutForm :: UserId -> CourseId -> Maybe (Set SchoolId) -> Form (Set SchoolId)
+-- ^ Deals with sets of _opt outs_
+examOfficeOptOutForm uid cid (fromMaybe Set.empty -> template) = renderWForm FormStandard $ do
+ schools <- liftHandler . runDB . E.select $ courseExamOfficeSchools (E.val uid) (E.val cid)
+
+ res <- fmap sequence . forM schools $ \(Entity ssh School{..}, E.Value isForced)
+ -> fmap (ssh, ) <$> bool wpopt wforcedJust isForced checkBoxField (fslI schoolName) (Just $ ssh `Set.notMember` template)
+
+ return $ res <&> setOf (folded . filtered (not . view _2) . _1)
+
+getCExamOfficeR, postCExamOfficeR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCExamOfficeR = postCExamOfficeR
+postCExamOfficeR tid ssh csh = do
+ uid <- requireAuthId
+ isModal <- hasCustomHeader HeaderIsModal
+
+ (cid, optOuts, hasForced) <- runDB $ do
+ cid <- getKeyBy404 (TermSchoolCourseShort tid ssh csh)
+ optOuts <- selectList [ CourseUserExamOfficeOptOutCourse ==. cid, CourseUserExamOfficeOptOutUser ==. uid ] []
+ hasForced <- E.selectExists $ do
+ (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid)
+ E.where_ isForced
+ return (cid, optOuts, hasForced)
+
+ ((optOutRes, optOutView), optOutEnc)
+ <- runFormPost $ examOfficeOptOutForm uid cid (Just $ setOf (folded . _entityVal . _courseUserExamOfficeOptOutSchool) optOuts )
+
+ formResultModal optOutRes (CourseR tid ssh csh CExamOfficeR) $ \optOuts' -> do
+ lift . runDB $ do
+ deleteWhere [ CourseUserExamOfficeOptOutCourse ==. cid
+ , CourseUserExamOfficeOptOutUser ==. uid
+ , CourseUserExamOfficeOptOutSchool /<-. Set.toList optOuts'
+ ]
+ forM_ optOuts' $ \ssh' ->
+ void $ insertUnique CourseUserExamOfficeOptOut
+ { courseUserExamOfficeOptOutCourse = cid
+ , courseUserExamOfficeOptOutUser = uid
+ , courseUserExamOfficeOptOutSchool = ssh'
+ }
+ tell . pure =<< messageI Success MsgExamOfficeOptOutsChanged
+
+
+ let optOutView' = wrapForm optOutView def
+ { formAction = Just . SomeRoute $ CourseR tid ssh csh CExamOfficeR
+ , formEncoding = optOutEnc
+ , formAttrs = [ asyncSubmitAttr | isModal ]
+ }
+
+ siteLayoutMsg MsgMenuCourseExamOffice $ do
+ setTitleI MsgMenuCourseExamOffice
+
+ let explanation = $(i18nWidgetFile "course-exam-office-explanation")
+
+ [whamlet|
+ $newline never
+
+ _{MsgExamOfficeSubscribedFieldsExplanation}
+ ^{fieldsView'}
+ |]
+
diff --git a/src/Handler/ExamOffice/Users.hs b/src/Handler/ExamOffice/Users.hs
new file mode 100644
index 000000000..0a5d3b9bd
--- /dev/null
+++ b/src/Handler/ExamOffice/Users.hs
@@ -0,0 +1,188 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.ExamOffice.Users
+ ( getEOUsersR, postEOUsersR
+ , getEOUsersInviteR, postEOUsersInviteR
+ ) where
+
+import Import
+import Utils.Form
+import Handler.Utils
+import Handler.Utils.Invitations
+
+import Text.Hamlet (ihamlet)
+import Data.Aeson hiding (Result(..))
+import Jobs.Queue
+
+import qualified Database.Esqueleto as E
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Data.Map ((!), (!?))
+
+
+instance IsInvitableJunction ExamOfficeUser where
+ type InvitationFor ExamOfficeUser = User
+ data InvitableJunction ExamOfficeUser = JunctionExamOfficeUser
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ data InvitationDBData ExamOfficeUser = InvDBDataExamOfficeUser
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ data InvitationTokenData ExamOfficeUser = InvTokenDataExamOfficeUser
+ { invTokenExamOfficeUserOffice :: CryptoUUIDUser
+ }
+ deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+ _InvitableJunction = iso
+ (\ExamOfficeUser{..} -> (examOfficeUserUser, examOfficeUserOffice, JunctionExamOfficeUser))
+ (\(examOfficeUserUser, examOfficeUserOffice, JunctionExamOfficeUser) -> ExamOfficeUser{..})
+
+instance ToJSON (InvitableJunction ExamOfficeUser) where
+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+ toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+instance FromJSON (InvitableJunction ExamOfficeUser) where
+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+
+instance ToJSON (InvitationDBData ExamOfficeUser) where
+ toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+ toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationDBData ExamOfficeUser) where
+ parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+
+instance ToJSON (InvitationTokenData ExamOfficeUser) where
+ toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
+ toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
+instance FromJSON (InvitationTokenData ExamOfficeUser) where
+ parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 5 }
+
+examOfficeUserInvitationConfig :: InvitationConfig ExamOfficeUser
+examOfficeUserInvitationConfig = InvitationConfig{..}
+ where
+ invitationRoute _ _ = return $ ExamOfficeR EOUsersInviteR
+ invitationResolveFor InvTokenDataExamOfficeUser{..} = do
+ officeId <- decrypt invTokenExamOfficeUserOffice
+ bool notFound (return officeId) =<< existsKey officeId
+ invitationSubject (Entity _ User{..}) _ = do
+ return . SomeMessage $ MsgMailSubjectExamOfficeUserInvitation userDisplayName
+ invitationHeading (Entity _ User{..}) _ = do
+ return . SomeMessage $ MsgExamOfficeUserInviteHeading userDisplayName
+ invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgExamOfficeUserInviteExplanation}|]
+ invitationTokenConfig _ _ = do
+ itAuthority <- liftHandler requireAuthId
+ let itExpiresAt = Nothing
+ itStartsAt = Nothing
+ itAddAuth = Nothing
+ return InvitationTokenConfig{..}
+ invitationRestriction _ _ = return Authorized
+ invitationForm _ _ _ = pure (JunctionExamOfficeUser, ())
+ invitationInsertHook _ _ ExamOfficeUser{..} _ act = do
+ res <- act
+ audit $ TransactionExamOfficeUserAdd examOfficeUserOffice examOfficeUserUser
+ return res
+ invitationSuccessMsg _ _ =
+ return $ SomeMessage MsgExamOfficeUserInvitationAccepted
+ invitationUltDest _ _ = return $ SomeRoute HomeR
+
+
+makeExamOfficeUsersForm :: Maybe (Set (Either UserEmail UserId)) -> Form (Set (Either UserEmail UserId))
+makeExamOfficeUsersForm template = renderWForm FormStandard $ do
+ cRoute <- fromMaybe (error "makeExamOfficeUsersForm called from 404-handler") <$> getCurrentRoute
+
+ let
+ miAdd' :: (Text -> Text)
+ -> FieldView UniWorX
+ -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
+ miAdd' nudge btn csrf = do
+ MsgRenderer mr <- getMsgRenderer
+ (addRes, addView) <- mpreq (multiUserField False Nothing) ("" & addName (nudge "users") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
+ let
+ res' :: FormResult ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
+ res' = addRes <&> \newUsers oldUsers -> if
+ | null newUsers
+ -> pure oldUsers
+ | otherwise
+ -> pure . nub $ oldUsers ++ Set.toList newUsers
+ return (res', $(widgetFile "widgets/massinput/examOfficeUsers/add"))
+ miCell' :: Either UserEmail UserId -> Widget
+ miCell' (Left email) = do
+ invWarnMsg <- messageI Warning MsgEmailInvitationWarning
+ $(widgetFile "widgets/massinput/examOfficeUsers/cellInvitation")
+ miCell' (Right uid) = do
+ User{..} <- liftHandler . runDB $ getJust uid
+ $(widgetFile "widgets/massinput/examOfficeUsers/cellKnown")
+ miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+ miButtonAction' frag = Just . SomeRoute $ cRoute :#: frag
+ miLayout' :: MassInputLayout ListLength _ ()
+ miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examOfficeUsers/layout")
+ miIdent' :: Text
+ miIdent' = "exam-office-users"
+ fSettings :: FieldSettings UniWorX
+ fSettings = fslI MsgExamOfficeSubscribedUsers
+ & setTooltip MsgExamOfficeSubscribedUsersTip
+ fRequired :: Bool
+ fRequired = False
+
+ template' <- for template $ \uids -> liftHandler . runDB $ do
+ let (invitations, knownUsers) = partitionEithers $ Set.toList uids
+ knownUsers' <- fmap (map E.unValue) . E.select . E.from $ \user -> do
+ E.where_ $ user E.^. UserId `E.in_` E.valList knownUsers
+ E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
+ return $ user E.^. UserId
+ return $ map Left invitations ++ map Right knownUsers'
+
+ fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired template'
+
+
+-- | Manage the list of users this user (in her function as exam-office)
+-- has an interest in, i.e. that authorize her to view their grades
+getEOUsersR, postEOUsersR :: Handler Html
+getEOUsersR = postEOUsersR
+postEOUsersR = do
+ uid <- requireAuthId
+
+ oldUsers <- liftHandler . runDB $ do
+ users <- E.select . E.from $ \(user `E.InnerJoin` examOfficeUser) -> do
+ E.on $ user E.^. UserId E.==. examOfficeUser E.^. ExamOfficeUserUser
+ E.&&. examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val uid
+ return $ user E.^. UserId
+ invites <- Map.keysSet <$> sourceInvitationsF @ExamOfficeUser uid
+ return $ setOf (folded . _Value . re _Right) users <> Set.mapMonotonic Left invites
+
+ ((usersRes, usersView), usersEnc) <- runFormPost . makeExamOfficeUsersForm $ Just oldUsers
+
+ formResult usersRes $ \(setSymmDiff oldUsers -> changes) -> do
+ liftHandler . runDBJobs . forM_ changes $ \change -> if
+ | change `Set.member` oldUsers -> case change of
+ Right change' -> do
+ deleteBy $ UniqueExamOfficeUser uid change'
+ audit $ TransactionExamOfficeUserDelete uid change'
+ Left change' ->
+ deleteInvitation @ExamOfficeUser uid change'
+ | otherwise -> case change of
+ Right change' -> do
+ insert_ $ ExamOfficeUser uid change'
+ audit $ TransactionExamOfficeUserAdd uid change'
+ Left change' -> do
+ cID <- encrypt uid
+ sinkInvitation examOfficeUserInvitationConfig (change', uid, (InvDBDataExamOfficeUser, InvTokenDataExamOfficeUser cID))
+ addMessageI Success $ MsgTransactionExamOfficeUsersUpdated (Set.size $ changes `Set.intersection` oldUsers) (Set.size $ changes `Set.difference` oldUsers)
+ redirect $ ExamOfficeR EOExamsR
+
+ let
+ usersView' = wrapForm usersView def
+ { formAction = Just . SomeRoute $ ExamOfficeR EOUsersR
+ , formEncoding = usersEnc
+ }
+
+ siteLayoutMsg MsgMenuExamOfficeUsers $ do
+ setTitleI MsgMenuExamOfficeUsers
+
+ [whamlet|
+ $newline never
+
+ _{MsgExamOfficeSubscribedUsersExplanation}
+ ^{usersView'}
+ |]
+
+getEOUsersInviteR, postEOUsersInviteR :: Handler Html
+getEOUsersInviteR = postEOUsersInviteR
+postEOUsersInviteR = invitationR examOfficeUserInvitationConfig
diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs
index dad7ef747..7cb8aa83b 100644
--- a/src/Handler/Health.hs
+++ b/src/Handler/Health.hs
@@ -27,7 +27,7 @@ getHealthR = do
waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore)
case waitResult of
Left False -> sendResponseStatus noContent204 ()
- Left True -> fail "System is not generating HealthReports"
+ Left True -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text)
Right _ -> redirect HealthR
Just healthReports -> do
let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index 30beb116a..0382fab4a 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -3,8 +3,6 @@ module Handler.Home where
import Import
import Handler.Utils
-import Handler.Utils.Table.Cells
-
import qualified Data.Map as Map
import Database.Esqueleto.Utils.TH
@@ -60,7 +58,7 @@ homeUpcomingSheets uid = do
, E.Value UTCTime
, E.Value (Maybe SubmissionId)
))
- (DBCell (HandlerT UniWorX IO) ())
+ (DBCell Handler ())
colonnade = mconcat
[ -- dbRow
-- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
@@ -84,7 +82,7 @@ homeUpcomingSheets uid = do
(hasTickmark True)
]
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
- sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable
+ sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable
{ dbtSQLQuery = tableData
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
, dbtColonnade = colonnade
@@ -129,7 +127,7 @@ homeUpcomingSheets uid = do
homeUpcomingExams :: UserId -> Widget
homeUpcomingExams uid = do
now <- liftIO getCurrentTime
- ((Any hasExams, examTable), warningDays) <- liftHandlerT . runDB $ do
+ ((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do
User {userWarningDays} <- get404 uid
let fortnight = addUTCTime userWarningDays now
let -- code copied and slightly adapted from Handler.Course.getCShowR:
@@ -204,7 +202,7 @@ homeUpcomingExams uid = do
isRegistered <- existsBy $ UniqueExamRegistration eId uid
if
| mayRegister -> do
- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
+ (examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
return $ wrapForm examRegisterForm def
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
, formEncoding = examRegisterEnctype
diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs
index 260f03357..aa98bdac1 100644
--- a/src/Handler/Info.hs
+++ b/src/Handler/Info.hs
@@ -47,4 +47,23 @@ getInfoLecturerR =
siteLayoutMsg' MsgInfoLecturerTitle $ do
setTitleI MsgInfoLecturerTitle
$(i18nWidgetFile "info-lecturer")
-
+ where
+ tooltipNew, tooltipProblem, tooltipPlanned, tooltipNewU2W :: WidgetFor UniWorX ()
+ tooltipNew = [whamlet| _{MsgLecturerInfoTooltipNew} |]
+ tooltipProblem = [whamlet| _{MsgLecturerInfoTooltipProblem} |]
+ tooltipPlanned = [whamlet| _{MsgLecturerInfoTooltipPlanned} |]
+ tooltipNewU2W = [whamlet| _{MsgLecturerInfoTooltipNewU2W} |]
+ newU2WFeat, probFeatInline, plannedFeat, plannedFeatInline :: WidgetFor UniWorX ()
+ newU2WFeat = [whamlet| ^{iconTooltip tooltipNew (Just IconAnnounce) True} |] -- to be used inside text blocks
+ probFeatInline = [whamlet| ^{iconTooltip tooltipProblem (Just IconProblem) True} |] -- to be used inside text blocks
+ plannedFeat = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) False} |]
+ plannedFeatInline = [whamlet| ^{iconTooltip tooltipPlanned (Just IconPlanned) True} |] -- to be used inside text blocks
+
+ -- new feature with given introduction date
+ newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX ()
+ newFeat year month day = do
+ currentTime <- liftIO getCurrentTime
+ let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian year month day) 0
+ if currentTime > expiryTime
+ then mempty
+ else toWidget [whamlet| ^{iconTooltip tooltipNewU2W (Just IconNew) False} |]
diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs
index 791475e71..740ed670d 100644
--- a/src/Handler/Material.hs
+++ b/src/Handler/Material.hs
@@ -17,8 +17,6 @@ import Database.Esqueleto.Utils.TH
import Utils.Form
import Handler.Utils
import Handler.Utils.Delete
-import Handler.Utils.Table.Cells
-import Handler.Utils.Table.Columns
import Control.Monad.Writer (MonadWriter(..), execWriterT)
@@ -30,7 +28,7 @@ data MaterialForm = MaterialForm
, mfType :: Maybe (CI Text)
, mfDescription :: Maybe Html
, mfVisibleFrom :: Maybe UTCTime
- , mfFiles :: Maybe (Source Handler (Either FileId File))
+ , mfFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
}
makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
@@ -42,7 +40,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
| Just source <- template >>= mfFiles
= runConduit $ source .| C.foldMap setIds
| otherwise = return Set.empty
- typeOptions :: HandlerT UniWorX IO (OptionList (CI Text))
+ typeOptions :: HandlerFor UniWorX (OptionList (CI Text))
typeOptions = do
let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
previouslyUsed <- runDB $
@@ -63,7 +61,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
flip (renderAForm FormStandard) html $ MaterialForm
<$> areq (textField & cfStrip & cfCI) (fslI MsgMaterialName) (mfName <$> template)
- <*> aopt (textField & cfStrip & cfCI & addDatalist typeOptions)
+ <*> aopt (textField & cfStrip & guardField (not . null) & cfCI & addDatalist typeOptions)
(fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
(mfType <$> template)
<*> aopt htmlField (fslpI MsgMaterialDescription "Html")
@@ -79,8 +77,8 @@ getMaterialKeyBy404 tid ssh csh mnm = do
getKeyBy404 $ UniqueMaterial cid mnm
fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
-fetchMaterial tid ssh csh mnm = do
- [matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints
+fetchMaterial tid ssh csh mnm =
+ maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints
\(course `E.InnerJoin` material) -> do
E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
@@ -88,7 +86,6 @@ fetchMaterial tid ssh csh mnm = do
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. material E.^. MaterialName E.==. E.val mnm
return material
- return matEnt
getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -247,7 +244,7 @@ postMEditR tid ssh csh mnm = do
E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
return $ file E.^. FileId
- return (matEnt, (Left . E.unValue) <$> fileIds)
+ return (matEnt, Left . E.unValue <$> fileIds)
-- let cid = materialCourse
let template = Just MaterialForm
{ mfName = materialName
@@ -310,14 +307,14 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
when saveOk $ redirect -- redirect must happen outside of runDB
$ CourseR tid ssh csh (MaterialR mfName MShowR)
- insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB ()
+ insertMaterialFile' :: MaterialId -> ConduitT () (Either FileId File) Handler () -> DB ()
insertMaterialFile' mid fs = do
oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do
E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
return $ file E.^. FileId
let oldFileIds = setFromList $ map E.unValue oldFileIdVals
- keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
+ keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId)
where
finsert (Left fileId) = tell $ singleton fileId
diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs
index b4a38f4f3..9487e9b55 100644
--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@@ -1,9 +1,17 @@
-module Handler.Profile where
+module Handler.Profile
+ ( getProfileR, postProfileR
+ , getProfileDataR, makeProfileData
+ , getAuthPredsR, postAuthPredsR
+ , getUserNotificationR, postUserNotificationR
+ , getSetDisplayEmailR, postSetDisplayEmailR
+ , getCsvOptionsR, postCsvOptionsR
+ ) where
import Import
import Handler.Utils
-import Handler.Utils.Table.Cells
+import Handler.Utils.Profile
+import Handler.Utils.Tokens
-- import Colonnade hiding (fromMaybe, singleton)
-- import Yesod.Colonnade
@@ -17,25 +25,33 @@ import qualified Database.Esqueleto.Utils as E
import qualified Data.CaseInsensitive as CI
+import Jobs
+
data SettingsForm = SettingsForm
- { stgMaxFavourties :: Int
- , stgTheme :: Theme
- , stgDateTime :: DateTimeFormat
- , stgDate :: DateTimeFormat
- , stgTime :: DateTimeFormat
- , stgDownloadFiles :: Bool
- , stgWarningDays :: NominalDiffTime
- , stgSchools :: Set SchoolId
+ { stgDisplayName :: UserDisplayName
+ , stgDisplayEmail :: UserEmail
+ , stgMaxFavourites :: Int
+ , stgMaxFavouriteTerms :: Int
+ , stgTheme :: Theme
+ , stgDateTime :: DateTimeFormat
+ , stgDate :: DateTimeFormat
+ , stgTime :: DateTimeFormat
+ , stgDownloadFiles :: Bool
+ , stgWarningDays :: NominalDiffTime
+ , stgSchools :: Set SchoolId
, stgNotificationSettings :: NotificationSettings
}
+makeLenses_ ''SettingsForm
data NotificationTriggerKind
= NTKAll
| NTKCourseParticipant
| NTKExamParticipant
| NTKCorrector
+ | NTKCourseLecturer
| NTKAllocationStaff
+ | NTKAllocationParticipant
| NTKFunctionary SchoolFunction
deriving (Eq, Ord, Generic, Typeable)
deriveFinite ''NotificationTriggerKind
@@ -46,7 +62,9 @@ instance RenderMessage UniWorX NotificationTriggerKind where
NTKCourseParticipant -> mr MsgNotificationTriggerKindCourseParticipant
NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant
NTKCorrector -> mr MsgNotificationTriggerKindCorrector
+ NTKCourseLecturer -> mr MsgNotificationTriggerKindCourseLecturer
NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff
+ NTKAllocationParticipant -> mr MsgNotificationTriggerKindAllocationParticipant
NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin
NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer
NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice
@@ -58,9 +76,14 @@ instance RenderMessage UniWorX NotificationTriggerKind where
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template html = do
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
- <$ aformSection MsgFormCosmetics
- <*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
- (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
+ <$ aformSection MsgFormPersonalAppearance
+ <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template)
+ <*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template)
+ <* aformSection MsgFormCosmetics
+ <*> areq (natFieldI $ MsgNatField "Favoriten")
+ (fslpI MsgFavourites "Anzahl Favoriten" & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template)
+ <*> areq (natFieldI $ MsgNatField "Favoriten-Semester")
+ (fslpI MsgFavouriteSemesters "Anzahl Semester") (stgMaxFavouriteTerms <$> template)
<*> areq (selectField . return $ mkOptionList themeList)
(fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template)
<*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
@@ -85,7 +108,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
where
schoolsForm' :: WForm Handler (FormResult (Set SchoolId))
schoolsForm' = do
- allSchools <- liftHandlerT . runDB $ selectList [] [Asc SchoolName]
+ allSchools <- liftHandler . runDB $ selectList [] [Asc SchoolName]
let
schoolForm (Entity ssh School{schoolName})
@@ -107,7 +130,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
notificationForm template = wFormToAForm $ do
- mbUid <- liftHandlerT maybeAuthId
+ mbUid <- liftHandler maybeAuthId
isAdmin <- hasReadAccessTo AdminR
let
@@ -132,10 +155,14 @@ notificationForm template = wFormToAForm $ do
, NTKExamParticipant <- nt
= fmap not . E.selectExists . E.from $ \examRegistration ->
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
+ | Just uid <- mbUid
+ , NTKCourseLecturer <- nt
+ = fmap not . E.selectExists . E.from $ \lecturer ->
+ E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
| otherwise
= return False
- ntHidden <- liftHandlerT . runDB
+ ntHidden <- liftHandler . runDB
$ Set.fromList universeF
& Map.fromSet sectionIsHidden
& sequenceA
@@ -151,28 +178,43 @@ notificationForm template = wFormToAForm $ do
= apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template)
ntSection = \case
- NTSubmissionRatedGraded -> Just NTKCourseParticipant
- NTSubmissionRated -> Just NTKCourseParticipant
- NTSheetActive -> Just NTKCourseParticipant
- NTSheetSoonInactive -> Just NTKCourseParticipant
- NTSheetInactive -> Just $ NTKFunctionary SchoolLecturer
- NTCorrectionsAssigned -> Just NTKCorrector
- NTCorrectionsNotDistributed -> Just $ NTKFunctionary SchoolLecturer
- NTUserRightsUpdate -> Just NTKAll
- NTUserAuthModeUpdate -> Just NTKAll
- NTExamResult -> Just NTKExamParticipant
- NTAllocationStaffRegister -> Just $ NTKFunctionary SchoolLecturer
- NTAllocationAllocation -> Just NTKAllocationStaff
- NTAllocationRegister -> Just NTKAll
- NTAllocationOutdatedRatings -> Just NTKAllocationStaff
- NTAllocationUnratedApplications -> Just NTKAllocationStaff
- -- _other -> Nothing
+ NTSubmissionRatedGraded -> Just NTKCourseParticipant
+ NTSubmissionRated -> Just NTKCourseParticipant
+ NTSheetActive -> Just NTKCourseParticipant
+ NTSheetSoonInactive -> Just NTKCourseParticipant
+ NTSheetInactive -> Just NTKCourseLecturer
+ NTCorrectionsAssigned -> Just NTKCorrector
+ NTCorrectionsNotDistributed -> Just NTKCourseLecturer
+ NTUserRightsUpdate -> Just NTKAll
+ NTUserAuthModeUpdate -> Just NTKAll
+ NTExamRegistrationActive -> Just NTKCourseParticipant
+ NTExamRegistrationSoonInactive -> Just NTKCourseParticipant
+ NTExamDeregistrationSoonInactive -> Just NTKCourseParticipant
+ NTExamResult -> Just NTKExamParticipant
+ NTAllocationStaffRegister -> Just $ NTKFunctionary SchoolLecturer
+ NTAllocationAllocation -> Just NTKAllocationStaff
+ NTAllocationRegister -> Just NTKAll
+ NTAllocationOutdatedRatings -> Just NTKAllocationStaff
+ NTAllocationUnratedApplications -> Just NTKAllocationStaff
+ NTAllocationResults -> Just NTKAllocationParticipant
+ NTExamOfficeExamResults -> Just $ NTKFunctionary SchoolExamOffice
+ NTExamOfficeExamResultsChanged -> Just $ NTKFunctionary SchoolExamOffice
+ NTCourseRegistered -> Just NTKAll
+ -- _other -> Nothing
forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate]
aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False
+validateSettings :: User -> FormValidator SettingsForm Handler ()
+validateSettings User{..} = do
+ userDisplayName' <- use _stgDisplayName
+
+ guardValidation MsgUserDisplayNameInvalid $
+ validDisplayName userTitle userFirstName userSurname userDisplayName'
+
+
data ButtonResetTokens = BtnResetTokens
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonResetTokens
@@ -195,7 +237,7 @@ nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
getProfileR, postProfileR :: Handler Html
getProfileR = postProfileR
postProfileR = do
- (uid, User{..}) <- requireAuthPair
+ (uid, user@User{..}) <- requireAuthPair
userSchools <- fmap (setOf $ folded . _Value) . runDB . E.select . E.from $ \school -> do
E.where_ . E.exists . E.from $ \userSchool ->
E.where_ $ E.not_ (userSchool E.^. UserSchoolIsOptOut)
@@ -203,36 +245,38 @@ postProfileR = do
E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
return $ school E.^. SchoolId
let settingsTemplate = Just SettingsForm
- { stgMaxFavourties = userMaxFavourites
- , stgTheme = userTheme
- , stgDateTime = userDateTimeFormat
- , stgDate = userDateFormat
- , stgTime = userTimeFormat
- , stgDownloadFiles = userDownloadFiles
- , stgSchools = userSchools
+ { stgDisplayName = userDisplayName
+ , stgDisplayEmail = userDisplayEmail
+ , stgMaxFavourites = userMaxFavourites
+ , stgMaxFavouriteTerms = userMaxFavouriteTerms
+ , stgTheme = userTheme
+ , stgDateTime = userDateTimeFormat
+ , stgDate = userDateFormat
+ , stgTime = userTimeFormat
+ , stgDownloadFiles = userDownloadFiles
+ , stgSchools = userSchools
, stgNotificationSettings = userNotificationSettings
- , stgWarningDays = userWarningDays
+ , stgWarningDays = userWarningDays
}
- ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
+ ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
formResult res $ \SettingsForm{..} -> do
- runDB $ do
- update uid [ UserMaxFavourites =. stgMaxFavourties
- , UserTheme =. stgTheme
- , UserDateTimeFormat =. stgDateTime
- , UserDateFormat =. stgDate
- , UserTimeFormat =. stgTime
- , UserDownloadFiles =. stgDownloadFiles
- , UserWarningDays =. stgWarningDays
- , UserNotificationSettings =. stgNotificationSettings
- ]
- when (stgMaxFavourties < userMaxFavourites) $ do
- -- prune Favourites to user-defined size
- oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
- [ Desc CourseFavouriteTime
- , OffsetBy stgMaxFavourties
- ]
- mapM_ delete oldFavs
+ runDBJobs $ do
+ update uid $
+ [ UserDisplayName =. stgDisplayName
+ , UserMaxFavourites =. stgMaxFavourites
+ , UserMaxFavouriteTerms =. stgMaxFavouriteTerms
+ , UserTheme =. stgTheme
+ , UserDateTimeFormat =. stgDateTime
+ , UserDateFormat =. stgDate
+ , UserTimeFormat =. stgTime
+ , UserDownloadFiles =. stgDownloadFiles
+ , UserWarningDays =. stgWarningDays
+ , UserNotificationSettings =. stgNotificationSettings
+ ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ]
+ when (stgDisplayEmail /= userDisplayEmail) $ do
+ queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
+ addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail
let
symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools)
forM_ symDiff $ \ssh -> if
@@ -252,7 +296,7 @@ postProfileR = do
}
[ UserSchoolIsOptOut =. True
]
- addMessageI Info MsgSettingsUpdate
+ addMessageI Success MsgSettingsUpdate
redirect $ ProfileR :#: ProfileSettings
((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm
@@ -286,6 +330,7 @@ postProfileR = do
, formAnchor = Just ProfileResetTokens
}
tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation")
+ displayNameRules = $(i18nWidgetFile "profile/displayNameRules")
$(widgetFile "profile/profile")
@@ -726,3 +771,65 @@ postUserNotificationR cID = do
siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do
setTitleI $ MsgNotificationSettingsHeading userDisplayName
formWidget
+
+
+data ButtonSetDisplayEmail = BtnSetDisplayEmail
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe ButtonSetDisplayEmail
+instance Finite ButtonSetDisplayEmail
+
+nullaryPathPiece ''ButtonSetDisplayEmail $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonSetDisplayEmail id
+
+instance Button UniWorX ButtonSetDisplayEmail where
+ btnClasses _ = [BCIsButton]
+
+
+getSetDisplayEmailR, postSetDisplayEmailR :: Handler Html
+getSetDisplayEmailR = postSetDisplayEmailR
+postSetDisplayEmailR = do
+ uid <- requireAuthId
+ mDisplayEmail <- requireCurrentTokenRestrictions
+
+ case mDisplayEmail of
+ Nothing -> invalidArgs ["Bearer token required"]
+ Just displayEmail -> do
+ ((btnRes, btnView), btnEnc) <- runFormPost $ formEmbedJwtPost buttonForm
+ let btnView' = wrapForm btnView def
+ { formSubmit = FormNoSubmit
+ , formAction = Just $ SomeRoute SetDisplayEmailR
+ , formEncoding = btnEnc
+ }
+
+ formResult btnRes $ \case
+ BtnSetDisplayEmail -> do
+ runDB $
+ update uid [UserDisplayEmail =. displayEmail]
+ addMessageI Success MsgUserDisplayEmailChanged
+ redirect ProfileR
+
+ siteLayoutMsg MsgTitleChangeUserDisplayEmail $ do
+ setTitleI MsgTitleChangeUserDisplayEmail
+ $(i18nWidgetFile "set-display-email")
+
+getCsvOptionsR, postCsvOptionsR :: Handler Html
+getCsvOptionsR = postCsvOptionsR
+postCsvOptionsR = do
+ Entity uid User{userCsvOptions} <- requireAuth
+
+ ((optionsRes, optionsWgt'), optionsEnctype) <- runFormPost . renderAForm FormStandard $
+ csvOptionsForm (fslI MsgCsvOptions & setTooltip MsgCsvOptionsTip) (Just userCsvOptions)
+
+ formResultModal optionsRes CsvOptionsR $ \opts -> do
+ lift . runDB $ update uid [ UserCsvOptions =. opts ]
+ tell . pure =<< messageI Success MsgCsvOptionsUpdated
+
+ siteLayoutMsg MsgCsvOptions $ do
+ setTitleI MsgCsvOptions
+
+ isModal <- hasCustomHeader HeaderIsModal
+ wrapForm optionsWgt' def
+ { formAction = Just $ SomeRoute CsvOptionsR
+ , formEncoding = optionsEnctype
+ , formAttrs = [ asyncSubmitAttr | isModal ]
+ }
diff --git a/src/Handler/School.hs b/src/Handler/School.hs
index f97130264..fa0ef7fe1 100644
--- a/src/Handler/School.hs
+++ b/src/Handler/School.hs
@@ -2,7 +2,6 @@ module Handler.School where
import Import
import Handler.Utils
-import Handler.Utils.Table.Columns
import qualified Database.Esqueleto as E
@@ -71,7 +70,7 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
<*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template)
<*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
where
- ldapOrgs :: HandlerT UniWorX IO (OptionList (CI Text))
+ ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 331922434..543865af2 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -2,7 +2,7 @@
module Handler.Sheet where
-import Import
+import Import hiding (link)
import Jobs.Queue
@@ -10,8 +10,6 @@ import Jobs.Queue
import Utils.Sheet
import Handler.Utils
-- import Handler.Utils.Zip
-import Handler.Utils.Table.Cells
--- import Handler.Utils.Table.Columns
import Handler.Utils.SheetType
import Handler.Utils.Delete
import Handler.Utils.Invitations
@@ -71,10 +69,7 @@ data SheetForm = SheetForm
, sfActiveTo :: UTCTime
, sfHintFrom :: Maybe UTCTime
, sfSolutionFrom :: Maybe UTCTime
- , sfSheetF :: Maybe (Source Handler (Either FileId File))
- , sfHintF :: Maybe (Source Handler (Either FileId File))
- , sfSolutionF :: Maybe (Source Handler (Either FileId File))
- , sfMarkingF :: Maybe (Source Handler (Either FileId File))
+ , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ())
, sfType :: SheetType
, sfGrouping :: SheetGroup
, sfSubmissionMode :: SubmissionMode
@@ -95,7 +90,7 @@ makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
oldFileIds <- (return.) <$> case msId of
Nothing -> return $ partitionFileType mempty
- (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
+ (Just sId) -> liftHandler $ runDB $ getFtIdMap sId
mr <- getMsgRenderer
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
@@ -427,11 +422,12 @@ getSShowR tid ssh csh shn = do
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
let zipLink = CSheetR tid ssh csh shn SArchiveR
visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet
- sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
- sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
- hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
- solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
- markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
+ sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
+ sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
+ hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
+ solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
+ markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
+ submissionTip <- messageI Info MsgSheetCorrectorSubmissionsTip
$(widgetFile "sheetShow")
getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
@@ -639,20 +635,20 @@ postSDelR tid ssh csh shn = do
insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
insertSheetFile sid ftype finfo = do
- runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert
+ 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 -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
+insertSheetFile' :: SheetId -> SheetFileType -> ConduitT () (Either FileId File) Handler () -> YesodDB UniWorX ()
insertSheetFile' sid ftype fs = do
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
return (file E.^. FileId)
- keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
+ keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
where
finsert (Left fileId) = tell $ singleton fileId
@@ -691,13 +687,13 @@ defaultLoads shid = do
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
where
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
- toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load)
+ toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (cState, cLoad)
correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector))
correctorForm shid = wFormToAForm $ do
- Just currentRoute <- liftHandlerT getCurrentRoute
- userId <- liftHandlerT requireAuthId
+ currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
+ userId <- liftHandler requireAuthId
MsgRenderer mr <- getMsgRenderer
let
@@ -705,9 +701,9 @@ correctorForm shid = wFormToAForm $ do
currentLoads = Map.union
<$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
<*> fmap (fmap ((,) <$> invDBSheetCorrectorState <*> invDBSheetCorrectorLoad) . Map.mapKeysMonotonic Left) (sourceInvitationsF shid)
- (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads
+ (defaultLoads', currentLoads') <- liftHandler . runDB $ (,) <$> defaultLoads shid <*> currentLoads
- isWrite <- liftHandlerT $ isWriteRequest currentRoute
+ isWrite <- liftHandler $ isWriteRequest currentRoute
let
applyDefaultLoads = Map.null currentLoads' && not isWrite
@@ -768,8 +764,9 @@ correctorForm shid = wFormToAForm $ do
identWidget <- case userIdent of
Left email -> return . toWidget $ mailtoHtml email
Right uid -> do
- User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid
+ User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid
return $ nameEmailWidget userEmail userDisplayName userSurname
+ invWarnMsg <- messageI Warning MsgEmailInvitationWarning
return (res, $(widgetFile "sheetCorrectors/cell"))
@@ -814,7 +811,7 @@ correctorForm shid = wFormToAForm $ do
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector
postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
- postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector))
+ postProcess' (Left email, (cState, load)) = Left (email, shid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector))
filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!
@@ -896,18 +893,22 @@ correctorInvitationConfig = InvitationConfig{..}
Course{..} <- get404 sheetCourse
return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
invitationResolveFor _ = do
- Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute
- fetchSheetId tid csh ssh shn
+ cRoute <- getCurrentRoute
+ case cRoute of
+ Just (CSheetR tid csh ssh shn SCorrInviteR) ->
+ fetchSheetId tid csh ssh shn
+ _other ->
+ error "correctorInvitationConfig called from unsupported route"
invitationSubject (Entity _ Sheet{..}) _ = do
Course{..} <- get404 sheetCourse
return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
invitationTokenConfig _ _ = do
- itAuthority <- liftHandlerT requireAuthId
+ itAuthority <- liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
- invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ())
+ invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
invitationInsertHook _ _ _ _ = id
invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
invitationUltDest (Entity _ Sheet{..}) _ = do
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index fe52740d4..a925753dd 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -11,7 +11,6 @@ import Jobs
import Handler.Utils
import Handler.Utils.Delete
import Handler.Utils.Submission
-import Handler.Utils.Table.Cells
import Handler.Utils.Invitations
-- import Control.Monad.Trans.Maybe
@@ -90,9 +89,13 @@ submissionUserInvitationConfig = InvitationConfig{..}
cID <- encrypt subId
return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR
invitationResolveFor _ = do
- Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute
- subId <- decrypt cID
- bool notFound (return subId) =<< existsKey subId
+ cRoute <- getCurrentRoute
+ case cRoute of
+ Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) -> do
+ subId <- decrypt cID
+ bool notFound (return subId) =<< existsKey subId
+ _other ->
+ error "submissionUserInvitationConfig called from unsupported route"
invitationSubject (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet
Course{..} <- getJust sheetCourse
@@ -104,7 +107,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
invitationTokenConfig (Entity _ Submission{..}) _ = do
Sheet{..} <- getJust submissionSheet
Course{..} <- getJust sheetCourse
- itAuthority <- liftHandlerT requireAuthId
+ itAuthority <- liftHandler requireAuthId
itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
let itExpiresAt = Nothing
itStartsAt = Nothing
@@ -122,15 +125,17 @@ submissionUserInvitationConfig = InvitationConfig{..}
return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
-makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId))
+makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (ConduitT () File Handler ()), Set (Either UserEmail UserId))
makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
<$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode
<*> wFormToAForm submittorsForm
where
miCell' :: Markup -> Either UserEmail UserId -> Widget
- miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
+ miCell' csrf (Left email) = do
+ invWarnMsg <- messageI Warning MsgEmailInvitationWarning
+ $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
miCell' csrf (Right uid) = do
- User{..} <- liftHandlerT . runDB $ getJust uid
+ User{..} <- liftHandler . runDB $ getJust uid
$(widgetFile "widgets/massinput/submissionUsers/cellKnown")
miLayout :: ListLength
@@ -192,7 +197,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
| null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty]
| otherwise -> FormSuccess $ Set.fromList submittors'
| otherwise = do
- uid <- liftHandlerT requireAuthId
+ uid <- liftHandler requireAuthId
mRoute <- getCurrentRoute
let
@@ -276,7 +281,7 @@ submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe
submissionHelper tid ssh csh shn mcid = do
uid <- requireAuthId
msmid <- traverse decrypt mcid
- Just actionUrl <- getCurrentRoute
+ actionUrl <- fromMaybe (error "submissionHelper called from 404-handler") <$> getCurrentRoute
(Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner) <- runDB $ do
csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
@@ -437,7 +442,9 @@ submissionHelper tid ssh csh shn mcid = do
-- Determine old submission users
subUsersOld <- if
- | isJust msmid -> setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] []
+ | isJust msmid -> Set.union
+ <$> (setOf (folded . _entityVal . _submissionUserUser . to Right) <$> selectList [SubmissionUserSubmission ==. smid] [])
+ <*> (sourceInvitationsF smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email))
| otherwise -> return Set.empty -- optimization (do not perform selection if submission was freshly created)
-- Since invitations carry no data we only need to consider changes to
@@ -477,7 +484,7 @@ submissionHelper tid ssh csh shn mcid = do
Nothing -> return ()
-- Maybe construct a table to display uploaded archive files
- let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ())
+ let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerFor UniWorX) ())
colonnadeFiles cid = mconcat
[ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr)
diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs
index b2c7ef90f..c6a3c2214 100644
--- a/src/Handler/SystemMessage.hs
+++ b/src/Handler/SystemMessage.hs
@@ -9,7 +9,6 @@ import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NonEmpty
import Handler.Utils
-import Handler.Utils.Table.Cells
import qualified Database.Esqueleto as E
@@ -180,7 +179,7 @@ postMessageListR = do
{ dbrOutput = (smE, smT)
, ..
}
- psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
+ psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
(tableRes', tableView) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery
, dbtRowKey = (E.^. SystemMessageId)
@@ -217,7 +216,7 @@ postMessageListR = do
]
(actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
- , dbParamsFormEvaluate = liftHandlerT . runFormPost
+ , dbParamsFormEvaluate = liftHandler . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
@@ -226,8 +225,8 @@ postMessageListR = do
, dbtCsvDecode = Nothing
}
- let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
- & mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
+ let tableRes = tableRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
+ <&> _1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
case tableRes of
FormMissing -> return ()
diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs
index ba4be993c..26c349c83 100644
--- a/src/Handler/Term.hs
+++ b/src/Handler/Term.hs
@@ -2,7 +2,6 @@ module Handler.Term where
import Import
import Handler.Utils
-import Handler.Utils.Table.Cells
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
@@ -177,7 +176,7 @@ postTermEditExistR tid = do
termEditHandler :: TermFormTemplate -> Handler Html
termEditHandler term = do
- Just eHandler <- getCurrentRoute
+ eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
case result of
(FormSuccess res) -> do
diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs
index babe6563f..04fc02220 100644
--- a/src/Handler/Tutorial.hs
+++ b/src/Handler/Tutorial.hs
@@ -1,476 +1,13 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
module Handler.Tutorial
( module Handler.Tutorial
) where
-import Import
-import Handler.Utils
-import Handler.Utils.Tutorial
-import Handler.Utils.Table.Cells
-import Handler.Utils.Delete
-import Handler.Utils.Communication
-import Handler.Utils.Form.Occurrences
-import Handler.Utils.Invitations
-import Jobs.Queue
-
-import qualified Database.Esqueleto as E
-import Database.Esqueleto.Utils.TH
-
-import Data.Map ((!))
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-import qualified Data.CaseInsensitive as CI
-
-import Data.Aeson hiding (Result(..))
-import Text.Hamlet (ihamlet)
-
-import Handler.Tutorial.Users as Handler.Tutorial
-
-{-# ANN module ("Hlint: ignore Redundant void" :: String) #-}
-
-
-getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCTutorialListR tid ssh csh = do
- Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
-
- let
- tutorialDBTable = DBTable{..}
- where
- dbtSQLQuery tutorial = do
- E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
- let participants = E.sub_select . E.from $ \tutorialParticipant -> do
- E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
- return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
- return (tutorial, participants)
- dbtRowKey = (E.^. TutorialId)
- dbtProj = return . over (_dbrOutput . _2) E.unValue
- dbtColonnade = dbColonnade $ mconcat
- [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialType
- , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
- , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do
- tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
- E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
- E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
- return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
- return [whamlet|
- $newline never
-
- $forall tutor <- tutors
-
+ $forall tutor <- tutors
+