packages feed

sandwich-slack 0.1.0.3 → 0.1.0.4

raw patch · 12 files changed

+269/−249 lines, 12 files

Files

− README.md 
@@ -1,1 +0,0 @@-# sandwich-slack
sandwich-slack.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d446a77761b7441448561836b119c54e0f5f6fb6eb49a42e8d04b74a9ae208d1+-- hash: 87b67607e636cc36cd53424fdd2c45e855177f019d67d230fd8d6d77bdbc6f3f  name:           sandwich-slack-version:        0.1.0.3+version:        0.1.0.4 synopsis:       Sandwich integration with Slack description:    Please see the documentation at <https://codedownio.github.io/sandwich/docs/extensions/sandwich-slack> category:       Testing@@ -20,7 +20,6 @@ license-file:   LICENSE build-type:     Simple extra-source-files:-    README.md     CHANGELOG.md  source-repository head@@ -29,12 +28,13 @@  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+      Test.Sandwich.Formatters.Slack.Internal   other-modules:+      Test.Sandwich.Formatters.Slack.Internal.Core+      Test.Sandwich.Formatters.Slack.Internal.Markdown+      Test.Sandwich.Formatters.Slack.Internal.ProgressBar+      Test.Sandwich.Formatters.Slack.Internal.Types       Paths_sandwich_slack   hs-source-dirs:       src
− src/Test/Sandwich/Formatters/Internal/Core.hs 
@@ -1,58 +0,0 @@-{-# 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 
@@ -1,38 +0,0 @@-{-# 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 
@@ -1,87 +0,0 @@-{-# 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 
@@ -1,49 +0,0 @@-{-# 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
@@ -7,12 +7,12 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} -module Test.Sandwich.Formatters.Slack (-  SlackFormatter-  , SlackConfig(..)+-- | The Slack formatter shows live-updating test progress and failures by sending messages to a Slack channel. -  , defaultSlackFormatter+module Test.Sandwich.Formatters.Slack (+  defaultSlackFormatter +  -- * Options   , slackFormatterSlackConfig   , slackFormatterChannel @@ -26,6 +26,8 @@    , slackFormatterMaxMessageSize +  -- * Auxiliary types+  , SlackConfig(..)   , SlackFormatterShowCallStacks(..)   ) where @@ -48,11 +50,10 @@ 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.Formatters.Slack.Internal.Markdown+import Test.Sandwich.Formatters.Slack.Internal.ProgressBar+import Test.Sandwich.Formatters.Slack.Internal.Types import Test.Sandwich.Internal-import Test.Sandwich.Internal.Formatters   data SlackFormatter = SlackFormatter {@@ -87,7 +88,7 @@   -- 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 {
+ src/Test/Sandwich/Formatters/Slack/Internal.hs view
@@ -0,0 +1,12 @@++module Test.Sandwich.Formatters.Slack.Internal (+   module Test.Sandwich.Formatters.Slack.Internal.Core+  , module Test.Sandwich.Formatters.Slack.Internal.Markdown+  , module Test.Sandwich.Formatters.Slack.Internal.ProgressBar+  , module Test.Sandwich.Formatters.Slack.Internal.Types+  ) where++import Test.Sandwich.Formatters.Slack.Internal.Core+import Test.Sandwich.Formatters.Slack.Internal.Markdown+import Test.Sandwich.Formatters.Slack.Internal.ProgressBar+import Test.Sandwich.Formatters.Slack.Internal.Types
+ src/Test/Sandwich/Formatters/Slack/Internal/Core.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Sandwich.Formatters.Slack.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.Slack.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/Slack/Internal/Markdown.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Sandwich.Formatters.Slack.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.Slack.Internal.Types+++toMarkdown :: FailureReason -> T.Text+toMarkdown (Reason {..}) = T.pack failureReason+toMarkdown (ChildrenFailed {failureNumChildren=n}) = [i|#{n} #{if n == 1 then ("child" :: T.Text) else "children"} failed|]+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/Slack/Internal/ProgressBar.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Sandwich.Formatters.Slack.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.Slack.Internal.Core+import Test.Sandwich.Formatters.Slack.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/Slack/Internal/Types.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Sandwich.Formatters.Slack.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