module Handler.Allocation.Prios
  ( getAPriosR, postAPriosR
  ) where

import Import

import Handler.Utils
import Handler.Utils.Csv
import Handler.Utils.Allocation

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

import qualified Data.Conduit.List as C

import qualified Data.Csv as Csv


data AllocationPrioritiesMode
  = AllocationPrioritiesNumeric
  | AllocationPrioritiesOrdinal
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe AllocationPrioritiesMode
instance Finite AllocationPrioritiesMode

nullaryPathPiece ''AllocationPrioritiesMode $ camelToPathPiece' 2

embedRenderMessage ''UniWorX ''AllocationPrioritiesMode id


getAPriosR, postAPriosR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAPriosR = postAPriosR
postAPriosR tid ssh ash = do
  doNumericPrios <- runDB $ do
    Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash

    numericPrios <- E.selectCountRows . E.from $ \allocationUser -> do
      E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
      E.where_ . E.maybe E.false sqlAllocationPriorityNumeric $ allocationUser E.^. AllocationUserPriority

    ordinalPrios <- E.selectCountRows . E.from $ \allocationUser -> do
      E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
      E.where_ . E.maybe E.false (E.not_ . sqlAllocationPriorityNumeric) $ allocationUser E.^. AllocationUserPriority
    let doNumericPrios = ((>=) :: Int64 -> Int64 -> Bool) numericPrios ordinalPrios

    return doNumericPrios

  let explainAllocationPrioMode = \case
        AllocationPrioritiesNumeric -> return $(i18nWidgetFile "allocation-priority-explanation/numeric")
        AllocationPrioritiesOrdinal -> return $(i18nWidgetFile "allocation-priority-explanation/ordinal")

  ignoreWarningMsg <- messageIconI Warning IconMissingAllocationPriority MsgAllocationMissingPrioritiesIgnored
  ((priosRes, priosView), priosEnctype) <- runFormPost . renderAForm FormStandard $ (,)
    <$> apopt (explainedSelectionField Nothing (explainOptionList optionsFinite explainAllocationPrioMode)) (fslI MsgAllocationPrioritiesMode) (Just $ bool AllocationPrioritiesOrdinal AllocationPrioritiesNumeric doNumericPrios)
    <*  aformMessage ignoreWarningMsg
    <*> areq fileField (fslI MsgAllocationPrioritiesFile) Nothing

  formResult priosRes $ \(mode, fInfo) -> do
    let sourcePrios = case mode of
          AllocationPrioritiesNumeric -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader
          AllocationPrioritiesOrdinal -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader .| C.map Csv.fromOnly .| ordinalPriorities

    (matrSunk, matrMissing) <- runDB $ do
      Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
      updateWhere
        [ AllocationUserAllocation ==. aId ]
        [ AllocationUserPriority =. Nothing ]
      matrSunk <- runConduit $ sourcePrios .| sinkAllocationPriorities aId
      matrMissing <- E.selectCountRows . E.from $ \allocationUser -> do
        E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
             E.&&. E.isNothing (allocationUser E.^. AllocationUserPriority)

        E.where_ . E.exists . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do
          E.on $ allocationCourse E.^. AllocationCourseCourse E.==. courseApplication E.^. CourseApplicationCourse
           E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationCourse E.^. AllocationCourseAllocation)
          E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
               E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
      return (matrSunk, matrMissing)

    when (matrSunk > 0) $
      addMessageI Success $ MsgAllocationPrioritiesSunk matrSunk
    when (matrMissing > 0) $
      addMessageI Error $ MsgAllocationPrioritiesMissing matrMissing
    redirect $ AllocationR tid ssh ash AUsersR

  siteLayoutMsg MsgMenuAllocationPriorities $ do
    setTitleI $ MsgAllocationPrioritiesTitle tid ssh ash

    let priosForm = wrapForm priosView def
          { formEncoding = priosEnctype
          , formAction = Just . SomeRoute $ AllocationR tid ssh ash APriosR
          }
    gradeScale <- getsYesod $ view _appAllocationGradeScale
    gradeOrdinalProportion <- getsYesod $ view _appAllocationGradeOrdinalProportion

    $(i18nWidgetFile "allocation-priorities")