From 1b532c4e4d2aa90da93a08dd4f1dbaf8626e8077 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <kleen@cip.ifi.lmu.de>
Date: Wed, 17 Jul 2019 11:14:15 +0200
Subject: [PATCH] feat(exams): allow forced deregistration

---
 messages/uniworx/de.msg |  2 ++
 routes                  |  2 +-
 src/Handler/Exam.hs     | 51 +++++++++++++++++++++++++++++++++++++----
 3 files changed, 49 insertions(+), 6 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index 2deccb636..88a2d6821 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -1186,6 +1186,8 @@ VersionHistory: Versionsgeschichte
 KnownBugs: Bekannte Bugs
 
 ExamUsersHeading: Klausurteilnehmer
+ExamUserDeregister: Teilnehmer von Klausur abmelden
+ExamUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
 
 CsvFile: CSV-Datei
 CsvModifyExisting: Existierende Einträge angleichen
diff --git a/routes b/routes
index a6241127d..3b1aa5262 100644
--- a/routes
+++ b/routes
@@ -143,7 +143,7 @@
     /show                       EShowR         GET             !time
     /edit                       EEditR         GET POST
     /corrector-invite           ECInviteR      GET POST
-    /users                      EUsersR        GET POST        !timeANDcorrector
+    /users                      EUsersR        GET POST
     /users/new                  EAddUserR      GET POST
     /users/invite               EInviteR       GET POST
     /register                   ERegisterR         POST        !timeANDcourse-registered !timeANDexam-registered
diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs
index b3ad24767..73c323d4d 100644
--- a/src/Handler/Exam.hs
+++ b/src/Handler/Exam.hs
@@ -36,6 +36,8 @@ import qualified Data.Conduit.List as C
 
 import Numeric.Lens (integral)
 
+import Database.Persist.Sql (deleteWhereCount)
+
 
 
 -- Dedicated ExamRegistrationButton
@@ -809,6 +811,9 @@ queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
 queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
 queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
 
+resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
+resultExamRegistration = _dbrOutput . _1
+
 resultUser :: Lens' ExamUserTableData (Entity User)
 resultUser = _dbrOutput . _2
 
@@ -866,10 +871,18 @@ instance CsvColumnsExplained ExamUserTableCsv where
     , ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax ) 
     ]
 
+data ExamUserAction = ExamUserDeregister
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe ExamUserAction
+instance Finite ExamUserAction
+nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''ExamUserAction id
+
 getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEUsersR = postEUsersR
 postEUsersR tid ssh csh examn = do
-  ((), examUsersTable) <- runDB $ do
+  (registrationResult, examUsersTable) <- runDB $ do
     exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
     bonus <- examBonus exam
 
@@ -894,8 +907,9 @@ postEUsersR tid ssh csh examn = do
             return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField)
           dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
           dbtProj = return
-          dbtColonnade = dbColonnade . mconcat $ catMaybes
-            [ pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
+          dbtColonnade = mconcat $ catMaybes
+            [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey)
+            , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
             , pure   colUserMatriclenr
             , pure $ colField            resultStudyField
             , pure $ colDegreeShort      resultStudyDegree
@@ -937,7 +951,20 @@ postEUsersR tid ssh csh examn = do
             , prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence)
             ]
           dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
-          dbtParams = def
+          dbtParams = DBParamsForm
+            { dbParamsFormMethod = POST
+            , dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR
+            , dbParamsFormAttrs  = []
+            , dbParamsFormSubmit = FormSubmit
+            , dbParamsFormAdditional = \csrf -> do
+                (res, vw) <- mreq (selectField optionsFinite) "" Nothing
+                let formWgt = toWidget csrf <> fvInput vw
+                    formRes = (, mempty) . First . Just <$> res
+                return (formRes, formWgt)
+            , dbParamsFormEvaluate = liftHandlerT . runFormPost
+            , dbParamsFormResult   = id
+            , dbParamsFormIdent    = def
+            }
           dbtIdent :: Text
           dbtIdent = "exam-users"
           dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
@@ -956,7 +983,21 @@ postEUsersR tid ssh csh examn = do
           dbtCsvDecode = Nothing
 
       examUsersDBTableValidator = def
-    dbTable examUsersDBTableValidator examUsersDBTable
+
+      postprocess :: FormResult (First ExamUserAction, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserAction, Set ExamRegistrationId)
+      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
+
+  formResult registrationResult $ \case
+    (ExamUserDeregister, selectedRegistrations) -> do
+      nrDel <- runDB $ deleteWhereCount
+        [ ExamRegistrationId <-. Set.toList selectedRegistrations
+        ]
+      addMessageI Success $ MsgExamUsersDeregistered nrDel
+      redirect $ CExamR tid ssh csh examn EUsersR
 
   siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
     setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading