fradrive-old/src/Handler/Allocation/Accept.hs

module Handler.Allocation.Accept
  ( SessionDataAllocationResults(..)
  , AllocationAcceptButton(..)
  , allocationAcceptForm
  , getAAcceptR, postAAcceptR
  ) where

import Import
import Handler.Utils
import Handler.Utils.Allocation

import Data.Map ((!?))
import qualified Data.Map as Map

import qualified Database.Esqueleto as E
import qualified Control.Monad.State.Class as State

import Data.Semigroup (Dual(..))

import Data.Sequence (Seq((:|>)))


newtype SessionDataAllocationResults = SessionDataAllocationResults
  { getSessionDataAllocationResults :: Map ( TermId
                                           , SchoolId
                                           , AllocationShorthand
                                           )
                                           ( UTCTime
                                           , AllocationFingerprint
                                           , 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 (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 (UserId, CourseId), Seq MatchingLogRun)))
allocationAcceptForm aId = runMaybeT $ do
  Allocation{..} <- MaybeT $ get aId
  SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
  allocRes@(allocTime, allocFp, allocMatching, _ :|> MatchingLogRun{..}) <- hoistMaybe $ allocMap !? (allocationTerm, allocationSchool, allocationShorthand)
  $logInfoS "allocationAcceptForm" $ tshow allocRes

  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
    return (allocationCourse, course, participants)
  let allocationCapacity = sumOf (folded . _2 . _entityVal . _courseCapacity . _Just) 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), Integer)]

  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
        | [_] <- nubOn (view $ _1 . _2 . _entityVal . _courseTerm) allocationCourses'
        = False
        | otherwise
        = True
      showSchools
        | [_] <- nubOn (view $ _1 . _2 . _entityVal . _courseSchool) allocationCourses'
        = False
        | otherwise
        = True
      optimumAllocated = round . (* optimumProportion) . fromIntegral
        where optimumProportion :: Rational
              optimumProportion
                | allocationCapacity == 0 = 0
                | otherwise = fromIntegral allocationPlacesRequested % fromIntegral allocationCapacity
      allocHeat capN allocated
        | optimumAllocated capN >= capN
        = 2 - coHeat capN allocated * 2
        | otherwise
        = 2 - dualHeat (optimumAllocated capN) capN allocated
      
    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 MsgMenuAllocationAccept $ do
    setTitleI MsgMenuAllocationAccept

    wrapForm' BtnAllocationAccept acceptView def
      { formEncoding = acceptEnctype
      }