diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,138 @@ + +30802.1.0 +========= + +This release supports server version 3.8.2. + +API changes: +* Made the PendingPost `created_at` field optional. It defaults to 0. + This behavior is due to MatterMost's support for admins setting the + creation timestamp to values in the past. A value of zero causes + the server to use the server's clock to set the creation timestamp. + Any other value is only permitted for users with administrative + privileges. +* Moved some types to a new Types.Internal module and exposed that + module for testing purposes. It should not be used by anyone wanting + a stable API. For a stable API, see the export list for the Types + module. + +30802.0.0 +========= + +This release supports server version 3.8.2. + +API changes: +* The `Network.Mattermost.Types` module is now directly exported and all + clients should obtain their types from this import. The types are + still exported from `Network.Mattermost` to allow time for this change + but this export is deprecated will be removed in a future version. +* Added the CommandResponse type for the execute endpoint. +* mmGetMoreChannels, mmGetChannelMembers, and mmGetProfiles now take + limit/offset parameters. +* mmGetFile now supports v4 file-fetching. +* Added new constructors to the WebsocketEventType corresponding to + server websocket events. +* mmUpdateLastViewedAt was replaced with mmViewChannel. +* Added the WithDefault type to wrap around bools and NotifyOptions. +* Added NotifyProps types. +* The `Token` type has been replaced with a `Session` type, + representing a combination of a `Token` and a `ConnectionData` + type. All exposed API functions which require an authenticated + connection will use this instead. This is a major breaking change, + but makes the API significantly cleaner. +* Removed `UserProfile` type in favor of single pervasive `User` type. +* Replaced the return type of `mmGetTeamMembers` to use a `TeamMember` + instead of raw JSON `Value`s. + +Documentation: +* All API functions how have corresponding HTTP route documentation. + +Package changes: +* Source repository was updated. +* Constrained 'memory' version to avoid 'foundation' dependency. +* Include Network.Mattermost.TH. +* The `Network.Mattermost.Websocket` module now exports everything + exported by `Network.Mattermost.Websocket.Types` in order to cut + down on the number of imports needed by users. + +30701.0.0 +========= + +* Supports server version 3.7.1. + +API changes: +* Tests now provide websocket event testing infrastructure +* The Channel data type now supports Group channels (type "G") +* Added mmGetTeamMembers to get the users in a channel +* Added support for the Post type `system_header_change` and the post + properties `new_header` and `old_header` as described at + https://github.com/mattermost/platform/pull/4209 +* Removed the UserProfile type in favor of the User type (fixed #23) + +Bug fixes: +* WebSocket.Types: permit empty `team_id` in event data + +30600.2.2 +========= + +Bug fixes: + * Support optional `notify_props` and `last_password_update` in + mmGetUser responses. + +Package changes: + * Renamed ChangeLog.md to CHANGELOG.md. + +Testing changes: + * Added support for testing websocket events and updated the test suite + to check for expected websocket events. + +30600.2.1 +========= + +API changes: + * Export FileInfo type + +Bug fixes: + * Fixed parsing of nullable width/height fields in FileInfo + * Fixed parsing of create_at, update_at, and delete_at timestamp fields + in FileInfo + +30600.2.0 +========= + +API changes: + * Added mmDeletePost + * Added mmUpdatePost for editing posts + * Post: make deletion time optional to match server API, do millisecond + conversion on JSON encoding + * PendingPost: add fields for setting parents in case of replies + * Export PendingPost type so it can be modified for replies and edits + +Bug fixes: + * Post: do millisecond conversion of timestamps on JSON encoding + +30600.1.0 +========= + +API changes: + * MinCommand lost its unused minComSuggest field + +Bug fixes: + * The JSON format of MinCommand got its channelId field (3.5.0) renamed + to channel_id (3.6.0). See also: + https://github.com/mattermost/platform/issues/5281 + +Other: + * mmGetJSONBody got a debugging label that it now uses to generate + exception messages to indicate what kind of value it was attempting + to parse. + +30600.0.0 +========= + +Initial release for server version 3.6.0. + +0.1.0.0 +======= + +First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, Jason Dagit + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jason Dagit nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ +[![Build +Status](https://travis-ci.org/matterhorn-chat/mattermost-api.svg?branch=master)](https://travis-ci.org/matterhorn-chat/mattermost-api) +# mattermost-api +Client side API for communicating with a MatterMost server, in Haskell. + +# Testing + +We use the MaterMost docker image for detecting changes in the API. See +`.travis.yml` or the [MatterMost +docs](https://docs.mattermost.com/install/docker-local-machine.html#one-line-docker-install) +for the details. + +If you are testing your changes locally during development, you will want to run +the script `./test/local_test_mm.sh`. + +**Note: The `local_test_mm.sh` script will stop and remove a docker container +named `mattermost-preview`.** + +**Note: The tests can only be run once against a given MatterMost instance. This +is because the scripts currently assume they can create an initial admin user.** + +**Note: The scripts assume the instance is reachable on `localhost:8065` over plain +HTTP.** + +For use in production we use TLS, but for testing purposes we avoid the +certificate setup. + +# Our Versioning Scheme + +This library uses the same versioning scheme as `matterhorn`, see [Our +Versioning +Scheme](https://github.com/matterhorn-chat/matterhorn/blob/master/README.md#our-versioning-scheme). +The short version is that in `ABBCC.X.Y`, the `ABBCC` corresponds to MatterMost +server version `A.BB.CC` and the `X.Y` portion of the version string corresponds +to the version of `mattermost-api` package releases. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Config.hs b/examples/Config.hs new file mode 100644 --- /dev/null +++ b/examples/Config.hs @@ -0,0 +1,12 @@ +module Config where + +import Data.Text + +data Config + = Config + { configUsername :: Text + , configHostname :: Text + , configTeam :: Text + , configPort :: Int + , configPassword :: Text + } diff --git a/examples/GetChannels.hs b/examples/GetChannels.hs new file mode 100644 --- /dev/null +++ b/examples/GetChannels.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +-- Note: See LocalConfig.hs to configure example for your server +module Main (main) where +import Text.Show.Pretty ( pPrint ) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Network.Connection +import Data.Foldable +import Control.Monad ( when, join ) + +import Network.Mattermost + +import Config +import LocalConfig -- You will need to define a function: + -- getConfig :: IO Config + -- See Config.hs + +main :: IO () +main = do + config <- getConfig -- see LocalConfig import + ctx <- initConnectionContext + let cd = mkConnectionData (configHostname config) + (fromIntegral (configPort config)) ctx + + let login = Login { username = configUsername config + , password = configPassword config + } + + (session, mmUser) <- join (hoistE <$> mmLogin cd login) + putStrLn "Authenticated as:" + pPrint mmUser + + i <- mmGetInitialLoad session + forM_ (initialLoadTeams i) $ \t -> do + when (teamName t == configTeam config) $ do + chans <- mmGetChannels session (teamId t) + forM_ chans $ \chan -> do + channel <- mmGetChannel session (teamId t) (channelId chan) + pPrint channel + putStrLn "" diff --git a/examples/GetPosts.hs b/examples/GetPosts.hs new file mode 100644 --- /dev/null +++ b/examples/GetPosts.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +-- Note: See LocalConfig.hs to configure example for your server +module Main (main) where +import Text.Read ( readMaybe ) +import Text.Printf ( printf ) +import Data.Foldable ( toList ) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Text.Show.Pretty ( pPrint ) +import Network.Connection +import System.Process ( readProcess ) +import System.Exit ( exitFailure + , exitWith + , ExitCode(..) ) +import Data.Foldable +import Control.Monad ( when, join ) + +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) + +import Network.Mattermost +import Network.Mattermost.Logging +import Network.Mattermost.Util + +import Config +import LocalConfig -- You will need to define a function: + -- getConfig :: IO Config + -- See Config.hs + + +data Options + = Options + { optChannel :: T.Text + , optVerbose :: Bool + , optOffset :: Int + , optLimit :: Int + , optLogging :: Bool + } deriving (Read, Show) + +defaultOptions :: Options +defaultOptions = Options + { optChannel = "town-square" + , optVerbose = False + , optOffset = 0 + , optLimit = 10 + , optLogging = False + } + +options :: [ OptDescr (Options -> IO Options) ] +options = + [ Option "c" ["channel"] + (ReqArg + (\arg opt -> return opt { optChannel = T.pack arg }) + "CHANNEL") + "Channel to fetch posts from" + , Option "v" ["verbose"] + (NoArg + (\opt -> return opt { optVerbose = True })) + "Enable verbose output" + , Option "L" ["logging"] + (NoArg + (\opt -> do + return opt { optLogging = True })) + "Log debug output to stderr" + , Option "o" ["offset"] + (ReqArg + (\arg opt -> do + case readMaybe arg of + Nothing -> do putStrLn "offset must be an int" + exitFailure + Just i -> return opt { optOffset = i }) + "OFFSET") + "Starting offset to grab posts, 0 is most recent" + , Option "l" ["limit"] + (ReqArg + (\arg opt -> do + case readMaybe arg of + Nothing -> do putStrLn "limit must be an int" + exitFailure + Just n -> return opt { optLimit = n }) + "LIMIT") + "Maximum number of posts to fetch" + , Option "h" ["help"] + (NoArg + (\_ -> do + prg <- getProgName + putStrLn (usageInfo prg options) + exitWith ExitSuccess)) + "Show help" + ] + +main :: IO () +main = do + args <- getArgs + let (actions, nonOptions, errors) = getOpt RequireOrder options args + 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 = if optLogging opts + then cd' `withLogger` mmLoggerDebugErr + else cd' + + (session, mmUser) <- join (hoistE <$> mmLogin cd login) + when (optVerbose opts) $ do + putStrLn "Authenticated as:" + pPrint mmUser + + i <- mmGetInitialLoad session + when (optVerbose opts) $ do + pPrint i + forM_ (initialLoadTeams i) $ \t -> do + when (teamName t == configTeam config) $ do + userMap <- mmGetProfiles session (getId t) 0 10000 + when (optVerbose opts) $ do + pPrint userMap + chans <- mmGetChannels session (getId t) + forM_ chans $ \chan -> do + when (optVerbose opts) $ do + pPrint chan + when (channelName chan == optChannel opts) $ do + posts <- mmGetPosts session (getId t) (getId chan) (optOffset opts) (optLimit opts) + forM_ (reverse (toList (postsOrder posts))) $ \postId -> do + -- this is just a toy program, so we don't care about + -- this pattern match failure + let Just p = HM.lookup postId (postsPosts posts) + Just uId = postUserId p + Just user = HM.lookup uId userMap + when (optVerbose opts) $ do + pPrint p + let message = printf "%s: %s" + (userUsername user) + (postMessage p) + putStrLn message diff --git a/examples/GetTeams.hs b/examples/GetTeams.hs new file mode 100644 --- /dev/null +++ b/examples/GetTeams.hs @@ -0,0 +1,31 @@ +-- Note: See LocalConfig.hs to configure example for your server +module Main (main) where +import Control.Monad ( void, join ) +import qualified Data.Text as T +import Text.Show.Pretty ( pPrint ) +import Network.Connection +import System.Process ( readProcess ) + +import Network.Mattermost + +import Config +import LocalConfig -- You will need to define a function: + -- getConfig :: IO Config + -- See Config.hs + +main :: IO () +main = do + config <- getConfig -- see LocalConfig import + ctx <- initConnectionContext + let cd = mkConnectionData (configHostname config) + (fromIntegral (configPort config)) + ctx + let login = Login { username = configUsername config + , password = configPassword config + } + + (session, mmUser) <- join (hoistE <$> mmLogin cd login) + putStrLn "Authenticated as: " + pPrint mmUser + i <- mmGetInitialLoad session + pPrint $ initialLoadTeams i diff --git a/examples/GetWebsocketConnection.hs b/examples/GetWebsocketConnection.hs new file mode 100644 --- /dev/null +++ b/examples/GetWebsocketConnection.hs @@ -0,0 +1,79 @@ +module Main(main) where + +import Control.Monad ( when, join ) +import qualified Data.Text as T +import Network.Connection +import Text.Read ( readMaybe ) +import Text.Show.Pretty ( pPrint ) + +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) +import System.Exit ( exitFailure + , exitWith + , ExitCode(..) ) + +import Network.Mattermost +import Network.Mattermost.Util +import Network.Mattermost.WebSocket + +import Config +import LocalConfig -- You will need to define a function: + -- getConfig :: IO Config + -- See Config.hs + +data Options + = Options + { optVerbose :: Bool + } deriving (Read, Show) + +defaultOptions :: Options +defaultOptions = Options + { optVerbose = False + } + +options :: [ OptDescr (Options -> IO Options) ] +options = + [ Option "v" ["verbose"] + (NoArg + (\opt -> return opt { optVerbose = True })) + "Enable verbose output" + , Option "h" ["help"] + (NoArg + (\_ -> do + prg <- getProgName + putStrLn (usageInfo prg options) + exitWith ExitSuccess)) + "Show help" + ] + +main :: IO () +main = do + args <- getArgs + let (actions, nonOptions, errors) = getOpt RequireOrder options args + 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 + } + + (session, mmUser) <- join (hoistE <$> mmLogin cd login) + when (optVerbose opts) $ do + putStrLn "Authenticated as:" + pPrint mmUser + + mmWithWebSocket session printEvent checkForExit + +printEvent :: WebsocketEvent -> IO () +printEvent we = pPrint we + +checkForExit :: MMWebSocket -> IO () +checkForExit ws = do + ln <- getLine + if ln == "exit" + then mmCloseWebSocket ws + else checkForExit ws diff --git a/examples/LocalConfig.hs b/examples/LocalConfig.hs new file mode 100644 --- /dev/null +++ b/examples/LocalConfig.hs @@ -0,0 +1,17 @@ +module LocalConfig where +import Config +import System.Process ( readProcess ) +import qualified Data.Text as T + +getConfig :: IO Config +getConfig = do + -- This example command uses the OSX keychain tool + let cmd = words "pass ldap" + pass <- takeWhile (/='\n') <$> readProcess (head cmd) (tail cmd) "" + return $ Config + { configUsername = T.pack "USERNAME" + , configHostname = T.pack "mattermost.example.com" + , configTeam = T.pack "TEAMNAME" + , configPort = 443 -- currently we only support HTTPS + , configPassword = T.pack pass + } diff --git a/examples/MakePost.hs b/examples/MakePost.hs new file mode 100644 --- /dev/null +++ b/examples/MakePost.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +-- Note: See LocalConfig.hs to configure example for your server +module Main (main) where +import Text.Read ( readMaybe ) +import Text.Printf ( printf ) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Text.Show.Pretty ( pPrint ) +import Network.Connection +import System.Process ( readProcess ) +import System.Exit ( exitFailure + , exitWith + , ExitCode(..) ) +import Data.Foldable +import Control.Monad ( when, join ) + +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) + +import Network.Mattermost +import Network.Mattermost.Util + +import Config +import LocalConfig -- You will need to define a function: + -- getConfig :: IO Config + -- See Config.hs + + +data Options + = Options + { optChannel :: T.Text + , optVerbose :: Bool + , optMessage :: T.Text + } deriving (Read, Show) + +defaultOptions :: Options +defaultOptions = Options + { optChannel = "town-square" + , optVerbose = False + , optMessage = "" + } + +options :: [ OptDescr (Options -> IO Options) ] +options = + [ Option "c" ["channel"] + (ReqArg + (\arg opt -> return opt { optChannel = T.pack arg }) + "CHANNEL") + "Channel to fetch posts from" + , Option "v" ["verbose"] + (NoArg + (\opt -> return opt { optVerbose = True })) + "Enable verbose output" + , Option "m" ["message"] + (ReqArg + (\arg opt -> return opt { optMessage = T.pack arg }) + "MESSAGE") + "message to send" + , Option "h" ["help"] + (NoArg + (\_ -> do + prg <- getProgName + putStrLn (usageInfo prg options) + exitWith ExitSuccess)) + "Show help" + ] + +main :: IO () +main = do + args <- getArgs + let (actions, nonOptions, errors) = getOpt RequireOrder options args + 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 + } + + (session, mmUser) <- join (hoistE <$> mmLogin cd login) + when (optVerbose opts) $ do + putStrLn "Authenticated as:" + pPrint mmUser + + i <- mmGetInitialLoad session + when (optVerbose opts) $ do + pPrint i + forM_ (initialLoadTeams i) $ \t -> do + when (teamName t == configTeam config) $ do + userMap <- mmGetProfiles session (getId t) 0 10000 + when (optVerbose opts) $ do + pPrint userMap + chans <- mmGetChannels session (getId t) + forM_ chans $ \chan -> do + when (optVerbose opts) $ do + pPrint chan + when (channelName chan == optChannel opts) $ do + when (not (T.null (optMessage opts))) $ do + pendingPost <- mkPendingPost (optMessage opts) + (getId mmUser) + (getId chan) + post <- mmPost session (getId t) pendingPost + when (optVerbose opts) (pPrint post) diff --git a/examples/ShowRawEvents.hs b/examples/ShowRawEvents.hs new file mode 100644 --- /dev/null +++ b/examples/ShowRawEvents.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main(main) where + +import Control.Exception as E +import Control.Concurrent ( myThreadId ) +import Control.Monad ( when, join, forever ) +import Data.Bits (xor) +import Data.Char (ord) +import Data.Word (Word8) +import Data.List ( sort, isPrefixOf ) +import qualified Data.Text as T +import qualified Data.HashMap.Strict as HM +import Network.Connection +import Text.Read ( readMaybe ) +import Text.Show.Pretty ( pPrint ) + +import System.Console.GetOpt +import System.Environment ( getArgs, getProgName ) +import System.Exit ( exitFailure + , exitWith + , ExitCode(..) ) + +import Network.Mattermost +import Network.Mattermost.Util +import Network.Mattermost.WebSocket +import Network.Mattermost.WebSocket.Types + +import Config +import LocalConfig -- You will need to define a function: + -- getConfig :: IO Config + -- See Config.hs + +data Options + = Options + { optVerbose :: Bool + } deriving (Read, Show) + +defaultOptions :: Options +defaultOptions = Options + { optVerbose = False + } + +options :: [ OptDescr (Options -> IO Options) ] +options = + [ Option "v" ["verbose"] + (NoArg + (\opt -> return opt { optVerbose = True })) + "Enable verbose output" + , Option "h" ["help"] + (NoArg + (\_ -> do + prg <- getProgName + putStrLn (usageInfo prg options) + exitWith ExitSuccess)) + "Show help" + ] + +main :: IO () +main = do + args <- getArgs + let (actions, nonOptions, errors) = getOpt RequireOrder options args + 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 + } + + (session, mmUser) <- join (hoistE <$> mmLogin cd login) + when (optVerbose opts) $ do + putStrLn "Authenticated as:" + pPrint mmUser + let myId = getId mmUser + + mmWithWebSocket session printEvent checkForExit + +printEvent :: WebsocketEvent -> IO () +printEvent e = pPrint e + +checkForExit :: MMWebSocket -> IO () +checkForExit ws = do + _ <- getLine + return () diff --git a/mattermost-api.cabal b/mattermost-api.cabal new file mode 100644 --- /dev/null +++ b/mattermost-api.cabal @@ -0,0 +1,188 @@ +name: mattermost-api +version: 30802.1.0 +synopsis: Client API for MatterMost chat system +description: Client API for MatterMost chat system +license: BSD3 +license-file: LICENSE +author: Jason Dagit +maintainer: dagitj@gmail.com +copyright: 2016-2017 Jason Dagit, Getty Ritter, Jonathan Daugherty +category: Web +build-type: Simple +extra-doc-files: README.md, + CHANGELOG.md +cabal-version: >=1.10 +tested-with: GHC == 7.10.3, GHC == 8.0.1 +source-repository head + type: git + location: https://github.com/matterhorn-chat/mattermost-api.git + +flag build-examples + description: Build example applications + default: False + +library + exposed-modules: Network.Mattermost + Network.Mattermost.Exceptions + Network.Mattermost.Lenses + Network.Mattermost.Logging + Network.Mattermost.Util + Network.Mattermost.WebSocket + Network.Mattermost.WebSocket.Types + Network.Mattermost.Version + Network.Mattermost.Types + Network.Mattermost.Types.Base + Network.Mattermost.Types.Internal + other-modules: Network.Mattermost.TH + Paths_mattermost_api + -- other-extensions: + build-depends: base >=4.4 && <5 + , websockets >= 0.11.0.0 + , stm + , aeson >= 1.0.0.0 + , connection + -- The next two constraints are required to avoid a + -- dependency on 'foundation' + , memory <0.14.3 + , cryptonite <0.23 + , bytestring + , process + , HTTP + , network-uri + , text + , time + , unordered-containers + , hashable + , containers + , gitrev + , template-haskell + , microlens + , microlens-th + -- Only here to make debugging easier + , pretty-show + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable mm-get-teams + if !flag(build-examples) + buildable: False + default-language: Haskell2010 + main-is: GetTeams.hs + other-modules: Config + LocalConfig + hs-source-dirs: examples + build-depends: base + , mattermost-api + , aeson + , text + , connection + , process + , unordered-containers + , pretty-show + +executable mm-get-channels + if !flag(build-examples) + buildable: False + default-language: Haskell2010 + main-is: GetChannels.hs + other-modules: Config + LocalConfig + hs-source-dirs: examples + build-depends: base + , mattermost-api + , aeson + , text + , connection + , process + , unordered-containers + , pretty-show + +executable mm-get-posts + if !flag(build-examples) + buildable: False + default-language: Haskell2010 + main-is: GetPosts.hs + other-modules: Config + LocalConfig + hs-source-dirs: examples + build-depends: base + , mattermost-api + , aeson + , text + , connection + , process + , unordered-containers + , pretty-show + +executable mm-make-post + if !flag(build-examples) + buildable: False + default-language: Haskell2010 + main-is: MakePost.hs + other-modules: Config + LocalConfig + hs-source-dirs: examples + build-depends: base + , mattermost-api + , aeson + , text + , connection + , process + , unordered-containers + , pretty-show + +executable mm-get-websocket-connection + if !flag(build-examples) + buildable: False + default-language: Haskell2010 + main-is: GetWebsocketConnection.hs + other-modules: Config + LocalConfig + hs-source-dirs: examples + build-depends: base + , mattermost-api + , aeson + , text + , connection + , process + , unordered-containers + , pretty-show + +executable mm-show-raw-events + if !flag(build-examples) + buildable: False + default-language: Haskell2010 + main-is: ShowRawEvents.hs + other-modules: Config + LocalConfig + hs-source-dirs: examples + build-depends: base + , mattermost-api + , aeson + , text + , connection + , process + , unordered-containers + , pretty-show + +test-suite test-mm-api + type: exitcode-stdio-1.0 + ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + other-modules: Tests.Util + Tests.Types + build-depends: base + , mtl + , stm + , mattermost-api + , tasty + , tasty-hunit + , HUnit + , text + , pretty-show + , unordered-containers + , containers + , aeson diff --git a/src/Network/Mattermost.hs b/src/Network/Mattermost.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost.hs @@ -0,0 +1,854 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.Mattermost +( -- * Types + -- ** 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(..) +, Hostname +, Port +, ConnectionData +, Session +, Id(..) +, User(..) +, UserId(..) +, InitialLoad(..) +, Team(..) +, TeamMember(..) +, Type(..) +, TeamId(..) +, TeamsCreate(..) +, Channel(..) +, ChannelWithData(..) +, ChannelData(..) +, ChannelId(..) +, Channels +, MinChannel(..) +, UsersCreate(..) +, Post(..) +, PostProps(..) +, PendingPost(..) +, PostId(..) +, FileId(..) +, FileInfo(..) +, Reaction(..) +, urlForFile +, Posts(..) +, MinCommand(..) +, CommandResponse(..) +, CommandResponseType(..) +-- ** Log-related types +, Logger +, LogEvent(..) +, LogEventType(..) +, withLogger +, noLogger +-- * Typeclasses +, HasId(..) +-- * HTTP API Functions +, mkConnectionData +, initConnectionData +, initConnectionDataInsecure +, mmLogin +, mmCreateDirect +, mmCreateChannel +, mmCreateTeam +, mmDeleteChannel +, mmLeaveChannel +, mmJoinChannel +, mmGetTeams +, mmGetChannels +, mmGetMoreChannels +, mmGetChannel +, mmViewChannel +, mmDeletePost +, mmGetPost +, mmGetPosts +, mmGetPostsSince +, mmGetPostsBefore +, mmGetPostsAfter +, mmGetReactionsForPost +, mmGetFileInfo +, mmGetFile +, mmGetUser +, mmGetUsers +, mmGetTeamMembers +, mmGetChannelMembers +, mmGetProfilesForDMList +, mmGetMe +, mmGetProfiles +, mmGetStatuses +, mmGetInitialLoad +, mmSaveConfig +, mmSetChannelHeader +, mmChannelAddUser +, mmTeamAddUser +, mmUsersCreate +, mmUsersCreateWithSession +, mmPost +, mmUpdatePost +, mmExecute +, mmGetConfig +, mkPendingPost +, idString +, hoistE +, noteE +, assertE +) where + +import Control.Exception (throwIO) +import Control.Monad (when) +import Data.Monoid ((<>)) +import Text.Printf ( printf ) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Time.Clock ( UTCTime ) +import Network.Connection ( Connection + , connectionGetLine + , connectionPut + , connectionClose ) +import Network.HTTP.Headers ( HeaderName(..) + , mkHeader + , lookupHeader ) +import Network.HTTP.Base ( Request(..) + , RequestMethod(..) + , defaultUserAgent + , Response_String + , Response(..) ) +import Network.Stream as NS ( Stream(..) ) +import Network.URI ( URI, parseRelativeReference ) +import Network.HTTP.Stream ( simpleHTTP_ ) +import Data.HashMap.Strict ( HashMap ) +import qualified Data.HashMap.Strict as HM +import Data.Aeson ( Value(..) + , ToJSON(..) + , FromJSON + , object + , (.=) + , encode + , eitherDecode + ) +import Data.Maybe ( maybeToList ) +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import Control.Arrow ( left ) + +import Network.Mattermost.Exceptions +import Network.Mattermost.Util +import Network.Mattermost.Types.Base +import Network.Mattermost.Types.Internal +import Network.Mattermost.Types + +maxLineLength :: Int +maxLineLength = 2^(16::Int) + +-- | This instance allows us to use 'simpleHTTP' from 'Network.HTTP.Stream' with +-- connections from the 'connection' package. +instance Stream Connection where + readLine con = Right . B.unpack . dropTrailingChar <$> connectionGetLine maxLineLength con + readBlock con n = Right . B.unpack <$> connectionGetExact con n + writeBlock con block = Right <$> connectionPut con (B.pack block) + close con = connectionClose con + closeOnEnd _ _ = return () + + +-- MM utility functions + +-- | Parse a path, failing if we cannot. +mmPath :: String -> IO URI +mmPath str = + noteE (parseRelativeReference str) + (URIParseException ("mmPath: " ++ str)) + +-- | Parse the JSON body out of a request, failing if it isn't an +-- 'application/json' response, or if the parsing failed +mmGetJSONBody :: FromJSON t => String -> Response_String -> IO (Value, t) +mmGetJSONBody label rsp = do + contentType <- mmGetHeader rsp HdrContentType + assertE (contentType ~= "application/json") + (ContentTypeException + ("mmGetJSONBody: " ++ label ++ ": " ++ + "Expected content type 'application/json'" ++ + " found " ++ contentType)) + + let value = left (\s -> JSONDecodeException ("mmGetJSONBody: " ++ label ++ ": " ++ s) + (rspBody rsp)) + (eitherDecode (BL.pack (rspBody rsp))) + let rawVal = left (\s -> JSONDecodeException ("mmGetJSONBody: " ++ label ++ ": " ++ s) + (rspBody rsp)) + (eitherDecode (BL.pack (rspBody rsp))) + hoistE $ do + x <- rawVal + y <- value + return (x, y) + +-- | Grab a header from the response, failing if it isn't present +mmGetHeader :: Response_String -> HeaderName -> IO String +mmGetHeader rsp hdr = + noteE (lookupHeader hdr (rspHeaders rsp)) + (HeaderNotFoundException ("mmGetHeader: " ++ show hdr)) + +-- API calls + +-- | We should really only need this function to get an auth token. +-- We provide it in a fairly generic form in case we need ever need it +-- but it could be inlined into mmLogin. +mmUnauthenticatedHTTPPost :: ToJSON t => ConnectionData -> URI -> t -> IO Response_String +mmUnauthenticatedHTTPPost cd path json = do + rsp <- withConnection cd $ \con -> do + let content = BL.toStrict (encode json) + contentLength = B.length content + request = Request + { rqURI = path + , rqMethod = POST + , rqHeaders = [ mkHeader HdrHost (T.unpack $ cdHostname cd) + , mkHeader HdrUserAgent defaultUserAgent + , mkHeader HdrContentType "application/json" + , mkHeader HdrContentLength (show contentLength) + ] ++ autoCloseToHeader (cdAutoClose cd) + , rqBody = B.unpack content + } + simpleHTTP_ con request + hoistE $ left ConnectionException rsp + +-- | Fire off a login attempt. Note: We get back more than just the auth token. +-- We also get all the server-side configuration data for the user. +-- +-- route: @\/api\/v3\/users\/login@ +mmLogin :: ConnectionData -> Login -> IO (Either LoginFailureException (Session, User)) +mmLogin cd login = do + let rawPath = "/api/v3/users/login" + path <- mmPath rawPath + runLogger cd "mmLogin" $ + HttpRequest GET rawPath (Just (toJSON login)) + rsp <- mmUnauthenticatedHTTPPost cd path login + if (rspCode rsp /= (2,0,0)) + then return (Left (LoginFailureException (show (rspCode rsp)))) + else do + token <- mmGetHeader rsp (HdrCustom "Token") + (raw, value) <- mmGetJSONBody "User" rsp + runLogger cd "mmLogin" $ + HttpResponse 200 rawPath (Just raw) + return (Right (Session cd (Token token), value)) + +-- | Fire off a login attempt. Note: We get back more than just the auth token. +-- We also get all the server-side configuration data for the user. +-- +-- route: @\/api\/v3\/users\/initial_load@ +mmGetInitialLoad :: Session -> IO InitialLoad +mmGetInitialLoad sess = + mmDoRequest sess "mmGetInitialLoad" "/api/v3/users/initial_load" + +-- | Requires an authenticated user. Returns the full list of teams. +-- +-- route: @\/api\/v3\/teams\/all@ +mmGetTeams :: Session -> IO (HashMap TeamId Team) +mmGetTeams sess = + mmDoRequest sess "mmGetTeams" "/api/v3/teams/all" + +-- | +-- route: @\/api\/v3\/teams\/create@ +mmCreateTeam :: Session -> TeamsCreate -> IO Team +mmCreateTeam sess payload = do + let path = "/api/v3/teams/create" + uri <- mmPath path + runLoggerS sess "mmCreateTeam" $ + HttpRequest POST path (Just (toJSON payload)) + rsp <- mmPOST sess uri payload + (val, r) <- mmGetJSONBody "Team" rsp + runLoggerS sess "mmCreateTeam" $ + HttpResponse 200 path (Just val) + return r + +-- | Requires an authenticated user. Returns the full list of channels +-- for a given team of which the user is a member +-- +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/@ +mmGetChannels :: Session -> TeamId -> IO Channels +mmGetChannels sess teamid = mmDoRequest sess "mmGetChannels" $ + printf "/api/v3/teams/%s/channels/" (idString teamid) + +-- | Requires an authenticated user. Returns the channels for a team of +-- which the user is not already a member +-- +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/more\/{offset}\/{limit}@ +mmGetMoreChannels :: Session -> TeamId -> Int -> Int -> IO Channels +mmGetMoreChannels sess teamid offset limit = + mmDoRequest sess "mmGetMoreChannels" $ + printf "/api/v3/teams/%s/channels/more/%d/%d" + (idString teamid) + offset + limit + +-- | Requires an authenticated user. Returns the details of a +-- specific channel. +-- +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}@ +mmGetChannel :: Session + -> TeamId + -> ChannelId + -> IO ChannelWithData +mmGetChannel sess teamid chanid = mmWithRequest sess "mmGetChannel" + (printf "/api/v3/teams/%s/channels/%s/" + (idString teamid) + (idString chanid)) + return + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/view@ +mmViewChannel :: Session + -> TeamId + -> ChannelId -- ^ channel to view + -> Maybe ChannelId -- ^ previous channel + -> IO () +mmViewChannel sess teamid chanid previd = do + let path = printf "/api/v3/teams/%s/channels/view" + (idString teamid) + prev = maybeToList (("prev_channel_id" :: T.Text,) <$> previd) + payload = HM.fromList $ [("channel_id" :: T.Text, chanid)] ++ prev + uri <- mmPath path + runLoggerS sess "mmViewChannel" $ + HttpRequest POST path (Just (toJSON payload)) + _ <- mmPOST sess uri payload + runLoggerS sess "mmViewChannel" $ + HttpResponse 200 path Nothing + return () + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/join@ +mmJoinChannel :: Session + -> TeamId + -> ChannelId + -> IO () +mmJoinChannel sess teamid chanid = do + let path = printf "/api/v3/teams/%s/channels/%s/join" + (idString teamid) + (idString chanid) + uri <- mmPath path + runLoggerS sess "mmJoinChannel" $ + HttpRequest POST path Nothing + rsp <- mmPOST sess uri (""::T.Text) + (val, (_::Channel)) <- mmGetJSONBody "Channel" rsp + runLoggerS sess "mmJoinChannel" $ + HttpResponse 200 path (Just val) + return () + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/leave@ +mmLeaveChannel :: Session + -> TeamId + -> ChannelId + -> IO () +mmLeaveChannel sess teamid chanid = do + let path = printf "/api/v3/teams/%s/channels/%s/leave" + (idString teamid) + (idString chanid) + payload = HM.fromList [("id" :: T.Text, chanid)] + uri <- mmPath path + runLoggerS sess "mmLeaveChannel" $ + HttpRequest POST path (Just (toJSON payload)) + rsp <- mmPOST sess uri payload + (val, (_::HM.HashMap T.Text ChannelId)) <- mmGetJSONBody "Channel name/ID map" rsp + runLoggerS sess "mmCreateDirect" $ + HttpResponse 200 path (Just val) + return () + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/page\/{offset}\/{limit}@ +mmGetPosts :: Session + -> TeamId + -> ChannelId + -> Int -- offset in the backlog, 0 is most recent + -> Int -- try to fetch this many + -> IO Posts +mmGetPosts sess teamid chanid offset limit = + mmDoRequest sess "mmGetPosts" $ + printf "/api/v3/teams/%s/channels/%s/posts/page/%d/%d" + (idString teamid) + (idString chanid) + offset + limit + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/since\/{utc_time}@ +mmGetPostsSince :: Session + -> TeamId + -> ChannelId + -> UTCTime + -> IO Posts +mmGetPostsSince sess teamid chanid since = + mmDoRequest sess "mmGetPostsSince" $ + printf "/api/v3/teams/%s/channels/%s/posts/since/%d" + (idString teamid) + (idString chanid) + (utcTimeToMilliseconds since :: Int) + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/{post_id}\/get@ +mmGetPost :: Session + -> TeamId + -> ChannelId + -> PostId + -> IO Posts +mmGetPost sess teamid chanid postid = do + let path = printf "/api/v3/teams/%s/channels/%s/posts/%s/get" + (idString teamid) + (idString chanid) + (idString postid) + uri <- mmPath path + rsp <- mmRequest sess uri + (raw, json) <- mmGetJSONBody "Posts" rsp + runLoggerS sess "mmGetPost" $ + HttpResponse 200 path (Just raw) + return json + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/{post_id}\/after\/{offset}\/{limit}@ +mmGetPostsAfter :: Session + -> TeamId + -> ChannelId + -> PostId + -> Int -- offset in the backlog, 0 is most recent + -> Int -- try to fetch this many + -> IO Posts +mmGetPostsAfter sess teamid chanid postid offset limit = + mmDoRequest sess "mmGetPosts" $ + printf "/api/v3/teams/%s/channels/%s/posts/%s/after/%d/%d" + (idString teamid) + (idString chanid) + (idString postid) + offset + limit + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/{post_id}\/before\/{offset}\/{limit}@ +mmGetPostsBefore :: Session + -> TeamId + -> ChannelId + -> PostId + -> Int -- offset in the backlog, 0 is most recent + -> Int -- try to fetch this many + -> IO Posts +mmGetPostsBefore sess teamid chanid postid offset limit = + mmDoRequest sess "mmGetPosts" $ + printf "/api/v3/teams/%s/channels/%s/posts/%s/before/%d/%d" + (idString teamid) + (idString chanid) + (idString postid) + offset + limit + +-- | +-- route: @\/api\/v3\/files\/{file_id}\/get_info@ +mmGetFileInfo :: Session + -> FileId + -> IO FileInfo +mmGetFileInfo sess fileId = + mmDoRequest sess "mmGetFileInfo" $ + printf "/api/v3/files/%s/get_info" (idString fileId) + +-- | +-- route: @\/api\/v4\/files\/{file_id}@ +mmGetFile :: Session + -> FileId + -> IO B.ByteString +mmGetFile sess@(Session cd _) fileId = do + let path = printf "/api/v4/files/%s" (idString fileId) + uri <- mmPath path + runLogger cd "mmGetFile" $ + HttpRequest GET path Nothing + rsp <- mmRequest sess uri + return (B.pack (rspBody rsp)) + +-- | +-- route: @\/api\/v3\/users\/{user_id}\/get@ +mmGetUser :: Session -> UserId -> IO User +mmGetUser sess userid = mmDoRequest sess "mmGetUser" $ + printf "/api/v3/users/%s/get" (idString userid) + +-- | +-- route: @\/api\/v3\/users\/{offset}\/{limit}@ +mmGetUsers :: Session -> Int -> Int -> IO (HashMap UserId User) +mmGetUsers sess offset limit = + mmDoRequest sess "mmGetUsers" $ + printf "/api/v3/users/%d/%d" offset limit + +-- | +-- route: @\/api\/v3\/teams\/members\/{team_id}@ +mmGetTeamMembers :: Session -> TeamId -> IO (Seq.Seq TeamMember) +mmGetTeamMembers sess teamid = mmDoRequest sess "mmGetTeamMembers" $ + printf "/api/v3/teams/members/%s" (idString teamid) + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/users\/{offset}\/{limit}@ +mmGetChannelMembers :: Session + -> TeamId + -> ChannelId + -> Int + -> Int + -> IO (HashMap UserId User) +mmGetChannelMembers sess teamid chanid offset limit = mmDoRequest sess "mmGetChannelMembers" $ + printf "/api/v3/teams/%s/channels/%s/users/%d/%d" + (idString teamid) + (idString chanid) + offset + limit + +-- | +-- route: @\/api\/v3\/users\/profiles_for_dm_list\/{team_id}@ +mmGetProfilesForDMList :: Session -> TeamId + -> IO (HashMap UserId User) +mmGetProfilesForDMList sess teamid = + mmDoRequest sess "mmGetProfilesForDMList" $ + printf "/api/v3/users/profiles_for_dm_list/%s" (idString teamid) + +-- | +-- route: @\/api\/v3\/users\/me@ +mmGetMe :: Session -> IO User +mmGetMe sess = mmDoRequest sess "mmGetMe" "/api/v3/users/me" + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/users\/{offset}\/{limit}@ +mmGetProfiles :: Session + -> TeamId + -> Int + -> Int + -> IO (HashMap UserId User) +mmGetProfiles sess teamid offset limit = mmDoRequest sess "mmGetProfiles" $ + printf "/api/v3/teams/%s/users/%d/%d" + (idString teamid) + offset + limit + +-- | +-- route: @\/api\/v3\/users\/status@ +mmGetStatuses :: Session -> IO (HashMap UserId T.Text) +mmGetStatuses sess = mmDoRequest sess "mmGetStatuses" $ + printf "/api/v3/users/status" + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/create_direct@ +mmCreateDirect :: Session -> TeamId -> UserId -> IO Channel +mmCreateDirect sess teamid userid = do + let path = printf "/api/v3/teams/%s/channels/create_direct" (idString teamid) + payload = HM.fromList [("user_id" :: T.Text, userid)] + uri <- mmPath path + runLoggerS sess "mmCreateDirect" $ + HttpRequest POST path (Just (toJSON payload)) + rsp <- mmPOST sess uri payload + (val, r) <- mmGetJSONBody "Channel" rsp + runLoggerS sess "mmCreateDirect" $ + HttpResponse 200 path (Just val) + return r + +-- { name, display_name, purpose, header } +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/create@ +mmCreateChannel :: Session -> TeamId -> MinChannel -> IO Channel +mmCreateChannel sess teamid payload = do + let path = printf "/api/v3/teams/%s/channels/create" (idString teamid) + uri <- mmPath path + runLoggerS sess "mmCreateChannel" $ + HttpRequest POST path (Just (toJSON payload)) + rsp <- mmPOST sess uri payload + (val, r) <- mmGetJSONBody "Channel" rsp + runLoggerS sess "mmCreateChannel" $ + HttpResponse 200 path (Just val) + return r + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/delete@ +mmDeleteChannel :: Session -> TeamId -> ChannelId -> IO () +mmDeleteChannel sess teamid chanid = do + let path = printf "/api/v3/teams/%s/channels/%s/delete" + (idString teamid) (idString chanid) + uri <- mmPath path + runLoggerS sess "mmDeleteChannel" $ + HttpRequest POST path Nothing + _ <- mmRawPOST sess uri "" + runLoggerS sess "mmDeleteChannel" $ + HttpResponse 200 path Nothing + return () + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/{post_id}\/delete@ +mmDeletePost :: Session + -> TeamId + -> ChannelId + -> PostId + -> IO () +mmDeletePost sess teamid chanid postid = do + let path = printf "/api/v3/teams/%s/channels/%s/posts/%s/delete" + (idString teamid) + (idString chanid) + (idString postid) + uri <- mmPath path + runLoggerS sess "mmDeletePost" $ + HttpRequest POST path Nothing + rsp <- mmPOST sess uri ([]::[String]) + (_, _::Value) <- mmGetJSONBody "Post" rsp + runLoggerS sess "mmDeletePost" $ + HttpResponse 200 path Nothing + return () + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/update@ +mmUpdatePost :: Session + -> TeamId + -> Post + -> IO Post +mmUpdatePost sess teamid post = do + let chanid = postChannelId post + path = printf "/api/v3/teams/%s/channels/%s/posts/update" + (idString teamid) + (idString chanid) + uri <- mmPath path + runLoggerS sess "mmUpdatePost" $ + HttpRequest POST path (Just (toJSON post)) + rsp <- mmPOST sess uri post + (val, r) <- mmGetJSONBody "Post" rsp + runLoggerS sess "mmUpdatePost" $ + HttpResponse 200 path (Just (val)) + return r + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/create@ +mmPost :: Session + -> TeamId + -> PendingPost + -> IO Post +mmPost sess teamid post = do + let chanid = pendingPostChannelId post + path = printf "/api/v3/teams/%s/channels/%s/posts/create" + (idString teamid) + (idString chanid) + uri <- mmPath path + runLoggerS sess "mmPost" $ + HttpRequest POST path (Just (toJSON post)) + rsp <- mmPOST sess uri post + (val, r) <- mmGetJSONBody "Post" rsp + runLoggerS sess "mmPost" $ + HttpResponse 200 path (Just (val)) + return r + +-- | Get the system configuration. Requires administrative permission. +-- +-- route: @\/api\/v3\/admin\/config@ +mmGetConfig :: Session + -> IO Value +mmGetConfig sess = + mmDoRequest sess "mmGetConfig" "/api/v3/admin/config" + +mmSaveConfig :: Session + -> Value + -> IO () +mmSaveConfig sess config = do + let path = "/api/v3/admin/save_config" + uri <- mmPath path + runLoggerS sess "mmSaveConfig" $ + HttpRequest POST path (Just config) + _ <- mmPOST sess uri config + runLoggerS sess "mmSaveConfig" $ + HttpResponse 200 path Nothing + return () + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/add@ +mmChannelAddUser :: Session + -> TeamId + -> ChannelId + -> UserId + -> IO ChannelData +mmChannelAddUser sess teamid chanId uId = do + let path = printf "/api/v3/teams/%s/channels/%s/add" + (idString teamid) + (idString chanId) + req = object ["user_id" .= uId] + uri <- mmPath path + runLoggerS sess "mmChannelAddUser" $ + HttpRequest POST path (Just req) + rsp <- mmPOST sess uri req + (val, r) <- mmGetJSONBody "ChannelData" rsp + runLoggerS sess "mmChannelAddUser" $ + HttpResponse 200 path (Just val) + return r + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/add_user_to_team@ +mmTeamAddUser :: Session + -> TeamId + -> UserId + -> IO () +mmTeamAddUser sess teamid uId = do + let path = printf "/api/v3/teams/%s/add_user_to_team" + (idString teamid) + req = object ["user_id" .= uId] + uri <- mmPath path + runLoggerS sess "mmTeamAddUser" $ + HttpRequest POST path (Just req) + _ <- mmPOST sess uri req + runLoggerS sess "mmTeamAddUSer" $ + HttpResponse 200 path Nothing + return () + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/commands\/execute@ +mmExecute :: Session + -> TeamId + -> MinCommand + -> IO CommandResponse +mmExecute sess teamid command = do + let path = printf "/api/v3/teams/%s/commands/execute" + (idString teamid) + uri <- mmPath path + runLoggerS sess "mmExecute" $ + HttpRequest POST path (Just (toJSON command)) + rsp <- mmPOST sess uri command + (val, r) <- mmGetJSONBody "Value" rsp + runLoggerS sess "mmExecute" $ + HttpResponse 200 path (Just (val)) + return r + +-- | +-- route: @\/api\/v3\/users\/create@ +mmUsersCreate :: ConnectionData + -> UsersCreate + -> IO User +mmUsersCreate cd usersCreate = do + let path = "/api/v3/users/create" + uri <- mmPath path + runLogger cd "mmUsersCreate" $ + HttpRequest POST path (Just (toJSON usersCreate)) + rsp <- mmUnauthenticatedHTTPPost cd uri usersCreate + (val, r) <- mmGetJSONBody "User" rsp + runLogger cd "mmUsersCreate" $ + HttpResponse 200 path (Just (val)) + return r + +-- | +-- route: @\/api\/v3\/users\/create@ +mmUsersCreateWithSession :: Session + -> UsersCreate + -> IO User +mmUsersCreateWithSession sess usersCreate = do + let path = "/api/v3/users/create" + uri <- mmPath path + runLoggerS sess "mmUsersCreateWithToken" $ + HttpRequest POST path (Just (toJSON usersCreate)) + rsp <- mmPOST sess uri usersCreate + (val, r) <- mmGetJSONBody "User" rsp + runLoggerS sess "mmUsersCreateWithToken" $ + HttpResponse 200 path (Just (val)) + return r + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/{channel_id}\/posts\/{post_id}\/reactions@ +mmGetReactionsForPost :: Session + -> TeamId + -> ChannelId + -> PostId + -> IO [Reaction] +mmGetReactionsForPost sess tId cId pId = do + let path = printf "/api/v3/teams/%s/channels/%s/posts/%s/reactions" + (idString tId) + (idString cId) + (idString pId) + mmDoRequest sess "mmGetReactionsForPost" path + +-- | This is for making a generic authenticated request. +mmRequest :: Session -> URI -> IO Response_String +mmRequest (Session cd token) path = do + rawRsp <- withConnection cd $ \con -> do + let request = Request + { rqURI = path + , rqMethod = GET + , rqHeaders = [ mkHeader HdrAuthorization ("Bearer " ++ getTokenString token) + , mkHeader HdrHost (T.unpack $ cdHostname cd) + , mkHeader HdrUserAgent defaultUserAgent + ] ++ autoCloseToHeader (cdAutoClose cd) + , rqBody = "" + } + simpleHTTP_ con request + rsp <- hoistE $ left ConnectionException rawRsp + assert200Response path rsp + return rsp + +-- This captures the most common pattern when making requests. +mmDoRequest :: FromJSON t + => Session + -> String + -> String + -> IO t +mmDoRequest sess fnname path = mmWithRequest sess fnname path return + +-- The slightly more general variant +mmWithRequest :: FromJSON t + => Session + -> String + -> String + -> (t -> IO a) + -> IO a +mmWithRequest sess@(Session cd _) fnname path action = do + uri <- mmPath path + runLogger cd fnname $ + HttpRequest GET path Nothing + rsp <- mmRequest sess uri + (raw,json) <- mmGetJSONBody fnname rsp + runLogger cd fnname $ + HttpResponse 200 path (Just raw) + action json + +mmPOST :: ToJSON t => Session -> URI -> t -> IO Response_String +mmPOST sess path json = + mmRawPOST sess path (BL.toStrict (encode json)) + +-- | +-- route: @\/api\/v3\/teams\/{team_id}\/channels\/update_header@ +mmSetChannelHeader :: Session -> TeamId -> ChannelId -> T.Text -> IO Channel +mmSetChannelHeader sess teamid chanid header = do + let path = printf "/api/v3/teams/%s/channels/update_header" + (idString teamid) + uri <- mmPath path + let req = SetChannelHeader chanid header + runLoggerS sess "mmSetChannelHeader" $ + HttpRequest POST path (Just (toJSON req)) + rsp <- mmPOST sess uri req + (_, r) <- mmGetJSONBody "Channel" rsp + return r + +mmRawPOST :: Session -> URI -> B.ByteString -> IO Response_String +mmRawPOST (Session cd token) path content = do + rawRsp <- withConnection cd $ \con -> do + let contentLength = B.length content + request = Request + { rqURI = path + , rqMethod = POST + , rqHeaders = [ mkHeader HdrAuthorization ("Bearer " ++ getTokenString token) + , mkHeader HdrHost (T.unpack $ cdHostname cd) + , mkHeader HdrUserAgent defaultUserAgent + , mkHeader HdrContentType "application/json" + , mkHeader HdrContentLength (show contentLength) + ] ++ autoCloseToHeader (cdAutoClose cd) + , rqBody = B.unpack content + } + simpleHTTP_ con request + rsp <- hoistE $ left ConnectionException rawRsp + assert200Response path rsp + return rsp + +assert200Response :: URI -> Response_String -> IO () +assert200Response path rsp = + when (rspCode rsp /= (2,0,0)) $ + let httpExc = HTTPResponseException $ "mmRequest: expected 200 response, got " <> + (show $ rspCode rsp) + in case eitherDecode $ BL.pack $ rspBody rsp of + Right (Object o) -> + case HM.lookup "message" o of + Just (String msg) -> + let newMsg = (T.pack $ "Error requesting " <> show path <> ": ") <> msg + in throwIO $ MattermostServerError newMsg + _ -> throwIO $ httpExc + _ -> throwIO $ httpExc diff --git a/src/Network/Mattermost/Exceptions.hs b/src/Network/Mattermost/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/Exceptions.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Network.Mattermost.Exceptions +( -- Exception Types + LoginFailureException(..) +, URIParseException(..) +, ContentTypeException(..) +, JSONDecodeException(..) +, HeaderNotFoundException(..) +, HTTPResponseException(..) +, ConnectionException(..) +, MattermostServerError(..) +) where + +import qualified Data.Text as T +import Data.Typeable ( Typeable ) +import Control.Exception ( Exception(..) ) +import Network.Stream ( ConnError ) + +-- + +-- Unlike many exceptions in this file, this is a mattermost specific exception +data LoginFailureException = LoginFailureException String + deriving (Show, Typeable) + +instance Exception LoginFailureException + +-- + +data URIParseException = URIParseException String + deriving (Show, Typeable) + +instance Exception URIParseException + +-- + +data ContentTypeException = ContentTypeException String + deriving (Show, Typeable) + +instance Exception ContentTypeException + +-- + +data JSONDecodeException + = JSONDecodeException + { jsonDecodeExceptionMsg :: String + , jsonDecodeExceptionJSON :: String + } deriving (Show, Typeable) + +instance Exception JSONDecodeException + +-- + +data HeaderNotFoundException = HeaderNotFoundException String + deriving (Show, Typeable) + +instance Exception HeaderNotFoundException + +-- + +data MattermostServerError = MattermostServerError T.Text + deriving (Show, Typeable) + +instance Exception MattermostServerError + +-- + +data HTTPResponseException = HTTPResponseException String + deriving (Show, Typeable) + +instance Exception HTTPResponseException + +-- + +data ConnectionException = ConnectionException ConnError + deriving (Show, Typeable) + +instance Exception ConnectionException diff --git a/src/Network/Mattermost/Lenses.hs b/src/Network/Mattermost/Lenses.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/Lenses.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Network.Mattermost.Lenses where + +import Network.Mattermost.Types.Internal +import Network.Mattermost.Types +import Network.Mattermost.WebSocket.Types +import Network.Mattermost.TH + +-- | This is the same type alias as in @Control.Lens@, and so can be used +-- anywhere lenses are needed. +type Lens' a b = forall f. Functor f => (b -> f b) -> (a -> f a) + +-- * 'ConnectionData' lenses +suffixLenses ''ConnectionData + +-- * 'Login' lenses +suffixLenses ''Login + +-- * 'Team' lenses +suffixLenses ''Team + +-- * 'TeamMember' lenses +suffixLenses ''TeamMember + +-- * 'NotifyProps' lenses +suffixLenses ''NotifyProps + +-- * 'Channel' lenses +suffixLenses ''Channel + +-- * 'ChannelData' lenses +suffixLenses ''ChannelData + +-- * 'User' lenses +suffixLenses ''User + +-- * 'Post' lenses +suffixLenses ''Post + +-- * 'PostProps' lenses +suffixLenses ''PostProps +suffixLenses ''PostPropAttachment + +-- * 'PendingPost' lenses +suffixLenses ''PendingPost + +-- * 'Posts' lenses +suffixLenses ''Posts + +-- * 'Reaction' lenses +suffixLenses ''Reaction + +-- * 'WebsocketEvent' lenses +suffixLenses ''WebsocketEvent + +-- * 'WEData' lenses +suffixLenses ''WEData + +-- * 'WEBroadcast' lenses +suffixLenses ''WEBroadcast + +-- * 'CommandResponse' lenses +suffixLenses ''CommandResponse +suffixLenses ''CommandResponseType diff --git a/src/Network/Mattermost/Logging.hs b/src/Network/Mattermost/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/Logging.hs @@ -0,0 +1,84 @@ +module Network.Mattermost.Logging +( -- * Logging-Related Types + Logger +, LogEvent(..) +, LogEventType(..) + -- * Basic Loggers +, mmLoggerInfo +, mmLoggerInfoFilter +, mmLoggerDebug +, mmLoggerDebugFilter + -- ** @stderr@ variants +, mmLoggerInfoErr +, mmLoggerInfoFilterErr +, mmLoggerDebugErr +, mmLoggerDebugFilterErr +) where + +import Data.Time.Clock (getCurrentTime) +import System.IO (Handle, hFlush, hPutStr, stderr) + +import Network.Mattermost.Types.Base + +-- | 'mmLoggerDebugFilter' is the same as 'mmLoggerDebug' but takes +-- a user-defined predicate that it uses to select which events to +-- log before writing them to the provided 'Handle' +mmLoggerDebugFilter :: (LogEvent -> Bool) -> Handle -> Logger +mmLoggerDebugFilter p h l + | p l = mmLoggerDebug h l + | otherwise = return () + +-- | 'mmLoggerDebug' prints the full data of every logging event to +-- the provided 'Handle'. +mmLoggerDebug :: Handle -> Logger +mmLoggerDebug h LogEvent { logFunction = f, logEventType = e } = do + now <- getCurrentTime + mapM_ (hPutStr h) + [ "[", show now, "] ", f, ": ", show e, "\n" ] + hFlush h + +-- | 'mmLoggerDebugErr' prints the full data of every logging event +-- to 'stderr'. +mmLoggerDebugErr :: Logger +mmLoggerDebugErr = mmLoggerDebug stderr + +-- | 'mmLoggerDebugFilterErr' takes a user-defined predicate that +-- it uses to select which events to log before logging them to +-- 'stderr'. +mmLoggerDebugFilterErr :: (LogEvent -> Bool) -> Logger +mmLoggerDebugFilterErr p l = mmLoggerDebugFilter p stderr l + + +-- | 'mmLoggerInfoFilter' is the same as 'mmLoggerInfo' but takes +-- a user-defined predicate that it uses to select which events to +-- log before writing them to the provided 'Handle' +mmLoggerInfoFilter :: (LogEvent -> Bool) -> Handle -> Logger +mmLoggerInfoFilter p h l + | p l = mmLoggerInfo h l + | otherwise = return () + +-- | 'mmLoggerInfo' prints which calls are happening and which +-- endpoints are being hit, but without the payloads. +mmLoggerInfo :: Handle -> Logger +mmLoggerInfo h LogEvent { logFunction = f, logEventType = e } = do + now <- getCurrentTime + mapM_ (hPutStr h) + [ "[", show now, "] ", f, ": ", info e, "\n" ] + hFlush h + where info (HttpRequest m s _) = show m ++ " " ++ s + info (HttpResponse n s _) = show n ++ " from " ++ s + info (WebSocketRequest _) = "websocket request" + info (WebSocketResponse _) = "websocket request" + info WebSocketPing = "websocket ping" + info WebSocketPong = "websocket pong" + +-- | 'mmLoggerInfoErr' prints request/response data without payloads +-- to 'stderr' +mmLoggerInfoErr :: Logger +mmLoggerInfoErr = mmLoggerInfo stderr + +-- | 'mmLoggerInfoFilterErr' takes a user-defined predicate that +-- it uses to select which events to log before logging them to +-- 'stderr'. +mmLoggerInfoFilterErr :: (LogEvent -> Bool) -> Logger +mmLoggerInfoFilterErr p l = mmLoggerInfoFilter p stderr l diff --git a/src/Network/Mattermost/TH.hs b/src/Network/Mattermost/TH.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/TH.hs @@ -0,0 +1,11 @@ +module Network.Mattermost.TH where + +import qualified Language.Haskell.TH.Syntax as TH +import qualified Language.Haskell.TH.Lib as TH + +import Lens.Micro ((&), (.~)) +import Lens.Micro.TH (DefName(..), makeLensesWith, lensRules, lensField) + +suffixLenses :: TH.Name -> TH.DecsQ +suffixLenses = makeLensesWith $ + lensRules & lensField .~ (\_ _ name -> [TopName $ TH.mkName $ TH.nameBase name ++ "L"]) diff --git a/src/Network/Mattermost/Types.hs b/src/Network/Mattermost/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/Types.hs @@ -0,0 +1,861 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Network.Mattermost.Types where + +import Control.Applicative +import Text.Printf ( printf ) +import Data.Hashable ( Hashable ) +import qualified Data.Aeson as A +import Data.Aeson ( (.:), (.=), (.:?), (.!=) ) +import Data.Aeson.Types ( ToJSONKey + , FromJSONKey + , FromJSON + , ToJSON + , Parser + , typeMismatch + ) +import qualified Data.HashMap.Strict as HM +import Data.Monoid ( (<>) ) +import Data.Ratio ( (%) ) +import Data.Sequence (Seq) +import qualified Data.Sequence as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock ( UTCTime, getCurrentTime ) +import Data.Time.Clock.POSIX ( posixSecondsToUTCTime + , utcTimeToPOSIXSeconds ) +import Network.Connection (ConnectionContext, initConnectionContext) +import Network.Mattermost.Types.Base +import Network.Mattermost.Types.Internal + +runLogger :: ConnectionData -> String -> LogEventType -> IO () +runLogger ConnectionData { cdLogger = Just l } n ev = + l (LogEvent n ev) +runLogger _ _ _ = return () + +runLoggerS :: Session -> String -> LogEventType -> IO () +runLoggerS (Session cd _) = runLogger cd + +maybeFail :: Parser a -> Parser (Maybe a) +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 + } + +-- | 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 + } + +initConnectionData :: Hostname -> Port -> IO ConnectionData +initConnectionData host port = do + ctx <- initConnectionContext + return (mkConnectionData host port ctx) + +initConnectionDataInsecure :: Hostname -> Port -> IO ConnectionData +initConnectionDataInsecure host port = do + ctx <- initConnectionContext + return (mkConnectionDataInsecure host port ctx) + +withLogger :: ConnectionData -> Logger -> ConnectionData +withLogger cd logger = cd { cdLogger = Just logger } + +noLogger :: ConnectionData -> ConnectionData +noLogger cd = cd { cdLogger = Nothing } + +data Session = Session + { sessConn :: ConnectionData + , sessTok :: Token + } + +mkSession :: ConnectionData -> Token -> Session +mkSession = Session + +-- + +data Login + = Login + { username :: Text + , password :: Text + } + +instance A.ToJSON Login where + toJSON l = A.object ["login_id" A..= username l + ,"password" A..= password l + ] + + +data SetChannelHeader = SetChannelHeader + { setChannelHeaderChanId :: ChannelId + , setChannelHeaderString :: Text + } + +instance A.ToJSON SetChannelHeader where + toJSON (SetChannelHeader cId p) = + A.object ["channel_id" A..= cId + ,"channel_header" A..= p + ] + +data Type = Ordinary + | Direct + | Private + | Group + | SystemHeaderChange + | Unknown Text + deriving (Read, Show, Ord, Eq) + +instance A.FromJSON Type where + parseJSON = A.withText "Type" $ \t -> + return $ if | t == "O" -> Ordinary + | t == "D" -> Direct + | t == "P" -> Private + | t == "G" -> Group + | t == "system_header_change" -> SystemHeaderChange + | otherwise -> Unknown t + +instance A.ToJSON Type where + toJSON Direct = A.toJSON ("D"::Text) + toJSON Ordinary = A.toJSON ("O"::Text) + toJSON Private = A.toJSON ("P"::Text) + toJSON SystemHeaderChange = A.toJSON ("system_header_change"::Text) + toJSON Group = A.toJSON ("G"::Text) + toJSON (Unknown t) = A.toJSON t + +-- + +-- For converting from type specific Id to generic Id +class IsId x where + toId :: x -> Id + fromId :: Id -> x + +class HasId x y | x -> y where + getId :: x -> y + +newtype Id = Id { unId :: Text } + deriving (Read, Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, FromJSONKey) + +idString :: IsId x => x -> Text +idString x = unId i + where i = toId x + +instance A.FromJSON Id where + parseJSON = A.withText "Id" $ \t -> + case T.null t of + False -> return $ Id t + True -> fail "Empty ID" + +instance IsId Id where + toId = id + fromId = id + +instance HasId Id Id where + getId = id + +-- + +newtype TeamId = TI { unTI :: Id } + deriving (Read, Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, FromJSONKey, FromJSON) + +instance IsId TeamId where + toId = unTI + fromId = TI + +data Team + = Team + { teamId :: TeamId + , teamCreateAt :: UTCTime + , teamUpdateAt :: UTCTime + , teamDeleteAt :: UTCTime + , teamDisplayName :: Text + , teamName :: Text + , teamEmail :: Text + , teamType :: Type + , teamCompanyName :: Text + , teamAllowedDomains :: Text + , teamInviteId :: Id + , teamAllowOpenInvite :: Bool + } + deriving (Read, Show, Eq, Ord) + +instance HasId Team TeamId where + getId = teamId + +instance A.FromJSON Team where + parseJSON = A.withObject "Team" $ \v -> do + teamId <- v .: "id" + teamCreateAt <- millisecondsToUTCTime <$> v .: "create_at" + teamUpdateAt <- millisecondsToUTCTime <$> v .: "update_at" + teamDeleteAt <- millisecondsToUTCTime <$> v .: "delete_at" + teamDisplayName <- v .: "display_name" + teamName <- v .: "name" + teamEmail <- v .: "email" + teamType <- v .: "type" + teamCompanyName <- v .: "company_name" + teamAllowedDomains <- v .: "allowed_domains" + teamInviteId <- v .: "invite_id" + teamAllowOpenInvite <- v .: "allow_open_invite" + return Team { .. } + +data TeamMember = TeamMember + { teamMemberUserId :: UserId + , teamMemberTeamId :: TeamId + , teamMemberRoles :: Text + } deriving (Read, Show, Eq, Ord) + +instance A.FromJSON TeamMember where + parseJSON = A.withObject "TeamMember" $ \v -> do + teamMemberUserId <- v .: "user_id" + teamMemberTeamId <- v .: "team_id" + teamMemberRoles <- v .: "roles" + return TeamMember { .. } + +-- + +data WithDefault a + = IsValue a + | Default + deriving (Read, Show, Eq, Ord) + +instance A.FromJSON t => A.FromJSON (WithDefault t) where + parseJSON (A.String "default") = return Default + parseJSON t = IsValue <$> A.parseJSON t + +instance Functor WithDefault where + fmap f (IsValue x) = IsValue (f x) + fmap _ Default = Default + +data NotifyOption + = NotifyOptionAll + | NotifyOptionMention + | NotifyOptionNone + deriving (Read, Show, Eq, Ord) + +instance A.FromJSON NotifyOption where + parseJSON (A.String "all") = return NotifyOptionAll + parseJSON (A.String "mention") = return NotifyOptionMention + parseJSON (A.String "none") = return NotifyOptionNone + parseJSON xs = fail ("Unknown NotifyOption value: " ++ show xs) + +data NotifyProps = NotifyProps + { notifyPropsMentionKeys :: [Text] + , notifyPropsEmail :: WithDefault Bool + , notifyPropsPush :: WithDefault NotifyOption + , notifyPropsDesktop :: WithDefault NotifyOption + , notifyPropsDesktopSound :: WithDefault Bool + , notifyPropsChannel :: WithDefault Bool + , notifyPropsFirstName :: WithDefault Bool + , notifyPropsMarkUnread :: WithDefault NotifyOption + } deriving (Eq, Show, Read, Ord) + +emptyNotifyProps :: NotifyProps +emptyNotifyProps = NotifyProps + { notifyPropsMentionKeys = [] + , notifyPropsEmail = IsValue False + , notifyPropsPush = IsValue NotifyOptionNone + , notifyPropsDesktop = IsValue NotifyOptionNone + , notifyPropsDesktopSound = IsValue False + , notifyPropsChannel = IsValue False + , notifyPropsFirstName = IsValue False + , notifyPropsMarkUnread = IsValue NotifyOptionNone + } + +newtype BoolString = BoolString { fromBoolString :: Bool } + +instance A.FromJSON BoolString where + parseJSON = A.withText "bool as string" $ \v -> + case v of + "true" -> return (BoolString True) + "false" -> return (BoolString False) + _ -> fail "Expected \"true\" or \"false\"" + +instance A.FromJSON NotifyProps where + parseJSON = A.withObject "NotifyProps" $ \v -> do + notifyPropsMentionKeys <- T.split (==',') <$> + (v .:? "mention_keys" .!= "") + notifyPropsEmail <- fmap fromBoolString <$> + (v .:? "email" .!= IsValue (BoolString True)) + notifyPropsPush <- v .:? "push" .!= IsValue NotifyOptionMention + notifyPropsDesktop <- v .:? "desktop" .!= IsValue NotifyOptionAll + notifyPropsDesktopSound <- fmap fromBoolString <$> + (v .:? "desktop_sound" .!= IsValue (BoolString True)) + notifyPropsChannel <- fmap fromBoolString <$> + (v .:? "channel" .!= IsValue (BoolString True)) + notifyPropsFirstName <- fmap fromBoolString <$> + (v .:? "first_name" .!= IsValue (BoolString False)) + notifyPropsMarkUnread <- v .:? "mark_unread" .!= IsValue NotifyOptionAll + return NotifyProps { .. } + +-- + +newtype ChannelId = CI { unCI :: Id } + deriving (Read, Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, FromJSONKey, FromJSON) + +instance IsId ChannelId where + toId = unCI + fromId = CI + +data Channel + = Channel + { channelId :: ChannelId + , channelCreateAt :: UTCTime + , channelUpdateAt :: UTCTime + , channelDeleteAt :: UTCTime + , channelTeamId :: Maybe TeamId + , channelType :: Type + , channelDisplayName :: Text + , channelName :: Text + , channelHeader :: Text + , channelPurpose :: Text + , channelLastPostAt :: UTCTime + , channelTotalMsgCount :: Int + , channelExtraUpdateAt :: UTCTime + , channelCreatorId :: Maybe UserId + } deriving (Read, Show, Eq, Ord) + +instance HasId Channel ChannelId where + getId = channelId + +instance A.FromJSON Channel where + parseJSON = A.withObject "Channel" $ \v -> do + channelId <- v .: "id" + channelCreateAt <- millisecondsToUTCTime <$> v .: "create_at" + channelUpdateAt <- millisecondsToUTCTime <$> v .: "update_at" + channelDeleteAt <- millisecondsToUTCTime <$> v .: "delete_at" + channelTeamId <- maybeFail (v .: "team_id") + channelType <- v .: "type" + channelDisplayName <- v .: "display_name" + channelName <- v .: "name" + channelHeader <- v .: "header" + channelPurpose <- v .: "purpose" + channelLastPostAt <- millisecondsToUTCTime <$> v .: "last_post_at" + channelTotalMsgCount <- v .: "total_msg_count" + channelExtraUpdateAt <- millisecondsToUTCTime <$> v .: "extra_update_at" + channelCreatorId <- maybeFail (v .: "creator_id") + return Channel { .. } + +-- This type only exists so that we can strip off the +-- outer most layer in mmGetChannel. See the +-- FromJSON instance. +newtype SingleChannel = SC Channel + deriving (Read, Show, Eq, Ord) + +instance A.FromJSON SingleChannel where + parseJSON = A.withObject "SingleChannel" $ \v -> do + channel <- v .: "channel" + return (SC channel) + +instance HasId ChannelData ChannelId where + getId = channelDataChannelId + +data ChannelData + = ChannelData + { channelDataChannelId :: ChannelId + , channelDataUserId :: UserId + , channelDataRoles :: Text + , channelDataLastViewedAt :: UTCTime + , channelDataMsgCount :: Int + , channelDataMentionCount :: Int + , channelDataNotifyProps :: NotifyProps + , channelDataLastUpdateAt :: UTCTime + } deriving (Read, Show, Eq) + +instance A.FromJSON ChannelData where + parseJSON = A.withObject "ChannelData" $ \o -> do + channelDataChannelId <- o .: "channel_id" + channelDataUserId <- o .: "user_id" + channelDataRoles <- o .: "roles" + channelDataLastViewedAt <- millisecondsToUTCTime <$> o .: "last_viewed_at" + channelDataMsgCount <- o .: "msg_count" + channelDataMentionCount <- o .: "mention_count" + channelDataNotifyProps <- o .: "notify_props" + channelDataLastUpdateAt <- millisecondsToUTCTime <$> o .: "last_update_at" + return ChannelData { .. } + +data ChannelWithData = ChannelWithData Channel ChannelData + deriving (Read, Show, Eq) + +instance A.FromJSON ChannelWithData where + parseJSON (A.Object v) = + ChannelWithData <$> (v .: "channel") + <*> (v .: "member") + parseJSON v = typeMismatch "Invalid channel/data pair " v + +type Channels = Seq Channel + +data MinChannel = MinChannel + { minChannelName :: Text + , minChannelDisplayName :: Text + , minChannelPurpose :: Maybe Text + , minChannelHeader :: Maybe Text + , minChannelType :: Type + } deriving (Read, Eq, Show) + +instance A.ToJSON MinChannel where + toJSON MinChannel { .. } = A.object $ + [ "name" .= minChannelName + , "display_name" .= minChannelDisplayName + , "type" .= minChannelType + ] ++ + [ "purpose" .= p | Just p <- [minChannelPurpose] ] ++ + [ "header" .= h | Just h <- [minChannelHeader] ] +-- + +newtype UserId = UI { unUI :: Id } + deriving (Read, Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, FromJSONKey, FromJSON) + +instance IsId UserId where + toId = unUI + fromId = UI + +-- + +-- Note: there's lots of other stuff in an initial_load response but +-- this is what we use for now. +data InitialLoad + = InitialLoad + { initialLoadUser :: User + , initialLoadTeams :: Seq Team + } deriving (Eq, Show) + +instance A.FromJSON InitialLoad where + parseJSON = A.withObject "InitialLoad" $ \o -> do + initialLoadUser <- o .: "user" + initialLoadTeams <- o .: "teams" + return InitialLoad { .. } + +-- + +instance HasId User UserId where + getId = userId + +data User + = User + { userId :: UserId + , userCreateAt :: UTCTime + , userUpdateAt :: UTCTime + , userDeleteAt :: UTCTime + , userUsername :: Text + , userAuthData :: Text + , userAuthService :: Text + , userEmail :: Text + , userEmailVerified :: Bool + , userNickname :: Text + , userFirstName :: Text + , userLastName :: Text + , userRoles :: Text + , userNotifyProps :: NotifyProps + , userLastPasswordUpdate :: Maybe UTCTime + , userLastPictureUpdate :: Maybe UTCTime + , userLocale :: Text + } deriving (Read, Show, Eq) + +instance A.FromJSON User where + parseJSON = A.withObject "User" $ \o -> do + userId <- o .: "id" + userCreateAt <- millisecondsToUTCTime <$> o .: "create_at" + userUpdateAt <- millisecondsToUTCTime <$> o .: "update_at" + userDeleteAt <- millisecondsToUTCTime <$> o .: "delete_at" + userUsername <- o .: "username" + userAuthData <- o .: "auth_data" + userAuthService <- o .: "auth_service" + userEmail <- o .: "email" + userEmailVerified <- o .:? "email_verified" .!= False + userNickname <- o .: "nickname" + userFirstName <- o .: "first_name" + userLastName <- o .: "last_name" + userRoles <- o .: "roles" + userNotifyProps <- o .:? "notify_props" .!= emptyNotifyProps + userLastPasswordUpdate <- (millisecondsToUTCTime <$>) <$> + (o .:? "last_password_update") + userLastPictureUpdate <- (millisecondsToUTCTime <$>) <$> (o .:? "last_picture_update") + userLocale <- o .: "locale" + return User { .. } + +data PostPropAttachment + = PostPropAttachment + { ppaColor :: Text + , ppaText :: Text + } deriving (Read, Show, Eq) + +instance A.FromJSON PostPropAttachment where + parseJSON = A.withObject "Attachment" $ \v -> do + ppaColor <- v .: "color" + ppaText <- v .: "text" + return PostPropAttachment { .. } + +instance A.ToJSON PostPropAttachment where + toJSON PostPropAttachment { .. } = A.object + [ "color" .= ppaColor + , "text" .= ppaText + ] + +data PostProps + = PostProps + { postPropsOverrideIconUrl :: Maybe Text + , postPropsOverrideUsername :: Maybe Text + , postPropsAttachments :: Maybe (Seq PostPropAttachment) -- A.Value + , postPropsNewHeader :: Maybe Text + , postPropsOldHeader :: Maybe Text + } deriving (Read, Show, Eq) + +instance A.FromJSON PostProps where + parseJSON = A.withObject "Props" $ \v -> do + postPropsOverrideIconUrl <- v .:? "override_icon_url" + postPropsOverrideUsername <- v .:? "override_username" + postPropsAttachments <- v .:? "attachments" + postPropsNewHeader <- v .:? "new_header" + postPropsOldHeader <- v .:? "old_header" + return PostProps { .. } + +instance A.ToJSON PostProps where + toJSON PostProps { .. } = A.object $ + [ "override_icon_url" .= v | Just v <- [postPropsOverrideIconUrl ] ] ++ + [ "override_username" .= v | Just v <- [postPropsOverrideUsername] ] ++ + [ "attachments" .= v | Just v <- [postPropsAttachments ] ] ++ + [ "new_header" .= v | Just v <- [postPropsNewHeader ] ] ++ + [ "old_header" .= v | Just v <- [postPropsOldHeader ] ] + +newtype PostId = PI { unPI :: Id } + deriving (Read, Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, FromJSONKey, FromJSON) + +instance IsId PostId where + toId = unPI + fromId = PI + +newtype FileId = FI { unFI :: Id } + deriving (Read, Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, FromJSONKey, FromJSON) + +instance IsId FileId where + toId = unFI + fromId = FI + +urlForFile :: FileId -> Text +urlForFile fId = + "/api/v3/files/" <> idString fId <> "/get" + +data Post + = Post + { postPendingPostId :: Maybe PostId + , postOriginalId :: Maybe PostId + , postProps :: PostProps + , postRootId :: Text + , postFileIds :: Seq FileId + , postId :: PostId + , postType :: Type + , postMessage :: Text + , postDeleteAt :: Maybe UTCTime + , postHashtags :: Text + , postUpdateAt :: UTCTime + , postUserId :: Maybe UserId + , postCreateAt :: UTCTime + , postParentId :: Maybe PostId + , postChannelId :: ChannelId + , postHasReactions :: Bool + } deriving (Read, Show, Eq) + +instance HasId Post PostId where + getId = postId + +instance A.FromJSON Post where + parseJSON = A.withObject "Post" $ \v -> do + postPendingPostId <- maybeFail (v .: "pending_post_id") + postOriginalId <- maybeFail (v .: "original_id") + postProps <- v .: "props" + postRootId <- v .: "root_id" + postFileIds <- (v .: "file_ids") <|> (return mempty) + postId <- v .: "id" + postType <- v .: "type" + postMessage <- v .: "message" + postDeleteAt <- (millisecondsToUTCTime <$>) <$> v .:? "delete_at" + postHashtags <- v .: "hashtags" + postUpdateAt <- millisecondsToUTCTime <$> v .: "update_at" + postUserId <- maybeFail (v .: "user_id") + postCreateAt <- millisecondsToUTCTime <$> v .: "create_at" + postParentId <- maybeFail (v .: "parent_id") + postChannelId <- v .: "channel_id" + postHasReactions <- (v .: "has_reactions") <|> (return False) + return Post { .. } + +instance A.ToJSON Post where + toJSON Post { .. } = A.object + [ "pending_post_id" .= postPendingPostId + , "original_id" .= postOriginalId + , "props" .= postProps + , "root_id" .= postRootId + , "file_ids" .= postFileIds + , "id" .= postId + , "type" .= postType + , "message" .= postMessage + , "delete_at" .= (utcTimeToMilliseconds <$> postDeleteAt) + , "hashtags" .= postHashtags + , "update_at" .= utcTimeToMilliseconds postUpdateAt + , "user_id" .= postUserId + , "create_at" .= utcTimeToMilliseconds postCreateAt + , "parent_id" .= postParentId + , "channel_id" .= postChannelId + , "has_reactions" .= postHasReactions + ] + +data PendingPost + = PendingPost + { pendingPostChannelId :: ChannelId + , pendingPostCreateAt :: Maybe UTCTime + , pendingPostFilenames :: Seq FilePath + , pendingPostMessage :: Text + , pendingPostId :: PendingPostId + , pendingPostUserId :: UserId + , pendingPostParentId :: Maybe PostId + , pendingPostRootId :: Maybe PostId + } deriving (Read, Show, Eq) + +instance A.ToJSON PendingPost where + toJSON post = A.object + [ "channel_id" .= pendingPostChannelId post + , "create_at" .= maybe 0 utcTimeToMilliseconds (pendingPostCreateAt post) + , "filenames" .= pendingPostFilenames post + , "message" .= pendingPostMessage post + , "pending_post_id" .= pendingPostId post + , "user_id" .= pendingPostUserId post + , "root_id" .= pendingPostRootId post + , "parent_id" .= pendingPostParentId post + ] + +newtype PendingPostId = PPI { unPPI :: Id } + deriving (Read, Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, FromJSONKey, FromJSON) + +instance IsId PendingPostId where + toId = unPPI + fromId = PPI + +instance HasId PendingPost PendingPostId where + getId = pendingPostId + +mkPendingPost :: Text -> UserId -> ChannelId -> IO PendingPost +mkPendingPost msg userid channelid = do + now <- getCurrentTime + let ms = utcTimeToMilliseconds now :: Int + pid = T.pack $ printf "%s:%d" (idString userid) ms + return PendingPost + { pendingPostId = PPI (Id pid) + , pendingPostChannelId = channelid + , pendingPostCreateAt = Nothing + , pendingPostFilenames = S.empty + , pendingPostMessage = msg + , pendingPostUserId = userid + , pendingPostRootId = Nothing + , pendingPostParentId = Nothing + } + +data FileInfo + = FileInfo + { fileInfoId :: FileId + , fileInfoUserId :: UserId + , fileInfoPostId :: Maybe PostId + , fileInfoCreateAt :: UTCTime + , fileInfoUpdateAt :: UTCTime + , fileInfoDeleteAt :: UTCTime + , fileInfoName :: Text + , fileInfoExtension :: Text + , fileInfoSize :: Int + , fileInfoMimeType :: Text + , fileInfoWidth :: Maybe Int + , fileInfoHeight :: Maybe Int + , fileInfoHasPreview :: Bool + } deriving (Read, Show, Eq) + +instance FromJSON FileInfo where + parseJSON = A.withObject "file_info" $ \o -> do + fileInfoId <- o .: "id" + fileInfoUserId <- o .: "user_id" + fileInfoPostId <- o .: "post_id" + fileInfoCreateAt <- millisecondsToUTCTime <$> o .: "create_at" + fileInfoUpdateAt <- millisecondsToUTCTime <$> o .: "update_at" + fileInfoDeleteAt <- millisecondsToUTCTime <$> o .: "delete_at" + fileInfoName <- o .: "name" + fileInfoExtension <- o .: "extension" + fileInfoSize <- o .: "size" + fileInfoMimeType <- o .: "mime_type" + fileInfoWidth <- o .:? "width" + fileInfoHeight <- o .:? "height" + fileInfoHasPreview <- (o .: "has_preview_image") <|> pure False + return FileInfo { .. } + +-- + +data Posts + = Posts + { postsPosts :: HM.HashMap PostId Post + , postsOrder :: Seq PostId + } deriving (Read, Show, Eq) + +instance A.FromJSON Posts where + parseJSON = A.withObject "Posts" $ \v -> do + postsPosts <- v .:? "posts" .!= HM.empty + postsOrder <- v .: "order" + return Posts { .. } + +-- + +millisecondsToUTCTime :: Integer -> UTCTime +millisecondsToUTCTime ms = posixSecondsToUTCTime (fromRational (ms%1000)) + +utcTimeToMilliseconds :: UTCTime -> Int +utcTimeToMilliseconds utc = truncate ((utcTimeToPOSIXSeconds utc)*1000) + +-- + +data MinCommand + = MinCommand + { minComChannelId :: ChannelId + , minComCommand :: Text + } deriving (Read, Show, Eq) + +instance A.ToJSON MinCommand where + toJSON MinCommand { .. } = A.object + [ "channel_id" .= minComChannelId + , "command" .= minComCommand + ] + +-- + +data Command + = Command + { commandId :: CommandId + , commandToken :: Token + , commandCreateAt :: UTCTime + , commandUpdateAt :: UTCTime + , commandDeleteAt :: UTCTime + , commandCreatorId :: UserId + , commandTeamId :: TeamId + , commandTrigger :: Text + , commandMethod :: Text + , commandUsername :: Text + , commandIconURL :: Text + , commandAutoComplete :: Bool + , commandAutoCompleteDesc :: Text + , commandAutoCompleteHint :: Text + , commandDisplayName :: Text + , commandDescription :: Text + , commandURL :: Text + } deriving (Read, Show, Eq) + +newtype CommandId = CmdI { unCmdI :: Id } + deriving (Read, Show, Eq, Ord, Hashable, ToJSON, ToJSONKey, FromJSONKey, FromJSON) + +instance IsId CommandId where + toId = unCmdI + fromId = CmdI + +instance HasId Command CommandId where + getId = commandId + +data CommandResponseType + = CommandResponseInChannel + | CommandResponseEphemeral + deriving (Read, Show, Eq) + +instance A.FromJSON CommandResponseType where + parseJSON (A.String "in_channel") = return CommandResponseInChannel + parseJSON (A.String "ephemeral") = return CommandResponseEphemeral + parseJSON _ = fail "Unknown command response type: expected `in_channel` or `ephemeral`" + +data CommandResponse + = CommandResponse + { commandResponseType :: CommandResponseType + , commandResponseText :: Text + , commandResponseUsername :: Text + , commandResponseIconURL :: Text + , commandResponseGotoLocation :: Text + , commandResponseAttachments :: Seq PostPropAttachment + } deriving (Read, Show, Eq) + +instance A.FromJSON CommandResponse where + parseJSON = A.withObject "CommandResponse" $ \o -> do + commandResponseType <- o .: "response_type" + commandResponseText <- o .: "text" + commandResponseUsername <- o .: "username" + commandResponseIconURL <- o .: "icon_url" + commandResponseGotoLocation <- o .: "goto_location" + commandResponseAttachments <- o .:? "attachments" .!= S.empty + return CommandResponse { .. } + +-- + +data UsersCreate + = UsersCreate + { usersCreateEmail :: Text + , usersCreatePassword :: Text + , usersCreateUsername :: Text + , usersCreateAllowMarketing :: Bool + } deriving (Read, Show, Eq) + +instance A.ToJSON UsersCreate where + toJSON UsersCreate { .. } = A.object + [ "email" .= usersCreateEmail + , "allow_marketing" .= usersCreateAllowMarketing + , "password" .= usersCreatePassword + , "username" .= usersCreateUsername + ] + +-- + +data TeamsCreate + = TeamsCreate + { teamsCreateDisplayName :: Text + , teamsCreateName :: Text + , teamsCreateType :: Type + } deriving (Read, Show, Eq) + +instance A.ToJSON TeamsCreate where + toJSON TeamsCreate { .. } = A.object + [ "display_name" .= teamsCreateDisplayName + , "name" .= teamsCreateName + , "type" .= teamsCreateType + ] + +-- + +data Reaction + = Reaction + { reactionUserId :: UserId + , reactionPostId :: PostId + , reactionEmojiName :: Text + , reactionCreateAt :: UTCTime + } deriving (Read, Show, Eq) + +instance A.FromJSON Reaction where + parseJSON = A.withObject "Reaction" $ \v -> do + reactionUserId <- v .: "user_id" + reactionPostId <- v .: "post_id" + reactionEmojiName <- v .: "emoji_name" + reactionCreateAt <- millisecondsToUTCTime <$> v .: "create_at" + return Reaction { .. } + +instance A.ToJSON Reaction where + toJSON Reaction {.. } = A.object + [ "user_id" .= reactionUserId + , "post_id" .= reactionPostId + , "emoji_name" .= reactionEmojiName + , "create_at" .= utcTimeToMilliseconds reactionCreateAt + ] diff --git a/src/Network/Mattermost/Types/Base.hs b/src/Network/Mattermost/Types/Base.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/Types/Base.hs @@ -0,0 +1,33 @@ +-- | These are the fundamental types that are used for building +-- everything else. Specifically, these types are used by the +-- Network.Mattermost.Types.Internal, but are not subject to the +-- cautions that as associated with the latter. + +module Network.Mattermost.Types.Base where + +import qualified Data.Aeson as A +import Data.Text (Text) +import Network.HTTP.Base (RequestMethod) + +type Hostname = Text +type Port = Int + +-- | A 'Logger' is any function which responds to log events: +type Logger = LogEvent -> IO () + +-- | If there is a 'Logger' in the 'ConnectionData' struct, it will +-- be sporadically called with values of type 'LogEvent'. +data LogEvent = LogEvent + { logFunction :: String + , logEventType :: LogEventType + } deriving (Eq, Show) + +-- | A 'LogEventType' describes the particular event that happened +data LogEventType + = HttpRequest RequestMethod String (Maybe A.Value) + | HttpResponse Int String (Maybe A.Value) + | WebSocketRequest A.Value + | WebSocketResponse A.Value + | WebSocketPing + | WebSocketPong + deriving (Eq, Show) diff --git a/src/Network/Mattermost/Types/Internal.hs b/src/Network/Mattermost/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/Types/Internal.hs @@ -0,0 +1,43 @@ +-- | 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: +-- they can be used in a manner that would cause significant +-- disruption and may be subject to change without being reflected in +-- the mattermost-api version. + +module Network.Mattermost.Types.Internal where + +import Network.Connection (ConnectionContext) +import Network.HTTP.Headers (Header, HeaderName(..), mkHeader) +import Network.Mattermost.Types.Base + +data Token = Token String + deriving (Read, Show, Eq, Ord) + +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) + +-- | We return a list of headers so that we can treat +-- the headers like a monoid. +autoCloseToHeader :: AutoClose -> [Header] +autoCloseToHeader No = [] +autoCloseToHeader Yes = [mkHeader HdrConnection "Close"] + + +data ConnectionData + = ConnectionData + { cdHostname :: Hostname + , cdPort :: Port + , cdAutoClose :: AutoClose + , cdConnectionCtx :: ConnectionContext + , cdToken :: Maybe Token + , cdLogger :: Maybe Logger + , cdUseTLS :: Bool + } diff --git a/src/Network/Mattermost/Util.hs b/src/Network/Mattermost/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/Util.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Network.Mattermost.Util +( assertE +, noteE +, hoistE +, (~=) +, dropTrailingChar +, withConnection +, mkConnection +, connectionGetExact +) where + +import Data.Char ( toUpper ) +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T + +import Control.Exception ( Exception + , throwIO + , bracket ) +import Network.Connection ( Connection + , ConnectionParams(..) + , TLSSettings(..) + , connectionGet + , connectionClose + , connectTo ) + +import Network.Mattermost.Types.Internal + +-- | This unwraps a 'Maybe' value, throwing a provided exception +-- if the value is 'Nothing'. +noteE :: Exception e => Maybe r -> e -> IO r +noteE Nothing e = throwIO e +noteE (Just r) _ = pure r + +-- | This unwraps an 'Either' value, throwing the contained exception +-- if the 'Either' was a 'Left' value. +hoistE :: Exception e => Either e r -> IO r +hoistE (Left e) = throwIO e +hoistE (Right r) = pure r + +-- | This asserts that the provided 'Bool' is 'True', throwing a +-- provided exception is the argument was 'False'. +assertE :: Exception e => Bool -> e -> IO () +assertE True _ = pure () +assertE False e = throwIO e + +-- | Case Insensitive string comparison +(~=) :: 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. +withConnection :: ConnectionData -> (Connection -> IO a) -> IO a +withConnection cd action = + bracket (mkConnection cd) + connectionClose + action + +-- | 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 + then Just (TLSSettingsSimple False False False) + else Nothing + , connectionUseSocks = Nothing + } + + +-- | Get exact count of bytes from a connection. +-- +-- The size argument is the exact amount that must be returned to the user. +-- The call will wait until all data is available. Hence, it behaves like +-- 'B.hGet'. +-- +-- On end of input, 'connectionGetExact' will throw an 'E.isEOFError' +-- exception. +-- Taken from: https://github.com/vincenthz/hs-connection/issues/9 +connectionGetExact :: Connection -> Int -> IO B.ByteString +connectionGetExact con n = loop B.empty 0 + where loop bs y + | y == n = return bs + | otherwise = do + next <- connectionGet con (n - y) + loop (B.append bs next) (y + (B.length next)) diff --git a/src/Network/Mattermost/Version.hs b/src/Network/Mattermost/Version.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/Version.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Network.Mattermost.Version (mmApiVersion) where + +import Data.Version (showVersion) +import Development.GitRev (gitBranch, gitHash) +import Paths_mattermost_api (version) + +mmApiVersion :: String +mmApiVersion + | $(gitHash) == ("UNKNOWN" :: String) = "mattermost-api " ++ showVersion version + | otherwise = "mattermost-api " ++ showVersion version ++ " (" ++ + $(gitBranch) ++ "@" ++ take 7 $(gitHash) ++ ")" diff --git a/src/Network/Mattermost/WebSocket.hs b/src/Network/Mattermost/WebSocket.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/WebSocket.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Network.Mattermost.WebSocket +( MMWebSocket +, MMWebSocketTimeoutException +, mmWithWebSocket +, mmCloseWebSocket +, mmGetConnectionHealth +, module Network.Mattermost.WebSocket.Types +) where + +import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay) +import qualified Control.Concurrent.STM.TQueue as Queue +import Control.Exception (Exception, SomeException, catch, throwIO, throwTo) +import Control.Monad (forever) +import Control.Monad.STM (atomically) +import Data.Aeson (toJSON) +import qualified Data.ByteString.Char8 as B +import Data.ByteString.Lazy (toStrict) +import Data.IORef +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) +import Data.Typeable ( Typeable ) +import Network.Connection ( Connection + , connectionClose + , connectionGet + , connectionPut + ) +import qualified Network.WebSockets as WS +import Network.WebSockets.Stream (Stream, makeStream) + +import Network.Mattermost.Util +import Network.Mattermost.Types.Base +import Network.Mattermost.Types.Internal +import Network.Mattermost.Types +import Network.Mattermost.WebSocket.Types + + +connectionToStream :: Connection -> IO Stream +connectionToStream con = makeStream rd wr + where wr Nothing = connectionClose con + wr (Just bs) = connectionPut con (toStrict bs) + rd = do + bs <- connectionGet con 1024 + return $ if B.null bs + then Nothing + else Just bs + +data MMWebSocket = MMWS WS.Connection (IORef NominalDiffTime) + +data MMWebSocketTimeoutException = MMWebSocketTimeoutException + deriving (Show, Typeable) + +instance Exception MMWebSocketTimeoutException where + +data PEvent = P UTCTime + +createPingPongTimeouts :: ThreadId + -> IORef NominalDiffTime + -> Int + -> (LogEventType -> IO ()) + -> IO (IO (), IO (), ThreadId) +createPingPongTimeouts pId health n doLog = do + pingChan <- Queue.newTQueueIO + pongChan <- Queue.newTQueueIO + let pingAction = do + now <- getCurrentTime + doLog WebSocketPing + atomically $ Queue.writeTQueue pingChan (P now) + let pongAction = do + now <- getCurrentTime + doLog WebSocketPong + atomically $ Queue.writeTQueue pongChan (P now) + watchdogPId <- forkIO $ do + let go = do + P old <- atomically $ Queue.readTQueue pingChan + threadDelay (n * 1000 * 1000) + b <- atomically $ Queue.isEmptyTQueue pongChan + if b + then throwTo pId MMWebSocketTimeoutException + else do + P new <- atomically $ Queue.readTQueue pongChan + atomicWriteIORef health (new `diffUTCTime` old) + go + go + + return (pingAction, pongAction, watchdogPId) + +mmCloseWebSocket :: MMWebSocket -> IO () +mmCloseWebSocket (MMWS c _) = WS.sendClose c B.empty + +mmGetConnectionHealth :: MMWebSocket -> IO NominalDiffTime +mmGetConnectionHealth (MMWS _ h) = readIORef h + +pingThread :: IO () -> WS.Connection -> IO () +pingThread onPingAction conn = loop 0 + where loop :: Int -> IO () + loop n = do + threadDelay (10 * 1000 * 1000) + onPingAction + WS.sendPing conn (B.pack (show n)) + loop (n+1) + +mmWithWebSocket :: Session + -> (WebsocketEvent -> IO ()) + -> (MMWebSocket -> IO ()) + -> IO () +mmWithWebSocket (Session cd (Token tk)) recv body = do + con <- mkConnection cd + stream <- connectionToStream con + health <- newIORef 0 + myId <- myThreadId + let doLog = runLogger cd "websocket" + (onPing, onPong, _) <- createPingPongTimeouts myId health 8 doLog + let action c = do + pId <- forkIO (pingThread onPing c `catch` cleanup) + mId <- forkIO $ flip catch cleanup $ forever $ do + p <- WS.receiveData c + doLog (WebSocketResponse (toJSON p)) + recv p + body (MMWS c health) `catch` propagate [mId, pId] + WS.runClientWithStream stream + (T.unpack $ cdHostname cd) + "/api/v3/users/websocket" + WS.defaultConnectionOptions { WS.connectionOnPong = onPong } + [ ("Authorization", "Bearer " <> B.pack tk) ] + action + where cleanup :: SomeException -> IO () + cleanup _ = return () + propagate :: [ThreadId] -> SomeException -> IO () + propagate ts e = do + sequence_ [ throwTo t e | t <- ts ] + throwIO e diff --git a/src/Network/Mattermost/WebSocket/Types.hs b/src/Network/Mattermost/WebSocket/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mattermost/WebSocket/Types.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.Mattermost.WebSocket.Types +( WebsocketEventType(..) +, WebsocketEvent(..) +, WEData(..) +, WEBroadcast(..) +) where + +import Control.Applicative +import Control.Exception ( throw ) +import Data.Aeson ( FromJSON(..) + , ToJSON(..) + , (.:) + , (.:?) + , (.=) + ) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import Data.ByteString.Lazy (fromStrict, toStrict) +import qualified Data.ByteString.Lazy.Char8 as BC +import qualified Data.HashMap.Strict as HM +import Data.Int (Int64) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Network.WebSockets (WebSocketsData(..)) +import qualified Network.WebSockets as WS + +import Network.Mattermost.Types +import Network.Mattermost.Exceptions + + +data WebsocketEventType + = WMTyping + | WMPosted + | WMPostEdited + | WMPostDeleted + | WMChannelDeleted + | WMChannelCreated + | WMDirectAdded + | WMGroupAdded + | WMNewUser + | WMAddedToTeam + | WMLeaveTeam + | WMUpdateTeam + | WMUserAdded + | WMUserUpdated + | WMUserRemoved + | WMPreferenceChanged + | WMEphemeralMessage + | WMStatusChange + | WMHello + | WMWebRTC + | WMAuthenticationChallenge + | WMReactionAdded + | WMReactionRemoved + deriving (Read, Show, Eq, Ord) + +instance FromJSON WebsocketEventType where + parseJSON = A.withText "event type" $ \s -> case s of + "typing" -> return WMTyping + "posted" -> return WMPosted + "post_edited" -> return WMPostEdited + "post_deleted" -> return WMPostDeleted + "channel_deleted" -> return WMChannelDeleted + "direct_added" -> return WMDirectAdded + "new_user" -> return WMNewUser + "leave_team" -> return WMLeaveTeam + "user_added" -> return WMUserAdded + "user_updated" -> return WMUserUpdated + "user_removed" -> return WMUserRemoved + "preference_changed" -> return WMPreferenceChanged + "ephemeral_message" -> return WMEphemeralMessage + "status_change" -> return WMStatusChange + "hello" -> return WMHello + "update_team" -> return WMUpdateTeam + "reaction_added" -> return WMReactionAdded + "reaction_removed" -> return WMReactionRemoved + "channel_created" -> return WMChannelCreated + "group_added" -> return WMGroupAdded + "added_to_team" -> return WMAddedToTeam + "webrtc" -> return WMWebRTC + "authentication_challenge" -> return WMAuthenticationChallenge + _ -> fail ("Unknown websocket message: " ++ show s) + +instance ToJSON WebsocketEventType where + toJSON WMTyping = "typing" + toJSON WMPosted = "posted" + toJSON WMPostEdited = "post_edited" + toJSON WMPostDeleted = "post_deleted" + toJSON WMChannelDeleted = "channel_deleted" + toJSON WMDirectAdded = "direct_added" + toJSON WMNewUser = "new_user" + toJSON WMLeaveTeam = "leave_team" + toJSON WMUserAdded = "user_added" + toJSON WMUserUpdated = "user_updated" + toJSON WMUserRemoved = "user_removed" + toJSON WMPreferenceChanged = "preference_changed" + toJSON WMEphemeralMessage = "ephemeral_message" + toJSON WMStatusChange = "status_change" + toJSON WMHello = "hello" + toJSON WMUpdateTeam = "update_team" + toJSON WMReactionAdded = "reaction_added" + toJSON WMReactionRemoved = "reaction_removed" + toJSON WMChannelCreated = "channel_created" + toJSON WMGroupAdded = "group_added" + toJSON WMAddedToTeam = "added_to_team" + toJSON WMWebRTC = "webrtc" + toJSON WMAuthenticationChallenge = "authentication_challenge" + +-- + +toValueString :: ToJSON a => a -> A.Value +toValueString v = toJSON (decodeUtf8 (toStrict (A.encode v))) + +fromValueString :: FromJSON a => A.Value -> A.Parser a +fromValueString = A.withText "string-encoded json" $ \s -> do + case A.eitherDecode (fromStrict (encodeUtf8 s)) of + Right v -> return v + Left err -> throw (JSONDecodeException err (T.unpack s)) + +-- + +data WebsocketEvent = WebsocketEvent + { weEvent :: WebsocketEventType + , weData :: WEData + , weBroadcast :: WEBroadcast + , weSeq :: Int64 + } deriving (Read, Show, Eq) + +instance FromJSON WebsocketEvent where + parseJSON = A.withObject "WebsocketEvent" $ \o -> do + weEvent <- o .: "event" + weData <- o .: "data" + weBroadcast <- o .: "broadcast" + weSeq <- o .: "seq" + return WebsocketEvent { .. } + +instance ToJSON WebsocketEvent where + toJSON WebsocketEvent { .. } = A.object + [ "event" .= weEvent + , "data" .= weData + , "broadcast" .= weBroadcast + , "seq" .= weSeq + ] + +instance WebSocketsData WebsocketEvent where + fromDataMessage (WS.Text bs _) = fromLazyByteString bs + fromDataMessage (WS.Binary bs) = fromLazyByteString bs + fromLazyByteString s = case A.eitherDecode s of + Left err -> throw (JSONDecodeException err (BC.unpack s)) + Right v -> v + toLazyByteString = A.encode + +-- + +data WEData = WEData + { wepChannelId :: Maybe ChannelId + , wepTeamId :: Maybe TeamId + , wepSenderName :: Maybe Text + , wepUserId :: Maybe UserId + , wepUser :: Maybe User + , wepChannelDisplayName :: Maybe Text + , wepPost :: Maybe Post + , wepStatus :: Maybe Text + , wepReaction :: Maybe Reaction + } deriving (Read, Show, Eq) + +instance FromJSON WEData where + parseJSON = A.withObject "WebSocketEvent Data" $ \o -> do + wepChannelId <- o .:? "channel_id" + wepTeamId <- maybeFail (o .: "team_id") + wepSenderName <- o .:? "sender_name" + wepUserId <- o .:? "user_id" + wepUser <- o .:? "user" + wepChannelDisplayName <- o .:? "channel_name" + wepPostRaw <- o .:? "post" + wepPost <- case wepPostRaw of + Just str -> fromValueString str + Nothing -> return Nothing + wepStatus <- o .:? "status" + wepReactionRaw <- o .:? "reaction" + wepReaction <- case wepReactionRaw of + Just str -> fromValueString str + Nothing -> return Nothing + return WEData { .. } + +instance ToJSON WEData where + toJSON WEData { .. } = A.object + [ "channel_id" .= wepChannelId + , "team_id" .= wepTeamId + , "sender_name" .= wepSenderName + , "user_id" .= wepUserId + , "channel_name" .= wepChannelDisplayName + , "post" .= toValueString wepPost + , "reaction" .= wepReaction + ] + +-- + +data WEBroadcast = WEBroadcast + { webChannelId :: Maybe ChannelId + , webUserId :: Maybe UserId + , webTeamId :: Maybe TeamId + , webOmitUsers :: Maybe (HM.HashMap UserId Bool) + } deriving (Read, Show, Eq) + +nullable :: Alternative f => f a -> f (Maybe a) +nullable p = (Just <$> p) <|> pure Nothing + +instance FromJSON WEBroadcast where + parseJSON = A.withObject "WebSocketEvent Broadcast" $ \o -> do + webChannelId <- nullable (o .: "channel_id") + webTeamId <- nullable (o .: "team_id") + webUserId <- nullable (o .: "user_id") + webOmitUsers <- nullable (o .: "omit_users") + return WEBroadcast { .. } + +instance ToJSON WEBroadcast where + toJSON WEBroadcast { .. } = A.object + [ "channel_id" .= webChannelId + , "team_id" .= webTeamId + , "user_id" .= webUserId + , "omit_users" .= webOmitUsers + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main ( + main +) where + +import Control.Exception +import Control.Monad (when) + +import System.Exit + +import Text.Show.Pretty ( ppShow ) + +import Data.Aeson +import Data.Monoid ((<>)) +import qualified Data.HashMap.Strict as HM +import qualified Data.Sequence as Seq + +import Test.Tasty + +import Network.Mattermost.Types +import Network.Mattermost.WebSocket.Types +import Network.Mattermost.Exceptions + +import Tests.Util +import Tests.Types + +main :: IO () +main = defaultMain tests `catch` \(JSONDecodeException msg badJson) -> do + putStrLn $ "JSONDecodeException: " ++ msg + putStrLn badJson + exitFailure + +-- Users and other test configuration data + +testConfig :: Config +testConfig = Config + { configUsername = "testAdmin" + , configEmail = "testAdmin@example.com" + , configHostname = "localhost" + , configTeam = "testteam" + , configPort = 8065 + , configPassword = "password" + } + +testUserLogin :: Login +testUserLogin = Login + { username = "test-user" + , password = "password" + } + +testMinChannel :: MinChannel +testMinChannel = MinChannel + { minChannelName = "test-channel" + , minChannelDisplayName = "Test Channel" + , minChannelPurpose = Just "A channel for test cases" + , minChannelHeader = Just "Test Header" + , minChannelType = Ordinary + } + +testTeamsCreate :: TeamsCreate +testTeamsCreate = TeamsCreate + { teamsCreateDisplayName = "Test Team" + , teamsCreateName = "testteam" + , teamsCreateType = Ordinary + } + +testAccount :: UsersCreate +testAccount = + UsersCreate { usersCreateEmail = "test-user@example.com" + , usersCreatePassword = password testUserLogin + , usersCreateUsername = username testUserLogin + , usersCreateAllowMarketing = False + } + +-- Test groups + +tests :: TestTree +tests = testGroup "Tests" + [ setup + , unitTests + ] + +-- Note that the order of the tests matters as each may have side +-- effects on which subsequent tests depend. +unitTests :: TestTree +unitTests = testGroup "Units" + [ loginAsNormalUserTest + , initialLoadTest + , createChannelTest + , getChannelsTest + , leaveChannelTest + , joinChannelTest + , deleteChannelTest + ] + +-- Test definitions + +setup :: TestTree +setup = mmTestCase "Setup" testConfig $ do + adminUser <- createAdminAccount + + print_ "Logging into Admin account" + loginAdminAccount + + expectWSEvent "hello" (hasWSEventType WMHello) + expectWSEvent "status" (isStatusChange adminUser "online") + + print_ "Creating test team" + testTeam <- createTeam testTeamsCreate + + -- Load channels so we can get the IDs of joined channels + chans <- getChannels testTeam + + let townSquare = findChannel chans "Town Square" + offTopic = findChannel chans "Off-Topic" + + print_ "Getting Config" + config <- getConfig + + print_ "Saving Config" + -- Enable open team so that the admin can create + -- new users. + let Object oldConfig = config + Object teamSettings = oldConfig HM.! "TeamSettings" + newConfig = Object (HM.insert "TeamSettings" + (Object (HM.insert "EnableOpenServer" + (Bool True) teamSettings)) oldConfig) + saveConfig newConfig + + expectWSEvent "admin joined town square" + (isPost adminUser townSquare "testadmin has joined the channel.") + + print_ "Creating test account" + testUser <- createAccount testAccount + + print_ "Add test user to test team" + teamAddUser testTeam testUser + + expectWSEvent "new test user" + (isNewUserEvent testUser) + + expectWSEvent "test user joined town square" + (isPost testUser townSquare "test-user has joined the channel.") + + expectWSEvent "test user joined off-topic" + (isPost testUser offTopic "test-user has joined the channel.") + + expectWSDone + +loginAsNormalUserTest :: TestTree +loginAsNormalUserTest = + mmTestCase "Logging in with normal account" testConfig $ do + loginAccount testUserLogin + Just testUser <- getUserByName (username testUserLogin) + + expectWSEvent "hello" (hasWSEventType WMHello) + expectWSEvent "status" (isStatusChange testUser "online") + expectWSDone + +initialLoadTest :: TestTree +initialLoadTest = + mmTestCase "Initial Load" testConfig $ do + loginAccount testUserLogin + + initialLoad <- getInitialLoad + -- print the team names + print_ (ppShow (fmap teamName (initialLoadTeams initialLoad))) + + expectWSEvent "hello" (hasWSEventType WMHello) + expectWSDone + +createChannelTest :: TestTree +createChannelTest = + mmTestCase "Create Channel" testConfig $ do + loginAccount testUserLogin + + initialLoad <- getInitialLoad + let team Seq.:< _ = Seq.viewl (initialLoadTeams initialLoad) + chan <- createChannel team testMinChannel + print_ (ppShow chan) + + expectWSEvent "hello" (hasWSEventType WMHello) + expectWSEvent "new channel event" (isChannelCreatedEvent chan) + expectWSDone + +getChannelsTest :: TestTree +getChannelsTest = + mmTestCase "Get Channels" testConfig $ do + loginAccount testUserLogin + initialLoad <- getInitialLoad + let team Seq.:< _ = Seq.viewl (initialLoadTeams initialLoad) + chans <- getChannels team + + let chan Seq.:< _ = Seq.viewl chans + print_ (ppShow chan) + + expectWSEvent "hello" (hasWSEventType WMHello) + expectWSDone + +leaveChannelTest :: TestTree +leaveChannelTest = + mmTestCase "Leave Channel" testConfig $ do + loginAccount testUserLogin + Just testUser <- getUserByName (username testUserLogin) + initialLoad <- getInitialLoad + + let team Seq.:< _ = Seq.viewl (initialLoadTeams initialLoad) + chans <- getChannels team + print_ (ppShow chans) + + let chan = findChannel chans $ minChannelName testMinChannel + leaveChannel team chan + + expectWSEvent "hello" (hasWSEventType WMHello) + expectWSEvent "leave channel" (isUserLeave testUser chan) + expectWSDone + +joinChannelTest :: TestTree +joinChannelTest = + mmTestCase "Join Channel" testConfig $ do + loginAccount testUserLogin + Just testUser <- getUserByName (username testUserLogin) + initialLoad <- getInitialLoad + + let team Seq.:< _ = Seq.viewl (initialLoadTeams initialLoad) + chans <- getMoreChannels team + print_ (ppShow chans) + + let chan = findChannel chans $ minChannelName testMinChannel + joinChannel team chan + + members <- getChannelMembers team chan + let expected :: [User] + expected = [testUser] + when (members /= expected) $ + error $ "Expected channel members: " <> show expected + + expectWSEvent "hello" (hasWSEventType WMHello) + expectWSEvent "join channel" (isUserJoin testUser chan) + expectWSEvent "join post" + (isPost testUser chan "test-user has joined the channel.") + expectWSDone + +deleteChannelTest :: TestTree +deleteChannelTest = + mmTestCase "Delete Channel" testConfig $ do + loginAccount testUserLogin + Just testUser <- getUserByName (username testUserLogin) + + initialLoad <- getInitialLoad + let team Seq.:< _ = Seq.viewl (initialLoadTeams initialLoad) + chans <- getChannels team + + let toDelete = findChannel chans (minChannelName testMinChannel) + + deleteChannel team toDelete + + expectWSEvent "hello" (hasWSEventType WMHello) + + expectWSEvent "channel deletion post" + (isPost testUser toDelete "test-user has archived the channel.") + + expectWSEvent "channel delete event" + (isChannelDeleteEvent toDelete) + + expectWSDone diff --git a/test/Tests/Types.hs b/test/Tests/Types.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Types.hs @@ -0,0 +1,36 @@ +module Tests.Types + ( Config(..) + , TestM + , TestState(..) + ) +where + +import Data.Text (Text) +import Control.Monad.State.Lazy +import Control.Concurrent.MVar +import qualified Control.Concurrent.STM.TChan as STM + +import Network.Mattermost.Types.Internal +import Network.Mattermost.Types (Session) +import Network.Mattermost.WebSocket.Types + +data Config + = Config { configUsername :: Text + , configHostname :: Text + , configTeam :: Text + , configPort :: Int + , configPassword :: Text + , configEmail :: Text + } + +type TestM a = StateT TestState IO a + +data TestState = + TestState { tsPrinter :: String -> IO () + , tsConfig :: Config + , tsConnectionData :: ConnectionData + , tsSession :: Maybe Session + , tsDebug :: Bool + , tsWebsocketChan :: STM.TChan WebsocketEvent + , tsDone :: MVar () + } diff --git a/test/Tests/Util.hs b/test/Tests/Util.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Util.hs @@ -0,0 +1,393 @@ +module Tests.Util + ( mmTestCase + , print_ + , getConnection + , getSession + , getInitialLoad + , createChannel + , deleteChannel + , joinChannel + , leaveChannel + , getMoreChannels + , getChannels + , getChannelMembers + , getUserByName + , getConfig + , saveConfig + , teamAddUser + , reportJSONExceptions + , adminAccount + , createAdminAccount + , loginAccount + , loginAdminAccount + , createAccount + , createTeam + , findChannel + , connectFromConfig + + -- * Testing Websocket Events + , expectWSEvent + , expectWSDone + + -- * Websocket Event Predicates + , hasWSEventType + , forUser + , forChannel + , isStatusChange + , isPost + , isNewUserEvent + , isChannelCreatedEvent + , isChannelDeleteEvent + , isUserJoin + , isUserLeave + , wsHas + , (&&&) + ) +where + +import qualified Data.Aeson as A +import qualified Control.Exception as E +import qualified Control.Concurrent.STM as STM +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar +import Data.Monoid ((<>)) +import qualified Data.Sequence as Seq +import qualified Data.Text as T +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCaseSteps) +import Control.Monad.State.Lazy +import System.Timeout (timeout) +import qualified Data.HashMap.Lazy as HM + +import Network.Mattermost +import Network.Mattermost.WebSocket +import Network.Mattermost.Exceptions + +import Tests.Types + +mmTestCase :: String -> Config -> TestM () -> TestTree +mmTestCase testName cfg act = + testCaseSteps testName $ \prnt -> do + cd <- connectFromConfig cfg + wsChan <- STM.atomically STM.newTChan + mv <- newEmptyMVar + let initState = TestState { tsPrinter = prnt + , tsConfig = cfg + , tsConnectionData = cd + , tsSession = Nothing + , tsDebug = False + , tsWebsocketChan = wsChan + , tsDone = mv + } + (reportJSONExceptions $ evalStateT act initState) `E.finally` + (putMVar mv ()) + +print_ :: String -> TestM () +print_ s = do + dbg <- gets tsDebug + printFunc <- gets tsPrinter + when dbg $ liftIO $ printFunc s + +-- This only exists because tasty will call `show` on the exception that +-- we give it. If we directly output the exception first then we avoid +-- an unnecessary level of quotation in the output. We still throw the +-- exception though so that tasty reports the correct exception type. +-- This results in some redundancy but we only see it when there are +-- failures, so it seems acceptable. +reportJSONExceptions :: IO a -> IO a +reportJSONExceptions io = io + `E.catch` \e@(JSONDecodeException msg badJson) -> do + putStrLn $ "\nException: JSONDecodeException: " ++ msg + putStrLn badJson + E.throwIO e + +adminAccount :: Config -> UsersCreate +adminAccount cfg = + UsersCreate { usersCreateEmail = configEmail cfg + , usersCreatePassword = configPassword cfg + , usersCreateUsername = configUsername cfg + , usersCreateAllowMarketing = True + } + +createAdminAccount :: TestM User +createAdminAccount = do + cd <- getConnection + cfg <- gets tsConfig + u <- liftIO $ mmUsersCreate cd $ adminAccount cfg + print_ "Admin Account created" + return u + +loginAccount :: Login -> TestM () +loginAccount login = do + cd <- getConnection + (session, _mmUser) <- liftIO $ join (hoistE <$> mmLogin cd login) + print_ $ "Authenticated as " ++ T.unpack (username login) + chan <- gets tsWebsocketChan + doneMVar <- gets tsDone + void $ liftIO $ forkIO $ mmWithWebSocket session + (STM.atomically . STM.writeTChan chan) + (const $ takeMVar doneMVar) + modify $ \ts -> ts { tsSession = Just session } + +hasWSEventType :: WebsocketEventType -> WebsocketEvent -> Bool +hasWSEventType = wsHas weEvent + +wsHas :: (Eq a) => (WebsocketEvent -> a) -> a -> WebsocketEvent -> Bool +wsHas f expected e = f e == expected + +(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool +(&&&) f g a = f a && g a + +-- | Expect the websocket event channel to contain an event that matches +-- the specified predicate. +expectWSEvent :: String + -- ^ A human-readable label for this test in case it + -- fails. + -> (WebsocketEvent -> Bool) + -- ^ The predicate to apply. + -> TestM () +expectWSEvent name match = do + chan <- gets tsWebsocketChan + let timeoutAmount = 10 * 1000 * 1000 + mEv <- liftIO $ timeout timeoutAmount $ + STM.atomically $ STM.readTChan chan + + case mEv of + Nothing -> do + let msg = "Expected a websocket event for " <> show name <> + " but timed out waiting" + print_ msg + error msg + Just ev -> when (not $ match ev) $ do + let msg = "Expected a websocket event for " <> show name <> + " but got " <> show ev + print_ msg + error msg + +-- | Does the websocket correspond to the specified user? +forUser :: User -> WebsocketEvent -> Bool +forUser u = + wsHas (wepUserId . weData) (Just $ userId u) + +-- | Does the websocket correspond to the specified channel? +forChannel :: Channel -> WebsocketEvent -> Bool +forChannel ch = + wsHas (wepChannelId . weData) (Just $ channelId ch) + +-- | Is this websocket event a status change message? +isStatusChange :: User + -- ^ The user whose status changed + -> T.Text + -- ^ The new status + -> WebsocketEvent + -> Bool +isStatusChange u s = + hasWSEventType WMStatusChange &&& + forUser u &&& + wsHas (wepStatus . weData) (Just s) + +-- | Is the websocket event indicating that a new user was added to the +-- server? +isNewUserEvent :: User + -- ^ The user that was added + -> WebsocketEvent + -> Bool +isNewUserEvent u = + hasWSEventType WMNewUser &&& forUser u + +isChannelCreatedEvent :: Channel + -> WebsocketEvent + -> Bool +isChannelCreatedEvent c = + hasWSEventType WMChannelCreated &&& forChannel c + +-- | Is the websocket event indicating that a channel was deleted? +isChannelDeleteEvent :: Channel -> WebsocketEvent -> Bool +isChannelDeleteEvent ch = + forChannel ch &&& hasWSEventType WMChannelDeleted + +-- | Is the websocket event indicating that a user joined a channel? +isUserJoin :: User + -- ^ The user that joined a channel + -> Channel + -- ^ The channel that was joined + -> WebsocketEvent + -> Bool +isUserJoin u ch = + hasWSEventType WMUserAdded &&& + forUser u &&& + wsHas (webChannelId . weBroadcast) (Just $ channelId ch) + +-- | Is the websocket event indicating that a user left a channel? +isUserLeave :: User + -- ^ The user that left a channel + -> Channel + -- ^ The channel that the user left + -> WebsocketEvent + -> Bool +isUserLeave u ch = + hasWSEventType WMUserRemoved &&& + forChannel ch &&& + wsHas (webUserId . weBroadcast) (Just $ userId u) + +-- | Is the websocket event indicating that a new message was posted to +-- a channel? +isPost :: User + -- ^ The user who posted + -> Channel + -- ^ The channel to which the new post was added + -> T.Text + -- ^ The content of the new post + -> WebsocketEvent + -> Bool +isPost u ch msg = + hasWSEventType WMPosted &&& + wsHas (\e -> postMessage <$> (wepPost $ weData e)) + (Just msg) &&& + wsHas (\e -> postChannelId <$> (wepPost $ weData e)) + (Just $ channelId ch) &&& + wsHas (\e -> postUserId =<< (wepPost $ weData e)) + (Just $ userId u) + +-- | Timeout in seconds for expectWSDone to wait before concluding that +-- no new websocket events are available. +emptyWSTimeout :: Int +emptyWSTimeout = 2 + +-- | Expect that the websocket event channel is empty. Waits up to +-- emptyWSTimeout seconds. Succeeds if no events are received; fails +-- otherwise. +expectWSDone :: TestM () +expectWSDone = do + chan <- gets tsWebsocketChan + let timeoutAmount = emptyWSTimeout * 1000 * 1000 + mEv <- liftIO $ timeout timeoutAmount $ + STM.atomically $ STM.readTChan chan + case mEv of + Nothing -> return () + Just ev -> do + let msg = "Expected no websocket events but got " <> show ev + print_ msg + error msg + +loginAdminAccount :: TestM () +loginAdminAccount = do + cfg <- gets tsConfig + let admin = Login { username = configUsername cfg + , password = configPassword cfg + } + loginAccount admin + +createAccount :: UsersCreate -> TestM User +createAccount account = do + session <- getSession + newUser <- liftIO $ mmUsersCreateWithSession session account + print_ $ "account created for " <> (T.unpack $ usersCreateUsername account) + return newUser + +createTeam :: TeamsCreate -> TestM Team +createTeam tc = do + session <- getSession + team <- liftIO $ mmCreateTeam session tc + print_ $ "Team created: " <> (T.unpack $ teamsCreateName tc) + return team + +findChannel :: Channels -> T.Text -> Channel +findChannel chans name = + let result = Seq.viewl (Seq.filter nameMatches chans) + nameMatches c = name `elem` [ channelName c + , channelDisplayName c + ] + in case result of + chan Seq.:< _ -> chan + _ -> + let namePairs = mkPair <$> chans + mkPair c = (channelName c, channelDisplayName c) + in error $ "Expected to find channel by name " <> + show name <> " but got " <> show namePairs + +connectFromConfig :: Config -> IO ConnectionData +connectFromConfig cfg = + initConnectionDataInsecure (configHostname cfg) + (fromIntegral (configPort cfg)) + +getConnection :: TestM ConnectionData +getConnection = gets tsConnectionData + +getSession :: TestM Session +getSession = do + val <- gets tsSession + case val of + Just s -> return s + Nothing -> error "Expected authentication token but none was present" + +getInitialLoad :: TestM InitialLoad +getInitialLoad = do + session <- getSession + liftIO $ mmGetInitialLoad session + +getUserByName :: T.Text -> TestM (Maybe User) +getUserByName uname = do + session <- getSession + allUserMap <- liftIO $ mmGetUsers session 0 10000 + -- Find the user matching the username and get its ID + let matches = HM.filter matchingUser allUserMap + matchingUser u = userUsername u == uname + + case HM.size matches == 1 of + False -> return Nothing + True -> do + let uId = fst $ HM.toList matches !! 0 + -- Then load the User record + Just <$> (liftIO $ mmGetUser session uId) + +createChannel :: Team -> MinChannel -> TestM Channel +createChannel team mc = do + session <- getSession + liftIO $ mmCreateChannel session (teamId team) mc + +deleteChannel :: Team -> Channel -> TestM () +deleteChannel team ch = do + session <- getSession + liftIO $ mmDeleteChannel session (teamId team) (channelId ch) + +joinChannel :: Team -> Channel -> TestM () +joinChannel team chan = do + session <- getSession + liftIO $ mmJoinChannel session (teamId team) (channelId chan) + +getMoreChannels :: Team -> TestM Channels +getMoreChannels team = do + session <- getSession + liftIO $ mmGetMoreChannels session (teamId team) 0 100 + +leaveChannel :: Team -> Channel -> TestM () +leaveChannel team chan = do + session <- getSession + liftIO $ mmLeaveChannel session (teamId team) (channelId chan) + +getChannelMembers :: Team -> Channel -> TestM [User] +getChannelMembers team chan = do + session <- getSession + (snd <$>) <$> HM.toList <$> + (liftIO $ mmGetChannelMembers session (teamId team) (channelId chan) 0 10000) + +getChannels :: Team -> TestM Channels +getChannels team = do + session <- getSession + liftIO $ mmGetChannels session (teamId team) + +getConfig :: TestM A.Value +getConfig = do + session <- getSession + liftIO $ mmGetConfig session + +saveConfig :: A.Value -> TestM () +saveConfig newConfig = do + session <- getSession + liftIO $ mmSaveConfig session newConfig + +teamAddUser :: Team -> User -> TestM () +teamAddUser team user = do + session <- getSession + liftIO $ mmTeamAddUser session (teamId team) (userId user)