Do paged conversation lists; change the pager to be generic over types

slack-web.cabal

@@ -105,6 +105,7 @@ library
       Web.Slack.Internal
       Web.Slack.MessageParser
       Web.Slack.Pager
+      Web.Slack.Pager.Types
       Web.Slack.Types
       Web.Slack.User
       Web.Slack.Experimental.Blocks

src/Web/Slack.hs

@@ -19,6 +19,7 @@ module Web.Slack
     authTest,
     chatPostMessage,
     conversationsList,
+    conversationsListAll,
     conversationsHistory,
     conversationsHistoryAll,
     conversationsReplies,
@@ -147,6 +148,20 @@ conversationsList_ ::
   Conversation.ListReq ->
   ClientM (ResponseJSON Conversation.ListRsp)
 
+-- | Returns an action to send a request to get the list of conversations in the
+--   workspace.
+--
+--   To fetch all replies in the conversation, run the returned 'LoadPage' action
+--   repeatedly until it returns an empty list.
+conversationsListAll ::
+  SlackConfig ->
+  -- | The first request to send. _NOTE_: 'Conversation.listReqCursor' is silently ignored.
+  Conversation.ListReq ->
+  -- | An action which returns a new page of messages every time called.
+  --   If there are no pages anymore, it returns an empty list.
+  IO (LoadPage IO Conversation.Conversation)
+conversationsListAll = fetchAllBy . conversationsList
+
 -- |
 --
 -- Retrieve ceonversation history.
@@ -264,7 +279,7 @@ conversationsHistoryAll ::
   -- | An action which returns a new page of messages every time called.
   --   If there are no pages anymore, it returns an empty list.
   IO (LoadPage IO Common.Message)
-conversationsHistoryAll = conversationsHistoryAllBy . conversationsHistory
+conversationsHistoryAll = fetchAllBy . conversationsHistory
 
 -- | Returns an action to send a request to get the replies of a conversation.
 --
@@ -282,7 +297,7 @@ repliesFetchAll ::
   -- | An action which returns a new page of messages every time called.
   --   If there are no pages anymore, it returns an empty list.
   IO (LoadPage IO Common.Message)
-repliesFetchAll = repliesFetchAllBy . conversationsReplies
+repliesFetchAll = fetchAllBy . conversationsReplies
 
 apiTest_
   :<|> authTest_

src/Web/Slack/Classy.hs

@@ -191,7 +191,7 @@ conversationsHistoryAll ::
   -- | An action which returns a new page of messages every time called.
   --   If there are no pages anymore, it returns an empty list.
   m (LoadPage m Common.Message)
-conversationsHistoryAll = conversationsHistoryAllBy conversationsHistory
+conversationsHistoryAll = fetchAllBy conversationsHistory
 
 -- | Returns an action to send a request to get the replies of a conversation.
 --
@@ -209,7 +209,7 @@ repliesFetchAll ::
   -- | An action which returns a new page of messages every time called.
   --   If there are no pages anymore, it returns an empty list.
   m (LoadPage m Common.Message)
-repliesFetchAll = repliesFetchAllBy conversationsReplies
+repliesFetchAll = fetchAllBy conversationsReplies
 
 liftNonClassy ::
   (MonadReader env m, HasManager env, HasToken env, MonadIO m) =>

src/Web/Slack/Conversation.hs

@@ -50,19 +50,14 @@ import Data.Aeson.Encoding
 import Data.Aeson.KeyMap qualified as KM
 import Data.Aeson.TH
 import Data.Aeson.Types
--- http-api-data
-
--- slack-web
-
--- scientific
 import Data.Scientific
--- text
 import Data.Text (Text)
 import Data.Text qualified as T
 import GHC.Generics (Generic)
 import Web.FormUrlEncoded
 import Web.HttpApiData
 import Web.Slack.Common
+import Web.Slack.Pager.Types (PagedRequest (..), PagedResponse (..), ResponseMetadata (..))
 import Web.Slack.Util
 import Prelude
 
@@ -211,7 +206,7 @@ instance FromJSON Conversation where
         (typeMismatch "Conversation" (Object o))
     where
       parseWhen key con o = do
-        is <- (o .: key)
+        is <- o .: key
         if is
           then con <$> parseJSON (Object o)
           else empty
