-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Wolfgang Witt -- -- 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")