-- 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 Jobs
-- 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.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 flagError 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
      forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (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 <$> 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 = isNothing <$> E.selectOne retrieveUnreachableUsers'
-- areAllUsersReachable = E.selectNotExists retrieveUnreachableUsers'
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%")    
      return user
    filterM hasInvalidEmail emailOnlyUsers    
  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
    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 ("solved" , FilterColumn . E.mkExactFilterLast $ views (to queryProblem) (E.isJust . (E.^. ProblemLogSolved)))
      ]
    dbtFilterUI mPrev = mconcat
      [ 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
-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
adminProblemCell AdminProblemNewCompany{}                                 
  = i18nCell MsgAdminProblemNewCompany
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute} 
  = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}  
  = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
adminProblemCell AdminProblemUnknown{adminProblemText}  
  = textCell $ "Problem: " <> adminProblemText