@@ -269,6 +264,9 @@ instance FromJSON ConversationType where
 data ListReq = ListReq
   { listReqExcludeArchived :: Maybe Bool
   , listReqTypes :: [ConversationType]
+  , listReqCursor :: Maybe Cursor
+  , listReqLimit :: Maybe Int
+  , listReqTeamId :: Maybe TeamId
   }
   deriving stock (Eq, Show, Generic)
 
@@ -282,28 +280,52 @@ mkListReq =
   ListReq
     { listReqExcludeArchived = Nothing
     , listReqTypes = []
+    , listReqLimit = Nothing
+    , listReqTeamId = Nothing
+    , listReqCursor = Nothing
     }
 
 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
+  toForm
+    ( ListReq
+        { listReqExcludeArchived = archived
+        , listReqTypes = types
+        , listReqTeamId
+        , listReqCursor
+        , listReqLimit
+        }
+      ) =
+      archivedForm
+        <> typesForm
+        <> toQueryParamIfJust "team_id" listReqTeamId
+        <> toQueryParamIfJust "cursor" listReqCursor
+        <> toQueryParamIfJust "limit" listReqLimit
+      where
+        archivedForm =
+          maybe mempty (\val -> [("archived", toUrlPiece val)]) archived
+        typesForm =
+          if null types
+            then mempty
+            else [("types", T.intercalate "," $ map toUrlPiece types)]
+
+data ListRsp = ListRsp
   { listRspChannels :: [Conversation]
+  , listRspResponseMetadata :: Maybe ResponseMetadata
   }
   deriving stock (Eq, Show, Generic)
 
 instance NFData ListRsp
 
 $(deriveFromJSON (jsonOpts "listRsp") ''ListRsp)
 
