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.1.0 +version: 0.3.0.0 build-type: Simple cabal-version: 1.20 @@ -33,12 +33,9 @@ Web.Slack Web.Slack.Api Web.Slack.Auth - 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 @@ -46,7 +43,7 @@ other-modules: Web.Slack.Util build-depends: - aeson >= 1.0 && < 1.5 + aeson >= 1.0 && < 1.6 , base >= 4.11 && < 4.15 , scientific , containers @@ -56,15 +53,15 @@ , http-api-data >= 0.3 && < 0.5 , http-client >= 0.5 && < 0.7 , http-client-tls >= 0.3 && < 0.4 - , servant >= 0.12 && < 0.18 - , servant-client >= 0.12 && < 0.18 - , servant-client-core >= 0.12 && < 0.18 + , servant >= 0.12 && < 0.19 + , servant-client >= 0.12 && < 0.19 + , servant-client-core >= 0.12 && < 0.19 , text >= 1.2 && < 1.3 , transformers , mtl , time , errors - , megaparsec >= 5.0 && < 9 + , megaparsec >= 5.0 && < 10 default-language: Haskell2010 ghc-options: diff --git a/src/Web/Slack.hs b/src/Web/Slack.hs --- a/src/Web/Slack.hs +++ b/src/Web/Slack.hs @@ -19,21 +19,11 @@ , apiTest , authTest , chatPostMessage - , channelsCreate , conversationsList , conversationsHistory , conversationsHistoryAll , conversationsReplies - , channelsList - , channelsHistory - , groupsHistory - , groupsList - , historyFetchAll , repliesFetchAll - , imHistory - , imList - , mpimList - , mpimHistory , getUserDesc , usersList , userLookupByEmail @@ -56,9 +46,6 @@ -- containers import qualified Data.Map as Map --- error -import Control.Error (lastZ) - -- http-client import Network.HTTP.Client (Manager, newManager) @@ -79,11 +66,8 @@ 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 @@ -169,53 +153,11 @@ :> ReqBody '[FormUrlEncoded] Conversation.RepliesReq :> Post '[JSON] (ResponseJSON Conversation.HistoryRsp) :<|> - "channels.create" - :> AuthProtect "token" - :> ReqBody '[FormUrlEncoded] Channel.CreateReq - :> Post '[JSON] (ResponseJSON Channel.CreateRsp) - :<|> - "channels.history" - :> AuthProtect "token" - :> ReqBody '[FormUrlEncoded] Common.HistoryReq - :> Post '[JSON] (ResponseJSON Common.HistoryRsp) - :<|> - "channels.list" - :> AuthProtect "token" - :> ReqBody '[FormUrlEncoded] Channel.ListReq - :> Post '[JSON] (ResponseJSON Channel.ListRsp) - :<|> "chat.postMessage" :> AuthProtect "token" :> ReqBody '[FormUrlEncoded] Chat.PostMsgReq :> Post '[JSON] (ResponseJSON Chat.PostMsgRsp) :<|> - "groups.history" - :> AuthProtect "token" - :> ReqBody '[FormUrlEncoded] Common.HistoryReq - :> Post '[JSON] (ResponseJSON Common.HistoryRsp) - :<|> - "groups.list" - :> AuthProtect "token" - :> Post '[JSON] (ResponseJSON Group.ListRsp) - :<|> - "im.history" - :> AuthProtect "token" - :> ReqBody '[FormUrlEncoded] Common.HistoryReq - :> Post '[JSON] (ResponseJSON Common.HistoryRsp) - :<|> - "im.list" - :> AuthProtect "token" - :> Post '[JSON] (ResponseJSON Im.ListRsp) - :<|> - "mpim.list" - :> AuthProtect "token" - :> Post '[JSON] (ResponseJSON Group.ListRsp) - :<|> - "mpim.history" - :> AuthProtect "token" - :> ReqBody '[FormUrlEncoded] Common.HistoryReq - :> Post '[JSON] (ResponseJSON Common.HistoryRsp) - :<|> "users.list" :> AuthProtect "token" :> Post '[JSON] (ResponseJSON User.ListRsp) @@ -324,64 +266,6 @@ -- | -- --- Create a channel. --- --- - -channelsCreate - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Channel.CreateReq - -> m (Response Channel.CreateRsp) -channelsCreate createReq = do - authR <- mkSlackAuthenticateReq - run (channelsCreate_ authR createReq) - -channelsCreate_ - :: AuthenticatedRequest (AuthProtect "token") - -> Channel.CreateReq - -> ClientM (ResponseJSON Channel.CreateRsp) - --- | --- --- Retrieve channel list. --- --- - -channelsList - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Channel.ListReq - -> m (Response Channel.ListRsp) -channelsList listReq = do - authR <- mkSlackAuthenticateReq - run (channelsList_ authR listReq) - -channelsList_ - :: AuthenticatedRequest (AuthProtect "token") - -> Channel.ListReq - -> ClientM (ResponseJSON Channel.ListRsp) - --- | --- --- Retrieve channel history. --- Consider using 'historyFetchAll' in combination with this function --- --- - -channelsHistory - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Common.HistoryReq - -> m (Response Common.HistoryRsp) -channelsHistory histReq = do - authR <- mkSlackAuthenticateReq - run (channelsHistory_ authR histReq) - -channelsHistory_ - :: AuthenticatedRequest (AuthProtect "token") - -> Common.HistoryReq - -> ClientM (ResponseJSON Common.HistoryRsp) - --- | --- -- Send a message to a channel. -- -- @@ -399,123 +283,9 @@ -> Chat.PostMsgReq -> ClientM (ResponseJSON Chat.PostMsgRsp) --- | --- --- This method returns a list of private channels in the team that the caller --- is in and archived groups that the caller was in. The list of --- (non-deactivated) members in each private channel is also returned. --- --- -groupsList - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => m (Response Group.ListRsp) -groupsList = do - authR <- mkSlackAuthenticateReq - run (groupsList_ authR) - -groupsList_ - :: AuthenticatedRequest (AuthProtect "token") - -> ClientM (ResponseJSON Group.ListRsp) - -- | -- --- This method returns a portion of messages/events from the specified --- private channel. To read the entire history for a private channel, --- call the method with no latest or oldest arguments, and then continue paging. --- Consider using 'historyFetchAll' in combination with this function --- --- - -groupsHistory - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Common.HistoryReq - -> m (Response Common.HistoryRsp) -groupsHistory hisReq = do - authR <- mkSlackAuthenticateReq - run (groupsHistory_ authR hisReq) - -groupsHistory_ - :: AuthenticatedRequest (AuthProtect "token") - -> Common.HistoryReq - -> ClientM (ResponseJSON Common.HistoryRsp) - --- | --- --- Returns a list of all direct message channels that the user has --- --- - -imList - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => m (Response Im.ListRsp) -imList = do - authR <- mkSlackAuthenticateReq - run (imList_ authR) - -imList_ - :: AuthenticatedRequest (AuthProtect "token") - -> ClientM (ResponseJSON Im.ListRsp) - --- | --- --- Retrieve direct message channel history. --- Consider using 'historyFetchAll' in combination with this function --- --- - -imHistory - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Common.HistoryReq - -> m (Response Common.HistoryRsp) -imHistory histReq = do - authR <- mkSlackAuthenticateReq - run (imHistory_ authR histReq) - -imHistory_ - :: AuthenticatedRequest (AuthProtect "token") - -> Common.HistoryReq - -> ClientM (ResponseJSON Common.HistoryRsp) - --- | --- --- Returns a list of all multiparty direct message channels that the user has --- --- - -mpimList - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => m (Response Group.ListRsp) -mpimList = do - authR <- mkSlackAuthenticateReq - run (mpimList_ authR) - -mpimList_ - :: AuthenticatedRequest (AuthProtect "token") - -> ClientM (ResponseJSON Group.ListRsp) - --- | --- --- Retrieve multiparty direct message channel history. --- Consider using 'historyFetchAll' in combination with this function --- --- - -mpimHistory - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Common.HistoryReq - -> m (Response Common.HistoryRsp) -mpimHistory histReq = do - authR <- mkSlackAuthenticateReq - run (mpimHistory_ authR histReq) - -mpimHistory_ - :: AuthenticatedRequest (AuthProtect "token") - -> Common.HistoryReq - -> ClientM (ResponseJSON Common.HistoryRsp) - --- | --- -- This method returns a list of all users in the team. -- This includes deleted/deactivated users. -- @@ -567,36 +337,7 @@ in \userId -> fromMaybe (unknownUserFn userId) $ Map.lookup userId userMap --- | --- Fetch all history items between two dates. The basic calls --- 'channelsHistory', 'groupsHistory', 'imHistory' and so on --- may not return exhaustive results if there were too many --- records. You need to use 'Web.Slack.Common.historyRspHasMore' to find out --- whether you got all the data. --- --- This function will repeatedly call the underlying history --- function until all the data is fetched or until a call --- fails, merging the messages obtained from each call. -historyFetchAll - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => (Common.HistoryReq -> m (Response Common.HistoryRsp)) - -- ^ The request to make. Can be for instance 'conversationsHistory'... - -> Text - -- ^ The channel name to query - -> Int - -- ^ The number of entries to fetch at once. - -> Common.SlackTimestamp - -- ^ The oldest timestamp to fetch records from - -> Common.SlackTimestamp - -- ^ The newest timestamp to fetch records to - -> m (Response Common.HistoryRsp) - -- ^ A list merging all the history records that were fetched - -- through the individual queries. -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 @@ -605,7 +346,7 @@ :: (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]) + -> 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 @@ -624,60 +365,17 @@ :: (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]) + -> 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 - -> Response Common.HistoryRsp -mergeResponses _ err@(Left _) = err -mergeResponses msgs (Right rsp) = - Right (rsp { Common.historyRspMessages = msgs ++ Common.historyRspMessages rsp }) - apiTest_ :<|> authTest_ :<|> conversationsList_ :<|> conversationsHistory_ :<|> conversationsReplies_ - :<|> channelsCreate_ - :<|> channelsHistory_ - :<|> channelsList_ :<|> chatPostMessage_ - :<|> groupsHistory_ - :<|> groupsList_ - :<|> imHistory_ - :<|> imList_ - :<|> mpimList_ - :<|> mpimHistory_ :<|> usersList_ :<|> userLookupByEmail_ = diff --git a/src/Web/Slack/Channel.hs b/src/Web/Slack/Channel.hs deleted file mode 100644 --- a/src/Web/Slack/Channel.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - ----------------------------------------------------------------------- --- | --- Module: Web.Slack.Channel --- Description: --- --- --- ----------------------------------------------------------------------- - -module Web.Slack.Channel - ( Channel(..) - , Purpose(..) - , Topic(..) - , CreateReq(..) - , mkCreateReq - , CreateRsp(..) - , ListReq(..) - , mkListReq - , ListRsp(..) - ) - where - --- aeson -import Data.Aeson.TH - --- base -import GHC.Generics (Generic) - --- deepseq -import Control.DeepSeq (NFData) - --- http-api-data -import Web.FormUrlEncoded - --- slack-web -import Web.Slack.Common -import Web.Slack.Util - --- text -import Data.Text (Text) - - --- | --- --- - -data Channel = - Channel - { channelId :: Text - , channelName :: Text - , channelCreated :: Integer - , channelCreator :: UserId - , channelIsArchived :: Bool - , channelIsMember :: Bool - , channelIsGeneral :: Bool - , channelLastRead :: Maybe Text - , channelLatest :: Maybe Text - , channelUnreadCount :: Maybe Integer - , channelUnreadCountDisplay :: Maybe Integer - , channelMembers :: [UserId] - , channelTopic :: Topic - , channelPurpose :: Purpose - } - deriving (Eq, Generic, Show) - -instance NFData Channel - - --- | --- --- - -data Purpose = - Purpose - { purposeValue :: Text - , purposeCreator :: Text - , purposeLastSet :: Integer - } - deriving (Eq, Generic, Show) - -instance NFData Purpose - - --- | --- --- - -data Topic = - Topic - { topicValue :: Text - , topicCreator :: Text - , topicLastSet :: Integer - } - deriving (Eq, Generic, Show) - -instance NFData Topic - - --- | --- --- - -$(deriveFromJSON (jsonOpts "channel") ''Channel) - - --- | --- --- - -$(deriveJSON (jsonOpts "purpose") ''Purpose) - - --- | --- --- - -$(deriveJSON (jsonOpts "topic") ''Topic) - - --- | --- --- - -data CreateReq = - CreateReq - { createReqName :: Text - , createReqValidate :: Maybe Bool - } - deriving (Eq, Generic, Show) - -instance NFData CreateReq - - --- | --- --- - -$(deriveJSON (jsonOpts "createReq") ''CreateReq) - - --- | --- --- - -instance ToForm CreateReq where - toForm = - genericToForm (formOpts "createReq") - - --- | --- --- - -mkCreateReq - :: Text - -> CreateReq -mkCreateReq name = - CreateReq - { createReqName = name - , createReqValidate = Nothing - } - - --- | --- --- - -data CreateRsp = - CreateRsp - { createRspChannel :: Channel - } - deriving (Eq, Generic, Show) - -instance NFData CreateRsp - - --- | --- --- -$(deriveFromJSON (jsonOpts "createRsp") ''CreateRsp) - -data ListReq = - ListReq - { listReqExcludeArchived :: Maybe Bool - , listReqExcludeMembers :: Maybe Bool - } - deriving (Eq, Generic, Show) - -instance NFData ListReq - - --- | --- --- - -$(deriveJSON (jsonOpts "listReq") ''ListReq) - - --- | --- --- - -instance ToForm ListReq where - toForm = - genericToForm (formOpts "listReq") - - --- | --- --- - -mkListReq - :: ListReq -mkListReq = - ListReq - { listReqExcludeArchived = Nothing - , listReqExcludeMembers = Nothing - } - - --- | --- --- - -data ListRsp = - ListRsp - { listRspChannels :: [Channel] - } - deriving (Eq, Generic, Show) - -instance NFData ListRsp - -$(deriveFromJSON (jsonOpts "listRsp") ''ListRsp) 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 @@ -18,17 +18,14 @@ ---------------------------------------------------------------------- module Web.Slack.Common - ( Color(unColor) - , UserId(unUserId) + ( Color(..) + , UserId(..) , ConversationId (..) , TeamId (..) , Cursor (..) , SlackTimestamp(..) , mkSlackTimestamp , timestampFromText - , HistoryReq(..) - , mkHistoryReq - , HistoryRsp(..) , Message(..) , MessageType(..) , SlackClientError(..) @@ -47,9 +44,6 @@ -- deepseq import Control.DeepSeq (NFData) --- http-api-data -import Web.HttpApiData -import Web.FormUrlEncoded -- servant-client import Servant.Client @@ -65,61 +59,6 @@ type ClientError = ServantError #endif --- | --- --- - -data HistoryReq = - HistoryReq - { historyReqChannel :: Text - , historyReqCount :: Int - , historyReqLatest :: Maybe SlackTimestamp - , historyReqOldest :: Maybe SlackTimestamp - , historyReqInclusive :: Bool - } - deriving (Eq, Show, Generic) - -instance NFData HistoryReq - - --- | --- --- - -$(deriveJSON (jsonOpts "historyReq") ''HistoryReq) - - --- | --- --- - -instance ToForm HistoryReq where - -- can't use genericToForm because slack expects booleans as 0/1 - toForm HistoryReq{..} = - [ ("channel", toQueryParam historyReqChannel) - , ("count", toQueryParam historyReqCount) - ] - <> toQueryParamIfJust "latest" historyReqLatest - <> toQueryParamIfJust "oldest" historyReqOldest - <> [("inclusive", toQueryParam (if historyReqInclusive then 1 :: Int else 0))] - - --- | --- --- - -mkHistoryReq - :: Text - -> HistoryReq -mkHistoryReq channel = - HistoryReq - { historyReqChannel = channel - , historyReqCount = 100 - , historyReqLatest = Nothing - , historyReqOldest = Nothing - , historyReqInclusive = True - } - data MessageType = MessageTypeMessage deriving (Eq, Show, Generic) @@ -146,17 +85,6 @@ instance NFData Message $(deriveJSON (jsonOpts "message") ''Message) - -data HistoryRsp = - HistoryRsp - { historyRspMessages :: [Message] - , historyRspHasMore :: Bool - } - deriving (Eq, Generic, Show) - -instance NFData HistoryRsp - -$(deriveJSON (jsonOpts "historyRsp") ''HistoryRsp) -- | -- Errors that can be triggered by a slack request. diff --git a/src/Web/Slack/Conversation.hs b/src/Web/Slack/Conversation.hs --- a/src/Web/Slack/Conversation.hs +++ b/src/Web/Slack/Conversation.hs @@ -57,7 +57,7 @@ import Web.HttpApiData -- slack-web -import Web.Slack.Common hiding (HistoryReq, HistoryRsp, mkHistoryReq) +import Web.Slack.Common import Web.Slack.Util -- scientific diff --git a/src/Web/Slack/Group.hs b/src/Web/Slack/Group.hs deleted file mode 100644 --- a/src/Web/Slack/Group.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} - ----------------------------------------------------------------------- --- | --- Module: Web.Slack.Group --- Description: --- --- --- ----------------------------------------------------------------------- - -module Web.Slack.Group - ( Group(..) - , ListRsp(..) - ) - where - --- aeson -import Data.Aeson.TH - --- base -import GHC.Generics (Generic) - --- deepseq -import Control.DeepSeq (NFData) - --- slack-web -import Web.Slack.Common -import Web.Slack.Util - --- text -import Data.Text (Text) - --- time -import Data.Time.Clock.POSIX - -data Group = - Group - { groupId :: Text - , groupName :: Text - , groupIsMpim :: Bool - , groupCreated :: POSIXTime - , groupCreator :: UserId - , groupIsArchived :: Bool - , groupMembers :: [UserId] - } - deriving (Eq, Generic, Show) - -instance NFData Group - -$(deriveFromJSON (jsonOpts "group") ''Group) - -data ListRsp = - ListRsp - { 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 deleted file mode 100644 --- a/src/Web/Slack/Im.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - ----------------------------------------------------------------------- --- | --- Module: Web.Slack.Im --- Description: --- --- --- ----------------------------------------------------------------------- - -module Web.Slack.Im - ( Im(..) - , ListRsp(..) - ) - where - --- aeson -import Data.Aeson.TH - --- base -import GHC.Generics (Generic) - --- deepseq -import Control.DeepSeq (NFData) - --- slack-web -import Web.Slack.Util -import Web.Slack.Common - --- text -import Data.Text (Text) - --- time -import Data.Time.Clock.POSIX - -data Im = - Im - { imId :: Text - , imIsIm :: Bool - , imUser :: UserId - , imCreated :: POSIXTime - , imIsUserDeleted :: Bool - } - deriving (Eq, Show, Generic) - -instance NFData Im - -$(deriveFromJSON (jsonOpts "im") ''Im) - -data ListRsp = - ListRsp - { listRspIms :: [Im] - } - 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 --- a/src/Web/Slack/Pager.hs +++ b/src/Web/Slack/Pager.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Web.Slack.Pager @@ -9,18 +9,18 @@ , conversationsHistoryAllBy , repliesFetchAllBy , LoadPage + , loadingPage ) where -- base -import Control.Monad (join) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Maybe (isNothing) +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.Common as Common import qualified Web.Slack.Conversation as Conversation -import qualified Web.Slack.Common as Common +import Web.Slack.Types (Cursor) -- | Public only for testing. @@ -30,8 +30,8 @@ -- ^ 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. + -> 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 @@ -46,7 +46,7 @@ -- ^ Response generator -> Conversation.RepliesReq -- ^ The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. - -> m (LoadPage m [Common.Message]) + -> 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 = @@ -62,14 +62,29 @@ -- 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) +type LoadPage m a = m (Response [a]) +-- | Utility function for 'LoadPage'. Perform the 'LoadPage' action to call +-- the function with the loaded page, until an empty page is loaded. +loadingPage :: (Monad m, Monoid n) => LoadPage m a -> (Response [a] -> m n) -> m n +loadingPage loadPage usePage = go mempty + where + go result = do + epage <- loadPage + case epage of + Right page -> + if null page + then return result + else (go $!) . (result <>) =<< usePage epage + Left e -> (result <>) <$> usePage (Left e) + + genericFetchAllBy :: MonadIO m => (a -> m (Response Conversation.HistoryRsp)) -> (Maybe Cursor -> a) - -> m (LoadPage m [Common.Message]) + -> m (LoadPage m Common.Message) genericFetchAllBy sendRequest requestFromCursor = do cursorRef <- liftIO $ newIORef Nothing