feat(course-users): allow registering tutorial users manually

include tutorials in course-user csv-export

messages/uniworx/de.msg

@@ -144,12 +144,15 @@ CourseFilterRegistered: Registriert
 CourseFilterNone: Egal
 CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen?
 CourseDeleted: Kurs gelöscht
+CourseUserTutorials: Angemeldete Tutorien
 CourseUserNote: Notiz
 CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar
 CourseUserNoteSaved: Notizänderungen gespeichert
 CourseUserNoteDeleted: Teilnehmernotiz gelöscht
 CourseUserDeregister: Vom Kurs abmelden
 CourseUsersDeregistered count@Int64: #{show count} Teilnehmer vom Kurs abgemeldet
+CourseUserRegisterTutorial: Zu einem Tutorium anmelden
+CourseUsersTutorialRegistered count@Int64: #{show count} Teilnehmer zum Tutorium angemeldet
 CourseUserSendMail: Mitteilung verschicken
 TutorialUserDeregister: Vom Tutorium Abmelden
 TutorialUserSendMail: Mitteilung verschicken

src/CryptoID.hs

@@ -50,6 +50,7 @@ decCryptoIDs [ ''SubmissionId
              , ''CourseId
              , ''CourseNewsId
              , ''CourseEventId
+             , ''TutorialId
              ]
 
 -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"

src/Handler/Course/Users.hs

@@ -116,6 +116,14 @@ colUserComment tid ssh csh =
   where
     courseLink = CourseR tid ssh csh . CUserR
 
+colUserTutorials :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
+colUserTutorials tid ssh csh = sortable (Just "tutorials") (i18nCell MsgCourseUserTutorials)
+  $ \(view _userTutorials -> tuts') ->
+    let tuts = sortOn (tutorialName . entityVal) $ (tuts' ^. _1) ++ (tuts' ^.. _2 . folded . _Just)
+     in (cellAttrs <>~ [("class", "list--inline list--comma-separated list--iconless")]) . listCell tuts $ anchorCell'
+          (\(Entity _ Tutorial{..}) -> CTutorialR tid ssh csh tutorialName TUsersR)
+          (tutorialName . entityVal)
+
 colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
 colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
     foldMap numCell . preview _rowUserSemester
@@ -219,7 +227,9 @@ userTableCsvHeader UserCsvExportData{..} tuts = Csv.header $
     regGroups = Set.toList $ setOf (folded . _entityVal . _tutorialRegGroup . _Just) tuts
 
 
-data CourseUserAction = CourseUserSendMail | CourseUserDeregister
+data CourseUserAction = CourseUserSendMail
+                      | CourseUserDeregister
+                      | CourseUserRegisterTutorial
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 instance Universe CourseUserAction
@@ -231,6 +241,9 @@ data CourseUserActionData = CourseUserSendMailData
                           | CourseUserDeregisterData
                             { deregisterReason :: Maybe Text
                             }
+                          | CourseUserRegisterTutorialData
+                            { registerTutorial :: TutorialId
+                            }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 
@@ -260,7 +273,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
           let
             regGroups = setOf (folded . _entityVal . _tutorialRegGroup . _Just) tutorials
             tuts' = filter (\(Entity tutId _) -> any ((== tutId) . tutorialParticipantTutorial . entityVal) tuts'') tutorials
-            tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) regGroups) tuts'
+            tuts = foldr (\tut@(Entity _ Tutorial{..}) -> maybe (over _1 $ cons tut) (over _2 . flip (Map.insertWith (<|>)) (Just tut)) tutorialRegGroup) ([], Map.fromSet (const Nothing) regGroups) tuts'
           return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms), tuts)
         dbtColonnade = colChoices
         dbtSorting   = Map.fromList
@@ -280,6 +293,13 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
                   E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
                   return . E.max_ $ edit E.^. CourseUserNoteEditTime
             )
+          , ("tutorials"   , SortColumn $ queryUser >>> \user ->
+                E.sub_select . E.from $ \(tutorial `E.InnerJoin` participant) -> do
+                  E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
+                   E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
+                  E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
+                  return . E.min_ $ tutorial E.^. TutorialName
+            )
           ]
         dbtFilter    = Map.fromList
           [ fltrUserNameLink    queryUser
@@ -407,20 +427,26 @@ postCUsersR tid ssh csh = do
   (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
     mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
     ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
-    let colChoices  = mconcat
+    hasTutorials <- exists [TutorialCourse ==. cid]
-          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
+    let colChoices  = mconcat $ catMaybes
-          , colUserNameLink (CourseR tid ssh csh . CUserR)
+          [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-          , colUserEmail
+          , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
-          , colUserMatriclenr
+          , pure $ colUserEmail
-          , colUserDegreeShort
+          , pure $ colUserMatriclenr
-          , colUserField
+          , pure $ colUserDegreeShort
-          , colUserSemester
+          , pure $ colUserField
-          , sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
+          , pure $ colUserSemester
-          , colUserComment tid ssh csh
+          , guardOn hasTutorials $ colUserTutorials tid ssh csh
+          , pure $ sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
+          , pure $ colUserComment tid ssh csh
           ]
         psValidator = def & defaultSortingByName
         acts = mconcat
           [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
+          , singletonMap CourseUserRegisterTutorial $ CourseUserRegisterTutorialData <$>
+            apopt (selectField' Nothing . fmap (fmap entityKey) $ optionsPersistCryptoId [TutorialCourse ==. cid] [Asc TutorialName] tutorialName)
+                  (fslI MsgCourseTutorial)
+                  Nothing
           , if
               | mayRegister
                 -> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
@@ -448,6 +474,11 @@ postCUsersR tid ssh csh = do
           return 1
         addMessageI Success $ MsgCourseUsersDeregistered nrDel
         redirect $ CourseR tid ssh csh CUsersR
+    (CourseUserRegisterTutorialData{..}, selectedUsers) -> do
+        runDB . forM_ selectedUsers $ 
+          void . insertUnique . TutorialParticipant registerTutorial
+        addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
+        redirect $ CourseR tid ssh csh CUsersR
   let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]
       headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
   siteLayout headingLong $ do

src/Handler/Tutorial/Users.hs

@@ -46,7 +46,7 @@ postTUsersR tid ssh csh tutn = do
           ]
         psValidator = def
           & defaultSortingByName
-          & restrictSorting (\name _ -> none (== name) ["note"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
+          & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
         isInTut q = E.exists . E.from $ \tutorialParticipant ->
           E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
                E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid

templates/i18n/changelog/de.hamlet

@@ -1,5 +1,12 @@
 $newline never
 <dl .deflist>
+  <dt .deflist__dt>
+    ^{formatGregorianW 2019 10 10}
+  <dd .deflist__dd>
+    <ul>
+      <li>CSV-Export für Liste von Kursteilnehmern exportiert nun auch die angemeldeten Tutorien
+      <li>Teilnehmer können von der Teilnehmerliste aus in Tutorien angemeldet werden
+
   <dt .deflist__dt>
     ^{formatGregorianW 2019 10 09}
   <dd .deflist__dd>