{-# 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

-- | Parse a path, failing if we cannot.
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))

-- | Parse the JSON body out of a request, failing if it isn't an
--   'application/json' response, or if the parsing failed
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)))

-- | Parse the JSON body out of a request, failing if it isn't an
--   'application/json' response, or if the parsing failed
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 ()


-- | Grab a header from the response, failing if it isn't present
mmGetHeader :: HTTP.Response_String -> HTTP.HeaderName -> IO String
mmGetHeader :: Response_String -> HeaderName -> IO String
mmGetHeader 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))

-- | Parse the JSON body out of a request, failing if it isn't an
--   'application/json' response, or if the parsing failed
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

-- | Submit an HTTP request.
--
-- If the request fails due to a 429 (rate-limited) response, this
-- raises 'RateLimitException' with the fields populated from the
-- response headers where possible.
--
-- If the response status is 2XX, the response is returned.
--
-- If the response status is anything else, its body is assumed to be
-- a JSON encoding of a Mattermost server error. If it can be decoded
-- as such, a 'MattermostError' exception is raised. Otherwise an
-- 'HTTPResponseException' is raised.
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
      -- Try to submit the request. If we got an exception that we think
      -- indicates a network problem, we assume that to mean that the
      -- connection pool contained a connection that had been severed
      -- since it was last used. That means it's very likely that the
      -- pool has other stale connections in it, so we destroy all idle
      -- connections in the pool and try the request one more time. All
      -- other errors and exceptions are just propagated.
      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
        -- Extract rate limit information if possible
        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
findHeader :: HeaderName -> [Header] -> Maybe String
findHeader 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
rateLimitLimitHeader :: HeaderName
rateLimitLimitHeader = 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
rateLimitResetHeader :: HeaderName
rateLimitResetHeader = 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
       -- There is not a specific predicate for "resource vanished"
       -- exceptions so "show" is as good as it gets.
       , 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