feat(allocations): properly save allocation-relevant course-deregs

messages/uniworx/de.msg

@@ -1859,3 +1859,9 @@ CourseNewsCreated: Kursnachricht erfolgreich angelegt
 CourseNewsEdited: Kursnachricht erfolgreich editiert
 CourseNewsDeleteQuestion: Wollen Sie die unten aufgeführte Nachricht wirklich löschen?
 CourseNewsDeleted: Kursnachricht erfolgreich gelöscht
+
+CourseDeregistrationAllocationLog: Ihr Platz in diesem Kurs stammt aus einer Zentralanmeldung. Wenn Sie sich vom Kurs abmelden wird dieser Umstand permanent im System gespeichert und kann Sie u.U. bei zukünftigen Zentralanmeldungen benachteiligen. Wenn Sie gute Gründe vorzuweisen haben, warum Ihre Abmeldung nicht selbstverschuldet ist, kontaktieren Sie bitte einen Kursverwalter. Diese haben die Möglichkeit Sie ohne permanente Eintragung im System abzumelden. 
+CourseDeregistrationAllocationReason: Grund
+CourseDeregistrationAllocationReasonTip: Der angegebene Grund wird permanent im System hinterlegt und ist i.A. einziger Anhaltspunkt zur Schlichtung etwaiger Konflikte
+CourseDeregistrationAllocationShouldLog: Selbstverschuldet
+CourseDeregistrationAllocationShouldLogTip: Falls der Platz des Studierenden, der abgemeldet wird, aus einer Zentralanmeldung stammt, ist vorgesehen einen permanenten Eintrag im System zu speichern, der den Studierenden u.U. bei zukünftigen Zentralanmeldungen benachteiligt. Als Kursverwalter haben Sie die Möglichkeit dies zu unterbinden, wenn der Studierende gute Gründe vorweisen kann, warum seine Abmeldung nicht selbstverschuldet ist.

src/Foundation.hs

@@ -1018,7 +1018,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
     mba <- mbAllocation tid ssh csh
     case mba of
       Just (_, Allocation{..})
-        | NTop allocationRegisterByStaffTo <= NTop (Just now)
+        |    NTop allocationRegisterByStaffTo <= NTop (Just now)
           || NTop allocationRegisterByStaffFrom >= NTop (Just now)
           -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete
       _other -> return Authorized

src/Handler/Course/Register.hs

@@ -142,6 +142,9 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
       | otherwise
         -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
 
+    when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $
+      wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationLog
+      
     return $ CourseRegisterForm
       <$  secretRes
       <*> fieldRes

src/Handler/Course/Users.hs

@@ -11,7 +11,6 @@ import Import
 
 import Utils.Form
 import Handler.Utils
-import Database.Persist.Sql (deleteWhereCount)
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
@@ -126,18 +125,23 @@ instance Finite CourseUserAction
 nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
 embedRenderMessage ''UniWorX ''CourseUserAction id
 
+data CourseUserActionData = CourseUserSendMailData
+                          | CourseUserDeregisterData
+                            { deregisterReason :: Maybe Text
+                            }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
-makeCourseUserTable :: forall h acts.
+
+makeCourseUserTable :: forall h act act'.
                        ( Functor h, ToSortable h
-                       , MonoFoldable acts
+                       , Ord act, PathPiece act, RenderMessage UniWorX act
-                       , RenderMessage UniWorX (Element acts), Eq (Element acts), PathPiece (Element acts)
                        )
                     => CourseId
-                    -> acts
+                    -> Map act (AForm Handler act')
                     -> (UserTableExpr -> E.SqlExpr (E.Value Bool))
-                    -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)))
+                    -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData)))
-                    -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))
+                    -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))
-                    -> DB (FormResult (Element acts, Set UserId), Widget)
+                    -> DB (FormResult (act', Set UserId), Widget)
 makeCourseUserTable cid acts restrict colChoices psValidator = do
     currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute
     -- -- psValidator has default sorting and filtering
@@ -209,7 +213,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do
           , dbParamsFormAdditional
               = renderAForm FormStandard
                    $  (, mempty) . First . Just
-                  <$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing
+                  <$> multiActionA acts (fslI MsgAction) Nothing
           , dbParamsFormEvaluate = liftHandler . runFormPost
           , dbParamsFormResult   = id
           , dbParamsFormIdent    = def
@@ -218,17 +222,28 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do
         dbtCsvDecode = Nothing
     over _1 postprocess <$> dbTable psValidator DBTable{..}
   where
-    postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)
+    postprocess :: FormResult (First act', DBFormResult UserId Bool UserTableData) -> FormResult (act', Set UserId)
     postprocess inp = do
       (First (Just act), usrMap) <- inp
       let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
       return (act, usrSet)
 
+courseUserDeregisterForm :: CourseId -> AForm Handler CourseUserActionData
+courseUserDeregisterForm cid = wFormToAForm $ do
+  allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant ->
+    E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
+         E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated)
+  if | allocated -> do
+         wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip
+         fmap CourseUserDeregisterData <$> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True)
+     | otherwise -> pure . pure $ CourseUserDeregisterData Nothing
+
 getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCUsersR = postCUsersR
 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)
