-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Handler.Admin
  ( module Handler.Admin
  ) where

import Import

-- import Data.Either
import qualified Data.Set as Set
import qualified Data.Map as Map
-- import qualified Data.Text.Lazy.Encoding as LBS

-- import qualified Control.Monad.Catch as Catch
-- import Servant.Client (ClientError(..), ResponseF(..))
-- import Text.Blaze.Html (preEscapedToHtml)

import Database.Persist.Sql (updateWhereCount)
import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Legacy as EL (on) -- needed for dbTable
import qualified Database.Esqueleto.Utils as E

import Handler.Utils
import Handler.Utils.Avs
import Handler.Utils.Users
-- import Handler.Utils.Company
import Handler.Health.Interface

import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin
import Handler.Admin.Tokens as Handler.Admin
import Handler.Admin.Crontab as Handler.Admin
import Handler.Admin.Avs as Handler.Admin
import Handler.Admin.Ldap as Handler.Admin

-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton


-- Types and Template Haskell
data ProblemTableAction = ProblemTableMarkSolved
                        | ProblemTableMarkUnsolved
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
  deriving anyclass (Universe, Finite)

nullaryPathPiece ''ProblemTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''ProblemTableAction id

data ProblemTableActionData = ProblemTableMarkSolvedData
                            | ProblemTableMarkUnsolvedData -- Placeholder, remove later
  deriving (Eq, Ord, Read, Show, Generic)


-- Handlers
getAdminR :: Handler Html
getAdminR = redirect AdminProblemsR

getAdminProblemsR, postAdminProblemsR :: Handler Html
getAdminProblemsR = handleAdminProblems Nothing

