284 lines
14 KiB
Haskell
284 lines
14 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
module Handler.Exam.AutoOccurrence
|
|
( examAutoOccurrenceCalculateWidget
|
|
, postEAutoOccurrenceR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Utils.Exam
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import Database.Persist.Sql (updateWhereCount)
|
|
|
|
newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm
|
|
{ eaofConfig :: ExamAutoOccurrenceConfig
|
|
} deriving stock (Eq, Ord, Read, Show, Generic)
|
|
deriving newtype (Default, FromJSON, ToJSON)
|
|
|
|
makeLenses_ ''ExamAutoOccurrenceCalculateForm
|
|
|
|
data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm
|
|
{ eaofMapping :: ExamOccurrenceMapping ExamOccurrenceId
|
|
, eaofAssignment :: Map UserId (Maybe ExamOccurrenceId)
|
|
, eaofSuccess :: Bool
|
|
} deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
deriveJSON defaultOptions
|
|
{ fieldLabelModifier = camelToPathPiece' 1
|
|
} ''ExamAutoOccurrenceAcceptForm
|
|
|
|
data ExamAutoOccurrenceButton
|
|
= BtnExamAutoOccurrenceCalculate
|
|
| BtnExamAutoOccurrenceAccept
|
|
| BtnExamAutoOccurrenceNudgeUp | BtnExamAutoOccurrenceNudgeDown
|
|
| BtnExamAutoOccurrenceIgnore | BtnExamAutoOccurrenceReconsider
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
|
instance Universe ExamAutoOccurrenceButton
|
|
instance Finite ExamAutoOccurrenceButton
|
|
|
|
nullaryPathPiece ''ExamAutoOccurrenceButton $ camelToPathPiece' 4
|
|
|
|
instance Button UniWorX ExamAutoOccurrenceButton where
|
|
btnLabel BtnExamAutoOccurrenceCalculate = i18n MsgBtnExamAutoOccurrenceCalculate
|
|
btnLabel BtnExamAutoOccurrenceAccept = i18n MsgBtnExamAutoOccurrenceAccept
|
|
btnLabel BtnExamAutoOccurrenceNudgeUp = toWidget iconExamAutoOccurrenceNudgeUp
|
|
btnLabel BtnExamAutoOccurrenceNudgeDown = toWidget iconExamAutoOccurrenceNudgeDown
|
|
btnLabel BtnExamAutoOccurrenceIgnore = toWidget iconExamAutoOccurrenceIgnore
|
|
btnLabel BtnExamAutoOccurrenceReconsider = toWidget iconExamAutoOccurrenceReconsider
|
|
|
|
btnClasses BtnExamAutoOccurrenceNudgeUp = [BCIsButton]
|
|
btnClasses BtnExamAutoOccurrenceNudgeDown = [BCIsButton]
|
|
btnClasses BtnExamAutoOccurrenceIgnore = [BCIsButton]
|
|
btnClasses BtnExamAutoOccurrenceReconsider = [BCIsButton]
|
|
btnClasses _ = [BCIsButton, BCPrimary]
|
|
|
|
|
|
examAutoOccurrenceCalculateForm :: Map ExamOccurrenceId ExamOccurrenceCapacity
|
|
-> Map UserId (User, Maybe ExamOccurrenceId)
|
|
-> ExamAutoOccurrenceCalculateForm
|
|
-> Form ExamAutoOccurrenceCalculateForm
|
|
examAutoOccurrenceCalculateForm occurrences (fromIntegral . length -> usersCount) ExamAutoOccurrenceCalculateForm { eaofConfig }
|
|
= identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm
|
|
where
|
|
eaocForm =
|
|
(set _eaocIgnoreRooms . automaticIfTrue <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just . minimizeRooms $ eaofConfig ^. _eaocIgnoreRooms))
|
|
<*> pure def
|
|
automaticIfTrue :: Bool -> ExamAutoOccurrenceIgnoreRooms
|
|
automaticIfTrue True = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored, eaoirSorted=True}
|
|
automaticIfTrue False = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored=Set.empty, eaoirSorted=False}
|
|
minimizeRooms :: ExamAutoOccurrenceIgnoreRooms -> Bool
|
|
minimizeRooms ExamAutoOccurrenceIgnoreRooms {eaoirSorted} = eaoirSorted
|
|
eaoirIgnored :: Set ExamOccurrenceId
|
|
-- ^ Minimise number of occurrences used
|
|
--
|
|
-- Prefer occurrences with higher capacity
|
|
--
|
|
-- If a single occurrence can accommodate all participants, pick the one with
|
|
-- the least capacity
|
|
eaoirIgnored
|
|
| Just largeEnoughs <- fromNullable . filter ((>= Restricted usersCount) . view _2) $ Map.toList occurrences
|
|
= Set.delete (view _1 $ minimumBy (comparing $ view _2) largeEnoughs) $ Map.keysSet occurrences
|
|
| otherwise
|
|
= Set.fromList . view _2 . foldl' accF (Restricted 0, [])
|
|
. sortOn (Down . view _2) $ Map.toList occurrences
|
|
where
|
|
accF :: (ExamOccurrenceCapacity, [ExamOccurrenceId])
|
|
-> (ExamOccurrenceId, ExamOccurrenceCapacity)
|
|
-> (ExamOccurrenceCapacity, [ExamOccurrenceId])
|
|
accF (accSize, accIgnored) (occId, occSize)
|
|
| accSize >= Restricted usersCount
|
|
= (accSize, occId:accIgnored)
|
|
| otherwise
|
|
= (accSize <> occSize, accIgnored)
|
|
|
|
examAutoOccurrenceNudgeForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm
|
|
examAutoOccurrenceNudgeForm occId protoForm html = do
|
|
cID <- encrypt occId
|
|
(btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceNudge $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceNudgeUp, BtnExamAutoOccurrenceNudgeDown]) html
|
|
oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField
|
|
oldDataId <- newIdent
|
|
|
|
let protoForm' = fromMaybe def $ protoForm <|> oldDataRes
|
|
genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n
|
|
where n = case btn of
|
|
BtnExamAutoOccurrenceNudgeUp -> 1
|
|
BtnExamAutoOccurrenceNudgeDown -> -1
|
|
_other -> 0
|
|
res = genForm <$> btnRes
|
|
oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False
|
|
return (res, wgt <> oldDataView)
|
|
|
|
examAutoOccurrenceIgnoreRoomsForm :: ExamOccurrenceId
|
|
-> Maybe ExamAutoOccurrenceCalculateForm
|
|
-> Maybe ExamAutoOccurrenceCalculateForm
|
|
-> Form ExamAutoOccurrenceCalculateForm
|
|
examAutoOccurrenceIgnoreRoomsForm occId calculateRes protoForm html = do
|
|
cID <- encrypt occId
|
|
oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField
|
|
oldDataId <- newIdent
|
|
|
|
-- create both buttons
|
|
(btnResIgnore, wgtIgnore) <- identifyForm (FIDExamAutoOccurrenceIgnoreRoom $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceIgnore]) html
|
|
(btnResReconsider, wgtReconsider) <- identifyForm (FIDExamAutoOccurrenceIgnoreRoom $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceReconsider]) html
|
|
|
|
-- choose the relevant button to display
|
|
let btnRes = btnResIgnore <|> btnResReconsider
|
|
wgt = case btnRes of
|
|
(FormSuccess BtnExamAutoOccurrenceIgnore) -> wgtReconsider
|
|
(FormSuccess BtnExamAutoOccurrenceReconsider) -> wgtIgnore
|
|
_otherwise -> case eaocIgnoreRooms . eaofConfig $ fromMaybe def $ calculateRes <|> oldDataRes of
|
|
ExamAutoOccurrenceIgnoreRooms {eaoirIgnored}
|
|
| Set.member occId eaoirIgnored
|
|
-> wgtReconsider
|
|
| otherwise
|
|
-> wgtIgnore
|
|
|
|
|
|
let protoForm' = fromMaybe def $ calculateRes <|> protoForm <|> oldDataRes
|
|
genForm btn = protoForm' & _eaofConfig . _eaocIgnoreRooms . _eaoirIgnored %~ action occId
|
|
where
|
|
action = case btn of
|
|
BtnExamAutoOccurrenceIgnore -> Set.insert
|
|
BtnExamAutoOccurrenceReconsider -> Set.delete
|
|
_other -> flip const -- i.e. ignore argument
|
|
res = genForm <$> btnRes
|
|
oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False
|
|
return (res, wgt <> oldDataView)
|
|
|
|
examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm
|
|
examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do
|
|
(confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData
|
|
let fs :: FieldSettings UniWorX
|
|
fs = (if maybe False eaofSuccess confirmData then id else set _fsAttrs [("disabled", "")]) ""
|
|
(acceptRes, acceptView) <- buttonForm'' [BtnExamAutoOccurrenceAccept] fs mempty
|
|
return (acceptRes *> confirmDataRes, toWidget html <> fvWidget confirmDataView <> acceptView)
|
|
|
|
|
|
examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget
|
|
examAutoOccurrenceCalculateWidget tid ssh csh examn = do
|
|
(formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm Map.empty Map.empty def
|
|
|
|
wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def
|
|
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
|
|
, formEncoding
|
|
}
|
|
|
|
|
|
postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
|
|
postEAutoOccurrenceR tid ssh csh examn = do
|
|
(Entity eId Exam{ examOccurrenceRule }, occurrences, participants) <- runDB $ do
|
|
exam@(Entity eId _) <- fetchExam tid ssh csh examn
|
|
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ]
|
|
participants <- E.select . E.from $ \(registration `E.InnerJoin` user) -> do
|
|
E.on $ registration E.^. ExamRegistrationUser E.==. user E.^. UserId
|
|
E.where_ $ registration E.^. ExamRegistrationExam E.==. E.val eId
|
|
return (user, registration)
|
|
return (exam, occurrences, participants)
|
|
|
|
|
|
let participants' = Map.fromList $ do
|
|
(Entity uid userRec, Entity _ ExamRegistration{..}) <- participants
|
|
return (uid, (userRec, examRegistrationOccurrence))
|
|
occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, _examOccurrenceCapacityIso # (fromIntegral <$> examOccurrenceCapacity))) occurrences
|
|
((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm occurrences' participants' def
|
|
|
|
|
|
(nudgeRes, ignoreRes) <- mdo
|
|
nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->
|
|
runFormPost $ examAutoOccurrenceNudgeForm occId (formResult' . asum $ nudgeRes ^.. ifolded . ifiltered (\occId' _ -> occId' /= occId) . _1 . _1 ++ ignoreRes ^.. folded . _1 . _1)
|
|
ignoreRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->
|
|
runFormPost $ examAutoOccurrenceIgnoreRoomsForm occId (formResult' calculateRes) (formResult' . asum $ nudgeRes ^.. folded . _1 . _1 ++ ignoreRes ^.. ifolded . ifiltered (\occId' _ -> occId' /= occId) . _1 . _1)
|
|
return (nudgeRes, ignoreRes)
|
|
|
|
|
|
let calculateRes' = asum $ calculateRes : nudgeRes ^.. folded . _1 . _1 ++ ignoreRes ^.. folded . _1 . _1
|
|
|
|
calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> do
|
|
let autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
|
|
(eaofMapping, eaofAssignment, eaofSuccess) <- case autoOccurrenceResult of
|
|
(Left e) -> do
|
|
addMessageI Error e
|
|
pure ( ExamOccurrenceMapping {
|
|
examOccurrenceMappingRule = examOccurrenceRule,
|
|
examOccurrenceMappingMapping = Map.empty
|
|
}
|
|
, Map.map (view _2) participants'
|
|
, False
|
|
)
|
|
(Right res) -> pure $ uncurry (,,True) res
|
|
return $ Just ExamAutoOccurrenceAcceptForm{..}
|
|
|
|
((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult
|
|
let confirmWidget = wrapForm confirmView def
|
|
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
|
|
, formEncoding = confirmEncoding
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
|
|
formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do
|
|
Sum assignedCount <- runDB $ do
|
|
let eaofMapping'' :: Maybe (ExamOccurrenceMapping ExamOccurrenceName)
|
|
eaofMapping'' = ($ eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of
|
|
[Entity _ ExamOccurrence{..}] -> Just examOccurrenceName
|
|
_other -> Nothing
|
|
eaofMapping' <- case eaofMapping'' of
|
|
Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight]
|
|
Just x -> return $ Just x
|
|
update eId [ ExamExamOccurrenceMapping =. eaofMapping' ]
|
|
fmap fold . iforM eaofAssignment $ \pid occ -> case occ of
|
|
Just _ -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ]
|
|
Nothing -> return mempty
|
|
addMessageI Success $ MsgExamAutoOccurrenceParticipantsAssigned assignedCount
|
|
redirect $ CExamR tid ssh csh examn EUsersR
|
|
|
|
let nudgeWgt = nudgeRes <&> \((_, nudgeView), nudgeEncoding) ->
|
|
wrapForm nudgeView def
|
|
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
|
|
, formEncoding = nudgeEncoding
|
|
, formSubmit = FormNoSubmit
|
|
, formAttrs = [("class", "buttongroup")]
|
|
}
|
|
|
|
let ignoreRoomWgt = ignoreRes <&> \((_, ignoreRoomsView), ignoreRoomsEncoding) ->
|
|
wrapForm ignoreRoomsView def
|
|
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
|
|
, formEncoding = ignoreRoomsEncoding
|
|
, formSubmit = FormNoSubmit
|
|
, formAttrs = [("class", "buttongroup")]
|
|
}
|
|
isIgnored :: ExamOccurrenceId -> Bool
|
|
isIgnored occId = maybe False (Set.member occId) $ formResult' calculateRes' ^? _Just . _eaofConfig . _eaocIgnoreRooms . _eaoirIgnored
|
|
|
|
ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult
|
|
|
|
let heading = MsgTitleExamAutoOccurrence tid ssh csh examn
|
|
mappingWgt
|
|
= let occLoads :: Map ExamOccurrenceId Natural
|
|
occLoads = Map.fromListWith (+) . mapMaybe (\(_, mOcc) -> (, 1) <$> mOcc) $ Map.toList eaofAssignment
|
|
|
|
occLoad = fromMaybe 0 . flip Map.lookup occLoads
|
|
|
|
occMappingRule = examOccurrenceMappingRule eaofMapping
|
|
|
|
loadProp curr max'
|
|
| Just max'' <- assertM (/= 0) max'
|
|
= MsgProportion (toMessage curr) (toMessage max'') (toRational curr / toRational max'')
|
|
| otherwise
|
|
= MsgProportionNoRatio (toMessage curr) $ maybe "∞" toMessage max'
|
|
|
|
occMapping occId = examOccurrenceMappingDescriptionWidget occMappingRule <$> Map.lookup occId (examOccurrenceMappingMapping eaofMapping)
|
|
in $(widgetFile "widgets/exam-occurrence-mapping")
|
|
|
|
siteLayoutMsg heading $ do
|
|
setTitleI heading
|
|
$(widgetFile "exam/auto-occurrence-confirm")
|