221 lines
11 KiB
Haskell
221 lines
11 KiB
Haskell
{-# 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 = EAOIRManual Set.empty
|
|
ignoreRooms :: ExamAutoOccurrenceIgnoreRooms -> Bool
|
|
ignoreRooms EAOIRAutomatic = True
|
|
ignoreRooms (EAOIRManual s) = null s
|
|
|
|
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
|
|
-- TODO new constructor instead of FIDExamAutoOccurrenceNudge
|
|
-- type FormIdentifier, lives in Utils.Form
|
|
(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 %~ EAOIRManual . action occId . toManualSet
|
|
where
|
|
toManualSet EAOIRAutomatic = Set.empty
|
|
toManualSet (EAOIRManual s) = s
|
|
action = case btn of
|
|
BtnExamAutoOccurrenceIgnoreEnable -> Set.insert
|
|
BtnExamAutoOccurrenceIgnoreDisable -> 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
|
|
(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")
|