{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Handler.Allocation.Users
  ( getAUsersR, postAUsersR
  ) where

import Import

import Handler.Utils
import Handler.Utils.Allocation

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

import qualified Data.Csv as Csv


type UserTableExpr = E.SqlExpr (Entity User)
       `E.InnerJoin` E.SqlExpr (Entity AllocationUser)

queryUser :: Getter UserTableExpr (E.SqlExpr (Entity User))
queryUser = to $(E.sqlIJproj 2 1)

queryAllocationUser :: Getter UserTableExpr (E.SqlExpr (Entity AllocationUser))
queryAllocationUser = to $(E.sqlIJproj 2 2)

queryAppliedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int))
queryAppliedCourses = queryAllocationUser . to queryAppliedCourses'
  where queryAppliedCourses' allocationUser = E.subSelectCount . E.from $ \courseApplication ->
          E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
               E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationUser E.^. AllocationUserAllocation)

queryAssignedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int))
queryAssignedCourses = queryAllocationUser . to queryAssignedCourses'
  where queryAssignedCourses' allocationUser = E.subSelectCount . E.from $ \courseParticipant ->
          E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. allocationUser E.^. AllocationUserUser
               E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.just (allocationUser E.^. AllocationUserAllocation)

queryVetoedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int))
queryVetoedCourses = queryAllocationUser . to queryVetoedCourses'
  where queryVetoedCourses' allocationUser = E.subSelectCount . E.from $ \courseApplication -> do
          E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
               E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationUser E.^. AllocationUserAllocation)
          E.where_ $ courseApplication E.^. CourseApplicationRatingVeto
               E.||. courseApplication E.^. CourseApplicationRatingPoints `E.in_` E.valList (map Just $ filter (view $ passingGrade . _Wrapped . to not) universeF)


type UserTableData = DBRow ( Entity User
                           , Entity AllocationUser
                           , Int -- ^ Applied
                           , Int -- ^ Assigned
                           , Int -- ^ Vetoed
                           )                          

resultUser :: Lens' UserTableData (Entity User)
resultUser = _dbrOutput . _1
  
resultAllocationUser :: Lens' UserTableData (Entity AllocationUser)
resultAllocationUser = _dbrOutput . _2

resultAppliedCourses, resultAssignedCourses, resultVetoedCourses :: Lens' UserTableData Int
resultAppliedCourses  = _dbrOutput . _3
resultAssignedCourses = _dbrOutput . _4
resultVetoedCourses = _dbrOutput . _5


data AllocationUserTableCsv = AllocationUserTableCsv
  { csvAUserSurname       :: Text
  , csvAUserFirstName     :: Text
  , csvAUserName          :: Text
  , csvAUserMatriculation :: Maybe Text
  , csvAUserRequested
  , csvAUserApplied   
  , csvAUserVetos
  , csvAUserAssigned      :: Natural
  , csvAUserPriority      :: Maybe AllocationPriority
  } deriving (Generic)
makeLenses_ ''AllocationUserTableCsv

allocationUserTableCsvOptions :: Csv.Options
allocationUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3}

instance Csv.ToNamedRecord AllocationUserTableCsv where
  toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions 

instance Csv.DefaultOrdered AllocationUserTableCsv where
  headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions 

instance CsvColumnsExplained AllocationUserTableCsv where
  csvColumnsExplanations = genericCsvColumnsExplanations allocationUserTableCsvOptions $ mconcat
    [ singletonMap 'csvAUserSurname       MsgCsvColumnAllocationUserSurname
    , singletonMap 'csvAUserFirstName     MsgCsvColumnAllocationUserFirstName
    , singletonMap 'csvAUserName          MsgCsvColumnAllocationUserName
    , singletonMap 'csvAUserMatriculation MsgCsvColumnAllocationUserMatriculation
    , singletonMap 'csvAUserRequested     MsgCsvColumnAllocationUserRequested
    , singletonMap 'csvAUserApplied       MsgCsvColumnAllocationUserApplied
    , singletonMap 'csvAUserVetos         MsgCsvColumnAllocationUserVetos
    , singletonMap 'csvAUserAssigned      MsgCsvColumnAllocationUserAssigned
    , singletonMap 'csvAUserPriority      MsgCsvColumnAllocationUserPriority
    ]


