-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE TypeApplications #-}

module Handler.Utils.Qualification
  ( module Handler.Utils.Qualification
  ) where

import Import

-- import Data.Time.Calendar (CalendarDiffDays(..))
-- import Database.Persist.Sql (updateWhereCount)
import qualified Database.Esqueleto.Experimental as E   -- might need TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Utils as E

import Handler.Utils.DateTime (toMidnight)
import Handler.Utils.Widgets  (statusHtml)

statusQualificationBlock :: Bool -> Html
statusQualificationBlock s = statusHtml (bool Error Success s) $ iconQualificationBlock s


-- needs refactoring, probbably no longer helpful
mkQualificationBlocked :: QualificationBlockStandardReason -> UTCTime -> QualificationUserId -> QualificationUserBlock
mkQualificationBlocked reason qualificationUserBlockFrom qualificationUserBlockQualificationUser = QualificationUserBlock{..}
   where 
     qualificationUserBlockReason = qualificationBlockedReasonText reason    
     qualificationUserBlockUnblock = False 
     qualificationUserBlockBlocker = Nothing

-- somewhat dangerous, if not used with latest effective block
isValidQualification :: (HasQualificationUser a, HasQualificationUserBlock b) => Day -> a -> Maybe b -> Bool
isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _qualificationUserFirstHeld
                                            ,qu ^. hasQualificationUser . _qualificationUserValidUntil)
                          && all (^. hasQualificationUserBlock . _qualificationUserBlockUnblock) qb

------------------
-- SQL Snippets --
------------------

-- | Recently became invalid or blocked and not yet notified
quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
quserToNotify quser cutoff =                                                                                        -- recently invalid or...
  (       E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil
    E.&&. E.notExists (do
        qualUserBlock <- E.from $ E.table @QualificationUserBlock
        E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
          E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>.  quser E.^. QualificationUserLastNotified
          E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
          E.&&. E.notExists (do                                                                                     --   block is the most recent block
            qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
            E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock)
                      qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
                E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
          )
      )
  ) E.||. E.exists (do                                                                                              -- ...recently blocked
    qualUserBlock <- E.from $ E.table @QualificationUserBlock
    E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)                                            --   block is not an unblock
        E.&&. E.day (qualUserBlock E.^. QualificationUserBlockFrom) E.<.  quser E.^. QualificationUserValidUntil    --   block was essential during validity
        E.&&.        qualUserBlock E.^. QualificationUserBlockFrom  E.>.  quser E.^. QualificationUserLastNotified  --   block has not yet been communicated
        E.&&.        qualUserBlock E.^. QualificationUserBlockFrom  E.<=. E.val cutoff                              --   block is already active
        E.&&. E.notExists (do                                                                                       --   block is the most recent block
            qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
            E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock))
                      qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
                E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
          )
  )

-- condition to ensure that the lastes QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
    newerBlock <- E.from $ E.table @QualificationUserBlock
    E.where_ $        newerBlock E.^. QualificationUserBlockFrom               E.<=. cutoff
        E.&&. E.just (newerBlock E.^. QualificationUserBlockFrom)              E.>.  qualBlock E.?. QualificationUserBlockFrom
        E.&&.         newerBlock E.^. QualificationUserBlockQualificationUser  E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
  )
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do 
  qualUserBlock <- E.from $ E.table @QualificationUserBlock 
  E.where_  $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
      E.&&. (qualUserBlock E.^. QualificationUserBlockFrom E.<=. cutoff)
      E.&&. checkQualUserId (qualUserBlock E.^. QualificationUserBlockQualificationUser)
      E.&&. E.notExists (do
        qualUserUnblock <- E.from $ E.table @QualificationUserBlock
        E.where_ $ (qualUserUnblock E.^. QualificationUserBlockUnblock)
            E.&&.  checkQualUserId (qualUserUnblock E.^. QualificationUserBlockQualificationUser)
            E.&&.  qualUserUnblock E.^. QualificationUserBlockFrom E.<=. cutoff
            E.&&.  qualUserUnblock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
      )
  whenIsJust mbBlockCondition (E.where_ . ($ qualUserBlock))

-- | Test whether a QualificationUser was blocked/unblocked at a given day; negCond: True:isBlocked False:isUnblocked 
quserBlock :: Bool -> UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
quserBlock negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.==. (qualUser E.^. QualificationUserId)) Nothing

