module Web.Slack
( SlackConfig(..)
, mkSlackConfig
, apiTest
, authTest
, chatPostMessage
, channelsCreate
, channelsList
, channelsHistory
, groupsHistory
, groupsList
, historyFetchAll
, imHistory
, imList
, mpimList
, mpimHistory
, getUserDesc
, usersList
, authenticateReq
, Response
, HasManager
, HasToken
)
where
import Data.Aeson
import Control.Arrow ((&&&))
import Data.Maybe
import Data.Proxy (Proxy(..))
import qualified Data.Map as Map
import Control.Error (lastZ, isNothing)
import Network.HTTP.Client (Manager, newManager)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Control.Monad.Reader
import Servant.API
import Servant.Client
import Servant.Common.Req (Req, appendToQueryString)
import qualified Web.Slack.Api as Api
import qualified Web.Slack.Auth as Auth
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 Data.Text (Text)
class HasManager a where
getManager :: a -> Manager
class HasToken a where
getToken :: a -> Text
data SlackConfig
= SlackConfig
{ slackConfigManager :: Manager
, slackConfigToken :: Text
}
instance HasManager SlackConfig where
getManager = slackConfigManager
instance HasToken SlackConfig where
getToken = slackConfigToken
data ResponseSlackError = ResponseSlackError Text
deriving (Eq, Show)
type Response a = Either Common.SlackClientError a
newtype ResponseJSON a = ResponseJSON (Either ResponseSlackError a)
instance FromJSON a => FromJSON (ResponseJSON a) where
parseJSON = withObject "Response" $ \o -> do
ok <- o .: "ok"
ResponseJSON <$> if ok
then Right <$> parseJSON (Object o)
else Left . ResponseSlackError <$> o .: "error"
type Api =
"api.test"
:> ReqBody '[FormUrlEncoded] Api.TestReq
:> Post '[JSON] (ResponseJSON Api.TestRsp)
:<|>
"auth.test"
:> AuthProtect "token"
:> Post '[JSON] (ResponseJSON Auth.TestRsp)
:<|>
"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)
apiTest
:: (MonadReader env m, HasManager env, MonadIO m)
=> Api.TestReq
-> m (Response Api.TestRsp)
apiTest req = run (apiTest_ req)
apiTest_
:: Api.TestReq
-> ClientM (ResponseJSON Api.TestRsp)
authTest
:: (MonadReader env m, HasManager env, HasToken env, MonadIO m)
=> m (Response Auth.TestRsp)
authTest = do
authR <- mkSlackAuthenticateReq
run (authTest_ authR)
authTest_
:: AuthenticateReq (AuthProtect "token")
-> ClientM (ResponseJSON Auth.TestRsp)
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_
:: AuthenticateReq (AuthProtect "token")
-> Channel.CreateReq
-> ClientM (ResponseJSON Channel.CreateRsp)
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_
:: AuthenticateReq (AuthProtect "token")
-> Channel.ListReq
-> ClientM (ResponseJSON Channel.ListRsp)
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_
:: AuthenticateReq (AuthProtect "token")
-> Common.HistoryReq
-> ClientM (ResponseJSON Common.HistoryRsp)
chatPostMessage
:: (MonadReader env m, HasManager env, HasToken env, MonadIO m)
=> Chat.PostMsgReq
-> m (Response Chat.PostMsgRsp)
chatPostMessage postReq = do
authR <- mkSlackAuthenticateReq
run (chatPostMessage_ authR postReq)
chatPostMessage_
:: AuthenticateReq (AuthProtect "token")
-> Chat.PostMsgReq
-> ClientM (ResponseJSON Chat.PostMsgRsp)
groupsList
:: (MonadReader env m, HasManager env, HasToken env, MonadIO m)
=> m (Response Group.ListRsp)
groupsList = do
authR <- mkSlackAuthenticateReq
run (groupsList_ authR)
groupsList_
:: AuthenticateReq (AuthProtect "token")
-> ClientM (ResponseJSON Group.ListRsp)
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_
:: AuthenticateReq (AuthProtect "token")
-> Common.HistoryReq
-> ClientM (ResponseJSON Common.HistoryRsp)
imList
:: (MonadReader env m, HasManager env, HasToken env, MonadIO m)
=> m (Response Im.ListRsp)
imList = do
authR <- mkSlackAuthenticateReq
run (imList_ authR)
imList_
:: AuthenticateReq (AuthProtect "token")
-> ClientM (ResponseJSON Im.ListRsp)
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_
:: AuthenticateReq (AuthProtect "token")
-> Common.HistoryReq
-> ClientM (ResponseJSON Common.HistoryRsp)
mpimList
:: (MonadReader env m, HasManager env, HasToken env, MonadIO m)
=> m (Response Group.ListRsp)
mpimList = do
authR <- mkSlackAuthenticateReq
run (mpimList_ authR)
mpimList_
:: AuthenticateReq (AuthProtect "token")
-> ClientM (ResponseJSON Group.ListRsp)
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_
:: AuthenticateReq (AuthProtect "token")
-> Common.HistoryReq
-> ClientM (ResponseJSON Common.HistoryRsp)
usersList
:: (MonadReader env m, HasManager env, HasToken env, MonadIO m)
=> m (Response User.ListRsp)
usersList = do
authR <- mkSlackAuthenticateReq
run (usersList_ authR)
usersList_
:: AuthenticateReq (AuthProtect "token")
-> ClientM (ResponseJSON User.ListRsp)
getUserDesc
:: (Common.UserId -> Text)
-> User.ListRsp
-> (Common.UserId -> Text)
getUserDesc unknownUserFn users =
let userMap = Map.fromList $ (User.userId &&& User.userName) <$> User.listRspMembers users
in
\userId -> fromMaybe (unknownUserFn userId) $ Map.lookup userId userMap
historyFetchAll
:: (MonadReader env m, HasManager env, HasToken env, MonadIO m)
=> (Common.HistoryReq -> m (Response Common.HistoryRsp))
-> Text
-> Int
-> Common.SlackTimestamp
-> Common.SlackTimestamp
-> m (Response Common.HistoryRsp)
historyFetchAll makeReq channel count oldest latest = do
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)
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_
:<|> channelsCreate_
:<|> channelsHistory_
:<|> channelsList_
:<|> chatPostMessage_
:<|> groupsHistory_
:<|> groupsList_
:<|> imHistory_
:<|> imList_
:<|> mpimList_
:<|> mpimHistory_
:<|> usersList_
=
client (Proxy :: Proxy Api)
type instance AuthClientData (AuthProtect "token") =
Text
authenticateReq
:: Text
-> Req
-> Req
authenticateReq token =
appendToQueryString "token" (Just token)
run
:: (MonadReader env m, HasManager env, MonadIO m)
=> ClientM (ResponseJSON a)
-> m (Response a)
run clientAction = do
env <- ask
let baseUrl = BaseUrl Https "slack.com" 443 "/api"
unnestErrors <$> liftIO (runClientM clientAction $ ClientEnv (getManager env) baseUrl)
mkSlackAuthenticateReq :: (MonadReader env m, HasToken env)
=> m (AuthenticateReq (AuthProtect "token"))
mkSlackAuthenticateReq = flip mkAuthenticateReq authenticateReq . getToken <$> ask
unnestErrors :: Either ServantError (ResponseJSON a) -> Response a
unnestErrors (Right (ResponseJSON (Right a))) = Right a
unnestErrors (Right (ResponseJSON (Left (ResponseSlackError serv))))
= Left (Common.SlackError serv)
unnestErrors (Left slackErr) = Left (Common.ServantError slackErr)
mkSlackConfig :: Text -> IO SlackConfig
mkSlackConfig token = SlackConfig <$> newManager tlsManagerSettings <*> pure token