marvin 0.0.5 → 0.0.6
raw patch · 9 files changed
+618/−331 lines, 9 filesdep +waidep +warpdep ~marvin
Dependencies added: wai, warp
Dependency ranges changed: marvin
Files
- marvin.cabal +6/−3
- preprocessor/Main.hs +5/−2
- src/Marvin.hs +18/−9
- src/Marvin/Adapter.hs +3/−31
- src/Marvin/Adapter/Slack.hs +103/−67
- src/Marvin/Adapter/Telegram.hs +241/−0
- src/Marvin/Internal.hs +191/−109
- src/Marvin/Internal/Types.hs +37/−15
- src/Marvin/Run.hs +14/−95
marvin.cabal view
@@ -1,5 +1,5 @@ name: marvin-version: 0.0.5+version: 0.0.6 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -38,6 +38,7 @@ Marvin.Util.HTTP Marvin.Adapter Marvin.Adapter.Slack+ Marvin.Adapter.Telegram Marvin.Internal Marvin.Internal.Types build-depends:@@ -65,7 +66,9 @@ 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+ lifted-async >=0.9.0 && <0.10,+ wai >=3.2.1.1 && <3.3,+ warp >=3.2.8 && <3.3 default-language: Haskell2010 default-extensions: OverloadedStrings TypeFamilies MultiParamTypeClasses TupleSections GADTs TemplateHaskell@@ -81,7 +84,7 @@ mustache ==2.1.*, directory >=1.2.6.2 && <1.3, filepath >=1.4.1.0 && <1.5,- marvin >=0.0.5 && <0.1,+ marvin >=0.0.6 && <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
@@ -27,12 +27,15 @@ slackRtmData :: (String, String)-slackRtmData = ("Marvin.Adapter.Slack", "SlackRTMAdapter")+slackRtmData = ("Marvin.Adapter.Slack", "(SlackAdapter RTM)") adapters :: [(String, (String, String))] adapters =- [("slack-rtm", slackRtmData)]+ [ ("slack-rtm", slackRtmData)+ , ("telegram-poll", ("Marvin.Adapter.Telegram", "(TelegramAdapter Poll)"))+ , ("telegram-push", ("Marvin.Adapter.Telegram", "(TelegramAdapter Push)"))+ ] tpl :: Template
src/Marvin.hs view
@@ -7,25 +7,34 @@ Stability : experimental Portability : POSIX +For the proper, verbose documentation see <https://marvin.readthedocs.org/en/latest/scripting.html>.+ -} module Marvin- ( -- * Scripts+ (+ -- * The Script Script(..), defineScript, ScriptInit , ScriptId- , ScriptDefinition- , IsAdapter- -- * Reacting+ , ScriptDefinition, IsAdapter+ -- * Reacting+ -- ** Reaction Functions , hear, respond, enter, exit, enterIn, exitFrom, topic, topicIn, customTrigger+ -- ** Getting data+ , getData, getMessage, getMatch, getTopic, getChannel, getUser, getUsername, getChannelName, resolveChannel+ -- ** Sending messages , send, reply, messageChannel, messageChannel'- , getData, getMessage, getMatch, getTopic, getChannel, getUser, getUsername, getChannelName- , Message(..), User, Channel- , getConfigVal, requireConfigVal- , BotReacting, HasMessage(messageLens), HasMatch(matchLens), HasTopic(topicLens), HasChannel(channelLens), HasUser(userLens)+ -- ** Interaction with the config+ , getConfigVal, requireConfigVal, getBotName+ -- ** Handler Types+ , Message(..), User, Channel, BotReacting -- ** Advanced actions , extractAction, extractReaction+ -- ** Misc+ , Topic ) where import Marvin.Adapter (IsAdapter) import Marvin.Internal-import Marvin.Internal.Types+import Marvin.Internal.Types hiding (getChannelName, getUsername, messageChannel,+ resolveChannel)
src/Marvin/Adapter.hs view
@@ -13,7 +13,7 @@ module Marvin.Adapter ( Event(..) , RunWithAdapter, EventHandler, InitEventHandler, RunnerM- , IsAdapter(..)+ , IsAdapter(..), AdapterId , liftAdapterAction ) where @@ -24,34 +24,6 @@ import Marvin.Internal.Types --- | 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- -- | 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- -- | 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)-- liftAdapterAction :: MonadIO m => RunnerM a -> m a-liftAdapterAction = liftIO . runStderrLoggingT+liftAdapterAction ac =+ liftIO $ runStderrLoggingT ac
src/Marvin/Adapter/Slack.hs view
@@ -7,19 +7,19 @@ Stability : experimental Portability : POSIX -}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Marvin.Adapter.Slack (SlackRTMAdapter) where+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Marvin.Adapter.Slack where 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.MVar.Lifted (MVar, newEmptyMVar, putMVar, readMVar, takeMVar) import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar, takeTMVar) import Control.Exception.Lifted import Control.Lens hiding ((.=))@@ -34,23 +34,26 @@ import qualified Data.Configurator.Types as C import Data.Containers import Data.Foldable (toList)+import Data.Hashable import Data.HashMap.Strict (HashMap) import Data.IORef.Lifted import Data.Maybe (fromMaybe) import Data.Sequences+import Data.String (IsString (..)) import qualified Data.Text as T import qualified Data.Text.Lazy as L import Marvin.Adapter import Marvin.Interpolate.Text import Marvin.Types as Types import Network.URI+import Network.Wai+import Network.Wai.Handler.Warp import Network.WebSockets import Network.Wreq import Prelude hiding (lookup) import Text.Read (readMaybe) import Wuss - instance FromJSON URI where parseJSON (String t) = maybe mzero return $ parseURI $ unpack t parseJSON _ = mzero@@ -71,27 +74,36 @@ , payload :: a } +-- | Identifier for a user (internal and not necessarily equal to the username)+newtype SlackUserId = SlackUserId T.Text deriving (IsString, Eq, Hashable)+-- | Identifier for a channel (internal and not necessarily equal to the channel name)+newtype SlackChannelId = SlackChannelId T.Text deriving (IsString, Eq, Show, Hashable) ++deriveJSON defaultOptions { unwrapUnaryRecords = True } ''SlackUserId+deriveJSON defaultOptions { unwrapUnaryRecords = True } ''SlackChannelId++ declareFields [d| data LimitedChannelInfo = LimitedChannelInfo- { limitedChannelInfoIdValue :: Channel- , limitedChannelInfoName :: L.Text- , limitedChannelInfoTopic :: L.Text+ { limitedChannelInfoIdValue :: SlackChannelId+ , limitedChannelInfoName :: L.Text+ , limitedChannelInfoTopic :: L.Text } deriving Show |] declareFields [d| data UserInfo = UserInfo { userInfoUsername :: L.Text- , userInfoIdValue :: User+ , userInfoIdValue :: SlackUserId } |] declareFields [d| data ChannelCache = ChannelCache- { channelCacheInfoCache :: HashMap Channel LimitedChannelInfo- , channelCacheNameResolver :: HashMap L.Text Channel+ { channelCacheInfoCache :: HashMap SlackChannelId LimitedChannelInfo+ , channelCacheNameResolver :: HashMap L.Text SlackChannelId } |] @@ -103,9 +115,9 @@ } | Unhandeled String | Ignored- | ChannelArchiveStatusChange Channel Bool+ | ChannelArchiveStatusChange SlackChannelId Bool | ChannelCreated LimitedChannelInfo- | ChannelDeleted Channel+ | ChannelDeleted SlackChannelId | ChannelRename LimitedChannelInfo | UserChange UserInfo @@ -113,7 +125,7 @@ deriveJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } ''RTMData -messageParser :: Value -> Parser Types.Message+messageParser :: Value -> Parser (Types.Message (SlackAdapter a)) messageParser (Object o) = Message <$> o .: "user" <*> o .: "channel"@@ -122,7 +134,7 @@ messageParser _ = mzero -eventParser :: Value -> Parser (Either InternalType Event)+eventParser :: Value -> Parser (Either InternalType (Event (SlackAdapter a))) eventParser v@(Object o) = isErrParser <|> hasTypeParser where isErrParser = do@@ -150,18 +162,20 @@ "channel_leave" -> cLeave "group_leave" -> cLeave "channel_topic" -> do- t <- TopicChangeEvent <$> o .: "topic" <*> o .: "channel"+ t <- TopicChangeEvent <$> o .: "topic" <*> channel return $ Right t _ -> msgEv _ -> msgEv where msgEv = Right . MessageEvent <$> messageParser v+ user = o .: "user"+ channel = o .: "channel" cJoin = do- ev <- ChannelJoinEvent <$> o .: "user" <*> o .: "channel"+ ev <- ChannelJoinEvent <$> user <*> channel return $ Right ev cLeave = do- ev <- ChannelLeaveEvent <$> o .: "user" <*> o .: "channel"+ ev <- ChannelLeaveEvent <$> user <*> channel return $ Right ev "reconnect_url" -> return $ Left Ignored "channel_archive" -> do@@ -208,17 +222,17 @@ apiResponseParser f v@(Object o) = APIResponse <$> o .: "ok" <*> f v apiResponseParser _ _ = mzero -data SlackRTMAdapter = SlackRTMAdapter+data SlackAdapter a = SlackAdapter { sendMessage :: BS.ByteString -> RunnerM () , userConfig :: C.Config , midTracker :: TMVar Int , channelChache :: IORef ChannelCache- , userInfoCache :: IORef (HashMap User UserInfo)+ , userInfoCache :: IORef (HashMap SlackUserId UserInfo) } -runConnectionLoop :: C.Config -> Chan BS.ByteString -> MVar Connection -> RunnerM ()-runConnectionLoop cfg messageChan connTracker = forever $ do+runConnectionLoop :: SlackAdapter RTM -> Chan BS.ByteString -> MVar Connection -> RunnerM ()+runConnectionLoop ada messageChan connTracker = forever $ do token <- liftIO $ C.require cfg "token" $logDebug "initializing socket" r <- liftIO $ post "https://slack.com/api/rtm.start" [ "token" := (token :: T.Text) ]@@ -252,32 +266,31 @@ $ \e -> do void $ takeMVar connTracker logErrorN $(isT "#{e :: ConnectionException}")+ where cfg = userConfig ada -runHandlerLoop :: SlackRTMAdapter -> Chan BS.ByteString -> EventHandler SlackRTMAdapter -> RunnerM ()+runHandlerLoop :: SlackAdapter a -> Chan BS.ByteString -> EventHandler (SlackAdapter a) -> RunnerM () runHandlerLoop adapter messageChan handler = forever $ do d <- readChan messageChan case eitherDecode d >>= parseEither eventParser of Left err -> logErrorN $(isT "Error parsing json: #{err} original data: #{rawBS d}")- Right v ->- case v of- Right event -> liftIO $ handler event- Left internalEvent ->- case internalEvent of- Unhandeled type_ ->- $logDebug $(isT "Unhandeled event type #{type_} payload: #{rawBS d}")- Error code 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)+ Right (Right event) -> liftIO $ handler event+ Right (Left internalEvent) ->+ case internalEvent of+ Unhandeled type_ ->+ $logDebug $(isT "Unhandeled event type #{type_} payload: #{rawBS d}")+ Error code 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 ()@@ -294,19 +307,20 @@ go (n-1) -runnerImpl :: RunWithAdapter SlackRTMAdapter+runnerImpl :: MkSlack a => RunWithAdapter (SlackAdapter a) runnerImpl cfg handlerInit = do midTracker <- liftIO $ atomically $ newTMVar 0 connTracker <- newEmptyMVar messageChan <- newChan let send = sendMessageImpl connTracker- adapter <- SlackRTMAdapter send cfg midTracker <$> newIORef (ChannelCache mempty mempty) <*> newIORef mempty+ adapter <- SlackAdapter send cfg midTracker <$> newIORef (ChannelCache mempty mempty) <*> newIORef mempty handler <- liftIO $ handlerInit adapter- void $ async $ runConnectionLoop cfg messageChan connTracker+ let eventGetter = mkEventGetter adapter+ void $ async $ eventGetter messageChan connTracker runHandlerLoop adapter messageChan handler -execAPIMethod :: (Value -> Parser a) -> SlackRTMAdapter -> String -> [FormParam] -> RunnerM (Either String (APIResponse a))+execAPIMethod :: (Value -> Parser v) -> SlackAdapter a -> String -> [FormParam] -> RunnerM (Either String (APIResponse v)) execAPIMethod innerParser adapter method params = do token <- liftIO $ C.require cfg "token" response <- liftIO $ post ("https://slack.com/api/" ++ method) (("token" := (token :: T.Text)):params)@@ -315,15 +329,15 @@ cfg = userConfig adapter -newMid :: SlackRTMAdapter -> RunnerM Int-newMid SlackRTMAdapter{midTracker} = liftIO $ atomically $ do+newMid :: SlackAdapter a -> RunnerM Int+newMid SlackAdapter{midTracker} = liftIO $ atomically $ do id <- takeTMVar midTracker putTMVar midTracker (id + 1) return id -messageChannelImpl :: SlackRTMAdapter -> Channel -> L.Text -> RunnerM ()-messageChannelImpl adapter (Channel chan) msg = do+messageChannelImpl :: SlackAdapter a -> SlackChannelId -> L.Text -> RunnerM ()+messageChannelImpl adapter (SlackChannelId chan) msg = do mid <- newMid adapter sendMessage adapter $ encode $ object [ "id" .= mid@@ -333,14 +347,14 @@ ] -getUserInfoImpl :: SlackRTMAdapter -> User -> RunnerM UserInfo-getUserInfoImpl adapter user@(User user') = do+getUserInfoImpl :: SlackAdapter a -> SlackUserId -> RunnerM UserInfo+getUserInfoImpl adapter user@(SlackUserId user') = do uc <- readIORef $ userInfoCache adapter maybe (refreshUserInfo adapter user) return $ lookup user uc -refreshUserInfo :: SlackRTMAdapter -> User -> RunnerM UserInfo-refreshUserInfo adapter user@(User user') = do+refreshUserInfo :: SlackAdapter a -> SlackUserId -> RunnerM UserInfo+refreshUserInfo adapter user@(SlackUserId user') = do usr <- execAPIMethod userInfoParser adapter "users.info" ["user" := user'] case usr of Left err -> error ("Parse error when getting user data " ++ err)@@ -359,7 +373,7 @@ lciListParser = withArray "array" $ fmap toList . mapM lciParser -refreshChannels :: SlackRTMAdapter -> RunnerM (Either String ChannelCache)+refreshChannels :: SlackAdapter a -> RunnerM (Either String ChannelCache) refreshChannels adapter = do usr <- execAPIMethod (withObject "object" (\o -> o .: "channels" >>= lciListParser)) adapter "channels.list" [] case usr of@@ -373,7 +387,7 @@ Right (APIResponse False _) -> return $ Left "Server denied getting channel info request" -resolveChannelImpl :: SlackRTMAdapter -> L.Text -> RunnerM (Maybe Channel)+resolveChannelImpl :: SlackAdapter a -> L.Text -> RunnerM (Maybe SlackChannelId) resolveChannelImpl adapter name' = do cc <- readIORef $ channelChache adapter case cc ^? nameResolver . ix name of@@ -386,7 +400,7 @@ where name = L.tail name' -getChannelNameImpl :: SlackRTMAdapter -> Channel -> RunnerM L.Text+getChannelNameImpl :: SlackAdapter a -> SlackChannelId -> RunnerM L.Text getChannelNameImpl adapter channel = do cc <- readIORef $ channelChache adapter L.cons '#' <$>@@ -397,16 +411,16 @@ Just found -> return $ found ^. name -putChannel :: SlackRTMAdapter -> LimitedChannelInfo -> RunnerM ()-putChannel SlackRTMAdapter{channelChache} channelInfo@(LimitedChannelInfo id name _) =+putChannel :: SlackAdapter a -> LimitedChannelInfo -> RunnerM ()+putChannel SlackAdapter{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 =+deleteChannel :: SlackAdapter a -> SlackChannelId -> RunnerM ()+deleteChannel SlackAdapter{channelChache} channel = void $ atomicModifyIORef channelChache $ \cache -> case cache ^? infoCache . ix channel of Nothing -> (cache, ())@@ -415,8 +429,8 @@ & nameResolver . at name .~ Nothing -renameChannel :: SlackRTMAdapter -> LimitedChannelInfo -> RunnerM ()-renameChannel SlackRTMAdapter{channelChache} channelInfo@(LimitedChannelInfo id name _) =+renameChannel :: SlackAdapter a -> LimitedChannelInfo -> RunnerM ()+renameChannel SlackAdapter{channelChache} channelInfo@(LimitedChannelInfo id name _) = void $ atomicModifyIORef channelChache $ \cache -> let inserted = cache & infoCache . at id .~ Just channelInfo & nameResolver . at name .~ Just id@@ -426,9 +440,31 @@ _ -> (inserted, ()) +class MkSlack a where+ mkAdapterId :: SlackAdapter a -> AdapterId (SlackAdapter a)+ mkEventGetter :: SlackAdapter a -> Chan BS.ByteString -> MVar Connection -> RunnerM () -instance IsAdapter SlackRTMAdapter where- adapterId = "slack-rtm"++data RTM+++instance MkSlack RTM where+ mkAdapterId _ = "slack-rtm"+ mkEventGetter = runConnectionLoop+++data EventsAPI+++instance MkSlack EventsAPI where+ mkAdapterId _ = "slack-events"+ mkEventGetter = error "not implemented"+++instance MkSlack a => IsAdapter (SlackAdapter a) where+ type User (SlackAdapter a) = SlackUserId+ type Channel (SlackAdapter a) = SlackChannelId+ adapterId = mkAdapterId (error "phantom value" :: SlackAdapter a) messageChannel = messageChannelImpl runWithAdapter = runnerImpl getUsername a = fmap (^.username) . getUserInfoImpl a
+ src/Marvin/Adapter/Telegram.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Marvin.Adapter.Telegram+ ( TelegramAdapter, Push, Poll+ , TelegramChat(..), ChatType(..)+ , TelegramUser(..)+ , HasId_(id_), HasUsername(username), HasFirstName(firstName), HasLastName(lastName), HasType_(type_)+ ) where++import Control.Applicative+import Control.Concurrent.Async.Lifted+import Control.Concurrent.Chan.Lifted+import Control.Concurrent.Lifted+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Data.Aeson hiding (Error, Success)+import Data.Aeson.Types (Parser, parseEither)+import qualified Data.Configurator as C+import qualified Data.Configurator.Types as C+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import Marvin.Adapter+import Marvin.Interpolate.String+import Marvin.Interpolate.Text+import Marvin.Types+import Network.Wai+import Network.Wai.Handler.Warp+import Network.Wreq+++data APIResponse a+ = Success { description :: Maybe T.Text, result :: a}+ | Error { errorCode :: Int, errDescription :: T.Text}+++data TelegramAdapter updateType = TelegramAdapter+ { userConfig :: C.Config+ }+++data TelegramUpdate any+ = Ev (Event (TelegramAdapter any))+ | Ignored+ | Unhandeled+++data ChatType+ = PrivateChat+ | GroupChat+ | SupergroupChat+ | ChannelChat+++declareFields [d|+ data TelegramUser = TelegramUser+ { telegramUserId_ :: Integer+ , telegramUserFirstName :: L.Text+ , telegramUserLastName :: Maybe L.Text+ , telegramUserUsername :: Maybe L.Text+ }+ |]++declareFields [d|++ data TelegramChat = TelegramChat+ { telegramChatId_ :: Integer+ , telegramChatType_ :: ChatType+ , telegramChatUsername :: Maybe L.Text+ , telegramChatFirstName :: Maybe L.Text+ , telegramChatLastName :: Maybe L.Text+ }+ |]++instance FromJSON ChatType where+ parseJSON = withText "expected string" fromStr+ where+ fromStr "private" = pure PrivateChat+ fromStr "group" = pure GroupChat+ fromStr "supergroup" = pure SupergroupChat+ fromStr "channel" = pure ChannelChat+ fromStr _ = mzero++instance FromJSON TelegramUser where+ parseJSON = withObject "user must be object" $ \o ->+ TelegramUser+ <$> o .: "id"+ <*> o .: "first_name"+ <*> o .:? "last_name"+ <*> o .:? "username"++instance FromJSON TelegramChat where+ parseJSON = withObject "channel must be object" $ \o ->+ TelegramChat+ <$> o .: "id"+ <*> o .: "type"+ <*> o .:? "username"+ <*> o .:? "first_name"+ <*> o .:? "last_name"++instance FromJSON (TelegramUpdate any) where+ parseJSON = withObject "expected object" inner+ where+ inner o = isMessage <|> isPost <|> isUnhandeled+ where+ isMessage = do+ msg <- o .: "message" >>= msgParser+ return $ Ev $ MessageEvent msg+ isPost = Ev . MessageEvent <$> (o .: "channel_post" >>= msgParser)+ isUnhandeled = return Unhandeled+++msgParser :: Value -> Parser (Message (TelegramAdapter a))+msgParser = withObject "expected message object" $ \o ->+ Message+ <$> o .: "from"+ <*> o .: "chat"+ <*> o .: "text"+ <*> o .: "date"++++apiResponseParser :: (Value -> Parser a) -> Value -> Parser (APIResponse a)+apiResponseParser innerParser = withObject "expected object" $ \o -> do+ ok <- o .: "ok"+ if ok+ then Success <$> o .:? "description" <*> (o .: "result" >>= innerParser)+ else Error <$> o .: "error_code" <*> o .: "description"+++execAPIMethod :: (Value -> Parser a) -> TelegramAdapter b -> String -> [FormParam] -> RunnerM (Either String (APIResponse a))+execAPIMethod innerParser adapter methodName params = do+ token <- liftIO $ C.require cfg "token"+ response <- liftIO $ post $(isS "https://api.telegram.org/bot#{token :: String}/#{methodName}") params+ return $ eitherDecode (response^.responseBody) >>= parseEither (apiResponseParser innerParser)+ where+ cfg = userConfig adapter+++getUsernameImpl :: TelegramAdapter a -> TelegramUser -> RunnerM L.Text+getUsernameImpl _ u = return $ fromMaybe (u^.firstName) $ u^.username+++getChannelNameImpl :: TelegramAdapter a -> TelegramChat -> RunnerM L.Text+getChannelNameImpl _ c = return $ fromMaybe "<unnamed>" $+ c^.username <|> (L.unwords <$> sequence [c^.firstName, c^.lastName]) <|> c^.firstName+++messageChannelImpl :: TelegramAdapter a -> TelegramChat -> L.Text -> RunnerM ()+messageChannelImpl ada chat msg = do+ res <- execAPIMethod msgParser ada "sendMessage" ["chat_id" := (chat^.id_) , "text" := msg]+ case res of+ Left err -> error $(isS "Unparseable JSON #{err}")+ Right Success{} -> return ()+ Right (Error code desc) ->+ logErrorN $(isT "Sending message failed with #{code}: #{desc}")++++runnerImpl :: forall a. MkTelegram a => RunWithAdapter (TelegramAdapter a)+runnerImpl config initializer = do+ msgChan <- newChan+ let ada = TelegramAdapter config+ handler <- liftIO $ initializer ada+ let eventGetter = mkEventGetter ada msgChan+ async eventGetter++ forever $ do+ d <- readChan msgChan+ case d of+ Ev ev -> liftIO $ handler ev+ Ignored -> return ()+ Unhandeled -> logDebugN $(isT "Unhadeled event.")++++pollEventGetter :: TelegramAdapter Poll -> Chan (TelegramUpdate Poll) -> RunnerM ()+pollEventGetter ada msgChan =+ forever $ do+ response <- execAPIMethod parseJSON ada "getUpdates" []+ case response of+ Left err -> do+ logErrorN $(isT "Unable to parse json: #{err}")+ threadDelay 30000+ Right (Error code desc) -> do+ logErrorN $(isT "Sending message failed with #{code}: #{desc}")+ threadDelay 30000+ Right Success {result=updates} ->+ writeList2Chan msgChan updates+++pushEventGetter :: TelegramAdapter Push -> Chan (TelegramUpdate Push) -> RunnerM ()+pushEventGetter ada msgChan =+ -- port <- liftIO $ C.require cfg "port"+ -- url <- liftIO $ C.require cfg "url"+ return ()+ where+ cfg = userConfig ada++++scriptIdImpl :: forall a. MkTelegram a => TelegramAdapter a -> AdapterId (TelegramAdapter a)+scriptIdImpl _ = mkAdapterId (error "phantom value" :: a)+++class MkTelegram a where+ mkEventGetter :: TelegramAdapter a -> Chan (TelegramUpdate a) -> RunnerM ()+ mkAdapterId :: a -> AdapterId (TelegramAdapter a)+++instance MkTelegram a => IsAdapter (TelegramAdapter a) where+ type User (TelegramAdapter a) = TelegramUser+ type Channel (TelegramAdapter a) = TelegramChat+ adapterId = scriptIdImpl (error "phantom value" :: TelegramAdapter a)+ runWithAdapter = runnerImpl+ getUsername = getUsernameImpl+ getChannelName = getChannelNameImpl+ resolveChannel _ _ = do+ logErrorN "Channel resolving not supported"+ return Nothing+ messageChannel = messageChannelImpl+++data Poll+++instance MkTelegram Poll where+ mkAdapterId _ = "telegram-poll"+ mkEventGetter = pollEventGetter+++data Push+++instance MkTelegram Push where+ mkAdapterId _ = "telegram-push"+ mkEventGetter = pushEventGetter
src/Marvin/Internal.hs view
@@ -6,47 +6,76 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-}-module Marvin.Internal where+module Marvin.Internal+ (+ -- * Exposed API+ defineScript+ -- ** Reacting+ , hear, respond, topic, topicIn, enter, exit, enterIn, exitFrom, customTrigger+ -- ** Sending messages+ , send, reply, messageChannel, messageChannel'+ -- ** Getting Data+ , getData, getUser, getMatch, getMessage, getChannel, getTopic, getBotName, getChannelName, resolveChannel, getUsername+ -- ** Interacting with the config+ , getConfigVal, requireConfigVal+ -- *** Access config (advanced, internal)+ , getAppConfigVal, requireAppConfigVal, getConfig, getConfigInternal+ -- ** Types+ , Topic+ -- ** Advanced Actions+ , extractAction, extractReaction+ -- * Internals+ -- ** Values+ , defaultBotName+ -- ** Functions+ , runDefinitions+ -- ** Types+ , BotActionState(BotActionState)+ , BotReacting(..), Script(..), ScriptDefinition(..), ScriptInit(..), ScriptId(..), Handlers(..)+ -- ** Helper lenses+ , HasActions(actions), HasHears(hears), HasResponds(responds), HasJoins(joins), HasCustoms(customs), HasJoinsIn(joinsIn), HasLeaves(leaves), HasLeavesFrom(leavesFrom), HasTopicChange(topicChange), HasTopicChangeIn(topicChangeIn)+ -- ** HelperClasses+ , AccessAdapter(AdapterT, getAdapter), Get(getLens)+ ) where import Control.Monad.Reader import Control.Monad.State-import qualified Data.Configurator as C-import qualified Data.Configurator.Types as C+import qualified Data.Configurator as C+import qualified Data.Configurator.Types as C -import Control.Lens hiding (cons)+import Control.Arrow+import Control.Exception.Lifted+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 qualified Data.HashMap.Strict as HM+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import Data.Vector (Vector)+import qualified Data.Vector as V+import Marvin.Adapter (IsAdapter)+import qualified Marvin.Adapter as A+import Marvin.Internal.Types hiding (getChannelName, getUsername, messageChannel,+ resolveChannel, resolveChannel) import Marvin.Interpolate.Text-import Marvin.Util.Regex (Match, Regex)+import Marvin.Util.Regex (Match, Regex) import Util +defaultBotName :: L.Text+defaultBotName = "marvin"+ -- | Read only data available to a handler when the bot reacts to an event. declareFields [d| data BotActionState a d = BotActionState { botActionStateScriptId :: ScriptId , botActionStateConfig :: C.Config , botActionStateAdapter :: a- , botActionStateVariable :: d- }- |]---- | Payload in the reaction Monad when triggered by a message.--- Contains a field for the 'Message' and a field for the 'Match' from the 'Regex'.------ Both fields are accessible directly via the 'getMessage' and 'getMatch' functions--- or this data via 'getData'.-declareFields [d|- data MessageReactionData = MessageReactionData- { messageReactionDataMessageField :: Message- , messageReactionDataMatchField :: Match+ , botActionStatePayload :: d } |] @@ -54,19 +83,26 @@ 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+declareFields [d|+ data Handlers a = Handlers+ { handlersResponds :: Vector (Regex, Match -> Message a -> RunnerM ())+ , handlersHears :: Vector (Regex, Match -> Message a -> RunnerM ())+ , handlersCustoms :: Vector (Event a -> Maybe (RunnerM ()))+ , handlersJoins :: Vector ((User' a, Channel' a) -> RunnerM ())+ , handlersLeaves :: Vector ((User' a, Channel' a) -> RunnerM ())+ , handlersTopicChange :: Vector ((Topic, Channel' a) -> RunnerM ())+ , handlersJoinsIn :: HM.HashMap L.Text (Vector ((User' a, Channel' a) -> RunnerM ()))+ , handlersLeavesFrom :: HM.HashMap L.Text (Vector ((User' a, Channel' a) -> RunnerM ()))+ , handlersTopicChangeIn :: HM.HashMap L.Text (Vector ((Topic, Channel' a) -> RunnerM ()))+ }+ |] -data WrappedAction a = forall d. WrappedAction (ActionData d) (BotReacting a d ())+instance Monoid (Handlers a) where+ mempty = Handlers mempty mempty mempty mempty mempty mempty mempty mempty mempty+ mappend (Handlers r1 h1 c1 j1 l1 t1 ji1 li1 ti1)+ (Handlers r2 h2 c2 j2 l2 t2 ji2 li2 ti2)+ = Handlers (r1 <> r2) (h1 <> h2) (c1 <> c2) (j1 <> j2) (l1 <> l2) (t1 <> t2) (ji1 <> ji2) (li1 <> li2) (ti1 <> ti2) -- | Monad for reacting in the bot. Allows use of functions like 'send', 'reply' and 'messageChannel' as well as any arbitrary 'IO' action using 'liftIO'.@@ -79,7 +115,7 @@ -- 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) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadReader (BotActionState a d), MonadLogger)+newtype BotReacting a d r = BotReacting { runReaction :: ReaderT (BotActionState a d) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadReader (BotActionState a d), MonadLogger, MonadLoggerIO) -- | An abstract type describing a marvin script. --@@ -88,7 +124,7 @@ -- Internal structure is exposed for people wanting to extend this. declareFields [d| data Script a = Script- { scriptActions :: [WrappedAction a]+ { scriptActions :: Handlers a , scriptScriptId :: ScriptId , scriptConfig :: C.Config , scriptAdapter :: a@@ -105,49 +141,35 @@ -- | Class which says that there is a way to get to a 'Message' from this type @m@.-class HasMessage m where- messageLens :: Lens' m Message--instance HasMessageField m Message => HasMessage m where- messageLens = messageField---- | Class which says that there is a way to get to a 'Match' from this type @m@.-class HasMatch m where- matchLens :: Lens' m Match+class Get a b where+ getLens :: Lens' a b -instance HasMatchField m Match => HasMatch m where- matchLens = matchField+instance Get (b, Message a) (Message a) where+ getLens = _2 --- | 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 Get (Match, b) Match where+ getLens = _1 -instance HasTopic (Topic, a) where- topicLens = _1+instance Get (Topic, a) Topic where+ getLens = _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})+instance Get (b, Channel' a) (Channel' a) where+ getLens = _2 -class HasUser a where- userLens :: Lens' a User+instance Get (b, Message a) (Channel' a) where+ getLens = _2 . lens (Channel' . channel) (\a (Channel' b) -> a {channel = b}) -instance HasUser User where- userLens = idLens+instance Get a a where+ getLens = idLens -instance HasUser (User, a) where- userLens = _1+instance Get (User' a, b) (User' a) where+ getLens = _1 -instance HasUser MessageReactionData where- userLens = messageField . lens sender (\a b -> a {sender = b})+instance Get (b, Message a) (User' a) where+ getLens = _2 . lens (User' . sender) (\a (User' b) -> a {sender = b}) instance HasConfigAccess (ScriptDefinition a) where getConfigInternal = ScriptDefinition $ use config@@ -177,49 +199,87 @@ getSubConfFor (ScriptId name) = C.subconfig ("script." <> name) <$> getConfigInternal +-- | Get the config part for the currect script getConfig :: HasConfigAccess m => m C.Config getConfig = getScriptId >>= getSubConfFor -addReaction :: ActionData d -> BotReacting a d () -> ScriptDefinition a ()-addReaction data_ action = ScriptDefinition $ actions %= cons (WrappedAction data_ action)+runBotAction :: ShowT t => ScriptId -> C.Config -> a -> Maybe t -> d -> BotReacting a d () -> RunnerM ()+runBotAction scriptId config adapter trigger data_ action = do+ oldLogFn <- askLoggerIO+ catch+ (liftIO $ flip runLoggingT (loggingAddSourcePrefix $(isT "script.#{scriptId}") oldLogFn) $ flip runReaderT actionState $ runReaction action)+ (onScriptExcept scriptId trigger)+ where+ actionState = BotActionState scriptId config adapter data_ +prepareAction :: (MonadState (Script a) m, ShowT t) => Maybe t -> BotReacting a d () -> m (d -> RunnerM ())+prepareAction trigger reac = do+ ada <- use adapter+ cfg <- use config+ sid <- use scriptId+ return $ \d -> runBotAction sid cfg ada trigger d reac ++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 = logErrorNS "#{applicationScriptId}.dispatch"+ -- | Whenever any message matches the provided regex this handler gets run. -- -- Equivalent to "robot.hear" in hubot-hear :: Regex -> BotReacting a MessageReactionData () -> ScriptDefinition a ()-hear !re = addReaction (Hear re)-+hear :: Regex -> BotReacting a (Match, Message a) () -> ScriptDefinition a ()+hear !re ac = ScriptDefinition $ do+ pac <- prepareAction (Just re) ac+ actions . hears %= V.cons (re, curry pac) -- | Runs the handler only if the bot was directly addressed. -- -- Equivalent to "robot.respond" in hubot-respond :: Regex -> BotReacting a MessageReactionData () -> ScriptDefinition a ()-respond !re = addReaction (Respond re)+respond :: Regex -> BotReacting a (Match, Message a) () -> ScriptDefinition a ()+respond !re ac = ScriptDefinition $ do+ pac <- prepareAction (Just re) ac+ actions . responds %= V.cons (re, curry pac) -- | 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+enter :: BotReacting a (User' a, Channel' a) () -> ScriptDefinition a ()+enter ac = ScriptDefinition $ do+ pac <- prepareAction (Just "enter event" :: Maybe T.Text) ac+ actions . joins %= V.cons pac -- | 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+exit :: BotReacting a (User' a, Channel' a) () -> ScriptDefinition a ()+exit ac = ScriptDefinition $ do+ pac <- prepareAction (Just "exit event" :: Maybe T.Text) ac+ actions . leaves %= V.cons pac +alterHelper :: a -> Maybe (Vector a) -> Maybe (Vector a)+alterHelper v = return . maybe (return v) (V.cons v)++ -- | 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)+enterIn :: L.Text -> BotReacting a (User' a, Channel' a) () -> ScriptDefinition a ()+enterIn !chanName ac = ScriptDefinition $ do+ pac <- prepareAction (Just $(isT "anter event in #{chanName}")) ac+ actions . joinsIn %= HM.alter (alterHelper pac) chanName -- | This handler runs whenever a user exits __the specified channel__, provided the bot is subscribed to the channel in question.@@ -227,22 +287,28 @@ -- 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)+exitFrom :: L.Text -> BotReacting a (User' a, Channel' a) () -> ScriptDefinition a ()+exitFrom !chanName ac = ScriptDefinition $ do+ pac <- prepareAction (Just $(isT "exit event in #{chanName}")) ac+ actions . leavesFrom %= HM.alter (alterHelper pac) 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+topic :: BotReacting a (Topic, Channel' a) () -> ScriptDefinition a ()+topic ac = ScriptDefinition $ do+ pac <- prepareAction (Just "topic event" :: Maybe T.Text) ac+ actions . topicChange %= V.cons pac -- | 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)+topicIn :: L.Text -> BotReacting a (Topic, Channel' a) () -> ScriptDefinition a ()+topicIn !chanName ac = ScriptDefinition $ do+ pac <- prepareAction (Just $(isT "topic event in #{chanName}")) ac+ actions . topicChangeIn %= HM.alter (alterHelper pac) chanName -- | Extension point for the user@@ -250,34 +316,36 @@ -- 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 :: (A.Event a -> Maybe d) -> BotReacting a d () -> ScriptDefinition a ()+customTrigger tr ac = ScriptDefinition $ do+ pac <- prepareAction (Nothing :: Maybe T.Text) ac+ actions . customs %= V.cons (maybe Nothing (return . pac) . tr) -- | Send a message to the channel the triggering message came from. -- -- Equivalent to "robot.send" in hubot-send :: (IsAdapter a, HasChannel m) => L.Text -> BotReacting a m ()+send :: (IsAdapter a, Get m (Channel' a)) => L.Text -> BotReacting a m () send msg = do o <- getChannel messageChannel' o msg -- | Get the username of a registered user.-getUsername :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User -> m L.Text+getUsername :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User (AdapterT m) -> m L.Text getUsername usr = do a <- getAdapter A.liftAdapterAction $ A.getUsername a usr -resolveChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => L.Text -> m (Maybe Channel)+resolveChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => L.Text -> m (Maybe (Channel (AdapterT m))) resolveChannel name = do a <- getAdapter- A.liftAdapterAction $ 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 L.Text+getChannelName :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel (AdapterT m) -> m L.Text getChannelName rm = do a <- getAdapter A.liftAdapterAction $ A.getChannelName a rm@@ -286,7 +354,7 @@ -- | 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) => L.Text -> BotReacting a m ()+reply :: (IsAdapter a, Get m (Message a)) => L.Text -> BotReacting a m () reply msg = do om <- getMessage user <- getUsername $ sender om@@ -294,13 +362,13 @@ -- | Send a message to a Channel (by name)-messageChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m, MonadLogger m) => L.Text -> L.Text -> m ()+messageChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadLoggerIO m) => L.Text -> L.Text -> m () messageChannel name msg = do mchan <- resolveChannel name maybe ($logError $(isT "No channel known with the name #{name}")) (`messageChannel'` msg) mchan -messageChannel' :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel -> L.Text -> m ()+messageChannel' :: (AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel (AdapterT m) -> L.Text -> m () messageChannel' chan msg = do a <- getAdapter A.liftAdapterAction $ A.messageChannel a chan msg@@ -328,35 +396,35 @@ -- 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-getData = view variable+getData = view payload -- | Get the results from matching the regular expression. -- -- Equivalent to "msg.match" in hubot.-getMatch :: HasMatch m => BotReacting a m Match-getMatch = view (variable . matchLens)+getMatch :: Get m Match => BotReacting a m Match+getMatch = view (payload . getLens) -- | Get the message that triggered this action -- Includes sender, target channel, as well as the full, untruncated text of the original message-getMessage :: HasMessage m => BotReacting a m Message-getMessage = view (variable . messageLens)+getMessage :: Get m (Message a) => BotReacting a m (Message a)+getMessage = view (payload . getLens) -- | Get the the new topic.-getTopic :: HasTopic m => BotReacting a m Topic-getTopic = view (variable . topicLens)+getTopic :: Get m Topic => BotReacting a m Topic+getTopic = view (payload . getLens) -- | Get the stored channel in which something happened.-getChannel :: HasChannel m => BotReacting a m Channel-getChannel = view (variable . channelLens)+getChannel :: forall a m. Get m (Channel' a) => BotReacting a m (Channel a)+getChannel = (unwrapChannel' :: Channel' a -> Channel a) <$> view (payload . getLens) -- | Get the user whihc was part of the triggered action.-getUser :: HasUser m => BotReacting a m User-getUser = view (variable . userLens)+getUser :: forall m a. Get m (User' a) => BotReacting a m (User a)+getUser = (unwrapUser' :: User' a -> User a) <$> view (payload . getLens) -- | Get a value out of the config, returns 'Nothing' if the value didn't exist.@@ -381,20 +449,34 @@ liftIO $ C.require cfg name +-- | INTERNAL, USE WITH CARE+--+-- Get the configuration for the bot (should be "bot" subconfig) getAppConfig :: HasConfigAccess m => m C.Config getAppConfig = getSubConfFor applicationScriptId +-- | INTERNAL, USE WITH CARE+--+-- Get a value from the bot config (should be "bot" subconfig) getAppConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m (Maybe a) getAppConfigVal name = do cfg <- getAppConfig liftIO $ C.lookup cfg name +-- | INTERNAL, USE WITH CARE+--+-- Get a value from the bot config (should be "bot" subconfig) requireAppConfigVal :: (C.Configured a, HasConfigAccess m) => C.Name -> m a requireAppConfigVal name = do cfg <- getAppConfig liftIO $ C.require cfg name+++-- | Get the configured name of the bot.+getBotName :: HasConfigAccess m => m L.Text+getBotName = fromMaybe defaultBotName <$> getAppConfigVal "name" -- | Take a reaction and produce an IO action with the same effect.
src/Marvin/Internal/Types.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TemplateHaskell #-} module Marvin.Internal.Types where @@ -10,36 +9,56 @@ 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 qualified Data.Text as T-import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy as L import Marvin.Interpolate.Text import Text.Read (readMaybe) --- | 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)+-- | Representation for the types of events which can occur+data Event a+ = MessageEvent (Message a)+ | ChannelJoinEvent (User a) (Channel a)+ | ChannelLeaveEvent (User a) (Channel a)+ | TopicChangeEvent L.Text (Channel a) -deriveJSON defaultOptions { unwrapUnaryRecords = True } ''User-deriveJSON defaultOptions { unwrapUnaryRecords = True } ''Channel+type EventHandler a = Event a -> 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+ type User a+ type Channel a+ -- | Used for scoping config and logging+ adapterId :: AdapterId a+ -- | Post a message to a channel given the internal channel identifier+ messageChannel :: a -> Channel a -> L.Text -> RunnerM ()+ -- | Initialize and run the bot+ runWithAdapter :: RunWithAdapter a+ -- | Resolve a username given the internal user identifier+ getUsername :: a -> User a -> RunnerM L.Text+ -- | Resolve the human readable name for a channel given the internal channel identifier+ getChannelName :: a -> Channel a -> RunnerM L.Text+ -- | Resolve to the internal channel identifier given a human readable name+ resolveChannel :: a -> L.Text -> RunnerM (Maybe (Channel a)) ++newtype User' a = User' {unwrapUser' :: User a}+newtype Channel' a = Channel' {unwrapChannel' :: Channel a}+ newtype TimeStamp = TimeStamp { unwrapTimeStamp :: Double } deriving Show -- | contents and meta information of a recieved message-data Message = Message- { sender :: User- , channel :: Channel- , content :: LT.Text+data Message a = Message+ { sender :: User a+ , channel :: Channel a+ , content :: L.Text , timestamp :: TimeStamp } @@ -95,6 +114,9 @@ -- -- During script definition or when handling a request we can obtain the config with 'getConfigVal' or 'requireConfigVal'. class (IsScript m, MonadIO m) => HasConfigAccess m where+ -- | INTERNAL USE WITH CARE+ --+ -- Obtain the entire config structure getConfigInternal :: m C.Config
src/Marvin/Run.hs view
@@ -31,10 +31,9 @@ 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.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Sequences-import qualified Data.Text as T import qualified Data.Text.Lazy as L import Data.Traversable (for) import Data.Vector (Vector)@@ -55,10 +54,6 @@ } -defaultBotName :: L.Text-defaultBotName = "marvin"-- defaultConfigName :: FilePath defaultConfigName = "config.cfg" @@ -74,30 +69,8 @@ lookupFromAppConfig :: C.Configured a => C.Config -> C.Name -> IO (Maybe a) lookupFromAppConfig cfg = C.lookup (C.subconfig (unwrapScriptId applicationScriptId) cfg) --declareFields [d|- 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 :: IsAdapter a => LoggingFn -> [Script a] -> C.Config -> a -> EventHandler a+mkApp :: forall a. IsAdapter a => LoggingFn -> [Script a] -> C.Config -> a -> EventHandler a mkApp log scripts cfg adapter = flip runLoggingT log . genericHandler where genericHandler ev = do@@ -109,25 +82,25 @@ 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 (ChannelJoinEvent user chan) = changeHandlerHelper joinsV joinsInV (User' user) chan+ handler (ChannelLeaveEvent user chan) = changeHandlerHelper leavesV leavesFromV (User' user) chan handler (TopicChangeEvent topic chan) = changeHandlerHelper topicsV topicsInV topic chan - changeHandlerHelper :: Vector ((b, Channel) -> RunnerM ())- -> (HM.HashMap L.Text (Vector ((b, Channel) -> RunnerM ())))+ changeHandlerHelper :: Vector ((b, Channel' a) -> RunnerM ())+ -> HM.HashMap L.Text (Vector ((b, Channel' a) -> RunnerM ())) -> b- -> Channel+ -> Channel a -> 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)))+ wildcardsRunning <- for wildcards (async . ($ (other, Channel' chan))) - applicablesRunning <- for applicables (async . ($ (other, chan)))+ applicablesRunning <- for applicables (async . ($ (other, Channel' chan))) - mapM_ wait $ wildcards `mappend` applicablesRunning+ mapM_ wait $ wildcardsRunning `mappend` applicablesRunning @@ -146,64 +119,10 @@ catMaybes <$> for things (\(trigger, action) -> 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)+ Just m -> Just <$> async (action m msg)) 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 :: 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 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 = botAcWith (Nothing :: Maybe ()) s ac- where- botAcWith :: ShowT t => Maybe t -> d -> BotReacting a d () -> RunnerM ()- botAcWith = runBotAction script adapter---runBotAction :: ShowT t => Script a -> a -> Maybe t -> d -> BotReacting a d () -> RunnerM ()-runBotAction script adapter trigger data_ action = do- oldLogFn <- askLoggerIO- catch- (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_---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 = logErrorNS "#{applicationScriptId}.dispatch"+ foldMap (^.actions) scripts -- | Create a wai compliant application@@ -215,7 +134,7 @@ where onInitExcept :: ScriptId -> SomeException -> RunnerM (Maybe a') onInitExcept (ScriptId id) e = do- err $(isT "Unhandled exception during initialization of script ${id}")+ err $(isT "Unhandled exception during initialization of script #{id}") err $(isT "#{e}") return Nothing where err = logErrorNS $(isT "#{applicationScriptId}.init")@@ -236,7 +155,7 @@ ($logInfoS $(isT "${applicationScriptId}") "Using default config: config.cfg" >> return defaultConfigName) return (configPath args)- (cfg, cfgTid) <- liftIO $ C.autoReload C.autoConfig [C.Required cfgLoc]+ (cfg, _) <- liftIO $ C.autoReload C.autoConfig [C.Required cfgLoc] loggingLevelFromCfg <- liftIO $ C.lookup cfg $(isT "#{applicationScriptId}.logging") let loggingLevel