mattermost-api 40700.0.0 → 40800.0.0

raw patch · 16 files changed

+279/−177 lines, 16 filesdep +resource-poolPVP ok

version bump matches the API change (PVP)

Dependencies added: resource-pool

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• examples/GetChannels.hs +2/−3
• examples/GetPosts.hs +5/−7
• examples/GetTeams.hs +3/−4
• examples/GetWebsocketConnection.hs +6/−7
• examples/MakePost.hs +6/−7
• examples/ShowRawEvents.hs +6/−7
• mattermost-api.cabal +2/−1
• src/Network/Mattermost.hs +7/−1
• src/Network/Mattermost/Connection.hs +82/−47
• src/Network/Mattermost/Endpoints.hs +3/−3
• src/Network/Mattermost/Types.hs +68/−31
• src/Network/Mattermost/Types/Internal.hs +54/−12
• src/Network/Mattermost/Util.hs +21/−43
• src/Network/Mattermost/WebSocket.hs +2/−2
• test/Tests/Util.hs +2/−2

@@ -1,4 +1,14 @@ +40800.0.0+=========++ * Fixed the URI for the mmUnflagPost API call.+ * Some JSON instances now more precisely handle missing optional+   fields.+ * mattermost-api now supports connection pooling with persistent server+   connections. A connection pool configuration is required to connect+   to Mattermost servers (thanks to Abhinav Sarkar)+ 40700.0.0 ========= 

