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
-> Text
-> Maybe Int64
-> ProgressBarInfo
-> IO (Either Text ProgressBar)
createProgressBar SlackConfig
slackConfig Text
channel Maybe Int64
maxMessageSize pbi :: ProgressBarInfo
pbi@(ProgressBarInfo {Maybe Double
Maybe [Value]
Maybe [ProgressBarAttachment]
Maybe Text
progressBarInfoBlocks :: ProgressBarInfo -> Maybe [Value]
progressBarInfoAttachments :: ProgressBarInfo -> Maybe [ProgressBarAttachment]
progressBarInfoSize :: ProgressBarInfo -> Maybe Double
progressBarInfoBottomMessage :: ProgressBarInfo -> Maybe Text
progressBarInfoTopMessage :: ProgressBarInfo -> Maybe Text
progressBarInfoBlocks :: Maybe [Value]
progressBarInfoAttachments :: Maybe [ProgressBarAttachment]
progressBarInfoSize :: Maybe Double
progressBarInfoBottomMessage :: Maybe Text
progressBarInfoTopMessage :: Maybe Text
..}) =
  (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
SlackConfig -> Text -> Text -> [Value] -> Maybe [Value] -> m Value
postMessage SlackConfig
slackConfig Text
channel Text
message (ProgressBarInfo -> [Value]
getAttachments ProgressBarInfo
pbi) Maybe [Value]
blocks) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Text
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [i|Failed to send initial result: '#{err}'. Blocks were '#{A.encode progressBarInfoBlocks}'.|]
    Right Value
resp -> case (Value
resp forall s a. s -> Getting (First a) s a -> Maybe a
^? forall t. AsValue t => Key -> Traversal' t Value
key Key
"ts" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Text
_String, Value
resp forall s a. s -> Getting (First a) s a -> Maybe a
^? forall t. AsValue t => Key -> Traversal' t Value
key Key
"channel" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Text
_String) of
      (Just Text
ts, Just Text
chan) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text -> ProgressBar
ProgressBar Text
ts Text
chan
      (Maybe Text, Maybe Text)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [i|Couldn't find timestamp and/or channel in response|]
  where
    message :: Text
message = ProgressBarInfo -> Text
getMessage ProgressBarInfo
pbi
    blocks :: Maybe [Value]
blocks = Maybe Int64 -> [Value] -> [Value]
truncateBlocksIfNecessary Maybe Int64
maxMessageSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe [Value] -> Maybe [Value]
addMessageToBlocks Text
message Maybe [Value]
progressBarInfoBlocks

-- | Update an existing progress bar.
updateProgressBar :: SlackConfig -> Maybe Int64 -> ProgressBar -> ProgressBarInfo -> IO (Either T.Text ())
updateProgressBar :: SlackConfig
-> Maybe Int64
-> ProgressBar
-> ProgressBarInfo
-> IO (Either Text ())
updateProgressBar SlackConfig
slackConfig Maybe Int64
maxMessageSize (ProgressBar {Text
progressBarChannel :: ProgressBar -> Text
progressBarTs :: ProgressBar -> Text
progressBarChannel :: Text
progressBarTs :: Text
..}) pbi :: ProgressBarInfo
pbi@(ProgressBarInfo {Maybe Double
Maybe [Value]
Maybe [ProgressBarAttachment]
Maybe Text
progressBarInfoBlocks :: Maybe [Value]
progressBarInfoAttachments :: Maybe [ProgressBarAttachment]
progressBarInfoSize :: Maybe Double
progressBarInfoBottomMessage :: Maybe Text
progressBarInfoTopMessage :: Maybe Text
progressBarInfoBlocks :: ProgressBarInfo -> Maybe [Value]
progressBarInfoAttachments :: ProgressBarInfo -> Maybe [ProgressBarAttachment]
progressBarInfoSize :: ProgressBarInfo -> Maybe Double
progressBarInfoBottomMessage :: ProgressBarInfo -> Maybe Text
progressBarInfoTopMessage :: ProgressBarInfo -> Maybe Text
..}) =
  (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError Text m, MonadIO m) =>
SlackConfig
-> Text -> Text -> Text -> [Value] -> Maybe [Value] -> m ()
updateMessage SlackConfig
slackConfig Text
progressBarChannel Text
progressBarTs (ProgressBarInfo -> Text
getMessage ProgressBarInfo
pbi) (ProgressBarInfo -> [Value]
getAttachments ProgressBarInfo
pbi) Maybe [Value]
blocks) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left Text
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left [i|Failed to update progress bar: '#{err}'|]
    Right ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
  where
    message :: Text
message = ProgressBarInfo -> Text
getMessage ProgressBarInfo
pbi
    blocks :: Maybe [Value]
blocks = Maybe Int64 -> [Value] -> [Value]
truncateBlocksIfNecessary Maybe Int64
maxMessageSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe [Value] -> Maybe [Value]
addMessageToBlocks Text
message Maybe [Value]
progressBarInfoBlocks

-- * Internal

