diff --git a/main/cli.hs b/main/cli.hs --- a/main/cli.hs +++ b/main/cli.hs @@ -27,7 +27,7 @@ import Text.Pretty.Simple (pPrint, pShow) -- slack-web -import qualified Web.Slack as Slack +import qualified Web.Slack.Classy as Slack import qualified Web.Slack.Common as Slack import qualified Web.Slack.Conversation as SlackConversation 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.3.0.1 +version: 0.4.0.0 build-type: Simple cabal-version: 1.20 @@ -19,7 +19,7 @@ category: Web -tested-with: GHC == 8.0.2 +tested-with: GHC == 8.10.7 extra-source-files: CHANGELOG.md @@ -34,17 +34,18 @@ Web.Slack.Api Web.Slack.Auth Web.Slack.Chat + Web.Slack.Classy Web.Slack.Common Web.Slack.Conversation Web.Slack.MessageParser + Web.Slack.Pager Web.Slack.Types Web.Slack.User - Web.Slack.Pager other-modules: Web.Slack.Util build-depends: aeson >= 1.0 && < 1.6 - , base >= 4.11 && < 4.15 + , base >= 4.11 && < 4.16 , scientific , containers , deepseq diff --git a/src/Web/Slack.hs b/src/Web/Slack.hs --- a/src/Web/Slack.hs +++ b/src/Web/Slack.hs @@ -1,15 +1,16 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeOperators #-} ---------------------------------------------------------------------- -- | -- Module: Web.Slack --- Description: --- --- +-- Description: Provides Slack's Web API functions. +-- *Since 0.4.0.0*: The API functions is now more intuitive for newbies +-- than before. If you need compatiblity with the previous version, use +-- 'Web.Slack.Classy' instead. -- ---------------------------------------------------------------------- @@ -30,8 +31,6 @@ , authenticateReq , Response , LoadPage - , HasManager(..) - , HasToken(..) ) where @@ -60,7 +59,13 @@ -- servant-client import Servant.Client hiding (Response, baseUrl) + +#if MIN_VERSION_servant(0,16,0) +import Servant.Client.Core (AuthClientData, AuthenticatedRequest, Request, mkAuthenticatedRequest, addHeader) +#else +import Servant.Client.Core.Internal.Auth import Servant.Client.Core (Request, addHeader) +#endif -- slack-web import qualified Web.Slack.Api as Api @@ -79,31 +84,13 @@ mkClientEnv = ClientEnv #endif -#if MIN_VERSION_servant(0,16,0) -import Servant.Client.Core (AuthenticatedRequest, AuthClientData, mkAuthenticatedRequest, ClientError) -#else -import Servant.Client.Core.Internal.Auth -import Servant.Client.Core (ServantError) -type ClientError = ServantError -#endif -class HasManager a where - getManager :: a -> Manager - -class HasToken a where - getToken :: a -> Text - --- | Implements the 'HasManager' and 'HasToken' typeclasses. data SlackConfig = SlackConfig { slackConfigManager :: Manager , slackConfigToken :: Text } -instance HasManager SlackConfig where - getManager = slackConfigManager -instance HasToken SlackConfig where - getToken = slackConfigToken -- contains errors that can be returned by the slack API. -- constrast with 'SlackClientError' which additionally @@ -128,7 +115,6 @@ -- | -- -- - type Api = "api.test" :> ReqBody '[FormUrlEncoded] Api.TestReq @@ -175,15 +161,16 @@ -- apiTest - :: (MonadReader env m, HasManager env, MonadIO m) - => Api.TestReq - -> m (Response Api.TestRsp) -apiTest req = run (apiTest_ req) + :: Manager + -> Api.TestReq + -> IO (Response Api.TestRsp) +apiTest mgr req = run (apiTest_ req) mgr apiTest_ :: Api.TestReq -> ClientM (ResponseJSON Api.TestRsp) + -- | -- -- Check authentication and identity. @@ -191,11 +178,11 @@ -- authTest - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => m (Response Auth.TestRsp) + :: SlackConfig + -> IO (Response Auth.TestRsp) authTest = do authR <- mkSlackAuthenticateReq - run (authTest_ authR) + run (authTest_ authR) . slackConfigManager authTest_ :: AuthenticatedRequest (AuthProtect "token") @@ -208,12 +195,12 @@ -- conversationsList - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Conversation.ListReq - -> m (Response Conversation.ListRsp) -conversationsList listReq = do + :: SlackConfig + -> Conversation.ListReq + -> IO (Response Conversation.ListRsp) +conversationsList = flip $ \listReq -> do authR <- mkSlackAuthenticateReq - run (conversationsList_ authR listReq) + run (conversationsList_ authR listReq) . slackConfigManager conversationsList_ :: AuthenticatedRequest (AuthProtect "token") @@ -229,12 +216,12 @@ -- conversationsHistory - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Conversation.HistoryReq - -> m (Response Conversation.HistoryRsp) -conversationsHistory histReq = do + :: SlackConfig + -> Conversation.HistoryReq + -> IO (Response Conversation.HistoryRsp) +conversationsHistory = flip $ \histReq -> do authR <- mkSlackAuthenticateReq - run (conversationsHistory_ authR histReq) + run (conversationsHistory_ authR histReq) . slackConfigManager conversationsHistory_ :: AuthenticatedRequest (AuthProtect "token") @@ -251,12 +238,12 @@ -- conversationsReplies - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Conversation.RepliesReq - -> m (Response Conversation.HistoryRsp) -conversationsReplies repliesReq = do + :: SlackConfig + -> Conversation.RepliesReq + -> IO (Response Conversation.HistoryRsp) +conversationsReplies = flip $ \repliesReq -> do authR <- mkSlackAuthenticateReq - run (conversationsReplies_ authR repliesReq) + run (conversationsReplies_ authR repliesReq) . slackConfigManager conversationsReplies_ :: AuthenticatedRequest (AuthProtect "token") @@ -271,12 +258,12 @@ -- chatPostMessage - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => Chat.PostMsgReq - -> m (Response Chat.PostMsgRsp) -chatPostMessage postReq = do + :: SlackConfig + -> Chat.PostMsgReq + -> IO (Response Chat.PostMsgRsp) +chatPostMessage = flip $ \postReq -> do authR <- mkSlackAuthenticateReq - run (chatPostMessage_ authR postReq) + run (chatPostMessage_ authR postReq) . slackConfigManager chatPostMessage_ :: AuthenticatedRequest (AuthProtect "token") @@ -292,11 +279,11 @@ -- usersList - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => m (Response User.ListRsp) + :: SlackConfig + -> IO (Response User.ListRsp) usersList = do authR <- mkSlackAuthenticateReq - run (usersList_ authR) + run (usersList_ authR) . slackConfigManager usersList_ :: AuthenticatedRequest (AuthProtect "token") @@ -310,12 +297,12 @@ -- userLookupByEmail - :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) - => User.Email - -> m (Response User.UserRsp) -userLookupByEmail email = do + :: SlackConfig + -> User.Email + -> IO (Response User.UserRsp) +userLookupByEmail = flip $ \email -> do authR <- mkSlackAuthenticateReq - run (userLookupByEmail_ authR email) + run (userLookupByEmail_ authR email) . slackConfigManager userLookupByEmail_ :: AuthenticatedRequest (AuthProtect "token") @@ -343,13 +330,13 @@ -- 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 + :: SlackConfig + -> Conversation.HistoryReq -- ^ The first request to send. _NOTE_: 'Conversation.historyReqCursor' is silently ignored. - -> m (LoadPage m Common.Message) + -> IO (LoadPage IO 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 +conversationsHistoryAll = conversationsHistoryAllBy . conversationsHistory -- | Returns an action to send a request to get the replies of a conversation. @@ -362,14 +349,15 @@ -- 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 + :: SlackConfig + -> Conversation.RepliesReq -- ^ The first request to send. _NOTE_: 'Conversation.repliesReqCursor' is silently ignored. - -> m (LoadPage m Common.Message) + -> IO (LoadPage IO 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 +repliesFetchAll = repliesFetchAllBy . conversationsReplies + apiTest_ :<|> authTest_ :<|> conversationsList_ @@ -393,7 +381,6 @@ -- | -- -- - authenticateReq :: Text -> Request @@ -407,17 +394,17 @@ -- run - :: (MonadReader env m, HasManager env, MonadIO m) - => ClientM (ResponseJSON a) - -> m (Response a) -run clientAction = do - env <- ask + :: ClientM (ResponseJSON a) + -> Manager + -> IO (Response a) +run clientAction mgr = do let baseUrl = BaseUrl Https "slack.com" 443 "/api" - unnestErrors <$> liftIO (runClientM clientAction $ mkClientEnv (getManager env) baseUrl) + unnestErrors <$> liftIO (runClientM clientAction $ mkClientEnv mgr baseUrl) -mkSlackAuthenticateReq :: (MonadReader env m, HasToken env) - => m (AuthenticatedRequest (AuthProtect "token")) -mkSlackAuthenticateReq = flip mkAuthenticatedRequest authenticateReq . getToken <$> ask + +mkSlackAuthenticateReq :: SlackConfig -> AuthenticatedRequest (AuthProtect "token") +mkSlackAuthenticateReq = (`mkAuthenticatedRequest` authenticateReq) . slackConfigToken + unnestErrors :: Either ClientError (ResponseJSON a) -> Response a unnestErrors (Right (ResponseJSON (Right a))) = Right a diff --git a/src/Web/Slack/Classy.hs b/src/Web/Slack/Classy.hs new file mode 100644 --- /dev/null +++ b/src/Web/Slack/Classy.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} + +---------------------------------------------------------------------- +-- | +-- Module: Web.Slack.Classy +-- Description: For compatibility with Web.Slack prior to v0.4.0.0. +-- +-- +-- +---------------------------------------------------------------------- + +module Web.Slack.Classy + ( SlackConfig(..) + , mkSlackConfig + , apiTest + , authTest + , chatPostMessage + , conversationsList + , conversationsHistory + , conversationsHistoryAll + , conversationsReplies + , repliesFetchAll + , getUserDesc + , usersList + , userLookupByEmail + , authenticateReq + , Response + , LoadPage + , HasManager(..) + , HasToken(..) + ) + where + +-- base +import Control.Arrow ((&&&)) +import Data.Maybe + +-- containers +import qualified Data.Map as Map + +-- http-client +import Network.HTTP.Client (Manager) + +-- mtl +import Control.Monad.Reader + +-- 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.Chat as Chat +import qualified Web.Slack.Common as Common +import qualified Web.Slack.User as User +import Web.Slack.Pager +import qualified Web.Slack as NonClassy +import Web.Slack (SlackConfig (..), authenticateReq, mkSlackConfig) + +-- text +import Data.Text (Text) + +#if !MIN_VERSION_servant(0,13,0) +mkClientEnv :: Manager -> BaseUrl -> ClientEnv +mkClientEnv = ClientEnv +#endif + +-- | Implemented by 'SlackConfig' +class HasManager a where + getManager :: a -> Manager + +-- | Implemented by 'SlackConfig' +class HasToken a where + getToken :: a -> Text + +instance HasManager SlackConfig where + getManager = slackConfigManager +instance HasToken SlackConfig where + getToken = slackConfigToken + + +-- | +-- +-- Check API calling code. +-- +-- + +apiTest + :: (MonadReader env m, HasManager env, MonadIO m) + => Api.TestReq + -> m (Response Api.TestRsp) +apiTest = liftToReader . flip (NonClassy.apiTest . getManager) + + +-- | +-- +-- Check authentication and identity. +-- +-- + +authTest + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => m (Response Auth.TestRsp) +authTest = liftNonClassy NonClassy.authTest + + +-- | +-- +-- Retrieve conversations list. +-- +-- + +conversationsList + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => Conversation.ListReq + -> m (Response Conversation.ListRsp) +conversationsList = liftNonClassy . flip NonClassy.conversationsList + + +-- | +-- +-- 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 = liftNonClassy . flip NonClassy.conversationsHistory + + +-- | +-- +-- 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 = liftNonClassy . flip NonClassy.conversationsReplies + + +-- | +-- +-- Send a message to a channel. +-- +-- + +chatPostMessage + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => Chat.PostMsgReq + -> m (Response Chat.PostMsgRsp) +chatPostMessage = liftNonClassy . flip NonClassy.chatPostMessage + + +-- | +-- +-- This method returns a list of all users in the team. +-- This includes deleted/deactivated users. +-- +-- + +usersList + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => m (Response User.ListRsp) +usersList = liftNonClassy NonClassy.usersList + + +-- | +-- +-- This method returns a list of all users in the team. +-- This includes deleted/deactivated users. +-- +-- + +userLookupByEmail + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => User.Email + -> m (Response User.UserRsp) +userLookupByEmail = liftNonClassy . flip NonClassy.userLookupByEmail + + +-- | Returns a function to get a username from a 'Common.UserId'. +-- Comes in handy to use 'Web.Slack.MessageParser.messageToHtml' +getUserDesc + :: (Common.UserId -> Text) + -- ^ A function to give a default username in case the username is unknown + -> User.ListRsp + -- ^ List of users as known by the slack server. See 'usersList'. + -> (Common.UserId -> Text) + -- ^ A function from 'Common.UserId' to username. +getUserDesc unknownUserFn users = + let userMap = Map.fromList $ (User.userId &&& User.userName) <$> User.listRspMembers users + in + \userId -> fromMaybe (unknownUserFn userId) $ Map.lookup userId userMap + + +-- | 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 + + +liftNonClassy + :: (MonadReader env m, HasManager env, HasToken env, MonadIO m) + => (SlackConfig -> IO a) -> m a +liftNonClassy f = + liftToReader $ \env -> f $ SlackConfig (getManager env) (getToken env) + + +liftToReader + :: (MonadReader env m, MonadIO m) + => (env -> IO a) -> m a +liftToReader f = do + env <- ask + liftIO $ f env