Browse Source

Basic data structures in place for viewing

Getty Ritter 3 years ago
commit
4d3ed9a417
6 changed files with 232 additions and 0 deletions
  1. 5
    0
      .gitignore
  2. 12
    0
      LICENSE
  3. 31
    0
      mattermost-demo-client.cabal
  4. 49
    0
      src/Config.hs
  5. 114
    0
      src/Main.hs
  6. 21
    0
      src/State.hs

+ 5
- 0
.gitignore View File

@@ -0,0 +1,5 @@
1
+config.json
2
+cabal.project.local
3
+dist
4
+dist-newstyle
5
+*~

+ 12
- 0
LICENSE View File

@@ -0,0 +1,12 @@
1
+Copyright (c) 2016, Getty Ritter
2
+All rights reserved.
3
+
4
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5
+
6
+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7
+
8
+2. 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.
9
+
10
+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11
+
12
+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 HOLDER 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.

+ 31
- 0
mattermost-demo-client.cabal View File

@@ -0,0 +1,31 @@
1
+name:             mattermost-demo-client
2
+version:          0.1.0.0
3
+-- synopsis:
4
+-- description:
5
+license:          BSD3
6
+license-file:     LICENSE
7
+author:           Getty Ritter <gdritter@galois.com>
8
+maintainer:       Getty Ritter <gdritter@galois.com>
9
+copyright:        ©2016 Getty Ritter
10
+-- category:
11
+build-type:       Simple
12
+cabal-version:    >= 1.12
13
+
14
+executable mm-track
15
+  hs-source-dirs:      src
16
+  main-is:             Main.hs
17
+  other-modules:       Config
18
+                       State
19
+  default-extensions:  OverloadedStrings,
20
+                       ScopedTypeVariables
21
+  ghc-options:         -Wall
22
+  build-depends:       base >=4.7 && <4.9
23
+                     , mattermost-api
24
+                     , unordered-containers
25
+                     , text
26
+                     , bytestring
27
+                     , aeson
28
+                     , process
29
+                     , connection
30
+                     , microlens-platform
31
+  default-language:    Haskell2010

+ 49
- 0
src/Config.hs View File

