diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright James Dabbs (c) 2016 + +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 Author name here 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. 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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Main where + +import Replicant +import qualified Replicant.Adapters.CLI as CLI + +import Control.Monad (void) +import Control.Monad.Except (throwError) +import Control.Monad.Reader (asks, liftIO) +import qualified Database.Redis.Namespace as R + +type B = ReplicantT AppError AppConf IO + +data AppConf = AppConf + { connection :: R.Connection + , working :: Supervisor B BotId + } + +data AppError = RedisError | OtherError deriving Show + +instance Replicant AppError B where + redisPool = asks connection + redisNamespace = return "replicant" + redisError _ = throwError RedisError + +runB :: AppConf -> B a -> IO (Either AppError a) +runB = runReplicantT + +bot :: Bot +bot = Bot + { botId = "1" + , botName = "repl" + , botIcon = "^_^" + , botToken = "" + , botUserId = "1" + } + +plugins :: [Plugin B] +plugins = [divide, echo, help, score] + +mkConf :: IO AppConf +mkConf = AppConf <$> R.connect R.defaultConnectInfo <*> newSupervisor + +main :: IO () +main = do + conf <- mkConf + result <- runB conf $ do + startBot (working conf) (liftIO . print) (buildBot CLI.adapter plugins bot) + CLI.wait + either (error . show) return result diff --git a/replicant.cabal b/replicant.cabal new file mode 100644 --- /dev/null +++ b/replicant.cabal @@ -0,0 +1,89 @@ +name: replicant +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: https://github.com/jamesdabbs/replicant#readme +license: BSD3 +license-file: LICENSE +author: James Dabbs +maintainer: jamesdabbs@gmail.com +copyright: 2016 James Dabbs +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + default-extensions: LambdaCase + , OverloadedStrings + , RecordWildCards + ghc-options: -Wall + exposed-modules: Replicant + , Replicant.Adapters.CLI + , Replicant.Adapters.Slack + , Replicant.Adapters.Slack.Api + , Replicant.Adapters.Slack.Types + , Replicant.Base + , Replicant.Bot + , Replicant.Bot.Supervisor + , Replicant.Logging + , Replicant.Plugin + , Replicant.Plugins.Base + , Replicant.Plugins.Divide + , Replicant.Plugins.Echo + , Replicant.Plugins.Help + , Replicant.Plugins.Score + , Replicant.Types + build-depends: base >= 4.7 && < 5 + , aeson + , aeson-pretty + , ansi-terminal + , attoparsec + , bytestring + , containers + , either + , exceptions + , fast-logger + , hedis + , hedis-namespace + , lens + , lens-aeson + , lifted-base + , monad-control + , monad-logger + , mtl + , network + , resourcet + , stm + , text + , transformers + , transformers-base + , websockets + , wreq + , wuss + default-language: Haskell2010 + +executable replicant + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , replicant + , bytestring + , hedis-namespace + , mtl + default-language: Haskell2010 + +test-suite replicant-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , replicant + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/githubuser/replicant diff --git a/src/Replicant.hs b/src/Replicant.hs new file mode 100644 --- /dev/null +++ b/src/Replicant.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Replicant + ( module Replicant + , Bot(..) + , BotSpec(..) + , Plugin + , Supervisor + , WorkerStatus(..) + , buildBot + , newSupervisor + , redis + , status + , startBot + , stopBot + -- plugins + , divide + , echo + , help + , score + ) where + +import qualified Replicant.Types as Replicant + +import Replicant.Base +import Replicant.Bot +import Replicant.Bot.Supervisor +import Replicant.Plugin + +import Replicant.Plugins.Divide +import Replicant.Plugins.Echo +import Replicant.Plugins.Help +import Replicant.Plugins.Score + +import Control.Monad.Base +import Control.Monad.Catch (MonadCatch(..), MonadThrow(..)) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Control +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) + +newtype ReplicantT e c m a = ReplicantT + { unReplicantT :: ExceptT e (ReaderT c m) a + } deriving + ( Applicative + , Functor + , Monad + , MonadIO + , MonadReader c + , MonadError e + ) + +deriving instance MonadBase b m => MonadBase b (ReplicantT e c m) + +instance MonadCatch m => MonadCatch (ReplicantT e c m) where + catch (ReplicantT m) f = ReplicantT $ m `catch` (unReplicantT . f) + +instance MonadThrow m => MonadThrow (ReplicantT e c m) where + throwM = ReplicantT . throwM + +instance MonadTrans (ReplicantT e c) where + lift = ReplicantT . lift . lift + +instance MonadBaseControl IO m => MonadBaseControl IO (ReplicantT e c m) where + type StM (ReplicantT e c m) a = ComposeSt (ReplicantT e c) m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + +instance MonadTransControl (ReplicantT e c) where + type StT (ReplicantT e c) a = StT (ExceptT e) (StT (ReaderT c) a) + liftWith f = ReplicantT $ liftWith $ \run -> + liftWith $ \run' -> + f (run' . run . unReplicantT) + restoreT = ReplicantT . restoreT . restoreT + +runReplicantT :: c -> ReplicantT e c m a -> m (Either e a) +runReplicantT conf m = runReaderT (runExceptT $ unReplicantT m) conf diff --git a/src/Replicant/Adapters/CLI.hs b/src/Replicant/Adapters/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Adapters/CLI.hs @@ -0,0 +1,160 @@ +module Replicant.Adapters.CLI + ( adapter + , wait + ) where + +import Replicant.Base +import Replicant.Bot (botDirectives) +import Replicant.Plugins.Base (whitespace) +import qualified Replicant.Logging as Log + +import Control.Concurrent.MVar +import Data.Attoparsec.Text +import Data.Maybe (isJust, fromJust) +import qualified Data.List as L +import qualified Data.Text as T +import qualified Data.Text.IO as T +import System.Console.ANSI +import System.IO +import System.IO.Unsafe (unsafePerformIO) + +import Replicant.Plugin + +adapter :: Replicant e m => Adapter m +adapter = Adapter + { bootBot = _bootBot + , sendToUserId = _sendUserId + , sendToRoom = _sendRoom + , parseCommand = _parseCommand + , getRoomByName = _getRoomByName + , getRoomMembers = _getRoomMembers + } + +done :: MVar () +{-# NOINLINE done #-} +done = unsafePerformIO newEmptyMVar + +wait :: MonadIO m => m () +{-# NOINLINE wait #-} +wait = liftIO $ takeMVar done + +_bootBot :: Replicant e m => BotSpec m -> m () +_bootBot spec@BotSpec{..} = do + let Bot{..} = botRecord + let + loop = do + _ask botName "here" + input <- liftIO $ do + hFlush stdout + T.getLine + if input == "q" + then liftIO $ putMVar done () + else dispatch spec input >> loop + loop + +dispatch :: Replicant e m => BotSpec m -> Text -> m () +dispatch spec input = case parseOnly messageParser input of + Left err -> liftIO . putStrLn $ "Could not parse input: " ++ err + Right msg -> botDirectives spec msg + +_log :: MonadIO m => [Text] -> m () +_log = liftIO . T.putStr . T.concat + +outPrompt :: Text +outPrompt = Log.colorize' Dull botC " > " + +prefixLines :: Text -> Text -> Text +prefixLines pre corpus = T.unlines . map (\l -> pre <> l) $ T.lines corpus + +_send :: MonadIO m => Text -> Text -> Text -> m () +_send bot target text = _log + [ Log.bracket botC bot + , target + , prefixLines outPrompt text + ] + +_ask :: MonadIO m => Text -> Text -> m () +_ask botName target = _log + [ Log.bracket botC botName + , Log.bracket roomC target + , " < " + ] + +_sendUserId :: MonadIO m => Bot -> UserId -> Text -> m () +_sendUserId Bot{..} _id = _send botName $ Log.bracket userC name + where + name = userName . fromJust $ L.find (\u -> userId u == _id) users + +_sendRoom :: MonadIO m => Bot -> Room -> Text -> m () +_sendRoom Bot{..} Room{..} = _send botName $ Log.bracket roomC roomName + +_parseCommand :: Bot -> Message -> Maybe Text +_parseCommand bot Message{..} = case parseOnly (commandParser bot) messageText of + Left _ -> Nothing + Right mt -> mt + +_getRoomByName :: Monad m => Bot -> Text -> m (Maybe Room) +_getRoomByName _ = return . roomNamed + +_getRoomMembers :: Monad m => Bot -> Room -> m [User] +_getRoomMembers _ room = do + let found = L.find (\(r,_) -> r == room) rooms + return $ case found of + Just (_, users) -> users + Nothing -> [] + +word :: Parser Text +word = T.pack <$> many' letter + +messageParser :: Parser Message +messageParser = do + mRoomName <- optional $ "room:" *> word + let mRoom = case mRoomName of + Just name -> roomNamed name + Nothing -> Just here + room <- maybe mzero return mRoom + + mDirect <- optional "dm:" + whitespace + rest <- takeText + return Message + { messageRoom = room + , messageUser = me + , messageText = rest + , messageDirect = isJust mDirect + } + + +commandParser :: Bot -> Parser (Maybe Text) +commandParser Bot{..} = do + name <- optional $ string ("@" <> botName) + whitespace + rest <- takeText + return $ if isJust name + then Just rest + else Nothing + +me, you :: User +me = User "1" "me" +you = User "2" "you" + +users :: [User] +users = [me, you] + +here, there :: Room +here = Room "A" "here" +there = Room "B" "there" + +rooms :: [(Room, [User])] +rooms = + [ (here, [me, you]) + , (there, [you]) + ] + +roomNamed :: Text -> Maybe Room +roomNamed name = fst <$> L.find (\(r,_) -> roomName r == name) rooms + +botC, roomC, userC :: Color +botC = Green +roomC = Yellow +userC = Cyan diff --git a/src/Replicant/Adapters/Slack.hs b/src/Replicant/Adapters/Slack.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Adapters/Slack.hs @@ -0,0 +1,149 @@ +module Replicant.Adapters.Slack + ( adapter + ) where + +import Prelude hiding (takeWhile) +import Replicant.Base + +import qualified Replicant.Adapters.Slack.Api as S +import qualified Replicant.Adapters.Slack.Types as S + +import Control.Monad.Trans.Control (control) +import Data.Aeson (eitherDecode) +import Data.Attoparsec.Text +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List as L +import Data.Maybe (isJust) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Database.Redis.Namespace as R +import Network.Socket (withSocketsDo) +import qualified Network.WebSockets as WS +import qualified Wuss as WS (runSecureClient) + +import Replicant.Bot (botDirectives, redis) +import Replicant.Plugin +import Replicant.Plugins.Base (whitespace) +import qualified Replicant.Logging as Log + + +adapter :: Replicant e m => Adapter m +adapter = Adapter + { bootBot = _bootBot + , sendToUserId = _sendToUserId + , sendToRoom = _sendToRoom + , parseCommand = parseSlackCommand + , getRoomByName = getSlackRoomByName + , getRoomMembers = getSlackRoomMembers + } + +_bootBot :: Replicant e m => BotSpec m -> m () +_bootBot spec@BotSpec{..} = do + url <- S.getWebsocket botRecord + let (domain, path) = T.breakOn "/" . T.drop 6 $ url + + control $ \run -> withSocketsDo $ + WS.runSecureClient (T.unpack domain) 443 (T.unpack path) $ \conn -> do + WS.forkPingThread conn 15 + forever $ WS.receiveData conn >>= run . dispatchEvents spec + +dispatchEvents :: Replicant e m => BotSpec m -> LBS.ByteString -> m () +dispatchEvents spec msg = case eitherDecode msg of + Left err -> liftIO . T.putStrLn $ "Failed to parse event: " <> T.pack err + Right event -> withMessages (botDirectives spec) event + +toMessage :: S.Message -> Message +toMessage sm = + let r = S.messageChannel sm + u = maybe "" id $ S.messageUser sm + in Message + { messageRoom = Room { roomId = r, roomName = r } + , messageUser = User { userId = u, userName = u } + , messageText = S.messageBody sm + , messageDirect = isDirect sm + } + +withMessages :: Monad m => (Message -> m ()) -> S.Event -> m () +withMessages f (S.MessageEvent m) = f $ toMessage m +withMessages _ _ = return () + +commandParser :: Parser (Text, Text) +commandParser = do + whitespace + _ <- string "<@" + userId <- takeWhile $ \c -> c /= '>' + _ <- char '>' + whitespace + _ <- optional ":" + whitespace + msg <- takeWhile $ const True + return (userId, msg) + +parseSlackCommand :: Bot -> Message -> Maybe Text +parseSlackCommand bot Message{..} = + case parseOnly commandParser messageText of + Right (_id, command) -> + if _id == botUserId bot + then Just command + else Nothing + _ -> + if messageDirect + then Just messageText + else Nothing + +isDirect :: S.Message -> Bool +isDirect S.Message{..} = channelIsDirect && isFromAHuman + where + channelIsDirect = T.isPrefixOf "D" messageChannel + isFromAHuman = isJust messageUser -- TODO: improve? + +_sendToUserId :: Replicant e m => Bot -> UserId -> Text -> m () +_sendToUserId bot userId text = + getDmRoomId bot userId >>= \case + Nothing -> return () -- TODO?? + Just im -> S.sendMessage bot im text + +_sendToRoom :: Replicant e m => Bot -> Room -> Text -> m () +_sendToRoom bot Room{..} = S.sendMessage bot roomId + +-- TODO: support to- / from- json and cache room name => room lookup +cached :: Replicant e m => Bot -> Text -> Text -> m (Maybe Text) -> m (Maybe Text) +cached bot collection key q = do + let rk = encodeUtf8 $ "cache:" <> collection <> ":" <> key + found <- redis $ R.get rk + case found of + Just val -> do + Log.cacheHit (botName bot) collection key + return . Just $ decodeUtf8 val + Nothing -> q >>= \case + Nothing -> return Nothing + Just val -> do + redis . R.set rk $ encodeUtf8 val + return $ Just val + +getDmRoomId :: Replicant e m => Bot -> UserId -> m (Maybe RoomId) +getDmRoomId bot userId = cached bot "im-ids" userId $ do + rooms <- S.getImList bot + return $ snd <$> L.find (\(u,_) -> u == userId) rooms + +channelToRoom :: S.Channel -> Room +channelToRoom ch = Room + { roomId = S.channelId ch + , roomName = S.channelName ch + } + +getSlackRoomByName :: Replicant e m => Bot -> Text -> m (Maybe Room) +getSlackRoomByName bot text = do + channels <- S.getChannels bot + return $ channelToRoom <$> L.find (\c -> text == S.channelName c) channels + +getSlackRoomMembers :: Replicant e m => Bot -> Room -> m [User] +getSlackRoomMembers bot Room{..} = do + members <- S.getChannelMembers bot roomId + return $ map memberToUser members + +memberToUser :: S.User -> User +memberToUser su = User + { userId = S.userId su + , userName = S.userName su + } diff --git a/src/Replicant/Adapters/Slack/Api.hs b/src/Replicant/Adapters/Slack/Api.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Adapters/Slack/Api.hs @@ -0,0 +1,99 @@ +module Replicant.Adapters.Slack.Api + ( getBotInfo + , getWebsocket + , replyTo + , sendMessage + , getChannels + , getChannelMembers + , getImList + , oauth + ) where + +import Replicant.Base +import Replicant.Logging (apiCall) +import qualified Replicant.Adapters.Slack.Types as S + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T + +import Control.Lens ((.~), (&), (^.), (^..)) +import Data.Aeson.Lens +import Network.Wreq (FormParam, postWith, defaults, param, responseBody, Options, Response) + +import Data.Aeson (Value) + +replyTo :: Replicant e m => Bot -> S.Message -> Text -> m () +replyTo bot S.Message{..} = sendMessage bot messageChannel + +sendMessage :: Replicant e m => Bot -> S.ChannelId -> Text -> m () +sendMessage Bot{..} channel body = do + resp <- slackRequest botName botToken "chat.postMessage" $ + \p -> p & param "channel" .~ [channel] + & param "text" .~ [body] + & param "username" .~ [botName] + & param "as_user" .~ ["false" :: Text] + & param "icon_emoji" .~ [botIcon] + return () + +getWebsocket :: Replicant e m => Bot -> m Text +getWebsocket Bot{..} = do + r <- slackRequest botName botToken "rtm.start" id + return $ r ^. responseBody . key "url" . _String + +getBotInfo :: Replicant e m => BotInfo -> m Bot +getBotInfo BotInfo{..} = do + r <- slackRequest "??" botInfoToken "auth.test" id + let k str = r ^. responseBody . key str . _String + botName = k "user" + botUserId = k "user_id" + botToken = botInfoToken + botIcon = ":" <> botInfoIcon <> ":" + teamId = k "team_id" + botId = "slack:" <> teamId <> ":" <> botUserId + return Bot{..} + +getChannels :: Replicant e m => Bot -> m [S.Channel] +getChannels Bot{..} = do + error "FIXME: getChannels" + return [] + +getChannelMembers :: Replicant e m => Bot -> Text -> m [S.User] +getChannelMembers _ _ = do + error "FIXME: getChannelMembers" + return [] + +getImList :: Replicant e m => Bot -> m [(UserId, RoomId)] +getImList Bot{..} = do + r <- slackRequest botName botToken "im.list" id + let rooms = r ^.. responseBody . key "ims" . _Array . traverse + return $ map parseImRoom rooms + +parseImRoom :: Value -> (UserId, RoomId) +parseImRoom v = + ( v ^. key "user" . _String + , v ^. key "id" . _String + ) + +oauth :: Replicant e m => S.Credentials -> Text -> m (BotToken, BotToken) +oauth S.Credentials{..} code = do + let opts = defaults + & param "client_id" .~ [appClientId] + & param "client_secret" .~ [appClientSecret] + & param "code" .~ [code] + let url = "https://slack.com/api/oauth.access" + let form = [] :: [FormParam] + r <- liftIO $ postWith opts url form + apiCall "??" "oauth.access" r + let user = r ^. responseBody . key "access_token" . _String + bot = r ^. responseBody . key "bot" . key "bot_access_token" . _String + return (user, bot) + +slackRequest :: Replicant e m => BotName -> BotToken -> Text -> (Options -> Options) -> m (Response LBS.ByteString) +slackRequest name token endpoint updater = do + let opts = defaults + & param "token" .~ [token] + let url = "https://slack.com/api/" <> endpoint + let form = [] :: [FormParam] + r <- liftIO $ postWith (updater opts) (T.unpack url) form + apiCall name endpoint r + return r diff --git a/src/Replicant/Adapters/Slack/Types.hs b/src/Replicant/Adapters/Slack/Types.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Adapters/Slack/Types.hs @@ -0,0 +1,72 @@ +module Replicant.Adapters.Slack.Types + ( Channel(..) + , ChannelId + , Credentials(..) + , Event(..) + , Message(..) + , Token + , User(..) + , UserId + ) where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.ByteString.Lazy as LBS +import Data.Text (Text) + +type ChannelId = Text +type UserId = Text +type Token = Text + +data Message = Message + { messageBody :: !Text + , messageChannel :: !ChannelId + , messageUser :: !(Maybe Text) + } deriving Show + +data Channel = Channel + { channelId :: !ChannelId + , channelName :: !Text + } deriving Show + +data User = User + { userId :: !UserId + , userName :: !Text + } + +data Event = MessageEvent Message + | MessageResponse + | MessageError + | UnknownEvent Text LBS.ByteString + deriving Show + +data Credentials = Credentials + { appClientId :: !Text + , appClientSecret :: !Text + } deriving (Show, Eq) + +instance FromJSON Message where + parseJSON = withObject "message" $ \v -> do + messageBody <- v .: "text" + messageChannel <- v .: "channel" + messageUser <- v .:? "user" + return Message{..} + +instance FromJSON Event where + parseJSON = withObject "event" $ \v -> do + typ <- v .:? "type" + case typ of + Just t -> parseEvent t $ Object v + Nothing -> do + ok <- v .: "ok" + if ok + then return MessageResponse -- <$> v .: "reply_to" <*> v .: "ts" <*> v .: "text" + else return MessageError -- <$> v .: "reply_to" <*> v .: "error" + +parseEvent :: Text -> Value -> Parser Event +parseEvent t = withObject "event" $ \v -> + case t of + "message" -> do + m <- parseJSON $ Object v + return $ MessageEvent m + _ -> return $ UnknownEvent t (encode v) diff --git a/src/Replicant/Base.hs b/src/Replicant/Base.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Base.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE FlexibleContexts #-} +module Replicant.Base + ( module Replicant.Base + ) where + +import Control.Applicative as Replicant.Base (optional, many) +import Control.Concurrent as Replicant.Base (ThreadId) +import Control.Monad as Replicant.Base (MonadPlus, forever, forM, forM_, join, liftM2, mzero, unless, void, when, (>=>)) +import Control.Monad.Except as Replicant.Base (MonadError, throwError) +import Control.Monad.Logger as Replicant.Base (MonadLogger, logDebug, logError, logInfo, logWarn, toLogStr) +import Control.Monad.Reader as Replicant.Base (MonadReader, asks, ask) +import Control.Monad.IO.Class as Replicant.Base (MonadIO) +import Control.Monad.Trans as Replicant.Base (liftIO) +import Control.Monad.Trans.Either as Replicant.Base (EitherT, left, right) +import Control.Monad.Trans.Except as Replicant.Base (ExceptT) +import Control.Monad.Trans.Resource as Replicant.Base (MonadBaseControl) +import Data.Monoid as Replicant.Base ((<>)) +import Data.Text as Replicant.Base (Text) +import Data.Text.Encoding as Replicant.Base (encodeUtf8, decodeUtf8) + +import Replicant.Types as Replicant.Base + +import qualified Debug.Trace as Debug + +tr :: Show a => a -> b -> b +tr = Debug.traceShow + +tr' :: Show a => a -> a +tr' = Debug.traceShowId + +trm :: (Show a, Monad m) => a -> m () +trm = Debug.traceShowM diff --git a/src/Replicant/Bot.hs b/src/Replicant/Bot.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Bot.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleContexts #-} +module Replicant.Bot + ( botDirectives + , buildBot + , redis + , startBot + , stopBot + ) where + +import Replicant.Base +import Replicant.Bot.Supervisor (Supervisor, WorkerStatus, halt, monitor) +import Replicant.Plugin +import qualified Replicant.Logging as Log + +import Control.Exception.Lifted (try) +import Control.Monad.Trans.Control (control) +import qualified Data.List as L +import qualified Database.Redis as R (Redis, Reply) +import Database.Redis.Namespace (RedisNS, runRedisNS) + +redis :: Replicant e m => RedisNS R.Redis (Either R.Reply) a -> m a +redis q = do + conn <- redisPool + ns <- redisNamespace + res <- liftIO $ runRedisNS conn ns q + either redisError return res + +botDirectives :: Replicant e m => BotSpec m -> Message -> m () +botDirectives b msg = do + let applicable = L.filter (\p -> handlerApplies p b msg) (botHandlers b) + + -- TODO: + -- * enforce only one match? + -- * respond to _direct_ messages if nothing matches + unless (null applicable) $ do + let names = L.map handlerName applicable + Log.handlerMatch (botRecord b) msg names + forM_ applicable $ \p -> tryRun p b msg + +tryRun :: (MonadBaseControl IO m, MonadIO m) => Handler m -> BotSpec m -> Message -> m () +tryRun h b m = do + result <- try $ runHandler h b m + case result of + -- TODO: respond to user if handler crashes + Left err -> Log.handlerCrash (botRecord b) err + Right _ -> return () + +buildBot :: Adapter m -> [Plugin m] -> Bot -> BotSpec m +buildBot botAdapter botPlugins botRecord = BotSpec{..} + +startBot :: Replicant e m => Supervisor m BotId -> (WorkerStatus -> m c) -> BotSpec m -> m () +startBot supervisor cb spec@BotSpec{..} = monitor supervisor cb (botId botRecord) (bootBot botAdapter spec) + +stopBot :: Replicant e m => Supervisor m BotId -> BotId -> m () +stopBot = halt diff --git a/src/Replicant/Bot/Supervisor.hs b/src/Replicant/Bot/Supervisor.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Bot/Supervisor.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE FlexibleContexts #-} +module Replicant.Bot.Supervisor + ( Supervisor + , WorkerStatus(..) + , newSupervisor + , monitor + , halt + , status + ) where + +import Control.Concurrent (ThreadId, killThread) +import Control.Concurrent.Lifted (forkFinally) +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TVar +import Control.Exception (SomeException) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Control (MonadBaseControl) +import qualified Data.Map as M + +data Worker m = Worker + { workerJob :: m () + , workerStatus :: TVar WorkerStatus + } + +data Supervisor m a = Supervisor + { supervisorWorkers :: TVar (M.Map a (Worker m)) + } + +data WorkerStatus = WorkerBooting | WorkerRunning ThreadId | WorkerCrashed SomeException | WorkerDone deriving Show + +newSupervisor :: IO (Supervisor m a) +newSupervisor = Supervisor <$> newTVarIO M.empty + +monitor :: (MonadBaseControl IO m, MonadIO m, Ord a) + => Supervisor m a -> (WorkerStatus -> m c) -> a -> m b -> m () +monitor s@Supervisor{..} cb key job = do + halt s key + w <- mkWorker job + liftIO . atomically . modifyTVar supervisorWorkers $ M.insert key w + runWorker w $ \st -> void $ do + liftIO . atomically $ writeTVar (workerStatus w) st + cb st + +halt :: (MonadIO m, Ord a) => Supervisor m a -> a -> m () +halt Supervisor{..} key = do + keys <- liftIO . atomically $ pop key supervisorWorkers + mapM_ shutdownWorker keys + +status :: MonadIO m => Supervisor m a -> m (M.Map a WorkerStatus) +status Supervisor{..} = liftIO . atomically $ + readTVar supervisorWorkers >>= mapM (readTVar . workerStatus) + +mkWorker :: MonadIO m => m b -> m (Worker m) +mkWorker job = liftIO $ Worker + <$> pure (void job) + <*> newTVarIO WorkerBooting + +runWorker :: (MonadBaseControl IO m, MonadIO m) => Worker m -> (WorkerStatus -> m ()) -> m () +runWorker Worker{..} watcher = do + watcher WorkerBooting + thread <- forkFinally workerJob (handleExit watcher) + watcher $ WorkerRunning thread + +-- TODO: can we determine if this was a deliberate shutdown? Should we try to reboot? +handleExit :: MonadIO m => (WorkerStatus -> m c) -> Either SomeException () -> m c +handleExit watcher (Left err) = watcher $ WorkerCrashed err +handleExit watcher _ = watcher WorkerDone + +shutdownWorker :: MonadIO m => Worker m -> m () +shutdownWorker Worker{..} = liftIO $ readTVarIO workerStatus >>= \case + WorkerRunning threadId -> killThread threadId + _ -> return () + +pop :: Ord a => a -> TVar (M.Map a b) -> STM (Maybe b) +pop k tmap = do + val <- M.lookup k <$> readTVar tmap + modifyTVar' tmap $ M.delete k + return val diff --git a/src/Replicant/Logging.hs b/src/Replicant/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Logging.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Replicant.Logging + ( Logger + , apiCall + , blog + , bracket + , cacheHit + , colorize + , colorize' + , newLogger + , handlerCrash + , handlerMatch + , pprint + , worker + ) where + +import Replicant.Base + +import Control.Exception (SomeException) +import Control.Lens ((^.)) +import Data.Attoparsec.Lazy (Result(..), parse) +import Data.Aeson (json') +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Network.Wreq (Response, responseBody) +import System.Console.ANSI +import System.Log.FastLogger + +type Logger = FastLogger + +newLogger :: IO Logger +newLogger = do + (l, _) <- newFastLogger $ LogStderr defaultBufSize + return l + +handlerMatch :: MonadIO m => Bot -> Message -> [Text] -> m () +handlerMatch Bot{..} msg = mapM_ l + where + l name = blog botName + [ colorize Magenta (userName . messageUser $ msg) + , ": " + , colorize Blue (messageText msg) + , " => " + , colorize Green name + ] + +apiCall :: MonadIO m => BotName -> Text -> Response LBS.ByteString -> m () +apiCall bot endpoint resp = do + blog bot [ colorize Red endpoint ] + when False $ + liftIO . LBS.putStrLn . pprint $ resp ^. responseBody + +blog :: MonadIO m => BotName -> [Text] -> m () +blog bot msg = liftIO . T.putStrLn . T.concat $ + [ bracket Green bot + , " " + , T.concat msg + ] + +handlerCrash :: MonadIO m => Bot -> SomeException -> m () +handlerCrash Bot{..} err = liftIO . T.putStrLn . T.concat $ + [ bracket Red botName + , " " + , colorize Red "CRASHED" + , " " + , T.pack (show err) + ] + +worker :: MonadIO m => Text -> Text -> m () +worker name msg = liftIO . T.putStrLn . T.concat $ + [ bracket Blue $ "supervisor:" <> name + , " " + , msg + ] + +cacheHit :: MonadIO m => BotName -> Text -> Text -> m () +cacheHit name coll key = blog name + [ colorize Blue "cache" + , " " + , coll + , ":" + , key + ] + +colorize :: Color -> Text -> Text +colorize = colorize' Vivid + +colorize' :: ColorIntensity -> Color -> Text -> Text +colorize' int color str = T.concat + [ T.pack $ setSGRCode [SetColor Foreground int color] + , str + , T.pack $ setSGRCode [Reset] + ] + +bracket :: Color -> Text -> Text +bracket c text = T.concat + [ colorize' Dull c "[" + , colorize' Vivid c text + , colorize' Dull c "]" + ] + +pprint :: LBS.ByteString -> LBS.ByteString +pprint s = case parse json' s of + Done _ v -> encodePretty v + _ -> s diff --git a/src/Replicant/Plugin.hs b/src/Replicant/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Plugin.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Replicant.Plugin + ( Adapter(..) + , BotSpec(..) + , Example(..) + , H + , Handler + , HandlerCtx(..) + , Plugin(..) + , PluginData(..) + , botHandlers + , mkHandler + , handlerApplies + , handlerCommandOnly + , handlerExamples + , handlerName + , pluginExamples + , runHandler + , sendToUser + ) where + +import Replicant.Base + +import Control.Monad.Reader (ReaderT, runReaderT, lift) +import Data.Attoparsec.Text (Parser, parseOnly, endOfInput) +import Data.ByteString (ByteString) +import Data.List (find) +import Data.Maybe (isNothing) +import qualified Database.Redis as Redis (Connection) + + +data HandlerCtx m = HandlerCtx + { handlerBot :: BotSpec m + , handlerMessage :: Message + , handlerPluginName :: ByteString + , handlerRedisConn :: Redis.Connection + } +type H m a = ReaderT (HandlerCtx m) m a + +instance Replicant e m => Replicant e (ReaderT (HandlerCtx m) m) where + redisPool = lift redisPool + redisError = lift . redisError + redisNamespace = do + base <- lift redisNamespace + plugin <- asks handlerPluginName + BotSpec{..} <- asks handlerBot + return $ base <> ":bot:" <> encodeUtf8 (botId botRecord) <> ":plugin:" <> plugin + +data Example = Example + { exampleText :: Text + , exampleDescription :: Text + } deriving Show + +data Plugin m = Plugin + { pluginName :: Text + , pluginHandlers :: [Handler m] + } + +data PluginData = PluginData + { pdName :: Text + , pdExamples :: [Example] + } + +data Handler m = Handler + { handlerName :: Text + , handlerExamples :: [Example] + , handlerCommand :: Bool + -- The odd version of Bool is so we can have a consistent + -- monadic interface to both these helpers + -- We always `return ()` if the command check fails + -- These aren't exposed, so it's not that bad, but ... + -- TODO: make this more intuitive + , handlerTest :: BotSpec m -> Message -> Maybe () + , handlerRun :: BotSpec m -> Message -> m () + } + +-- Idea: +-- * enforce that plugins parse their examples +-- * (optional) enforce that other plugins _don't_ parse +data BotSpec m = BotSpec + { botRecord :: !Bot + , botAdapter :: !(Adapter m) + , botPlugins :: ![Plugin m] + } + +data Adapter m = Adapter + { bootBot :: BotSpec m -> m () + , sendToRoom :: Bot -> Room -> Text -> m () + , sendToUserId :: Bot -> UserId -> Text -> m () + , parseCommand :: Bot -> Message -> Maybe Text + , getRoomByName :: Bot -> Text -> m (Maybe Room) + , getRoomMembers :: Bot -> Room -> m [User] + } + +sendToUser :: Adapter m -> Bot -> User -> Text -> m () +sendToUser a b User{..} = sendToUserId a b userId + +checkParser :: Parser a -> BotSpec m -> Message -> Maybe () +checkParser parser _ Message{..} = + case parseOnly (parser <* endOfInput) messageText of + Right _ -> Nothing + Left _ -> Just () + +runParser :: Monad m => Parser a -> (BotSpec m -> Message -> a -> m ()) -> BotSpec m -> Message -> m () +runParser parser handler bot msg@Message{..} = + case parseOnly parser messageText of + Right r -> handler bot msg r + Left _ -> return () + +handlerApplies :: Monad m => Handler m -> BotSpec m -> Message -> Bool +handlerApplies p b m = isNothing $ handlerTest p b m + +handlerCommandOnly :: Handler m -> Bool +handlerCommandOnly = handlerCommand + +runHandler :: Monad m => Handler m -> BotSpec m -> Message -> m () +runHandler = handlerRun + +mkHandler :: Replicant e m + => Text + -> Bool + -> Parser a + -> [Example] + -> (a -> H m ()) + -> Handler m +mkHandler name commandOnly parser examples handler = Handler + { handlerName = name + , handlerExamples = map verify examples + , handlerCommand = commandOnly + , handlerTest = withCommand $ checkParser parser + , handlerRun = withCommand . runParser parser $ run handler + } + where + run :: Replicant e m => (a -> H m ()) -> BotSpec m -> Message -> a -> m () + run h b msg a = do + conn <- redisPool + let + Bot{..} = botRecord b + ctx = HandlerCtx + { handlerBot = b + , handlerMessage = msg + , handlerPluginName = encodeUtf8 $ pluginNamespace b name + , handlerRedisConn = conn + } + runReaderT (h a) ctx + + withCommand :: (Monad m, Monad a) => (BotSpec a -> Message -> m ()) -> BotSpec a -> Message -> m () + withCommand f b m = case parseCommand (botAdapter b) (botRecord b) m of + Just text -> f b $ m { messageText = text } + _ -> -- This didn't match the command format for the given adapter + if commandOnly + then return () + else f b m + + -- TODO: check that each example does match the given parser (what about commands, users, room, &c) + verify = id + +botHandlers :: BotSpec m -> [Handler m] +botHandlers bot = concatMap pluginHandlers $ botPlugins bot + +-- TODO: plugins should probably just hold on to their namespace. How should +-- we enforce consistency? +pluginNamespace :: BotSpec m -> Text -> Text +pluginNamespace BotSpec{..} handler = + case find container botPlugins of + Just plugin -> pluginName plugin + -- This handler isn't in the bots' installed plugins + Nothing -> "handler:" <> handler + where + container Plugin{..} = any (\h -> handlerName h == handler) pluginHandlers + +pluginExamples :: Plugin m -> [Example] +pluginExamples = concatMap handlerExamples . pluginHandlers diff --git a/src/Replicant/Plugins/Base.hs b/src/Replicant/Plugins/Base.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Plugins/Base.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +module Replicant.Plugins.Base + ( module Replicant.Base + -- re-exports + , Example(..) + , Handler + , H + , Plugin(..) + , botHandlers + , mkHandler + , redis + -- locals + , getBot + , getMessage + , getRoomByName + , getRoomMembers + , getSender + , reply + , sendToRoom + , sendToUser + , sendToUserId + , whitespace + , word + ) where + +import Replicant.Base +import Replicant.Bot (redis) +import Replicant.Plugin (Adapter, BotSpec(..), Example(..), H, Handler, Plugin(..), botHandlers, mkHandler) +import qualified Replicant.Plugin as P + +import Control.Monad.Reader (lift) +import Data.Attoparsec.Text +import qualified Data.Text as T + +whitespace :: Parser () +whitespace = void . many . satisfy $ inClass [' ', '\t', '\n'] + +word :: Parser Text +word = T.pack <$> many' letter + +getMessage :: Monad m => H m Message +getMessage = asks P.handlerMessage + +getBot :: Monad m => H m (BotSpec m) +getBot = asks P.handlerBot + +getSender :: Monad m => H m User +getSender = messageUser <$> getMessage + +reply :: Monad m => Text -> H m () +reply text = do + BotSpec{..} <- getBot + Message{..} <- getMessage + if messageDirect + then sendToUser messageUser text + else sendToRoom messageRoom text + + +-- Lifted versions of handler helper functions + +sendToUser :: Monad m => User -> Text -> H m () +sendToUser = liftH2 P.sendToUser + +sendToUserId :: Monad m => UserId -> Text -> H m () +sendToUserId = liftH2 P.sendToUserId + +sendToRoom :: Monad m => Room -> Text -> H m () +sendToRoom = liftH2 P.sendToRoom + +getRoomByName :: Monad m => Text -> H m (Maybe Room) +getRoomByName = liftH P.getRoomByName + +getRoomMembers :: Monad m => Room -> H m [User] +getRoomMembers = liftH P.getRoomMembers + +liftH :: Monad m => (Adapter m -> Bot -> a -> m r) -> a -> H m r +liftH h a = do + BotSpec{..} <- getBot + lift $ h botAdapter botRecord a + +liftH2 :: Monad m => (Adapter m -> Bot -> a -> b -> m r) -> a -> b -> H m r +liftH2 h a b = do + BotSpec{..} <- getBot + lift $ h botAdapter botRecord a b diff --git a/src/Replicant/Plugins/Divide.hs b/src/Replicant/Plugins/Divide.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Plugins/Divide.hs @@ -0,0 +1,26 @@ +module Replicant.Plugins.Divide + ( divide + ) where + +import Replicant.Plugins.Base +import Data.Attoparsec.Text +import qualified Data.Text as T + +divide :: Replicant e m => Plugin m +divide = Plugin "divide" [divideH] + +divideH :: Replicant e m => Handler m +divideH = mkHandler "divide" True divParser + [ Example "10 / 2" "Do some math" + , Example "1 / 0" "Force a crash" + ] + $ \(num, denom) -> reply . T.pack . show $ num `div` denom + +divParser :: Parser (Int, Int) +divParser = do + a <- many digit + whitespace + _ <- string "/" + whitespace + b <- many digit + return (read a, read b) diff --git a/src/Replicant/Plugins/Echo.hs b/src/Replicant/Plugins/Echo.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Plugins/Echo.hs @@ -0,0 +1,15 @@ +module Replicant.Plugins.Echo + ( echo + ) where + +import Replicant.Plugins.Base +import Data.Attoparsec.Text + +echo :: Replicant e m => Plugin m +echo = Plugin "echo" [echoH] + +echoH :: Replicant e m => Handler m +echoH = mkHandler "echo" False ("echo " *> takeText) + [ Example "echo hello world" "Repeat `hello world` back" + ] + reply diff --git a/src/Replicant/Plugins/Help.hs b/src/Replicant/Plugins/Help.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Plugins/Help.hs @@ -0,0 +1,30 @@ +module Replicant.Plugins.Help + ( help + ) where + +import Replicant.Plugins.Base +import Data.Attoparsec.Text + +import Replicant.Plugin (BotSpec(..), handlerCommandOnly, handlerExamples) + +import qualified Data.Text as T + +help :: Replicant e m => Plugin m +help = Plugin "help" [helpH] + +helpH :: Replicant e m => Handler m +helpH = mkHandler "help" True (string "help") + [ Example "help" "Show this help message" + ] $ \_ -> do + bot <- getBot + let examples = concatMap (full handlerExamples bot) $ botHandlers bot :: [(Text, Text)] + colWidth = maximum $ map (T.length . fst) examples + msg = T.concat $ concatMap (\(cmd, desc)-> [T.justifyLeft colWidth ' ' cmd, " => ", desc, "\n"]) examples + reply $ "```\n" <> msg <> "```" + +full :: (Handler m -> [Example]) -> BotSpec m -> Handler m -> [(Text, Text)] +full f BotSpec{..} h = map expand $ f h + where + expand Example{..} = if handlerCommandOnly h + then ("@" <> botName botRecord <> ": " <> exampleText, exampleDescription) + else (exampleText, exampleDescription) diff --git a/src/Replicant/Plugins/Score.hs b/src/Replicant/Plugins/Score.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Plugins/Score.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} +module Replicant.Plugins.Score + ( score + ) where + +import Replicant.Plugins.Base + +import qualified Data.Text as T +import qualified Database.Redis.Namespace as R + + +score :: Replicant e m => Plugin m +score = Plugin "score" [scoreUp, scoreDown, scoreShow] + + +scoreShow, scoreUp, scoreDown :: Replicant e m => Handler m + +scoreShow = mkHandler "Show score" False ("score " *> word) + [ Example "score leeloo" "Show the score for leeloo"] + $ \term -> delta term 0 + +scoreUp = mkHandler "Add score" False (word <* "++") + [ Example "leeloo++" "Give leeloo 1 point"] + $ \term -> delta term 1 + +scoreDown = mkHandler "Lower score" False (word <* "--") + [ Example "leeloo--" "Be a monster"] + $ \term -> delta term (-1) + + +delta :: Replicant e m => Text -> Integer -> H m () +delta term dn = redis (R.incrby term' dn) >>= explain term + where term' = encodeUtf8 term + +explain :: Monad m => Text -> Integer -> H m () +explain term n = reply $ term <> " has " <> T.pack (show n) <> " points" diff --git a/src/Replicant/Types.hs b/src/Replicant/Types.hs new file mode 100644 --- /dev/null +++ b/src/Replicant/Types.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Replicant.Types + ( Bot(..) + , BotId + , BotInfo(..) + , BotName + , BotToken + , Message(..) + , Namespace + , Replicant(..) + , Room(..) + , RoomId + , UserId + , User(..) + ) where + +import Control.Monad.Except (MonadError) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Resource (MonadBaseControl) +import Data.Aeson +import Data.Text (Text) +import Data.ByteString (ByteString) +import qualified Database.Redis as Redis + +type BotId = Text +type RoomId = Text +type UserId = Text + +type BotName = Text +type BotToken = Text + +type Namespace = Text + +data Bot = Bot + { botId :: BotId + , botName :: BotName + , botIcon :: Text + , botToken :: BotToken + , botUserId :: UserId + } deriving (Show, Eq) + +data Room = Room + { roomId :: !RoomId + , roomName :: !Text + } deriving (Show, Eq) + +data User = User + { userId :: !UserId + , userName :: !Text + } deriving (Show, Eq) + +data Message = Message -- an _incoming_ message + { messageRoom :: !Room + , messageUser :: !User + , messageText :: !Text + , messageDirect :: Bool + } deriving Show + +data BotInfo = BotInfo + { botInfoToken :: BotToken + , botInfoIcon :: Text + } + +class (MonadError e m, MonadBaseControl IO m, MonadIO m) => Replicant e m where + redisPool :: m Redis.Connection + redisNamespace :: m ByteString + redisError :: Redis.Reply -> m a + +instance ToJSON Bot where + toJSON Bot{..} = object + [ "id" .= botId + , "name" .= botName + , "icon" .= botIcon + , "token" .= botToken + , "user_id" .= botUserId + ] + +instance FromJSON Bot where + parseJSON = withObject "bot" $ \v -> do + botId <- v .: "id" + botName <- v .: "name" + botIcon <- v .: "icon" + botToken <- v .: "token" + botUserId <- v .: "user_id" + return Bot{..} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"