{-# 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 as E import Database.Persist.Sql (updateWhereCount) newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm { eaofConfig :: ExamAutoOccurrenceConfig } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (Default, FromJSON, ToJSON) makeLenses_ ''ExamAutoOccurrenceCalculateForm data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm { eaofMapping :: ExamOccurrenceMapping ExamOccurrenceId , eaofAssignment :: Map UserId (Maybe ExamOccurrenceId) } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''ExamAutoOccurrenceAcceptForm data ExamAutoOccurrenceButton = BtnExamAutoOccurrenceCalculate | BtnExamAutoOccurrenceAccept | BtnExamAutoOccurrenceNudgeUp | BtnExamAutoOccurrenceNudgeDown | BtnExamAutoOccurrenceIgnoreEnable | BtnExamAutoOccurrenceIgnoreDisable deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamAutoOccurrenceButton instance Finite ExamAutoOccurrenceButton nullaryPathPiece ''ExamAutoOccurrenceButton $ camelToPathPiece' 4 embedRenderMessage ''UniWorX ''ExamAutoOccurrenceButton id instance Button UniWorX ExamAutoOccurrenceButton where btnClasses BtnExamAutoOccurrenceNudgeUp = [BCIsButton] btnClasses BtnExamAutoOccurrenceNudgeDown = [BCIsButton] btnClasses _ = [BCIsButton, BCPrimary] examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig } = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm where eaocForm = (set _eaocIgnoreRooms . automaticIfTrue <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just . ignoreRooms $ eaofConfig ^. _eaocIgnoreRooms)) <*> pure def automaticIfTrue :: Bool -> ExamAutoOccurrenceIgnoreRooms automaticIfTrue True = EAOIRAutomatic automaticIfTrue False = def ignoreRooms :: ExamAutoOccurrenceIgnoreRooms -> Bool ignoreRooms EAOIRAutomatic = True ignoreRooms EAOIRManual {eaoirmSorted} = eaoirmSorted 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 $ oldDataRes <|> protoForm 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 -> Form ExamAutoOccurrenceCalculateForm examAutoOccurrenceIgnoreRoomsForm occId protoForm html = do cID <- encrypt occId (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceIgnoreRooms $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceIgnoreEnable, BtnExamAutoOccurrenceIgnoreDisable]) html oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField oldDataId <- newIdent let protoForm' = fromMaybe def $ oldDataRes <|> protoForm genForm btn = protoForm' & _eaofConfig . _eaocIgnoreRooms %~ action where action EAOIRAutomatic = EAOIRManual {eaoirmIgnored=Set.empty, eaoirmSorted=True} action ir@EAOIRManual {eaoirmIgnored, eaoirmSorted} = case btn of BtnExamAutoOccurrenceIgnoreEnable -> EAOIRManual {eaoirmIgnored=Set.insert occId eaoirmIgnored, eaoirmSorted} BtnExamAutoOccurrenceIgnoreDisable -> EAOIRManual {eaoirmIgnored=Set.delete occId eaoirmIgnored, eaoirmSorted} _other -> ir 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 (acceptRes, acceptView) <- buttonForm' [BtnExamAutoOccurrenceAccept] 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 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) <- runDB $ do exam@(Entity eId _) <- fetchExam tid ssh csh examn occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ] return (exam, occurrences) ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId -> runFormPost $ examAutoOccurrenceNudgeForm occId (formResult' calculateRes) ignoreRoomsRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId -> runFormPost $ examAutoOccurrenceIgnoreRoomsForm occId (formResult' calculateRes) let calculateRes' = asum $ calculateRes : nudgeRes ^.. folded . _1 . _1 ++ ignoreRoomsRes ^.. folded . _1 . _1 calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do 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) 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 autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants' (eaofMapping, eaofAssignment, _ignoredOccurrences) <- case autoOccurrenceResult of (Left e) -> do addMessageI Error e redirect $ CExamR tid ssh csh examn EUsersR (Right r) -> pure r -- TODO use returned ignoredOccurrences 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 = ignoreRoomsRes <&> \((_, ignoreRoomsView), ignoreRoomsEncoding) -> wrapForm ignoreRoomsView def { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR , formEncoding = ignoreRoomsEncoding , formSubmit = FormNoSubmit , formAttrs = [("class", "buttongroup")] } 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")