danibot (empty) → 0.2.0.0
raw patch · 12 files changed
+849/−0 lines, 12 filesdep +aesondep +asyncdep +attoparsecsetup-changed
Dependencies added: aeson, async, attoparsec, base, bytestring, conceit, containers, danibot, foldl, lens, lens-aeson, monoid-subclasses, network, optparse-applicative, stm, streaming, text, transformers, websockets, wreq, wuss
Files
- CHANGELOG +0/−0
- LICENSE +21/−0
- README.md +30/−0
- Setup.hs +2/−0
- danibot.cabal +62/−0
- exe/Main.hs +40/−0
- lib/Network/Danibot.hs +104/−0
- lib/Network/Danibot/Main.hs +77/−0
- lib/Network/Danibot/Slack.hs +124/−0
- lib/Network/Danibot/Slack/API.hs +46/−0
- lib/Network/Danibot/Slack/RTM.hs +75/−0
- lib/Network/Danibot/Slack/Types.hs +268/−0
+ CHANGELOG view
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2016 Daniel Díaz Carrete++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,30 @@+A very basic framework for creating Slack bots.++The bot will respond to messages in IM channels, and also to messages+explicitly directed at him in general channels (`@nameofthebot: some message`).++The bot reads the Slack api token from the environment variable+"DANIBOT_SLACK_API_TOKEN".++The default danibot executable comes with a few example handlers:++- *up? host port* ++ Checks if a port is open in a host.++- *lookup key* ++ Checks the value of key in a dictionary that is loaded at+ startup with the --dict parameter. The dictionary is a json object with+ string values.++- *help* ++ Lists available options.++Right now the bot ignores most chat events apart from messages.++To create your own customized bot, import `Network.Danibot.Main` and pass a+value of type `IO (Either String (Text -> IO Text))` to `mainWith`, where `Text+-> IO Text` is the type of the handler function.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ danibot.cabal view
@@ -0,0 +1,62 @@+Name: danibot+Version: 0.2.0.0+Cabal-Version: >=1.10+Build-Type: Simple+License: MIT+License-File: LICENSE+Copyright: 2015 Daniel Diaz+Author: Daniel Diaz+Maintainer: diaz_carrete@yahoo.com+Bug-Reports: https://github.com/danidiaz/danibot/issues+Synopsis: Basic Slack bot framework.+Category: Network++extra-source-files:+ README.md+ CHANGELOG++source-repository head+ type: git+ location: git@github.com:danidiaz/danibot.git++executable danibot+ hs-source-dirs: exe+ main-is: Main.hs+ default-language: Haskell2010+ ghc-options: -Wall -threaded -O2+ build-depends: + base >= 4.7 && < 5+ , optparse-applicative >= 0.12.1.0+ , danibot++library+ hs-source-dirs: lib+ default-language: Haskell2010+ build-depends:+ base >= 4 && < 5 + , transformers >= 0.4.3.0+ , wreq >= 0.4.1.0 + , network >= 2.6+ , websockets >= 0.9.6.0+ , wuss >= 1.0.2+ , aeson >= 0.11.0.0+ , bytestring >= 0.10.6.0+ , text >= 1.2.2.0+ , lens >= 4.5+ , lens-aeson >= 1.0.0.0 + , monoid-subclasses >= 0.4.2+ , containers >= 0.5+ , conceit >= 0.4.0.0+ , attoparsec >= 0.13+ , stm >= 2.4.4+ , async >= 2.1.0+ , foldl >= 1.1.5+ , streaming >= 0.1.4+ exposed-modules:+ Network.Danibot+ Network.Danibot.Main+ Network.Danibot.Slack+ Network.Danibot.Slack.Types+ Network.Danibot.Slack.API+ Network.Danibot.Slack.RTM+ ghc-options: -O2 -Wall
+ exe/Main.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (+ main+ ) where++import Data.Monoid+import Network.Danibot+import Network.Danibot.Main (mainWith,readJSON)++import Options.Applicative +import qualified Options.Applicative as Options++data Args = Args+ {+ dictPath :: Maybe String+ } deriving (Show)++parserInfo :: Options.ParserInfo Args+parserInfo = + info (helper <*> parser) infoMod+ where+ parser = + Args <$> optional (strOption (help "json dict file" <> + long "dict" <> + metavar "DICT"))+ infoMod = + fullDesc <> header "program desc" ++main :: IO ()+main = do+ args <- Options.execParser parserInfo+ mdict <- mapM readJSON (dictPath args) + let dict = maybe mempty id mdict+ handlers = [("nop",dumbHandler)+ ,("up?",isUpHandler)+ ,("lookup",lookupHandler dict)]+ handlersWithHelp = [("help", helpHandler handlers)] ++ handlers + mainWith (pure (Right (dispatch handlersWithHelp)))+
+ lib/Network/Danibot.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumDecimals #-}+{-# LANGUAGE ViewPatterns #-}++module Network.Danibot (+ Command+ , Description+ , dumbHandler+ , lookupHandler+ , isUpHandler+ , helpHandler+ , dispatch+ ) where++import Data.Monoid+import Data.Char+import Data.Map+import Data.List+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Attoparsec.Text as Atto+import Text.Read+import Control.Applicative+import Control.Concurrent+import Control.Concurrent.Async+import Network+import System.IO+import Control.Exception++type Command = Text++type Description = Text++{-| Waits half a second, does nothing. ++-}+dumbHandler :: (Text -> IO Text,Description)+dumbHandler = + let go _ = do + threadDelay 0.5e6+ return "Nothing was done."+ in (go,"")++{-| Performs lookups against an in-memory map. ++-}+lookupHandler :: Map Text Text -> (Text -> IO Text,Description) +lookupHandler aMap = + let go key = pure (maybe "Entry not found." id (Map.lookup key aMap))+ in (go,"key") ++{-| Is the given port listening on the given host? ++-}+isUpHandler :: (Text -> IO Text,Description)+isUpHandler =+ let go (Text.break isSpace . Text.strip -> (Text.strip -> host,Text.strip -> port)) = do + case (extractAddress host, readMaybe (Text.unpack port)) of+ (Right host', Just numericport) -> do+ let attempt =+ catchAny+ (bracket (Network.connectTo (Text.unpack host') (PortNumber (fromInteger numericport)))+ hClose+ (\_ -> pure "The port is listening."))+ (\e -> pure ("Exception when trying to connect: " <> Text.pack (show e)))+ either id id <$> race attempt (threadDelay 3e6 *> pure "Timeout.")+ _ -> pure "Expected arguments: host port"+ in (go, "host port")+ where+ catchAny :: IO a -> (SomeException -> IO a) -> IO a+ catchAny = catch++ extractAddress :: Text -> Either String Text+ extractAddress txt = Atto.parseOnly extractor txt+ where+ extractor = + (Atto.string "<" *> Atto.takeTill (\c -> c == '|') + *> Atto.string "|"+ *> Atto.takeTill (\c -> c == '>') + <* Atto.string ">")+ <|>+ Atto.takeText++{-| Builds the help message. ++-}+helpHandler :: [(Command,(Text -> IO Text,Description))] -> (Text -> IO Text, Description)+helpHandler handlers = + let helptext = mconcat (intersperse "\n" [k <> " " <> v | (k,(_,v)) <- handlers])+ in (\_ -> pure helptext,"")++splitWord :: Text -> (Text,Text)+splitWord (Text.break isSpace . Text.strip -> (Text.strip -> word,Text.strip -> rest)) = (word,rest)++{-| Builds a handler from a list of command names and sub-handlers. ++-}+dispatch :: [(Command,(Text -> IO Text,x))] -> Text -> IO Text+dispatch (Map.fromList -> handlers) (splitWord -> (key,request)) = + case Map.lookup key handlers of+ Just (f,_) -> f request+ Nothing -> pure "Unknown command."+
+ lib/Network/Danibot/Main.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.Danibot.Main (+ mainWith+ , readJSON+ ) where++import Data.Function ((&))+import qualified Data.ByteString as Bytes+import Data.Text (Text)+import Data.String+import Data.Aeson (FromJSON,eitherDecodeStrict')++import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Except+import qualified Control.Foldl as Foldl++import Control.Concurrent.Conceit++import System.Environment (lookupEnv)+import System.IO++import Network.Danibot.Slack +import Network.Danibot.Slack.Types (introUrl,introChat)+import Network.Danibot.Slack.API (startRTM)+import Network.Danibot.Slack.RTM (fromWSSURI,loopRTM)++slack_api_token_env_var :: String+slack_api_token_env_var = "DANIBOT_SLACK_API_TOKEN"++slack_api_token_env_var_missing :: String +slack_api_token_env_var_missing = + "Environment variable " ++ + slack_api_token_env_var +++ " not found."++{-| Read a configuration value from a JSON file. ++-}+readJSON :: FromJSON a => FilePath -> IO a+readJSON path = do+ bytes <- Bytes.readFile path+ case eitherDecodeStrict' bytes of + Right dict -> pure dict+ Left err -> throwIO (userError err)++exceptMain :: IO (Either String (Text -> IO Text)) -> ExceptT String IO ()+exceptMain handlerio = do+ slack_api_token <- ExceptT (fmap (maybe (Left slack_api_token_env_var_missing) + (Right . fromString))+ (lookupEnv "DANIBOT_SLACK_API_TOKEN"))+ handler <- ExceptT handlerio+ intro <- ExceptT (startRTM slack_api_token)+ liftIO (print intro)+ endpoint <- fromWSSURI (introUrl intro)+ & either throwE pure+ (workChan,workerAction) <- liftIO (worker handler)+ (chatState,source) <- liftIO (makeChatState (introChat intro))+ let theEventFold = eventFold workChan chatState+ liftIO (_runConceit (_Conceit (loopRTM theEventFold source endpoint) + *> _Conceit workerAction))++{-| Create a main from an action that either fails with an error or returns a+ handler for incoming messages. ++-}+mainWith :: IO (Either String (Text -> IO Text)) -> IO ()+mainWith handlerio = do+ final <- runExceptT (exceptMain handlerio)+ case final of+ Left err -> print err+ Right () -> pure ()+
+ lib/Network/Danibot/Slack.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Danibot.Slack (+ worker+ , makeChatState+ , eventFold+ ) where++import Data.Text (Text)+import Data.Char+import qualified Data.Attoparsec.Text as Atto++import Control.Lens+import Control.Exception+import Control.Monad+import Streaming (Stream)+import Streaming.Prelude (Of)+import qualified Streaming.Prelude as Streaming+import Control.Foldl (FoldM(..))+import Control.Concurrent+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar+import Control.Concurrent.STM.TChan++import Network.Danibot.Slack.Types ++{-| Takes a request handling function, returns a channel that takes+ (requests,post-processing actions) along with a worker action that drains the+ channel and forks a thread for each request. ++-}+worker :: (Text -> IO Text) -- ^ A request handler function.+ -> IO (TChan (Text,Text -> IO ()), IO ()) -- ^ Action that creates the request channel and worker action.+worker handler = do+ chan <- atomically newTChan + let go = forever (do (task,post) <- atomically (readTChan chan)+ forkIO (do+ result <- handler task+ post result))+ pure (chan,go) ++{-| Builds a Fold that consumes messages coming from the Slack RTM connection. ++-}+eventFold :: TChan (Text,Text -> IO ()) + -> ChatState+ -> FoldM IO Event ()+eventFold pool cs =+ FoldM reactToEvent (pure InitialState) (\_ -> pure ())+ where+ reactToEvent protocolState event =+ case (protocolState,event) of+ (InitialState,HelloEvent) -> + pure NormalState+ (InitialState,_) -> + throwIO (userError "wrong start")+ (NormalState,MessageEvent (Message _ (Right (UserMessage channel_ user_ text_ NotMe)))) -> do+ currentcs <- atomically (readTVar (chatVar cs)) + let whoami = identity (self currentcs) + send = sendMessageToChannel cs channel_+ if has (ims.ix channel_) currentcs + then -- IM message?+ case isDirectedTo text_ of+ Just (target,text') | user_ /= whoami && target == whoami -> do+ atomically (writeTChan pool + (text',send))+ Nothing | user_ /= whoami -> do+ atomically (writeTChan pool + (text_,send))+ _ -> pure ()+ else -- message in general channel? + case isDirectedTo text_ of+ Just (target,text') | user_ /= whoami && target == whoami -> do+ atomically (writeTChan pool + (text',send . addressTo user_))+ _ -> pure ()+ pure NormalState+ _ -> do+ pure NormalState++data ChatState = ChatState+ {+ chatVar :: TVar Chat + , nextMsgIdVar :: TVar Integer + , outboundChan :: TChan OutboundMessage + } ++makeChatState :: Chat -> IO (ChatState, Stream (Of OutboundMessage) IO ())+makeChatState c = do+ chatVar' <- atomically (newTVar c)+ nextMsgIdVar' <- atomically (newTVar 0)+ outboundChan' <- atomically newTChan + pure (ChatState chatVar' nextMsgIdVar' outboundChan'+ ,Streaming.repeatM (atomically (readTChan outboundChan')))++data ProtocolState = + InitialState+ | NormalState++isDirectedTo :: Text -> Maybe (Text,Text)+isDirectedTo txt = case Atto.parse mentionParser txt of+ Atto.Done rest userId_ -> Just (userId_,rest)+ _ -> Nothing+ where+ mentionParser = + Atto.string "<@" + *> + Atto.takeWhile isAlphaNum + <* + Atto.string ">:"+ <* + Atto.skipSpace++addressTo :: Text -> Text -> Text+addressTo uid msg = mconcat ["<@",uid,">: ",msg]++sendMessageToChannel :: ChatState -> Text -> Text -> IO () +sendMessageToChannel cstate channelId_ msg = do+ atomically (do+ i <- readTVar (nextMsgIdVar cstate)+ modifyTVar' (nextMsgIdVar cstate) succ + writeTChan (outboundChan cstate) + (OutboundMessage i channelId_ msg)) +
+ lib/Network/Danibot/Slack/API.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Danibot.Slack.API (+ AuthToken+ , startRTM+ ) where++import Control.Lens+import Data.Aeson (Value(..),fromJSON,toJSON,Result(Error,Success))+import Data.Aeson.Lens+import Data.Text (Text)+import qualified Data.Monoid.Textual as Textual+import qualified Network.Wreq as Wreq++import Network.Danibot.Slack.Types (Wire(..),Intro(..))++type AuthToken = Text++{-| Start a connection with the Slack RTM and return the initial state of the+ chat. ++-}+startRTM :: AuthToken -> IO (Either String Intro)+startRTM authToken = do + resp <- Wreq.postWith (withToken authToken) + "https://slack.com/api/rtm.start" + (toJSON ())+ respJSON <- view Wreq.responseBody <$> Wreq.asJSON resp+ pure (checkResp respJSON)++withToken :: AuthToken -> Wreq.Options+withToken token = + Wreq.defaults+ & set (Wreq.param "token") [token]++checkResp :: Value -> Either String Intro+checkResp v =+ let parsedOk = v^?key "ok"._Bool+ parsedIntro = fromJSON v+ parsedError = v^?key "error"._String+ in case (parsedOk,parsedIntro,parsedError) of+ (Just True ,Success (Wire info),_ ) -> Right info+ (Just False,_ ,Just err) -> Left (Textual.fromText err)+ (_ ,Error err ,_ ) -> Left err+ _ -> Left "malformed response"+
+ lib/Network/Danibot/Slack/RTM.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module Network.Danibot.Slack.RTM (+ fromWSSURI+ , loopRTM+ ) where++import qualified Data.Monoid.Cancellative as Textual+import qualified Data.Monoid.Textual as Textual+import Data.Text (Text)+import Data.ByteString (ByteString)+import qualified Data.ByteString +import qualified Data.ByteString.Lazy.Char8 as Bytes.Lazy.Char8+import Data.Aeson (eitherDecode',encode)+import Control.Monad+import Control.Monad.IO.Class+import Control.Exception+import Control.Concurrent.Conceit+import Control.Foldl (impurely,FoldM)+import Streaming (Stream)+import Streaming.Prelude (Of)+import qualified Streaming as Streaming+import qualified Streaming.Prelude as Streaming+import qualified Wuss+import qualified Network.WebSockets as Webs++import Network.Danibot.Slack.Types(Wire(..),Event(..),OutboundMessage(..))++data WSSEndpoint = WSSEndpoint+ {+ host :: Text+ , path :: Text + } deriving (Show)++fromWSSURI :: Text -> Either String WSSEndpoint+fromWSSURI uri = + case Textual.stripPrefix "wss://" uri of+ Nothing -> Left "malformed wss uri"+ Just uri' -> case Textual.break_ True (=='/') uri' of+ (host,web) -> Right (WSSEndpoint host web)++{-| Connect to the Slack RTM websocket. ++-}+ws :: FoldM IO Event () -- ^ Fold for processing incoming messages.+ -> Stream (Of OutboundMessage) IO () -- ^ Stream that produces outbound messages.+ -> Webs.ClientApp ()+ws eventFold messageStream connection = + let conceited =+ (_Conceit (impurely Streaming.foldM_ eventFold eventStream))+ *> + (_Conceit (Streaming.mapM_ sendMessage messageStream))+ eventStream = forever (do+ message <- liftIO (Webs.receiveData connection)+ case eitherDecode' message of+ Left errmsg -> + liftIO (throwIO (userError ("Malformed msg: " ++ errmsg)))+ Right (Wire event) -> do+ liftIO (Bytes.Lazy.Char8.putStrLn (encode event))+ Streaming.yield event)+ sendMessage = + Webs.sendTextData connection . encode . Wire+ in _runConceit conceited+++loopRTM :: FoldM IO Event ()+ -> Stream (Of OutboundMessage) IO ()+ -> WSSEndpoint + -> IO ()+loopRTM eventHandler messageEmitter (WSSEndpoint host path) = do + Wuss.runSecureClient (Textual.fromText host) + 443+ (Textual.fromText path) + (ws eventHandler messageEmitter)
+ lib/Network/Danibot/Slack/Types.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveAnyClass #-}++module Network.Danibot.Slack.Types where++import Data.Map.Strict (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Aeson+import Data.Aeson.Types+import Control.Applicative+import Control.Lens (Lens',lens)++import GHC.Generics++{-| Newtype that marks the values that go "over the wire". ++-}+newtype Wire a = Wire { unWire :: a } deriving (Show,Functor)++instance Identified i => Identified (Wire i) where+ identity (Wire i) = identity i++class Identified i where+ identity :: i -> Text++class Named n where+ name :: n -> Text++{-| The initial information returned by the Slack API when the RTM is started.++-}+data Intro = Intro+ {+ introUrl :: Text+ , introChat :: Chat+ } deriving (Generic,Show)++instance ToJSON Intro++instance FromJSON (Wire Intro) where+ parseJSON (Object v) = + let introParser = Intro+ <$> v .: "url"+ <*> chatParser + chatParser = Chat+ <$> (unWire <$> v .: "self")+ <*> (unWire <$> v .: "team")+ <*> (mapify <$> v .: "users")+ <*> (mapify <$> v .: "channels")+ <*> (mapify <$> v .: "groups")+ <*> (mapify <$> v .: "ims")+ mapify es = + Map.fromList (zip (map identity es) (map unWire es))+ in Wire <$> introParser+ parseJSON _ = empty++data Chat = Chat+ {+ self :: !Self+ , team :: !Team+ , users :: !(Map Text User)+ , channels :: !(Map Text Channel)+ , groups :: !(Map Text Group)+ , _ims :: !(Map Text IM)+ } deriving (Generic,Show,ToJSON)++ims :: Lens' Chat (Map Text IM)+ims = lens _ims (\s b -> s { _ims = b })++data Self = Self+ {+ selfId :: Text+ , selfName :: Text+ } deriving (Generic,Show,ToJSON)++instance Identified Self where+ identity = selfId++instance Named Self where+ name = selfName++instance FromJSON (Wire Self) where+ parseJSON (Object v) = Wire <$> (Self+ <$> v .: "id"+ <*> v .: "name")+ parseJSON _ = empty++data Team = Team+ {+ teamId :: Text+ , teamName :: Text+ } deriving (Generic,Show,ToJSON)++instance Identified Team where+ identity = teamId++instance Named Team where+ name = teamName++instance FromJSON (Wire Team) where+ parseJSON (Object v) = Wire <$> (Team+ <$> v .: "id"+ <*> v .: "name")+ parseJSON _ = empty++data User = User+ {+ userId :: Text+ , userName :: Text+ } deriving (Generic,Show,ToJSON)++instance Identified User where+ identity = userId++instance Named User where+ name = userName++instance FromJSON (Wire User) where+ parseJSON (Object v) = Wire <$> (User+ <$> v .: "id"+ <*> v .: "name")+ parseJSON _ = empty++data Channel = Channel+ {+ channelId :: Text+ , channelName :: Text+ , isMember :: Bool+ , isGeneral :: Bool+ } deriving (Generic,Show,ToJSON)++instance Identified Channel where+ identity = channelId++instance Named Channel where+ name = channelName++instance FromJSON (Wire Channel) where+ parseJSON (Object v) = Wire <$> (Channel+ <$> v .: "id"+ <*> v .: "name"+ <*> v .: "is_member"+ <*> v .: "is_general")+ parseJSON _ = empty++data Group = Group+ {+ groupId :: Text+ , groupName :: Text+ , members :: [Text]+ } deriving (Generic,Show,ToJSON)++instance Identified Group where+ identity = groupId++instance Named Group where+ name = groupName++instance FromJSON (Wire Group) where+ parseJSON (Object v) = Wire <$> (Group+ <$> v .: "id"+ <*> v .: "name"+ <*> v .: "members")+ parseJSON _ = empty++data IM = IM+ {+ imId :: Text+ , user :: Text+ } deriving (Generic,Show,ToJSON)++instance Identified IM where+ identity = imId++instance FromJSON (Wire IM) where+ parseJSON (Object v) = Wire <$> (IM+ <$> v .: "id"+ <*> v .: "user")+ parseJSON _ = empty++data Message = Message {+ messageTs :: Text+ , messageValue :: Either Value UserMessage+ } deriving (Generic,Show,ToJSON)++data Me = Me | NotMe deriving (Generic,Show)++instance ToJSON Me++data UserMessage = UserMessage + {+ messageChannel :: Text+ , messageUser :: Text+ , messageText :: Text+ , messageMe :: Me+ } deriving (Generic,Show,ToJSON)++instance FromJSON (Wire Message) where+ parseJSON (Object v) = Wire <$> (do+ ts <- v .: "ts" + subtype <- v .:? "subtype" .!= Text.empty+ let me = if subtype == "me_message" + then Me + else NotMe + msgval <- if any (==subtype) ["","me_message"]+ then do+ channel_ <- v .: "channel"+ user_ <- v .: "user"+ text_ <- v .: "text" + pure (Right (UserMessage channel_ user_ text_ me))+ else + pure (Left (Object v))+ pure (Message ts msgval))+ parseJSON _ = empty++data ChannelUser = ChannelUser+ {+ cuChannel :: Text+ , cuUser :: Text+ } deriving (Generic,Show,ToJSON)++instance FromJSON (Wire ChannelUser) where+ parseJSON (Object v) = Wire <$> (ChannelUser+ <$> v .: "channel"+ <*> v .: "user")+ parseJSON _ = empty++data Event =+ HelloEvent+ | MessageEvent Message+ | UserTypingEvent ChannelUser+ | GeneralEvent Value + deriving (Generic,Show,ToJSON)++instance FromJSON (Wire Event) where+ parseJSON (Object v) = Wire <$> (do+ eventType <- v .:? "type"+ case eventType :: Maybe Text of+ Just "hello" -> + pure HelloEvent + Just "message" -> + MessageEvent . unWire <$> parseJSON (Object v)+ Just "user_typing" -> + UserTypingEvent . unWire <$> parseJSON (Object v)+ _ -> pure (GeneralEvent (Object v))) + parseJSON _ = empty++data OutboundMessage = OutboundMessage+ {+ outboundMessageId :: Integer+ , outboundMessageChannel :: Text + , outboundMessageText :: Text + } deriving (Generic,Show,ToJSON) ++instance ToJSON (Wire OutboundMessage) where+ toJSON (Wire (OutboundMessage msgid ch txt)) = object [+ "type" .= ("message" :: Text)+ , "id" .= msgid+ , "channel" .= ch + , "text" .= txt+ ]+