{-# 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 =
Maybe URI -> URIParseException -> IO URI
forall e r. Exception e => Maybe r -> e -> IO r
noteE (String -> Maybe URI
URI.parseRelativeReference String
str)
(String -> URIParseException
URIParseException (String
"mmPath: " String -> String -> String
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"]
Bool -> ContentTypeException -> IO ()
forall e. Exception e => Bool -> e -> IO ()
assertE (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString -> Maybe ByteString
forall a. Accept a => [a] -> ByteString -> Maybe a
HTTPM.matchContent [ByteString]
allowedTypes (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack String
contentType)
(String -> ContentTypeException
ContentTypeException
(String
"Expected content type 'application/json';" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
contentType))
jsonResponse :: A.FromJSON t => HTTP.Response_String -> IO t
jsonResponse :: Response_String -> IO t
jsonResponse Response_String
rsp = do
Response_String -> IO ()
assertJSONResponse Response_String
rsp
Either JSONDecodeException t -> IO t
forall e r. Exception e => Either e r -> IO r
hoistE (Either JSONDecodeException t -> IO t)
-> Either JSONDecodeException t -> IO t
forall a b. (a -> b) -> a -> b
$ (String -> JSONDecodeException)
-> Either String t -> Either JSONDecodeException t
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 (Response_String -> String
forall a. Response a -> a
HTTP.rspBody Response_String
rsp))
(ByteString -> Either String t
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (String -> ByteString
BL.pack (Response_String -> String
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 =
ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ByteString
B.pack (Response_String -> String
forall a. Response a -> a
HTTP.rspBody Response_String
rsp))
noResponse :: HTTP.Response_String -> IO ()
noResponse :: Response_String -> IO ()
noResponse Response_String
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mmGetHeader :: HTTP.Response_String -> HTTP.HeaderName -> IO String
Response_String
rsp HeaderName
hdr =
Maybe String -> HeaderNotFoundException -> IO String
forall e r. Exception e => Maybe r -> e -> IO r
noteE (HeaderName -> [Header] -> Maybe String
HTTP.lookupHeader HeaderName
hdr (Response_String -> [Header]
forall a. Response a -> [Header]
HTTP.rspHeaders Response_String
rsp))
(String -> HeaderNotFoundException
HeaderNotFoundException (String
"mmGetHeader: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HeaderName -> String
forall a. Show a => a -> String
show HeaderName
hdr))
mmGetJSONBody :: A.FromJSON t => String -> HTTP.Response_String -> IO (t)
mmGetJSONBody :: 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 = (String -> JSONDecodeException)
-> Either String t -> Either JSONDecodeException t
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: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
label String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
(Response_String -> String
forall a. Response a -> a
HTTP.rspBody Response_String
rsp))
(ByteString -> Either String t
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (String -> ByteString
BL.pack (Response_String -> String
forall a. Response a -> a
HTTP.rspBody Response_String
rsp)))
Either JSONDecodeException t -> IO t
forall e r. Exception e => Either e r -> IO r
hoistE (Either JSONDecodeException t -> IO t)
-> Either JSONDecodeException t -> IO t
forall a b. (a -> b) -> a -> b
$ do
t
y <- Either JSONDecodeException t
value
t -> Either JSONDecodeException t
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 (Token -> Maybe Token
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 Maybe Token
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 (String -> IO URI) -> String -> IO URI
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 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Token -> String
getTokenString Token
token)]
request :: Request String
request = Request :: forall a. URI -> RequestMethod -> [Header] -> a -> Request a
HTTP.Request
{ rqURI :: URI
HTTP.rqURI = URI
parsedPath
, rqMethod :: RequestMethod
HTTP.rqMethod = RequestMethod
method
, rqHeaders :: [Header]
HTTP.rqHeaders =
[Header]
authHeader [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<>
[ HeaderName -> String -> Header
HTTP.mkHeader HeaderName
HTTP.HdrHost (Text -> String
T.unpack (Text -> String) -> Text -> String
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 (Int -> String
forall a. Show a => a -> String
show Int
contentLength)
] [Header] -> [Header] -> [Header]
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 = ConnectionData
-> (MMConn -> IO (Either ConnError Response_String))
-> IO (Either ConnError Response_String)
forall a. ConnectionData -> (MMConn -> IO a) -> IO a
withConnection ConnectionData
cd ((MMConn -> IO (Either ConnError Response_String))
-> IO (Either ConnError Response_String))
-> (MMConn -> IO (Either ConnError Response_String))
-> IO (Either ConnError Response_String)
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 Maybe String
forall a. Maybe a
Nothing)
Either ConnError Response_String
result <- MMConn -> Request String -> IO (Either ConnError Response_String)
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 -> Either ConnError Response_String
-> IO (Either ConnError Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConnError Response_String
-> IO (Either ConnError Response_String))
-> Either ConnError Response_String
-> IO (Either ConnError Response_String)
forall a b. (a -> b) -> a -> b
$ ConnError -> Either ConnError Response_String
forall a b. a -> Either a b
Left ConnError
e
Right Response_String
response -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Response_String -> Bool
shouldClose Response_String
response) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MMConn -> IO ()
closeMMConn MMConn
con
Either ConnError Response_String
-> IO (Either ConnError Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ConnError Response_String
-> IO (Either ConnError Response_String))
-> Either ConnError Response_String
-> IO (Either ConnError Response_String)
forall a b. (a -> b) -> a -> b
$ Response_String -> Either ConnError Response_String
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)
<- IO (Either ConnError Response_String)
-> IO (Either IOException (Either ConnError 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
Pool MMConn -> IO ()
forall a. Pool a -> IO ()
destroyAllResources (ConnectionData -> Pool MMConn
cdConnectionPool ConnectionData
cd)
IO (Either ConnError Response_String)
go
Left IOException
e -> IOException -> IO (Either ConnError Response_String)
forall e a. Exception e => e -> IO a
throwIO IOException
e
Right Either ConnError Response_String
result -> Either ConnError Response_String
-> IO (Either ConnError Response_String)
forall (m :: * -> *) a. Monad m => a -> m a
return Either ConnError Response_String
result
Response_String
rsp <- Either ConnectionException Response_String -> IO Response_String
forall e r. Exception e => Either e r -> IO r
hoistE ((ConnError -> ConnectionException)
-> Either ConnError Response_String
-> Either ConnectionException Response_String
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 Response_String -> ResponseCode
forall a. Response a -> ResponseCode
HTTP.rspCode Response_String
rsp of
(Int
4, Int
2, Int
9) -> do
let headers :: [Header]
headers = Response_String -> [Header]
forall x. HasHeaders x => x -> [Header]
HTTP.getHeaders Response_String
rsp
mLimit :: Maybe Int
mLimit = String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> Maybe String -> Maybe Int
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 = String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> Maybe String -> Maybe Int
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 = String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> Maybe String -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HeaderName -> [Header] -> Maybe String
findHeader HeaderName
rateLimitResetHeader [Header]
headers
RateLimitException -> IO Response_String
forall e a. Exception e => e -> IO a
throwIO (RateLimitException -> IO Response_String)
-> RateLimitException -> IO Response_String
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
_) -> Response_String -> IO Response_String
forall (m :: * -> *) a. Monad m => a -> m a
return Response_String
rsp
ResponseCode
code -> do
case ByteString -> Either String MattermostError
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (String -> ByteString
BL.pack (Response_String -> String
forall a. Response a -> a
HTTP.rspBody Response_String
rsp)) of
Right MattermostError
err ->
MattermostError -> IO Response_String
forall e a. Exception e => e -> IO a
throwIO (MattermostError
err :: MattermostError)
Left String
_ ->
HTTPResponseException -> IO Response_String
forall e a. Exception e => e -> IO a
throwIO (String -> HTTPResponseException
HTTPResponseException (String
"Server returned unexpected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ResponseCode -> String
forall a. Show a => a -> String
show ResponseCode
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" response"))
findHeader :: HTTP.HeaderName -> [HTTP.Header] -> Maybe String
HeaderName
n [Header]
hs = Header -> String
HTTP.hdrValue (Header -> String) -> Maybe Header -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Header] -> Maybe Header
forall a. [a] -> Maybe a
listToMaybe ((Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
n) (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
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 =
[Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ IOException -> Bool
isEOFError IOException
e
, String
"resource vanished" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`List.isInfixOf` IOException -> String
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 (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
v) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"close"
isConnClose Header
_ = Bool
False
in (Header -> Bool) -> [Header] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Header -> Bool
isConnClose ([Header] -> Bool) -> [Header] -> Bool
forall a b. (a -> b) -> a -> b
$ Response_String -> [Header]
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 =
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"&" [ (Char -> Bool) -> String -> String
URI.escapeURIString Char -> Bool
URI.isUnescapedInURIComponent String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"=" String -> String -> 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 :: i -> ByteString
jsonBody = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> (i -> ByteString) -> i -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> ByteString
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 :: 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 IO Response_String -> (Response_String -> IO o) -> IO o
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 :: 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 IO Response_String -> (Response_String -> IO o) -> IO o
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 :: 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 IO Response_String -> (Response_String -> IO o) -> IO o
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 :: 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 IO Response_String -> (Response_String -> IO o) -> IO o
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response_String -> IO o
k