@@ -241,27 +256,33 @@ postCUsersR tid ssh csh = do
           , colUserComment tid ssh csh
           ]
         psValidator = def & defaultSortingByName
-        acts = catMaybes
+        acts = mconcat
-          [ Just CourseUserSendMail
+          [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
-          , guardOn mayRegister CourseUserDeregister
+          , if
+              | mayRegister
+                -> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid
+              | otherwise
+                -> mempty
           ]
-    ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
     numParticipants <- count [CourseParticipantCourse ==. cid]
     table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator
     return (ent, numParticipants, table)
   formResult participantRes $ \case
-    (CourseUserSendMail, selectedUsers) -> do
+    (CourseUserSendMailData, selectedUsers) -> do
         cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
         redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
-    (CourseUserDeregister,selectedUsers) -> do
+    (CourseUserDeregisterData{..}, selectedUsers) -> do
-        Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do
+        Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
-          nrDel <- deleteWhereCount
+          now <- liftIO getCurrentTime
-            [ CourseParticipantCourse ==. cid
+          Entity reg CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid
-            , CourseParticipantUser ==. uid
+          lift $ delete reg
-            ]
+          lift . audit $ TransactionCourseParticipantDeleted cid uid
-          unless (nrDel == 0) $
+          case deregisterReason of
-            audit $ TransactionCourseParticipantDeleted cid uid
+            Just reason
-          return $ Sum nrDel
+              | is _Just courseParticipantAllocated ->
+                  lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason)
+            _other -> return ()
+          return 1
         addMessageI Success $ MsgCourseUsersDeregistered nrDel
         redirect $ CourseR tid ssh csh CUsersR
   let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]

src/Handler/Tutorial/Users.hs

@@ -14,6 +14,7 @@ import qualified Data.CaseInsensitive as CI
 import Data.Function ((&))
 
 import qualified Data.Set as Set
+import qualified Data.Map as Map
 
 import qualified Database.Esqueleto as E
 
@@ -51,7 +52,7 @@ postTUsersR tid ssh csh tutn = do
                E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
 
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    table <- makeCourseUserTable cid universeF isInTut colChoices psValidator
+    table <- makeCourseUserTable cid (Map.fromList $ map (id &&& pure) universeF) isInTut colChoices psValidator
     return (tut, table)
 
   formResult participantRes $ \case

src/Utils/Allocation.hs

@@ -116,17 +116,20 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
                           guard $ (s, cn') == student
                           return course
 
-                      let capacity = maybe (error "course without capacity treated as one") fromIntegral $ capacities Map.! c
+                      let capacity = maybe (error "course without capacity treated as one") fromIntegral . fromMaybe (error "course not found in capacities") $ capacities Map.!? c
                           (worseSpots, betterSpots) = Seq.spanr isWorseSpot spots
-                          isWorseSpot existing = case (comparing $ courseRating c &&& stb) existing (st, cn) of
+                          isWorseSpot existing = case (comparing $ fromMaybe (error "(st, c) not in preferences") . courseRating c &&& stb) existing (st, cn) of
                             EQ -> error "Two student-clones compared equal in the face of stb"
                             GT -> False
                             LT -> True
                           (newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots
 
                           isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool
-                          isUnstableWith cn' (stO, cnO) = fromMaybe False $ matchingCourse st cn' <&> \c' ->
+                          isUnstableWith cn' (stO, cnO) = fromMaybe False $ do
-                            LT == (comparing $ courseRating c' &&& stb) (st, cn') (stO, cnO)
+                            c' <- matchingCourse st cn'
+                            rMe <- courseRating c' (st, cn')
+                            rOther <- courseRating c' (stO, cnO)
+                            return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO))
 
                       if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots
                            -> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c
@@ -227,10 +230,10 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
           Right spots -> view _1 <$> toList spots
         return (student, course)
 
-    courseRating :: course -> (student, CloneIndex) -> courseRatingStudent'
+    courseRating :: course -> (student, CloneIndex) -> Maybe courseRatingStudent'
-    courseRating c (st, cn) = centralNudge st (fromIntegral cn) courseRating'
+    courseRating c (st, cn) = do
-      where
+      (_, courseRating') <- preferences Map.!? (st, c)
-        (_, courseRating') = preferences Map.! (st, c)
+      return $ centralNudge st (fromIntegral cn) courseRating'
     
     clonedStudents :: Set (student, CloneIndex)
     clonedStudents = Set.fromDistinctAscList $ do