replicant (empty) → 0.1.0.0
raw patch · 21 files changed
+1467/−0 lines, 21 filesdep +aesondep +aeson-prettydep +ansi-terminalsetup-changed
Dependencies added: aeson, aeson-pretty, ansi-terminal, attoparsec, base, bytestring, containers, either, exceptions, fast-logger, hedis, hedis-namespace, lens, lens-aeson, lifted-base, monad-control, monad-logger, mtl, network, replicant, resourcet, stm, text, transformers, transformers-base, websockets, wreq, wuss
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/Main.hs +53/−0
- replicant.cabal +89/−0
- src/Replicant.hs +83/−0
- src/Replicant/Adapters/CLI.hs +160/−0
- src/Replicant/Adapters/Slack.hs +149/−0
- src/Replicant/Adapters/Slack/Api.hs +99/−0
- src/Replicant/Adapters/Slack/Types.hs +72/−0
- src/Replicant/Base.hs +32/−0
- src/Replicant/Bot.hs +55/−0
- src/Replicant/Bot/Supervisor.hs +79/−0
- src/Replicant/Logging.hs +108/−0
- src/Replicant/Plugin.hs +176/−0
- src/Replicant/Plugins/Base.hs +85/−0
- src/Replicant/Plugins/Divide.hs +26/−0
- src/Replicant/Plugins/Echo.hs +15/−0
- src/Replicant/Plugins/Help.hs +30/−0
- src/Replicant/Plugins/Score.hs +36/−0
- src/Replicant/Types.hs +86/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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
+ replicant.cabal view
@@ -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
+ src/Replicant.hs view
@@ -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
+ src/Replicant/Adapters/CLI.hs view
@@ -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
+ src/Replicant/Adapters/Slack.hs view
@@ -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+ }
+ src/Replicant/Adapters/Slack/Api.hs view
@@ -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
+ src/Replicant/Adapters/Slack/Types.hs view
@@ -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)
+ src/Replicant/Base.hs view
@@ -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
+ src/Replicant/Bot.hs view
@@ -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
+ src/Replicant/Bot/Supervisor.hs view
@@ -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
+ src/Replicant/Logging.hs view
@@ -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
+ src/Replicant/Plugin.hs view
@@ -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
+ src/Replicant/Plugins/Base.hs view
@@ -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
+ src/Replicant/Plugins/Divide.hs view
@@ -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)
+ src/Replicant/Plugins/Echo.hs view
@@ -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
+ src/Replicant/Plugins/Help.hs view
@@ -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)
+ src/Replicant/Plugins/Score.hs view
@@ -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"
+ src/Replicant/Types.hs view
@@ -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{..}
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"