151 lines
6.6 KiB
Haskell
151 lines
6.6 KiB
Haskell
module Handler.Allocation.Compute
|
|
( getAComputeR
|
|
, postAComputeR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Allocation
|
|
import Handler.Allocation.Accept (SessionDataAllocationResults(..))
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
|
|
data AllocationComputeForm = AllocationComputeForm
|
|
{ acfMissingPrioritiesOk :: Set UserId
|
|
, acfRestrictCourses :: Maybe (Set CourseId)
|
|
}
|
|
|
|
data AllocationComputeButton
|
|
= BtnAllocationCompute
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''AllocationComputeButton $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''AllocationComputeButton id
|
|
|
|
instance Button UniWorX AllocationComputeButton where
|
|
btnClasses BtnAllocationCompute = [BCIsButton, BCPrimary]
|
|
|
|
missingPrioritiesUsers :: AllocationId -> DB (Map UserId User)
|
|
missingPrioritiesUsers aId = $cachedHereBinary aId $ do
|
|
usersWithoutPrio <- E.select . E.from $ \(user `E.InnerJoin` allocationUser) -> do
|
|
E.on $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser
|
|
E.&&. allocationUser E.^. AllocationUserAllocation E.==. E.val aId
|
|
|
|
-- Ignore users without applications
|
|
E.where_ . E.exists . E.from $ \courseApplication -> do
|
|
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
|
|
E.&&. courseApplication E.^. CourseApplicationUser E.==. user E.^. UserId
|
|
E.where_ . E.exists . E.from $ \allocationCourse ->
|
|
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
|
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
|
|
|
|
E.where_ . E.isNothing $ allocationUser E.^. AllocationUserPriority
|
|
|
|
return user
|
|
|
|
return $ toMapOf (folded .> _entityVal) usersWithoutPrio
|
|
|
|
missingPriorities :: AllocationId -> AForm DB (Set UserId)
|
|
missingPriorities aId = wFormToAForm $ do
|
|
usersWithoutPrio <- lift . lift $ missingPrioritiesUsers aId
|
|
|
|
let missingPriosField = checkBoxField { fieldView = missingPriosFieldView }
|
|
where
|
|
missingPriosFieldView theId name attrs res isReq
|
|
= $(i18nWidgetFile "allocation-confirm-missing-prios")
|
|
where checkBoxFieldView = labeledCheckBoxView (i18n MsgAllocationUsersMissingPrioritiesOk) theId name attrs res isReq
|
|
|
|
if
|
|
| null usersWithoutPrio
|
|
-> return $ pure Set.empty
|
|
| otherwise
|
|
-> fmap (bool Set.empty $ Map.keysSet usersWithoutPrio) <$> wpreq missingPriosField (fslI MsgAllocationUsersMissingPriorities & setTooltip MsgAllocationUsersMissingPrioritiesTip) (Just False)
|
|
|
|
|
|
data AllocationCourseRestrictionMode
|
|
= AllocationCourseRestrictionDontRestrict
|
|
| AllocationCourseRestrictionSubstitutes
|
|
| AllocationCourseRestrictionCustom
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
deriving anyclass (Universe, Finite)
|
|
nullaryPathPiece ''AllocationCourseRestrictionMode $ camelToPathPiece' 3
|
|
embedRenderMessage ''UniWorX ''AllocationCourseRestrictionMode id
|
|
|
|
restrictCourses :: (MonadHandler m, HandlerSite m ~ UniWorX) => AllocationId -> AForm m (Maybe (Set CourseId))
|
|
restrictCourses aId = hoistAForm liftHandler $ multiActionA restrictOpts (fslI MsgAllocationRestrictCourses & setTooltip MsgAllocationRestrictCoursesTip) (Just AllocationCourseRestrictionDontRestrict)
|
|
where
|
|
restrictOpts = mapF $ \case
|
|
AllocationCourseRestrictionDontRestrict -> pure Nothing
|
|
AllocationCourseRestrictionSubstitutes -> wFormToAForm $ do
|
|
now <- liftIO getCurrentTime
|
|
allocCourses <- fmap (setOf $ folded . _Value) . liftHandler . runDB . E.select . E.from $ \allocationCourse -> do
|
|
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
|
|
E.where_ . E.maybe E.false (E.>=. E.val now) $ allocationCourse E.^. AllocationCourseAcceptSubstitutes
|
|
return $ allocationCourse E.^. AllocationCourseCourse
|
|
return . pure $ Just allocCourses
|
|
AllocationCourseRestrictionCustom -> Just <$> selectCourses
|
|
selectCourses = courseSelectForm query coursePred miButtonAction' miIdent' fSettings fRequired mPrev
|
|
where
|
|
query = E.from $ \(course `E.InnerJoin` allocationCourse) -> do
|
|
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
|
|
return course
|
|
coursePred _ = return True
|
|
mPrev = Nothing
|
|
fRequired = True
|
|
fSettings = fslI MsgAllocationRestrictCoursesSelection & setTooltip MsgAllocationRestrictCoursesSelectionTip
|
|
miIdent' :: Text
|
|
miIdent' = "course-selection"
|
|
miButtonAction' _ = Nothing
|
|
|
|
allocationComputeForm :: AllocationId -> AForm DB AllocationComputeForm
|
|
allocationComputeForm aId = wFormToAForm $ do
|
|
onlyComputeMsg <- messageI Info MsgAllocationOnlyCompute
|
|
|
|
aFormToWForm $ AllocationComputeForm
|
|
<$ aformMessage onlyComputeMsg
|
|
<*> missingPriorities aId
|
|
<*> restrictCourses aId
|
|
|
|
validateAllocationComputeForm :: AllocationId -> FormValidator AllocationComputeForm DB ()
|
|
validateAllocationComputeForm aId = do
|
|
usersWithoutPrio <- lift $ missingPrioritiesUsers aId
|
|
|
|
missingOk <- State.gets acfMissingPrioritiesOk
|
|
guardValidation MsgAllocationUsersMissingPrioritiesNotOk $
|
|
Map.keysSet usersWithoutPrio `Set.isSubsetOf` missingOk
|
|
|
|
|
|
getAComputeR, postAComputeR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
|
getAComputeR = postAComputeR
|
|
postAComputeR tid ssh ash = do
|
|
(_, ((_computeFormRes, computeFormView), computeFormEnctype)) <- runDB $ do
|
|
aEnt@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
formRes@((computeFormRes, _), _) <- runFormPost . validateForm (validateAllocationComputeForm aId) . renderAForm FormStandard $ allocationComputeForm aId
|
|
|
|
formResult computeFormRes $ \AllocationComputeForm{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
(allocFp, eligibleCourses, allocMatching, allocLog) <- computeAllocation aEnt acfRestrictCourses
|
|
tellSessionJson SessionAllocationResults . SessionDataAllocationResults $
|
|
Map.singleton (tid, ssh, ash) (now, allocFp, eligibleCourses, allocMatching, allocLog)
|
|
addMessageI Success MsgAllocationComputed
|
|
redirect $ AllocationR tid ssh ash AUsersR -- Redirect aborts transaction for safety
|
|
|
|
return (aEnt, formRes)
|
|
|
|
siteLayoutMsg MsgMenuAllocationCompute $ do
|
|
setTitleI MsgMenuAllocationCompute
|
|
|
|
wrapForm' BtnAllocationCompute computeFormView def
|
|
{ formEncoding = computeFormEnctype
|
|
}
|