feat(exam-office): course/user opt-outs

messages/uniworx/de.msg

@@ -1022,6 +1022,7 @@ MenuCourseMembers: Kursteilnehmer
 MenuCourseAddMembers: Kursteilnehmer hinzufügen
 MenuCourseCommunication: Kursmitteilung
 MenuCourseApplications: Bewerbungen
+MenuCourseExamOffice: Prüfungsämter
 MenuTermShow: Semester
 MenuSubmissionDelete: Abgabe löschen
 MenuUsers: Benutzer
@@ -1743,3 +1744,5 @@ TitleChangeUserDisplayEmail: Öffentliche E-Mail Adresse setzen
 MailSubjectChangeUserDisplayEmail: Diese E-Mail Adresse in Uni2work veröffentlichen
 MailIntroChangeUserDisplayEmail displayEmail@UserEmail: Der oben genannte Benutzer möchte „#{displayEmail}“ als öffentliche Adresse, assoziiert mit sich selbst, angeben. Wenn Sie diese Aktion nicht selbst ausgelöst haben, ignorieren Sie diese Mitteilung bitte!
 MailTitleChangeUserDisplayEmail displayName@Text: #{displayName} möchte diese E-Mail Adresse in Uni2work veröffentlichen
+
+ExamOfficeOptOutsChanged: Zuständige Prüfungsämter erfolgreich angepasst

routes

@@ -115,6 +115,7 @@
   /correctors                 CHiWisR          GET
   /communication              CCommR           GET POST
   /notes                      CNotesR          GET POST        !corrector -- THIS route is used to check for overall course corrector access!
+  /exam-office                CExamOfficeR     GET POST        !course-registered
   /subs                       CCorrectionsR    GET POST
   /subs/assigned              CAssignR         GET POST
   /sheet                      SheetListR       GET             !course-registered !materials !corrector

src/Foundation.hs

@@ -67,6 +67,7 @@ import qualified Control.Monad.Catch as C
 import Handler.Utils.StudyFeatures
 import Handler.Utils.SchoolLdap
 import Handler.Utils.ExamOffice.Exam.Auth
+import Handler.Utils.ExamOffice.Course
 import Handler.Utils.Profile
 import Utils.Form
 import Utils.Sheet
@@ -1831,6 +1832,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CourseR tid ssh csh CUsersR)    = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh CAddUserR)  = return ("Kursteilnehmer hinzufügen", Just $ CourseR tid ssh csh CUsersR)
   breadcrumb (CourseR tid ssh csh CInviteR)   = return ("Einladung", Just $ CourseR tid ssh csh CShowR)
+  breadcrumb (CourseR tid ssh csh CExamOfficeR) = return ("Prüfungsamter", Just $ CourseR tid ssh csh CShowR)
   breadcrumb (CourseR tid ssh csh (CUserR cID)) = do
     uid <- decrypt cID
     User{userDisplayName} <- runDB $ get404 uid
@@ -2454,6 +2456,20 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionSecondary
+      , menuItemLabel = MsgMenuCourseExamOffice
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamOfficeR
+      , menuItemModal = True
+      , menuItemAccessCallback' = do
+          uid <- requireAuthId
+          runDB $ do
+            cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh 
+            E.selectExists $ do
+              (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid)
+              E.where_ $ E.not_ isForced
+      }
   ]
 pageActions (CourseR tid ssh csh CCorrectionsR) =
   [ MenuItem

src/Handler/Course.hs

@@ -16,6 +16,7 @@ import Handler.Course.Show as Handler.Course
 import Handler.Course.User as Handler.Course
 import Handler.Course.Users as Handler.Course
 import Handler.Course.Application as Handler.Course
+import Handler.ExamOffice.Course as Handler.Course
 
 
 getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html

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 <- liftHandlerT . 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
+      <section>
+        ^{explanation}
+      <section>
+        ^{optOutView'}
+    |]

src/Handler/Utils/ExamOffice/Course.hs

@@ -0,0 +1,32 @@
+module Handler.Utils.ExamOffice.Course
+  ( courseExamOfficeSchools
+  ) where
+
+import Import.NoFoundation
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+
+courseExamOfficeSchools :: E.SqlExpr (E.Value UserId)
+                        -> E.SqlExpr (E.Value CourseId)
+                        -> E.SqlQuery (E.SqlExpr (Entity School), E.SqlExpr (E.Value Bool)) -- ^ @Entity School@ and @forced@
+courseExamOfficeSchools user _course = E.from $ \(school `E.InnerJoin` userFunction `E.InnerJoin` (examOfficeField `E.FullOuterJoin` examOfficeUser))
+  -> E.distinctOnOrderBy [E.asc $ userFunction E.^. UserFunctionSchool] $ do
+       E.on   E.false
+       E.on $ (      examOfficeUser E.?. ExamOfficeUserUser E.==. E.just user
+               E.&&. examOfficeUser E.?. ExamOfficeUserOffice E.==. E.just (userFunction E.^. UserFunctionUser)
+              )
+        E.||. (      examOfficeField E.?. ExamOfficeFieldOffice E.==. E.just (userFunction E.^. UserFunctionUser)
+               E.&&. E.exists ( E.from $ \studyFeatures ->
+                                  E.where_ $ E.just (studyFeatures E.^. StudyFeaturesField) E.==. examOfficeField E.?. ExamOfficeFieldField
+                                       E.&&. studyFeatures E.^. StudyFeaturesUser E.==. user
+                              )
+              )
+       E.on $ school E.^. SchoolId E.==. userFunction E.^. UserFunctionSchool
+        E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
+
+       let forced = E.maybe E.true id $ examOfficeField E.?. ExamOfficeFieldForced 
+
+       E.orderBy [E.desc forced]
+       return $ (school, forced)

src/Utils/Lens.hs

@@ -191,6 +191,8 @@ makeLenses_ ''SchoolLdap
 
 makeLenses_ ''UserFunction
 
+makeLenses_ ''CourseUserExamOfficeOptOut
+  
 
 -- makeClassy_ ''Load
 

templates/i18n/course-exam-office-explanation/de.hamlet

@@ -0,0 +1,24 @@
+$newline never
+<p>
+  Hier können Sie der Meldung ihrer Prüfungsleistungen an Prüfungsämter #
+  bestimmter Institute (innerhalb von Uni2work) widersprechen.
+<p>
+  Bedenken Sie, dass die Meldung der Prüfungsleistungen direkt in Uni2work den #
+  Verwaltungsaufwand (und die damit verbunden Dauer) für die ordnungsgemäße #
+  Anrechung Ihrer Leistungen drastisch reduziert.
+<p>
+  Unter Umständen können Prüfungsämter ungeachtet der Angaben, die Sie hier #
+  machen, Einsicht in Ihre Leistungen erlangen.<br />
+  Dies geschieht nur in begründeten Einzelfällen (z.B. bei Studierenden im #
+  ERASMUS-Programm).
+<p>
+  Nutzer, die unabhängig von diesen Einstellungen, Einsicht in Ihre #
+  Prüfungsleistungen haben (z.B. die Kursverwalter) können Ihre Note natürlich #
+  außerhalb von Uni2work an Prüfungsämter melden (auch solche, die hier nicht #
+  aufgeführt sind).
+$if hasForced
+  <p>
+    Wenn Sie der Meldung an einzelne Prüfungsämter nicht widersprechen können, #
+    so hat das jeweilige Prüfungsamt angegeben, dass die Einsicht, entweder #
+    aufgrund einer Ihrer Studiengänge (z.B. aufgrund der Studienordnung) oder #
+    bei Ihnen spezifisch, zwingend erforderlich ist.