-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.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.Text.Lazy.Encoding as LBS

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

import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Utils as E

import Handler.Utils
import Handler.Utils.Avs
import Handler.Utils.Users

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.ExternalUser as Handler.Admin


getAdminR :: Handler Html
getAdminR = redirect AdminProblemsR

getAdminProblemsR :: Handler Html
getAdminProblemsR = 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, interfaceTable) <- runDB $ (,,,,,) 
      <$> areAllUsersReachable 
      <*> allDriversHaveAvsId now
      <*> allRDriversHaveFs now
      <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
      <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])      
      <*> fmap (view _2) (mkInterfaceLogTable flagError cutOffOldTime)
  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

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


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
    return $ filter hasInvalidEmail emailOnlyUsers
  where 
    hasInvalidEmail = isNothing . getEmailAddress . entityVal
  

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





mkInterfaceLogTable :: (Bool -> Widget) -> UTCTime -> DB (Any, Widget)
mkInterfaceLogTable flagError cutOffOldTime = do
  avsSynchStats <- E.select $ do
    uavs <- E.from $ E.table @UserAvs
    E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
    let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError)
    E.groupBy isOk
    E.orderBy [E.descNullsLast isOk]
    return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
  let 
    mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
      fmtCut <- formatTime SelFormatDate cutOffOldTime
      fmtBad <- formatTime SelFormatDateTime badTime
      return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
    mkBadInfo _ _ = return mempty
    writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo = 
      void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True)
        (InterfaceLog "AVS" "Synch" True okTime okRows badInfo)
        [InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo]
  --case $(unValueN 3) <$> avsSynchStats of  
  case avsSynchStats of 
    ((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
      writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime
    ((E.Value True , E.Value okRows, E.Value okTime):_)    ->
      writeAvsSynchStats (Just okRows) okTime mempty
    ((E.Value False, E.Value badRows, E.Value badTime):_) -> do
      lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
      writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime
    _ -> return ()
  
  let
    flagOld       = flagError . (cutOffOldTime <)
    resultDBTable = DBTable{..}
      where
        resultILog :: Lens' (DBRow (Entity InterfaceLog)) InterfaceLog
        resultILog = _dbrOutput . _entityVal
        dbtSQLQuery = return
        dbtRowKey = (E.^. InterfaceLogId)
        dbtProj = dbtProjId
        dbtColonnade = dbColonnade $ mconcat
          [ sortable Nothing            (textCell "Status"              ) $ wgtCell . flagOld . view (resultILog . _interfaceLogTime)
          , sortable (Just "interface") (textCell "Interface"           ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
          , sortable (Just "subtype")   (i18nCell MsgInterfaceSubtype   ) $ textCell . view (resultILog . _interfaceLogSubtype)
          , sortable (Just "write")     (i18nCell MsgInterfaceWrite     ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
          , sortable (Just "time")      (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
          , sortable (Just "rows")      (i18nCell MsgTableRows          ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)                              
          , sortable Nothing            (textCell "Info"                ) $ \(view resultILog -> ilt) -> case ilt of
              InterfaceLog "AVS" "Synch" True _ _ i -> anchorCell ProblemAvsErrorR $ toWgt i
              InterfaceLog _     _       _    _ _ i -> textCell i 
          ]
        dbtSorting = mconcat
          [ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface)
          , singletonMap "subtype"   $ SortColumn (E.^. InterfaceLogSubtype)
          , singletonMap "write"     $ SortColumn (E.^. InterfaceLogWrite)
          , singletonMap "time"      $ SortColumn (E.^. InterfaceLogTime)
          , singletonMap "rows"      $ SortColumn (E.^. InterfaceLogRows)          
          ]
        dbtFilter     = mempty
        dbtFilterUI   = mempty
        dbtStyle      = def
        dbtIdent      = "interface-log" :: Text
        dbtParams     = def
        dbtCsvEncode  = noCsvEncode
        dbtCsvDecode  = Nothing
        dbtExtraReps  = []
    resultDBTableValidator = def
      & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
  dbTable resultDBTableValidator resultDBTable