getMessage :: ProgressBarInfo -> T.Text
getMessage :: ProgressBarInfo -> Text
getMessage (ProgressBarInfo {Maybe Double
Maybe [Value]
Maybe [ProgressBarAttachment]
Maybe Text
progressBarInfoBlocks :: Maybe [Value]
progressBarInfoAttachments :: Maybe [ProgressBarAttachment]
progressBarInfoSize :: Maybe Double
progressBarInfoBottomMessage :: Maybe Text
progressBarInfoTopMessage :: Maybe Text
progressBarInfoBlocks :: ProgressBarInfo -> Maybe [Value]
progressBarInfoAttachments :: ProgressBarInfo -> Maybe [ProgressBarAttachment]
progressBarInfoSize :: ProgressBarInfo -> Maybe Double
progressBarInfoBottomMessage :: ProgressBarInfo -> Maybe Text
progressBarInfoTopMessage :: ProgressBarInfo -> Maybe Text
..}) =
  Text -> [Text] -> Text
T.intercalate Text
"\n" forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe Text
progressBarInfoTopMessage
                                 , Double -> Text
barSized forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
progressBarInfoSize
                                 , Maybe Text
progressBarInfoBottomMessage]

getAttachments :: ProgressBarInfo -> [A.Value]
getAttachments :: ProgressBarInfo -> [Value]
getAttachments (ProgressBarInfo {Maybe Double
Maybe [Value]
Maybe [ProgressBarAttachment]
Maybe Text
progressBarInfoBlocks :: Maybe [Value]
progressBarInfoAttachments :: Maybe [ProgressBarAttachment]
progressBarInfoSize :: Maybe Double
progressBarInfoBottomMessage :: Maybe Text
progressBarInfoTopMessage :: Maybe Text
progressBarInfoBlocks :: ProgressBarInfo -> Maybe [Value]
progressBarInfoAttachments :: ProgressBarInfo -> Maybe [ProgressBarAttachment]
progressBarInfoSize :: ProgressBarInfo -> Maybe Double
progressBarInfoBottomMessage :: ProgressBarInfo -> Maybe Text
progressBarInfoTopMessage :: ProgressBarInfo -> Maybe Text
..}) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToJSON a => a -> Value
A.toJSON) Maybe [ProgressBarAttachment]
progressBarInfoAttachments

addMessageToBlocks :: T.Text -> Maybe [A.Value] -> Maybe [A.Value]
addMessageToBlocks :: Text -> Maybe [Value] -> Maybe [Value]
addMessageToBlocks Text
_ Maybe [Value]
Nothing = forall a. Maybe a
Nothing
addMessageToBlocks Text
msg (Just [Value]
blocks) = forall a. a -> Maybe a
Just (Value
textBlock forall a. a -> [a] -> [a]
: [Value]
blocks)
  where
    textBlock :: Value
textBlock = [Pair] -> Value
A.object [
      (Key
"type", Text -> Value
A.String Text
"section")
      , (Key
"text", [Pair] -> Value
A.object [(Key
"type", Text -> Value
A.String Text
"mrkdwn")
                          , (Key
"text", Text -> Value
A.String Text
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 :: Maybe Int64 -> [Value] -> [Value]
truncateBlocksIfNecessary Maybe Int64
_ [] = []
truncateBlocksIfNecessary Maybe Int64
Nothing [Value]
xs = [Value]
xs
truncateBlocksIfNecessary (Just Int64
bytesRemaining) (Value
x:[Value]
xs) = case ByteString -> Int64
BL.length forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
A.encode Value
x of
  Int64
len | Int64
len forall a. Ord a => a -> a -> Bool
>= Int64
bytesRemaining -> []
  Int64
len -> Value
x forall a. a -> [a] -> [a]
: (Maybe Int64 -> [Value] -> [Value]
truncateBlocksIfNecessary (forall a. a -> Maybe a
Just (Int64
bytesRemaining forall a. Num a => a -> a -> a
- Int64
len forall a. Num a => a -> a -> a
- Int64
1)) [Value]
xs)

barSized :: Double -> T.Text
barSized :: Double -> Text
barSized Double
n = (Int -> Text -> Text
T.replicate Int
darkBlocks forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Int -> Char
chr Int
9608)
             forall a. Semigroup a => a -> a -> a
<> (Int -> Text -> Text
T.replicate Int
lightBlocks forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Int -> Char
chr Int
9617)
             forall a. Semigroup a => a -> a -> a
<> [i| #{roundTo 2 n}%|]
  where darkBlocks :: Int
darkBlocks = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ Double
n forall a. Num a => a -> a -> a
* Double
multiplier
        lightBlocks :: Int
lightBlocks = forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ (Double
100 forall a. Num a => a -> a -> a
- Double
n) forall a. Num a => a -> a -> a
* Double
multiplier
        multiplier :: Double
multiplier = Double
0.5

        roundTo :: (Fractional a, RealFrac a) => Integer -> a -> a
        roundTo :: forall a. (Fractional a, RealFrac a) => Integer -> a -> a
roundTo Integer
places a
num = (forall a. Num a => Integer -> a
fromInteger forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
round forall a b. (a -> b) -> a -> b
$ a
num forall a. Num a => a -> a -> a
* (a
10forall a b. (Num a, Integral b) => a -> b -> a
^Integer
places)) forall a. Fractional a => a -> a -> a
/ (a
10.0forall a b. (Fractional a, Integral b) => a -> b -> a
^^Integer
places)