mattermost-api-30802.1.0: src/Network/Mattermost.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.Mattermost
( -- * Types
-- ** Mattermost-Related Types (deprecated: use Network.MatterMost.Types instead)
-- n.b. the deprecation notice is in that haddock header because we're
-- still waiting for https://ghc.haskell.org/trac/ghc/ticket/4879 ...
Login(..)
, Hostname
, Port
, ConnectionData
, Session
, Id(..)
, User(..)
, UserId(..)
, InitialLoad(..)
, Team(..)
, TeamMember(..)
, Type(..)
, TeamId(..)
, TeamsCreate(..)
, Channel(..)
, ChannelWithData(..)
, ChannelData(..)
, ChannelId(..)
, Channels
, MinChannel(..)
, UsersCreate(..)
, Post(..)
, PostProps(..)
, PendingPost(..)
, PostId(..)
, FileId(..)
, FileInfo(..)
, Reaction(..)
, urlForFile
, Posts(..)
, MinCommand(..)
, CommandResponse(..)
, CommandResponseType(..)
-- ** Log-related types
, Logger
, LogEvent(..)
, LogEventType(..)
, withLogger
, noLogger
-- * Typeclasses
, HasId(..)
-- * HTTP API Functions
, mkConnectionData
, initConnectionData
, initConnectionDataInsecure
, mmLogin
, mmCreateDirect
, mmCreateChannel
, mmCreateTeam
, mmDeleteChannel
, mmLeaveChannel
, mmJoinChannel
, mmGetTeams
, mmGetChannels
, mmGetMoreChannels
, mmGetChannel
, mmViewChannel
, mmDeletePost
, mmGetPost
, mmGetPosts
, mmGetPostsSince
, mmGetPostsBefore
, mmGetPostsAfter
, mmGetReactionsForPost
, mmGetFileInfo
, mmGetFile
, mmGetUser
, mmGetUsers
, mmGetTeamMembers
, mmGetChannelMembers
, mmGetProfilesForDMList
, mmGetMe
, mmGetProfiles
, mmGetStatuses
, mmGetInitialLoad
, mmSaveConfig
, mmSetChannelHeader
, mmChannelAddUser
, mmTeamAddUser
, mmUsersCreate
, mmUsersCreateWithSession
, mmPost
, mmUpdatePost
, mmExecute
, mmGetConfig
, mkPendingPost
, idString
, hoistE
, noteE
, assertE
) where
import Control.Exception (throwIO)
import Control.Monad (when)
import Data.Monoid ((<>))
import Text.Printf ( printf )
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Time.Clock ( UTCTime )
import Network.Connection ( Connection
, connectionGetLine
, connectionPut
, connectionClose )
import Network.HTTP.Headers ( HeaderName(..)
, mkHeader
, lookupHeader )
import Network.HTTP.Base ( Request(..)
, RequestMethod(..)
, defaultUserAgent
, Response_String
, Response(..) )
import Network.Stream as NS ( Stream(..) )
import Network.URI ( URI, parseRelativeReference )
import Network.HTTP.Stream ( simpleHTTP_ )
import Data.HashMap.Strict ( HashMap )
import qualified Data.HashMap.Strict as HM
import Data.Aeson ( Value(..)
, ToJSON(..)
, FromJSON
, object
, (.=)
, encode
, eitherDecode
)
import Data.Maybe ( maybeToList )
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import Control.Arrow ( left )
import Network.Mattermost.Exceptions
import Network.Mattermost.Util
import Network.Mattermost.Types.Base
import Network.Mattermost.Types.Internal
import Network.Mattermost.Types
maxLineLength :: Int
maxLineLength = 2^(16::Int)
-- | This instance allows us to use 'simpleHTTP' from 'Network.HTTP.Stream' with
-- connections from the 'connection' package.
instance Stream Connection where
readLine con = Right . B.unpack . dropTrailingChar <$> connectionGetLine maxLineLength con
readBlock con n = Right . B.unpack <$> connectionGetExact con n
writeBlock con block = Right <$> connectionPut con (B.pack block)
close con = connectionClose con
closeOnEnd _ _ = return ()
-- MM utility functions
-- | Parse a path, failing if we cannot.
mmPath :: String -> IO URI
mmPath str =
noteE (parseRelativeReference str)
(URIParseException ("mmPath: " ++ str))
-- | Parse the JSON body out of a request, failing if it isn't an
-- 'application/json' response, or if the parsing failed
mmGetJSONBody :: FromJSON t => String -> Response_String -> IO (Value, t)
mmGetJSONBody label rsp = do
contentType <- mmGetHeader rsp HdrContentType
assertE (contentType ~= "application/json")
(ContentTypeException
("mmGetJSONBody: " ++ label ++ ": " ++
"Expected content type 'application/json'" ++
" found " ++ contentType))
let value = left (\s -> JSONDecodeException ("mmGetJSONBody: " ++ label ++ ": " ++ s)
(rspBody rsp))
(eitherDecode (BL.pack (rspBody rsp)))
let rawVal = left (\s -> JSONDecodeException ("mmGetJSONBody: " ++ label ++ ": " ++ s)
(rspBody rsp))
(eitherDecode (BL.pack (rspBody rsp)))
hoistE $ do
x <- rawVal
y <- value
return (x, y)
-- | Grab a header from the response, failing if it isn't present
mmGetHeader :: Response_String -> HeaderName -> IO String
mmGetHeader rsp hdr =
noteE (lookupHeader hdr (rspHeaders rsp))
(HeaderNotFoundException ("mmGetHeader: " ++ show hdr))
-- API calls
-- | We should really only need this function to get an auth token.
-- We provide it in a fairly generic form in case we need ever need it
-- but it could be inlined into mmLogin.
mmUnauthenticatedHTTPPost :: ToJSON t => ConnectionData -> URI -> t -> IO Response_String
mmUnauthenticatedHTTPPost cd path json = do
rsp <- withConnection cd $ \con -> do
let content = BL.toStrict (encode json)
contentLength = B.length content
request = Request
{ rqURI = path
, rqMethod = POST
, rqHeaders = [ mkHeader HdrHost (T.unpack $ cdHostname cd)
, mkHeader HdrUserAgent defaultUserAgent
, mkHeader HdrContentType "application/json"
, mkHeader HdrContentLength (show contentLength)
] ++ autoCloseToHeader (cdAutoClose cd)
, rqBody = B.unpack content
}
simpleHTTP_ con request
hoistE $ left ConnectionException rsp
-- | Fire off a login attempt. Note: We get back more than just the auth token.
-- We also get all the server-side configuration data for the user.
--
-- route: @\/api\/v3\/users\/login@
mmLogin :: ConnectionData -> Login -> IO (Either LoginFailureException (Session, User))
mmLogin cd login = do
let rawPath = "/api/v3/users/login"
path <- mmPath rawPath
runLogger cd "mmLogin" $
HttpRequest GET rawPath (Just (toJSON login))
rsp <- mmUnauthenticatedHTTPPost cd path login
if (rspCode rsp /= (2,0,0))
then return (Left (LoginFailureException (show (rspCode rsp))))
else do
token <- mmGetHeader rsp (HdrCustom "Token")
(raw, value) <- mmGetJSONBody "User" rsp
runLogger cd "mmLogin" $
HttpResponse 200 rawPath (Just raw)
return (Right (Session cd (Token token), value))
-- | Fire off a login attempt. Note: We get back more than just the auth token.
-- We also get all the server-side configuration data for the user.
--
-- route: @\/api\/v3\/users\/initial_load@
mmGetInitialLoad :: Session -> IO InitialLoad
mmGetInitialLoad sess =
mmDoRequest sess "mmGetInitialLoad" "/api/v3/users/initial_load"
-- | Requires an authenticated user. Returns the full list of teams.
--
-- route: @\/api\/v3\/teams\/all@
mmGetTeams :: Session -> IO (HashMap TeamId Team)
mmGetTeams sess =
mmDoRequest sess "mmGetTeams" "/api/v3/teams/all"
-- |
-- route: @\/api\/v3\/teams\/create@
mmCreateTeam :: Session -> TeamsCreate -> IO Team
mmCreateTeam sess payload = do
let path = "/api/v3/teams/create"
uri <- mmPath path
runLoggerS sess "mmCreateTeam" $
HttpRequest POST path (Just (toJSON payload))
rsp <- mmPOST sess uri payload
(val, r) <- mmGetJSONBody "Team" rsp
runLoggerS sess "mmCreateTeam" $
HttpResponse 200 path (Just val)
return r
-- | Requires an authenticated user. Returns the full list of channels
-- for a given team of which the user is a member
--
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/@
mmGetChannels :: Session -> TeamId -> IO Channels
mmGetChannels sess teamid = mmDoRequest sess "mmGetChannels" $
printf "/api/v3/teams/%s/channels/" (idString teamid)
-- | Requires an authenticated user. Returns the channels for a team of
-- which the user is not already a member
--
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/more\/{offset}\/{limit}@
mmGetMoreChannels :: Session -> TeamId -> Int -> Int -> IO Channels
mmGetMoreChannels sess teamid offset limit =
mmDoRequest sess "mmGetMoreChannels" $
printf "/api/v3/teams/%s/channels/more/%d/%d"
(idString teamid)
offset
limit
-- | Requires an authenticated user. Returns the details of a
-- specific channel.
--
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}@
mmGetChannel :: Session
-> TeamId
-> ChannelId
-> IO ChannelWithData
mmGetChannel sess teamid chanid = mmWithRequest sess "mmGetChannel"
(printf "/api/v3/teams/%s/channels/%s/"
(idString teamid)
(idString chanid))
return
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/view@
mmViewChannel :: Session
-> TeamId
-> ChannelId -- ^ channel to view
-> Maybe ChannelId -- ^ previous channel
-> IO ()
mmViewChannel sess teamid chanid previd = do
let path = printf "/api/v3/teams/%s/channels/view"
(idString teamid)
prev = maybeToList (("prev_channel_id" :: T.Text,) <$> previd)
payload = HM.fromList $ [("channel_id" :: T.Text, chanid)] ++ prev
uri <- mmPath path
runLoggerS sess "mmViewChannel" $
HttpRequest POST path (Just (toJSON payload))
_ <- mmPOST sess uri payload
runLoggerS sess "mmViewChannel" $
HttpResponse 200 path Nothing
return ()
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/join@
mmJoinChannel :: Session
-> TeamId
-> ChannelId
-> IO ()
mmJoinChannel sess teamid chanid = do
let path = printf "/api/v3/teams/%s/channels/%s/join"
(idString teamid)
(idString chanid)
uri <- mmPath path
runLoggerS sess "mmJoinChannel" $
HttpRequest POST path Nothing
rsp <- mmPOST sess uri (""::T.Text)
(val, (_::Channel)) <- mmGetJSONBody "Channel" rsp
runLoggerS sess "mmJoinChannel" $
HttpResponse 200 path (Just val)
return ()
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/leave@
mmLeaveChannel :: Session
-> TeamId
-> ChannelId
-> IO ()
mmLeaveChannel sess teamid chanid = do
let path = printf "/api/v3/teams/%s/channels/%s/leave"
(idString teamid)
(idString chanid)
payload = HM.fromList [("id" :: T.Text, chanid)]
uri <- mmPath path
runLoggerS sess "mmLeaveChannel" $
HttpRequest POST path (Just (toJSON payload))
rsp <- mmPOST sess uri payload
(val, (_::HM.HashMap T.Text ChannelId)) <- mmGetJSONBody "Channel name/ID map" rsp
runLoggerS sess "mmCreateDirect" $
HttpResponse 200 path (Just val)
return ()
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/page\/{offset}\/{limit}@
mmGetPosts :: Session
-> TeamId
-> ChannelId
-> Int -- offset in the backlog, 0 is most recent
-> Int -- try to fetch this many
-> IO Posts
mmGetPosts sess teamid chanid offset limit =
mmDoRequest sess "mmGetPosts" $
printf "/api/v3/teams/%s/channels/%s/posts/page/%d/%d"
(idString teamid)
(idString chanid)
offset
limit
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/since\/{utc_time}@
mmGetPostsSince :: Session
-> TeamId
-> ChannelId
-> UTCTime
-> IO Posts
mmGetPostsSince sess teamid chanid since =
mmDoRequest sess "mmGetPostsSince" $
printf "/api/v3/teams/%s/channels/%s/posts/since/%d"
(idString teamid)
(idString chanid)
(utcTimeToMilliseconds since :: Int)
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/{post_id}\/get@
mmGetPost :: Session
-> TeamId
-> ChannelId
-> PostId
-> IO Posts
mmGetPost sess teamid chanid postid = do
let path = printf "/api/v3/teams/%s/channels/%s/posts/%s/get"
(idString teamid)
(idString chanid)
(idString postid)
uri <- mmPath path
rsp <- mmRequest sess uri
(raw, json) <- mmGetJSONBody "Posts" rsp
runLoggerS sess "mmGetPost" $
HttpResponse 200 path (Just raw)
return json
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/{post_id}\/after\/{offset}\/{limit}@
mmGetPostsAfter :: Session
-> TeamId
-> ChannelId
-> PostId
-> Int -- offset in the backlog, 0 is most recent
-> Int -- try to fetch this many
-> IO Posts
mmGetPostsAfter sess teamid chanid postid offset limit =
mmDoRequest sess "mmGetPosts" $
printf "/api/v3/teams/%s/channels/%s/posts/%s/after/%d/%d"
(idString teamid)
(idString chanid)
(idString postid)
offset
limit
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/{post_id}\/before\/{offset}\/{limit}@
mmGetPostsBefore :: Session
-> TeamId
-> ChannelId
-> PostId
-> Int -- offset in the backlog, 0 is most recent
-> Int -- try to fetch this many
-> IO Posts
mmGetPostsBefore sess teamid chanid postid offset limit =
mmDoRequest sess "mmGetPosts" $
printf "/api/v3/teams/%s/channels/%s/posts/%s/before/%d/%d"
(idString teamid)
(idString chanid)
(idString postid)
offset
limit
-- |
-- route: @\/api\/v3\/files\/{file_id}\/get_info@
mmGetFileInfo :: Session
-> FileId
-> IO FileInfo
mmGetFileInfo sess fileId =
mmDoRequest sess "mmGetFileInfo" $
printf "/api/v3/files/%s/get_info" (idString fileId)
-- |
-- route: @\/api\/v4\/files\/{file_id}@
mmGetFile :: Session
-> FileId
-> IO B.ByteString
mmGetFile sess@(Session cd _) fileId = do
let path = printf "/api/v4/files/%s" (idString fileId)
uri <- mmPath path
runLogger cd "mmGetFile" $
HttpRequest GET path Nothing
rsp <- mmRequest sess uri
return (B.pack (rspBody rsp))
-- |
-- route: @\/api\/v3\/users\/{user_id}\/get@
mmGetUser :: Session -> UserId -> IO User
mmGetUser sess userid = mmDoRequest sess "mmGetUser" $
printf "/api/v3/users/%s/get" (idString userid)
-- |
-- route: @\/api\/v3\/users\/{offset}\/{limit}@
mmGetUsers :: Session -> Int -> Int -> IO (HashMap UserId User)
mmGetUsers sess offset limit =
mmDoRequest sess "mmGetUsers" $
printf "/api/v3/users/%d/%d" offset limit
-- |
-- route: @\/api\/v3\/teams\/members\/{team_id}@
mmGetTeamMembers :: Session -> TeamId -> IO (Seq.Seq TeamMember)
mmGetTeamMembers sess teamid = mmDoRequest sess "mmGetTeamMembers" $
printf "/api/v3/teams/members/%s" (idString teamid)
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/users\/{offset}\/{limit}@
mmGetChannelMembers :: Session
-> TeamId
-> ChannelId
-> Int
-> Int
-> IO (HashMap UserId User)
mmGetChannelMembers sess teamid chanid offset limit = mmDoRequest sess "mmGetChannelMembers" $
printf "/api/v3/teams/%s/channels/%s/users/%d/%d"
(idString teamid)
(idString chanid)
offset
limit
-- |
-- route: @\/api\/v3\/users\/profiles_for_dm_list\/{team_id}@
mmGetProfilesForDMList :: Session -> TeamId
-> IO (HashMap UserId User)
mmGetProfilesForDMList sess teamid =
mmDoRequest sess "mmGetProfilesForDMList" $
printf "/api/v3/users/profiles_for_dm_list/%s" (idString teamid)
-- |
-- route: @\/api\/v3\/users\/me@
mmGetMe :: Session -> IO User
mmGetMe sess = mmDoRequest sess "mmGetMe" "/api/v3/users/me"
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/users\/{offset}\/{limit}@
mmGetProfiles :: Session
-> TeamId
-> Int
-> Int
-> IO (HashMap UserId User)
mmGetProfiles sess teamid offset limit = mmDoRequest sess "mmGetProfiles" $
printf "/api/v3/teams/%s/users/%d/%d"
(idString teamid)
offset
limit
-- |
-- route: @\/api\/v3\/users\/status@
mmGetStatuses :: Session -> IO (HashMap UserId T.Text)
mmGetStatuses sess = mmDoRequest sess "mmGetStatuses" $
printf "/api/v3/users/status"
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/create_direct@
mmCreateDirect :: Session -> TeamId -> UserId -> IO Channel
mmCreateDirect sess teamid userid = do
let path = printf "/api/v3/teams/%s/channels/create_direct" (idString teamid)
payload = HM.fromList [("user_id" :: T.Text, userid)]
uri <- mmPath path
runLoggerS sess "mmCreateDirect" $
HttpRequest POST path (Just (toJSON payload))
rsp <- mmPOST sess uri payload
(val, r) <- mmGetJSONBody "Channel" rsp
runLoggerS sess "mmCreateDirect" $
HttpResponse 200 path (Just val)
return r
-- { name, display_name, purpose, header }
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/create@
mmCreateChannel :: Session -> TeamId -> MinChannel -> IO Channel
mmCreateChannel sess teamid payload = do
let path = printf "/api/v3/teams/%s/channels/create" (idString teamid)
uri <- mmPath path
runLoggerS sess "mmCreateChannel" $
HttpRequest POST path (Just (toJSON payload))
rsp <- mmPOST sess uri payload
(val, r) <- mmGetJSONBody "Channel" rsp
runLoggerS sess "mmCreateChannel" $
HttpResponse 200 path (Just val)
return r
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/delete@
mmDeleteChannel :: Session -> TeamId -> ChannelId -> IO ()
mmDeleteChannel sess teamid chanid = do
let path = printf "/api/v3/teams/%s/channels/%s/delete"
(idString teamid) (idString chanid)
uri <- mmPath path
runLoggerS sess "mmDeleteChannel" $
HttpRequest POST path Nothing
_ <- mmRawPOST sess uri ""
runLoggerS sess "mmDeleteChannel" $
HttpResponse 200 path Nothing
return ()
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/{post_id}\/delete@
mmDeletePost :: Session
-> TeamId
-> ChannelId
-> PostId
-> IO ()
mmDeletePost sess teamid chanid postid = do
let path = printf "/api/v3/teams/%s/channels/%s/posts/%s/delete"
(idString teamid)
(idString chanid)
(idString postid)
uri <- mmPath path
runLoggerS sess "mmDeletePost" $
HttpRequest POST path Nothing
rsp <- mmPOST sess uri ([]::[String])
(_, _::Value) <- mmGetJSONBody "Post" rsp
runLoggerS sess "mmDeletePost" $
HttpResponse 200 path Nothing
return ()
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/update@
mmUpdatePost :: Session
-> TeamId
-> Post
-> IO Post
mmUpdatePost sess teamid post = do
let chanid = postChannelId post
path = printf "/api/v3/teams/%s/channels/%s/posts/update"
(idString teamid)
(idString chanid)
uri <- mmPath path
runLoggerS sess "mmUpdatePost" $
HttpRequest POST path (Just (toJSON post))
rsp <- mmPOST sess uri post
(val, r) <- mmGetJSONBody "Post" rsp
runLoggerS sess "mmUpdatePost" $
HttpResponse 200 path (Just (val))
return r
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/create@
mmPost :: Session
-> TeamId
-> PendingPost
-> IO Post
mmPost sess teamid post = do
let chanid = pendingPostChannelId post
path = printf "/api/v3/teams/%s/channels/%s/posts/create"
(idString teamid)
(idString chanid)
uri <- mmPath path
runLoggerS sess "mmPost" $
HttpRequest POST path (Just (toJSON post))
rsp <- mmPOST sess uri post
(val, r) <- mmGetJSONBody "Post" rsp
runLoggerS sess "mmPost" $
HttpResponse 200 path (Just (val))
return r
-- | Get the system configuration. Requires administrative permission.
--
-- route: @\/api\/v3\/admin\/config@
mmGetConfig :: Session
-> IO Value
mmGetConfig sess =
mmDoRequest sess "mmGetConfig" "/api/v3/admin/config"
mmSaveConfig :: Session
-> Value
-> IO ()
mmSaveConfig sess config = do
let path = "/api/v3/admin/save_config"
uri <- mmPath path
runLoggerS sess "mmSaveConfig" $
HttpRequest POST path (Just config)
_ <- mmPOST sess uri config
runLoggerS sess "mmSaveConfig" $
HttpResponse 200 path Nothing
return ()
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/add@
mmChannelAddUser :: Session
-> TeamId
-> ChannelId
-> UserId
-> IO ChannelData
mmChannelAddUser sess teamid chanId uId = do
let path = printf "/api/v3/teams/%s/channels/%s/add"
(idString teamid)
(idString chanId)
req = object ["user_id" .= uId]
uri <- mmPath path
runLoggerS sess "mmChannelAddUser" $
HttpRequest POST path (Just req)
rsp <- mmPOST sess uri req
(val, r) <- mmGetJSONBody "ChannelData" rsp
runLoggerS sess "mmChannelAddUser" $
HttpResponse 200 path (Just val)
return r
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/add_user_to_team@
mmTeamAddUser :: Session
-> TeamId
-> UserId
-> IO ()
mmTeamAddUser sess teamid uId = do
let path = printf "/api/v3/teams/%s/add_user_to_team"
(idString teamid)
req = object ["user_id" .= uId]
uri <- mmPath path
runLoggerS sess "mmTeamAddUser" $
HttpRequest POST path (Just req)
_ <- mmPOST sess uri req
runLoggerS sess "mmTeamAddUSer" $
HttpResponse 200 path Nothing
return ()
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/commands\/execute@
mmExecute :: Session
-> TeamId
-> MinCommand
-> IO CommandResponse
mmExecute sess teamid command = do
let path = printf "/api/v3/teams/%s/commands/execute"
(idString teamid)
uri <- mmPath path
runLoggerS sess "mmExecute" $
HttpRequest POST path (Just (toJSON command))
rsp <- mmPOST sess uri command
(val, r) <- mmGetJSONBody "Value" rsp
runLoggerS sess "mmExecute" $
HttpResponse 200 path (Just (val))
return r
-- |
-- route: @\/api\/v3\/users\/create@
mmUsersCreate :: ConnectionData
-> UsersCreate
-> IO User
mmUsersCreate cd usersCreate = do
let path = "/api/v3/users/create"
uri <- mmPath path
runLogger cd "mmUsersCreate" $
HttpRequest POST path (Just (toJSON usersCreate))
rsp <- mmUnauthenticatedHTTPPost cd uri usersCreate
(val, r) <- mmGetJSONBody "User" rsp
runLogger cd "mmUsersCreate" $
HttpResponse 200 path (Just (val))
return r
-- |
-- route: @\/api\/v3\/users\/create@
mmUsersCreateWithSession :: Session
-> UsersCreate
-> IO User
mmUsersCreateWithSession sess usersCreate = do
let path = "/api/v3/users/create"
uri <- mmPath path
runLoggerS sess "mmUsersCreateWithToken" $
HttpRequest POST path (Just (toJSON usersCreate))
rsp <- mmPOST sess uri usersCreate
(val, r) <- mmGetJSONBody "User" rsp
runLoggerS sess "mmUsersCreateWithToken" $
HttpResponse 200 path (Just (val))
return r
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/{post_id}\/reactions@
mmGetReactionsForPost :: Session
-> TeamId
-> ChannelId
-> PostId
-> IO [Reaction]
mmGetReactionsForPost sess tId cId pId = do
let path = printf "/api/v3/teams/%s/channels/%s/posts/%s/reactions"
(idString tId)
(idString cId)
(idString pId)
mmDoRequest sess "mmGetReactionsForPost" path
-- | This is for making a generic authenticated request.
mmRequest :: Session -> URI -> IO Response_String
mmRequest (Session cd token) path = do
rawRsp <- withConnection cd $ \con -> do
let request = Request
{ rqURI = path
, rqMethod = GET
, rqHeaders = [ mkHeader HdrAuthorization ("Bearer " ++ getTokenString token)
, mkHeader HdrHost (T.unpack $ cdHostname cd)
, mkHeader HdrUserAgent defaultUserAgent
] ++ autoCloseToHeader (cdAutoClose cd)
, rqBody = ""
}
simpleHTTP_ con request
rsp <- hoistE $ left ConnectionException rawRsp
assert200Response path rsp
return rsp
-- This captures the most common pattern when making requests.
mmDoRequest :: FromJSON t
=> Session
-> String
-> String
-> IO t
mmDoRequest sess fnname path = mmWithRequest sess fnname path return
-- The slightly more general variant
mmWithRequest :: FromJSON t
=> Session
-> String
-> String
-> (t -> IO a)
-> IO a
mmWithRequest sess@(Session cd _) fnname path action = do
uri <- mmPath path
runLogger cd fnname $
HttpRequest GET path Nothing
rsp <- mmRequest sess uri
(raw,json) <- mmGetJSONBody fnname rsp
runLogger cd fnname $
HttpResponse 200 path (Just raw)
action json
mmPOST :: ToJSON t => Session -> URI -> t -> IO Response_String
mmPOST sess path json =
mmRawPOST sess path (BL.toStrict (encode json))
-- |
-- route: @\/api\/v3\/teams\/{team_id}\/channels\/update_header@
mmSetChannelHeader :: Session -> TeamId -> ChannelId -> T.Text -> IO Channel
mmSetChannelHeader sess teamid chanid header = do
let path = printf "/api/v3/teams/%s/channels/update_header"
(idString teamid)
uri <- mmPath path
let req = SetChannelHeader chanid header
runLoggerS sess "mmSetChannelHeader" $
HttpRequest POST path (Just (toJSON req))
rsp <- mmPOST sess uri req
(_, r) <- mmGetJSONBody "Channel" rsp
return r
mmRawPOST :: Session -> URI -> B.ByteString -> IO Response_String
mmRawPOST (Session cd token) path content = do
rawRsp <- withConnection cd $ \con -> do
let contentLength = B.length content
request = Request
{ rqURI = path
, rqMethod = POST
, rqHeaders = [ mkHeader HdrAuthorization ("Bearer " ++ getTokenString token)
, mkHeader HdrHost (T.unpack $ cdHostname cd)
, mkHeader HdrUserAgent defaultUserAgent
, mkHeader HdrContentType "application/json"
, mkHeader HdrContentLength (show contentLength)
] ++ autoCloseToHeader (cdAutoClose cd)
, rqBody = B.unpack content
}
simpleHTTP_ con request
rsp <- hoistE $ left ConnectionException rawRsp
assert200Response path rsp
return rsp
assert200Response :: URI -> Response_String -> IO ()
assert200Response path rsp =
when (rspCode rsp /= (2,0,0)) $
let httpExc = HTTPResponseException $ "mmRequest: expected 200 response, got " <>
(show $ rspCode rsp)
in case eitherDecode $ BL.pack $ rspBody rsp of
Right (Object o) ->
case HM.lookup "message" o of
Just (String msg) ->
let newMsg = (T.pack $ "Error requesting " <> show path <> ": ") <> msg
in throwIO $ MattermostServerError newMsg
_ -> throwIO $ httpExc
_ -> throwIO $ httpExc