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

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

import Import

import Handler.Allocation.Accept

import Handler.Utils
import Handler.Utils.Allocation
import Handler.Utils.StudyFeatures

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

import qualified Data.Csv as Csv

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

import Text.Blaze (toMarkup)

import qualified Data.Conduit.Combinators as C


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.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 (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)
               E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive

queryVetoedCourses :: Getter UserTableExpr (E.SqlExpr (E.Value Int))
queryVetoedCourses = queryAllocationUser . to queryVetoedCourses'
  where queryVetoedCourses' allocationUser = E.subSelectCount . 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 (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
                           , UserTableStudyFeatures
                           , Entity AllocationUser
                           , Int -- ^ Applied
                           , Int -- ^ Assigned
                           , Int -- ^ Vetoed
                           )

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

resultStudyFeatures :: Lens' UserTableData UserTableStudyFeatures
resultStudyFeatures = _dbrOutput . _2

resultAllocationUser :: Lens' UserTableData (Entity AllocationUser)
resultAllocationUser = _dbrOutput . _3

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


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

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

instance Csv.ToNamedRecord AllocationUserTableCsv where
  toNamedRecord AllocationUserTableCsv{..} = Csv.namedRecord $
    [ "surname"        Csv..= csvAUserSurname
    , "first-name"     Csv..= csvAUserFirstName
    , "name"           Csv..= csvAUserName
    , "matriculation"  Csv..= csvAUserMatriculation
    , "study-features" Csv..= csvAUserStudyFeatures
    , "requested"      Csv..= csvAUserRequested
    , "applied"        Csv..= csvAUserApplied
    , "vetos"          Csv..= csvAUserVetos
    , "assigned"       Csv..= csvAUserAssigned
    ] ++
    [ "new-assigned"   Csv..= newAssigned
    | newAssigned <- hoistMaybe csvAUserNewAssigned
    ] ++
    [ "priority"       Csv..= csvAUserPriority
    ]

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

userTableCsvHeader :: Bool -> Csv.Header
userTableCsvHeader hasNewAssigned = Csv.header $
  [ "surname"
  , "first-name"
  , "name"
  , "matriculation"
  , "study-features"
  , "requested"
  , "applied"
  , "vetos"
  , "assigned"
  ] ++
  [ "new-assigned"
  | hasNewAssigned
  ] ++
  [ "priority"
  ]


