diff --git a/marvin.cabal b/marvin.cabal --- a/marvin.cabal +++ b/marvin.cabal @@ -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, diff --git a/preprocessor/Main.hs b/preprocessor/Main.hs --- a/preprocessor/Main.hs +++ b/preprocessor/Main.hs @@ -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 diff --git a/src/Marvin.hs b/src/Marvin.hs --- a/src/Marvin.hs +++ b/src/Marvin.hs @@ -7,25 +7,34 @@ Stability : experimental Portability : POSIX +For the proper, verbose documentation see . + -} 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) diff --git a/src/Marvin/Adapter.hs b/src/Marvin/Adapter.hs --- a/src/Marvin/Adapter.hs +++ b/src/Marvin/Adapter.hs @@ -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 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 @@ -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 diff --git a/src/Marvin/Adapter/Telegram.hs b/src/Marvin/Adapter/Telegram.hs new file mode 100644 --- /dev/null +++ b/src/Marvin/Adapter/Telegram.hs @@ -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 "" $ + 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 diff --git a/src/Marvin/Internal.hs b/src/Marvin/Internal.hs --- a/src/Marvin/Internal.hs +++ b/src/Marvin/Internal.hs @@ -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. 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 @@ -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 diff --git a/src/Marvin/Run.hs b/src/Marvin/Run.hs --- a/src/Marvin/Run.hs +++ b/src/Marvin/Run.hs @@ -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