sandwich-slack (empty) → 0.1.0.0
raw patch · 12 files changed
+719/−0 lines, 12 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, containers, lens, lens-aeson, monad-logger, mtl, safe, safe-exceptions, sandwich, sandwich-slack, stm, string-interpolate, text, time, vector, wreq
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- app/Main.hs +76/−0
- sandwich-slack.cabal +117/−0
- src/Test/Sandwich/Formatters/Internal/Core.hs +58/−0
- src/Test/Sandwich/Formatters/Internal/Markdown.hs +38/−0
- src/Test/Sandwich/Formatters/Internal/ProgressBar.hs +87/−0
- src/Test/Sandwich/Formatters/Internal/Types.hs +49/−0
- src/Test/Sandwich/Formatters/Slack.hs +256/−0
- test/Spec.hs +2/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for sandwich-slack++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Tom McLaughlin (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tom McLaughlin nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# sandwich-slack
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Concurrent+import Control.Monad.IO.Class+import Data.Time+import GHC.Stack+import Test.Sandwich+import Test.Sandwich.Formatters.Print+import Test.Sandwich.Formatters.Slack+import Test.Sandwich.Formatters.TerminalUI++simple :: TopSpec+simple = parallel $ do+ it "does the thing 1" sleepThenSucceed+ it "does the thing 2" sleepThenSucceed+ it "does the thing 3" deepSleepThenFail+ describe "should happen sequentially" $ do+ it "sequential 1" sleepThenSucceed+ it "sequential 2" sleepThenFail+ it "sequential 3" sleepThenSucceed+ it "does the thing 4" deepSleepThenFail+ it "does the thing 5" sleepThenSucceed+ it "does the thing 6" sleepThenSucceed+++slackFormatter = defaultSlackFormatter {+ slackFormatterSlackConfig = SlackConfig ""+ , slackFormatterTopMessage = Just "Top message"+ , slackFormatterChannel = "test-channel"++ , slackFormatterMaxFailures = Just 2+ , slackFormatterMaxFailureReasonLines = Just 1+ , slackFormatterMaxCallStackLines = Just 3++ , slackFormatterVisibilityThreshold = Just 50+ }++baseFormatter = SomeFormatter defaultTerminalUIFormatter+-- baseFormatter = SomeFormatter defaultPrintFormatter++main :: IO ()+main = runSandwich options simple+ where+ options = defaultOptions {+ optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime)+ , optionsFormatters = [baseFormatter, SomeFormatter slackFormatter]+ }++-- * Util++sleepThenSucceed :: (HasCallStack) => ExampleM context ()+sleepThenSucceed = do+ -- liftIO $ threadDelay (2 * 10^1)+ liftIO $ threadDelay (2 * 10^5)+ -- liftIO $ threadDelay (1 * 10^6)+ -- liftIO $ threadDelay (3 * 10^6)++sleepThenFail :: (HasCallStack) => ExampleM context ()+sleepThenFail = do+ -- liftIO $ threadDelay (2 * 10^1)+ liftIO $ threadDelay (2 * 10^5)+ -- liftIO $ threadDelay (1 * 10^6)+ -- liftIO $ threadDelay (3 * 10^6)+ 2 `shouldBe` 3+++deepSleepThenFail :: (HasCallStack) => ExampleM context ()+deepSleepThenFail = deepSleepThenFail2++deepSleepThenFail2 :: (HasCallStack) => ExampleM context ()+deepSleepThenFail2 = deepSleepThenFail3++deepSleepThenFail3 :: (HasCallStack) => ExampleM context ()+deepSleepThenFail3 = sleepThenFail
+ sandwich-slack.cabal view
@@ -0,0 +1,117 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: d7320880fc7447510af33486a1a9fc622e995d778acdafb73e966bc9b2fb67ec++name: sandwich-slack+version: 0.1.0.0+synopsis: Slack integration for Sandwich+description: Please see the README on GitHub at <https://github.com/codedownio/sandwich-slack#readme>+category: Testing+homepage: https://github.com/codedownio/sandwich-slack#readme+bug-reports: https://github.com/codedownio/sandwich-slack/issues+author: Tom McLaughlin+maintainer: tom@codedown.io+copyright: 2021 Tom McLaughlin+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/codedownio/sandwich-slack++library+ exposed-modules:+ Test.Sandwich.Formatters.Internal.Core+ Test.Sandwich.Formatters.Internal.Markdown+ Test.Sandwich.Formatters.Internal.ProgressBar+ Test.Sandwich.Formatters.Internal.Types+ Test.Sandwich.Formatters.Slack+ other-modules:+ Paths_sandwich_slack+ hs-source-dirs:+ src+ ghc-options: -W+ build-depends:+ aeson+ , base <=4.14+ , bytestring+ , containers+ , lens+ , lens-aeson+ , monad-logger+ , mtl+ , safe+ , safe-exceptions+ , sandwich+ , stm+ , string-interpolate+ , text+ , time+ , vector+ , wreq+ default-language: Haskell2010++executable sandwich-slack-exe+ main-is: Main.hs+ other-modules:+ Paths_sandwich_slack+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , base <=4.14+ , bytestring+ , containers+ , lens+ , lens-aeson+ , monad-logger+ , mtl+ , safe+ , safe-exceptions+ , sandwich+ , sandwich-slack+ , stm+ , string-interpolate+ , text+ , time+ , vector+ , wreq+ default-language: Haskell2010++test-suite sandwich-slack-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_sandwich_slack+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , base <=4.14+ , bytestring+ , containers+ , lens+ , lens-aeson+ , monad-logger+ , mtl+ , safe+ , safe-exceptions+ , sandwich+ , sandwich-slack+ , stm+ , string-interpolate+ , text+ , time+ , vector+ , wreq+ default-language: Haskell2010
+ src/Test/Sandwich/Formatters/Internal/Core.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Sandwich.Formatters.Internal.Core where++import Control.Lens hiding ((??))+import Control.Monad.Except+import Data.Aeson+import qualified Data.Aeson as A+import Data.Aeson.Lens+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import qualified Network.Wreq as W+import Test.Sandwich.Formatters.Internal.Types++postMessage :: (MonadError T.Text m, MonadIO m) => SlackConfig -> ChannelName -> T.Text -> [A.Value] -> Maybe [A.Value] -> m Value+postMessage conf cid msg as maybeBlocks =+ makeSlackCall conf "chat.postMessage" $ A.object $ [+ ("token", A.String $ slackApiToken conf)+ , ("channel", A.String cid)+ , ("text", A.String msg)+ , ("attachments", A.Array $ V.fromList as)+ , ("as_user", A.Bool True)+ ]+ <> (case maybeBlocks of Nothing -> []; Just blocks -> [("blocks", A.Array $ V.fromList blocks)])++updateMessage :: (MonadError T.Text m, MonadIO m) => SlackConfig -> ChannelName -> T.Text -> T.Text -> [A.Value] -> Maybe [A.Value] -> m ()+updateMessage conf cid ts msg as maybeBlocks =+ void $ makeSlackCall conf "chat.update" $ A.object $ [+ ("token", A.String $ slackApiToken conf)+ , ("channel", A.String cid)+ , ("text", A.String msg)+ , ("attachments", A.Array $ V.fromList as)+ , ("as_user", A.Bool True)+ , ("ts", A.String ts)+ ]+ <> (case maybeBlocks of Nothing -> []; Just blocks -> [("blocks", A.Array $ V.fromList blocks)])++encode' :: A.ToJSON a => a -> T.Text+encode' = T.decodeUtf8 . BL.toStrict . encode++makeSlackCall :: (MonadError T.Text m, MonadIO m) => SlackConfig -> String -> A.Value -> m Value+makeSlackCall conf method body = do+ let url = "https://slack.com/api/" ++ method+ let opts = W.defaults & (W.header "Authorization" .~ ["Bearer " <> T.encodeUtf8 (slackApiToken conf)])+ rawResp <- liftIO $ W.postWith opts url (body)+ resp <- rawResp ^? W.responseBody . _Value ?? "Couldn't parse response"+ case resp ^? key "ok" . _Bool of+ Just True -> return resp+ Just False -> throwError $ resp ^. key "error" . _String+ Nothing -> throwError "Couldn't parse key 'ok' from response"++infixl 7 ??+(??) :: MonadError e m => Maybe a -> e -> m a+x ?? e = maybe (throwError e) return x
+ src/Test/Sandwich/Formatters/Internal/Markdown.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Sandwich.Formatters.Internal.Markdown where++import Data.Function+import qualified Data.List as L+import Data.String.Interpolate+import qualified Data.Text as T+import GHC.Stack+import Test.Sandwich+import Test.Sandwich.Formatters.Internal.Types+++toMarkdown :: FailureReason -> T.Text+toMarkdown (Reason {..}) = T.pack failureReason+toMarkdown (ExpectedButGot {..}) = [i|Expected *#{failureValue1}* but got *#{failureValue2}*|]+toMarkdown (DidNotExpectButGot {..}) = [i|Did not expect *#{failureValue1}*|]+toMarkdown (GotException {..}) = case failureMessage of+ Just msg -> [i|Got exception (_#{msg}_): #{failureException}|]+ Nothing -> [i|Got exception (no message): #{failureException}|]+toMarkdown (Pending {..}) = "Example was pending"+toMarkdown (GetContextException {..}) = [i|Context exception: #{failureException}|]+toMarkdown (GotAsyncException {..}) = case failureMessage of+ Just msg -> [i|Got async exception (_#{msg}_): #{failureAsyncException}|]+ Nothing -> [i|Got async exception: #{failureAsyncException}|]++callStackToMarkdown :: SlackFormatterShowCallStacks -> CallStack -> T.Text+callStackToMarkdown SlackFormatterNoCallStacks _cs = ""+callStackToMarkdown (SlackFormatterTopNCallStackFrames n) cs = "\n\n" <> showCallStack (fromCallSiteList $ L.take n $ getCallStack cs)+callStackToMarkdown SlackFormatterFullCallStack cs = "\n\n" <> showCallStack cs++showCallStack (getCallStack -> rows) = ["> *" <> (T.pack name) <> "*, called at "+ <> [i|_#{srcLocPackage}_:*#{srcLocFile}*:#{srcLocStartLine}:#{srcLocStartCol}|]+ | (name, SrcLoc {..}) <- rows]+ & T.intercalate "\n"
+ src/Test/Sandwich/Formatters/Internal/ProgressBar.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Sandwich.Formatters.Internal.ProgressBar where+++import Control.Lens hiding ((??))+import Control.Monad.Except+import qualified Data.Aeson as A+import Data.Aeson.Lens+import qualified Data.ByteString.Lazy as BL+import Data.Char+import Data.Maybe+import Data.String.Interpolate+import qualified Data.Text as T+import GHC.Int+import Test.Sandwich.Formatters.Internal.Core+import Test.Sandwich.Formatters.Internal.Types++-- | Create a progress bar message on the given channel.+-- Returns a 'ProgressBar' which can be used to update the message by calling 'updateProgressBar'.+createProgressBar :: SlackConfig -> ChannelName -> Maybe Int64 -> ProgressBarInfo -> IO (Either T.Text ProgressBar)+createProgressBar slackConfig channel maxMessageSize pbi@(ProgressBarInfo {..}) =+ (runExceptT $ postMessage slackConfig channel message (getAttachments pbi) blocks) >>= \case+ Left err -> return $ Left [i|Failed to send initial result: '#{err}'. Blocks were '#{A.encode progressBarInfoBlocks}'.|]+ Right resp -> case (resp ^? key "ts" . _String, resp ^? key "channel" . _String) of+ (Just ts, Just chan) -> return $ Right $ ProgressBar ts chan+ _ -> return $ Left [i|Couldn't find timestamp and/or channel in response|]+ where+ message = getMessage pbi+ blocks = truncateBlocksIfNecessary maxMessageSize <$> addMessageToBlocks message progressBarInfoBlocks++-- | Update an existing progress bar.+updateProgressBar :: SlackConfig -> Maybe Int64 -> ProgressBar -> ProgressBarInfo -> IO (Either T.Text ())+updateProgressBar slackConfig maxMessageSize (ProgressBar {..}) pbi@(ProgressBarInfo {..}) =+ (runExceptT $ updateMessage slackConfig progressBarChannel progressBarTs (getMessage pbi) (getAttachments pbi) blocks) >>= \case+ Left err -> return $ Left [i|Failed to update progress bar: '#{err}'|]+ Right _ -> return $ Right ()+ where+ message = getMessage pbi+ blocks = truncateBlocksIfNecessary maxMessageSize <$> addMessageToBlocks message progressBarInfoBlocks++-- * Internal++getMessage :: ProgressBarInfo -> T.Text+getMessage (ProgressBarInfo {..}) =+ T.intercalate "\n" $ catMaybes [progressBarInfoTopMessage+ , barSized <$> progressBarInfoSize+ , progressBarInfoBottomMessage]++getAttachments :: ProgressBarInfo -> [A.Value]+getAttachments (ProgressBarInfo {..}) = maybe [] (fmap A.toJSON) progressBarInfoAttachments++addMessageToBlocks :: T.Text -> Maybe [A.Value] -> Maybe [A.Value]+addMessageToBlocks _ Nothing = Nothing+addMessageToBlocks msg (Just blocks) = Just (textBlock : blocks)+ where+ textBlock = A.object [+ ("type", A.String "section")+ , ("text", A.object [("type", A.String "mrkdwn")+ , ("text", A.String msg)])+ ]++-- | This is kind of wasteful, because it requires encoding every block to get the lengths.+-- It's also a little rough because it won't exactly match the length of the encoded blocks list+-- (with brackets etc.) and doesn't take into account the rest of the message. Hopefully it's close+-- enough to correct, but TODO find a way to do the truncating efficiently as part of encoding+-- the message onto the wire.+truncateBlocksIfNecessary :: Maybe Int64 -> [A.Value] -> [A.Value]+truncateBlocksIfNecessary _ [] = []+truncateBlocksIfNecessary Nothing xs = xs+truncateBlocksIfNecessary (Just bytesRemaining) (x:xs) = case BL.length $ A.encode x of+ len | len >= bytesRemaining -> []+ len -> x : (truncateBlocksIfNecessary (Just (bytesRemaining - len - 1)) xs)++barSized :: Double -> T.Text+barSized n = (T.replicate darkBlocks $ T.singleton $ chr 9608)+ <> (T.replicate lightBlocks $ T.singleton $ chr 9617)+ <> [i| #{roundTo 2 n}%|]+ where darkBlocks = round $ n * multiplier+ lightBlocks = round $ (100 - n) * multiplier+ multiplier = 0.5++ roundTo :: (Fractional a, RealFrac a) => Integer -> a -> a+ roundTo places num = (fromInteger $ round $ num * (10^places)) / (10.0^^places)
+ src/Test/Sandwich/Formatters/Internal/Types.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Sandwich.Formatters.Internal.Types where++import qualified Data.Aeson as A+import qualified Data.Text as T++-- | Configuration options needed to connect to the Slack API+newtype SlackConfig = SlackConfig { slackApiToken :: T.Text+ -- ^ Slack API token+ } deriving (Show)++-- | The state of a progress bar message.+data ProgressBarInfo = ProgressBarInfo { progressBarInfoTopMessage :: Maybe T.Text+ -- ^ Message to show above the progress bar+ , progressBarInfoBottomMessage :: Maybe T.Text+ -- ^ Message to show below the progress bar+ , progressBarInfoSize :: Maybe Double+ -- ^ Size of the progress bar, a 'Double' from 0 to 100+ , progressBarInfoAttachments :: Maybe [ProgressBarAttachment]+ -- ^ Slack attachments for the message+ , progressBarInfoBlocks :: Maybe [A.Value]+ -- ^ Structured blocks, using the <https://api.slack.com/block-kit Slack Block Kit>+ }++-- | A Slack attachment.+data ProgressBarAttachment = ProgressBarAttachment { progressBarAttachmentText :: T.Text+ -- ^ Attachment text+ , progressBarAttachmentColor :: T.Text+ -- ^ Attachment color+ }+instance A.ToJSON ProgressBarAttachment+ where toJSON (ProgressBarAttachment {..}) = A.object [("text", A.String progressBarAttachmentText)+ , ("color", A.String progressBarAttachmentColor)]++-- | An opaque type representing an existing Slack message.+data ProgressBar = ProgressBar { progressBarTs :: T.Text+ , progressBarChannel :: T.Text }++data SlackFormatterShowCallStacks =+ SlackFormatterNoCallStacks+ -- ^ Don't include callstacks in failure messages+ | SlackFormatterTopNCallStackFrames Int+ -- ^ Include the top N stack frames+ | SlackFormatterFullCallStack+ -- ^ Include the full callstack++type ChannelName = T.Text
+ src/Test/Sandwich/Formatters/Slack.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}++module Test.Sandwich.Formatters.Slack (+ SlackFormatter+ , SlackConfig(..)++ , defaultSlackFormatter++ , slackFormatterSlackConfig+ , slackFormatterChannel++ , slackFormatterTopMessage++ , slackFormatterMaxFailures+ , slackFormatterMaxFailureReasonLines+ , slackFormatterMaxCallStackLines++ , slackFormatterVisibilityThreshold++ , slackFormatterMaxMessageSize++ , SlackFormatterShowCallStacks(..)+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+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.Internal.Markdown+import Test.Sandwich.Formatters.Internal.ProgressBar+import Test.Sandwich.Formatters.Internal.Types+import Test.Sandwich.Internal+import Test.Sandwich.Internal.Formatters+++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.+ }++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 :: (MonadIO m, MonadCatch 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 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 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 numExtraFailures = markdownSectionWithLines [[i|+ #{numExtraFailures} more failure|]]++markdownBlockWithLines ls = A.object [("type", A.String "mrkdwn"), ("text", A.String $ T.unlines ls)]++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
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"