Course User Deregister

messages/uniworx/de.msg

@@ -112,6 +112,9 @@ CourseUserNote: Notiz
 CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar
 CourseUserNoteSaved: Notizänderungen gespeichert
 CourseUserNoteDeleted: Teilnehmernotiz gelöscht
+CourseUserDeregister: Abmelden
+CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
+
 CourseLecturers: Kursverwalter
 CourseLecturer: Dozent
 CourseAssistant: Assistent

routes

@@ -75,7 +75,7 @@
   /register                   CRegisterR          POST        !timeANDcapacity
   /edit                       CEditR          GET POST
   /delete                     CDeleteR        GET POST        !lecturerANDempty
-  /users                      CUsersR         GET
+  /users                      CUsersR         GET POST
   /users/#CryptoUUIDUser      CUserR          GET POST        !lecturerANDparticipant
   /correctors                 CHiWisR         GET
   /notes                      CNotesR         GET POST        !corrector

src/Handler/Course.hs

@@ -14,6 +14,7 @@ import Handler.Utils.Delete
 import Handler.Utils.Database
 import Handler.Utils.Table.Cells
 import Handler.Utils.Table.Columns
+import Database.Persist.Sql (deleteWhereCount)
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
@@ -819,57 +820,87 @@ colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell
 colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
     foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
 
-makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
-makeCourseUserTable cid colChoices psValidator =
-  -- -- psValidator has default sorting and filtering
-  let dbtIdent     = "courseUsers" :: Text
-      dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
-      dbtSQLQuery  = userTableQuery cid
-      dbtRowKey    = queryUser >>> (E.^. UserId)
-      dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
-      dbtColonnade = colChoices
-      dbtSorting   = Map.fromList
-        [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
-        , sortUserSurname     queryUser -- needed for initial sorting
-        , sortUserDisplayName queryUser -- needed for initial sorting
-        , sortUserEmail       queryUser
-        , sortUserMatriclenr  queryUser
-        , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
-        , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
-        , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
-        , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
-        , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
-        , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
-        , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
-              E.sub_select . E.from $ \edit -> do
-                E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
-                return . E.max_ $ edit E.^. CourseUserNoteEditTime
-          )
-        ]
-      dbtFilter    = Map.fromList
-        [ fltrUserNameLink    queryUser
-        , fltrUserEmail       queryUser
-        , fltrUserMatriclenr  queryUser
-        , fltrUserNameEmail   queryUser
-        -- , ("course-user-degree", error "TODO") -- TODO
-        -- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO
-        , ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
-        -- , ("course-registration", error "TODO") -- TODO
-        -- , ("course-user-note", error "TODO") -- TODO
-        ]
-      dbtFilterUI mPrev = mconcat
-        [ fltrUserNameEmailUI  mPrev
-        , fltrUserMatriclenrUI mPrev
-        ]
-      dbtParams    = def
-  in dbTableWidget' psValidator DBTable{..}
 
+data CourseUserAction = CourseUserDeregister
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
-getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+instance Universe CourseUserAction
-getCUsersR tid ssh csh = do
+instance Finite CourseUserAction
-  (course, numParticipants, participantTable) <- runDB $ do
+nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''CourseUserAction id
+
+makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget)
+makeCourseUserTable cid colChoices psValidator = do
+    Just currentRoute <- liftHandlerT getCurrentRoute
+    -- -- psValidator has default sorting and filtering
+    let dbtIdent     = "courseUsers" :: Text
+        dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
+        dbtSQLQuery  = userTableQuery cid
+        dbtRowKey    = queryUser >>> (E.^. UserId)
+        dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
+        dbtColonnade = colChoices
+        dbtSorting   = Map.fromList
+          [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
+          , sortUserSurname     queryUser -- needed for initial sorting
+          , sortUserDisplayName queryUser -- needed for initial sorting
+          , sortUserEmail       queryUser
+          , sortUserMatriclenr  queryUser
+          , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
+          , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
+          , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
+          , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
+          , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+          , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
+          , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
+                E.sub_select . E.from $ \edit -> do
+                  E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
+                  return . E.max_ $ edit E.^. CourseUserNoteEditTime
+            )
+          ]
+        dbtFilter    = Map.fromList
+          [ fltrUserNameLink    queryUser
+          , fltrUserEmail       queryUser
+          , fltrUserMatriclenr  queryUser
+          , fltrUserNameEmail   queryUser
+          -- , ("course-user-degree", error "TODO") -- TODO
+          -- , ("field" , FilterColumn $ queryFeaturesField error "TODO") -- TODO
+          , ("semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+          -- , ("course-registration", error "TODO") -- TODO
+          -- , ("course-user-note", error "TODO") -- TODO
+          ]
+        dbtFilterUI mPrev = mconcat
+          [ fltrUserNameEmailUI  mPrev
+          , fltrUserMatriclenrUI mPrev
+          ]
+        dbtParams    = DBParamsForm
+          { dbParamsFormMethod = POST
+          , dbParamsFormAction = Just $ SomeRoute currentRoute
+          , 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
+          }
+    over _1 postprocess <$> dbTable psValidator DBTable{..}
+  where
+    postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool  UserTableData) -> FormResult (CourseUserAction, Set UserId)
+    postprocess inp = do
+      (First (Just act), usrMap) <- inp
+      let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
+      return (act, usrSet)
+
+getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCUsersR = postCUsersR
+postCUsersR tid ssh csh = do
+  (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
     let colChoices  = mconcat
-          [ colUserNameLink (CourseR tid ssh csh . CUserR)
+          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
+          , colUserNameLink (CourseR tid ssh csh . CUserR)
           , colUserEmail
           , colUserMatriclenr
           , colUserDegreeShort
@@ -879,10 +910,18 @@ getCUsersR tid ssh csh = do
           , colUserComment tid ssh csh
           ]
         psValidator = def & defaultSortingByName
-    Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh
+    ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
     numParticipants <- count [CourseParticipantCourse ==. cid]
-    participantTable <- makeCourseUserTable cid colChoices psValidator
+    table <- makeCourseUserTable cid colChoices psValidator
-    return (course, numParticipants, participantTable)
+    return (ent, numParticipants, table)
+  formResult participantRes $ \case
+    (CourseUserDeregister,selectedUsers) -> do
+        nrDel <- runDB $ deleteWhereCount
+          [ CourseParticipantCourse ==. cid
+          , CourseParticipantUser <-. Set.toList selectedUsers
+          ]
+        addMessageI Success $ MsgCourseUsersDeregistered nrDel
+        redirect $ CourseR tid ssh csh CUsersR
   let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
       headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
   siteLayout headingLong $ do