@@ -0,0 +1,49 @@
1
+{-# LANGUAGE RecordWildCards #-}
2
+
3
+module Config (Config(..), getConfig) where
4
+
5
+import           Data.Aeson
6
+import qualified Data.ByteString.Lazy as BS
7
+import           Data.Text (Text)
8
+import qualified Data.Text as T
9
+import           System.Exit (exitFailure)
10
+import           System.Process (readProcess)
11
+
12
+data Config = Config
13
+  { configUser     :: Text
14
+  , configHost     :: Text
15
+  , configTeam     :: Text
16
+  , configPort     :: Int
17
+  , configPass     :: Either String Text
18
+  } deriving (Eq, Show)
19
+
20
+instance FromJSON Config where
21
+  parseJSON = withObject "config" $ \o -> do
22
+    configUser <- o .:  "user"
23
+    configHost <- o .:  "host"
24
+    configTeam <- o .:  "team"
25
+    configPort <- o .:  "port"
26
+    passCmd    <- o .:? "passcmd"
27
+    pass       <- o .:? "pass"
28
+    configPass <- case passCmd of
29
+      Nothing -> case pass of
30
+        Nothing     -> fail "Configuration needs either `pass` or `passcmd`"
31
+        Just passwd -> return (Right passwd)
32
+      Just cmd -> return (Left cmd)
33
+    return Config { .. }
34
+
35
+getConfig :: IO Config
36
+getConfig = do
37
+  bs <- BS.readFile "config.json"
38
+  case decode bs of
39
+    Nothing   -> do
40
+      putStrLn "No config.json found"
41
+      exitFailure
42
+    Just conf -> do
43
+      actualPass <- case configPass conf of
44
+        Left cmdString -> do
45
+          let (cmd:rest) = words cmdString
46
+          r <- readProcess cmd rest ""
47
+          return (T.pack (takeWhile (/= '\n') r))
48
+        Right pass -> return pass
49
+      return conf { configPass = Right actualPass }

+ 114
- 0
src/Main.hs View File

@@ -0,0 +1,114 @@
1
+{-# LANGUAGE RecordWildCards #-}
2
+
3
+module Main where
4
+
5
+import           Control.Monad (join, forM, forM_)
6
+import           Data.HashMap.Strict ((!))
7
+import qualified Data.HashMap.Strict as HM
8
+import           Data.IORef
9
+import qualified Data.Text as T
10
+import           Lens.Micro.Platform
11
+
12
+import           Network.Connection
13
+import           Network.Mattermost
14
+import           Network.Mattermost.Lenses
15
+import           Network.Mattermost.WebSocket
16
+import           Network.Mattermost.WebSocket.Types
17
+
18
+import           Config
19
+import           State
20
+
21
+editMessage :: Post -> StateRef -> IO ()
22
+editMessage new stRef = modifyIORef stRef $ \ st ->
23
+  st & msgMap . ix (postChannelId new) . postsPostsL . ix (getId new) .~ new
24
+
25
+addMessage :: Post -> StateRef -> IO ()
26
+addMessage new stRef = modifyIORef stRef $ \ st ->
27
+  st & msgMap . ix (postChannelId new) . postsPostsL . ix (getId new) .~ new
28
+     & msgMap . ix (postChannelId new) . postsOrderL %~ (getId new :)
29
+
30
+getMessageListing :: ChannelId -> StateRef -> IO [(String, String)]
31
+getMessageListing cId stRef = do
32
+  st <- readIORef stRef
33
+  let us = st ^. usrMap
34
+  let ps = st ^. msgMap . ix cId . postsPostsL
35
+  let is = st ^. msgMap . ix cId . postsOrderL
36
+  return $ reverse
37
+    [ ( userProfileUsername (us ! postUserId p), postMessage p)
38
+    | i <- is
39
+    , let p = ps ! i
40
+    ]
41
+
42
+main :: IO ()
43
+main = do
44
+  config <- getConfig
45
+  ctx <- initConnectionContext
46
+  let cd = mkConnectionData (T.unpack (configHost config))
47
+                            (fromIntegral (configPort config))
48
+                            ctx
49
+      Right pass = configPass config
50
+      login = Login { username = configUser config
51
+                    , password = pass
52
+                    , teamname = configTeam config
53
+                    }
54
+
55
+  (token, myUser) <- join (hoistE <$> mmLogin cd login)
56
+
57
+  teamMap <- mmGetTeams cd token
58
+  let [myTeam] = [ t | t <- HM.elems teamMap
59
+                     , teamName t == T.unpack (configTeam config)
60
+                     ]
61
+
62
+  Channels chans _ <- mmGetChannels cd token (getId myTeam)
63
+
64
+  msgs <- fmap HM.fromList $ forM chans $ \c -> do
65
+    posts <- mmGetPosts cd token (getId myTeam) (getId c) 0 30
66
+    return (getId c, posts)
67
+
68
+  users <- mmGetProfiles cd token (getId myTeam)
69
+
70
+  st <- newIORef $ newState & chnMap .~ HM.fromList [ (getId c, c)
71
+                                                    | c <- chans
72
+                                                    ]
73
+                            & usrMap .~ users
74
+                            & msgMap .~ msgs
75
+
76
+  putStrLn "Ready."
77
+  mmWithWebSocket cd token (onEvent st)
78
+                           (handleInput st)
79
+
80
+onEvent :: StateRef -> WebsocketEvent -> IO ()
81
+onEvent st we = do
82
+  case weAction we of
83
+    WMPosted -> case wepPost (weProps we) of
84
+      Just p  -> addMessage p st
85
+      Nothing -> return ()
86
+    WMPostEdited -> case wepPost (weProps we) of
87
+      Just p  -> editMessage p st
88
+      Nothing -> return ()
89
+    WMPostDeleted -> case wepPost (weProps we) of
90
+      Just p  -> editMessage p { postMessage = "[deleted]" } st
91
+      Nothing -> return ()
92
+    _ -> return ()
93
+
94
+
95
+handleInput :: StateRef -> MMWebSocket -> IO ()
96
+handleInput st ws = do
97
+  ln <- getLine
98
+  case words ln of
99
+    ["show", chan] -> do
100
+      ChatState { _chnMap = cs } <- readIORef st
101
+      case [ c | c <- HM.elems cs, channelName c == chan ] of
102
+        c:_ -> do
103
+          ms <- getMessageListing (channelId c) st
104
+          forM_ ms $ \ (u, m) -> do
105
+            putStrLn ("@" ++ u ++ ":  " ++ m)
106
+          handleInput st ws
107
+        _ -> do
108
+          putStrLn ("cannot find " ++ chan)
109
+          handleInput st ws
110
+    ["quit"] -> do
111
+      mmCloseWebSocket ws
112
+    cmd -> do
113
+      putStrLn ("I don't know how to " ++ unwords cmd)
114
+      handleInput st ws

+ 21
- 0
src/State.hs View File

@@ -0,0 +1,21 @@
1
+{-# LANGUAGE TemplateHaskell #-}
2
+
3
+module State where
4
+
5
+import Data.HashMap.Strict (HashMap, empty)
6
+import Data.IORef (IORef)
7
+import Lens.Micro.Platform
8
+import Network.Mattermost
9
+
10
+data ChatState = ChatState
11
+  { _chnMap :: HashMap ChannelId Channel
12
+  , _msgMap :: HashMap ChannelId Posts
13
+  , _usrMap :: HashMap UserId UserProfile
14
+  } deriving (Eq, Show)
15
+
16
+newState :: ChatState
17
+newState = ChatState empty empty empty
18
+
19
+type StateRef = IORef ChatState
20
+
21
+makeLenses ''ChatState

Loading…
Cancel
Save