getAUsersR, postAUsersR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAUsersR = postAUsersR
postAUsersR tid ssh ash = do
  usersTable <- runDB $ do
    Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
    now <- liftIO getCurrentTime
    resultsDone <- (<= NTop (Just now)) . NTop <$> allocationDone aId

    csvName <- getMessageRender <*> pure (MsgAllocationUsersCsvName tid ssh ash)

    let
      allocationUsersDBTable = DBTable{..}
        where
          dbtSQLQuery = runReaderT $ do
            user           <- view queryUser
            allocationUser <- view queryAllocationUser
            applied        <- view queryAppliedCourses
            assigned       <- view queryAssignedCourses
            vetoed         <- view queryVetoedCourses

            lift $ do
              E.on $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser
               E.&&. allocationUser E.^. AllocationUserAllocation E.==. E.val aId
              E.where_ $ applied E.>. E.val 0
                   E.||. assigned E.>. E.val 0

            return ( user
                   , allocationUser
                   , applied
                   , assigned
                   , vetoed)
          dbtRowKey = views queryAllocationUser (E.^. AllocationUserId)
          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
            (,,,,)
              <$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
          dbtColonnade :: Colonnade Sortable _ _
          dbtColonnade = mconcat
            [ colUserDisplayName $ resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname
            , colUserMatriculation $ resultUser . _entityVal . _userMatrikelnummer
            , colAllocationRequested $ resultAllocationUser . _entityVal . _allocationUserTotalCourses
            , coursesModalApplied $ colAllocationApplied resultAppliedCourses
            , coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
            , coursesModalAssigned . assignedHeated $ colAllocationAssigned resultAssignedCourses
            , emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
            ]
            where
              emptyPriorityCell = addCellClass ("table__td--center" :: Text) . cell $
                messageTooltip =<< messageIconI Error IconMissingAllocationPriority MsgAllocationMissingPrioritiesIgnored
              assignedHeated
                | resultsDone = imapColonnade assignedHeated'
                | otherwise   = id
                where
                  assignedHeated' res
                    = let maxAssign = min (res ^. resultAllocationUser . _entityVal . _allocationUserTotalCourses . to fromIntegral)
                                          (res ^. resultAppliedCourses)
                          assigned = maxAssign - res ^. resultAssignedCourses
                       in cellAttrs <>~ [ ("class", "heated")
                                        , ("style", [st|--hotness: #{tshow (heat maxAssign assigned)}|])
                                        ]
              coursesModalApplied = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseApplication) -> do
                E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
                E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
                     E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val (res ^. resultUser . _entityKey)
                E.orderBy [E.desc $ courseApplication E.^. CourseApplicationAllocationPriority]
                return course
              coursesModalVetoed = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseApplication) -> do
                E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
                E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
                     E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val (res ^. resultUser . _entityKey)
                E.where_ $ courseApplication E.^. CourseApplicationRatingVeto
                     E.||. courseApplication E.^. CourseApplicationRatingPoints `E.in_` E.valList (map Just $ filter (view $ passingGrade . _Wrapped . to not) universeF)
                return course
              coursesModalAssigned = coursesModal $ \res -> E.from $ \(course `E.InnerJoin` courseParticipant) -> do
                E.on $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
                 E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.val (Just aId)
                E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val (res ^. resultUser . _entityKey)
                E.orderBy [E.asc $ courseParticipant E.^. CourseParticipantRegistration]
                return course
              coursesModal courseSel = imapColonnade coursesModal'
                where
                  coursesModal' res innerCell = review dbCell . (innerCell ^. cellAttrs, ) $ do
                    courses <- lift . E.select $ courseSel res
                    contents <- innerCell ^. cellContents
                    return $ if
                      | null courses -> contents
                      | otherwise    -> $(widgetFile "table/cell/allocation-courses")
          dbtSorting = mconcat
            [ sortUserName' $ queryUser . $(multifocusG 2) (to (E.^. UserDisplayName)) (to (E.^. UserSurname))
            , sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
            , sortAllocationApplied queryAppliedCourses
            , sortAllocationAssigned queryAssignedCourses
            , sortAllocationRequested $ queryAllocationUser . to (E.^. AllocationUserTotalCourses)
            , sortAllocationVetoed queryVetoedCourses
            , sortAllocationPriority $ queryAllocationUser . to (E.^. AllocationUserPriority)
            ]
          dbtFilter = mconcat
            [ fltrUserName' $ queryUser . to (E.^. UserDisplayName)
            , fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
            ]
          dbtFilterUI = mconcat
            [ fltrUserNameUI'
            , fltrUserMatriculationUI
            ]
          dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
          dbtParams = def
          dbtIdent :: Text
          dbtIdent = "allocation-users"
          dbtCsvEncode = simpleCsvEncode csvName $ AllocationUserTableCsv
            <$> view (resultUser . _entityVal . _userSurname)
            <*> view (resultUser . _entityVal . _userFirstName)
            <*> view (resultUser . _entityVal . _userDisplayName)
            <*> view (resultUser . _entityVal . _userMatrikelnummer)
            <*> view (resultAllocationUser . _entityVal . _allocationUserTotalCourses)
            <*> view (resultAppliedCourses . to fromIntegral)
            <*> view (resultVetoedCourses . to fromIntegral)
            <*> view (resultAssignedCourses . to fromIntegral)
            <*> view (resultAllocationUser . _entityVal . _allocationUserPriority)
          dbtCsvDecode = Nothing
      allocationUsersDBTableValidator = def
        & defaultSorting [SortAscBy "priority", SortAscBy "user-matriculation"]
        & defaultPagesize PagesizeAll

    dbTableDB' allocationUsersDBTableValidator allocationUsersDBTable

  siteLayoutMsg MsgMenuAllocationUsers $ do
    setTitleI $ MsgAllocationUsersTitle tid ssh ash

    usersTable