chore(exam): show exam occurrences in participants views for tutorial and course

messages/uniworx/categories/courses/courses/de-de-formal.msg

@@ -135,6 +135,7 @@ CourseUserTutorialsDeregistered count@Int64: Teilnehmer:in von #{show count} #{p
 CourseUserNoTutorialsDeregistered: Teilnehmer:in ist zu keinem der gewählten Kurse angemeldet
 CourseUserTutorials: Angemeldete Kurse
 CourseUserExams: Angemeldete Prüfungen
+CourseUserExamOccurrences: Termine/Räume
 CourseUserSheets: Übungsblätter
 CsvColumnUserName: Voller Name des/der Teilnehmers/Teilnehmerin
 CsvColumnUserMatriculation: AVS Nummer des/der Teilnehmers/Teilnehmerin

messages/uniworx/categories/courses/courses/en-eu.msg

@@ -135,6 +135,7 @@ CourseUserTutorialsDeregistered count: Sucessfully deregistered participant from
 CourseUserNoTutorialsDeregistered: Participant is not registered for any of the selected courses
 CourseUserTutorials: Registered courses
 CourseUserExams: Registered exams
+CourseUserExamOccurrences: Occurrences/rooms
 CourseUserSheets: Exercise sheets
 CsvColumnUserName: Participant's full name
 CsvColumnUserMatriculation: Participant's AVS number

src/Handler/Course/Users.hs

@@ -10,6 +10,7 @@ module Handler.Course.Users
   , postCUsersR, getCUsersR
   , colUserSex'
   , colUserQualifications, colUserQualificationBlocked
+  , colUserExamOccurrences
   , _userQualifications
   ) where
 
