marvin 0.0.1 → 0.0.2
raw patch · 17 files changed
+576/−229 lines, 17 filesdep +hashabledep +marvindep +mono-traversabledep −classy-preludedep −text-icusetup-changed
Dependencies added: hashable, marvin, mono-traversable, optparse-applicative, pcre-light, text, unordered-containers
Dependencies removed: classy-prelude, text-icu
Files
- README.md +206/−0
- Setup.hs +1/−1
- initializer/Main.hs +40/−24
- marvin.cabal +19/−13
- preprocessor/Main.hs +85/−26
- src/Marvin.hs +1/−1
- src/Marvin/Adapter.hs +9/−7
- src/Marvin/Adapter/Slack.hs +90/−79
- src/Marvin/Internal.hs +39/−23
- src/Marvin/Internal/Types.hs +13/−13
- src/Marvin/Prelude.hs +13/−9
- src/Marvin/Run.hs +19/−10
- src/Marvin/Types.hs +1/−1
- src/Marvin/Util/Logging.hs +7/−7
- src/Marvin/Util/Mutable.hs +2/−2
- src/Marvin/Util/Random.hs +4/−2
- src/Marvin/Util/Regex.hs +27/−11
+ README.md view
@@ -0,0 +1,206 @@+# Marvin, the paranoid bot (⍺ stage)++[](https://travis-ci.org/JustusAdam/marvin)+[](http://hackage.haskell.org/package/marvin)++Marvin is an attempt to combine the ease of use of [hubot](https://hubot.github.com) with the typesafety and easy syntax of Haskell and the performance gains from compiled languages.++A more in-depth version of the contents of this readme can be found on the [wiki](https://github.com/JustusAdam/marvin/wiki).+++## Installation++You can get a release version of marvin on [Hackage](https://hackage.haskell.org/package/marvin).++However this library is still a very early stage so you might want to get updates quicker. +You can do so by using [stack](https://docs.haskellstack.org) and adding a recent commit of this repository to your `stack.yaml` file.+Stack will take care of downloading and building it for you.+++## TLDR++```Haskell+module MyScript where++import Marvin.Prelude++script :: IsAdapter a => ScriptInit a+script = defineScript "my-script" $ do+ hear "I|i can't stand this (\w+)" $ do+ match <- getMatch++ let thing = match !! 1++ reply $ "I'm sorry to tell you but you'll have to do " ++ thing+ + respond "open the (\w+) door" $ do+ match <- getMatch+ let door = match !! 1+ openDoor door+ send $ printf "Door %v opened" door+ + respond "what is in file (\w+)" $ do+ match <- getMatch + let file = match !! 1++ liftIO $ readFile file++ send file+```++## How to Marvin++The best way to use Marvin is very much taken from hubot.++A Marvin instance composes of a collection of scripts which are reactions or actions on certain messages posted in slack.+Each script is a Haskell source file. +They get compiled into one single static binary, which is a HTTP server that listens for slack's event calls.++### Defining scripts++Defining scripts is very easy.++Create a new Haskell source file like "MyScript.hs" and import marvins prelude `Marvin.Prelude`.+This provides you with all the tools you need to interact with marvin.++Now you can start to define your script with `defineScript` which produces a script initializer.+If you wish to use marvins automatic script discovery your script initializer should be named `script` ++```Haskell+module MyScript where++import Marvin.Prelude++script :: IsAdapter a => ScriptInit a+script = defineScript "my-script" $ do+ ...+```++The script id, "my-script" in this case, is the name used for this script when repoting loggin messages as well as the key for this scripts configuration, see [configuration](#configuration).++In the define script block you can have marvin react to certain events with `hear` and `respond`.+More information on those in the section [reacting](#reacting)++Finally after you have defined your scripts you have to tie them together.+You can do this [manually](#wiring-manually) or you can have marvin create the boilerplate code for you.++To do this simply place a main file (this is the file you'll be compiling later) in the same directory the scripts are placed in.+Leave the file empty except for this line at the top `{-# OPTIONS_GHC -F -pgmF marvin-pp #-}`.+When you compile the file marvin will look for any other ".hs" and ".lhs" files in the same directory, import them and define a server which runs with the `script` from each.+If you wish to hide a file from the auto discovery either place it in a different directory or prefix it with "." or "_".++### Reacting++There are two main ways (currently) of reacting to events, `hear` and `respond`.++`hear` is for matching any incoming message. The provided regex is tried against all incomming messages, if one matches the handler is called.++`repond` only triggers on message which have the bot name, or a case variation thereof as the first word.+++Once a handler has triggered it may perform arbitrary IO actions (using `liftIO`) and send messages using `reply` and `send`.++- `reply` addresses the message to the original sender of the message that triggered the handler.+- `send` sends it to the same room the tiggering message weas sent to.+- `messageRoom` sends a message to a room specified by the user.++### Configuration++Configuration for marvin is written in the [configurator](https://hackage.haskell.com/package/configurator) syntax.++Configuration pertaining to the bot is stored under the "bot" key.++```+bot {+ name = "my-bot"+ logging = "INFO"+}+```++By default each script has access to a configuration stored under `script.<script-id>`.+And of course these scripts can have nested config groups.++```+bot {+ name = "my-bot"+}++script {+ script-1 {+ some-string = "foo"+ some-int = 1337+ bome-bool = true+ }+ script 2 {+ nested-group {+ val = false+ }+ name = "Trump"+ capable = false+ }+}+```++Configuration pertaining to the adapter is stored under `adapter.<adapter-name>`++```+bot {+ name = "my-bot"+ logging = "INFO"+}+adapter {+ slack-rtm {+ token = "eofk"+ }+}+``` ++### Wiring manually++How Marvin interacts with your chat program depends on the used Adapter.+For instance the currently default `slack-rtm` adapter creates a (client) websocket connection with the slack API and listens to the events there.+Other adapters may require to set up a server. ++### Utilities++All these utilities are already available to you if you import `Marvin.Prelude`.++#### Regex++Implemented in `Marvin.Util.Regex`, documentation coming soon.++#### Mutable variables++Implementation started in `Marvin.Util.Mutable`, documentation coming soon.++#### Format strings++For String formatting Marvin re-exposes the `Text.Printf` module. ++Format strings use placeholders with `%`, the default formatter (works for all `Show` datatypes) is `%v`.+Substitution is done with the varargs function `printf`.+You can find the full documentation in the documentation for the [`Text.Printf`](https://www.stackage.org/haddock/lts-7.12/base-4.9.0.0/Text-Printf.html#v:printf) module.++#### JSON++Exposed in `Marvin.Util.JSON` documentation coming soon. Until then refer to [aeson](https://hackage.haskell.org/package/aeson).++#### Logging++Marvin comes with a logging facility built in. +`Marvin.Util.Logging` expose the logging facility. +Several functions are available, depending on the urgency of your message, like `errorM`, `infoM` and `criticalM`.+Logging messages made this way are automatically formatted and tagged with the scripts that reported them.++By default all logging messages with higher priority `NOTICE` or higher are shown. +Using the command line parameter `verbose` also adds `INFO` messages and `debug` adds `DEBUG` messages.+You can select the exact logging level in your config file (see also [configuration](#configuration)).+ ++#### Random++Implemented in `Marvin.Util.Random`, documentation coming soon.++#### HTTP++Coarsely implemented in `Marvin.Util.HTTP`, documentation coming soon.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple+import Distribution.Simple main = defaultMain
initializer/Main.hs view
@@ -1,38 +1,41 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RecordWildCards #-} module Main where -import ClassyPrelude-import Options.Generic-import Paths_marvin-import System.Directory-import System.FilePath-import Text.Mustache.Compile-import Text.Mustache.Render-import Text.Mustache.Types+import Control.Arrow (second)+import Control.Monad+import Data.Containers+import Data.Foldable (for_)+import Data.Sequences+import qualified Data.Text.IO as T+import Options.Applicative+import Paths_marvin+import Prelude hiding (lookup)+import System.Directory+import System.FilePath+import Text.Mustache.Compile+import Text.Mustache.Render+import Text.Mustache.Types -data Opts = Opts +data Opts = Opts { botname :: String- , adapter :: Maybe String- } deriving (Generic)---instance ParseRecord Opts+ , adapter :: String+ } fromEither :: Show a => Either a b -> b-fromEither (Left e) = error $ "Was left: " ++ show e+fromEither (Left e) = error $ "Was left: " <> show e fromEither (Right v) = v wantDirectories :: [FilePath]-wantDirectories = +wantDirectories = [ "bot" ] wantFiles :: [(FilePath, Template)] wantFiles = map (second $ fromEither . compileTemplate "")- [ ("Main.hs.mustache", "bot/Main.hs") + [ ("Main.hs.mustache", "bot/Main.hs") , ("MyScript.hs.mustache", "bot/MyScript.hs") , ("config.cfg.mustache", "config.cfg") , ("bot.cabal.mustache", "{{name}}.cabal")@@ -46,13 +49,13 @@ main :: IO () main = do- opts <- getRecord "Marvin init"+ Opts{..} <- execParser infoParser d <- (</> "initializer") <$> getDataDir- unless ((== Just True) $ (`member` adType) <$> adapter opts) $ putStrLn "Unrecognized adapter"+ unless (adapter `member` adType) $ putStrLn "Unrecognized adapter" - let subsData = object [ "name" ~> botname opts- , "scriptsig" ~> maybe "IsAdapter a => ScriptInit a" ("ScriptInit " ++) (adapter opts >>= flip lookup adType)- , "adapter" ~> adapter opts+ let subsData = object [ "name" ~> botname+ , "scriptsig" ~> maybe "IsAdapter a => ScriptInit a" ("ScriptInit " <>) (lookup adapter adType)+ , "adapter" ~> adapter ] for_ wantDirectories $ \dir -> do@@ -64,7 +67,20 @@ if ".mustache" == takeExtension source then do tpl <- fromEither <$> automaticCompile [d] source- writeFile targetName $ substituteValue tpl subsData + T.writeFile targetName $ substituteValue tpl subsData else copyFile source targetName return ()+ where+ infoParser = info+ (helper <*> optsParser)+ (fullDesc <> header "marvin-init ~ make a new marvin project")+ optsParser = Opts+ <$> argument str (metavar "BOTNAME")+ <*> strOption+ ( long "adapter"+ <> short 'a'+ <> metavar "ID"+ <> value "slack-rtm"+ <> help "id of the adapter to use" )+
marvin.cabal view
@@ -1,5 +1,5 @@ name: marvin-version: 0.0.1+version: 0.0.2 synopsis: A modular bot for slack description: Please see README.md homepage: https://github.com/JustusAdam/marvin#readme@@ -10,7 +10,8 @@ copyright: Copyright: (c) 2016 Justus Adam category: Development build-type: Simple-extra-source-files: preprocessor/Main.mustache+extra-source-files: README.md+ , preprocessor/Main.mustache data-dir: resources data-files: initializer/*.hs.mustache initializer/config.cfg.mustache@@ -34,12 +35,11 @@ other-modules: Marvin.Internal , Marvin.Internal.Types build-depends: base >= 4.7 && < 5- , classy-prelude , wreq , aeson , mtl , lens- , text-icu+ , pcre-light , vector , optparse-generic , configurator@@ -52,31 +52,39 @@ , network-uri , wuss , random+ , hashable+ , text+ , mtl+ , unordered-containers+ , mono-traversable default-language: Haskell2010 default-extensions: OverloadedStrings , TypeFamilies , MultiParamTypeClasses , TupleSections , GADTs- , NoImplicitPrelude executable marvin-pp hs-source-dirs: preprocessor main-is: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base- , classy-prelude , mustache , directory , filepath- , optparse-generic+ , marvin+ , configurator+ , optparse-applicative+ , bytestring+ , mono-traversable+ , text+ , aeson default-language: Haskell2010 default-extensions: OverloadedStrings , TypeFamilies , MultiParamTypeClasses , TupleSections , GADTs- , NoImplicitPrelude executable marvin-init hs-source-dirs: initializer@@ -84,18 +92,18 @@ other-modules: Paths_marvin ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base- , classy-prelude , mustache , directory , filepath- , optparse-generic+ , optparse-applicative+ , mono-traversable+ , text default-language: Haskell2010 default-extensions: OverloadedStrings , TypeFamilies , MultiParamTypeClasses , TupleSections , GADTs- , NoImplicitPrelude -- test-suite slackbot-framework-test -- type: exitcode-stdio-1.0@@ -103,7 +111,6 @@ -- main-is: Spec.hs -- build-depends: base -- , marvin--- , classy-prelude -- ghc-options: -threaded -rtsopts -with-rtsopts=-N -- default-language: Haskell2010 -- default-extensions: OverloadedStrings@@ -111,7 +118,6 @@ -- , MultiParamTypeClasses -- , TupleSections -- , GADTs--- , NoImplicitPrelude source-repository head type: git
preprocessor/Main.hs view
@@ -1,46 +1,105 @@+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveGeneric #-}-import ClassyPrelude+import Data.Aeson hiding (object)+import qualified Data.ByteString.Lazy as B+import qualified Data.Configurator as C+import Data.Maybe (fromMaybe)+import Data.MonoTraversable.Unprefixed+import Data.Sequences+import qualified Data.Text.IO as T+import Marvin.Run (defaultConfigName, lookupFromAppConfig)+import Options.Applicative+import Prelude hiding (elem, filter) import System.Directory import System.FilePath import Text.Mustache import Text.Mustache.Compile-import Options.Generic -data Opts = Opts - { adapter :: Maybe String - } deriving (Generic)+data Opts = Opts+ { adapter :: Maybe String+ , sourceName :: FilePath+ , sourceLocation :: FilePath+ , targetFile :: FilePath+ , externalScripts :: FilePath+ , configLocation :: Maybe FilePath+ } -instance ParseRecord Opts+slackRtmData = ("Marvin.Adapter.Slack", "SlackRTMAdapter") adapters :: [(String, (String, String))] adapters =- [("slack-rtm", ("Marvin.Adapter.Slack", "SlackRTMAdapter"))]+ [("slack-rtm", slackRtmData)] tpl :: Template-tpl = $(embedTemplate ["app"] "Main.mustache")+tpl = $(embedTemplate ["preprocessor"] "Main.mustache") main :: IO () main = do- args <- getArgs- case args of- (srcname': srcLoc: out:r) -> do- let opts = getRecordPure r- srcname = unpack srcname'- dir = takeDirectory srcname- paths <- filter (not . ((||) <$> isPrefixOf "_" <*> isPrefixOf ".")) <$> getDirectoryContents dir- files <- filterM (doesFileExist . (dir </>)) paths- let hsFiles = map dropExtensions $ filter (/= takeFileName srcname) $ filter ((`elem` [".hs", ".lhs"]) . takeExtension) files- adapterType = opts >>= adapter >>= flip lookup adapters- processed = substitute tpl (object [ "scripts" ~> intercalate ", " (map (++ ".script") hsFiles)- , "imports" ~> hsFiles- , "adapter-import" ~> map fst adapterType- , "adapter-type" ~> maybe "AddYourAdapterTypeHere" snd adapterType - ])- writeFile (unpack out) processed- _ -> error "unexpected arguments"+ Opts{..} <- execParser infoParser++ adapter' <- maybe+ (do+ (cfg, _) <- C.autoReload C.autoConfig $ maybe [] (return . C.Optional) configLocation+ lookupFromAppConfig cfg "adapter"+ )+ (return . return)+ adapter++ let (adapterImport, adapterType) = fromMaybe slackRtmData $ adapter' >>= flip lookup adapters++ let dir = takeDirectory sourceName+ paths <- filter (not . ((||) <$> isPrefixOf "_" <*> isPrefixOf ".")) <$> getDirectoryContents dir+ files <- filterM (doesFileExist . (dir </>)) paths+ externals <- do+ exists <- doesFileExist externalScripts+ if exists+ then do+ f <- B.readFile externalScripts+ either error return $ eitherDecode f+ else return mempty+ let hsFiles = map dropExtensions $ filter (/= takeFileName sourceName) $ filter ((`elem` [".hs", ".lhs"]) . takeExtension) files+ scripts = hsFiles <> externals+ processed = substitute tpl (object [ "scripts" ~> intercalate ", " (map (<> ".script") scripts)+ , "imports" ~> scripts+ , "adapter-import" ~> adapterImport+ , "adapter-type" ~> adapterType+ ])+ T.writeFile targetFile processed+ where+ infoParser = info+ (helper <*> optsParser)+ (fullDesc <> header "marvin-pp ~ the marvin preprocessor")+ optsParser = Opts+ <$> optional+ (strOption+ $ long "adapter"+ <> short 'a'+ <> metavar "ID"+ <> help "adapter to use"+ <> showDefault+ )+ <*> argument str (metavar "NAME")+ <*> argument str (metavar "PATH")+ <*> argument str (metavar "PATH")+ <*> strOption+ ( long "external-scripts"+ <> short 's'+ <> value "external-scripts.json"+ <> metavar "PATH"+ <> help "config file of external scripts to load"+ <> showDefault+ )+ <*> optional+ (strOption+ $ long "config-location"+ <> short 'c'+ <> metavar "PATH"+ <> help "config to use"+ <> showDefault+ <> value defaultConfigName+ )
src/Marvin.hs view
@@ -16,7 +16,7 @@ , IsAdapter -- * Reacting , hear, respond, send, reply, messageRoom- , getMessage, getMatch+ , getMessage, getMatch, getUsername, getChannelName , Message(..), User(..), Room(..) , getConfigVal, requireConfigVal , BotReacting, HasMessage, HasMatch
src/Marvin/Adapter.hs view
@@ -12,8 +12,9 @@ {-# LANGUAGE ScopedTypeVariables #-} module Marvin.Adapter where -import ClassyPrelude+import Control.Monad.IO.Class import qualified Data.Configurator.Types as C+import Data.Text (unpack) import Marvin.Internal.Types import qualified System.Log.Logger as L @@ -27,22 +28,23 @@ class IsAdapter a where adapterId :: AdapterId a- messageRoom :: a -> Room -> Text -> IO ()- getUserInfo :: a -> User -> IO (Maybe UserInfo)+ messageRoom :: a -> Room -> String -> IO () runWithAdapter :: RunWithAdapter a+ getUsername :: a -> User -> IO String+ getChannelName :: a -> Room -> IO String type RunWithAdapter a = C.Config -> InitEventHandler a -> IO () -adapterLog :: forall m a. (MonadIO m, IsAdapter a) => (String -> String -> IO ()) -> a -> Text -> m ()+adapterLog :: forall m a. (MonadIO m, IsAdapter a) => (String -> String -> IO ()) -> a -> String -> m () adapterLog inner _ message =- liftIO $ inner (unpack $ "adapter." ++ aid) (unpack message)+ liftIO $ inner ("adapter." ++ unpack aid) message where (AdapterId aid) = adapterId :: AdapterId a -debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM :: (MonadIO m, IsAdapter a) => a -> Text -> m ()+debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM :: (MonadIO m, IsAdapter a) => a -> String -> m () debugM = adapterLog L.debugM infoM = adapterLog L.infoM noticeM = adapterLog L.noticeM@@ -53,5 +55,5 @@ emergencyM = adapterLog L.emergencyM -logM :: (MonadIO m, IsAdapter a) => L.Priority -> a -> Text -> m ()+logM :: (MonadIO m, IsAdapter a) => L.Priority -> a -> String -> m () logM prio = adapterLog (`L.logM` prio)
src/Marvin/Adapter/Slack.hs view
@@ -2,84 +2,55 @@ {-# LANGUAGE TemplateHaskell #-} module Marvin.Adapter.Slack (SlackRTMAdapter) where -import ClassyPrelude++import Control.Applicative ((<|>))+import Control.Arrow ((&&&))+import Control.Concurrent.Async (async, wait)+import Control.Concurrent.MVar (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar,+ readMVar, takeMVar)+import Control.Exception import Control.Lens hiding ((.=))+import Control.Monad import Data.Aeson hiding (Error) import Data.Aeson.TH import Data.Aeson.Types hiding (Error) import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Configurator as C import qualified Data.Configurator.Types as C+import Data.Containers+import Data.Foldable (toList)+import Data.HashMap.Strict (HashMap)+import Data.Maybe (fromMaybe)+import Data.Sequences+import Data.Text (Text, pack) import Marvin.Adapter import Marvin.Types import Network.URI import Network.WebSockets import Network.Wreq+import Prelude hiding (lookup)+import Text.Read (readMaybe) import Wuss data InternalType = Error { code :: Int- , msg :: Text+ , msg :: String }- | Unhandeled Text+ | Unhandeled String | Ignored instance FromJSON URI where parseJSON (String t) = maybe mzero return $ parseURI $ unpack t- parseJSON _ = mzero+ parseJSON _ = mzero instance ToJSON URI where toJSON = toJSON . show ---- data BotData = BotData--- { botId :: Text--- , notName :: Text--- , botCreated :: UTCTime--- }---- {--- "ok": true,--- "url": "wss:\/\/ms9.slack-msgs.com\/websocket\/7I5yBpcvk",---- "self": {--- "id": "U023BECGF",--- "name": "bobby",--- "prefs": {--- …--- },--- "created": 1402463766,--- "manual_presence": "active"--- },--- "team": {--- "id": "T024BE7LD",--- "name": "Example Team",--- "email_domain": "",--- "domain": "example",--- "icon": {--- …--- },--- "msg_edit_window_mins": -1,--- "over_storage_limit": false--- "prefs": {--- …--- },--- "plan": "std"--- },--- "users": [ … ],---- "channels": [ … ],--- "groups": [ … ],--- "mpims": [ … ],--- "ims": [ … ],---- "bots": [ … ],--- } data RTMData = RTMData { ok :: Bool , url :: URI@@ -124,12 +95,8 @@ eventParser _ = mzero -rawBS :: BS.ByteString -> Text-rawBS bs = "\"" ++ toStrict (decodeUtf8 bs) ++ "\""---showt :: Show a => a -> Text-showt = pack . show+rawBS :: BS.ByteString -> String+rawBS bs = "\"" ++ BS.unpack bs ++ "\"" helloParser :: Value -> Parser Bool@@ -144,34 +111,43 @@ usr <- o .: "user" case usr of (Object o) -> UserInfo <$> o .: "name" <*> o .: "id"- _ -> mzero+ _ -> mzero userInfoParser _ = mzero apiResponseParser :: (Value -> Parser a) -> Value -> Parser (APIResponse a) apiResponseParser f v@(Object o) = APIResponse <$> o .: "ok" <*> f v-apiResponseParser _ _ = mzero+apiResponseParser _ _ = mzero +data SlackRTMAdapter = SlackRTMAdapter+ { sendMessage :: BS.ByteString -> IO ()+ , userConfig :: C.Config+ , midTracker :: MVar Int+ , channelChache :: MVar (HashMap Room LimitedChannelInfo)+ , userInfoCache :: MVar (HashMap User UserInfo)+ }++ runConnectionLoop :: C.Config -> MVar BS.ByteString -> MVar Connection -> IO () runConnectionLoop cfg messageChan connTracker = forever $ do token <- C.require cfg "token" debugM pa "initializing socket" r <- post "https://slack.com/api/rtm.start" [ "token" := (token :: Text) ] case eitherDecode (r^.responseBody) of- Left err -> errorM pa $ "Error decoding rtm json: " ++ pack err+ Left err -> errorM pa $ "Error decoding rtm json: " ++ err Right js -> do let uri = url js authority = fromMaybe (error "URI lacks authority") (uriAuthority uri) host = uriUserInfo authority ++ uriRegName authority path = uriPath uri portOnErr v = do- debugM pa $ "Unreadable port '" ++ pack v ++ "'"+ debugM pa $ "Unreadable port '" ++ v ++ "'" return 443 port <- case uriPort authority of- v@(':':r) -> maybe (portOnErr v) return $ readMay r- v -> portOnErr v- debugM pa $ "connecting to socket '" ++ showt uri ++ "'"+ v@(':':r) -> maybe (portOnErr v) return $ readMaybe r+ v -> portOnErr v+ debugM pa $ "connecting to socket '" ++ show uri ++ "'" catch (runSecureClient host port path $ \conn -> do debugM pa "Connection established"@@ -186,7 +162,7 @@ putMVar messageChan d) $ \e -> do void $ takeMVar connTracker- errorM pa (pack $ show (e :: ConnectionException))+ errorM pa (show (e :: ConnectionException)) where pa = error "Phantom value" :: SlackRTMAdapter @@ -196,7 +172,7 @@ forever $ do d <- takeMVar messageChan case eitherDecode d >>= parseEither eventParser of- Left err -> errorM adapter $ "Error parsing json: " ++ pack err ++ " original data: " ++ rawBS d+ Left err -> errorM adapter $ "Error parsing json: " ++ err ++ " original data: " ++ rawBS d Right v -> case v of Right event -> handler event@@ -205,7 +181,7 @@ Unhandeled type_ -> debugM adapter $ "Unhandeled event type " ++ type_ ++ " payload " ++ rawBS d Error code msg ->- errorM adapter $ "Error from remote code: " ++ showt code ++ " msg: " ++ msg+ errorM adapter $ "Error from remote code: " ++ show code ++ " msg: " ++ msg Ignored -> return () @@ -217,7 +193,7 @@ let send d = do conn <- readMVar connTracker sendTextData conn d- adapter = SlackRTMAdapter send cfg midTracker+ adapter <- SlackRTMAdapter send cfg midTracker <$> newMVar mempty <*> newMVar mempty handler <- handlerInit adapter void $ async $ runConnectionLoop cfg messageChan connTracker runHandlerLoop adapter messageChan handler@@ -227,7 +203,7 @@ execAPIMethod innerParser adapter method params = do token <- C.require cfg "token" response <- post ("https://slack.com/api/" ++ method) (("token" := (token :: Text)):params)- debugM adapter (toStrict $ decodeUtf8 $ response^.responseBody)+ debugM adapter (BS.unpack $ response^.responseBody) return $ eitherDecode (response^.responseBody) >>= parseEither (apiResponseParser innerParser) where cfg = userConfig adapter@@ -240,7 +216,7 @@ return id -messageRoomImpl :: SlackRTMAdapter -> Room -> Text -> IO ()+messageRoomImpl :: SlackRTMAdapter -> Room -> String -> IO () messageRoomImpl adapter (Room room) msg = do mid <- newMid adapter sendMessage adapter $ encode $@@ -251,24 +227,59 @@ ] -getUserInfoImpl :: SlackRTMAdapter -> User -> IO (Maybe UserInfo)-getUserInfoImpl adapter (User user) = do- usr <- execAPIMethod userInfoParser adapter "users.info" ["user" := user]- case usr of- Left err -> errorM adapter ("Parse error when getting user data " ++ pack err) >> return Nothing- Right (APIResponse True v) -> return (Just v)- Right (APIResponse False _) -> errorM adapter "Server denied getting user info request" >> return Nothing+data UserInfo = UserInfo+ { uiUsername :: String+ , uiId :: User+ } -data SlackRTMAdapter = SlackRTMAdapter- { sendMessage :: BS.ByteString -> IO ()- , userConfig :: C.Config- , midTracker :: MVar Int+getUserInfoImpl :: SlackRTMAdapter -> User -> IO UserInfo+getUserInfoImpl adapter user@(User user') = do+ uc <- readMVar $ userInfoCache adapter+ maybe refreshAndReturn return $ lookup user uc+ where+ refreshAndReturn = do+ usr <- execAPIMethod userInfoParser adapter "users.info" ["user" := user']+ case usr of+ Left err -> error ("Parse error when getting user data " ++ err)+ Right (APIResponse True v) -> do+ modifyMVar_ (userInfoCache adapter) (return . insertMap user v)+ return v+ Right (APIResponse False _) -> error "Server denied getting user info request"+++data LimitedChannelInfo = LimitedChannelInfo+ { lciId :: Room+ , lciName :: String } +lciParser (Object o) = LimitedChannelInfo <$> o .: "id" <*> o .: "name"+lciParser _ = mzero ++lciListParser (Array a) = toList <$> mapM lciParser a+lciListParser _ = mzero++getChannelNameImpl :: SlackRTMAdapter -> Room -> IO String+getChannelNameImpl adapter channel = do+ cc <- readMVar $ channelChache adapter+ maybe refreshAndReturn return $ lciName <$> lookup channel cc+ where+ refreshAndReturn = do+ usr <- execAPIMethod lciListParser adapter "channels.list" []+ case usr of+ Left err -> error ("Parse error when getting channel data " ++ err)+ Right (APIResponse True v) -> do+ let cmap = mapFromList $ map (lciId &&& id) v+ putMVar (channelChache adapter) cmap+ return $ lciName $ fromMaybe (error "Room not found") $ lookup channel cmap+ Right (APIResponse False _) -> error "Server denied getting channel info request"++ instance IsAdapter SlackRTMAdapter where adapterId = "slack-rtm" messageRoom = messageRoomImpl- getUserInfo = getUserInfoImpl runWithAdapter = runnerImpl+ getUsername a = fmap uiUsername . getUserInfoImpl a+ getChannelName = getChannelNameImpl+
src/Marvin/Internal.hs view
@@ -10,12 +10,13 @@ module Marvin.Internal where -import ClassyPrelude import Control.Monad.State import qualified Data.Configurator as C import qualified Data.Configurator.Types as C import Control.Lens hiding (cons)+import Data.Monoid ((<>))+import Data.Sequences import Marvin.Adapter (IsAdapter) import qualified Marvin.Adapter as A import Marvin.Internal.Types@@ -107,8 +108,20 @@ instance IsScript (BotReacting a b) where getScriptId = BotReacting $ use scriptId +class AccessAdapter m where+ type AdapterT m+ getAdapter :: m (AdapterT m)++instance AccessAdapter (ScriptDefinition a) where+ type AdapterT (ScriptDefinition a) = a+ getAdapter = ScriptDefinition $ use adapter++instance AccessAdapter (BotReacting a b) where+ type AdapterT (BotReacting a b) = a+ getAdapter = BotReacting $ use adapter+ getSubConfFor :: HasConfigAccess m => ScriptId -> m C.Config-getSubConfFor (ScriptId name) = C.subconfig ("script." ++ name) <$> getConfigInternal+getSubConfFor (ScriptId name) = C.subconfig ("script." <> name) <$> getConfigInternal getConfig :: HasConfigAccess m => m C.Config@@ -136,46 +149,43 @@ -- | Send a message to the channel the triggering message came from. -- -- Equivalent to "robot.send" in hubot-send :: (IsAdapter a, HasMessage m) => Text -> BotReacting a m ()+send :: (IsAdapter a, HasMessage m) => String -> BotReacting a m () send msg = do o <- getMessage messageRoom (channel o) msg -getUserInfo :: IsAdapter a => User -> BotReacting a m (Maybe UserInfo)-getUserInfo u = do- a <- BotReacting $ use adapter- liftIO $ A.getUserInfo a u+-- | Get the username of a registered user.+getUsername :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User -> m String+getUsername usr = do+ a <- getAdapter+ liftIO $ A.getUsername a usr +-- | Get the human readable name of a channel.+getChannelName :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Room -> m String+getChannelName rm = do+ a <- getAdapter+ liftIO $ A.getChannelName a rm++ -- | Send a message to the channel the original message came from and address the user that sent the original message. -- -- Equivalent to "robot.reply" in hubot-reply :: (IsAdapter a, HasMessage m) => Text -> BotReacting a m ()+reply :: (IsAdapter a, HasMessage m) => String -> BotReacting a m () reply msg = do om <- getMessage- user <- getUserInfo $ sender om- case user of- Nothing -> errorM "Message sender has no info, message was not sent"- Just user -> send $ username user ++ " " ++ msg+ user <- getUsername $ sender om+ send $ user ++ " " ++ msg -- | Send a message to a room-messageRoom :: IsAdapter a => Room -> Text -> BotReacting a s ()+messageRoom :: (IsAdapter (AdapterT m), AccessAdapter m, MonadIO m) => Room -> String -> m () messageRoom room msg = do- a <- BotReacting $ use adapter+ a <- getAdapter liftIO $ A.messageRoom a room msg - -- token <- requireAppConfigVal "token"- -- liftIO $ async $ post "https://slack.com/api/chat.postMessage"- -- [ "token" := (token :: Text)- -- , "channel" := roomname room- -- , "text" := msg- -- ]- -- return ()-- -- | Define a new script for marvin -- -- You need to provide a ScriptId (which can simple be written as a non-empty string).@@ -247,12 +257,18 @@ liftIO $ C.require cfg name +-- | Take a reaction and produce an IO action with the same effect.+-- Useful for creating actions which can be scheduled to execute a certain time or asynchronous.+-- The idea is that one can conveniently send messages from inside a schedulable action. extractReaction :: BotReacting a s o -> BotReacting a s (IO o) extractReaction reac = BotReacting $ do s <- get return $ evalStateT (runReaction reac) s +-- | Take an action and produce an IO action with the same effect.+-- Useful for creating actions which can be scheduled to execute a certain time or asynchronous.+-- The idea is that one can conveniently send messages from inside a schedulable action. extractAction :: BotReacting a () o -> ScriptDefinition a (IO o) extractAction ac = ScriptDefinition $ do a <- use adapter
src/Marvin/Internal/Types.hs view
@@ -5,43 +5,43 @@ module Marvin.Internal.Types where -import ClassyPrelude+import Control.Arrow ((&&&)) import Control.Lens+import Control.Monad+import Control.Monad.IO.Class import Data.Aeson import Data.Aeson.TH import Data.Char (isAlphaNum, isLetter) import qualified Data.Configurator.Types as C+import Data.Hashable+import Data.String+import Data.Text (Text, pack, toUpper, unpack) import qualified System.Log.Logger as L+import Text.Read (readMaybe) -newtype User = User Text deriving (IsString, Eq)-newtype Room = Room Text deriving (IsString, Eq, Show)+newtype User = User String deriving (IsString, Eq, Hashable)+newtype Room = Room String deriving (IsString, Eq, Show, Hashable) deriveJSON defaultOptions { unwrapUnaryRecords = True } ''User deriveJSON defaultOptions { unwrapUnaryRecords = True } ''Room -data UserInfo = UserInfo- { username :: Text- , userID :: User- }-- newtype TimeStamp = TimeStamp { unwrapTimeStamp :: Double } deriving Show data Message = Message { sender :: User , channel :: Room- , content :: Text+ , content :: String , timestamp :: TimeStamp } instance FromJSON TimeStamp where- parseJSON (String s) = maybe mzero (return . TimeStamp) $ readMay s- parseJSON _ = mzero+ parseJSON (String s) = maybe mzero (return . TimeStamp) $ readMaybe (unpack s)+ parseJSON _ = mzero instance ToJSON TimeStamp where toJSON = toJSON . show . unwrapTimeStamp@@ -95,5 +95,5 @@ instance C.Configured L.Priority where convert (C.String s) = lookup (toUpper s) prioMapping- convert _ = Nothing+ convert _ = Nothing
src/Marvin/Prelude.hs view
@@ -9,12 +9,8 @@ -} module Marvin.Prelude (- -- | For exposing parameterised and generalised versions of prelude functions- module ClassyPrelude- -- | Marvin :3- --- -- Common functions and Types for scripts- , module Marvin+ -- | Common functions and Types for scripts+ module Marvin -- | Mutable references in marvin scripts , module Marvin.Util.Mutable -- | Logging in Scripts@@ -26,14 +22,22 @@ -- | Dealing with JSON , module Marvin.Util.JSON -- | Format strings which resolve to efficient Strings, aka 'Text'- , module Data.Text.Format+ , module Text.Printf+ -- | Arbitrary IO in scripts+ , MonadIO, liftIO+ -- | Useful functions not in the normal Prelude+ , when, unless, for, for_, fromMaybe ) where -import ClassyPrelude-import Data.Text.Format (format) import Marvin import Marvin.Util.JSON import Marvin.Util.Logging import Marvin.Util.Mutable import Marvin.Util.Random import Marvin.Util.Regex+import Text.Printf+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad (when, unless)+import Data.Foldable (for_)+import Data.Traversable (for)+import Data.Maybe (fromMaybe)
src/Marvin/Run.hs view
@@ -17,28 +17,33 @@ {-# LANGUAGE TemplateHaskell #-} module Marvin.Run ( runMarvin, ScriptInit, IsAdapter+ , requireFromAppConfig, lookupFromAppConfig, defaultConfigName ) where -import ClassyPrelude-import Control.Concurrent.Async (wait)+import Control.Concurrent.Async (async, wait)+import Control.Exception import Control.Lens hiding (cons) import Control.Monad.State hiding (mapM_) import Data.Char (isSpace) import qualified Data.Configurator as C import qualified Data.Configurator.Types as C+import Data.Maybe (fromMaybe)+import Data.Sequences+import Data.Traversable (for) import Data.Vector (Vector) import Marvin.Adapter import Marvin.Internal hiding (match) import Marvin.Internal.Types hiding (channel) import Marvin.Util.Regex import Options.Generic-import qualified Prelude as P+import Prelude hiding (dropWhile, splitAt, (++)) import qualified System.Log.Formatter as L import qualified System.Log.Handler.Simple as L import qualified System.Log.Logger as L -+(++) :: Monoid a => a -> a -> a+(++) = mappend data CmdOptions = CmdOptions { configPath :: Maybe FilePath@@ -50,10 +55,14 @@ instance ParseRecord CmdOptions -defaultBotName :: Text+defaultBotName :: String defaultBotName = "marvin" +defaultConfigName :: FilePath+defaultConfigName = "config.cfg"++ requireFromAppConfig :: C.Configured a => C.Config -> C.Name -> IO a requireFromAppConfig cfg = C.require (C.subconfig (unwrapScriptId applicationScriptId) cfg) @@ -78,7 +87,7 @@ handleMessage msg = do lDispatches <- doIfMatch allListens text botname <- fromMaybe defaultBotName <$> lookupFromAppConfig cfg "name"- let (trimmed, remainder) = splitAt (length botname) $ dropWhile isSpace text+ let (trimmed, remainder) = splitAt (fromIntegral $ length botname) $ dropWhile isSpace text rDispatches <- if toLower trimmed == toLower botname then doIfMatch allReactions remainder else return mempty@@ -87,9 +96,9 @@ text = content msg doIfMatch things toMatch = catMaybes <$> for things (\(trigger, action) ->- case match trigger toMatch of+ case match [] trigger toMatch of Nothing -> return Nothing- Just m -> Just <$> async (action msg m))+ Just m -> Just <$> async (action msg m)) flattenActions = foldr $ \script -> flip (foldr (addAction script adapter)) (script^.actions) @@ -145,7 +154,7 @@ handler = L.GenericHandler { L.priority = L.DEBUG , L.formatter = L.simpleLogFormatter "$time [$prio:$loggername] $msg" , L.privData = ()- , L.writeFunc = const P.putStrLn+ , L.writeFunc = const putStrLn , L.closeFunc = const $ return () } @@ -158,7 +167,7 @@ when (verbose args) $ L.updateGlobalLogger L.rootLoggerName (L.setLevel L.INFO) when (debug args) $ L.updateGlobalLogger L.rootLoggerName (L.setLevel L.DEBUG) cfgLoc <- maybe- (L.noticeM "bot" "Using default config: config.cfg" >> return "config.cfg")+ (L.noticeM "bot" "Using default config: config.cfg" >> return defaultConfigName) return (configPath args) (cfg, cfgTid) <- C.autoReload C.autoConfig [C.Required cfgLoc]
src/Marvin/Types.hs view
@@ -8,7 +8,7 @@ Portability : POSIX -} module Marvin.Types- ( User(..), UserInfo(..), Room(..), Message(..), ScriptId(..)+ ( User(..), Room(..), Message(..), ScriptId(..) , applicationScriptId, IsScript, getScriptId , HasConfigAccess ) where
src/Marvin/Util/Logging.hs view
@@ -11,18 +11,18 @@ ( debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM, logM ) where -import ClassyPrelude+import Control.Monad.IO.Class+import Data.Text (unpack) import Marvin.Types-import qualified System.Log.Logger as L-+import qualified System.Log.Logger as L -scriptLog :: (MonadIO m, IsScript m) => (String -> String -> IO ()) -> Text -> m ()+scriptLog :: (MonadIO m, IsScript m) => (String -> String -> IO ()) -> String -> m () scriptLog inner message = do (ScriptId sid) <- getScriptId- liftIO $ inner (unpack $ "script." ++ sid) (unpack message)+ liftIO $ inner ("script." ++ unpack sid) message -debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM :: (MonadIO m, IsScript m) => Text -> m ()+debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM :: (MonadIO m, IsScript m) => String -> m () debugM = scriptLog L.debugM infoM = scriptLog L.infoM noticeM = scriptLog L.noticeM@@ -33,5 +33,5 @@ emergencyM = scriptLog L.emergencyM -logM :: (MonadIO m, IsScript m) => L.Priority -> Text -> m ()+logM :: (MonadIO m, IsScript m) => L.Priority -> String -> m () logM prio = scriptLog (`L.logM` prio)
src/Marvin/Util/Mutable.hs view
@@ -10,8 +10,8 @@ module Marvin.Util.Mutable where -import ClassyPrelude-+import Control.Monad.IO.Class+import Data.IORef -- | A mutable reference to a value of type @v@ type Mutable v = IORef v
src/Marvin/Util/Random.hs view
@@ -13,7 +13,9 @@ ) where -import ClassyPrelude+import Control.Monad.IO.Class+import Data.MonoTraversable+import Data.Sequences import System.Random @@ -35,5 +37,5 @@ -- Usable in all IO capable monads, such as 'BotReacting' and 'ScriptDefinition'. randomFrom :: (IsSequence s, Index s ~ Int, MonadIO m) => s -> m (Element s) randomFrom list = do- n <- randomValFromRange (0, pred $ length list)+ n <- randomValFromRange (0, pred $ olength list) return $ list `indexEx` n
src/Marvin/Util/Regex.hs view
@@ -8,15 +8,31 @@ Portability : POSIX -} module Marvin.Util.Regex- ( Regex, Match, r, match, MatchOption(..)+ ( Regex, Match, r, match+ -- * Compile time regex options+ , Re.PCREOption++ , Re.anchored, Re.auto_callout+ , Re.caseless, Re.dollar_endonly+ , Re.dotall, Re.dupnames, Re.extended+ , Re.extra, Re.firstline, Re.multiline+ , Re.newline_cr+ , Re.newline_crlf, Re.newline_lf, Re.no_auto_capture+ , Re.ungreedy, Re.utf8, Re.no_utf8_check++ -- * Runtime regex options+ , Re.PCREExecOption++ , Re.exec_anchored+ , Re.exec_newline_cr, Re.exec_newline_crlf, Re.exec_newline_lf+ , Re.exec_notbol, Re.exec_noteol, Re.exec_notempty+ , Re.exec_no_utf8_check, Re.exec_partial -- ** Unstable , unwrapRegex ) where --import ClassyPrelude-import Data.Text.ICU (MatchOption (..))-import qualified Data.Text.ICU as Re+import Data.String+import qualified Text.Regex.PCRE.Light.Char8 as Re -- | Abstract Wrapper for a reglar expression implementation. Has an 'IsString' implementation, so literal strings can be used to create a 'Regex'.@@ -33,20 +49,20 @@ -- | A match to a 'Regex'. Index 0 is the full match, all other indexes are match groups.-type Match = [Text]+type Match = [String] -- | Compile a regex with options -- -- Normally it is sufficient to just write the regex as a plain string and have it be converted automatically, but if you want certain match options you can use this function.-r :: [Re.MatchOption] -> Text -> Regex-r opts s = Regex $ Re.regex opts s+r :: [Re.PCREOption] -> String -> Regex+r opts s = Regex $ Re.compile s opts instance IsString Regex where fromString "" = error "Empty regex is not permitted, use '.*' or similar instead"- fromString s = r [] $ pack s+ fromString s = r [] s -- | Match a regex against a string and return the first match found (if any).-match :: Regex -> Text -> Maybe Match-match re = fmap (Re.unfold Re.group) . Re.find (unwrapRegex re)+match :: [Re.PCREExecOption] -> Regex -> String -> Maybe Match+match opts re s = Re.match (unwrapRegex re) s opts