feat(allocations): properly save allocation-relevant course-deregs
This commit is contained in:
Gregor Kleen
parent
011b0dcc10
commit
7a759b192f
@ -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
|
||||
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.
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}|]
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user