content: {-# LANGUAGE OverloadedLists #-}
  
  -- | The Slack formatter shows live-updating test progress and failures by sending messages to a Slack channel.
  --
  -- Documentation can be found <https://codedownio.github.io/sandwich/docs/formatters/slack here>.
  
  module Test.Sandwich.Formatters.Slack (
    defaultSlackFormatter
    , SlackFormatter
  
    -- * Options
    , slackFormatterSlackConfig
    , slackFormatterChannel
  
    , slackFormatterTopMessage
  
    , slackFormatterMaxFailures
    , slackFormatterMaxFailureReasonLines
    , slackFormatterMaxCallStackLines
  
    , slackFormatterVisibilityThreshold
  
    , slackFormatterMaxMessageSize
  
    -- * Auxiliary types
    , SlackConfig(..)
    , SlackFormatterShowCallStacks(..)
    ) where
  
  import Control.Applicative
  import Control.Concurrent
  import Control.Concurrent.STM
  import Control.Monad
  import Control.Monad.IO.Class
  import Control.Monad.IO.Unlift
  import Control.Monad.Logger hiding (logError)
  import qualified Data.Aeson as A
  import Data.Foldable
  import Data.Function
  import qualified Data.List as L
  import qualified Data.Map as M
  import Data.Maybe
  import Data.String.Interpolate
  import qualified Data.Text as T
  import Data.Time
  import GHC.Int
  import Safe
  import Test.Sandwich
  import Test.Sandwich.Formatters.Slack.Internal.Markdown
  import Test.Sandwich.Formatters.Slack.Internal.ProgressBar
  import Test.Sandwich.Formatters.Slack.Internal.Types
  import Test.Sandwich.Internal
  import UnliftIO.Exception
  
  
  data SlackFormatter = SlackFormatter {
    slackFormatterSlackConfig :: SlackConfig
    -- ^ Slack credentials
    , slackFormatterChannel :: String
    -- ^ Slack channel on which to create the progress bar.
  
    , slackFormatterTopMessage :: Maybe String
    -- ^ Message to put above the progress bar.
    -- For example, the name of the test suite and a link to the run in the CI system.
  
    , slackFormatterMaxFailures :: Maybe Int
    -- ^ Maximum number of failures to include in a message.
    -- If too many are included, it's possible to hit Slack's request limit of 8KB, which
    -- causes the message to fail to update.
    -- Defaults to 30.
    , slackFormatterMaxFailureReasonLines :: Maybe Int
    -- ^ Maximum number of lines to devote to showing the failure reason underneath a failure.
    -- Set to 'Just 0' to disable showing failure reasons.
    , slackFormatterMaxCallStackLines :: Maybe Int
    -- ^ Maximum number of lines to devote to showing the call stack underneath a failure.
    -- Set to 'Just 0' to disable showing call stacks.
  
    , slackFormatterVisibilityThreshold :: Maybe Int
    -- ^ If present, filter the headings on failures to only include nodes whose visibility
    -- threshold is less than or equal to the value.
  
    , slackFormatterMaxMessageSize :: Maybe Int64
    -- ^ If present, make sure the messages we transmit to Slack default don't exceed this number
    -- of bytes. When a message does exceed it (probably because there are a ton of failures),
    -- start dropping blocks from the end of the message until the size is small enough.
    -- Making use of 'slackFormatterMaxFailures', 'slackFormatterMaxFailureReasonLines', and
    -- 'slackFormatterMaxCallStackLines' is a good way to avoid hitting the limit.
    } deriving (Show)
  
  defaultSlackFormatter :: SlackFormatter
  defaultSlackFormatter = SlackFormatter {
    slackFormatterSlackConfig = SlackConfig "my-password"
    , slackFormatterChannel = "slack-channel"
  
    , slackFormatterTopMessage = Just "Top message"
  
    , slackFormatterMaxFailures = Just 30
    , slackFormatterMaxFailureReasonLines = Just 5
    , slackFormatterMaxCallStackLines = Just 5
  
    , slackFormatterVisibilityThreshold = Nothing
  
    -- 8KB, although Slack might accept 16KB now?
    , slackFormatterMaxMessageSize = Just 8192
    }
  
  instance Formatter SlackFormatter where
    formatterName _ = "slack-formatter"
    runFormatter baseFormatter rts (Just clo) bc = runApp (addCommandLineOptions clo baseFormatter) rts bc
    runFormatter baseFormatter rts Nothing bc = runApp baseFormatter rts bc
    finalizeFormatter _ _ _ = return ()
  
  addCommandLineOptions :: CommandLineOptions a -> SlackFormatter -> SlackFormatter
  addCommandLineOptions (CommandLineOptions {optSlackOptions=(CommandLineSlackOptions {..})}) baseFormatter@(SlackFormatter {..}) = baseFormatter {
    slackFormatterSlackConfig = maybe slackFormatterSlackConfig (SlackConfig . T.pack) optSlackToken
    , slackFormatterChannel = fromMaybe slackFormatterChannel optSlackChannel
    , slackFormatterTopMessage = optSlackTopMessage <|> slackFormatterTopMessage
    , slackFormatterMaxFailures = optSlackMaxFailures <|> slackFormatterMaxFailures
    , slackFormatterMaxFailureReasonLines = optSlackMaxFailureReasonLines <|> slackFormatterMaxFailureReasonLines
    , slackFormatterMaxCallStackLines = optSlackMaxCallStackLines <|> slackFormatterMaxCallStackLines
    , slackFormatterVisibilityThreshold = optSlackVisibilityThreshold <|> slackFormatterVisibilityThreshold
    , slackFormatterMaxMessageSize = optSlackMaxMessageSize <|> slackFormatterMaxMessageSize
    }
  
  runApp :: (MonadUnliftIO m, MonadLogger m) => SlackFormatter -> [RunNode BaseContext] -> BaseContext -> m ()
  runApp sf@(SlackFormatter {..}) rts _bc = do
    startTime <- liftIO getCurrentTime
  
    let extractFromNode node = let RunNodeCommonWithStatus {..} = runNodeCommon node in (runTreeId, (T.pack runTreeLabel, runTreeVisibilityLevel))
    let idToLabelAndVisibilityThreshold = M.fromList $ mconcat [extractValues extractFromNode node | node <- rts]
  
    rtsFixed <- liftIO $ atomically $ mapM fixRunTree rts
    let pbi = publishTree sf idToLabelAndVisibilityThreshold 0 rtsFixed
    pb <- (liftIO $ createProgressBar slackFormatterSlackConfig (T.pack slackFormatterChannel) slackFormatterMaxMessageSize pbi) >>= \case
      Left err -> liftIO $ throwIO $ userError $ T.unpack err
      Right pb -> return pb
  
    unless (allIsDone rtsFixed) $ do
      currentFixedTree <- liftIO $ newTVarIO rtsFixed
      fix $ \loop -> do
        newFixedTree <- liftIO $ atomically $ do
          currentFixed <- readTVar currentFixedTree
          newFixed <- mapM fixRunTree rts
          when (fmap getCommons newFixed == fmap getCommons currentFixed) retry
          writeTVar currentFixedTree newFixed
          return newFixed
  
        now <- liftIO getCurrentTime
        let pbi' = publishTree sf idToLabelAndVisibilityThreshold (diffUTCTime now startTime) newFixedTree
        tryAny (liftIO $ updateProgressBar slackFormatterSlackConfig slackFormatterMaxMessageSize pb pbi') >>= \case
          Left err -> logError [i|Error updating progress bar: '#{err}'|]
          Right (Left err) -> logError [i|Inner error updating progress bar: '#{err}'. Blocks were '#{A.encode $ progressBarInfoBlocks pbi'}'|]
          Right (Right ()) -> return ()
  
        if | allIsDone newFixedTree -> do
               debug [i|All tree nodes are done, exiting!|]
               return ()
           | otherwise -> do
               liftIO $ threadDelay 100000 -- Sleep 100ms
               loop
  
  
  publishTree :: SlackFormatter -> M.Map Int (T.Text, Int) -> NominalDiffTime -> [RunNodeWithStatus context Status l t] -> ProgressBarInfo
  publishTree sf idToLabelAndVisibilityThreshold elapsed tree = pbi
    where
      pbi = ProgressBarInfo {
        progressBarInfoTopMessage = T.pack <$> (slackFormatterTopMessage sf)
        , progressBarInfoBottomMessage = Just fullBottomMessage
        , progressBarInfoSize = Just (100.0 * (fromIntegral (succeeded + pending' + failed) / (fromIntegral total)))
        , progressBarInfoAttachments = Nothing
        , progressBarInfoBlocks = Just $ case slackFormatterMaxFailures sf of
            Nothing -> mconcat blocks
            Just n -> case L.splitAt n blocks of
              (xs, []) -> mconcat xs
              (xs, rest) -> mconcat xs <> [extraFailuresBlock (L.length rest)]
        }
  
      runningMessage = headMay $ L.sort $ catMaybes $ flip concatMap tree $
        extractValues (\node -> if isRunningItBlock node then Just $ runTreeLabel $ runNodeCommon node else Nothing)
  
      fullBottomMessage = case runningMessage of
        Nothing -> bottomMessage
        Just t -> T.pack t <> "\n" <> bottomMessage
      bottomMessage = [i|#{succeeded} succeeded, #{failed} failed, #{pending'} pending, #{totalRunningTests} running of #{total} (#{formatNominalDiffTime elapsed} elapsed)|]
  
      blocks = catMaybes $ flip concatMap tree $ extractValuesControlRecurse $ \case
        -- Recurse into grouping nodes, because their failures are actually just derived from child failures
        RunNodeDescribe {} -> (True, Nothing)
        RunNodeParallel {} -> (True, Nothing)
        ((runTreeStatus . runNodeCommon) -> (Done {statusResult=(Failure (Pending {}))})) -> (False, Nothing)
        node@((runTreeStatus . runNodeCommon) -> (Done {statusResult=(Failure reason)})) | isFailedBlock node ->
          (False, Just $ singleFailureBlocks sf idToLabelAndVisibilityThreshold node reason)
        _ -> (True, Nothing)
  
      total = countWhere isItBlock tree
      succeeded = countWhere isSuccessItBlock tree
      pending' = countWhere isPendingItBlock tree
      failed = countWhere isFailedItBlock tree
      totalRunningTests = countWhere isRunningItBlock tree
      -- totalNotStartedTests = countWhere isNotStartedItBlock tree
  
  
  singleFailureBlocks :: SlackFormatter -> M.Map Int (T.Text, Int) -> RunNodeWithStatus context s l t -> FailureReason -> [A.Value]
  singleFailureBlocks sf idToLabelAndVisibilityThreshold node reason = catMaybes [
    Just $ markdownSectionWithLines [":red_circle: *" <> label <> "*"]
  
    -- Failure reason info
    , case (markdownLinesToShow, _overflowMarkdownLines) of
        ([], _) -> Nothing
        (toShow, []) -> Just $ markdownSectionWithLines toShow
        (toShow, overflow) -> Just $ markdownSectionWithLines $ addToLastLine toShow [i| (+ #{L.length overflow} more lines)|]
  
    -- Callstack info
    , case (callStackLinesToShow, _overflowCallStackLines) of
        ([], _) -> Nothing
        (toShow, []) -> Just $ markdownSectionWithLines toShow
        (toShow, overflow) -> Just $ markdownSectionWithLines $ addToLastLine toShow [i| (+ #{L.length overflow} more lines)|]
    ]
    where
      allMarkdownLines = T.lines $ toMarkdown reason
      (markdownLinesToShow, _overflowMarkdownLines) = case slackFormatterMaxFailureReasonLines sf of
        Nothing -> (allMarkdownLines, [])
        Just n -> L.splitAt n allMarkdownLines
  
      allCallStackLines = case failureCallStack reason of
        Just cs -> L.filter (not . T.null) $ T.lines $ callStackToMarkdown SlackFormatterFullCallStack cs
        _ -> []
      (callStackLinesToShow, _overflowCallStackLines) = case slackFormatterMaxCallStackLines sf of
        Nothing -> (allCallStackLines, [])
        Just n -> L.splitAt n allCallStackLines
  
      -- Show a question mark if we can't determine the label for a node (should never happen).
      -- Otherwise, use slackFormatterVisibilityThreshold to filter if provided.
      filterFn k = case M.lookup k idToLabelAndVisibilityThreshold of
        Nothing -> Just "?"
        Just (l, thresh) -> case slackFormatterVisibilityThreshold sf of
          Just maxThresh | thresh > maxThresh -> Nothing
          _ -> Just l
      label = T.intercalate ", " $ mapMaybe filterFn $ toList $ runTreeAncestors $ runNodeCommon node
  
  extraFailuresBlock :: Int -> A.Value
  extraFailuresBlock numExtraFailures = markdownSectionWithLines [[i|+ #{numExtraFailures} more failure|]]
  
  markdownBlockWithLines :: [T.Text] -> A.Value
  markdownBlockWithLines ls = A.object [("type", A.String "mrkdwn"), ("text", A.String $ T.unlines ls)]
  
  markdownSectionWithLines :: [T.Text] -> A.Value
  markdownSectionWithLines ls = A.object [("type", A.String "section"), ("text", markdownBlockWithLines ls)]
  
  addToLastLine :: [T.Text] -> T.Text -> [T.Text]
  addToLastLine [] _ = []
  addToLastLine xs toAdd = (init xs) <> [last xs <> toAdd]
  
  allIsDone :: [RunNodeFixed context] -> Bool
  allIsDone = all (isDone . runTreeStatus . runNodeCommon)
    where
      isDone :: Status -> Bool
      isDone (Done {}) = True
      isDone _ = False
  