1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE RecordWildCards #-}
5
6module Network.Mattermost.WebSocket.Types
7( WebsocketEventType(..)
8, WebsocketEvent(..)
9, WEData(..)
10, WEBroadcast(..)
11, WebsocketAction(..)
12, WebsocketActionResponse(..)
13, WebsocketActionStatus(..)
14) where
15
16import           Control.Applicative
17import           Control.Exception ( throw )
18import           Data.Aeson ( FromJSON(..)
19                            , ToJSON(..)
20                            , (.:)
21                            , (.:?)
22                            , (.=)
23                            )
24import qualified Data.Aeson as A
25import qualified Data.Aeson.Types as A
26#if !MIN_VERSION_base(4,11,0)
27import           Data.Monoid ( (<>) )
28#endif
29import           Data.ByteString.Lazy (fromStrict, toStrict)
30import qualified Data.ByteString.Lazy.Char8 as BC
31import qualified Data.HashMap.Strict as HM
32import           Data.Int (Int64)
33import           Data.Sequence (Seq)
34import           Data.Set (Set)
35import           Data.Text (Text)
36import qualified Data.Text as T
37import           Data.Text.Encoding (decodeUtf8, encodeUtf8)
38import           Network.WebSockets (WebSocketsData(..))
39import qualified Network.WebSockets as WS
40
41import           Network.Mattermost.Types
42import           Network.Mattermost.Exceptions
43
44
45data WebsocketEventType
46  = WMTyping
47  | WMPosted
48  | WMPostEdited
49  | WMPostDeleted
50  | WMChannelDeleted
51  | WMChannelCreated
52  | WMDirectAdded
53  | WMGroupAdded
54  | WMNewUser
55  | WMAddedToTeam
56  | WMLeaveTeam
57  | WMUpdateTeam
58  | WMTeamDeleted
59  | WMUserAdded
60  | WMUserUpdated
61  | WMUserRemoved
62  | WMPreferenceChanged
63  | WMPreferenceDeleted
64  | WMEphemeralMessage
65  | WMStatusChange
66  | WMHello
67  | WMWebRTC
68  | WMAuthenticationChallenge
69  | WMReactionAdded
70  | WMReactionRemoved
71  | WMChannelViewed
72  | WMChannelUpdated
73  | WMChannelMemberUpdated
74  | WMEmojiAdded
75  | WMUserRoleUpdated
76  | WMPluginStatusesChanged
77  | WMPluginEnabled
78  | WMPluginDisabled
79  | WMUnknownEvent T.Text
80  deriving (Read, Show, Eq, Ord)
81
82instance FromJSON WebsocketEventType where
83  parseJSON = A.withText "event type" $ \s -> case s of
84    "typing"             -> return WMTyping
85    "posted"             -> return WMPosted
86    "post_edited"        -> return WMPostEdited
87    "post_deleted"       -> return WMPostDeleted
88    "channel_deleted"    -> return WMChannelDeleted
89    "direct_added"       -> return WMDirectAdded
90    "new_user"           -> return WMNewUser
91    "leave_team"         -> return WMLeaveTeam
92    "user_added"         -> return WMUserAdded
93    "user_updated"       -> return WMUserUpdated
94    "user_removed"       -> return WMUserRemoved
95    "preferences_changed" -> return WMPreferenceChanged
96    "ephemeral_message"  -> return WMEphemeralMessage
97    "status_change"      -> return WMStatusChange
98    "hello"              -> return WMHello
99    "update_team"        -> return WMUpdateTeam
100    "delete_team"        -> return WMTeamDeleted
101    "reaction_added"     -> return WMReactionAdded
102    "reaction_removed"   -> return WMReactionRemoved
103    "channel_created"    -> return WMChannelCreated
104    "group_added"        -> return WMGroupAdded
105    "added_to_team"      -> return WMAddedToTeam
106    "webrtc"             -> return WMWebRTC
107    "authentication_challenge" -> return WMAuthenticationChallenge
108    "preferences_deleted" -> return WMPreferenceDeleted
109    "channel_viewed"     -> return WMChannelViewed
110    "channel_updated"    -> return WMChannelUpdated
111    "channel_member_updated" -> return WMChannelMemberUpdated
112    "emoji_added"        -> return WMEmojiAdded
113    "user_role_updated"  -> return WMUserRoleUpdated
114    "plugin_statuses_changed" -> return WMPluginStatusesChanged
115    "plugin_enabled"     -> return WMPluginEnabled
116    "plugin_disabled"    -> return WMPluginDisabled
117    _                    -> return $ WMUnknownEvent s
118
119instance ToJSON WebsocketEventType where
120  toJSON WMTyping                  = "typing"
121  toJSON WMPosted                  = "posted"
122  toJSON WMPostEdited              = "post_edited"
123  toJSON WMPostDeleted             = "post_deleted"
124  toJSON WMChannelDeleted          = "channel_deleted"
125  toJSON WMDirectAdded             = "direct_added"
126  toJSON WMNewUser                 = "new_user"
127  toJSON WMLeaveTeam               = "leave_team"
128  toJSON WMUserAdded               = "user_added"
129  toJSON WMUserUpdated             = "user_updated"
130  toJSON WMUserRemoved             = "user_removed"
131  toJSON WMPreferenceChanged       = "preferences_changed"
132  toJSON WMPreferenceDeleted       = "preferences_deleted"
133  toJSON WMEphemeralMessage        = "ephemeral_message"
134  toJSON WMStatusChange            = "status_change"
135  toJSON WMHello                   = "hello"
136  toJSON WMUpdateTeam              = "update_team"
137  toJSON WMTeamDeleted             = "delete_team"
138  toJSON WMReactionAdded           = "reaction_added"
139  toJSON WMReactionRemoved         = "reaction_removed"
140  toJSON WMChannelCreated          = "channel_created"
141  toJSON WMGroupAdded              = "group_added"
142  toJSON WMAddedToTeam             = "added_to_team"
143  toJSON WMWebRTC                  = "webrtc"
144  toJSON WMAuthenticationChallenge = "authentication_challenge"
145  toJSON WMChannelViewed           = "channel_viewed"
146  toJSON WMChannelUpdated          = "channel_updated"
147  toJSON WMChannelMemberUpdated    = "channel_member_updated"
148  toJSON WMEmojiAdded              = "emoji_added"
149  toJSON WMUserRoleUpdated         = "user_role_updated"
150  toJSON WMPluginStatusesChanged   = "plugin_statuses_changed"
151  toJSON WMPluginEnabled           = "plugin_enabled"
152  toJSON WMPluginDisabled          = "plugin_disabled"
153  toJSON (WMUnknownEvent s)        = toJSON s
154
155--
156
157toValueString :: ToJSON a => a -> A.Value
158toValueString v =  toJSON (decodeUtf8 (toStrict (A.encode v)))
159
160fromValueString :: FromJSON a => A.Value -> A.Parser a
161fromValueString = A.withText "string-encoded json" $ \s -> do
162    case A.eitherDecode (fromStrict (encodeUtf8 s)) of
163      Right v  -> return v
164      Left err -> throw (JSONDecodeException err (T.unpack s))
165
166--
167
168data WebsocketEvent = WebsocketEvent
169  { weEvent     :: WebsocketEventType
170  , weData      :: WEData
171  , weBroadcast :: WEBroadcast
172  , weSeq       :: Int64
173  } deriving (Read, Show, Eq)
174
175instance FromJSON WebsocketEvent where
176  parseJSON = A.withObject "WebsocketEvent" $ \o -> do
177    weEvent     <- o .: "event"
178    weData      <- o .: "data"
179    weBroadcast <- o .: "broadcast"
180    weSeq       <- o .: "seq"
181    return WebsocketEvent { .. }
182
183instance ToJSON WebsocketEvent where
184  toJSON WebsocketEvent { .. } = A.object
185    [ "event"      .= weEvent
186    , "data"       .= weData
187    , "broadcast"  .= weBroadcast
188    , "seq"        .= weSeq
189    ]
190
191instance WebSocketsData WebsocketEvent where
192  fromDataMessage (WS.Text bs _) = fromLazyByteString bs
193  fromDataMessage (WS.Binary bs) = fromLazyByteString bs
194  fromLazyByteString s = case A.eitherDecode s of
195    Left err -> throw (JSONDecodeException err (BC.unpack s))
196    Right v  -> v
197  toLazyByteString = A.encode
198
199--
200
201data WEData = WEData
202  { wepChannelId          :: Maybe ChannelId
203  , wepTeamId             :: Maybe TeamId
204  , wepSenderName         :: Maybe Text
205  , wepUserId             :: Maybe UserId
206  , wepUser               :: Maybe User
207  , wepChannelDisplayName :: Maybe Text
208  , wepPost               :: Maybe Post
209  , wepStatus             :: Maybe Text
210  , wepReaction           :: Maybe Reaction
211  , wepMentions           :: Maybe (Set UserId)
212  , wepPreferences        :: Maybe (Seq Preference)
213  , wepChannelMember      :: Maybe ChannelMember
214  } deriving (Read, Show, Eq)
215
216instance FromJSON WEData where
217  parseJSON = A.withObject "WebSocketEvent Data" $ \o -> do
218    wepChannelId          <- nullable (o .: "channel_id")
219    wepTeamId             <- maybeFail (o .: "team_id")
220    wepSenderName         <- o .:? "sender_name"
221    wepUserId             <- o .:? "user_id"
222    wepUser               <- o .:? "user"
223    wepChannelDisplayName <- o .:? "channel_name"
224    wepPost               <- mapM fromValueString =<< o .:? "post"
225    wepStatus             <- o .:? "status"
226    wepReaction           <- mapM fromValueString =<< o .:? "reaction"
227    wepMentions           <- mapM fromValueString =<< o .:? "mentions"
228    wepPreferences        <- mapM fromValueString =<< o .:? "preferences"
229    wepChannelMember      <- mapM fromValueString =<< o .:? "channelMember"
230    return WEData { .. }
231
232instance ToJSON WEData where
233  toJSON WEData { .. } = A.object
234    [ "channel_id"   .= wepChannelId
235    , "team_id"      .= wepTeamId
236    , "sender_name"  .= wepSenderName
237    , "user_id"      .= wepUserId
238    , "channel_name" .= wepChannelDisplayName
239    , "post"         .= toValueString wepPost
240    , "reaction"     .= wepReaction
241    , "mentions"     .= toValueString wepMentions
242    , "preferences"  .= toValueString wepPreferences
243    , "channelMember" .= toValueString wepChannelMember
244    ]
245
246--
247
248data WEBroadcast = WEBroadcast
249  { webChannelId :: Maybe ChannelId
250  , webUserId    :: Maybe UserId
251  , webTeamId    :: Maybe TeamId
252  , webOmitUsers :: Maybe (HM.HashMap UserId Bool)
253  } deriving (Read, Show, Eq)
254
255nullable :: Alternative f => f a -> f (Maybe a)
256nullable p = (Just <$> p) <|> pure Nothing
257
258instance FromJSON WEBroadcast where
259  parseJSON = A.withObject "WebSocketEvent Broadcast" $ \o -> do
260    webChannelId <- nullable (o .: "channel_id")
261    webTeamId    <- nullable (o .: "team_id")
262    webUserId    <- nullable (o .: "user_id")
263    webOmitUsers <- nullable (o .: "omit_users")
264    return WEBroadcast { .. }
265
266instance ToJSON WEBroadcast where
267  toJSON WEBroadcast { .. } = A.object
268    [ "channel_id" .= webChannelId
269    , "team_id"    .= webTeamId
270    , "user_id"    .= webUserId
271    , "omit_users" .= webOmitUsers
272    ]
273
274--
275
276data WebsocketAction =
277    UserTyping { waSeq          :: Int64
278               , waChannelId    :: ChannelId
279               , waParentPostId :: Maybe PostId
280               }
281  -- --  | GetStatuses { waSeq :: Int64 }
282  -- --  | GetStatusesByIds { waSeq :: Int64, waUserIds :: [UserId] }
283  deriving (Read, Show, Eq, Ord)
284
285instance ToJSON WebsocketAction where
286  toJSON (UserTyping s cId pId) = A.object
287    [ "seq"    .= s
288    , "action" .= T.pack "user_typing"
289    , "data"   .= A.object
290                  [ "channel_id" .= unId (toId cId)
291                  , "parent_id"  .= maybe "" (unId . toId) pId
292                  ]
293    ]
294
295instance WebSocketsData WebsocketAction where
296  fromDataMessage _ = error "Not implemented"
297  fromLazyByteString _ = error "Not implemented"
298  toLazyByteString = A.encode
299
300data WebsocketActionStatus =
301    WebsocketActionStatusOK
302    deriving (Read, Show, Eq, Ord)
303
304instance FromJSON WebsocketActionStatus where
305    parseJSON = A.withText "WebsocketActionStatus" $ \t ->
306        case t of
307            "OK" -> return WebsocketActionStatusOK
308            _ -> fail $ "Invalid WebsocketActionStatus: " <> show t
309
310instance ToJSON WebsocketActionStatus where
311    toJSON WebsocketActionStatusOK = "OK"
312
313data WebsocketActionResponse =
314    WebsocketActionResponse { warStatus :: WebsocketActionStatus
315                            , warSeqReply :: Int64
316                            }
317    deriving (Read, Show, Eq, Ord)
318
319instance FromJSON WebsocketActionResponse where
320  parseJSON =
321      A.withObject "WebsocketActionResponse" $ \o ->
322          WebsocketActionResponse <$> o A..: "status"
323                                  <*> o A..: "seq_reply"
324
325instance ToJSON WebsocketActionResponse where
326    toJSON (WebsocketActionResponse status s) =
327        A.object [ "status" A..= A.toJSON status
328                 , "seq" A..= A.toJSON s
329                 ]
330
331instance WebSocketsData WebsocketActionResponse where
332  fromDataMessage (WS.Text bs _) = fromLazyByteString bs
333  fromDataMessage (WS.Binary bs) = fromLazyByteString bs
334  fromLazyByteString s = case A.eitherDecode s of
335    Left err -> throw (JSONDecodeException err (BC.unpack s))
336    Right v  -> v
337  toLazyByteString = A.encode
338