@@ -95,7 +96,7 @@ type UserTableData = DBRow ( Entity User
                            , Entity CourseParticipant
                            , Maybe CourseUserNoteId
                            , ([Entity Tutorial], Map (CI Text) (Maybe (Entity Tutorial)))
-                           , [Entity Exam]
+                           , ([Entity Exam], [Entity ExamOccurrence])
                            , Maybe (Entity SubmissionGroup)
                            , Map SheetName (SheetType SqlBackendKey, Maybe Points)
                            , UserTableQualifications
@@ -120,7 +121,10 @@ _userTutorials :: Lens' UserTableData ([Entity Tutorial], Map (CI Text) (Maybe (
 _userTutorials = _dbrOutput . _4
 
 _userExams :: Lens' UserTableData [Entity Exam]
-_userExams = _dbrOutput . _5
+_userExams = _dbrOutput . _5 . _1
+
+_userExamOccurrences :: Lens' UserTableData [Entity ExamOccurrence]
+_userExamOccurrences = _dbrOutput . _5 . _2
 
 _userSubmissionGroup :: Traversal' UserTableData (Entity SubmissionGroup)
 _userSubmissionGroup = _dbrOutput . _6 . _Just
@@ -165,6 +169,13 @@ colUserExams tid ssh csh = sortable (Just "exams") (i18nCell MsgCourseUserExams)
           (\(Entity _ Exam{..}) -> CExamR tid ssh csh examName EUsersR)
           (examName . entityVal)
 
+colUserExamOccurrences :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
+colUserExamOccurrences _tid _ssh _csh = sortable (Just "exams") (i18nCell MsgCourseUserExamOccurrences)
+  $ \(view _userExamOccurrences -> exams') ->
+    let exams = sortOn (examOccurrenceName . entityVal) exams'
+     in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) $ listCell exams
+          (\(Entity _ ExamOccurrence{..}) -> wgtCell [whamlet|#{examOccurrenceName}:^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}|])
+
 colUserSex' :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
 colUserSex' = colUserSex $ hasUser . _userSex
 
@@ -389,8 +400,9 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
     courseQualis <- getCourseQualifications cid
     let cqids = entityKey <$> courseQualis
     tutorials <- selectList [ TutorialCourse ==. cid ] []
-    exams <- selectList [ ExamCourse ==. cid ] []
+    exams  <- selectList [ ExamCourse ==. cid ] []
-    sheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
+    exOccs <- selectList [ ExamOccurrenceExam <-. fmap entityKey exams] [ Asc ExamOccurrenceId ] <&> Map.fromAscList . fmap (\ent -> (entityKey ent, ent))
+    sheets <- selectList [ SheetCourse ==. cid] [Desc SheetActiveTo, Desc SheetActiveFrom]
     personalisedSheets <- E.select . E.from $ \sheet -> do
       let hasPersonalised = E.exists . E.from $ \psFile ->
             E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
@@ -432,9 +444,11 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
             regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
             tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials
             tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts'
-            exs = filter (\(Entity eId _) -> any ((== eId) . examRegistrationExam . entityVal) exams') exams
+            exs = filter (\(Entity eId _) -> any ((==      eId) . examRegistrationExam       . entityVal) exams') exams
+            -- ocs = filter (\(Entity oId _) -> any ((== Just oId) . examRegistrationOccurrence . entityVal) exams') exOccs
+            ocs = catMaybes [ Map.lookup oId exOccs | Entity{entityVal=ExamRegistration{examRegistrationOccurrence = Just oId}} <- exams' ]
             subs = Map.fromList $ map (over (_2 . _2) (views _entityVal submissionRatingPoints <=< assertM (views _entityVal submissionRatingDone)) . over _1 E.unValue . over (_2 . _1) E.unValue) subs'
-          return (user, participant, userNoteId, tuts, exs, subGroup, subs, qualis)
+          return (user, participant, userNoteId, tuts, (exs,ocs), subGroup, subs, qualis)
         dbtColonnade = colChoices
         dbtSorting   = mconcat
           [ single $ sortUserNameLink    queryUser -- slower sorting through clicking name column header
@@ -666,6 +680,7 @@ postCUsersR tid ssh csh = do
           , guardOn hasSubmissionGroups $ cap' colUserSubmissionGroup
           , guardOn hasTutorials . cap' $ colUserTutorials tid ssh csh
           , guardOn hasExams . cap' $ colUserExams tid ssh csh
+          , guardOn hasExams . cap' $ colUserExamOccurrences tid ssh csh
           , pure . cap' $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (maybe mempty dateCell . preview (_Just . _userTableRegistration) . assertM' (has $ _userTableParticipant . _entityVal . _courseParticipantState . _CourseParticipantActive))
           , pure . cap' $ sortable (Just "state") (i18nCell MsgCourseUserState) (i18nCell . view (_userTableParticipant . _entityVal . _courseParticipantState))
           , guardOn (not $ null sheetList) . colUserSheets $ map (sheetName . entityVal) sheetList

src/Handler/Sheet/Form.hs

@@ -60,7 +60,7 @@ data SheetPersonalisedFilesForm = SheetPersonalisedFilesForm
   , spffAllowNonPersonalisedSubmission :: Bool
   }
 
-  
+
 getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference)
 getFtIdMap sId = do
   allSheetFiles <- E.select . E.from $ \sheetFile -> do
@@ -84,7 +84,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
       return ((school, mSchoolAuthorshipStatement), course)
     sheetPersonalisedFilesForm <- makeSheetPersonalisedFilesForm $ template >>= sfPersonalF
 
-    let mkSheetForm 
+    let mkSheetForm
           sfName
           sfDescription
           sfRequireExamRegistration
@@ -130,7 +130,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
                 if | isn't _SchoolAuthorshipStatementModeNone schoolSheetAuthorshipStatementMode -> do
                        wformSection MsgSheetAuthorshipStatementSection
 
-                       let 
+                       let
                          reqContentField :: AForm Handler I18nStoredMarkup
                          reqContentField = formResultUnOpt mr' MsgSheetAuthorshipStatementContent
                                `fmapAForm` i18nFieldA htmlField True (\_ -> Nothing) ("authorship-statement" :: Text)
@@ -143,7 +143,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
 
                        if | not schoolSheetAuthorshipStatementAllowOther
                             -> (pure SheetAuthorshipStatementModeEnabled, pure sfAuthorshipStatementExam', )
-                               <$> (fmap (traverse $ fmap authorshipStatementDefinitionContent) . traverse forcedContentField $ entityVal <$> mSchoolAuthorshipStatement)
+                               <$> fmap (traverse $ fmap authorshipStatementDefinitionContent) (traverse (forcedContentField . entityVal) mSchoolAuthorshipStatement)
                           | otherwise -> do
                               examOpts <-
                                 let examFieldQuery = E.from $ \exam -> do
@@ -205,7 +205,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
                   #{iconFileZip}
                   \ _{MsgSheetPersonalisedFilesDownload}
                 |]
-        listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl 
+        listRoute <- for mbSheet $ \(sheetName -> shn) -> toTextUrl
           ( CourseR courseTerm courseSchool courseShorthand CUsersR
           , [ ("courseUsers-has-personalised-sheet-files"
               , toPathPiece shn

src/Handler/Tutorial/Users.hs

@@ -75,6 +75,7 @@ postTUsersR tid ssh csh tutn = do
           , pure $ colUserMatriclenr isAdmin
           , pure $ colUserQualifications nowaday
           , pure $ colUserQualificationBlocked isAdmin nowaday
+          , pure $ colUserExamOccurrences tid ssh csh
           ]
         psValidator = def
           & defaultSortingByName
@@ -87,6 +88,17 @@ postTUsersR tid ssh csh tutn = do
         csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
 
         qualOptions = qualificationsOptionList qualifications
+    -- pick earliest still open associated exam
+    _mbExam <- selectFirst
+      (-- ([ExamRegisterTo >=. Just now] ||. [ExamRegisterTo ==. Nothing]) ++ -- Reconsider: only allow exams with open registration?
+       ([ExamEnd        >=. Just now] ||. [ExamEnd        ==. Nothing]) ++
+        [ ExamStart <=. Just now --  , ExamRegisterFrom <=. Just now
+        , ExamCourse ==. cid, ExamClosed ==. Nothing, ExamFinished ==. Nothing -- Reconsider: ExamFinished prevents publication of results - do we want this?
+      ]) [Asc ExamRegisterFrom, Asc ExamStart, Asc ExamRegisterTo, Asc ExamName] -- earliest still open exam
+    -- pick exam occurrences and tutors
+    -- TODO: !!!continue here!!!
+
+    -- multiActionAOpts or similar, see FirmAction for another example
     let
       acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
       acts = Map.fromList $

src/Handler/Utils/Form.hs

@@ -1886,27 +1886,46 @@ userField onlySuggested suggestions = Field{..}
               <option value=#{email}>
                 #{email} (#{dName})
         |]
-    fieldParse (filter (not . Text.null) -> t : _) _ = runExceptT . fmap Just $ do
+    fieldParse (filter (not . Text.null) . fmap T.strip -> t : _) _ = runExceptT . fmap Just $
-      email <- either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . CI.mk . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
+      case Email.validate (encodeUtf8 t) of
-      case lookupExpr of
+        Right (CI.mk . decodeUtf8 . Email.toByteString -> email) -> case lookupExpr of
-        Nothing -> return $ Left email
+          Nothing -> return $ Left email
-        Just lookupExpr' -> do
+          Just lookupExpr' -> do
-            dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDB . E.select $ do
+              dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDBRead . E.select $ do
+                user <- lookupExpr'
+                E.where_ $ user E.^. UserIdent `E.ciEq` E.val email
+                    E.||. (       user E.^. UserDisplayEmail `E.ciEq` E.val email
+                            E.&&. unique UserDisplayEmail user
+                          )
+                    E.||. (       user E.^. UserEmail `E.ciEq` E.val email
+                            E.&&. unique UserEmail user
+                          )
+                return $ user E.^. UserId
+              if  | Set.null dbRes
+                    -> return $ Left email
+                  | [uid] <- Set.toList dbRes
+                    -> return $ Right uid
+                  | otherwise
+                    -> throwE $ SomeMessage MsgAmbiguousEmail
+        Left notAnEmail
+          | Just lookupExpr' <- lookupExpr -> do           -- allow known user entry by avs-nr or corporate-id for convenience
+            dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
               user <- lookupExpr'
-              E.where_ $ user E.^. UserIdent `E.ciEq` E.val email
+              E.where_ $  ( E.justVal t E.==. user E.^. UserCompanyPersonalNumber
-                   E.||. (       user E.^. UserDisplayEmail `E.ciEq` E.val email
+                                    E.&&. uniqueTX user UserCompanyPersonalNumber
-                           E.&&. unique UserDisplayEmail user
+                          )
-                         )
+                    E.||. ( E.justVal t E.==. user E.^. UserMatrikelnummer
-                   E.||. (       user E.^. UserEmail `E.ciEq` E.val email
+                                    E.&&. uniqueTX user UserMatrikelnummer
-                           E.&&. unique UserEmail user
+                          )
-                         )
+              E.limit 3     -- we need a single answer only, so we optimize the query to stop at multiple answers
               return $ user E.^. UserId
-            if | Set.null dbRes
+            let errMsg m = SomeMessage $ SomeMessages [SomeMessage MsgAvsPersonNo, text2message "/", SomeMessage MsgCompanyPersonalNumber, text2message t, m]
-                 -> return $ Left email
+            case dbRes of
-               | [uid] <- Set.toList dbRes
+              [uid] -> return $ Right $ E.unValue uid
-                 -> return $ Right uid
+              _ | Text.any Char.isAlpha t -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
-               | otherwise
+              []    -> throwE $ errMsg $ SomeMessage $ bool MsgUnknown MsgUnknownOrNotAllowed onlySuggested
-                 -> throwE $ SomeMessage MsgAmbiguousEmail
+              _     -> throwE $ errMsg $ SomeMessage MsgAmbiguous
+          | otherwise -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
     fieldParse _ _ = return $ Right Nothing
 
     unique field user = case lookupExpr of
@@ -1919,6 +1938,14 @@ userField onlySuggested suggestions = Field{..}
                    )
       Nothing -> E.true
 
+    uniqueTX user field | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do
+      user' <- lookupExpr'
+      E.where_ $  user' E.^. UserId                     E.!=. user E.^. UserId
+          E.&&. ( user' E.^. UserMatrikelnummer         E.==. user E.^. field
+            E.||. user' E.^. UserCompanyPersonalNumber  E.==. user E.^. field
+          )
+    uniqueTX _ _ =  E.true
+
 
 knownUserField :: forall m.
              ( MonadHandler m
@@ -1976,23 +2003,24 @@ knownUserField onlySuggested suggestions = Field{..}
                 #{email} (#{dName})
         |]
     fieldParse (filter (not . Text.null) . fmap T.strip -> t : _) _
-      | Just lookupExpr' <- lookupExpr = case Email.validate (encodeUtf8 t) of
+      | Text.any Char.isAlpha t, Just lookupExpr' <- lookupExpr
+       = case Email.validate (encodeUtf8 t) of
+        Left notAnEmail -> return $ Left $ SomeMessage $ MsgInvalidEmail [st|#{t} (#{notAnEmail})|]
         Right (CI.mk . decodeUtf8 . Email.toByteString -> email) -> do
-          dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
+            dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
-            user <- lookupExpr'
+              user <- lookupExpr'
-            E.where_ $    E.val email `E.ciEq` user E.^. UserIdent          -- UserIdent is unique
+              E.where_ $    E.val email `E.ciEq` user E.^. UserIdent          -- UserIdent is unique
-                  E.||.   E.val email `E.ciEq` user E.^. UserEmail          -- UserEmail is unique
+                    E.||.   E.val email `E.ciEq` user E.^. UserEmail          -- UserEmail is unique
-                  E.||. ( E.val email `E.ciEq` user E.^. UserDisplayEmail
+                    E.||. ( E.val email `E.ciEq` user E.^. UserDisplayEmail
-                                  E.&&. uniqueCI user UserDisplayEmail   -- ensure uniqueness
+                                    E.&&. uniqueCI user UserDisplayEmail   -- ensure uniqueness
-                        )
+                          )
-            E.limit 3     -- we need a single answer only, so we optimize the query to stop at multiple answers
+              E.limit 3     -- we need a single answer only, so we optimize the query to stop at multiple answers
-            return $ user E.^. UserId
+              return $ user E.^. UserId
-          case dbRes of
+            case dbRes of
-            [uid] -> return $ Right $ Just $ E.unValue uid
+              [uid] -> return $ Right $ Just $ E.unValue uid
-            []    -> return $ Left  $ SomeMessage MsgUnknownEmail
+              []    -> return $ Left  $ SomeMessage MsgUnknownEmail
-            _     -> return $ Left  $ SomeMessage MsgAmbiguousEmail
+              _     -> return $ Left  $ SomeMessage MsgAmbiguousEmail
-
+      | Just lookupExpr' <- lookupExpr = do                    -- allow known user entry by avs-nr or corporate-id for convenience
-        Left _notAnEmail -> do                    -- allow known user entry by avs-nr or corporate-id for convenience
           dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
             user <- lookupExpr'
             E.where_ $  ( E.justVal t E.==. user E.^. UserCompanyPersonalNumber

src/Utils.hs

@@ -332,6 +332,9 @@ text2AlphaNumPlus =
     let aNumPlus = Set.fromList oks <> alphaNum
     in  Text.filter (`Set.member` aNumPlus)
 
+-- hasAlpha :: Text -> Bool
+-- hasAlpha = Text.any Char.isAlpha
+
 -- | Convert or remove all non-ascii  characters, e.g. for filenames
 text2asciiAlphaNum :: Text -> Text
 text2asciiAlphaNum = text2AlphaNumPlus ['-','_']

src/Utils/DB.hs

@@ -245,6 +245,7 @@ put v = do
   forM_ (persistUniqueKeys v) deleteBy
   insert v
 
+-- | Deprecated, use selectFirst instead.
 selectMaybe :: forall record backend m.
                ( MonadIO m
                , PersistQueryRead backend