packages feed

mattermost-api (empty) → 30802.1.0

raw patch · 28 files changed

+4108/−0 lines, 28 filesdep +HTTPdep +HUnitdep +aesonsetup-changed

Dependencies added: HTTP, HUnit, aeson, base, bytestring, connection, containers, cryptonite, gitrev, hashable, mattermost-api, memory, microlens, microlens-th, mtl, network-uri, pretty-show, process, stm, tasty, tasty-hunit, template-haskell, text, time, unordered-containers, websockets

Files

+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Config.hs view
@@ -0,0 +1,12 @@+module Config where++import Data.Text++data Config+  = Config+  { configUsername :: Text+  , configHostname :: Text+  , configTeam     :: Text+  , configPort     :: Int+  , configPassword :: Text+  }
+ examples/GetChannels.hs view
@@ -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 ""
+ examples/GetPosts.hs view
@@ -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
+ examples/GetTeams.hs view
@@ -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
+ examples/GetWebsocketConnection.hs view
@@ -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
+ examples/LocalConfig.hs view
@@ -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+         }
+ examples/MakePost.hs view
@@ -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)
+ examples/ShowRawEvents.hs view
@@ -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 ()
+ mattermost-api.cabal view
@@ -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
+ src/Network/Mattermost.hs view
@@ -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
+ src/Network/Mattermost/Exceptions.hs view
@@ -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
+ src/Network/Mattermost/Lenses.hs view
@@ -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
+ src/Network/Mattermost/Logging.hs view
@@ -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
+ src/Network/Mattermost/TH.hs view
@@ -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"])
+ src/Network/Mattermost/Types.hs view
@@ -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+    ]
+ src/Network/Mattermost/Types/Base.hs view
@@ -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)
+ src/Network/Mattermost/Types/Internal.hs view
@@ -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+  }
+ src/Network/Mattermost/Util.hs view
@@ -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))
+ src/Network/Mattermost/Version.hs view
@@ -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) ++ ")"
+ src/Network/Mattermost/WebSocket.hs view
@@ -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
+ src/Network/Mattermost/WebSocket/Types.hs view
@@ -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+    ]
+ test/Main.hs view
@@ -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
+ test/Tests/Types.hs view
@@ -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 ()+              }
+ test/Tests/Util.hs view
@@ -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)