@@ -21,9 +21,8 @@ main :: IO () main = do   config <- getConfig -- see LocalConfig import-  ctx    <- initConnectionContext-  let cd = mkConnectionData (configHostname config)-                            (fromIntegral (configPort config)) ctx+  cd <- initConnectionData (configHostname config)+                           (fromIntegral (configPort config)) defaultConnectionPoolConfig    let login = Login { username = configUsername config                     , password = configPassword config

@@ -98,13 +98,11 @@   opts <- foldl (>>=) (return defaultOptions) actions    config <- getConfig -- see LocalConfig import-  ctx    <- initConnectionContext-  let cd'      = mkConnectionData (configHostname config)-                                 (fromIntegral (configPort config))-                                 ctx-      login   = Login { username = configUsername config-                      , password = configPassword config-                      }+  cd'    <- initConnectionData (configHostname config) (fromIntegral (configPort config))+                               defaultConnectionPoolConfig+  let login = Login { username = configUsername config+                    , password = configPassword config+                    }       cd = if optLogging opts              then cd' `withLogger` mmLoggerDebugErr              else cd'

@@ -18,10 +18,9 @@ main :: IO () main = do   config <- getConfig -- see LocalConfig import-  ctx    <- initConnectionContext-  let cd = mkConnectionData (configHostname config)-                            (fromIntegral (configPort config))-                            ctx+  cd <- initConnectionData (configHostname config) (fromIntegral (configPort config))+                           defaultConnectionPoolConfig+   let login = Login { username = configUsername config                     , password = configPassword config                     }

@@ -53,13 +53,12 @@   opts <- foldl (>>=) (return defaultOptions) actions    config <- getConfig -- see LocalConfig import-  ctx    <- initConnectionContext-  let cd      = mkConnectionData (configHostname config)-                                 (fromIntegral (configPort config))-                                 ctx-      login   = Login { username = configUsername config-                      , password = configPassword config-                      }+  cd <- initConnectionData (configHostname config) (fromIntegral (configPort config))+                           defaultConnectionPoolConfig++  let login = Login { username = configUsername config+                    , password = configPassword config+                    }    (session, mmUser) <- join (hoistE <$> mmLogin cd login)   when (optVerbose opts) $ do

@@ -74,13 +74,12 @@   opts <- foldl (>>=) (return defaultOptions) actions    config <- getConfig -- see LocalConfig import-  ctx    <- initConnectionContext-  let cd      = mkConnectionData (configHostname config)-                                 (fromIntegral (configPort config))-                                 ctx-      login   = Login { username = configUsername config-                      , password = configPassword config-                      }+  cd <- initConnectionData (configHostname config) (fromIntegral (configPort config))+                           defaultConnectionPoolConfig++  let login = Login { username = configUsername config+                    , password = configPassword config+                    }    (session, mmUser) <- join (hoistE <$> mmLogin cd login)   when (optVerbose opts) $ do

@@ -63,13 +63,12 @@   opts <- foldl (>>=) (return defaultOptions) actions    config <- getConfig -- see LocalConfig import-  ctx    <- initConnectionContext-  let cd      = mkConnectionData (configHostname config)-                  (fromIntegral (configPort config))-                  ctx-      login   = Login { username = configUsername config-                      , password = configPassword config-                      }+  cd     <- initConnectionData (configHostname config) (fromIntegral (configPort config))+                               defaultConnectionPoolConfig++  let login = Login { username = configUsername config+                    , password = configPassword config+                    }    (session, mmUser) <- join (hoistE <$> mmLogin cd login)   when (optVerbose opts) $ do

@@ -1,5 +1,5 @@ name:                mattermost-api-version:             40700.0.0+version:             40800.0.0 synopsis:            Client API for Mattermost chat system description:         Client API for Mattermost chat system license:             BSD3@@ -45,6 +45,7 @@                      , aeson >= 1.0.0.0                      , connection                      , memory <0.14.3+                     , resource-pool >= 0.2.3                      -- To prevent broken websockets versions from using                      -- incompatible versions of binary (for details, see                      -- https://github.com/matterhorn-chat/mattermost-api/issues/36):

@@ -6,7 +6,8 @@   -- ** 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(..)+  ConnectionPoolConfig(..)+, Login(..) , Hostname , Port , ConnectionData@@ -55,9 +56,11 @@ -- * Typeclasses , HasId(..) -- * HTTP API Functions+, defaultConnectionPoolConfig , mkConnectionData , initConnectionData , initConnectionDataInsecure+, mmCloseSession , mmLogin , mmCreateDirect , mmCreateChannel@@ -1079,3 +1082,6 @@                         in throwIO $ MattermostServerError newMsg                     _ -> throwIO $ httpExc             _ -> throwIO $ httpExc++mmCloseSession :: Session -> IO ()+mmCloseSession (Session cd _) = destroyConnectionData cd

@@ -1,17 +1,23 @@+{-# LANGUAGE ScopedTypeVariables #-} module Network.Mattermost.Connection where   import           Control.Arrow (left)-import           Control.Exception (throwIO)+import           Control.Exception (throwIO, IOException, try, throwIO)+import           Control.Monad (when)+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.URI as URI+import           System.IO.Error (isEOFError)  import Network.Mattermost.Exceptions import Network.Mattermost.Types@@ -73,25 +79,73 @@     y <- value     return (y) -doRequest :: HTTP.RequestMethod -> String -> B.ByteString -> Session -> IO HTTP.Response_String-doRequest method uri payload (Session cd token) = do+doRequest :: Session+          -> HTTP.RequestMethod+          -> String+          -> B.ByteString+          -> IO HTTP.Response_String+doRequest (Session cd token) = submitRequest cd (Just token)++doUnauthRequest :: ConnectionData+                -> HTTP.RequestMethod+                -> String+                -> B.ByteString+                -> IO HTTP.Response_String+doUnauthRequest cd = submitRequest cd Nothing++submitRequest :: ConnectionData+              -> Maybe Token+              -> HTTP.RequestMethod+              -> String+              -> B.ByteString+              -> IO HTTP.Response_String+submitRequest cd mToken method uri payload = do   path <- mmPath ("/api/v4" ++ uri)-  rawResponse <- withConnection cd $ \con -> do-    let contentLength = B.length payload-        request = HTTP.Request-          { HTTP.rqURI = path-          , HTTP.rqMethod = method-          , HTTP.rqHeaders =-            [ HTTP.mkHeader HTTP.HdrAuthorization ("Bearer " ++ getTokenString token)-            , HTTP.mkHeader HTTP.HdrHost          (T.unpack $ cdHostname cd)-            , HTTP.mkHeader HTTP.HdrUserAgent     HTTP.defaultUserAgent-            , HTTP.mkHeader HTTP.HdrContentType   "application/json"-            , HTTP.mkHeader HTTP.HdrContentLength (show contentLength)-            ] ++ autoCloseToHeader (cdAutoClose cd)-          , HTTP.rqBody    = B.unpack payload-          }-    runLogger cd "doRequest" (HttpRequest method uri Nothing)-    HTTP.simpleHTTP_ con request+  let contentLength = B.length payload+      authHeader =+          case mToken of+              Nothing -> []+              Just token -> [HTTP.mkHeader HTTP.HdrAuthorization ("Bearer " ++ getTokenString token)]++      request = HTTP.Request+        { HTTP.rqURI = path+        , HTTP.rqMethod = method+        , HTTP.rqHeaders =+          authHeader <>+          [ HTTP.mkHeader HTTP.HdrHost          (T.unpack $ cdHostname cd)+          , HTTP.mkHeader HTTP.HdrUserAgent     HTTP.defaultUserAgent+          , HTTP.mkHeader HTTP.HdrContentType   "application/json"+          , HTTP.mkHeader HTTP.HdrContentLength (show contentLength)+          ] ++ autoCloseToHeader (cdAutoClose cd)+        , HTTP.rqBody    = B.unpack payload+        }++      go = withConnection cd $ \con -> do+          runLogger cd "submitRequest" (HttpRequest method uri Nothing)+          result <- HTTP.simpleHTTP_ con request+          case result of+              Left e -> return $ Left e+              Right response -> do+                  when (shouldClose response) $ closeMMConn con+                  return $ Right response++  rawResponse <- do+      -- Try to submit the request. If we got an EOF exception, that+      -- means 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.+      resp :: Either IOException (Either HTTP.ConnError HTTP.Response_String)+           <- try go+      case resp of+          Left e | isEOFError e -> do+              destroyAllResources (cdConnectionPool cd)+              go+          Left e -> throwIO e+          Right result -> return result+   rsp <- hoistE (left ConnectionException rawResponse)   case HTTP.rspCode rsp of     (2, _, _) -> return rsp@@ -102,6 +156,11 @@         Left _ ->           throwIO (HTTPResponseException ("Server returned unexpected " ++ show code ++ " response")) +shouldClose :: HTTP.Response_String -> Bool+shouldClose r =+    let isConnClose (HTTP.Header HTTP.HdrConnection v) = (toLower <$> v) == "close"+        isConnClose _ = False+    in any isConnClose $ HTTP.rspHeaders r  mkQueryString :: [Maybe (String, String)] -> String mkQueryString ls =@@ -121,7 +180,7 @@   -> Session   -> IO o inPost uri payload k session =-  doRequest HTTP.POST uri payload session >>= k+  doRequest session HTTP.POST uri payload >>= k  inPut   :: String@@ -130,7 +189,7 @@   -> Session   -> IO o inPut uri payload k session =-  doRequest HTTP.PUT uri payload session >>= k+  doRequest session HTTP.PUT uri payload >>= k  inGet   :: String@@ -139,7 +198,7 @@   -> Session   -> IO o inGet uri payload k session =-  doRequest HTTP.GET uri payload session >>= k+  doRequest session HTTP.GET uri payload >>= k  inDelete   :: String@@ -148,28 +207,4 @@   -> Session   -> IO o inDelete uri payload k session =-  doRequest HTTP.DELETE uri payload session >>= k----doUnauthRequest :: HTTP.RequestMethod -> String -> B.ByteString -> ConnectionData -> IO HTTP.Response_String-doUnauthRequest method uri payload cd = do-  path <- mmPath ("/api/v4" ++ uri)-  rawResponse <- withConnection cd $ \con -> do-    let contentLength = B.length payload-        request = HTTP.Request-          { HTTP.rqURI = path-          , HTTP.rqMethod = method-          , HTTP.rqHeaders =-            [ HTTP.mkHeader HTTP.HdrHost          (T.unpack $ cdHostname cd)-            , HTTP.mkHeader HTTP.HdrUserAgent     HTTP.defaultUserAgent-            , HTTP.mkHeader HTTP.HdrContentType   "application/json"-            , HTTP.mkHeader HTTP.HdrContentLength (show contentLength)-            ] ++ autoCloseToHeader (cdAutoClose cd)-          , HTTP.rqBody    = B.unpack payload-          }-    HTTP.simpleHTTP_ con request-  rsp <- hoistE (left ConnectionException rawResponse)-  case HTTP.rspCode rsp of-    (2, _, _) -> return rsp-    code -> throwIO (HTTPResponseException ("Server returned unexpected " ++ show code ++ " response"))+  doRequest session HTTP.DELETE uri payload >>= k

@@ -23,7 +23,7 @@  mmLogin :: ConnectionData -> Login -> IO (Either LoginFailureException (Session, User)) mmLogin cd login = do-  rsp <- doUnauthRequest HTTP.POST "/users/login" (jsonBody login) cd+  rsp <- doUnauthRequest cd HTTP.POST "/users/login" (jsonBody login)   case HTTP.rspCode rsp of     (2, _, _) -> do       token <- mmGetHeader rsp (HTTP.HdrCustom "Token")@@ -35,7 +35,7 @@  mmInitialUser :: ConnectionData -> UsersCreate -> IO User mmInitialUser cd users = do-  rsp <- doUnauthRequest HTTP.POST "/users" (jsonBody users) cd+  rsp <- doUnauthRequest cd HTTP.POST "/users" (jsonBody users)   case HTTP.rspCode rsp of     (2, _, _) -> mmGetJSONBody "User" rsp     _ -> error ("Server returned unexpected " ++ show (HTTP.rspCode rsp) ++ " response")@@ -4011,4 +4011,4 @@         , flaggedPostId     = pId         , flaggedPostStatus = False         }-  in inPut (printf "/users/%s/preferences" uId) (jsonBody [body]) noResponse+  in inPost (printf "/users/%s/preferences/delete" uId) (jsonBody [body]) noResponse

@@ -24,18 +24,24 @@                                   , typeMismatch                                   ) import qualified Data.HashMap.Strict as HM+import           Data.Maybe (fromMaybe) import           Data.Monoid ( (<>) )+import qualified Data.Pool as Pool import           Data.Ratio ( (%) ) import           Data.Sequence (Seq) import qualified Data.Sequence as S+import           Data.Time (NominalDiffTime) import           Data.Text (Text) import qualified Data.Text as T import           Data.Time.Clock ( getCurrentTime ) import           Data.Time.Clock.POSIX ( posixSecondsToUTCTime                                        , utcTimeToPOSIXSeconds )-import           Network.Connection (ConnectionContext, initConnectionContext)+import           Network.Connection ( ConnectionContext+                                    , initConnectionContext+                                    ) import           Network.Mattermost.Types.Base import           Network.Mattermost.Types.Internal+import           Network.Mattermost.Util (mkConnection)  runLogger :: ConnectionData -> String -> LogEventType -> IO () runLogger ConnectionData { cdLogger = Just l } n ev =@@ -49,45 +55,66 @@ maybeFail p = (Just <$> p) <|> (return Nothing)  -- | Creates a structure representing a TLS connection to the server.-mkConnectionData :: Hostname -> Port -> ConnectionContext -> ConnectionData-mkConnectionData host port ctx = ConnectionData-  { cdHostname      = host-  , cdPort          = port-  , cdConnectionCtx = ctx-  , cdAutoClose     = Yes-  , cdToken         = Nothing-  , cdLogger        = Nothing-  , cdUseTLS        = True+mkConnectionData :: Hostname -> Port -> Pool.Pool MMConn -> ConnectionContext -> ConnectionData+mkConnectionData host port pool ctx = ConnectionData+  { cdHostname       = host+  , cdPort           = port+  , cdConnectionCtx  = ctx+  , cdAutoClose      = No+  , cdConnectionPool = pool+  , cdToken          = Nothing+  , cdLogger         = Nothing+  , cdUseTLS         = True   }  -- | Plaintext HTTP instead of a TLS connection.-mkConnectionDataInsecure :: Hostname -> Port -> ConnectionContext -> ConnectionData-mkConnectionDataInsecure host port ctx = ConnectionData-  { cdHostname      = host-  , cdPort          = port-  , cdConnectionCtx = ctx-  , cdAutoClose     = Yes-  , cdToken         = Nothing-  , cdLogger        = Nothing-  , cdUseTLS        = False+mkConnectionDataInsecure :: Hostname -> Port -> Pool.Pool MMConn -> ConnectionContext -> ConnectionData+mkConnectionDataInsecure host port pool ctx = ConnectionData+  { cdHostname       = host+  , cdPort           = port+  , cdConnectionCtx  = ctx+  , cdAutoClose      = No+  , cdConnectionPool = pool+  , cdToken          = Nothing+  , cdLogger         = Nothing+  , cdUseTLS         = False   } -initConnectionData :: Hostname -> Port -> IO ConnectionData-initConnectionData host port = do-  ctx <- initConnectionContext-  return (mkConnectionData host port ctx)+createPool :: Hostname -> Port -> ConnectionContext -> ConnectionPoolConfig -> IO (Pool.Pool MMConn)+createPool host port ctx cpc =+  Pool.createPool (mkConnection ctx host port True) closeMMConn+                  (cpStripesCount cpc) (cpIdleConnTimeout cpc) (cpMaxConnCount cpc) -initConnectionDataInsecure :: Hostname -> Port -> IO ConnectionData-initConnectionDataInsecure host port = do-  ctx <- initConnectionContext-  return (mkConnectionDataInsecure host port ctx)+initConnectionData :: Hostname -> Port -> ConnectionPoolConfig -> IO ConnectionData+initConnectionData host port cpc = do+  ctx  <- initConnectionContext+  pool <- createPool host port ctx cpc+  return (mkConnectionData host port pool ctx) +initConnectionDataInsecure :: Hostname -> Port -> ConnectionPoolConfig -> IO ConnectionData+initConnectionDataInsecure host port cpc = do+  ctx  <- initConnectionContext+  pool <- createPool host port ctx cpc+  return (mkConnectionDataInsecure host port pool ctx)++destroyConnectionData :: ConnectionData -> IO ()+destroyConnectionData = Pool.destroyAllResources . cdConnectionPool+ withLogger :: ConnectionData -> Logger -> ConnectionData withLogger cd logger = cd { cdLogger = Just logger }  noLogger :: ConnectionData -> ConnectionData noLogger cd = cd { cdLogger = Nothing } +data ConnectionPoolConfig = ConnectionPoolConfig+  { cpStripesCount    :: Int+  , cpIdleConnTimeout :: NominalDiffTime+  , cpMaxConnCount    :: Int+  }++defaultConnectionPoolConfig :: ConnectionPoolConfig+defaultConnectionPoolConfig = ConnectionPoolConfig 1 30 5+ data Session = Session   { sessConn :: ConnectionData   , sessTok  :: Token@@ -649,6 +676,16 @@   , postPropsOldHeader        :: Maybe Text   } deriving (Read, Show, Eq) +emptyPostProps :: PostProps+emptyPostProps+  = PostProps+  { postPropsOverrideIconUrl  = Nothing+  , postPropsOverrideUsername = Nothing+  , postPropsAttachments      = Nothing+  , postPropsNewHeader        = Nothing+  , postPropsOldHeader        = Nothing+  }+ instance A.FromJSON PostProps where   parseJSON = A.withObject "Props" $ \v -> do     postPropsOverrideIconUrl  <- v .:? "override_icon_url"@@ -757,9 +794,9 @@   parseJSON = A.withObject "Post" $ \v -> do     postPendingPostId <- maybeFail (v .: "pending_post_id")     postOriginalId    <- maybeFail (v .: "original_id")-    postProps         <- v .: "props"+    postProps         <- fromMaybe emptyPostProps <$> v .: "props"     postRootId        <- maybeFail (v .: "root_id")-    postFileIds       <- (v .: "file_ids") <|> (return mempty)+    postFileIds       <- v .:? "file_ids" .!= mempty     postId            <- v .: "id"     postType          <- v .: "type"     postMessage       <- v .: "message"@@ -771,7 +808,7 @@     postCreateAt      <- timeFromServer <$> v .: "create_at"     postParentId      <- maybeFail (v .: "parent_id")     postChannelId     <- v .: "channel_id"-    postHasReactions  <- (v .: "has_reactions") <|> (return False)+    postHasReactions  <- v .:? "has_reactions" .!= False     return Post { .. }  instance A.ToJSON Post where@@ -880,7 +917,7 @@     fileInfoMimeType   <- o .: "mime_type"     fileInfoWidth      <- o .:? "width"     fileInfoHeight     <- o .:? "height"-    fileInfoHasPreview <- (o .: "has_preview_image") <|> pure False+    fileInfoHasPreview <- o .:? "has_preview_image" .!= False     return FileInfo { .. }  --

@@ -1,3 +1,5 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} -- | The types defined in this module are exported to facilitate -- efforts such as QuickCheck and other instrospection efforts, but -- users are advised to avoid using these types wherever possible:@@ -7,8 +9,14 @@  module Network.Mattermost.Types.Internal where -import Network.Connection (ConnectionContext)+import Control.Monad (when)+import Data.Pool (Pool)+import qualified Network.Connection as C+import Control.Exception (finally)+import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Network.HTTP.Headers (Header, HeaderName(..), mkHeader)+import qualified Network.HTTP.Stream as HTTP+import qualified Data.ByteString.Char8 as B import Network.Mattermost.Types.Base  data Token = Token String@@ -17,10 +25,6 @@ getTokenString :: Token -> String getTokenString (Token s) = s --- For now we don't support or expose the ability to reuse connections,--- but we have this field in case we want to support that in the future.--- Doing so will require some modifications to withConnection (and uses).--- Note: don't export this until we support connection reuse. data AutoClose = No | Yes   deriving (Read, Show, Eq, Ord) @@ -30,14 +34,52 @@ autoCloseToHeader No  = [] autoCloseToHeader Yes = [mkHeader HdrConnection "Close"] +data MMConn = MMConn { fromMMConn :: C.Connection+                     , connConnected :: IORef Bool+                     } +closeMMConn :: MMConn -> IO ()+closeMMConn c = do+    conn <- readIORef $ connConnected c+    when conn $+        C.connectionClose (fromMMConn c)+            `finally` (writeIORef (connConnected c) False)++newMMConn :: C.Connection -> IO MMConn+newMMConn c = do+    v <- newIORef True+    return $ MMConn c v++isConnected :: MMConn -> IO Bool+isConnected = readIORef . connConnected++maxLineLength :: Int+maxLineLength = 2^(16::Int)++-- | HTTP ends newlines with \r\n sequence, but the 'connection' package doesn't+-- know this so we need to drop the \r after reading lines. This should only be+-- needed in your compatibility with the HTTP library.+dropTrailingChar :: B.ByteString -> B.ByteString+dropTrailingChar bs | not (B.null bs) = B.init bs+dropTrailingChar _ = ""++-- | This instance allows us to use 'simpleHTTP' from 'Network.HTTP.Stream' with+-- connections from the 'connection' package.+instance HTTP.Stream MMConn where+  readLine   con       = Right . B.unpack . dropTrailingChar <$> C.connectionGetLine maxLineLength (fromMMConn con)+  readBlock  con n     = Right . B.unpack <$> C.connectionGetExact (fromMMConn con) n+  writeBlock con block = Right <$> C.connectionPut (fromMMConn con) (B.pack block)+  close      con       = C.connectionClose (fromMMConn con)+  closeOnEnd _   _     = return ()+ data ConnectionData   = ConnectionData-  { cdHostname      :: Hostname-  , cdPort          :: Port-  , cdAutoClose     :: AutoClose-  , cdConnectionCtx :: ConnectionContext-  , cdToken         :: Maybe Token-  , cdLogger        :: Maybe Logger-  , cdUseTLS        :: Bool+  { cdHostname       :: Hostname+  , cdPort           :: Port+  , cdAutoClose      :: AutoClose+  , cdConnectionPool :: Pool MMConn+  , cdConnectionCtx  :: C.ConnectionContext+  , cdToken          :: Maybe Token+  , cdLogger         :: Maybe Logger+  , cdUseTLS         :: Bool   }

@@ -6,29 +6,27 @@ , noteE , hoistE , (~=)-, dropTrailingChar , withConnection , mkConnection , connectionGetExact ) where +import           Control.Exception (finally, onException) import           Data.Char ( toUpper ) import qualified Data.ByteString.Char8 as B import qualified Data.Text as T  import           Control.Exception ( Exception-                                   , throwIO-                                   , bracket )+                                   , throwIO )+import           Data.Pool (takeResource, putResource, destroyResource) import           Network.Connection ( Connection+                                    , ConnectionContext                                     , ConnectionParams(..)                                     , TLSSettings(..)                                     , connectionGet-                                    , connectionGetLine-                                    , connectionPut-                                    , connectionClose                                     , connectTo )-import qualified Network.HTTP.Stream as HTTP +import           Network.Mattermost.Types.Base import           Network.Mattermost.Types.Internal  -- | This unwraps a 'Maybe' value, throwing a provided exception@@ -53,49 +51,29 @@ (~=) :: String -> String -> Bool a ~= b = map toUpper a == map toUpper b --- | HTTP ends newlines with \r\n sequence, but the 'connection' package doesn't--- know this so we need to drop the \r after reading lines. This should only be--- needed in your compatibility with the HTTP library.-dropTrailingChar :: B.ByteString -> B.ByteString-dropTrailingChar bs | not (B.null bs) = B.init bs-dropTrailingChar _ = ""---- | Creates a new connection to 'Hostname' from an already initialized 'ConnectionContext'.--- Internally it uses 'bracket' to cleanup the connection.+-- | Creates a new connection to 'Hostname' from an already initialized+-- 'ConnectionContext'. withConnection :: ConnectionData -> (MMConn -> IO a) -> IO a-withConnection cd action =-  bracket (MMConn <$> mkConnection cd)-          (connectionClose . fromMMConn)-          action--maxLineLength :: Int-maxLineLength = 2^(16::Int)--newtype MMConn = MMConn { fromMMConn :: Connection }---- | This instance allows us to use 'simpleHTTP' from 'Network.HTTP.Stream' with--- connections from the 'connection' package.-instance HTTP.Stream MMConn where-  readLine   con       = Right . B.unpack . dropTrailingChar <$> connectionGetLine maxLineLength (fromMMConn con)-  readBlock  con n     = Right . B.unpack <$> connectionGetExact (fromMMConn con) n-  writeBlock con block = Right <$> connectionPut (fromMMConn con) (B.pack block)-  close      con       = connectionClose (fromMMConn con)-  closeOnEnd _   _     = return ()-+withConnection cd action = do+    (conn, lp) <- takeResource (cdConnectionPool cd)+    (action conn `onException` closeMMConn conn) `finally` do+        c <- isConnected conn+        if c then+             putResource lp conn else+             destroyResource (cdConnectionPool cd) lp conn  -- | Creates a connection from a 'ConnectionData' value, returning it. It --   is the user's responsibility to close this appropriately.-mkConnection :: ConnectionData -> IO Connection-mkConnection cd = do-  connectTo (cdConnectionCtx cd) $ ConnectionParams-    { connectionHostname  = T.unpack $ cdHostname cd-    , connectionPort      = fromIntegral (cdPort cd)-    , connectionUseSecure = if cdUseTLS cd+mkConnection :: ConnectionContext -> Hostname -> Port -> Bool -> IO MMConn+mkConnection connectionCtx hostname port useTLS = do+  newMMConn =<< (connectTo connectionCtx $ ConnectionParams+    { connectionHostname  = T.unpack hostname+    , connectionPort      = fromIntegral port+    , connectionUseSecure = if useTLS                                then Just (TLSSettingsSimple False False False)                                else Nothing     , connectionUseSocks  = Nothing-    }-+    })  -- | Get exact count of bytes from a connection. --

@@ -110,8 +110,8 @@                 -> (MMWebSocket -> IO ())                 -> IO () mmWithWebSocket (Session cd (Token tk)) recv body = do-  con <- mkConnection cd-  stream <- connectionToStream con+  con <- mkConnection (cdConnectionCtx cd) (cdHostname cd) (cdPort cd) (cdUseTLS cd)+  stream <- connectionToStream $ fromMMConn con   health <- newIORef 0   myId <- myThreadId   let doLog = runLogger cd "websocket"

@@ -330,8 +330,8 @@  connectFromConfig :: TestConfig -> IO ConnectionData connectFromConfig cfg =-  initConnectionDataInsecure (configHostname cfg)-                             (fromIntegral (configPort cfg))+  initConnectionDataInsecure (configHostname cfg) (fromIntegral (configPort cfg))+                             defaultConnectionPoolConfig  getConnection :: TestM ConnectionData getConnection = gets tsConnectionData