getAUsersR, postAUsersR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAUsersR = postAUsersR
postAUsersR tid ssh ash = do
  (usersTable, acceptForm) <- runDB $ do
    Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
    resultsDone <- is _Just <$> allocationStarted aId
    allocMatching <- runMaybeT $ do
      SessionDataAllocationResults allocMap <- MaybeT $ lookupSessionJson SessionAllocationResults
      allocMatching <- fmap (view _4) . hoistMaybe $ allocMap !? (tid, ssh, ash)
      return $ Map.fromListWith (<>) [ (uid, opoint cid) | (uid, cid) <- Set.toList allocMatching ] :: _ (Map UserId (NonNull (Set CourseId)))

    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 $ do
            feats <- lift . allocationUserStudyFeatures aId =<< views _1 entityKey
            (,,,,,)
              <$> view _1 <*> pure feats <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
          dbtColonnade :: Colonnade Sortable _ _
          dbtColonnade = mconcat . catMaybes $
            [ pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
            , pure $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
            , pure $ colStudyFeatures resultStudyFeatures
            , pure $ colAllocationRequested (resultAllocationUser . _entityVal . _allocationUserTotalCourses . _Integral)
            , pure . coursesModalApplied $ colAllocationApplied resultAppliedCourses
            , pure . coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
            , guardOn resultsDone . coursesModalAssigned . bool id (assignedHeated $ view resultAssignedCourses) resultsDone $ colAllocationAssigned resultAssignedCourses
            , coursesModalNewAssigned <$> do
                allocMatching' <- allocMatching
                let newAssigned uid = maybe 0 olength $ allocMatching' !? uid
                pure . assignedHeated (views (resultUser . _entityKey) newAssigned) . sortable (Just "new-assigned") (i18nCell MsgAllocationUserNewMatches) .
                  views (resultUser . _entityKey) $ cell . toWidget . toMarkup . newAssigned
            , pure $ emptyOpticColonnade' emptyPriorityCell (resultAllocationUser . _entityVal . _allocationUserPriority . _Just) colAllocationPriority
            ]
            where
              emptyPriorityCell = addCellClass ("table__td--center" :: Text) . cell $
                messageTooltip =<< messageIconI Error IconMissingAllocationPriority MsgAllocationMissingPrioritiesIgnored
              assignedHeated fAssigned = imapColonnade assignedHeated'
                where
                  assignedHeated' res
                    = let maxAssign = min (res ^. resultAllocationUser . _entityVal . _allocationUserTotalCourses . to fromIntegral)
                                          (res ^. resultAppliedCourses)
                          assigned = fAssigned res
                       in cellAttrs <>~ [ ("class", "heated")
                                        , ("style", [st|--hotness: #{tshow (coHeat 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
                       , courseApplication E.^. CourseApplicationRatingPoints
                       , E.just $ courseApplication E.^. CourseApplicationRatingVeto
                       , E.exists . E.from $ \allocationCourse ->
                           E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
                                E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
                       )
              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
                       , E.nothing
                       , E.nothing
                       , E.exists . E.from $ \allocationCourse ->
                           E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
                                E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
                       )
              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
                       , E.nothing
                       , E.nothing
                       , courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
                       )
              coursesModalNewAssigned = coursesModal $ \res -> E.from $ \course -> do
                E.where_ $ course E.^. CourseId `E.in_` E.valList (maybe [] otoList $ Map.lookup (res ^. resultUser . _entityKey) =<< allocMatching)
                return ( course
                       , E.nothing
                       , E.nothing
                       , E.true
                       )
              coursesModal :: (_ -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value (Maybe ExamGrade)), E.SqlExpr (E.Value (Maybe Bool)), E.SqlExpr (E.Value Bool))) -> _ -> _
              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    -> let tooltipContent = $(widgetFile "table/cell/allocation-courses")
                                          in $(widgetFile "widgets/tooltip_no-handle")
          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)
            , singletonMap "new-assigned" $
                SortProjected . comparing $ (\uid -> maybe 0 olength $ Map.lookup uid =<< allocMatching) . view (resultUser . _entityKey)
            ]
          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 = return DBTCsvEncode
            { dbtCsvExportForm = pure ()
            , dbtCsvDoEncode = \() -> C.mapM $ \(_, row) -> flip runReaderT row $
                AllocationUserTableCsv
                  <$> view (resultUser . _entityVal . _userSurname)
                  <*> view (resultUser . _entityVal . _userFirstName)
                  <*> view (resultUser . _entityVal . _userDisplayName)
                  <*> view (resultUser . _entityVal . _userMatrikelnummer)
                  <*> view  resultStudyFeatures
                  <*> view (resultAllocationUser . _entityVal . _allocationUserTotalCourses . _Integral)
                  <*> view (resultAppliedCourses . _Integral)
                  <*> view (resultVetoedCourses . _Integral)
                  <*> view (resultAssignedCourses . _Integral)
                  <*> views (resultUser . _entityKey) (\uid -> maybe 0 (fromIntegral . olength) . Map.lookup uid <$> allocMatching)
                  <*> view (resultAllocationUser . _entityVal . _allocationUserPriority)
            , dbtCsvName = unpack csvName
            , dbtCsvNoExportData = Just id
            , dbtCsvHeader = \_ -> return . userTableCsvHeader $ is _Just allocMatching
            , dbtCsvExampleData = Nothing
            }
          dbtCsvDecode = Nothing
          dbtExtraReps = []
      allocationUsersDBTableValidator = def
        & defaultSorting [SortAscBy "priority", SortAscBy "user-matriculation"]
        & defaultPagesize (PagesizeLimit 500)

    usersTable <- dbTableDB' allocationUsersDBTableValidator allocationUsersDBTable

    acceptForm <- allocationAcceptForm aId

    return (usersTable, acceptForm)

  acceptView <- for acceptForm $ \acceptForm' -> do
    (acceptWgt, acceptEnctype) <- generateFormPost acceptForm'
    return $ wrapForm' BtnAllocationAccept acceptWgt def
      { formAction = Just . SomeRoute $ AllocationR tid ssh ash AAcceptR
      , formEncoding = acceptEnctype
      }

  siteLayoutMsg MsgMenuAllocationUsers $ do
    setTitleI $ MsgAllocationUsersTitle tid ssh ash

    $(widgetFile "allocation/users")
