diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ========= diff --git a/examples/GetChannels.hs b/examples/GetChannels.hs --- a/examples/GetChannels.hs +++ b/examples/GetChannels.hs @@ -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 diff --git a/examples/GetPosts.hs b/examples/GetPosts.hs --- a/examples/GetPosts.hs +++ b/examples/GetPosts.hs @@ -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' diff --git a/examples/GetTeams.hs b/examples/GetTeams.hs --- a/examples/GetTeams.hs +++ b/examples/GetTeams.hs @@ -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 } diff --git a/examples/GetWebsocketConnection.hs b/examples/GetWebsocketConnection.hs --- a/examples/GetWebsocketConnection.hs +++ b/examples/GetWebsocketConnection.hs @@ -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 diff --git a/examples/MakePost.hs b/examples/MakePost.hs --- a/examples/MakePost.hs +++ b/examples/MakePost.hs @@ -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 diff --git a/examples/ShowRawEvents.hs b/examples/ShowRawEvents.hs --- a/examples/ShowRawEvents.hs +++ b/examples/ShowRawEvents.hs @@ -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 diff --git a/mattermost-api.cabal b/mattermost-api.cabal --- a/mattermost-api.cabal +++ b/mattermost-api.cabal @@ -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): diff --git a/src/Network/Mattermost.hs b/src/Network/Mattermost.hs --- a/src/Network/Mattermost.hs +++ b/src/Network/Mattermost.hs @@ -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 diff --git a/src/Network/Mattermost/Connection.hs b/src/Network/Mattermost/Connection.hs --- a/src/Network/Mattermost/Connection.hs +++ b/src/Network/Mattermost/Connection.hs @@ -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 diff --git a/src/Network/Mattermost/Endpoints.hs b/src/Network/Mattermost/Endpoints.hs --- a/src/Network/Mattermost/Endpoints.hs +++ b/src/Network/Mattermost/Endpoints.hs @@ -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 diff --git a/src/Network/Mattermost/Types.hs b/src/Network/Mattermost/Types.hs --- a/src/Network/Mattermost/Types.hs +++ b/src/Network/Mattermost/Types.hs @@ -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 { .. } -- diff --git a/src/Network/Mattermost/Types/Internal.hs b/src/Network/Mattermost/Types/Internal.hs --- a/src/Network/Mattermost/Types/Internal.hs +++ b/src/Network/Mattermost/Types/Internal.hs @@ -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 } diff --git a/src/Network/Mattermost/Util.hs b/src/Network/Mattermost/Util.hs --- a/src/Network/Mattermost/Util.hs +++ b/src/Network/Mattermost/Util.hs @@ -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. -- diff --git a/src/Network/Mattermost/WebSocket.hs b/src/Network/Mattermost/WebSocket.hs --- a/src/Network/Mattermost/WebSocket.hs +++ b/src/Network/Mattermost/WebSocket.hs @@ -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" diff --git a/test/Tests/Util.hs b/test/Tests/Util.hs --- a/test/Tests/Util.hs +++ b/test/Tests/Util.hs @@ -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