marvin 0.0.4 → 0.0.5
raw patch · 16 files changed
+764/−418 lines, 16 filesdep +lifted-asyncdep +lifted-basedep +marvin-interpolatedep −hsloggerdep −optparse-genericdep −pcre-lightdep ~marvin
Dependencies added: lifted-async, lifted-base, marvin-interpolate, monad-logger, stm, text-icu
Dependencies removed: hslogger, optparse-generic, pcre-light, template-haskell, text-format
Dependency ranges changed: marvin
Files
- README.md +10/−10
- initializer/Main.hs +2/−1
- marvin.cabal +18/−15
- preprocessor/Main.hs +1/−0
- src/Marvin.hs +5/−7
- src/Marvin/Adapter.hs +27/−30
- src/Marvin/Adapter/Slack.hs +261/−135
- src/Marvin/Internal.hs +133/−29
- src/Marvin/Internal/Types.hs +30/−16
- src/Marvin/Prelude.hs +11/−10
- src/Marvin/Run.hs +173/−93
- src/Marvin/Util/JSON.hs +2/−1
- src/Marvin/Util/Logging.hs +0/−37
- src/Marvin/Util/Mutable.hs +55/−7
- src/Marvin/Util/Regex.hs +9/−27
- src/Util.hs +27/−0
README.md view
@@ -29,15 +29,13 @@ hear "sudo (.+)" $ do match <- getMatch - let thing = match !! 1-- reply $ "All right, i'll do " ++ thing+ reply $(isL "All right, i'll do #{match !! 1}") respond "open the (\\w+) door" $ do match <- getMatch let door = match !! 1 openDoor door- send $ printf "Door %s opened" door+ send $(isL "Door #{door} opened") respond "what is in file (\\w+)\\??" $ do match <- getMatch @@ -54,7 +52,7 @@ 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.+They get compiled into one single static binary, which acts depending on the adapter used, in the case of the slack real time messaging adapter for instance it opens a websocket to the slack server from which it recieves events as they happen in your chat application. ### Defining scripts @@ -175,12 +173,14 @@ #### Format strings -For String formatting Marvin re-exposes the `Text.Printf` module. +Marvins Prelude exposes the [marvin-interpolate](https://github.com/JustusAdam/marvin-interpolate) library, which enables the user to write CoffeeScript/Scala like interpolated Strings using Template Haskell. -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.+```haskell +str = let x = "Hello" in $(isL "#{x} World!")+-- "Hello World"+```+ #### JSON Exposed in `Marvin.Util.JSON` documentation coming soon. Until then refer to [aeson](https://hackage.haskell.org/package/aeson).@@ -189,7 +189,7 @@ 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`.+Several functions are available, depending on the urgency of your message, like `logError`, `logInfo` and `logWarn`. 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.
initializer/Main.hs view
@@ -12,6 +12,7 @@ import Prelude hiding (lookup) import System.Directory import System.FilePath+import System.IO import Text.Mustache.Compile import Text.Mustache.Render import Text.Mustache.Types@@ -51,7 +52,7 @@ main = do Opts{..} <- execParser infoParser d <- (</> "initializer") <$> getDataDir- unless (adapter `member` adType) $ putStrLn "Unrecognized adapter"+ unless (adapter `member` adType) $ hPutStrLn stderr "Unrecognized adapter" let subsData = object [ "name" ~> botname , "scriptsig" ~> maybe "IsAdapter a => ScriptInit a" ("ScriptInit " <>) (lookup adapter adType)
marvin.cabal view
@@ -1,15 +1,15 @@ name: marvin-version: 0.0.4+version: 0.0.5 cabal-version: >=1.10 build-type: Simple license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2016 Justus Adam maintainer: dev@justus.science-homepage: https://github.com/JustusAdam/marvin#readme-synopsis: A modular bot for slack+homepage: https://marvin.readthedocs.io+synopsis: A modular chat bot description:- Please see README.md+ The proper documentation is on readthedocs: https://marvin.readthedocs.io category: Development author: JustusAdam data-files:@@ -34,26 +34,25 @@ Marvin.Util.Mutable Marvin.Util.Regex Marvin.Util.Random- Marvin.Util.Logging Marvin.Util.JSON Marvin.Util.HTTP Marvin.Adapter Marvin.Adapter.Slack+ Marvin.Internal+ Marvin.Internal.Types build-depends: base >=4.7 && <5, wreq >=0.4.1.0 && <0.5, aeson >=0.11.2.1 && <0.12, mtl >=2.2.1 && <2.3, lens ==4.14.*,- pcre-light >=0.4.0.4 && <0.5,+ text-icu >=0.7.0.1 && <0.8, vector >=0.11.0.0 && <0.12,- optparse-generic >=1.1.1 && <1.2,+ optparse-applicative >=0.12.1.0 && <0.13, configurator >=0.3.0.0 && <0.4,- template-haskell >=2.11.0.0 && <2.12, bytestring >=0.10.8.1 && <0.11, async >=2.1.0 && <2.2,- hslogger >=1.2.10 && <1.3,- text-format >=0.3.1.1 && <0.4,+ monad-logger >=0.3.19 && <0.4, websockets >=0.9.7.0 && <0.10, network-uri >=2.6.1.0 && <2.7, wuss >=1.1.1 && <1.2,@@ -62,14 +61,18 @@ text >=1.2.2.1 && <1.3, mtl >=2.2.1 && <2.3, unordered-containers >=0.2.7.1 && <0.3,- mono-traversable >=1.0.0.1 && <1.1+ mono-traversable >=1.0.0.1 && <1.1,+ stm >=2.4.4.1 && <2.5,+ marvin-interpolate >0.4 && <0.5,+ lifted-base >=0.2.3.8 && <0.3,+ lifted-async >=0.9.0 && <0.10 default-language: Haskell2010 default-extensions: OverloadedStrings TypeFamilies- MultiParamTypeClasses TupleSections GADTs+ MultiParamTypeClasses TupleSections GADTs TemplateHaskell+ QuasiQuotes hs-source-dirs: src other-modules:- Marvin.Internal- Marvin.Internal.Types+ Util executable marvin-pp main-is: Main.hs@@ -78,7 +81,7 @@ mustache ==2.1.*, directory >=1.2.6.2 && <1.3, filepath >=1.4.1.0 && <1.5,- marvin >=0.0.4 && <0.1,+ marvin >=0.0.5 && <0.1, configurator >=0.3.0.0 && <0.4, optparse-applicative >=0.12.1.0 && <0.13, bytestring >=0.10.8.1 && <0.11,
preprocessor/Main.hs view
@@ -26,6 +26,7 @@ } +slackRtmData :: (String, String) slackRtmData = ("Marvin.Adapter.Slack", "SlackRTMAdapter")
src/Marvin.hs view
@@ -15,19 +15,17 @@ , ScriptDefinition , IsAdapter -- * Reacting- , hear, respond, customTrigger, send, reply, messageChannel- , getData, getMessage, getMatch, getUsername, getChannelName+ , hear, respond, enter, exit, enterIn, exitFrom, topic, topicIn, customTrigger+ , send, reply, messageChannel, messageChannel'+ , getData, getMessage, getMatch, getTopic, getChannel, getUser, getUsername, getChannelName , Message(..), User, Channel , getConfigVal, requireConfigVal- , BotReacting, HasMessage(messageLens), HasMatch(matchLens)+ , BotReacting, HasMessage(messageLens), HasMatch(matchLens), HasTopic(topicLens), HasChannel(channelLens), HasUser(userLens) -- ** Advanced actions , extractAction, extractReaction- -- * Lenses and internal types- , HasScriptId(scriptId), HasConfig(config), HasAdapter(adapter), HasMessageField(messageField), HasMatchField(matchField), HasVariable(variable), BotActionState(BotActionState), MessageReactionData(MessageReactionData), HasActions(actions) ) where -import Marvin.Adapter (IsAdapter)+import Marvin.Adapter (IsAdapter) import Marvin.Internal import Marvin.Internal.Types-import Marvin.Types
src/Marvin/Adapter.hs view
@@ -10,51 +10,48 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-module Marvin.Adapter where+module Marvin.Adapter+ ( Event(..)+ , RunWithAdapter, EventHandler, InitEventHandler, RunnerM+ , IsAdapter(..)+ , liftAdapterAction+ ) where import Control.Monad.IO.Class+import Control.Monad.Logger import qualified Data.Configurator.Types as C-import Data.Text (unpack)+import qualified Data.Text.Lazy as L import Marvin.Internal.Types-import qualified System.Log.Logger as L ++-- | Representation for the types of events which can occur data Event = MessageEvent Message+ | ChannelJoinEvent User Channel+ | ChannelLeaveEvent User Channel+ | TopicChangeEvent L.Text Channel type EventHandler a = Event -> IO () type InitEventHandler a = a -> IO (EventHandler a)+type RunWithAdapter a = C.Config -> InitEventHandler a -> RunnerM () +-- | Basic functionality required of any adapter class IsAdapter a where+ -- | Used for scoping config and logging adapterId :: AdapterId a- messageChannel :: a -> Channel -> String -> IO ()+ -- | Post a message to a channel given the internal channel identifier+ messageChannel :: a -> Channel -> L.Text -> RunnerM ()+ -- | Initialize and run the bot runWithAdapter :: RunWithAdapter a- getUsername :: a -> User -> IO String- getChannelName :: a -> Channel -> IO String- resolveChannel :: a -> String -> IO (Maybe Channel)---type RunWithAdapter a = C.Config -> InitEventHandler a -> IO ()----adapterLog :: forall m a. (MonadIO m, IsAdapter a) => (String -> String -> IO ()) -> a -> String -> m ()-adapterLog inner _ 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 -> String -> m ()-debugM = adapterLog L.debugM-infoM = adapterLog L.infoM-noticeM = adapterLog L.noticeM-warningM = adapterLog L.warningM-errorM = adapterLog L.errorM-criticalM = adapterLog L.criticalM-alertM = adapterLog L.alertM-emergencyM = adapterLog L.emergencyM+ -- | Resolve a username given the internal user identifier+ getUsername :: a -> User -> RunnerM L.Text+ -- | Resolve the human readable name for a channel given the internal channel identifier+ getChannelName :: a -> Channel -> RunnerM L.Text+ -- | Resolve to the internal channel identifier given a human readable name+ resolveChannel :: a -> L.Text -> RunnerM (Maybe Channel) -logM :: (MonadIO m, IsAdapter a) => L.Priority -> a -> String -> m ()-logM prio = adapterLog (`L.logM` prio)+liftAdapterAction :: MonadIO m => RunnerM a -> m a+liftAdapterAction = liftIO . runStderrLoggingT
src/Marvin/Adapter/Slack.hs view
@@ -1,47 +1,56 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TemplateHaskell #-}+{-|+Module : $Header$+Description : Adapter for communicating with Slack via its real time event API+Copyright : (c) Justus Adam, 2016+License : BSD3+Maintainer : dev@justus.science+Stability : experimental+Portability : POSIX+-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeSynonymInstances #-} module Marvin.Adapter.Slack (SlackRTMAdapter) where -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.Applicative ((<|>))+import Control.Arrow ((&&&))+import Control.Concurrent.Async.Lifted (async)+import Control.Concurrent.Chan.Lifted (Chan, newChan, readChan, writeChan)+import Control.Concurrent.MVar.Lifted (MVar, modifyMVar_, newEmptyMVar, newMVar, putMVar,+ readMVar, takeMVar)+import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar, takeTMVar)+import Control.Exception.Lifted+import Control.Lens hiding ((.=)) import Control.Monad-import Data.Aeson hiding (Error)+import Control.Monad.IO.Class+import Control.Monad.Logger+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.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.Foldable (toList)+import Data.HashMap.Strict (HashMap)+import Data.IORef.Lifted+import Data.Maybe (fromMaybe) import Data.Sequences-import Data.Text (Text, pack)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L import Marvin.Adapter-import Marvin.Types+import Marvin.Interpolate.Text+import Marvin.Types as Types import Network.URI import Network.WebSockets import Network.Wreq-import Prelude hiding (lookup)-import Text.Read (readMaybe)+import Prelude hiding (lookup)+import Text.Read (readMaybe) import Wuss -data InternalType- = Error- { code :: Int- , msg :: String- }- | Unhandeled String- | Ignored-- instance FromJSON URI where parseJSON (String t) = maybe mzero return $ parseURI $ unpack t parseJSON _ = mzero@@ -63,11 +72,58 @@ } +declareFields [d|+ data LimitedChannelInfo = LimitedChannelInfo+ { limitedChannelInfoIdValue :: Channel+ , limitedChannelInfoName :: L.Text+ , limitedChannelInfoTopic :: L.Text+ } deriving Show+ |]++declareFields [d|+ data UserInfo = UserInfo+ { userInfoUsername :: L.Text+ , userInfoIdValue :: User+ }+ |]+++declareFields [d|+ data ChannelCache = ChannelCache+ { channelCacheInfoCache :: HashMap Channel LimitedChannelInfo+ , channelCacheNameResolver :: HashMap L.Text Channel+ }+ |]+++data InternalType+ = Error+ { code :: Int+ , msg :: String+ }+ | Unhandeled String+ | Ignored+ | ChannelArchiveStatusChange Channel Bool+ | ChannelCreated LimitedChannelInfo+ | ChannelDeleted Channel+ | ChannelRename LimitedChannelInfo+ | UserChange UserInfo++ deriveJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } ''RTMData +messageParser :: Value -> Parser Types.Message+messageParser (Object o) = Message+ <$> o .: "user"+ <*> o .: "channel"+ <*> o .: "text"+ <*> o .: "ts"+messageParser _ = mzero++ eventParser :: Value -> Parser (Either InternalType Event)-eventParser (Object o) = isErrParser <|> hasTypeParser+eventParser v@(Object o) = isErrParser <|> hasTypeParser where isErrParser = do e <- o .: "error"@@ -79,18 +135,51 @@ hasTypeParser = do t <- o .: "type" + -- https://api.slack.com/rtm case t of "error" -> do ev <- Error <$> o .: "code" <*> o .: "msg" return $ Left ev "message" -> do- ev <- Message- <$> o .: "user"- <*> o .: "channel"- <*> o .: "text"- <*> o .: "ts"- return $ Right (MessageEvent ev)+ subt <- o .:? "subtype"+ case (subt :: Maybe T.Text) of+ Just str ->+ case str of+ "channel_join" -> cJoin+ "group_join" -> cJoin+ "channel_leave" -> cLeave+ "group_leave" -> cLeave+ "channel_topic" -> do+ t <- TopicChangeEvent <$> o .: "topic" <*> o .: "channel"+ return $ Right t+ _ -> msgEv++ _ -> msgEv+ where+ msgEv = Right . MessageEvent <$> messageParser v+ cJoin = do+ ev <- ChannelJoinEvent <$> o .: "user" <*> o .: "channel"+ return $ Right ev+ cLeave = do+ ev <- ChannelLeaveEvent <$> o .: "user" <*> o .: "channel"+ return $ Right ev "reconnect_url" -> return $ Left Ignored+ "channel_archive" -> do+ ev <- ChannelArchiveStatusChange <$> o .: "channel" <*> pure True+ return $ Left ev+ "channel_unarchive" -> do+ ev <- ChannelArchiveStatusChange <$> o .: "channel" <*> pure False+ return $ Left ev+ "channel_created" -> do+ ev <- o .: "channel" >>= lciParser+ return $ Left $ ChannelCreated ev+ "channel_deleted" -> Left . ChannelDeleted <$> o .: "channel"+ "channel_rename" -> do+ ev <- o .: "channel" >>= lciParser+ pure $ Left $ ChannelRename ev+ "user_change" -> do+ ev <- o .: "user" >>= userInfoParser+ pure $ Left $ UserChange ev _ -> return $ Left $ Unhandeled t eventParser _ = mzero @@ -102,7 +191,7 @@ helloParser :: Value -> Parser Bool helloParser (Object o) = do t <- o .: "type"- return $ (t :: Text) == "hello"+ return $ (t :: T.Text) == "hello" helloParser _ = mzero @@ -119,193 +208,230 @@ apiResponseParser f v@(Object o) = APIResponse <$> o .: "ok" <*> f v apiResponseParser _ _ = mzero --data ChannelCache = ChannelCache- { ccCache :: HashMap Channel LimitedChannelInfo- , nameResolver :: HashMap String Channel- }-- data SlackRTMAdapter = SlackRTMAdapter- { sendMessage :: BS.ByteString -> IO ()+ { sendMessage :: BS.ByteString -> RunnerM () , userConfig :: C.Config- , midTracker :: MVar Int- , channelChache :: MVar ChannelCache- , userInfoCache :: MVar (HashMap User UserInfo)+ , midTracker :: TMVar Int+ , channelChache :: IORef ChannelCache+ , userInfoCache :: IORef (HashMap User UserInfo) } -runConnectionLoop :: C.Config -> MVar BS.ByteString -> MVar Connection -> IO ()+runConnectionLoop :: C.Config -> Chan BS.ByteString -> MVar Connection -> RunnerM () 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) ]+ token <- liftIO $ C.require cfg "token"+ $logDebug "initializing socket"+ r <- liftIO $ post "https://slack.com/api/rtm.start" [ "token" := (token :: T.Text) ] case eitherDecode (r^.responseBody) of- Left err -> errorM pa $ "Error decoding rtm json: " ++ err+ Left err -> logErrorN $(isT "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 '" ++ v ++ "'"+ logErrorN $(isT "Unreadable port #{v}") return 443 port <- case uriPort authority of v@(':':r) -> maybe (portOnErr v) return $ readMaybe r v -> portOnErr v- debugM pa $ "connecting to socket '" ++ show uri ++ "'"+ $logDebug $(isT "connecting to socket '#{uri}'")+ logFn <- askLoggerIO catch- (runSecureClient host port path $ \conn -> do- debugM pa "Connection established"- d <- receiveData conn+ (liftIO $ runSecureClient host port path $ \conn -> flip runLoggingT logFn $ do+ logInfoN "Connection established"+ d <- liftIO $ receiveData conn case eitherDecode d >>= parseEither helloParser of- Right True -> debugM pa "Recieved hello packet"+ Right True -> $logDebug "Recieved hello packet" Left _ -> error $ "Hello packet not readable: " ++ BS.unpack d _ -> error $ "First packet was not hello packet: " ++ BS.unpack d putMVar connTracker conn forever $ do- d <- receiveData conn- putMVar messageChan d)+ d <- liftIO $ receiveData conn+ writeChan messageChan d) $ \e -> do void $ takeMVar connTracker- errorM pa (show (e :: ConnectionException))- where- pa = error "Phantom value" :: SlackRTMAdapter+ logErrorN $(isT "#{e :: ConnectionException}") -runHandlerLoop :: SlackRTMAdapter -> MVar BS.ByteString -> EventHandler SlackRTMAdapter -> IO ()+runHandlerLoop :: SlackRTMAdapter -> Chan BS.ByteString -> EventHandler SlackRTMAdapter -> RunnerM () runHandlerLoop adapter messageChan handler = forever $ do- d <- takeMVar messageChan+ d <- readChan messageChan case eitherDecode d >>= parseEither eventParser of- Left err -> errorM adapter $ "Error parsing json: " ++ err ++ " original data: " ++ rawBS d+ Left err -> logErrorN $(isT "Error parsing json: #{err} original data: #{rawBS d}") Right v -> case v of- Right event -> handler event+ Right event -> liftIO $ handler event Left internalEvent -> case internalEvent of Unhandeled type_ ->- debugM adapter $ "Unhandeled event type " ++ type_ ++ " payload " ++ rawBS d+ $logDebug $(isT "Unhandeled event type #{type_} payload: #{rawBS d}") Error code msg ->- errorM adapter $ "Error from remote code: " ++ show code ++ " msg: " ++ msg+ logErrorN $(isT "Error from remote code: #{code} msg: #{msg}") Ignored -> return ()+ ChannelArchiveStatusChange _ _ ->+ -- TODO implement once we track the archiving status+ return ()+ ChannelCreated info ->+ putChannel adapter info+ ChannelDeleted chan -> deleteChannel adapter chan+ ChannelRename info -> renameChannel adapter info+ UserChange ui -> void $ refreshUserInfo adapter (ui^.idValue) +sendMessageImpl :: MVar Connection -> BS.ByteString -> RunnerM ()+sendMessageImpl connTracker msg = go (3 :: Int)+ where+ go 0 = logErrorN "Connection error, quitting retry."+ go n =+ catch+ (do+ conn <- readMVar connTracker+ liftIO $ sendTextData conn msg)+ $ \e -> do+ logErrorN $(isT "#{e :: ConnectionException}")+ go (n-1)++ runnerImpl :: RunWithAdapter SlackRTMAdapter runnerImpl cfg handlerInit = do- midTracker <- newMVar 0+ midTracker <- liftIO $ atomically $ newTMVar 0 connTracker <- newEmptyMVar- messageChan <- newEmptyMVar- let send d = do- conn <- readMVar connTracker- sendTextData conn d- adapter <- SlackRTMAdapter send cfg midTracker <$> newMVar (ChannelCache mempty mempty) <*> newMVar mempty- handler <- handlerInit adapter+ messageChan <- newChan+ let send = sendMessageImpl connTracker+ adapter <- SlackRTMAdapter send cfg midTracker <$> newIORef (ChannelCache mempty mempty) <*> newIORef mempty+ handler <- liftIO $ handlerInit adapter void $ async $ runConnectionLoop cfg messageChan connTracker runHandlerLoop adapter messageChan handler -execAPIMethod :: (Value -> Parser a) -> SlackRTMAdapter -> String -> [FormParam] -> IO (Either String (APIResponse a))+execAPIMethod :: (Value -> Parser a) -> SlackRTMAdapter -> String -> [FormParam] -> RunnerM (Either String (APIResponse a)) execAPIMethod innerParser adapter method params = do- token <- C.require cfg "token"- response <- post ("https://slack.com/api/" ++ method) (("token" := (token :: Text)):params)- debugM adapter (BS.unpack $ response^.responseBody)+ token <- liftIO $ C.require cfg "token"+ response <- liftIO $ post ("https://slack.com/api/" ++ method) (("token" := (token :: T.Text)):params) return $ eitherDecode (response^.responseBody) >>= parseEither (apiResponseParser innerParser) where cfg = userConfig adapter -newMid :: SlackRTMAdapter -> IO Int-newMid SlackRTMAdapter{midTracker} = do- id <- takeMVar midTracker- putMVar midTracker (id + 1)+newMid :: SlackRTMAdapter -> RunnerM Int+newMid SlackRTMAdapter{midTracker} = liftIO $ atomically $ do+ id <- takeTMVar midTracker+ putTMVar midTracker (id + 1) return id -messageChannelImpl :: SlackRTMAdapter -> Channel -> String -> IO ()+messageChannelImpl :: SlackRTMAdapter -> Channel -> L.Text -> RunnerM () messageChannelImpl adapter (Channel chan) msg = do mid <- newMid adapter sendMessage adapter $ encode $ object [ "id" .= mid- , "type" .= ("message" :: Text)+ , "type" .= ("message" :: T.Text) , "channel" .= chan , "text" .= msg ] -data UserInfo = UserInfo- { uiUsername :: String- , uiId :: User- }---getUserInfoImpl :: SlackRTMAdapter -> User -> IO UserInfo+getUserInfoImpl :: SlackRTMAdapter -> User -> RunnerM 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"+ uc <- readIORef $ userInfoCache adapter+ maybe (refreshUserInfo adapter user) return $ lookup user uc -data LimitedChannelInfo = LimitedChannelInfo- { lciId :: Channel- , lciName :: String- }+refreshUserInfo :: SlackRTMAdapter -> User -> RunnerM UserInfo+refreshUserInfo adapter user@(User user') = 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+ atomicModifyIORef (userInfoCache adapter) ((, ()) . insertMap user v)+ return v+ Right (APIResponse False _) -> error "Server denied getting user info request" -lciParser (Object o) = LimitedChannelInfo <$> o .: "id" <*> o .: "name"++lciParser :: Value -> Parser LimitedChannelInfo+lciParser (Object o) = LimitedChannelInfo <$> o .: "id" <*> o .: "name" <*> (o .: "topic" >>= withObject "object" (.: "value")) lciParser _ = mzero -lciListParser (Array a) = toList <$> mapM lciParser a-lciListParser _ = mzero+lciListParser :: Value -> Parser [LimitedChannelInfo]+lciListParser = withArray "array" $ fmap toList . mapM lciParser -refreshChannels :: SlackRTMAdapter -> IO ChannelCache+refreshChannels :: SlackRTMAdapter -> RunnerM (Either String ChannelCache) refreshChannels adapter = do- usr <- execAPIMethod lciListParser adapter "channels.list" []+ usr <- execAPIMethod (withObject "object" (\o -> o .: "channels" >>= lciListParser)) adapter "channels.list" [] case usr of- Left err -> error ("Parse error when getting channel data " ++ err)+ Left err -> return $ Left $ "Parse error when getting channel data " ++ err Right (APIResponse True v) -> do- let cmap = mapFromList $ map (lciId &&& id) v- nmap = mapFromList $ map (lciName &&& lciId) v+ let cmap = mapFromList $ map ((^. idValue) &&& id) v+ nmap = mapFromList $ map ((^. name) &&& (^. idValue)) v cache = ChannelCache cmap nmap- putMVar (channelChache adapter) cache- return cache- Right (APIResponse False _) -> error "Server denied getting channel info request"+ atomicWriteIORef (channelChache adapter) cache+ return $ Right cache+ Right (APIResponse False _) -> return $ Left "Server denied getting channel info request" -resolveChannelImpl :: SlackRTMAdapter -> String -> IO (Maybe Channel)-resolveChannelImpl adapter name = do- cc <- readMVar $ channelChache adapter- case lookup name (nameResolver cc) of+resolveChannelImpl :: SlackRTMAdapter -> L.Text -> RunnerM (Maybe Channel)+resolveChannelImpl adapter name' = do+ cc <- readIORef $ channelChache adapter+ case cc ^? nameResolver . ix name of Nothing -> do- ncc <- refreshChannels adapter- return $ lookup name (nameResolver ncc)+ refreshed <- refreshChannels adapter+ case refreshed of+ Left err -> logErrorN $(isT "#{err}") >> return Nothing+ Right ncc -> return $ ncc ^? nameResolver . ix name Just found -> return (Just found)+ where name = L.tail name' -getChannelNameImpl :: SlackRTMAdapter -> Channel -> IO String+getChannelNameImpl :: SlackRTMAdapter -> Channel -> RunnerM L.Text getChannelNameImpl adapter channel = do- cc <- readMVar $ channelChache adapter- case lookup channel (ccCache cc) of- Nothing -> do- ncc <- refreshChannels adapter- return $ lciName $ fromMaybe (error "Channel not found") $ lookup channel (ccCache ncc)- Just found -> return $ lciName found+ cc <- readIORef $ channelChache adapter+ L.cons '#' <$>+ case cc ^? infoCache . ix channel of+ Nothing -> do+ ncc <- either error id <$> refreshChannels adapter+ return $ (^.name) $ fromMaybe (error "Channel not found") $ ncc ^? infoCache . ix channel+ Just found -> return $ found ^. name +putChannel :: SlackRTMAdapter -> LimitedChannelInfo -> RunnerM ()+putChannel SlackRTMAdapter{channelChache} channelInfo@(LimitedChannelInfo id name _) =+ void $ atomicModifyIORef channelChache $ \cache ->+ (, ()) $ cache+ & infoCache . at id .~ Just channelInfo+ & nameResolver . at name .~ Just id+++deleteChannel :: SlackRTMAdapter -> Channel -> RunnerM ()+deleteChannel SlackRTMAdapter{channelChache} channel =+ void $ atomicModifyIORef channelChache $ \cache ->+ case cache ^? infoCache . ix channel of+ Nothing -> (cache, ())+ Just (LimitedChannelInfo _ name _) ->+ (, ()) $ cache & infoCache . at channel .~ Nothing+ & nameResolver . at name .~ Nothing+++renameChannel :: SlackRTMAdapter -> LimitedChannelInfo -> RunnerM ()+renameChannel SlackRTMAdapter{channelChache} channelInfo@(LimitedChannelInfo id name _) =+ void $ atomicModifyIORef channelChache $ \cache ->+ let inserted = cache & infoCache . at id .~ Just channelInfo+ & nameResolver . at name .~ Just id+ in case cache ^? infoCache . ix id of+ Just (LimitedChannelInfo _ oldName _) | oldName /= name ->+ (, ()) $ inserted & nameResolver . at oldName .~ Nothing+ _ -> (inserted, ())+++ instance IsAdapter SlackRTMAdapter where adapterId = "slack-rtm" messageChannel = messageChannelImpl runWithAdapter = runnerImpl- getUsername a = fmap uiUsername . getUserInfoImpl a+ getUsername a = fmap (^.username) . getUserInfoImpl a getChannelName = getChannelNameImpl resolveChannel = resolveChannelImpl
src/Marvin/Internal.hs view
@@ -4,8 +4,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Marvin.Internal where @@ -16,13 +16,16 @@ import qualified Data.Configurator.Types as C import Control.Lens hiding (cons)+import Control.Monad.Logger import Data.Monoid ((<>)) import Data.Sequences+import qualified Data.Text.Lazy as L import Marvin.Adapter (IsAdapter) import qualified Marvin.Adapter as A import Marvin.Internal.Types-import Marvin.Util.Logging+import Marvin.Interpolate.Text import Marvin.Util.Regex (Match, Regex)+import Util -- | Read only data available to a handler when the bot reacts to an event.@@ -48,9 +51,18 @@ |] +type Topic = L.Text++ data ActionData d where Hear :: Regex -> ActionData MessageReactionData Respond :: Regex -> ActionData MessageReactionData+ Join :: ActionData (User, Channel)+ JoinIn :: L.Text -> ActionData (User, Channel)+ Leave :: ActionData (User, Channel)+ LeaveFrom :: L.Text -> ActionData (User, Channel)+ TopicC :: ActionData (Topic, Channel)+ TopicCIn :: L.Text -> ActionData (Topic, Channel) Custom :: (A.Event -> Maybe d) -> ActionData d @@ -64,10 +76,10 @@ -- -- For completeness: @a@ is the adapter type and @r@ is the return type of the monadic computation. ----- This is also a 'MonadReader' instance, there you can inspect the entire state of this reaction. +-- This is also a 'MonadReader' instance, there you can inspect the entire state of this reaction. -- This is typically only used in internal or utility functions and not necessary for the user. -- To inspect particular pieces of this state refer to the *Lenses* section.-newtype BotReacting a d r = BotReacting { runReaction :: ReaderT (BotActionState a d) IO r } deriving (Monad, MonadIO, Applicative, Functor, MonadReader (BotActionState a d))+newtype BotReacting a d r = BotReacting { runReaction :: ReaderT (BotActionState a d) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadReader (BotActionState a d), MonadLogger) -- | An abstract type describing a marvin script. --@@ -85,11 +97,11 @@ -- | A monad for gradually defining a 'Script' using 'respond' and 'hear' as well as any 'IO' action.-newtype ScriptDefinition a r = ScriptDefinition { runScript :: StateT (Script a) IO r } deriving (Monad, MonadIO, Applicative, Functor)+newtype ScriptDefinition a r = ScriptDefinition { runScript :: StateT (Script a) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadLogger) -- | Initializer for a script. This gets run by the server during startup and creates a 'Script'-newtype ScriptInit a = ScriptInit (ScriptId, a -> C.Config -> IO (Script a))+newtype ScriptInit a = ScriptInit (ScriptId, a -> C.Config -> RunnerM (Script a)) -- | Class which says that there is a way to get to a 'Message' from this type @m@.@@ -106,6 +118,37 @@ instance HasMatchField m Match => HasMatch m where matchLens = matchField +-- | Class which says that there is a way to get to a topic of type 'String' from this type @m@.+class HasTopic m where+ topicLens :: Lens' m L.Text++instance HasTopic (Topic, a) where+ topicLens = _1++idLens :: Lens' a a+idLens = lens id (flip const)++class HasChannel a where+ channelLens :: Lens' a Channel++instance HasChannel (a, Channel) where+ channelLens = _2++instance HasChannel MessageReactionData where+ channelLens = messageField . lens channel (\a b -> a {channel = b})++class HasUser a where+ userLens :: Lens' a User++instance HasUser User where+ userLens = idLens++instance HasUser (User, a) where+ userLens = _1++instance HasUser MessageReactionData where+ userLens = messageField . lens sender (\a b -> a {sender = b})+ instance HasConfigAccess (ScriptDefinition a) where getConfigInternal = ScriptDefinition $ use config @@ -156,65 +199,111 @@ respond !re = addReaction (Respond re) +-- | This handler runs whenever a user enters __any channel__ (which the bot is subscribed to)+--+-- The payload contains the entering user and the channel which was entered.+enter :: BotReacting a (User, Channel) () -> ScriptDefinition a ()+enter = addReaction Join+++-- | This handler runs whenever a user exits __any channel__ (which the bot is subscribed to)+--+-- The payload contains the exiting user and the channel which was exited.+exit :: BotReacting a (User, Channel) () -> ScriptDefinition a ()+exit = addReaction Leave+++-- | This handler runs whenever a user enters __the specified channel__.+--+-- The argument is the human readable name for the channel.+--+-- The payload contains the entering user.+enterIn :: L.Text -> BotReacting a (User, Channel) () -> ScriptDefinition a ()+enterIn !chanName = addReaction (JoinIn chanName)+++-- | This handler runs whenever a user exits __the specified channel__, provided the bot is subscribed to the channel in question.+--+-- The argument is the human readable name for the channel.+--+-- The payload contains the exting user.+exitFrom :: L.Text -> BotReacting a (User, Channel) () -> ScriptDefinition a ()+exitFrom !chanName = addReaction (LeaveFrom chanName)+++-- | This handler runs when the topic in __any channel__ the bot is subscribed to changes.+--+-- The payload contains the new topic and the channel in which it was set.+topic :: BotReacting a (Topic, Channel) () -> ScriptDefinition a ()+topic = addReaction TopicC+++-- | This handler runs when the topic in __the specified channel__ is changed, provided the bot is subscribed to the channel in question.+--+-- The argument is the human readable channel name.+topicIn :: L.Text -> BotReacting a (Topic, Channel) () -> ScriptDefinition a ()+topicIn !chanName = addReaction (TopicCIn chanName)++ -- | Extension point for the user--- +-- -- Allows you to handle the raw event yourself. -- Returning 'Nothing' from the trigger function means you dont want to react to the event. -- The value returned inside the 'Just' is available in the handler later using 'getData'. customTrigger :: (A.Event -> Maybe d) -> BotReacting a d () -> ScriptDefinition a ()-customTrigger tr = addReaction (Custom tr) +customTrigger tr = addReaction (Custom tr) -- | Send a message to the channel the triggering message came from. -- -- Equivalent to "robot.send" in hubot-send :: (IsAdapter a, HasMessage m) => String -> BotReacting a m ()+send :: (IsAdapter a, HasChannel m) => L.Text -> BotReacting a m () send msg = do- o <- getMessage- messageChannel' (channel o) msg+ o <- getChannel+ messageChannel' o msg -- | Get the username of a registered user.-getUsername :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User -> m String+getUsername :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User -> m L.Text getUsername usr = do a <- getAdapter- liftIO $ A.getUsername a usr+ A.liftAdapterAction $ A.getUsername a usr -resolveChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => String -> m (Maybe Channel)+resolveChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => L.Text -> m (Maybe Channel) resolveChannel name = do a <- getAdapter- liftIO $ A.resolveChannel a name+ A.liftAdapterAction $ A.resolveChannel a name -- | Get the human readable name of a channel.-getChannelName :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel -> m String+getChannelName :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel -> m L.Text getChannelName rm = do a <- getAdapter- liftIO $ A.getChannelName a rm+ A.liftAdapterAction $ 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) => String -> BotReacting a m ()+reply :: (IsAdapter a, HasMessage m) => L.Text -> BotReacting a m () reply msg = do om <- getMessage user <- getUsername $ sender om- send $ user ++ " " ++ msg+ messageChannel' (channel om) $ user <> " " <> msg -- | Send a message to a Channel (by name)-messageChannel :: (AccessAdapter m, IsAdapter (AdapterT m), IsScript m, MonadIO m) => String -> String -> m ()+messageChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m, MonadLogger m) => L.Text -> L.Text -> m () messageChannel name msg = do mchan <- resolveChannel name- maybe (errorM $ "No channel known with the name " ++ name) (`messageChannel'` msg) mchan+ maybe ($logError $(isT "No channel known with the name #{name}")) (`messageChannel'` msg) mchan -messageChannel' :: (AccessAdapter m, IsAdapter (AdapterT m), IsScript m, MonadIO m) => Channel -> String -> m ()+messageChannel' :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel -> L.Text -> m () messageChannel' chan msg = do a <- getAdapter- liftIO $ A.messageChannel a chan msg+ A.liftAdapterAction $ A.messageChannel a chan msg @@ -229,13 +318,13 @@ ScriptInit (sid, runDefinitions sid definitions) -runDefinitions :: ScriptId -> ScriptDefinition a () -> a -> C.Config -> IO (Script a)+runDefinitions :: ScriptId -> ScriptDefinition a () -> a -> C.Config -> RunnerM (Script a) runDefinitions sid definitions ada cfg = execStateT (runScript definitions) (Script mempty sid cfg ada) --- | Obtain the event reaction data. --- --- The type of this data depends on the reacion function used.+-- | Obtain the event reaction data.+--+-- The type of this data depends on the reaction function used. -- For instance 'hear' and 'respond' will contain 'MessageReactionData'. -- The actual contents comes from the event itself and was put together by the trigger. getData :: BotReacting a d d@@ -255,6 +344,21 @@ getMessage = view (variable . messageLens) +-- | Get the the new topic.+getTopic :: HasTopic m => BotReacting a m Topic+getTopic = view (variable . topicLens)+++-- | Get the stored channel in which something happened.+getChannel :: HasChannel m => BotReacting a m Channel+getChannel = view (variable . channelLens)+++-- | Get the user whihc was part of the triggered action.+getUser :: HasUser m => BotReacting a m User+getUser = view (variable . userLens)++ -- | Get a value out of the config, returns 'Nothing' if the value didn't exist. -- -- This config is the config for this script. Ergo all config vars registered under the config section for the ScriptId of this script.@@ -299,7 +403,7 @@ extractReaction :: BotReacting a s o -> BotReacting a s (IO o) extractReaction reac = BotReacting $ do s <- ask- return $ runReaderT (runReaction reac) s+ return $ runStderrLoggingT $ runReaderT (runReaction reac) s -- | Take an action and produce an IO action with the same effect.@@ -310,4 +414,4 @@ a <- use adapter sid <- use scriptId cfg <- use config- return $ runReaderT (runReaction ac) (BotActionState sid cfg a ())+ return $ runStderrLoggingT $ runReaderT (runReaction ac) (BotActionState sid cfg a ())
src/Marvin/Internal/Types.hs view
@@ -5,23 +5,27 @@ module Marvin.Internal.Types where -import Control.Arrow ((&&&)) import Control.Lens import Control.Monad import Control.Monad.IO.Class+import Control.Monad.Logger import Data.Aeson import Data.Aeson.TH import Data.Char (isAlphaNum, isLetter) import qualified Data.Configurator.Types as C import Data.Hashable+import qualified Data.HashMap.Strict as HM import Data.String-import Data.Text (Text, pack, toUpper, unpack)-import qualified System.Log.Logger as L+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Marvin.Interpolate.Text import Text.Read (readMaybe) -newtype User = User String deriving (IsString, Eq, Hashable)-newtype Channel = Channel String deriving (IsString, Eq, Show, Hashable)+-- | Identifier for a user (internal and not necessarily equal to the username)+newtype User = User T.Text deriving (IsString, Eq, Hashable)+-- | Identifier for a channel (internal and not necessarily equal to the channel name)+newtype Channel = Channel T.Text deriving (IsString, Eq, Show, Hashable) deriveJSON defaultOptions { unwrapUnaryRecords = True } ''User@@ -31,16 +35,17 @@ newtype TimeStamp = TimeStamp { unwrapTimeStamp :: Double } deriving Show +-- | contents and meta information of a recieved message data Message = Message { sender :: User , channel :: Channel- , content :: String+ , content :: LT.Text , timestamp :: TimeStamp } instance FromJSON TimeStamp where- parseJSON (String s) = maybe mzero (return . TimeStamp) $ readMaybe (unpack s)+ parseJSON (String s) = maybe mzero (return . TimeStamp) $ readMaybe (T.unpack s) parseJSON _ = mzero instance ToJSON TimeStamp where@@ -48,17 +53,25 @@ -- | A type, basically a String, which identifies a script to the config and the logging facilities.-newtype ScriptId = ScriptId { unwrapScriptId :: Text } deriving (Show, Eq)+newtype ScriptId = ScriptId { unwrapScriptId :: T.Text } deriving (Show, Eq) -- | A type, basically a String, which identifies an adapter to the config and the logging facilities.-newtype AdapterId a = AdapterId { unwrapAdapterId :: Text } deriving (Show, Eq)+newtype AdapterId a = AdapterId { unwrapAdapterId :: T.Text } deriving (Show, Eq) +instance ShowT ScriptId where showT = unwrapScriptId++instance ShowT (AdapterId a) where showT = unwrapAdapterId++ applicationScriptId :: ScriptId applicationScriptId = ScriptId "bot" +type RunnerM = LoggingT IO++ verifyIdString :: String -> (String -> a) -> String -> a verifyIdString name _ "" = error $ name ++ " must not be empty" verifyIdString name f s@(x:xs)@@ -88,12 +101,13 @@ class IsScript m where getScriptId :: m ScriptId --prioMapping :: [(Text, L.Priority)]-prioMapping = map ((pack . show) &&& id) [L.DEBUG, L.INFO, L.NOTICE, L.WARNING, L.ERROR, L.CRITICAL, L.ALERT, L.EMERGENCY]---instance C.Configured L.Priority where- convert (C.String s) = lookup (toUpper s) prioMapping+instance C.Configured LogLevel where+ convert (C.String s) =+ case T.strip $ T.toLower s of+ "debug" -> Just LevelDebug+ "warning" -> Just LevelWarn+ "error" -> Just LevelError+ "info" -> Just LevelInfo+ _ -> Nothing convert _ = Nothing
src/Marvin/Prelude.hs view
@@ -14,30 +14,31 @@ -- | Mutable references in marvin scripts , module Marvin.Util.Mutable -- | Logging in Scripts- , module Marvin.Util.Logging+ , module Control.Monad.Logger -- | Random numbers and convenience functions , module Marvin.Util.Random -- | Marvins regex type and how to work with it , module Marvin.Util.Regex -- | Dealing with JSON , module Marvin.Util.JSON- -- | Format strings which resolve to efficient Strings, aka 'Text'- , module Text.Printf+ -- | Interpolated strings a la Scala and CoffeeScript+ , isL, isT -- | Arbitrary IO in scripts , MonadIO, liftIO -- | Useful functions not in the normal Prelude , when, unless, for, for_, fromMaybe ) where -import Control.Monad (unless, when)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Foldable (for_)-import Data.Maybe (fromMaybe)-import Data.Traversable (for)+import Control.Monad (unless, when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Logger+import Data.Foldable (for_)+import Data.Maybe (fromMaybe)+import Data.Traversable (for) import Marvin+import Marvin.Interpolate.Text (isT)+import Marvin.Interpolate.Text.Lazy (isL) import Marvin.Util.JSON-import Marvin.Util.Logging import Marvin.Util.Mutable import Marvin.Util.Random import Marvin.Util.Regex-import Text.Printf
src/Marvin/Run.hs view
@@ -7,12 +7,13 @@ Stability : experimental Portability : POSIX -}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Marvin.Run@@ -21,42 +22,40 @@ ) where -import Control.Concurrent.Async (async, wait)-import Control.Exception-import Control.Lens hiding (cons)+import Control.Concurrent.Async.Lifted (async, wait)+import Control.Exception.Lifted+import Control.Lens hiding (cons)+import Control.Monad.Logger import Control.Monad.Reader-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, mapMaybe)-import Data.Monoid ((<>))+import qualified Data.Configurator as C+import qualified Data.Configurator.Types as C+import Data.Foldable (for_)+import qualified Data.HashMap.Strict as HM+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Monoid ((<>)) 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 qualified Data.Text as T+import qualified Data.Text.Lazy as L+import Data.Traversable (for)+import Data.Vector (Vector)+import Marvin.Adapter as A+import Marvin.Internal+import Marvin.Internal.Types hiding (channel)+import Marvin.Interpolate.Text import Marvin.Util.Regex-import Options.Generic-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-import Data.Foldable (for_)+import Options.Applicative+import Prelude hiding (dropWhile, splitAt)+import Util data CmdOptions = CmdOptions { configPath :: Maybe FilePath , verbose :: Bool , debug :: Bool- } deriving (Generic)---instance ParseRecord CmdOptions+ } -defaultBotName :: String+defaultBotName :: L.Text defaultBotName = "marvin" @@ -64,6 +63,10 @@ defaultConfigName = "config.cfg" +defaultLoggingLevel :: LogLevel+defaultLoggingLevel = LevelWarn++ requireFromAppConfig :: C.Configured a => C.Config -> C.Name -> IO a requireFromAppConfig cfg = C.require (C.subconfig (unwrapScriptId applicationScriptId) cfg) @@ -73,124 +76,201 @@ declareFields [d|- data Handlers = Handlers- { handlersResponds :: [(Regex, Message -> Match -> IO ())]- , handlersHears :: [(Regex, Message -> Match -> IO ())]- , handlersCustoms :: [Event -> Maybe (IO ())]+ data Handlers f = Handlers+ { handlersResponds :: f (Regex, Message -> Match -> RunnerM ())+ , handlersHears :: f (Regex, Message -> Match -> RunnerM ())+ , handlersCustoms :: f (Event -> Maybe (RunnerM ()))+ , handlersJoins :: f ((User, Channel) -> RunnerM ())+ , handlersLeaves :: f ((User, Channel) -> RunnerM ())+ , handlersTopicChange :: f ((Topic, Channel) -> RunnerM ())+ , handlersJoinsIn :: HM.HashMap L.Text (f ((User, Channel) -> RunnerM ()))+ , handlersLeavesFrom :: HM.HashMap L.Text (f ((User, Channel) -> RunnerM ()))+ , handlersTopicChangeIn :: HM.HashMap L.Text (f ((Topic, Channel) -> RunnerM ())) } |] +mapHandlerFunctor :: (forall a. f a -> f' a) -> Handlers f -> Handlers f'+mapHandlerFunctor f (Handlers respondsV hearsV customsV joinsV leavesV topicsV joinsInV leavesFromV topicsInV) =+ Handlers (f respondsV) (f hearsV) (f customsV) (f joinsV) (f leavesV) (f topicsV)+ (fmap f joinsInV) (fmap f leavesFromV) (fmap f topicsInV)++ -- TODO add timeouts for handlers-mkApp :: [Script a] -> C.Config -> a -> EventHandler a-mkApp scripts cfg adapter = genericHandler+mkApp :: IsAdapter a => LoggingFn -> [Script a] -> C.Config -> a -> EventHandler a+mkApp log scripts cfg adapter = flip runLoggingT log . genericHandler where genericHandler ev = do generics <- async $ do- let applicables = mapMaybe ($ ev) allCustoms+ let applicables = catMaybes $ fmap ($ ev) customsV asyncs <- for applicables async for_ asyncs wait handler ev wait generics handler (MessageEvent msg) = handleMessage msg+ -- TODO implement other handlers+ handler (ChannelJoinEvent user chan) = changeHandlerHelper joinsV joinsInV user chan+ handler (ChannelLeaveEvent user chan) = changeHandlerHelper leavesV leavesFromV user chan+ handler (TopicChangeEvent topic chan) = changeHandlerHelper topicsV topicsInV topic chan + changeHandlerHelper :: Vector ((b, Channel) -> RunnerM ())+ -> (HM.HashMap L.Text (Vector ((b, Channel) -> RunnerM ())))+ -> b+ -> Channel+ -> RunnerM ()+ changeHandlerHelper wildcards specifics other chan = do+ cName <- A.getChannelName adapter chan++ let applicables = fromMaybe mempty $ specifics^?ix cName++ wildcards <- for wildcards (async . ($ (other, chan)))++ applicablesRunning <- for applicables (async . ($ (other, chan)))++ mapM_ wait $ wildcards `mappend` applicablesRunning+++ handleMessage msg = do- lDispatches <- doIfMatch allListens text- botname <- fromMaybe defaultBotName <$> lookupFromAppConfig cfg "name"- let (trimmed, remainder) = splitAt (fromIntegral $ length botname) $ dropWhile isSpace text+ lDispatches <- doIfMatch hearsV text+ botname <- fromMaybe defaultBotName <$> liftIO (lookupFromAppConfig cfg "name")+ let (trimmed, remainder) = L.splitAt (fromIntegral $ succ $ L.length botname) $ L.stripStart text -- TODO At some point this needs to support derivations of the name. Maybe make that configurable?- rDispatches <- if toLower trimmed == toLower botname- then doIfMatch allReactions remainder+ rDispatches <- if L.stripEnd (L.toLower trimmed) == L.strip (L.toLower botname)+ then doIfMatch respondsV remainder else return mempty mapM_ wait (lDispatches <> rDispatches) where 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)) flattenActions = foldr $ \script -> flip (foldr (addAction script adapter)) (script^.actions) - allActions = flattenActions (Handlers mempty mempty mempty) scripts-- allReactions :: Vector (Regex, Message -> Match -> IO ())- allReactions = fromList $! allActions^.responds- allListens :: Vector (Regex, Message -> Match -> IO ())- allListens = fromList $! allActions^.hears- allCustoms :: [Event -> Maybe (IO ())]- allCustoms = allActions^.customs + Handlers respondsV hearsV customsV joinsV leavesV topicsV joinsInV leavesFromV topicsInV =+ (mapHandlerFunctor fromList :: Handlers [] -> Handlers Vector)+ $ flattenActions (Handlers mempty mempty mempty mempty mempty mempty mempty mempty mempty :: Handlers []) scripts -addAction :: Script a -> a -> WrappedAction a -> Handlers -> Handlers+addAction :: forall a. Script a -> a -> WrappedAction a -> Handlers [] -> Handlers [] addAction script adapter wa = case wa of- (WrappedAction (Hear re) ac) -> hears %~ cons (re, runMessageAction script adapter re ac)- (WrappedAction (Respond re) ac) -> responds %~ cons (re, runMessageAction script adapter re ac)- (WrappedAction (Custom matcher) ac) -> customs %~ cons h+ WrappedAction (Hear re) ac -> hears %~ cons (re, runMessageAction script adapter re ac)+ WrappedAction (Respond re) ac -> responds %~ cons (re, runMessageAction script adapter re ac)+ WrappedAction Join ac -> joins %~ cons (\d -> botAcWith (Just "Join event" :: Maybe T.Text) d ac)+ WrappedAction Leave ac -> leaves %~ cons (\d -> botAcWith (Just "Leave event" :: Maybe T.Text) d ac)+ WrappedAction (JoinIn chName) ac -> joinsIn . at chName %~ Just . maybe (return reac) (cons reac)+ where reac chan = botAcWith (Just "Join event" :: Maybe T.Text) chan ac+ WrappedAction (LeaveFrom chName) ac -> leavesFrom . at chName %~ Just . maybe (return reac) (cons reac)+ where reac chan = botAcWith (Just "Leave event" :: Maybe T.Text) chan ac+ WrappedAction TopicC ac -> topicChange %~ cons (\d -> botAcWith (Just "Topic event" :: Maybe T.Text) d ac)+ WrappedAction (TopicCIn chanName) ac -> topicChangeIn . at chanName %~ Just . maybe (return reac) (cons reac)+ where reac chan = botAcWith (Just "Topic event" :: Maybe T.Text) chan ac+ WrappedAction (Custom matcher) ac -> customs %~ cons h where h ev = run <$> matcher ev- run s = runReaderT (runReaction ac) (BotActionState (script^.scriptId) (script^.config) adapter s)+ run s = botAcWith (Nothing :: Maybe ()) s ac+ where+ botAcWith :: ShowT t => Maybe t -> d -> BotReacting a d () -> RunnerM ()+ botAcWith = runBotAction script adapter -runMessageAction :: Script a -> a -> Regex -> BotReacting a MessageReactionData () -> Message -> Match -> IO ()-runMessageAction script adapter re ac msg mtch =+runBotAction :: ShowT t => Script a -> a -> Maybe t -> d -> BotReacting a d () -> RunnerM ()+runBotAction script adapter trigger data_ action = do+ oldLogFn <- askLoggerIO catch- (runReaderT (runReaction ac) (BotActionState (script^.scriptId) (script^.config) adapter (MessageReactionData msg mtch)))- (onScriptExcept (script^.scriptId) re)+ (liftIO $ flip runLoggingT (loggingAddSourcePrefix $(isT "script.#{script^.scriptId}") oldLogFn) $ flip runReaderT actionState $ runReaction action)+ (onScriptExcept (script^.scriptId) trigger) + where+ actionState = BotActionState (script^.scriptId) (script^.config) adapter data_ -onScriptExcept :: ScriptId -> Regex -> SomeException -> IO ()-onScriptExcept (ScriptId id) r e = do- err $ "Unhandled exception during execution of script " <> show id <> " with trigger " <> show r- err $ show e++runMessageAction :: Script a -> a -> Regex -> BotReacting a MessageReactionData () -> Message -> Match -> RunnerM ()+runMessageAction script adapter re ac msg mtch =+ runBotAction script adapter (Just re) (MessageReactionData msg mtch) ac+++onScriptExcept :: ShowT t => ScriptId -> Maybe t -> SomeException -> RunnerM ()+onScriptExcept id trigger e = do+ case trigger of+ Just t ->+ err $(isT "Unhandled exception during execution of script #{id} with trigger #{t}")+ Nothing ->+ err $(isT "Unhandled exception during execution of script #{id}")+ err $(isT "#{e}") where- err = L.errorM "bot.dispatch"+ err = logErrorNS "#{applicationScriptId}.dispatch" -- | Create a wai compliant application-application :: [ScriptInit a] -> C.Config -> InitEventHandler a-application inits config ada = do- L.infoM "bot" "Initializing scripts"+application :: IsAdapter a => LoggingFn -> [ScriptInit a] -> C.Config -> InitEventHandler a+application log inits config ada = flip runLoggingT log $ do+ $logInfoS "bot" "Initializing scripts" s <- catMaybes <$> mapM (\(ScriptInit (sid, s)) -> catch (Just <$> s ada config) (onInitExcept sid)) inits- return $ mkApp s config ada+ return $ mkApp log s config ada where- onInitExcept :: ScriptId -> SomeException -> IO (Maybe a')+ onInitExcept :: ScriptId -> SomeException -> RunnerM (Maybe a') onInitExcept (ScriptId id) e = do- err $ "Unhandled exception during initialization of script " <> show id- err $ show e+ err $(isT "Unhandled exception during initialization of script ${id}")+ err $(isT "#{e}") return Nothing- where err = L.errorM "bot.init"+ where err = logErrorNS $(isT "#{applicationScriptId}.init") -prepareLogger :: IO ()-prepareLogger =- L.updateGlobalLogger L.rootLoggerName (L.setHandlers [handler])- where- handler = L.GenericHandler { L.priority = L.DEBUG- , L.formatter = L.simpleLogFormatter "$time [$prio:$loggername] $msg"- , L.privData = ()- , L.writeFunc = const putStrLn- , L.closeFunc = const $ return ()- }-+setLoggingLevelIn :: LogLevel -> RunnerM a -> RunnerM a+setLoggingLevelIn lvl = filterLogger f+ where f _ lvl2 = lvl2 >= lvl +-- | Runs the marvin bot using whatever method the adapter uses. runMarvin :: forall a. IsAdapter a => [ScriptInit a] -> IO ()-runMarvin s' = do- prepareLogger- args <- getRecord "bot server"- when (verbose args) $ L.updateGlobalLogger L.rootLoggerName (L.setLevel L.INFO)- when (debug args) $ L.updateGlobalLogger L.rootLoggerName (L.setLevel L.DEBUG)+runMarvin s' = runStderrLoggingT $ do+ -- prepareLogger+ args <- liftIO $ execParser infoParser+ cfgLoc <- maybe- (L.noticeM "bot" "Using default config: config.cfg" >> return defaultConfigName)- return- (configPath args)- (cfg, cfgTid) <- C.autoReload C.autoConfig [C.Required cfgLoc]- unless (verbose args || debug args) $ C.lookup cfg "bot.logging" >>= maybe (return ()) (L.updateGlobalLogger L.rootLoggerName . L.setLevel)+ ($logInfoS $(isT "${applicationScriptId}") "Using default config: config.cfg" >> return defaultConfigName)+ return+ (configPath args)+ (cfg, cfgTid) <- liftIO $ C.autoReload C.autoConfig [C.Required cfgLoc]+ loggingLevelFromCfg <- liftIO $ C.lookup cfg $(isT "#{applicationScriptId}.logging") - runWithAdapter- (C.subconfig ("adapter." <> unwrapAdapterId (adapterId :: AdapterId a)) cfg)- $ application s' cfg+ let loggingLevel+ | debug args = LevelDebug+ | verbose args = LevelInfo+ | otherwise = fromMaybe defaultLoggingLevel loggingLevelFromCfg++ setLoggingLevelIn loggingLevel $ do+ oldLogFn <- askLoggerIO+ liftIO $ flip runLoggingT (loggingAddSourcePrefix adapterPrefix oldLogFn) $ runWithAdapter+ (C.subconfig adapterPrefix cfg)+ $ application oldLogFn s' cfg+ where+ adapterPrefix = $(isT "adapter.#{adapterId :: AdapterId a}")+ infoParser = info+ (helper <*> optsParser)+ (fullDesc <> header "Instance of marvin, the modular bot.")+ optsParser = CmdOptions+ <$> optional+ ( strOption+ $ long "config-path"+ <> value defaultConfigName+ <> short 'c'+ <> metavar "PATH"+ <> help "root cofiguration file for the bot"+ <> showDefault+ )+ <*> switch+ ( long "verbose"+ <> short 'v'+ <> help "enable verbose logging (overrides config)"+ )+ <*> switch+ ( long "debug"+ <> help "enable debug logging (overrides config and verbose flag)"+ )
src/Marvin/Util/JSON.hs view
@@ -10,7 +10,8 @@ This is provisionary, this might get properly wrapped at some point. -} module Marvin.Util.JSON- ( module Data.Aeson+ ( readJSON, writeJSON+ , module Data.Aeson , module Data.Aeson.TH ) where
− src/Marvin/Util/Logging.hs
@@ -1,37 +0,0 @@-{-|-Module : $Header$-Description : Logging facilities for marvin scripts.-Copyright : (c) Justus Adam, 2016-License : BSD3-Maintainer : dev@justus.science-Stability : experimental-Portability : POSIX--}-module Marvin.Util.Logging- ( debugM, infoM, noticeM, warningM, errorM, criticalM, alertM, emergencyM, logM- ) where--import Control.Monad.IO.Class-import Data.Text (unpack)-import Marvin.Types-import qualified System.Log.Logger as L--scriptLog :: (MonadIO m, IsScript m) => (String -> String -> IO ()) -> String -> m ()-scriptLog inner message = do- (ScriptId sid) <- getScriptId- liftIO $ inner ("script." ++ unpack sid) message---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-warningM = scriptLog L.warningM-errorM = scriptLog L.errorM-criticalM = scriptLog L.criticalM-alertM = scriptLog L.alertM-emergencyM = scriptLog L.emergencyM---logM :: (MonadIO m, IsScript m) => L.Priority -> String -> m ()-logM prio = scriptLog (`L.logM` prio)
src/Marvin/Util/Mutable.hs view
@@ -10,10 +10,14 @@ module Marvin.Util.Mutable where +import Control.Concurrent.MVar import Control.Monad.IO.Class import Data.IORef -- | A mutable reference to a value of type @v@+--+-- This is like a pointer in c, the value behind which can be mutated by several functions.+-- So long as they retain this reference they are able to retrieve the updated value. type Mutable v = IORef v @@ -37,16 +41,60 @@ modifyMutable m = liftIO . modifyIORef m --- type Synchronized = MVar+-- | A value that can be shared on multiple concurrent Threads.+--+-- This value works like a channel. It can either be empty or full.+-- If it is empty 'writeSynchronized' fills it, otherwise the write blocks.+-- If it is full 'takeSynchronized' empties, otherwise it blocks until it is filled.+-- 'readSynchronized' does not empty it and also blocks if the 'Synchronized' is empty.+--+-- Should you just use it as a thread safe mutable variable, mutations typically follow the pattern:+-- @+-- val <- takeSynchronized -- obtain the value and leave it empty to block concurrent reads+-- let mod = modify val -- modify the value+-- writeSynchronized val -- write back the result+-- @+--+-- Another use for this type is as a message channel, where we have a producer and a consumer,+-- the producer tries to write values into the 'Synchronized' ('writeSynchronized') and the consumer+-- waits for the 'Synchronized' to be filled and takes the value 'takeSynchronized' for procesing.+--+-- It works generally best if any 'Synchronized' is only used for one of these two applications at the same time.+--+-- This type is the same as 'MVar', only renamed for readability. If you want a more in depth documentation, see the documentation for 'MVar'.+type Synchronized = MVar --- readSynchronized :: MonadIO m => Synchronized a -> m a--- readSynchronized = liftIO . readMVar+-- | Read the vaue, but don't empty the 'Synchronized'. Blocks if it is empty.+readSynchronized :: MonadIO m => Synchronized a -> m a+readSynchronized = liftIO . readMVar --- tryReadSynchronized :: MonadIO m => Synchronized a -> m (Maybe a)--- tryReadSynchronized = liftIO . tryReadMVar+-- | Non blocking version of 'readSynchronized'. Returns 'Nothing' if it was empty.+tryReadSynchronized :: MonadIO m => Synchronized a -> m (Maybe a)+tryReadSynchronized = liftIO . tryReadMVar --- writeSynchronized :: MonadIO m => Synchronized a -> m ()--- writeSynchronized+-- | Read the value and empty the 'Synchronized', blocks if already empty.+takeSynchronized :: MonadIO m => Synchronized a -> m a+takeSynchronized = liftIO . takeMVar+++-- | Non blocking version of 'takeSynchronized', returns 'Nothing' if it was empty.+tryTakeSynchronized :: MonadIO m => Synchronized a -> m (Maybe a)+tryTakeSynchronized = liftIO . tryTakeMVar+++-- | Fills the empty 'Synchronized' with a value, blocks if it is full.+writeSynchronized :: MonadIO m => Synchronized a -> a -> m ()+writeSynchronized mv = liftIO . putMVar mv+++-- | Non blocking version of 'writeSynchronized'. Returns 'False' if it was full.+tryWriteSynchronized :: MonadIO m => Synchronized a -> a -> m Bool+tryWriteSynchronized mv = liftIO . tryPutMVar mv+++-- | Query if the 'Synchronized' is empty or full.+isEmptySynchronized :: MonadIO m => Synchronized a -> m Bool+isEmptySynchronized = liftIO . isEmptyMVar
src/Marvin/Util/Regex.hs view
@@ -9,30 +9,12 @@ -} module Marvin.Util.Regex ( 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+ , Re.MatchOption(..) ) where import Data.String-import qualified Text.Regex.PCRE.Light.Char8 as Re+import qualified Data.Text.ICU as Re+import qualified Data.Text.Lazy as L -- | Abstract Wrapper for a reglar expression implementation. Has an 'IsString' implementation, so literal strings can be used to create a 'Regex'.@@ -49,20 +31,20 @@ -- | A match to a 'Regex'. Index 0 is the full match, all other indexes are match groups.-type Match = [String]+type Match = [L.Text] -- | 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.PCREOption] -> String -> Regex-r opts s = Regex $ Re.compile s opts+r :: [Re.MatchOption] -> L.Text -> Regex+r opts = Regex . Re.regex opts . L.toStrict instance IsString Regex where fromString "" = error "Empty regex is not permitted, use '.*' or similar instead"- fromString s = r [] s+ fromString s = r [] (L.pack s) -- | Match a regex against a string and return the first match found (if any).-match :: [Re.PCREExecOption] -> Regex -> String -> Maybe Match-match opts re s = Re.match (unwrapRegex re) s opts+match :: Regex -> L.Text -> Maybe Match+match re s = map L.fromStrict . Re.unfold Re.group <$> Re.find (unwrapRegex re) (L.toStrict s)
+ src/Util.hs view
@@ -0,0 +1,27 @@+module Util where+++import Control.Monad.Logger+import qualified Data.Text as T+import Marvin.Interpolate.Text+++notImplemented :: a+notImplemented = error "Not implemented"+++addPrefix :: T.Text -> T.Text -> T.Text+addPrefix prefix source+ | T.null source = prefix+ | otherwise = $(isT "#{prefix}.#{source}")+++adaptLoggingSource :: (d -> b) -> (a -> b -> c) -> a -> d -> c+adaptLoggingSource adapt old loc source = old loc (adapt source)+++loggingAddSourcePrefix :: T.Text -> (a -> T.Text -> c) -> a -> T.Text -> c+loggingAddSourcePrefix = adaptLoggingSource . addPrefix+++type LoggingFn = Loc -> LogSource -> LogLevel -> LogStr -> IO ()