handleAdminProblems :: Maybe Widget -> Handler Html
handleAdminProblems mbProblemTable = do
  now <- liftIO getCurrentTime
  let nowaday = utctDay now
      cutOffOldDays = 1
      cutOffOldTime  = toMidnight $ addDays (-cutOffOldDays) nowaday

  -- we abuse messageTooltip for colored icons here
  msgSuccessTooltip <- messageI Success MsgMessageSuccess
  msgWarningTooltip <- messageI Warning MsgMessageWarning
  msgErrorTooltip   <- messageI Error   MsgMessageError

  let flagError   = messageTooltip . bool msgErrorTooltip   msgSuccessTooltip
      flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip
      flagNonZero :: Int -> Widget
      flagNonZero n | n <= 0    = flagError True
                    | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))

  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,)
      <$> areAllUsersReachable
      <*> allDriversHaveAvsId now
      <*> allRDriversHaveFs now
      <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
      <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
      <*> mkInterfaceLogTable mempty
  let interfacesBadNr = length $ filter (not . snd) interfaceOks
      -- interfacesOk = all snd interfaceOks

  diffLics <- try retrieveDifferingLicences >>= \case
    -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
    (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
    (Right (AvsLicenceDifferences{..},_)) -> do
      let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
      void $ runDB $ queueAvsUpdateByAID problemIds $ Just nowaday
      return $ Right
        ( Set.size avsLicenceDiffRevokeAll
        , Set.size avsLicenceDiffGrantVorfeld
        , Set.size avsLicenceDiffRevokeRollfeld
        , Set.size avsLicenceDiffGrantRollfeld
        )
  -- Attempt to format results in a nicer way failed, since rendering Html within a modal destroyed the page layout itself
  -- let procDiffLics (to0, to1, to2) = Right (Set.size to0, Set.size to1, Set.size to2)
  -- diffLics <- (procDiffLics . fst <$> retrieveDifferingLicences) `catches`
  --   [ Catch.Handler (\case (UnsupportedContentType "text/html;charset=utf-8" Response{responseBody})
  --                                         -> return $ Left $ toWidget $ preEscapedToHtml $ fromRight "Response UTF8-decoding error" $ LBS.decodeUtf8' responseBody
  --                          ex             -> return $ Left $ text2widget $ tshow ex)
  --   , Catch.Handler (\(ex::SomeException) -> return $ Left $ text2widget $ tshow ex)
  --   ]

  rerouteMail <- getsYesod $ view _appMailRerouteTo
  problemLogTable <- maybeM (snd <$> runDB mkProblemLogTable) return $ return mbProblemTable    -- formResult only processed in POST-Handler

  siteLayoutMsg MsgProblemsHeading $ do
    setTitleI   MsgProblemsHeading
    $(widgetFile "admin-problems")

postAdminProblemsR = do
    (problemLogRes, problemLogTable) <- runDB mkProblemLogTable
    formResult problemLogRes procProblems
    handleAdminProblems $ Just problemLogTable
  where
    procProblems :: (ProblemTableActionData, Set ProblemLogId) -> Handler ()
    procProblems (ProblemTableMarkSolvedData  , pids) = actUpdate True  pids
    procProblems (ProblemTableMarkUnsolvedData, pids) = actUpdate False pids

    actUpdate markdone pids = do
      mauid <- maybeAuthId
      now <- liftIO getCurrentTime
      let (pls_fltr,newv,msg) | markdone  = (ProblemLogSolved ==. Nothing, Just now, MsgAdminProblemsSolved)
                              | otherwise = (ProblemLogSolved !=. Nothing, Nothing , MsgAdminProblemsReopened)
      (fromIntegral -> oks) <- runDB $ updateWhereCount [pls_fltr, ProblemLogId <-. toList pids]
                                                        [ProblemLogSolved =. newv, ProblemLogSolver =. mauid]
      let no_req = Set.size pids
          mkind = if oks < no_req || no_req <= 0 then Warning else Success
      addMessageI mkind $ msg oks
      when (oks > 0) $ reloadKeepGetParams AdminProblemsR -- reload to update all tables

getProblemUnreachableR :: Handler Html
getProblemUnreachableR = do
  unreachables <- runDB retrieveUnreachableUsers
  siteLayoutMsg MsgProblemsUnreachableHeading $ do
    setTitleI   MsgProblemsUnreachableHeading
    [whamlet|
      <section>
        #{length unreachables} _{MsgProblemsUnreachableBody}
        <ul>
          $forall usr <- unreachables
            <li>
              ^{linkUserWidget ForProfileDataR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
    |]

getProblemFbutNoR :: Handler Html
getProblemFbutNoR = do
  now <- liftIO getCurrentTime
  rnofs <- runDB $ E.select $ retrieveDriversRWithoutF now
  siteLayoutMsg MsgProblemsRWithoutFHeading $ do
    setTitleI   MsgProblemsRWithoutFHeading
    [whamlet|
      <section>
        _{MsgProblemsRWithoutFBody}
        <ul>
          $forall usr <- rnofs
            <li>
              ^{linkUserWidget AdminUserR usr}
    |]

getProblemWithoutAvsId :: Handler Html
getProblemWithoutAvsId = do
  now <- liftIO getCurrentTime
  rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId now
  siteLayoutMsg MsgProblemsNoAvsIdHeading $ do
    setTitleI   MsgProblemsNoAvsIdHeading
    [whamlet|
      <section>
        _{MsgProblemsNoAvsIdBody}
        <ul>
          $forall usr <- rnofs
            <li>
              ^{linkUserWidget AdminUserR usr}
    |]

{-
mkUnreachableUsersTable = do
  let dbtSQLQuery user -> do
        E.where_ $ E.isNothing (user E.^. UserPostAddress)
          E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%")
        pure user
      dbtRowKey = (E.^. UserId)
      dbtProj = dbtProjId
      dbtColonnade =
-}

areAllUsersReachable :: DB Bool
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers' -- works and would be more efficient, but we cannot check proper email validity within DB alone
areAllUsersReachable = null <$> retrieveUnreachableUsers

-- retrieveUnreachableUsers' :: E.SqlQuery (E.SqlExpr (Entity User))
-- retrieveUnreachableUsers' = do
--     user <- E.from $ E.table @User
--     E.where_ $   E.isNothing (user E.^. UserPostAddress)
--           E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
--           E.&&. E.not_ ((user E.^. UserDisplayEmail)  `E.like` E.val "%@%.%")
--           E.&&. E.not_ ((user E.^. UserEmail)         `E.like` E.val "%@%.%")
--     return user

retrieveUnreachableUsers :: DB [Entity User]
retrieveUnreachableUsers = do
    emailOnlyUsers <- E.select $ do
      user <- E.from $ E.table @User
      E.where_ $   E.isNothing (user E.^. UserPostAddress)
            E.&&. (E.isNothing (user E.^. UserCompanyDepartment) E.||. user E.^. UserCompanyPersonalNumber `E.ilike` E.justVal "E%")
            E.&&. E.notExists (do
                (cmp :& usrCmp) <- E.from $ E.table @Company `E.innerJoin` E.table @UserCompany
                  `E.on` (\(cmp :& usrCmp) -> cmp E.^. CompanyId E.==. usrCmp E.^. UserCompanyCompany)
                E.where_ $ user E.^. UserId E.==. usrCmp E.^. UserCompanyUser
                    E.&&.  usrCmp E.^. UserCompanyUseCompanyAddress
                    E.&&.  E.isJust (cmp E.^. CompanyPostAddress)
              )
      return user
    filterM hasInvalidEmail emailOnlyUsers
    -- filterM hasInvalifPostal -- probably not worth it, since Utils.Postal.validPostAddress is pretty weak anyway
  where
    hasInvalidEmail = fmap isNothing . getUserEmail


allDriversHaveAvsId :: UTCTime -> DB Bool
-- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId

{-
-- | Returns users more than once if they own multiple avs-related valid licences, but no AvsID is known
retrieveDriversWithoutAvsId' :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId' nowaday = do
  (usr :& qualUsr :& qual) <- E.from $ E.table @User
    `E.innerJoin`  E.table @QualificationUser
    `E.on` (\(usr :& qualUsr) -> usr E.^. UserId E.==. qualUsr E.^. QualificationUserUser)
    `E.innerJoin`  E.table @Qualification
    `E.on` (\(_usr :& qualUsr :& qual) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification)
  E.where_ $ -- is avs licence
      E.isJust (qual E.^. QualificationAvsLicence)
    E.&&. (qualUsr & validQualification nowaday)
    E.&&. -- AvsId is unknown
      E.notExists (do
        avsUsr <- E.from $ E.table @UserAvs
        E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
      )
  return usr
-}

-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
retrieveDriversWithoutAvsId :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId now = do
  usr <- E.from $ E.table @User
  E.where_ $
      E.exists (do -- a valid avs licence
        (qual :& qualUsr) <- E.from (E.table @Qualification
              `E.innerJoin` E.table @QualificationUser
              `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
        E.where_ $ -- is avs licence
            E.isJust (qual E.^. QualificationAvsLicence)
          E.&&. (qualUsr & validQualification now) -- currently valid
          E.&&. -- matches user
            (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)
      )
    E.&&.
      E.notExists (do -- a known AvsId
        avsUsr <- E.from $ E.table @UserAvs
        E.where_ $ avsUsr E.^. UserAvsUser E.==. usr E.^. UserId
      )
  return usr


allRDriversHaveFs :: UTCTime -> DB Bool
-- allRDriversHaveFs = fmap isNothing . E.selectOne . retrieveDriversRWithoutF
allRDriversHaveFs = E.selectNotExists . retrieveDriversRWithoutF

-- | Returns users at most once, even if they own multiple avs-related licences, but no AvsID is known
retrieveDriversRWithoutF :: UTCTime -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversRWithoutF now = do
  usr <- E.from $ E.table @User
  let hasValidQual lic = do
        (qual :& qualUsr) <- E.from (E.table @Qualification
              `E.innerJoin` E.table @QualificationUser
              `E.on` (\(qual :& qualUsr) -> qual E.^. QualificationId E.==. qualUsr E.^. QualificationUserQualification))
        E.where_ $  (qual E.^. QualificationAvsLicence  E.==. E.justVal lic)    -- matches licence
              E.&&. (qualUsr E.^. QualificationUserUser E.==. usr E.^. UserId)  -- matches user
              E.&&. (qualUsr & validQualification now)                          -- currently valid
  E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
    E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
  return usr



type ProblemLogTableExpr = E.SqlExpr (Entity ProblemLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
queryProblem :: ProblemLogTableExpr -> E.SqlExpr (Entity ProblemLog)
queryProblem = $(E.sqlLOJproj 3 1)

querySolver :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
querySolver = $(E.sqlLOJproj 3 2)

queryUser :: ProblemLogTableExpr -> E.SqlExpr (Maybe (Entity User))
queryUser = $(E.sqlLOJproj 3 3)

type ProblemLogTableData = DBRow (Entity ProblemLog, Maybe (Entity User), Maybe (Entity User))
resultProblem :: Lens' ProblemLogTableData (Entity ProblemLog)
resultProblem = _dbrOutput . _1

resultSolver :: Traversal' ProblemLogTableData (Entity User)
resultSolver = _dbrOutput . _2 . _Just

resultUser :: Traversal' ProblemLogTableData (Entity User)
resultUser = _dbrOutput . _3 . _Just

mkProblemLogTable :: DB (FormResult (ProblemTableActionData, Set ProblemLogId), Widget)
mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
  where
    -- TODO: query to collect all occurring problem types to use as tooltip for the problem filter, so that these don't run out of synch
    dbtIdent = "problem-log" :: Text
    dbtSQLQuery = \(problem `E.LeftOuterJoin` solver `E.LeftOuterJoin` usr) -> do
                    -- EL.on (usr    E.?. UserId E.==. E.text2num (problem E.^. ProblemLogInfo   E.->>. "user")) -- works
                    EL.on (usr    E.?. UserId E.==. problem E.^. ProblemLogInfo E.->>>. "user")
                    EL.on (solver E.?. UserId E.==. problem E.^. ProblemLogSolver)
                    return (problem, solver, usr)
    dbtRowKey = queryProblem >>> (E.^. ProblemLogId)
    dbtProj = dbtProjId
    dbtColonnade = formColonnade $ mconcat
      [ dbSelect (applying _2) id $ return . view (resultProblem . _entityKey)
      , sortable (Just "time")    (i18nCell MsgAdminProblemCreated) $ \(   view $ resultProblem . _entityVal . _problemLogTime   -> t) ->           dateTimeCell t
      , sortable (Just "info")    (i18nCell MsgAdminProblemInfo)    $ \(   view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> adminProblemCell p
      -- , sortable (Just "firm")    (i18nCell MsgTableCompany)        $ \(preview $ resultProblem . _entityVal . _problemLogAdminProblem . _adminProblemCompany -> c) -> cellMaybe companyIdCell c
      , sortable (Just "firm")    (i18nCell MsgTableCompany)        $ \(   view $ resultProblem . _entityVal . _problemLogAdminProblem -> p) -> cellMaybe companyIdCell $ join (p ^? _adminProblemCompanyOld) <|> (p ^? _adminProblemCompany)
      , sortable (Just "user")    (i18nCell MsgAdminProblemUser)    $ \(preview resultUser   -> u) -> maybeCell u $ cellHasUserLink AdminUserR
      , sortable (Just "solved")  (i18nCell MsgAdminProblemSolved)  $ \(   view $ resultProblem . _entityVal . _problemLogSolved -> t) -> cellMaybe dateTimeCell t
      , sortable (Just "solver")  (i18nCell MsgAdminProblemSolver)  $ \(preview resultSolver -> u) -> maybeCell u $ cellHasUserLink AdminUserR
      ]
    dbtSorting = mconcat
      [ single ("time"  , SortColumn $ queryProblem >>> (E.^. ProblemLogTime))
      , single ("info"  , SortColumn $ queryProblem >>> (E.^. ProblemLogInfo))
      -- , single ("firm"  , SortColumn ((E.->>. "company" ).(queryProblem >>> (E.^. ProblemLogInfo))))
      , single ("firm"  , SortColumn $ \r -> queryProblem r E.^. ProblemLogInfo E.->>. "company")
      , single ("user"  , sortUserNameBareM queryUser)
      , single ("solved", SortColumn $ queryProblem >>> (E.^. ProblemLogSolved))
      , single ("solver", sortUserNameBareM querySolver)
      ]
    dbtFilter = mconcat
      [ single ("user"    , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryUser)   (E.?. UserDisplayName))
      , single ("solver"  , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySolver) (E.?. UserDisplayName))
      , single ("problem" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "problem").(E.^. ProblemLogInfo)))
      , single ("company" , FilterColumn . E.mkContainsFilter  $ views (to queryProblem) ((E.->>. "company").(E.^. ProblemLogInfo)))
      , single ("solved"  , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
      ]
    dbtFilterUI mPrev = mconcat
      [ prismAForm (singletonFilter "user"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgAdminProblemUser   & setTooltip MsgTableFilterCommaPlus)
      , prismAForm (singletonFilter "solver"  . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgAdminProblemSolver & setTooltip MsgTableFilterCommaPlusShort)
      , prismAForm (singletonFilter "problem" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgAdminProblemInfo   & setTooltip MsgAdminProblemInfoTooltip)
      , prismAForm (singletonFilter "company" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgTableCompanyShort)
      , prismAForm (singletonFilter "solved"  . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgAdminProblemSolved)
      ]
    acts :: Map ProblemTableAction (AForm Handler ProblemTableActionData)
    acts = mconcat
      [ singletonMap ProblemTableMarkSolved   $ pure ProblemTableMarkSolvedData
      , singletonMap ProblemTableMarkUnsolved $ pure ProblemTableMarkUnsolvedData
      ]
    dbtParams = DBParamsForm
          { dbParamsFormMethod = POST
          , dbParamsFormAction = Nothing
          , dbParamsFormAttrs  = []
          , dbParamsFormSubmit = FormSubmit
          , dbParamsFormAdditional
              = renderAForm FormStandard
                   $  (, mempty) . First . Just
                  <$> multiActionA acts (fslI MsgTableAction) (Just ProblemTableMarkSolved)
          , dbParamsFormEvaluate = liftHandler . runFormPost
          , dbParamsFormResult   = id
          , dbParamsFormIdent    = def
          }
    dbtCsvEncode = noCsvEncode
    dbtCsvDecode = Nothing
    dbtExtraReps = []
    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
    validator = def & defaultSorting [SortAscBy "time"]
                    & defaultFilter  (singletonMap "solved" [toPathPiece False])
    postprocess :: FormResult (First ProblemTableActionData, DBFormResult ProblemLogId Bool ProblemLogTableData)
                -> FormResult (      ProblemTableActionData, Set ProblemLogId)
    postprocess inp = do
      (First (Just act), usrMap) <- inp
      let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
      return (act, usrSet)

-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a -- moved to Handler.Utils
-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX) -- moved to Handler.Utils