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


module Handler.Health.Interface
  (
    getHealthInterfaceR
  , mkInterfaceLogTable
  , runInterfaceChecks
  )
 where

import Import

-- import qualified Data.Set as Set
import qualified Data.Text as Text
import Handler.Utils
import Handler.Utils.Concurrent

-- import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Legacy as EL (on)
import qualified Database.Persist.Sql as E (deleteWhereCount)


-- | identify a wildcard argument
wc2null :: Text -> Maybe Text
-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs
-- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface
wc2null "_" = Nothing
wc2null "*" = Nothing
wc2null  o  = Just o

-- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
pbool :: Text -> Maybe Bool
pbool (Text.toLower . Text.strip -> w)
  | w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True
  | w `elem` ["0", "f", "false","falsch"]    = Just False
  | otherwise                                = Nothing

-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places.
identifyInterfaces :: [Text] -> [Unique InterfaceHealth]
identifyInterfaces []        = []
identifyInterfaces [i]       = [UniqueInterfaceHealth i Nothing     Nothing]
identifyInterfaces [i,s]     = [UniqueInterfaceHealth i (wc2null s) Nothing]
identifyInterfaces (i:s:w:r) =  UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r

type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth])

-- | Interface names prefixed with '-' are to be excluded from the query
splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth
splitInterfaces = foldl' aux mempty
  where
    aux (reqs,bans) uih@(UniqueInterfaceHealth i s w)
      | Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans)
      | otherwise = (uih : reqs, bans)

-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second
matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool
matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw
  where
    eqOrNothing _ Nothing = True
    eqOrNothing a b       = a == b


getHealthInterfaceR :: [Text] -> Handler TypedContent
getHealthInterfaceR (dropWhile (=="force") -> ris) = do               -- for backwards compatibility we ignore leading "force"
  let interfs = splitInterfaces $ identifyInterfaces ris
  (missing, allok, res, iltable) <- runInterfaceLogTable interfs
  when missing notFound                                               -- send 404 if any requested interface was not found
  let ihstatus = if allok then status200
                          else internalServerError500
      plainMsg = if allok then "Interfaces are healthy."
                          else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
  sendResponseStatus ihstatus <=< selectRep $ do                      -- most browsers send accept:text/html, thus text/plain can be default here
    provideRep . return . RepPlain $ toContent plainMsg               -- /?_accept=text/plain
    provideRep . siteLayoutMsg MsgMenuHealthInterface $ do            -- /?_accept=text/html
      setTitleI MsgMenuHealthInterface
      [whamlet|
        <div>
          #{plainMsg}
        <div>
          ^{iltable}
      |]


runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
runInterfaceLogTable interfs@(reqIfs,_) = do
  -- 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
  (res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
  let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
      allok   = all snd res
  return (missing, allok, res, twgt)

-- ihDebugShow :: Unique InterfaceHealth -> Text
-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"

mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
    --   $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
    void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
    now <- liftIO getCurrentTime
    dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
  where
    sanitize      = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
    dbtIdent      = "interface-log" :: Text
    dbtProj       = dbtProjId
    dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do
      EL.on (       ilog E.^. InterfaceLogInterface E.=?.          ihealth E.?. InterfaceHealthInterface
              E.&&. ilog E.^. InterfaceLogSubtype   E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
              E.&&. ilog E.^. InterfaceLogWrite     E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite  )
            )
      let matchUIH crits = E.or
           [ E.and $ catMaybes
             [  ilog E.^. InterfaceLogInterface E.==.    E.val  (sanitize     ifce) & Just
             , (ilog E.^. InterfaceLogSubtype   E.==.) . E.val . sanitize <$> subt
             , (ilog E.^. InterfaceLogWrite     E.==.) . E.val            <$> writ
             ]
           | (UniqueInterfaceHealth ifce subt writ) <- crits
           ]
          matchUIHnot crits = E.and
           [ E.or $ catMaybes
             [  ilog E.^. InterfaceLogInterface E.!=.    E.val  (sanitize     ifce) & Just
             , (ilog E.^. InterfaceLogSubtype   E.!=.) . E.val . sanitize <$> subt
             , (ilog E.^. InterfaceLogWrite     E.!=.) . E.val            <$> writ
             ]
           | (UniqueInterfaceHealth ifce subt writ) <- crits
           ]
      unless (null reqIfs) $ E.where_ $ matchUIH    reqIfs
      unless (null banIfs) $ E.where_ $ matchUIHnot banIfs
      -- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155
      -- unless (null banIfs) $ E.where_ $ E.not_ $ E.parens $ matchUIH banIfs -- WORKS OKAY
      -- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&.  ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD  All missing, except for "Printer" "F"
      -- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&.  ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY
      -- E.where_ $         ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||.  ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F")  -- WORKS OKAY
      let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24)  -- if no default time is set, use 3 days instead
      return (ilog, ihour)

    queryILog     :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
    queryILog     = $(E.sqlLOJproj 2 1)
    resultILog    :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
    resultILog    = _dbrOutput . _1 . _entityVal
    resultHours   :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
    resultHours   = _dbrOutput . _2 . E._unValue

    dbtRowKey     = queryILog >>> (E.^.InterfaceLogId)
    colonnade now = mconcat
        [ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
            let hours   = row ^. resultHours
                -- defmsg  = row ^? resultErrMsg
                logtime = row ^. resultILog . _interfaceLogTime
                success = row ^. resultILog . _interfaceLogSuccess
                iface   = row ^. resultILog . _interfaceLogInterface
                status  = success && (hours < 0 || now <= addHours hours logtime)
            in tellCell [(iface,status)] $
                wgtCell $ flagError status
        , sortable (Just "interface") (i18nCell MsgInterfaceName      ) $ \(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 Nothing            (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
        , sortable (Just "rows")      (i18nCell MsgTableRows          ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
        , sortable (Just "success")   (i18nCell MsgInterfaceSuccess   ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s
        , sortable Nothing            (i18nCell MsgInterfaceInfo      ) $ \(view resultILog -> ilt) -> case ilt of
            InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR  $ toWgt $ bool i "AVS-Log" $ null i
            InterfaceLog "LPR" _       _    _ _ i _ -> anchorCell PrintLogR         $ toWgt $ bool i "LPR-Log" $ null i
            InterfaceLog _     _       _    _ _ i _ -> textCell i
        ]

    dbtSorting    = mconcat
        [ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface)
        , singletonMap "subtype"   $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype)
        , singletonMap "write"     $ SortColumn $ queryILog >>> (E.^. InterfaceLogWrite)
        , singletonMap "time"      $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
        , singletonMap "rows"      $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
        , singletonMap "success"   $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
        ]
    ilvalidator   = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
    dbtFilter     = mempty
    dbtFilterUI   = mempty
    dbtStyle      = def
    dbtParams     = def
    dbtCsvEncode  = noCsvEncode
    dbtCsvDecode  = Nothing
    dbtExtraReps  = []


-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call
runInterfaceChecks :: ReqBanInterfaceHealth -> DB ()
runInterfaceChecks interfs = do
  avsInterfaceCheck interfs
  lprAckCheck interfs

maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB ()
maybeRunCheck (reqIfs,banIfs) uih act
  | null reqIfs ||      any (matchesUniqueInterfaceHealth uih) reqIfs
  , null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do
      mih <- getBy uih
      whenIsJust mih $ \eih -> do
        now <- liftIO getCurrentTime
        act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now
  | otherwise = return ()


lprAckCheck :: ReqBanInterfaceHealth -> DB ()
lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do
    unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] []
    if notNull unproc
      then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist"
      else do
        oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True]
        if oks > 0
          then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed"
          else mkLog True Nothing mempty
  where
    mkLog = logInterface' "Printer" "Acknowledge" True


avsInterfaceCheck :: ReqBanInterfaceHealth -> DB ()
avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \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 badInfo =
      logInterface' "AVS" "Synch" True (null badInfo) okRows 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) =<< mkBadInfo badRows badTime
    ((E.Value True , E.Value okRows, E.Value _okTime):_)    ->
      writeAvsSynchStats (Just okRows) mempty
    ((E.Value False, E.Value badRows, E.Value badTime):_) ->
      -- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
      writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
    _ -> return ()