-- | Variant of `isBlocked` for outer joins              
quserBlock' :: Bool -> UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
quserBlock' negCond cutoff qualUser = quserBlockAux negCond (E.val cutoff) (E.=?. (qualUser E.?. QualificationUserId)) Nothing

qualificationValid :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
qualificationValid = flip validQualification

validQualification :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (E.Value Bool)
validQualification cutoff qualUser =
  (E.val (utctDay cutoff) `E.between` (qualUser E.^. QualificationUserFirstHeld
                                      ,qualUser E.^. QualificationUserValidUntil))   -- currently valid
           E.&&. quserBlock False cutoff qualUser

-- |  Variant of `validQualification` for outer joins
validQualification' :: UTCTime -> E.SqlExpr (Maybe (Entity QualificationUser)) -> E.SqlExpr (E.Value Bool)
validQualification' cutoff qualUser =
  (E.justVal (utctDay cutoff) `E.between` (qualUser E.?. QualificationUserFirstHeld
                                          ,qualUser E.?. QualificationUserValidUntil))   -- currently valid
           E.&&. quserBlock' False cutoff qualUser

selectValidQualifications :: QualificationId -> Maybe [UserId] -> UTCTime -> DB [Entity QualificationUser]
selectValidQualifications qid mbUids cutoff = 
  -- cutoff <- utctDay <$> liftIO getCurrentTime
  E.select $ do 
    qUser <- E.from $ E.table @QualificationUser
    E.where_ $  (qUser E.^. QualificationUserQualification E.==. E.val qid)
          E.&&. validQualification cutoff qUser
    --      E.&&. maybe E.true (\uids -> qUser E.^. QualificationUserUser `E.in_` E.valList uids) mbUids
    whenIsJust mbUids (\uids -> E.where_ $ qUser E.^. QualificationUserUser `E.in_` E.valList uids)
    pure qUser

selectRelevantBlock :: UTCTime -> QualificationUserId -> DB (Maybe (Entity QualificationUserBlock))
selectRelevantBlock cutoff quid =
  selectFirst [QualificationUserBlockQualificationUser ==. quid, QualificationUserBlockFrom <=. cutoff] [Desc QualificationUserBlockFrom]

------------------------
-- Complete Functions --
------------------------


upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking
upsertQualificationUser  qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
  Entity quid _ <- upsert
    QualificationUser
      { qualificationUserFirstHeld        = qualificationUserLastRefresh      
      , qualificationUserScheduleRenewal  = fromMaybe True mbScheduleRenewal
      , qualificationUserLastNotified     = toMidnight qualificationUserLastRefresh
      , ..
      }
    (
      [ QualificationUserScheduleRenewal    =. scheduleRenewal              | Just scheduleRenewal <- [mbScheduleRenewal]
      ] ++
      [ QualificationUserValidUntil         =. qualificationUserValidUntil
      , QualificationUserLastRefresh        =. qualificationUserLastRefresh      
      ]
    )
  
  audit TransactionQualificationUserEdit
    { transactionQualificationUser            = quid
    , transactionQualification                = qualificationUserQualification
    , transactionUser                         = qualificationUserUser
    , transactionQualificationValidUntil      = qualificationUserValidUntil
    , transactionQualificationScheduleRenewal = mbScheduleRenewal
    }

-- | Renew an existing qualification, ignoring all blocks
renewValidQualificationUsers :: QualificationId -> [UserId] -> DB Int
renewValidQualificationUsers qid uids =
  -- This code works in principle, but it does not allow audit log entries.
  -- E.update $ \qu -> do
  --   E.set qu [ QualificationUserValidUntil E.+=. E.interval (CalendarDiffDays 2 0) ] -- TODO: for Testing only
  --   E.where_ $ (qu E.^. QualificationUserQualification E.==. E.val qid )
  --       E.&&.  (qu E.^. QualificationUserUser `E.in_` E.valList uids)
  get qid >>= \case     
    Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
      now <- liftIO getCurrentTime
      quEntsAll <- selectValidQualifications qid (Just uids) now
      let nowaday     = utctDay now
          maxValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) nowaday
          quEnts      = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
      forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do 
        let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil        
        update quId [ QualificationUserValidUntil   =. newValidTo
                    , QualificationUserLastRefresh  =. nowaday
                    ]
        audit TransactionQualificationUserEdit
          { transactionQualificationUser            = quId
          , transactionQualification                = qualificationUserQualification
          , transactionUser                         = qualificationUserUser
          , transactionQualificationValidUntil      = newValidTo
          , transactionQualificationScheduleRenewal = Nothing
          }
      return $ length quEnts
    _ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.

