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

include tutorials in course-user csv-export
2019-10-10 11:58:38 +02:00 · 2019-10-10 11:58:38 +02:00 · d507d9bbde
commit d507d9bbde
parent 1d5ddd102c
5 changed files with 55 additions and 13 deletions
--- a/messages/uniworx/de.msg
+++ b/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
--- a/src/CryptoID.hs
+++ b/src/CryptoID.hs
@ -50,6 +50,7 @@ decCryptoIDs [ ''SubmissionId
             , ''CourseId
             , ''CourseNewsId
             , ''CourseEventId
+             , ''TutorialId
             ]

 -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"
--- a/src/Handler/Course/Users.hs
+++ b/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
-          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-          , colUserNameLink (CourseR tid ssh csh . CUserR)
-          , colUserEmail
-          , colUserMatriclenr
-          , colUserDegreeShort
-          , colUserField
-          , colUserSemester
-          , sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
-          , colUserComment tid ssh csh
+    hasTutorials <- exists [TutorialCourse ==. cid]
+    let colChoices  = mconcat $ catMaybes
+          [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
+          , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
+          , pure $ colUserEmail
+          , pure $ colUserMatriclenr
+          , pure $ colUserDegreeShort
+          , pure $ colUserField
+          , pure $ colUserSemester
+          , 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
--- a/src/Handler/Tutorial/Users.hs
+++ b/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
--- a/templates/i18n/changelog/de.hamlet
+++ b/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>