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


restrictCourses :: (MonadHandler m, HandlerSite m ~ UniWorX) => AllocationId -> AForm m (Maybe (Set CourseId))
restrictCourses aId = hoistAForm liftHandler $
  optionalActionA selectCourses (fslI MsgAllocationRestrictCourses & setTooltip MsgAllocationRestrictCoursesTip) (Just False)
  where
    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, allocMatching, allocLog) <- computeAllocation aId acfRestrictCourses
      tellSessionJson SessionAllocationResults . SessionDataAllocationResults $
        Map.singleton (tid, ssh, ash) (now, allocFp, 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
      }