-- | Block or unblock some users for a given reason 
qualificationUserBlocking :: 
  ( AuthId (HandlerSite m) ~ Key User
  , IsPersistBackend (YesodPersistBackend (HandlerSite m))
  , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
  , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
  , PersistQueryWrite (YesodPersistBackend (HandlerSite m))
  , PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
  , HasInstanceID (HandlerSite m) InstanceId
  , YesodAuthPersist (HandlerSite m)
  , HasAppSettings (HandlerSite m)
  , MonadHandler m
  , MonadCatch m
  , Num n
  ) => QualificationId -> [UserId] -> Bool -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserBlocking qid uids unblock (qualificationBlockReasonText -> reason) notify = do
  authUsr <- liftHandler maybeAuthId
  now <- liftIO getCurrentTime  
  -- -- Code would work, but problematic 
  -- oks <- E.insertSelectCount . E.from $ \qualificationUser -> do
  --   E.where_ $ qualificationUser E.^. QualificationUserQualification E.==. E.val qid 
  --       E.&&.  qualificationUser E.^. QualificationUserUser E.in_ E.valList uid
  --       E.&&.  quserBlock (not unblock) nowaday qualificationUser -- only unblock blocked qualification and vice versa
  --   return $ QualificationUserBlock
  --     E.<#  qualificationUser E.^. QualificationUserId
  --     E.<&> E.val unblock
  --     E.<&> E.val nowaday
  --     E.<&> E.val reason
  --     E.<&> E.val authUsr
  toChange' <- E.select $ do
    qualUser <- E.from $ E.table @QualificationUser
    E.where_ $ qualUser E.^. QualificationUserQualification E.==. E.val qid 
        E.&&.  qualUser E.^. QualificationUserUser `E.in_` E.valList uids
        E.&&.  quserBlock (not unblock) now qualUser -- only unblock blocked qualification and vice versa
    return (qualUser E.^. QualificationUserId, qualUser E.^. QualificationUserUser)
  let toChange = E.unValue . fst <$> toChange'
  E.insertMany_ $ map (\quid -> QualificationUserBlock
    { qualificationUserBlockQualificationUser = quid
    , qualificationUserBlockUnblock           = unblock
    , qualificationUserBlockFrom              = now
    , qualificationUserBlockReason            = reason
    , qualificationUserBlockBlocker           = authUsr
    }) toChange

  unless notify $ updateWhere [QualificationUserId <-. toChange] [QualificationUserLastNotified =. now]

  forM_ toChange' $ \(_, E.Value uid) -> do     
    audit TransactionQualificationUserBlocking 
      { -- transactionQualificationUser  = quid
        transactionQualification      = qid
      , transactionUser               = uid
      , transactionQualificationBlock = error "TODO" -- CONTINUE HERE
      }
  return $ fromIntegral $ length toChange


qualificationUserUnblockByReason :: 
  ( AuthId (HandlerSite m) ~ Key User
  , IsPersistBackend (YesodPersistBackend (HandlerSite m))
  , BaseBackend (YesodPersistBackend (HandlerSite m)) ~ SqlBackend
  , BackendCompatible SqlBackend (YesodPersistBackend (HandlerSite m))
  , PersistQueryWrite (YesodPersistBackend (HandlerSite m))
  , PersistUniqueWrite (YesodPersistBackend (HandlerSite m))
  , HasInstanceID (HandlerSite m) InstanceId
  , YesodAuthPersist (HandlerSite m)
  , HasAppSettings (HandlerSite m)
  , MonadHandler m
  , MonadCatch m
  , Num n
  ) => QualificationId -> [UserId] -> QualificationBlockReason -> QualificationBlockReason -> Bool -> ReaderT (YesodPersistBackend (HandlerSite m)) m n
qualificationUserUnblockByReason qid uids (qualificationBlockReasonText -> reason) undo_reason notify = do
  now <- liftIO getCurrentTime  
  toUnblock <- E.select $ do
    quser <- E.from $ E.table @QualificationUser
    E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
        E.&&.  quser E.^. QualificationUserUser `E.in_` E.valList uids
        E.&&.  quserBlockAux True (E.val now) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
    return $ quser E.^. QualificationUserUser
  qualificationUserBlocking qid (E.unValue <$> toUnblock) True undo_reason notify 
