From 7a759b192fff62bc8e7608f58f861f4c2e313534 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 4 Oct 2019 10:10:05 +0200 Subject: [PATCH] feat(allocations): properly save allocation-relevant course-deregs --- messages/uniworx/de.msg | 8 +++- src/Foundation.hs | 2 +- src/Handler/Course/Register.hs | 3 ++ src/Handler/Course/Users.hs | 69 ++++++++++++++++++++++------------ src/Handler/Tutorial/Users.hs | 3 +- src/Utils/Allocation.hs | 19 ++++++---- 6 files changed, 69 insertions(+), 35 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1af89344d..4ed788aa7 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1858,4 +1858,10 @@ CourseNewsVisibleFrom: Sichtbar ab CourseNewsCreated: Kursnachricht erfolgreich angelegt CourseNewsEdited: Kursnachricht erfolgreich editiert CourseNewsDeleteQuestion: Wollen Sie die unten aufgeführte Nachricht wirklich löschen? -CourseNewsDeleted: Kursnachricht erfolgreich gelöscht \ No newline at end of file +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. \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index ed240a2fe..68719193e 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 3cbc7e2e8..2e7b2fd45 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -141,6 +141,9 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do -> return $ FormSuccess Nothing | otherwise -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles + + when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $ + wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationLog return $ CourseRegisterForm <$ secretRes diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index df0169438..a89645a81 100644 --- a/src/Handler/Course/Users.hs +++ b/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 - , RenderMessage UniWorX (Element acts), Eq (Element acts), PathPiece (Element acts) + , Ord act, PathPiece act, RenderMessage UniWorX act ) => 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))) - -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)) - -> DB (FormResult (Element acts, Set UserId), Widget) + -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))) + -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData)) + -> 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 - [ Just CourseUserSendMail - , guardOn mayRegister CourseUserDeregister + acts = mconcat + [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData + , 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 - Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do - nrDel <- deleteWhereCount - [ CourseParticipantCourse ==. cid - , CourseParticipantUser ==. uid - ] - unless (nrDel == 0) $ - audit $ TransactionCourseParticipantDeleted cid uid - return $ Sum nrDel + (CourseUserDeregisterData{..}, selectedUsers) -> do + Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do + now <- liftIO getCurrentTime + Entity reg CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid + lift $ delete reg + lift . audit $ TransactionCourseParticipantDeleted cid uid + case deregisterReason of + Just reason + | 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}|] diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 3c3921960..4c33dd1ee 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/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 diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs index 716faa2f2..d5e80c6b4 100644 --- a/src/Utils/Allocation.hs +++ b/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' -> - LT == (comparing $ courseRating c' &&& stb) (st, cn') (stO, cnO) + isUnstableWith cn' (stO, cnO) = fromMaybe False $ do + 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 c (st, cn) = centralNudge st (fromIntegral cn) courseRating' - where - (_, courseRating') = preferences Map.! (st, c) + courseRating :: course -> (student, CloneIndex) -> Maybe courseRatingStudent' + courseRating c (st, cn) = do + (_, courseRating') <- preferences Map.!? (st, c) + return $ centralNudge st (fromIntegral cn) courseRating' clonedStudents :: Set (student, CloneIndex) clonedStudents = Set.fromDistinctAscList $ do