diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/initializer/Main.hs b/initializer/Main.hs --- a/initializer/Main.hs +++ b/initializer/Main.hs @@ -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) diff --git a/marvin.cabal b/marvin.cabal --- a/marvin.cabal +++ b/marvin.cabal @@ -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, diff --git a/preprocessor/Main.hs b/preprocessor/Main.hs --- a/preprocessor/Main.hs +++ b/preprocessor/Main.hs @@ -26,6 +26,7 @@ } +slackRtmData :: (String, String) slackRtmData = ("Marvin.Adapter.Slack", "SlackRTMAdapter") diff --git a/src/Marvin.hs b/src/Marvin.hs --- a/src/Marvin.hs +++ b/src/Marvin.hs @@ -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 diff --git a/src/Marvin/Adapter.hs b/src/Marvin/Adapter.hs --- a/src/Marvin/Adapter.hs +++ b/src/Marvin/Adapter.hs @@ -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 diff --git a/src/Marvin/Adapter/Slack.hs b/src/Marvin/Adapter/Slack.hs --- a/src/Marvin/Adapter/Slack.hs +++ b/src/Marvin/Adapter/Slack.hs @@ -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 diff --git a/src/Marvin/Internal.hs b/src/Marvin/Internal.hs --- a/src/Marvin/Internal.hs +++ b/src/Marvin/Internal.hs @@ -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 ()) diff --git a/src/Marvin/Internal/Types.hs b/src/Marvin/Internal/Types.hs --- a/src/Marvin/Internal/Types.hs +++ b/src/Marvin/Internal/Types.hs @@ -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 diff --git a/src/Marvin/Prelude.hs b/src/Marvin/Prelude.hs --- a/src/Marvin/Prelude.hs +++ b/src/Marvin/Prelude.hs @@ -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 diff --git a/src/Marvin/Run.hs b/src/Marvin/Run.hs --- a/src/Marvin/Run.hs +++ b/src/Marvin/Run.hs @@ -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)" + ) diff --git a/src/Marvin/Util/JSON.hs b/src/Marvin/Util/JSON.hs --- a/src/Marvin/Util/JSON.hs +++ b/src/Marvin/Util/JSON.hs @@ -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 diff --git a/src/Marvin/Util/Logging.hs b/src/Marvin/Util/Logging.hs deleted file mode 100644 --- a/src/Marvin/Util/Logging.hs +++ /dev/null @@ -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) diff --git a/src/Marvin/Util/Mutable.hs b/src/Marvin/Util/Mutable.hs --- a/src/Marvin/Util/Mutable.hs +++ b/src/Marvin/Util/Mutable.hs @@ -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 diff --git a/src/Marvin/Util/Regex.hs b/src/Marvin/Util/Regex.hs --- a/src/Marvin/Util/Regex.hs +++ b/src/Marvin/Util/Regex.hs @@ -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) diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -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 ()