167 lines
7.9 KiB
Haskell
167 lines
7.9 KiB
Haskell
module Handler.Allocation.Accept
|
|
( SessionDataAllocationResults(..)
|
|
, AllocationAcceptButton(..)
|
|
, allocationAcceptForm
|
|
, getAAcceptR, postAAcceptR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Utils.Allocation
|
|
|
|
import Data.Ratio ((%))
|
|
import Data.Map ((!?))
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
import Data.Sequence (Seq((:|>)))
|
|
|
|
|
|
newtype SessionDataAllocationResults = SessionDataAllocationResults
|
|
{ getSessionDataAllocationResults :: Map ( TermId
|
|
, SchoolId
|
|
, AllocationShorthand
|
|
)
|
|
( UTCTime
|
|
, AllocationFingerprint
|
|
, Set CourseId
|
|
, Set (UserId, CourseId)
|
|
, Seq MatchingLogRun
|
|
)
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving newtype (ToJSON, FromJSON)
|
|
deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set CourseId, Set (UserId, CourseId), Seq MatchingLogRun))
|
|
|
|
makeWrapped ''SessionDataAllocationResults
|
|
|
|
|
|
data AllocationAcceptButton
|
|
= BtnAllocationAccept
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
nullaryPathPiece ''AllocationAcceptButton $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''AllocationAcceptButton id
|
|
|
|
instance Button UniWorX AllocationAcceptButton where
|
|
btnClasses BtnAllocationAccept = [BCIsButton, BCPrimary]
|
|
|
|
|
|
allocationAcceptForm :: AllocationId -> DB (Maybe (Form (UTCTime, AllocationFingerprint, Set CourseId, Set (UserId, CourseId), Seq MatchingLogRun)))
|
|
allocationAcceptForm aId = runMaybeT $ do
|
|
Allocation{..} <- MaybeT $ get aId
|
|
SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
|
|
allocRes@(allocTime, allocFp, eligibleCourses, allocMatching, _ :|> MatchingLogRun{..}) <- hoistMaybe $ allocMap !? (allocationTerm, allocationSchool, allocationShorthand)
|
|
|
|
allocationUsers <- fmap (map $ bimap E.unValue E.unValue) . lift . E.select . E.from $ \allocationUser -> do
|
|
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
|
|
E.&&. E.not_ (E.isNothing $ allocationUser E.^. AllocationUserPriority)
|
|
let applications = E.subSelectCount . E.from $ \courseApplication ->
|
|
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
|
|
E.&&. courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
|
|
return . (allocationUser E.^. AllocationUserUser, ) $ E.case_
|
|
[ E.when_ (E.castNum (allocationUser E.^. AllocationUserTotalCourses) E.>. applications)
|
|
E.then_ (applications :: E.SqlExpr (E.Value Int))
|
|
]
|
|
(E.else_ . E.castNum $ allocationUser E.^. AllocationUserTotalCourses)
|
|
let allocationPlacesRequested = sumOf (folded . _2) allocationUsers
|
|
userAllocations = ofoldr (\(uid, _cid) -> Map.insertWith (+) uid 1) Map.empty allocMatching
|
|
|
|
allocationUsers' <- hoistMaybe $
|
|
let (res, leftoverAllocs) = foldr (\user@(uid, _) (acc, allocCounts)
|
|
-> ( (user, Map.findWithDefault 0 uid allocCounts) : acc
|
|
, Map.delete uid allocCounts
|
|
))
|
|
([] , userAllocations) allocationUsers
|
|
in guardOn (null leftoverAllocs) res :: Maybe [((UserId, Int), Integer)]
|
|
|
|
let unmatchedUsers = olength $ filter ((<= 0) . view _2) allocationUsers'
|
|
|
|
allocationCourses <- fmap (map $ over _3 E.unValue) . lift . E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do
|
|
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
|
|
let participants = E.subSelectCount . E.from $ \courseParticipant ->
|
|
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
return (allocationCourse, course, participants)
|
|
let allocationCapacity = sumOf (folded . _2 . _entityVal . _courseCapacity . _Just) allocationCourses
|
|
allocCourses = setOf (folded . _1 . _entityVal . _allocationCourseCourse) allocationCourses
|
|
|
|
let courseAllocations = ofoldr (\(_uid, cid) -> Map.insertWith (+) cid 1) Map.empty allocMatching
|
|
allocationCourses' <- hoistMaybe $
|
|
let (res, leftoverAllocs) = foldr (\course@(_, Entity cid _, _) (acc, allocCounts)
|
|
-> ( (course, Map.findWithDefault 0 cid allocCounts) : acc
|
|
, Map.delete cid allocCounts
|
|
))
|
|
([] , courseAllocations) allocationCourses
|
|
in guardOn (null leftoverAllocs) res :: Maybe [((Entity AllocationCourse, Entity Course, Int), Int)]
|
|
|
|
let unmatchedCourses = olength $ filter ((<= 0) . view _2) allocationCourses'
|
|
|
|
let validateMatches =
|
|
guardValidation MsgAllocationAcceptFormDoesNotMatchSession =<< State.get
|
|
|
|
return . set (mapped . mapped . _1 . mapped) allocRes . validateForm validateMatches . identifyForm FIDAllocationAccept $ \csrf -> do
|
|
(prevAllocRes, prevAllocView) <- mreq hiddenField "" $ Just allocFp
|
|
let prevAllocMatches = (== allocFp) <$> prevAllocRes
|
|
|
|
let
|
|
showTerms
|
|
| [_] <- nubOrdOn (view $ _1 . _2 . _entityVal . _courseTerm) allocationCourses'
|
|
= False
|
|
| otherwise
|
|
= True
|
|
showSchools
|
|
| [_] <- nubOrdOn (view $ _1 . _2 . _entityVal . _courseSchool) allocationCourses'
|
|
= False
|
|
| otherwise
|
|
= True
|
|
optimumAllocated = round . (* optimumProportion) . fromIntegral
|
|
where optimumProportion :: Rational
|
|
optimumProportion
|
|
| allocationCapacity > 0 = fromIntegral allocationPlacesRequested % fromIntegral allocationCapacity
|
|
| otherwise = 0
|
|
allocHeat capN
|
|
= invDualHeat (optimumAllocated capN) capN
|
|
degenerateHeat capN
|
|
= capN <= optimumAllocated capN
|
|
|
|
return (prevAllocMatches, $(widgetFile "allocation/accept"))
|
|
|
|
getAAcceptR, postAAcceptR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
|
getAAcceptR = postAAcceptR
|
|
postAAcceptR tid ssh ash = do
|
|
(((_, acceptView), acceptEnctype), didStore) <- runDB $ do
|
|
aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
|
|
acceptForm <- maybe (redirect $ AllocationR tid ssh ash AComputeR) return =<< allocationAcceptForm aId
|
|
|
|
formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm
|
|
|
|
didStore <- formResultMaybe acceptRes $ \(now, allocFp, _, allocMatchings, allocLog) -> do
|
|
modifySessionJson SessionAllocationResults . fmap (assertM $ not . views _Wrapped onull) . over (mapped . _Wrapped :: Setter' (Maybe SessionDataAllocationResults) _) $
|
|
Map.filterWithKey (\(tid', ssh', ash') (_, allocFp', _, _, _) ->
|
|
or [ tid' /= tid
|
|
, ssh' /= ssh
|
|
, ash' /= ash
|
|
, allocFp' /= allocFp
|
|
])
|
|
storeAllocationResult aId now (allocFp, allocMatchings, allocLog)
|
|
return $ Just ()
|
|
|
|
return (formRes, is _Just didStore)
|
|
|
|
when didStore $ do
|
|
addMessageI Success MsgAllocationAccepted
|
|
redirect $ AllocationR tid ssh ash AUsersR
|
|
|
|
siteLayoutMsg MsgHeadingAllocationAccept $ do
|
|
setTitleI MsgHeadingAllocationAccept
|
|
|
|
wrapForm' BtnAllocationAccept acceptView def
|
|
{ formEncoding = acceptEnctype
|
|
}
|