+instance PagedRequest ListReq where
+  setCursor c r = r {listReqCursor = c}
+
+instance PagedResponse ListRsp where
+  type ResponseObject ListRsp = Conversation
+  getResponseData ListRsp {listRspChannels} = listRspChannels
+  getResponseMetadata ListRsp {listRspResponseMetadata} = listRspResponseMetadata
+
 data HistoryReq = HistoryReq
   { historyReqChannel :: ConversationId
   , historyReqCursor :: Maybe Cursor
@@ -341,13 +363,6 @@ instance ToForm HistoryReq where
       <> toQueryParamIfJust "oldest" historyReqOldest
       <> [("inclusive", toQueryParam (if historyReqInclusive then 1 :: Int else 0))]
 
-newtype ResponseMetadata = ResponseMetadata {responseMetadataNextCursor :: Maybe Cursor}
-  deriving stock (Eq, Show, Generic)
-
-instance NFData ResponseMetadata
-
-$(deriveJSON (jsonOpts "responseMetadata") ''ResponseMetadata)
-
 data HistoryRsp = HistoryRsp
   { historyRspMessages :: [Message]
   , historyRspResponseMetadata :: Maybe ResponseMetadata
@@ -358,6 +373,14 @@ instance NFData HistoryRsp
 
 $(deriveJSON (jsonOpts "historyRsp") ''HistoryRsp)
 
+instance PagedRequest HistoryReq where
+  setCursor c r = r {historyReqCursor = c}
+
+instance PagedResponse HistoryRsp where
+  type ResponseObject HistoryRsp = Message
+  getResponseMetadata HistoryRsp {historyRspResponseMetadata} = historyRspResponseMetadata
+  getResponseData HistoryRsp {historyRspMessages} = historyRspMessages
+
 data RepliesReq = RepliesReq
   { repliesReqTs :: SlackTimestamp
   , repliesReqCursor :: Maybe Cursor
@@ -384,6 +407,9 @@ instance ToForm RepliesReq where
       <> toQueryParamIfJust "oldest" repliesReqOldest
       <> [("inclusive", toQueryParam (if repliesReqInclusive then 1 :: Int else 0))]
 
+instance PagedRequest RepliesReq where
+  setCursor c r = r {repliesReqCursor = c}
+
 mkRepliesReq ::
   ConversationId ->
   SlackTimestamp ->

src/Web/Slack/Pager.hs

@@ -1,56 +1,16 @@
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 module Web.Slack.Pager
   ( Response,
-    conversationsHistoryAllBy,
-    repliesFetchAllBy,
     LoadPage,
     loadingPage,
+    fetchAllBy,
+    module Web.Slack.Pager.Types,
   )
 where
 
--- FIXME: Web.Slack.Prelude
-
--- base
-import Control.Monad.IO.Class (MonadIO, liftIO)
-import Data.IORef (newIORef, readIORef, writeIORef)
-import Data.Maybe (isNothing)
--- slack-web
 import Web.Slack.Common qualified as Common
 import Web.Slack.Conversation qualified as Conversation
-import Web.Slack.Types (Cursor)
-import Prelude
-
--- | Public only for testing.
-conversationsHistoryAllBy ::
-  MonadIO m =>
-  -- | Response generator
-  (Conversation.HistoryReq -> m (Response Conversation.HistoryRsp)) ->
-  -- | The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored.
-  Conversation.HistoryReq ->
-  -- | An action which returns a new page of messages every time called.
-  --   If there are no pages anymore, it returns an empty list.
-  m (LoadPage m Common.Message)
-conversationsHistoryAllBy sendRequest initialRequest =
-  genericFetchAllBy
-    sendRequest
-    (\cursor -> initialRequest {Conversation.historyReqCursor = cursor})
-
--- | Public only for testing.
-repliesFetchAllBy ::
-  MonadIO m =>
-  -- | Response generator
-  (Conversation.RepliesReq -> m (Response Conversation.HistoryRsp)) ->
-  -- | The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored.
-  Conversation.RepliesReq ->
-  -- | An action which returns a new page of messages every time called.
-  --   If there are no pages anymore, it returns an empty list.
-  m (LoadPage m Common.Message)
-repliesFetchAllBy sendRequest initialRequest =
-  genericFetchAllBy
-    sendRequest
-    (\cursor -> initialRequest {Conversation.repliesReqCursor = cursor})
+import Web.Slack.Pager.Types
+import Web.Slack.Prelude
 
 type Response a = Either Common.SlackClientError a
 
@@ -74,24 +34,24 @@ loadingPage loadPage usePage = go mempty
             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)
-genericFetchAllBy sendRequest requestFromCursor = do
+fetchAllBy ::
+  ( MonadIO m
+  , PagedRequest req
+  , PagedResponse resp
+  ) =>
+  (req -> m (Response resp)) ->
+  req ->
+  m (LoadPage m (ResponseObject resp))
+fetchAllBy sendRequest initialRequest = 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
+  let requestFromCursor cursor = setCursor cursor initialRequest
+      collectAndUpdateCursor resp = do
+        let newCursor = Conversation.responseMetadataNextCursor =<< getResponseMetadata resp
+            -- 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 $ getResponseData resp
 
   return $ do
     cursor <- liftIO $ readIORef cursorRef

src/Web/Slack/Pager/Types.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Web.Slack.Pager.Types where
+
+import Web.Slack.Prelude
+import Web.Slack.Util
+
+newtype Cursor = Cursor {unCursor :: Text}
+  deriving stock (Eq, Generic, Show)
+  deriving newtype (NFData, Hashable, FromJSON, ToJSON, ToHttpApiData)
+
+newtype ResponseMetadata = ResponseMetadata {responseMetadataNextCursor :: Maybe Cursor}
+  deriving stock (Eq, Show, Generic)
+
+instance NFData ResponseMetadata
+
+$(deriveJSON (jsonOpts "responseMetadata") ''ResponseMetadata)
+
+class PagedRequest a where
+  setCursor :: Maybe Cursor -> a -> a
+
+class PagedResponse a where
+  type ResponseObject a
+  getResponseMetadata :: a -> Maybe ResponseMetadata
+  getResponseData :: a -> [ResponseObject a]

src/Web/Slack/Prelude.hs

@@ -3,10 +3,12 @@ module Web.Slack.Prelude
     module Data.Aeson,
     module Data.Aeson.TH,
     cs,
+    ToHttpApiData,
   )
 where
 
 import ClassyPrelude hiding (link)
 import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.:?), (.=))
 import Data.Aeson.TH (deriveJSON)
 import Data.String.Conversions (cs)
+import Web.HttpApiData (ToHttpApiData)

src/Web/Slack/Types.hs

@@ -18,21 +18,14 @@ module Web.Slack.Types
   )
 where
 
--- aeson
-
--- http-api-data
-
--- text
-
--- time
-
 import Control.Monad (MonadFail (..))
 import Data.Aeson
 import Data.Text qualified as T
 import Data.Text.Read (rational)
 import Data.Time.Clock
 import Data.Time.Clock.POSIX
 import Web.HttpApiData
+import Web.Slack.Pager.Types
 import Web.Slack.Prelude
 
 -- Ord to allow it to be a key of a Map
@@ -57,10 +50,6 @@ 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.