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.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)

  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

  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
        | [_] <- 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
        = 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 MsgMenuAllocationAccept $ do
    setTitleI MsgMenuAllocationAccept

    wrapForm' BtnAllocationAccept acceptView def
      { formEncoding = acceptEnctype
      }