{-# LANGUAGE ScopedTypeVariables #-}
module Network.Mattermost.Connection where
import Control.Arrow (left)
import Control.Exception (throwIO, IOException, try, throwIO)
import Control.Monad (when)
import Data.Maybe (isJust, listToMaybe)
import Data.Monoid ((<>))
import Data.Pool (destroyAllResources)
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Char (toLower)
import qualified Data.List as List
import qualified Data.Text as T
import qualified Network.HTTP.Base as HTTP
import qualified Network.HTTP.Headers as HTTP
import qualified Network.HTTP.Stream as HTTP
import qualified Network.HTTP.Media as HTTPM
import qualified Network.URI as URI
import System.IO.Error (isEOFError)
import Text.Read ( readMaybe )
import Network.Mattermost.Exceptions
import Network.Mattermost.Types
import Network.Mattermost.Types.Internal
import Network.Mattermost.Util
mmPath :: String -> IO URI.URI
mmPath :: String -> IO URI
mmPath String
str =
forall e r. Exception e => Maybe r -> e -> IO r
noteE (String -> Maybe URI
URI.parseRelativeReference String
str)
(String -> URIParseException
URIParseException (String
"mmPath: " forall a. [a] -> [a] -> [a]
++ String
str))
assertJSONResponse :: HTTP.Response_String -> IO ()
assertJSONResponse :: Response_String -> IO ()
assertJSONResponse Response_String
rsp = do
String
contentType <- Response_String -> HeaderName -> IO String
mmGetHeader Response_String
rsp HeaderName
HTTP.HdrContentType
let allowedTypes :: [ByteString]
allowedTypes = [String -> ByteString
B.pack String
"application/json"]
forall e. Exception e => Bool -> e -> IO ()
assertE (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a. Accept a => [a] -> ByteString -> Maybe a
HTTPM.matchContent [ByteString]
allowedTypes forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
contentType)
(String -> ContentTypeException
ContentTypeException
(String
"Expected content type 'application/json';" forall a. [a] -> [a] -> [a]
++
String
" found " forall a. [a] -> [a] -> [a]
++ String
contentType))
jsonResponse :: A.FromJSON t => HTTP.Response_String -> IO t
jsonResponse :: forall t. FromJSON t => Response_String -> IO t
jsonResponse Response_String
rsp = do
Response_String -> IO ()
assertJSONResponse Response_String
rsp
forall e r. Exception e => Either e r -> IO r
hoistE forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (\String
s -> String -> String -> JSONDecodeException
JSONDecodeException String
s (forall a. Response a -> a
HTTP.rspBody Response_String
rsp))
(forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (String -> ByteString
BL.pack (forall a. Response a -> a
HTTP.rspBody Response_String
rsp)))
bytestringResponse :: HTTP.Response_String -> IO B.ByteString
bytestringResponse :: Response_String -> IO ByteString
bytestringResponse Response_String
rsp =
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ByteString
B.pack (forall a. Response a -> a
HTTP.rspBody Response_String
rsp))
noResponse :: HTTP.Response_String -> IO ()
noResponse :: Response_String -> IO ()
noResponse Response_String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
mmGetHeader :: HTTP.Response_String -> HTTP.HeaderName -> IO String
Response_String
rsp HeaderName
hdr =
forall e r. Exception e => Maybe r -> e -> IO r
noteE (HeaderName -> [Header] -> Maybe String
HTTP.lookupHeader HeaderName
hdr (forall a. Response a -> [Header]
HTTP.rspHeaders Response_String
rsp))
(String -> HeaderNotFoundException
HeaderNotFoundException (String
"mmGetHeader: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show HeaderName
hdr))
mmGetJSONBody :: A.FromJSON t => String -> HTTP.Response_String -> IO (t)
mmGetJSONBody :: forall t. FromJSON t => String -> Response_String -> IO t
mmGetJSONBody String
label Response_String
rsp = do
Response_String -> IO ()
assertJSONResponse Response_String
rsp
let value :: Either JSONDecodeException t
value = forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (\String
s -> String -> String -> JSONDecodeException
JSONDecodeException (String
"mmGetJSONBody: " forall a. [a] -> [a] -> [a]
++ String
label forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
s)
(forall a. Response a -> a
HTTP.rspBody Response_String
rsp))
(forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (String -> ByteString
BL.pack (forall a. Response a -> a
HTTP.rspBody Response_String
rsp)))
forall e r. Exception e => Either e r -> IO r
hoistE forall a b. (a -> b) -> a -> b
$ do
t
y <- Either JSONDecodeException t
value
forall (m :: * -> *) a. Monad m => a -> m a
return (t
y)
doRequest :: Session
-> HTTP.RequestMethod
-> String
-> B.ByteString
-> IO HTTP.Response_String
doRequest :: Session
-> RequestMethod -> String -> ByteString -> IO Response_String
doRequest (Session ConnectionData
cd Token
token) = ConnectionData
-> Maybe Token
-> RequestMethod
-> String
-> ByteString
-> IO Response_String
submitRequest ConnectionData
cd (forall a. a -> Maybe a
Just Token
token)
doUnauthRequest :: ConnectionData
-> HTTP.RequestMethod
-> String
-> B.ByteString
-> IO HTTP.Response_String
doUnauthRequest :: ConnectionData
-> RequestMethod -> String -> ByteString -> IO Response_String
doUnauthRequest ConnectionData
cd = ConnectionData
-> Maybe Token
-> RequestMethod
-> String
-> ByteString
-> IO Response_String
submitRequest ConnectionData
cd forall a. Maybe a
Nothing
submitRequest :: ConnectionData
-> Maybe Token
-> HTTP.RequestMethod
-> String
-> B.ByteString
-> IO HTTP.Response_String
submitRequest :: ConnectionData
-> Maybe Token
-> RequestMethod
-> String
-> ByteString
-> IO Response_String
submitRequest ConnectionData
cd Maybe Token
mToken RequestMethod
method String
uri ByteString
payload = do
Text
path <- ConnectionData -> Text -> IO Text
buildPath ConnectionData
cd (String -> Text
T.pack String
uri)
URI
parsedPath <- String -> IO URI
mmPath forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
path
let contentLength :: Int
contentLength = ByteString -> Int
B.length ByteString
payload
authHeader :: [Header]
authHeader =
case Maybe Token
mToken of
Maybe Token
Nothing -> []
Just Token
token -> [HeaderName -> String -> Header
HTTP.mkHeader HeaderName
HTTP.HdrAuthorization (String
"Bearer " forall a. [a] -> [a] -> [a]
++ Token -> String
getTokenString Token
token)]
request :: Request String
request = HTTP.Request
{ rqURI :: URI
HTTP.rqURI = URI
parsedPath
, rqMethod :: RequestMethod
HTTP.rqMethod = RequestMethod
method
, rqHeaders :: [Header]
HTTP.rqHeaders =
[Header]
authHeader forall a. Semigroup a => a -> a -> a
<>
[ HeaderName -> String -> Header
HTTP.mkHeader HeaderName
HTTP.HdrHost (Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ ConnectionData -> Text
cdHostname ConnectionData
cd)
, HeaderName -> String -> Header
HTTP.mkHeader HeaderName
HTTP.HdrUserAgent String
HTTP.defaultUserAgent
, HeaderName -> String -> Header
HTTP.mkHeader HeaderName
HTTP.HdrContentType String
"application/json"
, HeaderName -> String -> Header
HTTP.mkHeader HeaderName
HTTP.HdrContentLength (forall a. Show a => a -> String
show Int
contentLength)
] forall a. [a] -> [a] -> [a]
++ AutoClose -> [Header]
autoCloseToHeader (ConnectionData -> AutoClose
cdAutoClose ConnectionData
cd)
, rqBody :: String
HTTP.rqBody = ByteString -> String
B.unpack ByteString
payload
}
go :: IO (Either ConnError Response_String)
go = forall a. ConnectionData -> (MMConn -> IO a) -> IO a
withConnection ConnectionData
cd forall a b. (a -> b) -> a -> b
$ \MMConn
con -> do
ConnectionData -> String -> LogEventType -> IO ()
runLogger ConnectionData
cd String
"submitRequest" (RequestMethod -> String -> Maybe String -> LogEventType
HttpRequest RequestMethod
method String
uri forall a. Maybe a
Nothing)
Either ConnError Response_String
result <- forall s.
Stream s =>
s -> Request String -> IO (Either ConnError Response_String)
HTTP.simpleHTTP_ MMConn
con Request String
request
case Either ConnError Response_String
result of
Left ConnError
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ConnError
e
Right Response_String
response -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response_String -> Bool
shouldClose Response_String
response) forall a b. (a -> b) -> a -> b
$ MMConn -> IO ()
closeMMConn MMConn
con
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Response_String
response
Either ConnError Response_String
rawResponse <- do
Either IOException (Either ConnError Response_String)
resp :: Either IOException (Either HTTP.ConnError HTTP.Response_String)
<- forall e a. Exception e => IO a -> IO (Either e a)
try IO (Either ConnError Response_String)
go
case Either IOException (Either ConnError Response_String)
resp of
Left IOException
e | IOException -> Bool
isConnectionError IOException
e -> do
forall a. Pool a -> IO ()
destroyAllResources (ConnectionData -> Pool MMConn
cdConnectionPool ConnectionData
cd)
IO (Either ConnError Response_String)
go
Left IOException
e -> forall e a. Exception e => e -> IO a
throwIO IOException
e
Right Either ConnError Response_String
result -> forall (m :: * -> *) a. Monad m => a -> m a
return Either ConnError Response_String
result
Response_String
rsp <- forall e r. Exception e => Either e r -> IO r
hoistE (forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ConnError -> ConnectionException
ConnectionException Either ConnError Response_String
rawResponse)
case forall a. Response a -> ResponseCode
HTTP.rspCode Response_String
rsp of
(Int
4, Int
2, Int
9) -> do
let headers :: [Header]
headers = forall x. HasHeaders x => x -> [Header]
HTTP.getHeaders Response_String
rsp
mLimit :: Maybe Int
mLimit = forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HeaderName -> [Header] -> Maybe String
findHeader HeaderName
rateLimitLimitHeader [Header]
headers
mRemaining :: Maybe Int
mRemaining = forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HeaderName -> [Header] -> Maybe String
findHeader HeaderName
rateLimitRemainingHeader [Header]
headers
mReset :: Maybe Int
mReset = forall a. Read a => String -> Maybe a
readMaybe forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HeaderName -> [Header] -> Maybe String
findHeader HeaderName
rateLimitResetHeader [Header]
headers
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Maybe Int -> Maybe Int -> Maybe Int -> RateLimitException
RateLimitException Maybe Int
mLimit Maybe Int
mRemaining Maybe Int
mReset
(Int
2, Int
_, Int
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Response_String
rsp
ResponseCode
code -> do
case forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (String -> ByteString
BL.pack (forall a. Response a -> a
HTTP.rspBody Response_String
rsp)) of
Right MattermostError
err ->
forall e a. Exception e => e -> IO a
throwIO (MattermostError
err :: MattermostError)
Left String
_ ->
forall e a. Exception e => e -> IO a
throwIO (String -> HTTPResponseException
HTTPResponseException (String
"Server returned unexpected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ResponseCode
code forall a. [a] -> [a] -> [a]
++ String
" response"))
findHeader :: HTTP.HeaderName -> [HTTP.Header] -> Maybe String
HeaderName
n [Header]
hs = Header -> String
HTTP.hdrValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
listToMaybe (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== HeaderName
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
HTTP.hdrName) [Header]
hs)
rateLimitLimitHeader :: HTTP.HeaderName
= String -> HeaderName
HTTP.HdrCustom String
"X-RateLimit-Limit"
rateLimitRemainingHeader :: HTTP.HeaderName
rateLimitRemainingHeader :: HeaderName
rateLimitRemainingHeader = String -> HeaderName
HTTP.HdrCustom String
"X-RateLimit-Remaining"
rateLimitResetHeader :: HTTP.HeaderName
= String -> HeaderName
HTTP.HdrCustom String
"X-RateLimit-Reset"
isConnectionError :: IOException -> Bool
isConnectionError :: IOException -> Bool
isConnectionError IOException
e =
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ IOException -> Bool
isEOFError IOException
e
, String
"resource vanished" forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` forall a. Show a => a -> String
show IOException
e
]
shouldClose :: HTTP.Response_String -> Bool
shouldClose :: Response_String -> Bool
shouldClose Response_String
r =
let isConnClose :: Header -> Bool
isConnClose (HTTP.Header HeaderName
HTTP.HdrConnection String
v) = (Char -> Char
toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
v) forall a. Eq a => a -> a -> Bool
== String
"close"
isConnClose Header
_ = Bool
False
in forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Header -> Bool
isConnClose forall a b. (a -> b) -> a -> b
$ forall a. Response a -> [Header]
HTTP.rspHeaders Response_String
r
mkQueryString :: [Maybe (String, String)] -> String
mkQueryString :: [Maybe (String, String)] -> String
mkQueryString [Maybe (String, String)]
ls =
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"&" [ (Char -> Bool) -> String -> String
URI.escapeURIString Char -> Bool
URI.isUnescapedInURIComponent String
k forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++
(Char -> Bool) -> String -> String
URI.escapeURIString Char -> Bool
URI.isUnescapedInURIComponent String
v
| Just (String
k, String
v) <- [Maybe (String, String)]
ls ]
jsonBody :: A.ToJSON i => i -> B.ByteString
jsonBody :: forall i. ToJSON i => i -> ByteString
jsonBody = ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
A.encode
noBody :: B.ByteString
noBody :: ByteString
noBody = ByteString
B.empty
inPost
:: String
-> B.ByteString
-> (HTTP.Response_String -> IO o)
-> Session
-> IO o
inPost :: forall o.
String
-> ByteString -> (Response_String -> IO o) -> Session -> IO o
inPost String
uri ByteString
payload Response_String -> IO o
k Session
session =
Session
-> RequestMethod -> String -> ByteString -> IO Response_String
doRequest Session
session RequestMethod
HTTP.POST String
uri ByteString
payload forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response_String -> IO o
k
inPut
:: String
-> B.ByteString
-> (HTTP.Response_String -> IO o)
-> Session
-> IO o
inPut :: forall o.
String
-> ByteString -> (Response_String -> IO o) -> Session -> IO o
inPut String
uri ByteString
payload Response_String -> IO o
k Session
session =
Session
-> RequestMethod -> String -> ByteString -> IO Response_String
doRequest Session
session RequestMethod
HTTP.PUT String
uri ByteString
payload forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response_String -> IO o
k
inGet
:: String
-> B.ByteString
-> (HTTP.Response_String -> IO o)
-> Session
-> IO o
inGet :: forall o.
String
-> ByteString -> (Response_String -> IO o) -> Session -> IO o
inGet String
uri ByteString
payload Response_String -> IO o
k Session
session =
Session
-> RequestMethod -> String -> ByteString -> IO Response_String
doRequest Session
session RequestMethod
HTTP.GET String
uri ByteString
payload forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response_String -> IO o
k
inDelete
:: String
-> B.ByteString
-> (HTTP.Response_String -> IO o)
-> Session
-> IO o
inDelete :: forall o.
String
-> ByteString -> (Response_String -> IO o) -> Session -> IO o
inDelete String
uri ByteString
payload Response_String -> IO o
k Session
session =
Session
-> RequestMethod -> String -> ByteString -> IO Response_String
doRequest Session
session RequestMethod
HTTP.DELETE String
uri ByteString
payload forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response_String -> IO o
k