diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/danibot.cabal b/danibot.cabal new file mode 100644 --- /dev/null +++ b/danibot.cabal @@ -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 diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -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))) + diff --git a/lib/Network/Danibot.hs b/lib/Network/Danibot.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Danibot.hs @@ -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." + diff --git a/lib/Network/Danibot/Main.hs b/lib/Network/Danibot/Main.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Danibot/Main.hs @@ -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 () + diff --git a/lib/Network/Danibot/Slack.hs b/lib/Network/Danibot/Slack.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Danibot/Slack.hs @@ -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)) + diff --git a/lib/Network/Danibot/Slack/API.hs b/lib/Network/Danibot/Slack/API.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Danibot/Slack/API.hs @@ -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" + diff --git a/lib/Network/Danibot/Slack/RTM.hs b/lib/Network/Danibot/Slack/RTM.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Danibot/Slack/RTM.hs @@ -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) diff --git a/lib/Network/Danibot/Slack/Types.hs b/lib/Network/Danibot/Slack/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Network/Danibot/Slack/Types.hs @@ -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 + ] +