diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,20 @@ + +50200.2.0 +========= + +API changes: + * Added `Network.Mattermost.Endpoints.mmDeleteReaction` to delete + reactions. + * Added `Network.Mattermost.Endpoints.mmPostReaction` to add reactions. + * Added an `Emoji` data type and functions for custom emoji search and listing: + * `Network.Mattermost.Endpoints.mmSearchCustomEmoji` + * `Network.Mattermost.Endpoints.mmGetListOfCustomEmoji` + +New features: + * Add support for SOCKS proxies via standard environment variables + `HTTPS_PROXY` and `ALL_PROXY`. + * Support `NO_PROXY` to blacklist proxied hosts. + 50200.1.4 ========= 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: 50200.1.4 +version: 50200.2.0 synopsis: Client API for Mattermost chat system description: Client API for Mattermost chat system. Mattermost is a @@ -34,6 +34,7 @@ Network.Mattermost.Lenses Network.Mattermost.Logging Network.Mattermost.Util + Network.Mattermost.Proxy Network.Mattermost.WebSocket Network.Mattermost.WebSocket.Types Network.Mattermost.Version @@ -73,6 +74,7 @@ , microlens-th -- Only here to make debugging easier , pretty-show + , split hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -Wcompat 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 @@ -415,13 +415,26 @@ -- mmCreateCustomEmoji = -- inPost "/emoji" noBody jsonResponse --- -- | Get a page of metadata for custom emoji on the system. --- -- --- -- /Permissions/: Must be authenticated. --- mmGetListOfCustomEmoji :: Maybe Integer -> Maybe Integer -> Session -> IO Emoji --- mmGetListOfCustomEmoji page perPage = --- inGet (printf "/emoji?%s" (mkQueryString [ sequence ("page", fmap show page) , sequence ("per_page", fmap show perPage) ])) noBody jsonResponse +-- | Search custom emoji using an infix match. (Does not support the +-- prefix_only option). +-- +-- /Permissions/: Must be authenticated. +mmSearchCustomEmoji :: T.Text -> Session -> IO [Emoji] +mmSearchCustomEmoji searchString = + let body = A.object [ "term" A..= searchString + ] + in inPost (printf "/emoji/search") (jsonBody body) jsonResponse +-- | Get a page of metadata for custom emoji on the system. +-- +-- /Permissions/: Must be authenticated. +mmGetListOfCustomEmoji :: Maybe Integer -> Maybe Integer -> Session -> IO [Emoji] +mmGetListOfCustomEmoji page perPage = + let qs = mkQueryString [ sequence ("page", fmap show page) + , sequence ("per_page", fmap show perPage) + ] + in inGet (printf "/emoji?%s" qs) noBody jsonResponse + -- -- | Get some metadata for a custom emoji. -- -- -- -- /Permissions/: Must be authenticated. @@ -844,11 +857,17 @@ mmGetReactionsForPost postId = inGet (printf "/posts/%s/reactions" postId) noBody jsonResponse --- mmPostReaction :: Session -> IO () --- mmPostReaction = --- inPost (printf "/reactions") (jsonBody ()) noResponse - +mmPostReaction :: PostId -> UserId -> T.Text -> Session -> IO () +mmPostReaction postId userId reac = + let body = A.object [ "user_id" A..= userId + , "post_id" A..= postId + , "emoji_name" A..= reac + ] + in inPost (printf "/reactions") (jsonBody body) noResponse +mmDeleteReaction :: PostId -> UserId -> T.Text -> Session -> IO () +mmDeleteReaction postId userId reac = + inDelete (printf "/users/%s/posts/%s/reactions/%s" userId postId reac) noBody noResponse -- * SAML @@ -1346,7 +1365,8 @@ mmSearchUsers body = inPost "/users/search" (jsonBody body) jsonResponse --- | Get a list of users based on a provided list of usernames. +-- | Get a list of users based on a provided list of usernames. The +-- input usernames must be usernames without sigils (@). -- -- /Permissions/: Requires an active session but no other permissions. mmGetUsersByUsernames :: (Seq Text) -> Session -> IO (Seq User) @@ -2060,47 +2080,39 @@ -- , "desc" A..= complianceDesc -- ] --- -- - --- -- - --- -- - --- data Emoji = Emoji --- { emojiCreatorId :: Text --- , emojiName :: Text --- -- ^ The name of the emoji --- , emojiDeleteAt :: UnknownType --- -- ^ The time at which the emoji was deleted. --- , emojiUpdateAt :: UnknownType --- -- ^ The time at which the emoji was updated. --- , emojiCreateAt :: UnknownType --- -- ^ The time at which the emoji was made --- , emojiId :: Text --- -- ^ The ID of the emoji --- } deriving (Read, Show, Eq) - --- instance A.FromJSON Emoji where --- parseJSON = A.withObject "emoji" $ \v -> do --- emojiCreatorId <- v A..: "creator_id" --- emojiName <- v A..: "name" --- emojiDeleteAt <- v A..: "delete_at" --- emojiUpdateAt <- v A..: "update_at" --- emojiCreateAt <- v A..: "create_at" --- emojiId <- v A..: "id" --- return Emoji { .. } +data Emoji = Emoji + { emojiCreatorId :: Text + , emojiName :: Text + -- ^ The name of the emoji + , emojiDeleteAt :: Integer + -- ^ The time at which the emoji was deleted. + , emojiUpdateAt :: Integer + -- ^ The time at which the emoji was updated. + , emojiCreateAt :: Integer + -- ^ The time at which the emoji was made + , emojiId :: Text + -- ^ The ID of the emoji + } deriving (Read, Show, Eq) --- instance A.ToJSON Emoji where --- toJSON Emoji { .. } = A.object --- [ "creator_id" A..= emojiCreatorId --- , "name" A..= emojiName --- , "delete_at" A..= emojiDeleteAt --- , "update_at" A..= emojiUpdateAt --- , "create_at" A..= emojiCreateAt --- , "id" A..= emojiId --- ] +instance A.FromJSON Emoji where + parseJSON = A.withObject "emoji" $ \v -> do + emojiCreatorId <- v A..: "creator_id" + emojiName <- v A..: "name" + emojiDeleteAt <- v A..: "delete_at" + emojiUpdateAt <- v A..: "update_at" + emojiCreateAt <- v A..: "create_at" + emojiId <- v A..: "id" + return Emoji { .. } --- -- +instance A.ToJSON Emoji where + toJSON Emoji { .. } = A.object + [ "creator_id" A..= emojiCreatorId + , "name" A..= emojiName + , "delete_at" A..= emojiDeleteAt + , "update_at" A..= emojiUpdateAt + , "create_at" A..= emojiCreateAt + , "id" A..= emojiId + ] -- data FileSettings = FileSettings -- { fileSettingsInitialfont :: Text diff --git a/src/Network/Mattermost/Proxy.hs b/src/Network/Mattermost/Proxy.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/Proxy.hs @@ -0,0 +1,84 @@ +module Network.Mattermost.Proxy + ( Scheme(..) + , ProxyType(..) + , proxyForScheme + , proxyHostPermitted + ) +where + +import Control.Applicative ((<|>)) +import Data.Char (toLower) +import Data.List (isPrefixOf) +import Data.List.Split (splitOn) +import Network.URI (parseURI, uriRegName, uriPort, uriAuthority, uriScheme) +import System.Environment (getEnvironment, lookupEnv) +import Text.Read (readMaybe) + +data Scheme = HTTPS + deriving (Eq, Show) + +data ProxyType = Socks + deriving (Eq, Show) + +newtype NormalizedEnv = NormalizedEnv [(String, String)] + +proxyHostPermitted :: String -> IO Bool +proxyHostPermitted hostname = do + result <- lookupEnv "NO_PROXY" + case result of + Nothing -> return True + Just blacklist -> do + let patterns = splitOn "," blacklist + hostnameParts = reverse $ splitOn "." hostname + isBlacklisted = any matches patterns + matches pat = + let patParts = reverse $ splitOn "." pat + go [] [] = True + go [] _ = False + go _ [] = False + go (p:pParts) hParts = + if p == "*" + then True + else case hParts of + [] -> False + (h:hTail) -> p == h && go pParts hTail + in go patParts hostnameParts + return $ not isBlacklisted + +proxyForScheme :: Scheme -> IO (Maybe (ProxyType, String, Int)) +proxyForScheme s = do + env <- getEnvironment + let proxy = case s of + HTTPS -> httpsProxy + return $ proxy $ normalizeEnv env + +httpsProxy :: NormalizedEnv -> Maybe (ProxyType, String, Int) +httpsProxy env = proxyFor "HTTPS_PROXY" env <|> + proxyFor "ALL_PROXY" env + +proxyFor :: String -> NormalizedEnv -> Maybe (ProxyType, String, Int) +proxyFor name env = do + val <- envLookup name env + uri <- parseURI val + + let scheme = uriScheme uri + getProxyType = isSocks + isSocks = if "socks" `isPrefixOf` scheme + then return Socks + else Nothing + + ty <- getProxyType + auth <- uriAuthority uri + port <- readMaybe (drop 1 $ uriPort auth) + return (ty, uriRegName auth, port) + +normalizeEnv :: [(String, String)] -> NormalizedEnv +normalizeEnv env = + let norm (k, v) = (normalizeVar k, v) + in NormalizedEnv $ norm <$> env + +normalizeVar :: String -> String +normalizeVar = (toLower <$>) + +envLookup :: String -> NormalizedEnv -> Maybe String +envLookup v (NormalizedEnv env) = lookup (normalizeVar v) env 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 @@ -80,8 +80,8 @@ } -- | Plaintext HTTP instead of a TLS connection. -mkConnectionDataInsecure :: Hostname -> Port -> Pool.Pool MMConn -> ConnectionContext -> ConnectionData -mkConnectionDataInsecure host port pool ctx = ConnectionData +mkConnectionDataInsecure :: Hostname -> Port -> ConnectionContext -> Pool.Pool MMConn -> ConnectionData +mkConnectionDataInsecure host port ctx pool = ConnectionData { cdHostname = host , cdPort = port , cdConnectionCtx = ctx @@ -94,7 +94,7 @@ createPool :: Hostname -> Port -> ConnectionContext -> ConnectionPoolConfig -> Bool -> IO (Pool.Pool MMConn) createPool host port ctx cpc secure = - Pool.createPool (mkConnection ctx host port secure) closeMMConn + Pool.createPool (mkConnection ctx host port secure >>= newMMConn) closeMMConn (cpStripesCount cpc) (cpIdleConnTimeout cpc) (cpMaxConnCount cpc) initConnectionData :: Hostname -> Port -> ConnectionPoolConfig -> IO ConnectionData @@ -107,7 +107,7 @@ initConnectionDataInsecure host port cpc = do ctx <- initConnectionContext pool <- createPool host port ctx cpc False - return (mkConnectionDataInsecure host port pool ctx) + return (mkConnectionDataInsecure host port ctx pool) destroyConnectionData :: ConnectionData -> IO () destroyConnectionData = Pool.destroyAllResources . cdConnectionPool 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 @@ -22,12 +22,14 @@ import Network.Connection ( Connection , ConnectionContext , ConnectionParams(..) + , ProxySettings(..) , TLSSettings(..) , connectionGet , connectTo ) import Network.Mattermost.Types.Base import Network.Mattermost.Types.Internal +import Network.Mattermost.Proxy -- | This unwraps a 'Maybe' value, throwing a provided exception -- if the value is 'Nothing'. @@ -64,16 +66,30 @@ -- | Creates a connection from a 'ConnectionData' value, returning it. It -- is the user's responsibility to close this appropriately. -mkConnection :: ConnectionContext -> Hostname -> Port -> Bool -> IO MMConn -mkConnection connectionCtx hostname port useTLS = do - newMMConn =<< (connectTo connectionCtx $ ConnectionParams - { connectionHostname = T.unpack hostname +-- +-- This function respects ALL_PROXY, HTTP_PROXY, HTTPS_PROXY, and +-- NO_PROXY environment variables for controlling whether the resulting +-- connection uses a proxy. However, note: +-- +-- * Only SOCKS version 4 and 5 proxies are supported using socks4:// +-- and socks5:// URIs, and +-- * No proxy authentication is supported. +mkConnection :: ConnectionContext -> Hostname -> Port -> Bool -> IO Connection +mkConnection ctx host port secure = do + proxy' <- if secure then proxyForScheme HTTPS else return Nothing + canUseProxy <- proxyHostPermitted (T.unpack host) + let proxy = if canUseProxy then proxy' else Nothing + connectTo ctx $ ConnectionParams + { connectionHostname = T.unpack host , connectionPort = fromIntegral port - , connectionUseSecure = if useTLS + , connectionUseSecure = if secure then Just (TLSSettingsSimple False False False) else Nothing - , connectionUseSocks = Nothing - }) + , connectionUseSocks = do + (ty, cHost, cPort) <- proxy + case ty of + Socks -> return $ SockSettingsSimple cHost (toEnum cPort) + } -- | 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 @@ -111,7 +111,7 @@ -> IO () mmWithWebSocket (Session cd (Token tk)) recv body = do con <- mkConnection (cdConnectionCtx cd) (cdHostname cd) (cdPort cd) (cdUseTLS cd) - stream <- connectionToStream $ fromMMConn con + stream <- connectionToStream con health <- newIORef 0 myId <- myThreadId let doLog = runLogger cd "websocket"