-- 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 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.DateTime
import Handler.Utils.Avs
import Handler.Utils.Widgets
import Handler.Utils.Users
import Handler.Utils.Qualification

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
      cutOffPrintDays = 7
      cutOffPrintJob  = addLocalDays (-cutOffPrintDays) now
  (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs) <- runDB $ (,,,) 
      <$> areAllUsersReachable 
      <*> allDriversHaveAvsId nowaday
      <*> allRDriversHaveFs nowaday
      <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <=. cutOffPrintJob])      
  diffLics <- try retrieveDifferingLicences <&> \case
    -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
    (Left e) -> Left $ text2widget $ tshow (e :: SomeException)
    (Right AvsLicenceDifferences{..}) -> 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)
  --   ]
      
  -- 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))                                    
  
  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
  let nowaday = utctDay now
  rnofs <- runDB $ E.select $ retrieveDriversRWithoutF nowaday
  siteLayoutMsg MsgProblemsRWithoutFHeading $ do
    setTitleI   MsgProblemsRWithoutFHeading
    [whamlet|
      <section>
        _{MsgProblemsRWithoutFBody}
        <ul>
          $forall usr <- rnofs
            <li>
              ^{linkUserWidget AdminUserR usr}
    |]

getProblemWithoutAvsId :: Handler Html
getProblemWithoutAvsId = do 
  now <- liftIO getCurrentTime
  let nowaday = utctDay now
  rnofs <- runDB $ E.select $ retrieveDriversWithoutAvsId nowaday
  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 = dbtProjFilteredPostId -- TODO: still don't understand the choices here
      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 :: Day -> 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 :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversWithoutAvsId nowaday = 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 nowaday) -- 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 :: Day -> 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 :: Day -> E.SqlQuery (E.SqlExpr (Entity User))
retrieveDriversRWithoutF nowaday = 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 nowaday)                                 -- currently valid            
  E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
    E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
  return usr