-- SPDX-FileCopyrightText: 2022 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.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


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, (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

  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