diff --git a/main/cli.hs b/main/cli.hs new file mode 100644 --- /dev/null +++ b/main/cli.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} + + +-- base +import Control.Exception (throwIO) +import Control.Monad.IO.Class (liftIO) +import Data.Functor (void) +import System.Environment (getEnv) +import System.Exit (die) +import System.IO (hPutStrLn, stderr) +import Text.Read (readMaybe) + +-- butcher +import UI.Butcher.Monadic + +-- bytestring +import qualified Data.ByteString.Lazy.Char8 as BL + +-- monad-loops +import Control.Monad.Loops (iterateUntil) + +-- mtl +import Control.Monad.Reader (runReaderT) + +-- pretty-simple +import Text.Pretty.Simple (pPrint, pShow) + +-- slack-web +import qualified Web.Slack as Slack +import qualified Web.Slack.Common as Slack +import qualified Web.Slack.Conversation as SlackConversation + +-- text +import qualified Data.Text as Text +import qualified Data.Text.Lazy as TextLazy + +-- time +import Data.Time.Clock (getCurrentTime, nominalDay, addUTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) + +-- servant-client-core +import Servant.Client.Core (ClientError(..), Response, ResponseF(..)) + + +main :: IO () +main = do + apiConfig <- Slack.mkSlackConfig . Text.pack =<< getEnv "SLACK_API_TOKEN" + mainFromCmdParserWithHelpDesc $ \helpDesc -> do + addHelpCommand helpDesc + addCmd "conversations.list" . addCmdImpl $ do + let listReq = SlackConversation.ListReq + { SlackConversation.listReqExcludeArchived = Just True + , SlackConversation.listReqTypes = + [ SlackConversation.PublicChannelType + , SlackConversation.PrivateChannelType + , SlackConversation.MpimType + , SlackConversation.ImType + ] + } + Slack.conversationsList listReq + `runReaderT` apiConfig >>= \case + Right (SlackConversation.ListRsp cs) -> do + pPrint cs + Left err -> do + peepInResponseBody err + hPutStrLn stderr "Error when fetching the list of conversations:" + die . TextLazy.unpack $ pShow err + + addCmd "conversations.history" $ do + conversationId <- + Slack.ConversationId . Text.pack + <$> addParamString "CONVERSATION_ID" (paramHelpStr "ID of the conversation to fetch") + getsAll <- addSimpleBoolFlag "A" ["all"] (flagHelpStr "Get all available messages in the channel") + addCmdImpl $ + if getsAll + then do + (`runReaderT` apiConfig) $ do + fetchPage <- Slack.conversationsHistoryAll $ (SlackConversation.mkHistoryReq conversationId) { SlackConversation.historyReqCount = 2 } + void . iterateUntil null $ do + result <- either (liftIO . throwIO) return =<< fetchPage + liftIO $ pPrint result + return result + else do + nowUtc <- getCurrentTime + let now = Slack.mkSlackTimestamp nowUtc + thirtyDaysAgo = Slack.mkSlackTimestamp $ addUTCTime (nominalDay * negate 30) nowUtc + histReq = SlackConversation.HistoryReq + { SlackConversation.historyReqChannel = conversationId + , SlackConversation.historyReqCount = 5 + , SlackConversation.historyReqLatest = Just now + , SlackConversation.historyReqOldest = Just thirtyDaysAgo + , SlackConversation.historyReqInclusive = True + , SlackConversation.historyReqCursor = Nothing + } + Slack.conversationsHistory histReq + `runReaderT` apiConfig >>= \case + Right rsp -> + pPrint rsp + Left err -> do + peepInResponseBody err + hPutStrLn stderr "Error when fetching the history of conversations:" + die . TextLazy.unpack $ pShow err + + addCmd "conversations.replies" $ do + conversationId <- + Slack.ConversationId . Text.pack + <$> addParamString "CONVERSATION_ID" (paramHelpStr "ID of the conversation to fetch") + threadTimeStampStr <- addParamString "TIMESTAMP" (paramHelpStr "Timestamp of the thread to fetch") + let ethreadTimeStamp = Slack.timestampFromText $ Text.pack threadTimeStampStr + pageSize <- addParamRead "PAGE_SIZE" (paramHelpStr "How many messages to get by a request.") + addCmdImpl $ do + -- NOTE: butcher's CmdParser isn't a MonadFail + threadTimeStamp <- either + (\emsg -> fail $ "Invalid timestamp " ++ show threadTimeStampStr ++ ": " ++ emsg) + return + ethreadTimeStamp + nowUtc <- getCurrentTime + let now = Slack.mkSlackTimestamp nowUtc + tenDaysAgo = Slack.mkSlackTimestamp $ addUTCTime (nominalDay * negate 10) nowUtc + req = (SlackConversation.mkRepliesReq conversationId threadTimeStamp) + { SlackConversation.repliesReqLimit = pageSize + , SlackConversation.repliesReqLatest = Just now + , SlackConversation.repliesReqOldest = Just tenDaysAgo + } + (`runReaderT` apiConfig) $ do + fetchPage <- Slack.repliesFetchAll req + void . iterateUntil null $ do + result <- either (liftIO . throwIO) return =<< fetchPage + liftIO $ pPrint result + return result + + +peepInResponseBody err = do + {- Uncomment these lines when you want to see the JSON in the reponse body. + case err of + Slack.ServantError (DecodeFailure _ res) -> + BL.putStrLn $ responseBody res + _ -> return () + -} + return () diff --git a/slack-web.cabal b/slack-web.cabal --- a/slack-web.cabal +++ b/slack-web.cabal @@ -1,5 +1,5 @@ name: slack-web -version: 0.2.0.12 +version: 0.2.1.0 build-type: Simple cabal-version: 1.20 @@ -36,23 +36,29 @@ Web.Slack.Channel Web.Slack.Chat Web.Slack.Common + Web.Slack.Conversation Web.Slack.Group Web.Slack.Im Web.Slack.MessageParser + Web.Slack.Types Web.Slack.User + Web.Slack.Pager other-modules: - Web.Slack.Types Web.Slack.Util build-depends: aeson >= 1.0 && < 1.5 - , base >= 4.11 && < 4.14 + , base >= 4.11 && < 4.15 + , scientific , containers + , deepseq + , unordered-containers + , hashable , http-api-data >= 0.3 && < 0.5 , http-client >= 0.5 && < 0.7 , http-client-tls >= 0.3 && < 0.4 - , servant >= 0.12 && < 0.17 - , servant-client >= 0.12 && < 0.17 - , servant-client-core >= 0.12 && < 0.17 + , servant >= 0.12 && < 0.18 + , servant-client >= 0.12 && < 0.18 + , servant-client-core >= 0.12 && < 0.18 , text >= 1.2 && < 1.3 , transformers , mtl @@ -71,27 +77,53 @@ main-is: Spec.hs hs-source-dirs: - src, tests + tests type: exitcode-stdio-1.0 other-modules: - Web.Slack.MessageParser + Web.Slack.PagerSpec Web.Slack.MessageParserSpec - Web.Slack.Types + Web.Slack.ConversationSpec build-depends: - base >= 4.11 && < 4.14 - , containers + base + , slack-web , aeson - , errors + , fakepull , hspec - , http-api-data , text , time - , megaparsec >= 5.0 && < 9 + , QuickCheck + , quickcheck-instances default-language: Haskell2010 ghc-options: -Wall + +flag cli + description: Build a CLI client for testing. + default: False + manual: True + +executable slack-web-cli + if flag(cli) + buildable: True + else + buildable: False + hs-source-dirs: main + main-is: cli.hs + build-depends: + base + , slack-web + , butcher + , bytestring + , monad-loops + , mtl + , pretty-simple + , text + , time + , servant-client-core + default-language: + Haskell2010 source-repository head type: git diff --git a/src/Web/Slack.hs b/src/Web/Slack.hs --- a/src/Web/Slack.hs +++ b/src/Web/Slack.hs @@ -20,11 +20,16 @@ , authTest , chatPostMessage , channelsCreate + , conversationsList + , conversationsHistory + , conversationsHistoryAll + , conversationsReplies , channelsList , channelsHistory , groupsHistory , groupsList , historyFetchAll + , repliesFetchAll , imHistory , imList , mpimList @@ -34,6 +39,7 @@ , userLookupByEmail , authenticateReq , Response + , LoadPage , HasManager(..) , HasToken(..) ) @@ -51,7 +57,7 @@ import qualified Data.Map as Map -- error -import Control.Error (lastZ, isNothing) +import Control.Error (lastZ) -- http-client import Network.HTTP.Client (Manager, newManager) @@ -72,12 +78,14 @@ -- slack-web import qualified Web.Slack.Api as Api import qualified Web.Slack.Auth as Auth +import qualified Web.Slack.Conversation as Conversation import qualified Web.Slack.Channel as Channel import qualified Web.Slack.Chat as Chat import qualified Web.Slack.Common as Common import qualified Web.Slack.Im as Im import qualified Web.Slack.Group as Group import qualified Web.Slack.User as User +import Web.Slack.Pager -- text import Data.Text (Text) @@ -119,7 +127,6 @@ data ResponseSlackError = ResponseSlackError Text deriving (Eq, Show) -type Response a = Either Common.SlackClientError a -- | -- Internal type! @@ -147,6 +154,21 @@ :> AuthProtect "token" :> Post '[JSON] (ResponseJSON Auth.TestRsp) :<|> + "conversations.list" + :> AuthProtect "token" + :> ReqBody '[FormUrlEncoded] Conversation.ListReq + :> Post '[JSON] (ResponseJSON Conversation.ListRsp) + :<|> + "conversations.history" + :> AuthProtect "token" + :> ReqBody '[FormUrlEncoded] Conversation.HistoryReq + :> Post '[JSON] (ResponseJSON Conversation.HistoryRsp) + :<|> + "conversations.replies" + :> AuthProtect "token" + :> ReqBody '[FormUrlEncoded] Conversation.RepliesReq + :> Post '[JSON] (ResponseJSON Conversation.HistoryRsp) + :<|> "channels.create" :> AuthProtect "token" :> ReqBody '[FormUrlEncoded] Channel.CreateReq @@ -237,9 +259,71 @@ :: AuthenticatedRequest (AuthProtect "token") -> ClientM (ResponseJSON Auth.TestRsp) +-- | +-- +-- Retrieve conversations list. +-- +-- +conversationsList + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => Conversation.ListReq + -> m (Response Conversation.ListRsp) +conversationsList listReq = do + authR <- mkSlackAuthenticateReq + run (conversationsList_ authR listReq) + +conversationsList_ + :: AuthenticatedRequest (AuthProtect "token") + -> Conversation.ListReq + -> ClientM (ResponseJSON Conversation.ListRsp) + + -- | -- +-- Retrieve ceonversation history. +-- Consider using 'historyFetchAll' in combination with this function. +-- +-- + +conversationsHistory + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => Conversation.HistoryReq + -> m (Response Conversation.HistoryRsp) +conversationsHistory histReq = do + authR <- mkSlackAuthenticateReq + run (conversationsHistory_ authR histReq) + +conversationsHistory_ + :: AuthenticatedRequest (AuthProtect "token") + -> Conversation.HistoryReq + -> ClientM (ResponseJSON Conversation.HistoryRsp) + + +-- | +-- +-- Retrieve replies of a conversation. +-- Consider using 'repliesFetchAll' if you want to get entire replies +-- of a conversation. +-- +-- + +conversationsReplies + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => Conversation.RepliesReq + -> m (Response Conversation.HistoryRsp) +conversationsReplies repliesReq = do + authR <- mkSlackAuthenticateReq + run (conversationsReplies_ authR repliesReq) + +conversationsReplies_ + :: AuthenticatedRequest (AuthProtect "token") + -> Conversation.RepliesReq + -> ClientM (ResponseJSON Conversation.HistoryRsp) + + +-- | +-- -- Create a channel. -- -- @@ -496,7 +580,7 @@ historyFetchAll :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) => (Common.HistoryReq -> m (Response Common.HistoryRsp)) - -- ^ The request to make. Can be for instance 'mpimHistory', 'channelsHistory'... + -- ^ The request to make. Can be for instance 'conversationsHistory'... -> Text -- ^ The channel name to query -> Int @@ -508,25 +592,69 @@ -> m (Response Common.HistoryRsp) -- ^ A list merging all the history records that were fetched -- through the individual queries. -historyFetchAll makeReq channel count oldest latest = do - -- From slack apidoc: If there are more than 100 messages between - -- the two timestamps then the messages returned are the ones closest to latest. - -- In most cases an application will want the most recent messages - -- and will page backward from there. - -- - -- for reference (does not apply here) => If oldest is provided but not - -- latest then the messages returned are those closest to oldest, - -- allowing you to page forward through history if desired. - rsp <- makeReq $ Common.HistoryReq channel count (Just latest) (Just oldest) False - case rsp of - Left _ -> return rsp - Right (Common.HistoryRsp msgs hasMore) -> do - let oldestReceived = Common.messageTs <$> lastZ msgs - if not hasMore || isNothing oldestReceived - then return rsp - else mergeResponses msgs <$> - historyFetchAll makeReq channel count oldest (fromJust oldestReceived) +historyFetchAll makeReq channel count = + commonHistoryFetchAll $ \latest oldest -> + makeReq . Common.HistoryReq channel count latest oldest + +-- | Returns an action to send a request to get the history of a conversation. +-- +-- To fetch all messages in the conversation, run the returned 'LoadPage' action +-- repeatedly until it returns an empty list. +conversationsHistoryAll + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => Conversation.HistoryReq + -- ^ The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. + -> m (LoadPage m [Common.Message]) + -- ^ An action which returns a new page of messages every time called. + -- If there are no pages anymore, it returns an empty list. +conversationsHistoryAll = conversationsHistoryAllBy conversationsHistory + + +-- | Returns an action to send a request to get the replies of a conversation. +-- +-- To fetch all replies in the conversation, run the returned 'LoadPage' action +-- repeatedly until it returns an empty list. +-- +-- *NOTE*: The conversations.replies endpoint always returns the first message +-- of the thread. So every page returned by the 'LoadPage' action includes +-- the first message of the thread. You should drop it if you want to +-- collect messages in a thread without duplicates. +repliesFetchAll + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => Conversation.RepliesReq + -- ^ The first request to send. _NOTE_: 'Conversation.repliesReqCursor' is silently ignored. + -> m (LoadPage m [Common.Message]) + -- ^ An action which returns a new page of messages every time called. + -- If there are no pages anymore, it returns an empty list. +repliesFetchAll = repliesFetchAllBy conversationsReplies + + +commonHistoryFetchAll + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => (Maybe Common.SlackTimestamp -> Maybe Common.SlackTimestamp -> Bool -> m (Response Common.HistoryRsp)) + -> Common.SlackTimestamp + -> Common.SlackTimestamp + -> m (Response Common.HistoryRsp) +commonHistoryFetchAll makeReq oldest latest = do + -- From slack apidoc: If there are more than 100 messages between + -- the two timestamps then the messages returned are the ones closest to latest. + -- In most cases an application will want the most recent messages + -- and will page backward from there. + -- + -- for reference (does not apply here) => If oldest is provided but not + -- latest then the messages returned are those closest to oldest, + -- allowing you to page forward through history if desired. + rsp <- makeReq (Just latest) (Just oldest) False + case rsp of + Left _ -> return rsp + Right (Common.HistoryRsp msgs hasMore) -> do + let oldestReceived = Common.messageTs <$> lastZ msgs + if not hasMore || isNothing oldestReceived + then return rsp + else mergeResponses msgs <$> + commonHistoryFetchAll makeReq oldest (fromJust oldestReceived) + mergeResponses :: [Common.Message] -> Response Common.HistoryRsp @@ -537,6 +665,9 @@ apiTest_ :<|> authTest_ + :<|> conversationsList_ + :<|> conversationsHistory_ + :<|> conversationsReplies_ :<|> channelsCreate_ :<|> channelsHistory_ :<|> channelsList_ diff --git a/src/Web/Slack/Api.hs b/src/Web/Slack/Api.hs --- a/src/Web/Slack/Api.hs +++ b/src/Web/Slack/Api.hs @@ -25,6 +25,9 @@ -- base import GHC.Generics (Generic) +-- deepseq +import Control.DeepSeq (NFData) + -- http-api-data import Web.FormUrlEncoded @@ -46,7 +49,9 @@ } deriving (Eq, Generic, Show) +instance NFData TestReq + -- | -- -- @@ -84,6 +89,8 @@ { testRspArgs :: Maybe TestReq } deriving (Eq, Generic, Show) + +instance NFData TestRsp -- | -- diff --git a/src/Web/Slack/Auth.hs b/src/Web/Slack/Auth.hs --- a/src/Web/Slack/Auth.hs +++ b/src/Web/Slack/Auth.hs @@ -21,6 +21,9 @@ -- base import GHC.Generics (Generic) +-- deepseq +import Control.DeepSeq (NFData) + -- slack-web import Web.Slack.Util @@ -42,6 +45,8 @@ , testRspEnterpriseId :: Maybe Text } deriving (Eq, Generic, Show) + +instance NFData TestRsp $(deriveJSON (jsonOpts "testRsp") ''TestRsp) diff --git a/src/Web/Slack/Channel.hs b/src/Web/Slack/Channel.hs --- a/src/Web/Slack/Channel.hs +++ b/src/Web/Slack/Channel.hs @@ -30,6 +30,9 @@ -- base import GHC.Generics (Generic) +-- deepseq +import Control.DeepSeq (NFData) + -- http-api-data import Web.FormUrlEncoded @@ -64,7 +67,9 @@ } deriving (Eq, Generic, Show) +instance NFData Channel + -- | -- -- @@ -77,7 +82,9 @@ } deriving (Eq, Generic, Show) +instance NFData Purpose + -- | -- -- @@ -90,7 +97,9 @@ } deriving (Eq, Generic, Show) +instance NFData Topic + -- | -- -- @@ -123,7 +132,9 @@ } deriving (Eq, Generic, Show) +instance NFData CreateReq + -- | -- -- @@ -164,7 +175,9 @@ } deriving (Eq, Generic, Show) +instance NFData CreateRsp + -- | -- -- @@ -177,7 +190,9 @@ } deriving (Eq, Generic, Show) +instance NFData ListReq + -- | -- -- @@ -216,5 +231,7 @@ { listRspChannels :: [Channel] } deriving (Eq, Generic, Show) + +instance NFData ListRsp $(deriveFromJSON (jsonOpts "listRsp") ''ListRsp) diff --git a/src/Web/Slack/Chat.hs b/src/Web/Slack/Chat.hs --- a/src/Web/Slack/Chat.hs +++ b/src/Web/Slack/Chat.hs @@ -25,6 +25,9 @@ -- base import GHC.Generics (Generic) +-- deepseq +import Control.DeepSeq (NFData) + -- http-api-data import Web.FormUrlEncoded @@ -52,7 +55,9 @@ } deriving (Eq, Generic, Show) +instance NFData PostMsg + -- | -- -- @@ -83,7 +88,9 @@ } deriving (Eq, Generic, Show) +instance NFData PostMsgReq + -- | -- -- @@ -137,5 +144,7 @@ , postMsgRspMessage :: PostMsg } deriving (Eq, Generic, Show) + +instance NFData PostMsgRsp $(deriveFromJSON (jsonOpts "postMsgRsp") ''PostMsgRsp) diff --git a/src/Web/Slack/Common.hs b/src/Web/Slack/Common.hs --- a/src/Web/Slack/Common.hs +++ b/src/Web/Slack/Common.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE CPP #-} @@ -18,8 +20,12 @@ module Web.Slack.Common ( Color(unColor) , UserId(unUserId) + , ConversationId (..) + , TeamId (..) + , Cursor (..) , SlackTimestamp(..) , mkSlackTimestamp + , timestampFromText , HistoryReq(..) , mkHistoryReq , HistoryRsp(..) @@ -36,9 +42,11 @@ -- base import Control.Exception -import Data.Typeable import GHC.Generics (Generic) +-- deepseq +import Control.DeepSeq (NFData) + -- http-api-data import Web.HttpApiData import Web.FormUrlEncoded @@ -69,14 +77,16 @@ , historyReqOldest :: Maybe SlackTimestamp , historyReqInclusive :: Bool } - deriving (Eq, Generic, Show) + deriving (Eq, Show, Generic) +instance NFData HistoryReq + -- | -- -- -$(deriveFromJSON (jsonOpts "historyReq") ''HistoryReq) +$(deriveJSON (jsonOpts "historyReq") ''HistoryReq) -- | @@ -86,12 +96,12 @@ instance ToForm HistoryReq where -- can't use genericToForm because slack expects booleans as 0/1 toForm HistoryReq{..} = - [ ("channel", toQueryParam historyReqChannel) - , ("count", toQueryParam historyReqCount) - , ("latest", toQueryParam historyReqLatest) - , ("oldest", toQueryParam historyReqOldest) - , ("inclusive", toQueryParam (if historyReqInclusive then 1::Int else 0)) - ] + [ ("channel", toQueryParam historyReqChannel) + , ("count", toQueryParam historyReqCount) + ] + <> toQueryParamIfJust "latest" historyReqLatest + <> toQueryParamIfJust "oldest" historyReqOldest + <> [("inclusive", toQueryParam (if historyReqInclusive then 1 :: Int else 0))] -- | @@ -111,12 +121,17 @@ } data MessageType = MessageTypeMessage - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData MessageType + instance FromJSON MessageType where parseJSON "message" = pure MessageTypeMessage parseJSON _ = fail "Invalid MessageType" +instance ToJSON MessageType where + toJSON _ = String "message" + data Message = Message { messageType :: MessageType @@ -128,8 +143,10 @@ } deriving (Eq, Generic, Show) -$(deriveFromJSON (jsonOpts "message") ''Message) +instance NFData Message +$(deriveJSON (jsonOpts "message") ''Message) + data HistoryRsp = HistoryRsp { historyRspMessages :: [Message] @@ -137,8 +154,10 @@ } deriving (Eq, Generic, Show) -$(deriveFromJSON (jsonOpts "historyRsp") ''HistoryRsp) +instance NFData HistoryRsp +$(deriveJSON (jsonOpts "historyRsp") ''HistoryRsp) + -- | -- Errors that can be triggered by a slack request. data SlackClientError @@ -146,6 +165,8 @@ -- ^ errors from the network connection | SlackError Text -- ^ errors returned by the slack API - deriving (Eq, Generic, Show, Typeable) + deriving (Eq, Generic, Show) + +instance NFData SlackClientError instance Exception SlackClientError diff --git a/src/Web/Slack/Conversation.hs b/src/Web/Slack/Conversation.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Conversation.hs @@ -0,0 +1,483 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} + +---------------------------------------------------------------------- +-- | +-- Module: Web.Slack.Channel +-- Description: Types and functions related to +-- +-- +-- +---------------------------------------------------------------------- + +module Web.Slack.Conversation + ( Conversation(..) + , ConversationId(..) + , ConversationType(..) + , ChannelConversation(..) + , GroupConversation(..) + , ImConversation(..) + , TeamId(..) + , Purpose(..) + , Topic(..) + , ListReq(..) + , mkListReq + , ListRsp(..) + , HistoryReq (..) + , mkHistoryReq + , HistoryRsp (..) + , RepliesReq (..) + , mkRepliesReq + , ResponseMetadata (..) + ) where + +-- aeson +import Data.Aeson +import Data.Aeson.Encoding +import Data.Aeson.TH +import Data.Aeson.Types + +-- unordered-containers +import qualified Data.HashMap.Strict as HM + +-- base +import Control.Applicative (empty, (<|>)) +import GHC.Generics (Generic) + +-- deepseq +import Control.DeepSeq (NFData) + +-- http-api-data +import Web.FormUrlEncoded +import Web.HttpApiData + +-- slack-web +import Web.Slack.Common hiding (HistoryReq, HistoryRsp, mkHistoryReq) +import Web.Slack.Util + +-- scientific +import Data.Scientific + +-- text +import Data.Text (Text) +import qualified Data.Text as T + + +-- | +-- +-- +data Topic = + Topic + { topicValue :: Text + , topicCreator :: Text + , topicLastSet :: Integer + } + deriving (Eq, Show, Generic) + +instance NFData Topic + +$(deriveJSON (jsonOpts "topic") ''Topic) + + +-- | +-- +-- +data Purpose = + Purpose + { purposeValue :: Text + , purposeCreator :: Text + , purposeLastSet :: Integer + } + deriving (Eq, Show, Generic) + +instance NFData Purpose + +$(deriveJSON (jsonOpts "purpose") ''Purpose) + + +-- | Conversation object representing a public channel, +-- which any people in the team can join in and see. +data ChannelConversation = + ChannelConversation + { channelId :: ConversationId + , channelName :: Text + , channelCreated :: Integer + , channelIsArchived :: Bool + , channelIsGeneral :: Bool + , channelUnlinked :: Integer + , channelNameNormalized :: Text + , channelIsShared :: Bool + + -- FIXME: + -- I'm not sure the correct type of this field, because I only found + -- example responses whose @parent_conversation@ is @null@ + -- , channelParentConversation: null + , channelCreator :: UserId + , channelIsExtShared :: Bool + , channelIsOrgShared :: Bool + , channelSharedTeamIds :: [TeamId] + + -- FIXME: + -- I'm not sure the correct type of these fields, because I only found + -- example responses whose @pending_connected_team_ids@ and + -- @pending_shared@ are empty arrays. (Perhaps this is because + -- my team is a free account. The names make me guess its type is + -- @[TeamId]@, but these were not documented as long as I looked up. + -- , channelPendingShared :: [TeamId] + -- , channelPendingConnectedTeamIds :: [TeamId] + + , channelIsPendingExtShared :: Bool + , channelIsMember :: Bool + , channelTopic :: Topic + , channelPurpose :: Purpose + , channelPreviousNames :: [Text] + , channelNumMembers :: Integer + } + deriving (Eq, Show, Generic) + +instance NFData ChannelConversation + +$(deriveJSON (jsonOpts "channel") ''ChannelConversation) + + +-- | Conversation object representing a private channel or +-- _a multi-party instant message (mpim)*, which only invited people in the +-- team can join in and see. +data GroupConversation = + GroupConversation + { groupId :: ConversationId + , groupName :: Text + , groupCreated :: Integer + , groupIsArchived :: Bool + , groupIsGeneral :: Bool + , groupUnlinked :: Integer + , groupNameNormalized :: Text + , groupIsShared :: Bool + + -- FIXME: + -- I'm not sure the correct type of this field, because I only found + -- example responses whose @parent_conversation@ is @null@ + -- , groupParentConversation :: null + + , groupCreator :: UserId + , groupIsExtShared :: Bool + , groupIsOrgShared :: Bool + , groupSharedTeamIds :: [TeamId] + + -- FIXME: + -- I'm not sure the correct type of these fields, because I only found + -- example responses whose @pending_connected_team_ids@ and + -- @pending_shared@ are empty arrays. (Perhaps this is because + -- my team is a free account. The names make me guess its type is + -- @[TeamId]@, but these were not documented as long as I looked up. + -- , group_pending_shared :: [] + -- , group_pending_connected_team_ids :: [] + + , groupIsPendingExtShared :: Bool + , groupIsMember :: Bool + , groupIsPrivate :: Bool + , groupIsMpim :: Bool + , groupLastRead :: SlackTimestamp + , groupIsOpen :: Bool + , groupTopic :: Topic + , groupPurpose :: Purpose + , groupPriority :: Scientific + } + deriving (Eq, Show, Generic) + +instance NFData GroupConversation + +$(deriveJSON (jsonOpts "group") ''GroupConversation) + + +-- | Conversation object representing a (single-party) instance message, +-- where only two people talk. +data ImConversation = + ImConversation + { imId :: ConversationId + , imCreated :: Integer + , imIsArchived :: Bool + , imIsOrgShared :: Bool + , imUser :: UserId + , imIsUserDeleted :: Bool + , imPriority :: Scientific + } + deriving (Eq, Show, Generic) + +instance NFData ImConversation + +$(deriveJSON (jsonOpts "im") ''ImConversation) + + +-- | Ref. https://api.slack.com/types/conversation +-- +-- +data Conversation = + Channel ChannelConversation + | Group GroupConversation + | Im ImConversation + deriving (Eq, Show, Generic) + +instance NFData Conversation + + +instance FromJSON Conversation where + parseJSON = withObject "Conversation" $ \o -> + parseWhen "is_channel" Channel o + <|> parseWhen "is_group" Group o + <|> parseWhen "is_im" Im o + <|> prependFailure + "parsing a Conversation failed: neither channel, group, nor im, " + (typeMismatch "Conversation" (Object o)) + where + parseWhen key con o = do + is <- (o .: key) <|> empty + if is + then con <$> parseJSON (Object o) + else empty + + +instance ToJSON Conversation where + toJSON (Channel channel) = + let (Object obj) = toJSON channel + in Object + . HM.insert "is_channel" (Bool True) + . HM.insert "is_group" (Bool False) + $ HM.insert "is_im" (Bool False) obj + toJSON (Group group) = + let (Object obj) = toJSON group + in Object + . HM.insert "is_channel" (Bool False) + . HM.insert "is_group" (Bool True) + $ HM.insert "is_im" (Bool False) obj + toJSON (Im im) = + let (Object obj) = toJSON im + in Object + . HM.insert "is_channel" (Bool False) + . HM.insert "is_group" (Bool False) + $ HM.insert "is_im" (Bool True) obj + + +data ConversationType = + PublicChannelType + | PrivateChannelType + | MpimType + | ImType + deriving (Eq, Show, Generic) + +instance NFData ConversationType + +instance ToHttpApiData ConversationType where + toUrlPiece PublicChannelType = "public_channel" + toUrlPiece PrivateChannelType = "private_channel" + toUrlPiece MpimType = "mpim" + toUrlPiece ImType = "im" + +instance ToJSON ConversationType where + toJSON = toJSON . toUrlPiece + toEncoding = text . toUrlPiece + +instance FromJSON ConversationType where + parseJSON = withText "ConversationType" $ \case + "public_channel" -> pure PublicChannelType + "private_channel" -> pure PrivateChannelType + "mpim" -> pure MpimType + "im" -> pure ImType + actual -> + prependFailure "must be either \"public_channel\", \"private_channel\", \"mpim\" or \"im\"!" + . typeMismatch "ConversationType" $ String actual + + + +data ListReq = + ListReq + { listReqExcludeArchived :: Maybe Bool + , listReqTypes :: [ConversationType] + } + deriving (Eq, Show, Generic) + +instance NFData ListReq + + +-- | +-- +-- + +$(deriveJSON (jsonOpts "listReq") ''ListReq) + +-- | +-- +-- + +mkListReq + :: ListReq +mkListReq = + ListReq + { listReqExcludeArchived = Nothing + , listReqTypes = [] + } + + +-- | +-- +-- + +instance ToForm ListReq where + toForm (ListReq archived types) = + archivedForm <> typesForm + where + archivedForm = + maybe mempty (\val -> [("archived", toUrlPiece val)]) archived + typesForm = + if null types + then mempty + else [("types", T.intercalate "," $ map toUrlPiece types)] + + +-- | +-- + +newtype ListRsp = + ListRsp + { listRspChannels :: [Conversation] + } + deriving (Eq, Show, Generic) + +instance NFData ListRsp + +$(deriveFromJSON (jsonOpts "listRsp") ''ListRsp) + +-- | +-- +-- + +data HistoryReq = + HistoryReq + { historyReqChannel :: ConversationId + , historyReqCursor :: Maybe Cursor + , historyReqCount :: Int + , historyReqLatest :: Maybe SlackTimestamp + , historyReqOldest :: Maybe SlackTimestamp + , historyReqInclusive :: Bool + } + deriving (Eq, Show, Generic) + +instance NFData HistoryReq + +-- | +-- +-- + +$(deriveJSON (jsonOpts "historyReq") ''HistoryReq) + + +-- | +-- +-- + +mkHistoryReq + :: ConversationId + -> HistoryReq +mkHistoryReq channel = + HistoryReq + { historyReqChannel = channel + , historyReqCursor = Nothing + , historyReqCount = 100 + , historyReqLatest = Nothing + , historyReqOldest = Nothing + , historyReqInclusive = True + } + +-- | +-- +-- + +instance ToForm HistoryReq where + -- can't use genericToForm because slack expects booleans as 0/1 + toForm HistoryReq{..} = + [("channel", toQueryParam historyReqChannel)] + <> toQueryParamIfJust "cursor" historyReqCursor + <> [("count", toQueryParam historyReqCount)] + <> toQueryParamIfJust "latest" historyReqLatest + <> toQueryParamIfJust "oldest" historyReqOldest + <> [("inclusive", toQueryParam (if historyReqInclusive then 1 :: Int else 0))] + + +-- | +-- +-- +newtype ResponseMetadata = ResponseMetadata { responseMetadataNextCursor :: Maybe Cursor } + deriving (Eq, Show, Generic) + +instance NFData ResponseMetadata + +$(deriveJSON (jsonOpts "responseMetadata") ''ResponseMetadata) + + +-- | +-- +-- + +data HistoryRsp = + HistoryRsp + { historyRspMessages :: [Message] + , historyRspResponseMetadata :: Maybe ResponseMetadata + } + deriving (Eq, Show, Generic) + +instance NFData HistoryRsp + +$(deriveJSON (jsonOpts "historyRsp") ''HistoryRsp) + + +data RepliesReq = + RepliesReq + { repliesReqTs :: SlackTimestamp + , repliesReqCursor :: Maybe Cursor + , repliesReqChannel :: ConversationId + , repliesReqLimit :: Int + , repliesReqLatest :: Maybe SlackTimestamp + , repliesReqOldest :: Maybe SlackTimestamp + , repliesReqInclusive :: Bool + } + deriving (Eq, Show, Generic) + +instance NFData RepliesReq + +$(deriveJSON (jsonOpts "repliesReq") ''RepliesReq) + +instance ToForm RepliesReq where + -- can't use genericToForm because slack expects booleans as 0/1 + toForm RepliesReq {..} = + [("channel", toQueryParam repliesReqChannel)] + <> [("ts", toQueryParam repliesReqTs)] + <> toQueryParamIfJust "cursor" repliesReqCursor + <> [("limit", toQueryParam repliesReqLimit)] + <> toQueryParamIfJust "latest" repliesReqLatest + <> toQueryParamIfJust "oldest" repliesReqOldest + <> [("inclusive", toQueryParam (if repliesReqInclusive then 1 :: Int else 0))] + + +-- | +-- +-- + +mkRepliesReq + :: ConversationId + -> SlackTimestamp + -> RepliesReq +mkRepliesReq channel ts = + RepliesReq + { repliesReqChannel = channel + , repliesReqCursor = Nothing + , repliesReqTs = ts + , repliesReqLimit = 100 + , repliesReqLatest = Nothing + , repliesReqOldest = Nothing + , repliesReqInclusive = True + } diff --git a/src/Web/Slack/Group.hs b/src/Web/Slack/Group.hs --- a/src/Web/Slack/Group.hs +++ b/src/Web/Slack/Group.hs @@ -23,6 +23,9 @@ -- base import GHC.Generics (Generic) +-- deepseq +import Control.DeepSeq (NFData) + -- slack-web import Web.Slack.Common import Web.Slack.Util @@ -45,6 +48,8 @@ } deriving (Eq, Generic, Show) +instance NFData Group + $(deriveFromJSON (jsonOpts "group") ''Group) data ListRsp = @@ -52,5 +57,7 @@ { listRspGroups :: [Group] } deriving (Eq, Generic, Show) + +instance NFData ListRsp $(deriveFromJSON (jsonOpts "listRsp") ''ListRsp) diff --git a/src/Web/Slack/Im.hs b/src/Web/Slack/Im.hs --- a/src/Web/Slack/Im.hs +++ b/src/Web/Slack/Im.hs @@ -24,6 +24,9 @@ -- base import GHC.Generics (Generic) +-- deepseq +import Control.DeepSeq (NFData) + -- slack-web import Web.Slack.Util import Web.Slack.Common @@ -42,14 +45,18 @@ , imCreated :: POSIXTime , imIsUserDeleted :: Bool } - deriving (Eq, Generic, Show) + deriving (Eq, Show, Generic) +instance NFData Im + $(deriveFromJSON (jsonOpts "im") ''Im) data ListRsp = ListRsp { listRspIms :: [Im] } - deriving (Eq, Generic, Show) + deriving (Eq, Show, Generic) + +instance NFData ListRsp $(deriveFromJSON (jsonOpts "listRsp") ''ListRsp) diff --git a/src/Web/Slack/Pager.hs b/src/Web/Slack/Pager.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Pager.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.Slack.Pager + ( Response + , conversationsHistoryAllBy + , repliesFetchAllBy + , LoadPage + ) where + +-- base +import Control.Monad (join) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Maybe (isNothing) + +-- slack-web +import Web.Slack.Types (Cursor) +import qualified Web.Slack.Conversation as Conversation +import qualified Web.Slack.Common as Common + + +-- | Public only for testing. +conversationsHistoryAllBy + :: MonadIO m + => (Conversation.HistoryReq -> m (Response Conversation.HistoryRsp)) + -- ^ Response generator + -> Conversation.HistoryReq + -- ^ The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. + -> m (LoadPage m [Common.Message]) + -- ^ An action which returns a new page of messages every time called. + -- If there are no pages anymore, it returns an empty list. +conversationsHistoryAllBy sendRequest initialRequest = + genericFetchAllBy + sendRequest + (\cursor -> initialRequest { Conversation.historyReqCursor = cursor }) + + +-- | Public only for testing. +repliesFetchAllBy + :: MonadIO m + => (Conversation.RepliesReq -> m (Response Conversation.HistoryRsp)) + -- ^ Response generator + -> Conversation.RepliesReq + -- ^ The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. + -> m (LoadPage m [Common.Message]) + -- ^ An action which returns a new page of messages every time called. + -- If there are no pages anymore, it returns an empty list. +repliesFetchAllBy sendRequest initialRequest = + genericFetchAllBy + sendRequest + (\cursor -> initialRequest { Conversation.repliesReqCursor = cursor }) + + +type Response a = Either Common.SlackClientError a + + +-- | Represents an action which returns a paginated response from Slack. +-- Every time calling the action, it performs a request with a new cursor +-- to get the next page. +-- If there is no more response, the action returns an empty list. +type LoadPage m a = m (Response a) + + +genericFetchAllBy + :: MonadIO m + => (a -> m (Response Conversation.HistoryRsp)) + -> (Maybe Cursor -> a) + -> m (LoadPage m [Common.Message]) +genericFetchAllBy sendRequest requestFromCursor = do + cursorRef <- liftIO $ newIORef Nothing + + let collectAndUpdateCursor + Conversation.HistoryRsp + { Conversation.historyRspMessages + , Conversation.historyRspResponseMetadata + } = do + let newCursor = Conversation.responseMetadataNextCursor =<< historyRspResponseMetadata + -- emptyCursor is used for the marker to show that there are no more pages. + cursorToSave = if isNothing newCursor then emptyCursor else newCursor + writeIORef cursorRef cursorToSave + return historyRspMessages + + return $ do + cursor <- liftIO $ readIORef cursorRef + if cursor == emptyCursor + then + return $ Right [] + else + traverse (liftIO . collectAndUpdateCursor) + =<< sendRequest (requestFromCursor cursor) + where + -- Used for the marker to show that there are no more pages. + emptyCursor = Just $ Common.Cursor "" diff --git a/src/Web/Slack/Types.hs b/src/Web/Slack/Types.hs --- a/src/Web/Slack/Types.hs +++ b/src/Web/Slack/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -15,8 +16,12 @@ module Web.Slack.Types ( Color(..) , UserId(..) + , ConversationId(..) + , TeamId(..) + , Cursor(..) , SlackTimestamp(..) , mkSlackTimestamp + , timestampFromText , SlackMessageText(..) ) where @@ -25,18 +30,22 @@ import Data.Aeson -- base +import Data.Bifunctor (second) import GHC.Generics (Generic) --- errors -import Control.Error (hush) +-- deepseq +import Control.DeepSeq (NFData) +-- hashable +import Data.Hashable (Hashable) + -- http-api-data import Web.HttpApiData -- text import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Read (decimal) +import Data.Text.Read (rational) -- time import Data.Time.Clock @@ -44,41 +53,70 @@ -- Ord to allow it to be a key of a Map newtype Color = Color { unColor :: Text } - deriving (Eq, Ord, Generic, Show, FromJSON) + deriving stock (Eq, Ord, Generic, Show) + deriving newtype (NFData, Hashable, FromJSON, ToJSON) -- Ord to allow it to be a key of a Map newtype UserId = UserId { unUserId :: Text } - deriving (Eq, Ord, Generic, Show, FromJSON) + deriving stock (Eq, Ord, Generic, Show) + deriving newtype (NFData, Hashable, FromJSON, ToJSON, ToHttpApiData) +-- | Common identifier for every type of 'Conversation'. +-- Unique to the team which the conversation belongs to. +-- Ord to allow it to be a key of a Map +newtype ConversationId = ConversationId { unConversationId :: Text } + deriving stock (Eq, Ord, Generic, Show) + deriving newtype (NFData, Hashable, FromJSON, ToJSON, ToHttpApiData) + +-- Ord to allow it to be a key of a Map +newtype TeamId = TeamId { unTeamId :: Text } + deriving stock (Eq, Ord, Generic, Show) + deriving newtype (NFData, Hashable, FromJSON, ToJSON, ToHttpApiData) + +newtype Cursor = Cursor { unCursor :: Text } + deriving stock (Eq, Generic, Show) + deriving newtype (NFData, Hashable, FromJSON, ToJSON, ToHttpApiData) + -- | Message text in the format returned by Slack, -- see https://api.slack.com/docs/message-formatting -- Consider using 'messageToHtml' for displaying. newtype SlackMessageText = SlackMessageText { unSlackMessageText :: Text} - deriving (Eq, Generic, Show, FromJSON) + deriving stock (Eq, Ord, Generic, Show) + deriving newtype (NFData, Hashable, FromJSON, ToJSON) data SlackTimestamp = SlackTimestamp { slackTimestampTs :: Text , slackTimestampTime :: UTCTime } - deriving (Eq, Show) + deriving stock (Eq, Show, Generic) +instance NFData SlackTimestamp + instance Ord SlackTimestamp where - compare (SlackTimestamp _ a) (SlackTimestamp _ b) = compare a b + compare (SlackTimestamp _ a) (SlackTimestamp _ b) = compare a b +-- | Convert timestamp texts e.g. "1595719220.011100" into 'SlackTimestamp' +timestampFromText :: Text -> Either String SlackTimestamp +timestampFromText t = f =<< rational t + where + f (posixTime, "") = + Right . SlackTimestamp t $ posixSecondsToUTCTime posixTime + f (_, _left) = Left "Unexpected text left after timestamp" + mkSlackTimestamp :: UTCTime -> SlackTimestamp -mkSlackTimestamp utctime = SlackTimestamp (T.pack (show @Integer unixts) <> ".000000") utctime - where unixts = floor $ toRational $ utcTimeToPOSIXSeconds utctime +mkSlackTimestamp utctime = SlackTimestamp (take6DigitsAfterPoint $ T.pack (show unixts)) utctime + where + unixts = nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds utctime + take6DigitsAfterPoint = uncurry (<>) . second (T.take 7) . T.break (== '.') instance ToHttpApiData SlackTimestamp where toQueryParam (SlackTimestamp contents _) = contents instance FromJSON SlackTimestamp where - parseJSON = withText "Slack ts" $ \contents -> - maybe (fail "Invalid slack ts") - (pure . SlackTimestamp contents) - (slackTimestampToTime contents) + parseJSON = withText "Slack ts" + $ either (fail . ("Invalid Slack ts: " ++)) pure + . timestampFromText -slackTimestampToTime :: Text -> Maybe UTCTime -slackTimestampToTime txt = - posixSecondsToUTCTime . realToFrac @Integer . fst <$> hush (decimal txt) +instance ToJSON SlackTimestamp where + toJSON = String . slackTimestampTs diff --git a/src/Web/Slack/Util.hs b/src/Web/Slack/Util.hs --- a/src/Web/Slack/Util.hs +++ b/src/Web/Slack/Util.hs @@ -10,6 +10,7 @@ module Web.Slack.Util ( formOpts , jsonOpts + , toQueryParamIfJust ) where @@ -19,9 +20,12 @@ -- base import Data.Char +import Data.Maybe (maybeToList) +import GHC.Exts (fromList) -- http-api-data -import Web.FormUrlEncoded (FormOptions(FormOptions)) +import Web.HttpApiData (toQueryParam, ToHttpApiData) +import Web.FormUrlEncoded (Form, FormOptions(FormOptions)) -- text import Data.Text (Text) @@ -75,3 +79,8 @@ -> String addUnderscores = camelTo2 '_' + + +toQueryParamIfJust :: ToHttpApiData a => Text -> Maybe a -> Form +toQueryParamIfJust key = + fromList . maybeToList . fmap (\justVal -> (key, toQueryParam justVal)) diff --git a/tests/Web/Slack/ConversationSpec.hs b/tests/Web/Slack/ConversationSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Web/Slack/ConversationSpec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Web.Slack.ConversationSpec + ( spec + ) where + +-- aeson +import Data.Aeson + +-- base +import Data.Maybe + +-- hspec +import Test.Hspec +import Test.Hspec.QuickCheck + +-- QuickCheck +import Test.QuickCheck + +-- quickcheck-instances +import Test.QuickCheck.Instances () + +-- slack-web +import Web.Slack.Common +import Web.Slack.Conversation + +-- text +import Data.Text (Text) + +-- time +import Data.Time.Clock.POSIX + + +instance Arbitrary MessageType where + arbitrary = return MessageTypeMessage + +instance Arbitrary UserId where + arbitrary = fromJust . decode . encode <$> (arbitrary :: Gen Text) + +instance Arbitrary SlackTimestamp where + -- NOTE: `arbitrary :: Gen UTCTime` only for positive POSIX Second is really slow! + arbitrary = mkSlackTimestamp . posixSecondsToUTCTime . fromIntegral <$> (arbitrary :: Gen Word) + +instance Arbitrary Message where + arbitrary = + Message <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Topic where + arbitrary = Topic <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary Purpose where + arbitrary = Purpose <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary ChannelConversation where + arbitrary = ChannelConversation + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary GroupConversation where + arbitrary = GroupConversation + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary ImConversation where + arbitrary = ImConversation + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary Conversation where + arbitrary = oneof [Channel <$> arbitrary, Group <$> arbitrary, Im <$> arbitrary] + + +deriving instance Arbitrary ConversationId +deriving instance Arbitrary SlackMessageText +deriving instance Arbitrary TeamId + + +spec :: Spec +spec = describe "ToJSON and FromJSON for Conversation" $ do + prop "the encoded json is decoded as " $ \conversation -> do + actual <- either fail return . eitherDecode $ encode conversation + actual `shouldBe` (conversation :: Conversation) diff --git a/tests/Web/Slack/PagerSpec.hs b/tests/Web/Slack/PagerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Web/Slack/PagerSpec.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Web.Slack.PagerSpec (spec) where + +-- base +import Control.Exception (throwIO) +import Data.Maybe (fromJust) + +-- fakepull +import Test.Pull.Fake.IO (FakeStream, pull, newFakeStream) + +-- hspec +import Test.Hspec + +-- slack-web +import Web.Slack.Pager +import Web.Slack.Common + ( mkSlackTimestamp + , Cursor (..) + , Message (..) + , MessageType (..) + , SlackMessageText (..) + ) +import Web.Slack.Conversation + ( ConversationId (ConversationId) + , mkHistoryReq + , mkRepliesReq + , HistoryReq (..) + , HistoryRsp (..) + , RepliesReq (..) + , ResponseMetadata (..) + ) +import Web.Slack.Types (UserId (..)) + +-- text +import qualified Data.Text as Text + +-- time +import Data.Time.Clock (getCurrentTime, nominalDay, addUTCTime) + + +stubbedSendRequest :: FakeStream (Response HistoryRsp) -> a -> IO (Response HistoryRsp) +stubbedSendRequest stream _request = fromJust <$> pull stream + + +spec :: Spec +spec = do + let prepare = do + nowUtc <- getCurrentTime + let now = mkSlackTimestamp nowUtc + oldest = mkSlackTimestamp $ addUTCTime (nominalDay * negate 20) nowUtc + messagesPerPage = 3 + allResponses :: [Response HistoryRsp] + allResponses = do + -- According to https://api.slack.com/docs/pagination, + -- The last page's cursor can be either an empty string, null, or non-exisitent in the object. + (pageN, cursor) <- zip [1..3] ["cursor1=", "cursor2=", ""] + let pageNT = Text.pack (show pageN) + pure . Right $ HistoryRsp + { historyRspMessages = do + messageN <- [1..messagesPerPage] + let messagesPerPageNDT = fromIntegral messagesPerPage + messageNDT = fromIntegral messageN + messageNT = Text.pack (show messageN) + createdBefore = negate $ nominalDay * ((pageN - 1) * messagesPerPageNDT + messageNDT) + pure $ Message + MessageTypeMessage + (Just . UserId $ "U" <> pageNT <> messageNT) + (SlackMessageText $ "message " <> pageNT <> "-" <> messageNT) + (mkSlackTimestamp $ addUTCTime createdBefore nowUtc) + , historyRspResponseMetadata = Just . ResponseMetadata . Just $ Cursor cursor + } + responsesToReturn <- newFakeStream allResponses + return (now, oldest, messagesPerPage, allResponses, responsesToReturn) + + describe "conversationsHistoryAllBy" $ + it "collect all results by sending requests" $ do + (now, oldest, messagesPerPage, allResponses, responsesToReturn) <- prepare + let initialRequest = (mkHistoryReq (ConversationId "C01234567")) + { historyReqCount = messagesPerPage + , historyReqLatest = Just now + , historyReqOldest = Just oldest + , historyReqInclusive = False + } + loadPage <- conversationsHistoryAllBy (stubbedSendRequest responsesToReturn) initialRequest + let actual = unfoldPageM $ either throwIO return =<< loadPage + expected <- fmap (map historyRspMessages) . either throwIO return $ sequenceA allResponses + actual `shouldReturn` expected + + describe "repliesFetchAllBy" $ + it "collect all results by sending requests" $ do + (now, oldest, messagesPerPage, allResponses, responsesToReturn) <- prepare + let initialRequest = (mkRepliesReq (ConversationId "C98765432") oldest) + { repliesReqLimit = messagesPerPage + , repliesReqLatest = Just now + , repliesReqOldest = Just oldest + , repliesReqInclusive = False + } + loadPage <- repliesFetchAllBy (stubbedSendRequest responsesToReturn) initialRequest + let actual = unfoldPageM $ either throwIO return =<< loadPage + expected <- fmap (map historyRspMessages) . either throwIO return $ sequenceA allResponses + actual `shouldReturn` expected + + +-- | Runs the given action repeatedly until it returns an empty list. +unfoldPageM :: Monad m => m [a] -> m [[a]] +unfoldPageM act = reverse <$> go [] + where + go accum = do + x <- act + case x of + [] -> return accum + xs -> go $! xs : accum