diff --git a/marvin.cabal b/marvin.cabal --- a/marvin.cabal +++ b/marvin.cabal @@ -1,5 +1,5 @@ name: marvin -version: 0.0.7 +version: 0.0.8 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -71,7 +71,9 @@ haskeline >=0.7.2.3 && <0.8, monad-loops >=0.4.3 && <0.5, mono-traversable >=1.0.0.1 && <1.1, - time >=1.6.0.1 && <1.7 + time >=1.6.0.1 && <1.7, + transformers-base >=0.4.4 && <0.5, + monad-control >=1.0.1.0 && <1.1 default-language: Haskell2010 default-extensions: OverloadedStrings TypeFamilies MultiParamTypeClasses TupleSections GADTs TemplateHaskell @@ -87,7 +89,7 @@ mustache ==2.1.*, directory >=1.2.6.2 && <1.3, filepath >=1.4.1.0 && <1.5, - marvin >=0.0.7 && <0.1, + marvin >=0.0.8 && <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/src/Marvin/Adapter.hs b/src/Marvin/Adapter.hs --- a/src/Marvin/Adapter.hs +++ b/src/Marvin/Adapter.hs @@ -10,20 +10,55 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} module Marvin.Adapter ( Event(..) - , RunWithAdapter, EventHandler, InitEventHandler, RunnerM + , RunWithAdapter, EventHandler, RunnerM , IsAdapter(..), AdapterId + , lookupFromAdapterConfig, requireFromAdapterConfig + , lookupFromAppConfig, requireFromAppConfig + , getAdapterConfig, getAppConfig , liftAdapterAction ) where import Control.Monad.IO.Class import Control.Monad.Logger import qualified Data.Configurator.Types as C +import qualified Data.Configurator as C import qualified Data.Text.Lazy as L import Marvin.Internal.Types +import Control.Monad.Reader +import Marvin.Interpolate.Text -liftAdapterAction :: MonadIO m => RunnerM a -> m a -liftAdapterAction ac = - liftIO $ runStderrLoggingT ac +liftAdapterAction :: (MonadIO m, HasConfigAccess m, AccessAdapter m, IsAdapter a, a ~ AdapterT m) => AdapterM a r -> m r +liftAdapterAction (AdapterM ac) = do + a <- getAdapter + c <- getConfigInternal + liftIO $ runStderrLoggingT $ runReaderT ac (c, a) + + +getAppConfig :: AdapterM a C.Config +getAppConfig = AdapterM $ + C.subconfig $(isT "#{applicationScriptId}") . fst <$> ask + + +lookupFromAppConfig :: C.Configured v => C.Name -> AdapterM a (Maybe v) +lookupFromAppConfig n = getAppConfig >>= liftIO . flip C.lookup n + + +requireFromAppConfig :: C.Configured v => C.Name -> AdapterM a v +requireFromAppConfig n = getAppConfig >>= liftIO . flip C.require n + + +getAdapterConfig :: forall a. IsAdapter a => AdapterM a C.Config +getAdapterConfig = AdapterM $ + C.subconfig $(isT "adapter.#{adapterId :: AdapterId a}") . fst <$> ask + + +lookupFromAdapterConfig :: (IsAdapter a, C.Configured v) => C.Name -> AdapterM a (Maybe v) +lookupFromAdapterConfig n = getAdapterConfig >>= liftIO . flip C.lookup n + + +requireFromAdapterConfig :: (IsAdapter a, C.Configured v) => C.Name -> AdapterM a v +requireFromAdapterConfig n = getAdapterConfig >>= liftIO . flip C.require n diff --git a/src/Marvin/Adapter/Shell.hs b/src/Marvin/Adapter/Shell.hs --- a/src/Marvin/Adapter/Shell.hs +++ b/src/Marvin/Adapter/Shell.hs @@ -16,7 +16,7 @@ import Marvin.Internal (defaultBotName) import Marvin.Internal.Types import Marvin.Interpolate.String -import Marvin.Run (lookupFromAppConfig) +import Marvin.Interpolate.Text.Lazy import System.Console.Haskeline import qualified Data.Configurator as C @@ -26,34 +26,58 @@ } +help :: L.Text +help = L.unlines + [ "Available commands:" + , ":? ~ print this help" + , ":join ~ make join the channel" + , ":join ~ make join the channel " + , ":leave ~ make leave the channel" + , ":leave ~ make leave the channel " + , ":topic <...topic> ~ change the topic to " + ] + + instance IsAdapter ShellAdapter where - type User ShellAdapter = () - type Channel ShellAdapter = () + type User ShellAdapter = L.Text + type Channel ShellAdapter = L.Text adapterId = "shell" - messageChannel ShellAdapter{output} _ = putMVar output . Just - getUsername _ _ = return "shell" - getChannelName _ _ = return "shell" - resolveChannel _ _ = return $ Just () - runWithAdapter cfg initializer = do - bot <- liftIO $ fromMaybe defaultBotName <$> lookupFromAppConfig cfg "name" - histfile <- liftIO $ C.lookup cfg "history-file" - out <- liftIO newEmptyMVar - let ada = ShellAdapter out - handler <- liftIO $ initializer ada - liftIO $ runInputT defaultSettings {historyFile=histfile} $ forever $ do - input <- getInputLine $(isS "#{bot}> ") - case input of - Nothing -> return () - Just i -> do - h <- liftIO $ async $ do - botname <- L.toLower . fromMaybe defaultBotName <$> liftIO (lookupFromAppConfig cfg "name") + messageChannel _ chan = do + ShellAdapter{output} <- getAdapter + putMVar output $ Just chan + getUsername = return + getChannelName = return + resolveChannel = return . Just + initAdapter = ShellAdapter <$> newEmptyMVar + runWithAdapter handler = do + bot <- fromMaybe defaultBotName <$> lookupFromAppConfig "name" + histfile <- lookupFromAdapterConfig "history-file" + ShellAdapter out <- getAdapter + liftIO $ runInputT defaultSettings {historyFile=histfile} $ do + outputStrLn "Type :? to see a a list of available commands" + forever $ do + input <- getInputLine $(isS "#{bot}> ") + ts <- liftIO $ TimeStamp <$> getCurrentTime + case input of + Nothing -> return () + Just i -> do let mtext = L.pack i - ts <- TimeStamp <$> getCurrentTime - handler $ case L.stripPrefix botname $ L.stripStart mtext of - Just cmd | fmap (isSpace . fst) (L.uncons cmd) == Just True -> - CommandEvent () () (L.stripStart cmd) ts - _ -> MessageEvent () () mtext ts - putMVar out Nothing - whileJust_ (liftIO $ takeMVar out) $ outputStrLn . L.unpack - liftIO $ wait h + h <- liftIO $ async $ do + case L.words mtext of + [":?"] -> putMVar out $ Just help + [":join", user] -> handler $ ChannelJoinEvent user "shell" ts + [":join", user, chan] -> handler $ ChannelJoinEvent user chan ts + [":leave", user] -> handler $ ChannelLeaveEvent user "shell" ts + [":leave", user, chan] -> handler $ ChannelLeaveEvent user chan ts + (":topic":t) -> handler $ TopicChangeEvent "shell" "shell" (L.unwords t) ts + (x:_) | ":" `L.isPrefixOf` x -> + putMVar out $ Just $(isL "Unknown command #{x} or unexpected arguments") + _ -> -- handle message + handler $ case L.stripPrefix bot $ L.stripStart mtext of + Just cmd | fmap (isSpace . fst) (L.uncons cmd) == Just True -> + CommandEvent "shell" "shell" (L.stripStart cmd) ts + _ -> MessageEvent "shell" "shell" mtext ts + putMVar out Nothing + whileJust_ (liftIO $ takeMVar out) $ outputStrLn . L.unpack + liftIO $ wait h 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 @@ -47,7 +47,6 @@ import Marvin.Internal import Marvin.Internal.Types as Types import Marvin.Interpolate.Text -import Marvin.Run import Network.URI import Network.Wai import Network.Wai.Handler.Warp @@ -227,17 +226,17 @@ apiResponseParser _ _ = mzero data SlackAdapter a = SlackAdapter - { sendMessage :: BS.ByteString -> RunnerM () - , userConfig :: C.Config - , midTracker :: TMVar Int + { midTracker :: TMVar Int , channelChache :: IORef ChannelCache , userInfoCache :: IORef (HashMap SlackUserId UserInfo) + , connectionTracker :: MVar Connection } -runConnectionLoop :: SlackAdapter RTM -> Chan BS.ByteString -> MVar Connection -> RunnerM () -runConnectionLoop ada messageChan connTracker = forever $ do - token <- liftIO $ C.require cfg "token" +runConnectionLoop :: Chan BS.ByteString -> AdapterM (SlackAdapter RTM) () +runConnectionLoop messageChan = forever $ do + SlackAdapter{connectionTracker} <- getAdapter + token <- requireFromAdapterConfig "token" $logDebug "initializing socket" r <- liftIO $ post "https://slack.com/api/rtm.start" [ "token" := (token :: T.Text) ] case eitherDecode (r^.responseBody) of @@ -263,14 +262,13 @@ Right True -> $logDebug "Recieved hello packet" Left _ -> error $ "Hello packet not readable: " ++ BS.unpack d _ -> error $ "First packet was not hello packet: " ++ BS.unpack d - putMVar connTracker conn + putMVar connectionTracker conn forever $ do d <- liftIO $ receiveData conn writeChan messageChan d) $ \e -> do - void $ takeMVar connTracker + void $ takeMVar connectionTracker logErrorN $(isT "#{e :: ConnectionException}") - where cfg = userConfig ada stripWhiteSpaceMay :: L.Text -> Maybe L.Text @@ -280,15 +278,15 @@ _ -> Nothing -runHandlerLoop :: SlackAdapter a -> Chan BS.ByteString -> EventHandler (SlackAdapter a) -> RunnerM () -runHandlerLoop adapter messageChan handler = +runHandlerLoop :: MkSlack a => Chan BS.ByteString -> EventHandler (SlackAdapter a) -> AdapterM (SlackAdapter a) () +runHandlerLoop 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 (Right ev@(MessageEvent u c m t)) -> do - botname <- L.toLower . fromMaybe defaultBotName <$> liftIO (lookupFromAppConfig cfg "name") + botname <- L.toLower . fromMaybe defaultBotName <$> lookupFromAppConfig "name" let lmsg = L.stripStart $ L.toLower m liftIO $ handler $ case asum $ map ((`L.stripPrefix` lmsg) >=> stripWhiteSpaceMay) [botname, L.cons '@' botname, L.cons '/' botname] of Nothing -> ev @@ -306,61 +304,55 @@ -- 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) - where - cfg = userConfig adapter + putChannel info + ChannelDeleted chan -> deleteChannel chan + ChannelRename info -> renameChannel info + UserChange ui -> void $ refreshUserInfo (ui^.idValue) -sendMessageImpl :: MVar Connection -> BS.ByteString -> RunnerM () -sendMessageImpl connTracker msg = go (3 :: Int) - where - go 0 = logErrorN "Connection error, quitting retry." - go n = - catch - (do - conn <- readMVar connTracker - liftIO $ sendTextData conn msg) - $ \e -> do - logErrorN $(isT "#{e :: ConnectionException}") - go (n-1) +sendMessageImpl :: BS.ByteString -> AdapterM (SlackAdapter a) () +sendMessageImpl msg = do + SlackAdapter{connectionTracker} <- getAdapter + let go 0 = logErrorN "Connection error, quitting retry." + go n = + catch + (do + conn <- readMVar connectionTracker + liftIO $ sendTextData conn msg) + $ \e -> do + logErrorN $(isT "#{e :: ConnectionException}") + go (n-1) + go (3 :: Int) + runnerImpl :: MkSlack a => RunWithAdapter (SlackAdapter a) -runnerImpl cfg handlerInit = do - midTracker <- liftIO $ atomically $ newTMVar 0 - connTracker <- newEmptyMVar +runnerImpl handler = do messageChan <- newChan - let send = sendMessageImpl connTracker - adapter <- SlackAdapter send cfg midTracker <$> newIORef (ChannelCache mempty mempty) <*> newIORef mempty - handler <- liftIO $ handlerInit adapter - let eventGetter = mkEventGetter adapter - void $ async $ eventGetter messageChan connTracker - runHandlerLoop adapter messageChan handler + void $ async $ mkEventGetter messageChan + runHandlerLoop messageChan handler -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" +execAPIMethod :: MkSlack a => (Value -> Parser v) -> String -> [FormParam] -> AdapterM (SlackAdapter a) (Either String (APIResponse v)) +execAPIMethod innerParser method params = do + token <- requireFromAdapterConfig "token" response <- liftIO $ post ("https://slack.com/api/" ++ method) (("token" := (token :: T.Text)):params) return $ eitherDecode (response^.responseBody) >>= parseEither (apiResponseParser innerParser) - where - cfg = userConfig adapter -newMid :: SlackAdapter a -> RunnerM Int -newMid SlackAdapter{midTracker} = liftIO $ atomically $ do - id <- takeTMVar midTracker - putTMVar midTracker (id + 1) - return id +newMid :: AdapterM (SlackAdapter a) Int +newMid = do + SlackAdapter{midTracker} <- getAdapter + liftIO $ atomically $ do + id <- takeTMVar midTracker + putTMVar midTracker (id + 1) + return id -messageChannelImpl :: SlackAdapter a -> SlackChannelId -> L.Text -> RunnerM () -messageChannelImpl adapter (SlackChannelId chan) msg = do - mid <- newMid adapter - sendMessage adapter $ encode $ +messageChannelImpl :: SlackChannelId -> L.Text -> AdapterM (SlackAdapter a) () +messageChannelImpl (SlackChannelId chan) msg = do + mid <- newMid + sendMessageImpl $ encode $ object [ "id" .= mid , "type" .= ("message" :: T.Text) , "channel" .= chan @@ -368,15 +360,17 @@ ] -getUserInfoImpl :: SlackAdapter a -> SlackUserId -> RunnerM UserInfo -getUserInfoImpl adapter user@(SlackUserId user') = do +getUserInfoImpl :: MkSlack a => SlackUserId -> AdapterM (SlackAdapter a) UserInfo +getUserInfoImpl user@(SlackUserId user') = do + adapter <- getAdapter uc <- readIORef $ userInfoCache adapter - maybe (refreshUserInfo adapter user) return $ lookup user uc + maybe (refreshUserInfo user) return $ lookup user uc -refreshUserInfo :: SlackAdapter a -> SlackUserId -> RunnerM UserInfo -refreshUserInfo adapter user@(SlackUserId user') = do - usr <- execAPIMethod userInfoParser adapter "users.info" ["user" := user'] +refreshUserInfo :: MkSlack a => SlackUserId -> AdapterM (SlackAdapter a) UserInfo +refreshUserInfo user@(SlackUserId user') = do + adapter <- getAdapter + usr <- execAPIMethod userInfoParser "users.info" ["user" := user'] case usr of Left err -> error ("Parse error when getting user data " ++ err) Right (APIResponse True v) -> do @@ -394,9 +388,10 @@ lciListParser = withArray "array" $ fmap toList . mapM lciParser -refreshChannels :: SlackAdapter a -> RunnerM (Either String ChannelCache) -refreshChannels adapter = do - usr <- execAPIMethod (withObject "object" (\o -> o .: "channels" >>= lciListParser)) adapter "channels.list" [] +refreshChannels :: MkSlack a => AdapterM (SlackAdapter a) (Either String ChannelCache) +refreshChannels = do + usr <- execAPIMethod (withObject "object" (\o -> o .: "channels" >>= lciListParser)) "channels.list" [] + adapter <- getAdapter case usr of Left err -> return $ Left $ "Parse error when getting channel data " ++ err Right (APIResponse True v) -> do @@ -408,12 +403,13 @@ Right (APIResponse False _) -> return $ Left "Server denied getting channel info request" -resolveChannelImpl :: SlackAdapter a -> L.Text -> RunnerM (Maybe SlackChannelId) -resolveChannelImpl adapter name' = do +resolveChannelImpl :: MkSlack a => L.Text -> AdapterM (SlackAdapter a) (Maybe SlackChannelId) +resolveChannelImpl name' = do + adapter <- getAdapter cc <- readIORef $ channelChache adapter case cc ^? nameResolver . ix name of Nothing -> do - refreshed <- refreshChannels adapter + refreshed <- refreshChannels case refreshed of Left err -> logErrorN $(isT "#{err}") >> return Nothing Right ncc -> return $ ncc ^? nameResolver . ix name @@ -421,27 +417,30 @@ where name = L.tail name' -getChannelNameImpl :: SlackAdapter a -> SlackChannelId -> RunnerM L.Text -getChannelNameImpl adapter channel = do +getChannelNameImpl :: MkSlack a => SlackChannelId -> AdapterM (SlackAdapter a) L.Text +getChannelNameImpl channel = do + adapter <- getAdapter cc <- readIORef $ channelChache adapter L.cons '#' <$> case cc ^? infoCache . ix channel of Nothing -> do - ncc <- either error id <$> refreshChannels adapter + ncc <- either error id <$> refreshChannels return $ (^.name) $ fromMaybe (error "Channel not found") $ ncc ^? infoCache . ix channel Just found -> return $ found ^. name -putChannel :: SlackAdapter a -> LimitedChannelInfo -> RunnerM () -putChannel SlackAdapter{channelChache} channelInfo@(LimitedChannelInfo id name _) = +putChannel :: LimitedChannelInfo -> AdapterM (SlackAdapter a) () +putChannel channelInfo@(LimitedChannelInfo id name _) = do + SlackAdapter{channelChache} <- getAdapter void $ atomicModifyIORef channelChache $ \cache -> (, ()) $ cache & infoCache . at id .~ Just channelInfo & nameResolver . at name .~ Just id -deleteChannel :: SlackAdapter a -> SlackChannelId -> RunnerM () -deleteChannel SlackAdapter{channelChache} channel = +deleteChannel :: SlackChannelId -> AdapterM (SlackAdapter a) () +deleteChannel channel = do + SlackAdapter{channelChache} <- getAdapter void $ atomicModifyIORef channelChache $ \cache -> case cache ^? infoCache . ix channel of Nothing -> (cache, ()) @@ -450,8 +449,9 @@ & nameResolver . at name .~ Nothing -renameChannel :: SlackAdapter a -> LimitedChannelInfo -> RunnerM () -renameChannel SlackAdapter{channelChache} channelInfo@(LimitedChannelInfo id name _) = +renameChannel :: LimitedChannelInfo -> AdapterM (SlackAdapter a) () +renameChannel channelInfo@(LimitedChannelInfo id name _) = do + SlackAdapter{channelChache} <- getAdapter void $ atomicModifyIORef channelChache $ \cache -> let inserted = cache & infoCache . at id .~ Just channelInfo & nameResolver . at name .~ Just id @@ -463,7 +463,7 @@ class MkSlack a where mkAdapterId :: SlackAdapter a -> AdapterId (SlackAdapter a) - mkEventGetter :: SlackAdapter a -> Chan BS.ByteString -> MVar Connection -> RunnerM () + mkEventGetter :: Chan BS.ByteString -> AdapterM (SlackAdapter a) () data RTM @@ -485,10 +485,12 @@ instance MkSlack a => IsAdapter (SlackAdapter a) where type User (SlackAdapter a) = SlackUserId type Channel (SlackAdapter a) = SlackChannelId + initAdapter = + SlackAdapter <$> liftIO (atomically $ newTMVar 0) <*> newIORef (ChannelCache mempty mempty) <*> newIORef mempty <*> newEmptyMVar adapterId = mkAdapterId (error "phantom value" :: SlackAdapter a) messageChannel = messageChannelImpl runWithAdapter = runnerImpl - getUsername a = fmap (^.username) . getUserInfoImpl a + getUsername = fmap (^.username) . getUserInfoImpl getChannelName = getChannelNameImpl resolveChannel = resolveChannelImpl diff --git a/src/Marvin/Adapter/Telegram.hs b/src/Marvin/Adapter/Telegram.hs --- a/src/Marvin/Adapter/Telegram.hs +++ b/src/Marvin/Adapter/Telegram.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} module Marvin.Adapter.Telegram ( TelegramAdapter, Push, Poll , TelegramChat(..), ChatType(..) @@ -39,8 +40,6 @@ data TelegramAdapter updateType = TelegramAdapter - { userConfig :: C.Config - } data TelegramUpdate any @@ -132,27 +131,25 @@ 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" +execAPIMethod :: MkTelegram b => (Value -> Parser a) -> String -> [FormParam] -> AdapterM (TelegramAdapter b) (Either String (APIResponse a)) +execAPIMethod innerParser methodName params = do + token <- requireFromAdapterConfig "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 +getUsernameImpl :: TelegramUser -> AdapterM (TelegramAdapter a) L.Text +getUsernameImpl u = return $ fromMaybe (u^.firstName) $ u^.username -getChannelNameImpl :: TelegramAdapter a -> TelegramChat -> RunnerM L.Text -getChannelNameImpl _ c = return $ fromMaybe "" $ +getChannelNameImpl :: TelegramChat -> AdapterM (TelegramAdapter a) 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] +messageChannelImpl :: MkTelegram a => TelegramChat -> L.Text -> AdapterM (TelegramAdapter a) () +messageChannelImpl chat msg = do + res <- execAPIMethod msgParser "sendMessage" ["chat_id" := (chat^.id_) , "text" := msg] case res of Left err -> error $(isS "Unparseable JSON #{err}") Right Success{} -> return () @@ -162,11 +159,9 @@ runnerImpl :: forall a. MkTelegram a => RunWithAdapter (TelegramAdapter a) -runnerImpl config initializer = do +runnerImpl handler = do msgChan <- newChan - let ada = TelegramAdapter config - handler <- liftIO $ initializer ada - let eventGetter = mkEventGetter ada msgChan + let eventGetter = mkEventGetter msgChan async eventGetter forever $ do @@ -178,10 +173,10 @@ -pollEventGetter :: TelegramAdapter Poll -> Chan (TelegramUpdate Poll) -> RunnerM () -pollEventGetter ada msgChan = +pollEventGetter :: Chan (TelegramUpdate Poll) -> AdapterM (TelegramAdapter Poll) () +pollEventGetter msgChan = forever $ do - response <- execAPIMethod parseJSON ada "getUpdates" [] + response <- execAPIMethod parseJSON "getUpdates" [] case response of Left err -> do logErrorN $(isT "Unable to parse json: #{err}") @@ -193,13 +188,11 @@ writeList2Chan msgChan updates -pushEventGetter :: TelegramAdapter Push -> Chan (TelegramUpdate Push) -> RunnerM () -pushEventGetter ada msgChan = +pushEventGetter :: Chan (TelegramUpdate Push) -> AdapterM (TelegramAdapter Push) () +pushEventGetter msgChan = -- port <- liftIO $ C.require cfg "port" -- url <- liftIO $ C.require cfg "url" return () - where - cfg = userConfig ada @@ -208,7 +201,7 @@ class MkTelegram a where - mkEventGetter :: TelegramAdapter a -> Chan (TelegramUpdate a) -> RunnerM () + mkEventGetter :: Chan (TelegramUpdate a) -> AdapterM (TelegramAdapter a) () mkAdapterId :: a -> AdapterId (TelegramAdapter a) @@ -216,10 +209,11 @@ type User (TelegramAdapter a) = TelegramUser type Channel (TelegramAdapter a) = TelegramChat adapterId = scriptIdImpl (error "phantom value" :: TelegramAdapter a) + initAdapter = return TelegramAdapter runWithAdapter = runnerImpl getUsername = getUsernameImpl getChannelName = getChannelNameImpl - resolveChannel _ _ = do + resolveChannel _ = do logErrorN "Channel resolving not supported" return Nothing messageChannel = messageChannelImpl diff --git a/src/Marvin/Internal.hs b/src/Marvin/Internal.hs --- a/src/Marvin/Internal.hs +++ b/src/Marvin/Internal.hs @@ -65,6 +65,7 @@ import Marvin.Interpolate.String import Marvin.Util.Regex (Match, Regex) import Util +import Control.Monad.Base defaultBotName :: L.Text @@ -113,7 +114,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, MonadLoggerIO) +newtype BotReacting a d r = BotReacting { runReaction :: ReaderT (BotActionState a d) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadReader (BotActionState a d), MonadLogger, MonadLoggerIO, MonadBase IO) -- | An abstract type describing a marvin script. -- @@ -131,7 +132,7 @@ -- | A monad for gradually defining a 'Script' using 'respond' and 'hear' as well as any 'IO' action. -newtype ScriptDefinition a r = ScriptDefinition { runScript :: StateT (Script a) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadLogger) +newtype ScriptDefinition a r = ScriptDefinition { runScript :: StateT (Script a) RunnerM r } deriving (Monad, MonadIO, Applicative, Functor, MonadLogger, MonadBase IO) -- | Initializer for a script. This gets run by the server during startup and creates a 'Script' @@ -190,10 +191,6 @@ instance IsScript (BotReacting a b) where getScriptId = view scriptId -class AccessAdapter m where - type AdapterT m - getAdapter :: m (AdapterT m) - instance AccessAdapter (ScriptDefinition a) where type AdapterT (ScriptDefinition a) = a getAdapter = ScriptDefinition $ use adapter @@ -339,23 +336,17 @@ -- | Get the username of a registered user. -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 +getUsername :: (HasConfigAccess m, AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User (AdapterT m) -> m L.Text +getUsername = A.liftAdapterAction . A.getUsername -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) +resolveChannel :: (HasConfigAccess m, AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => L.Text -> m (Maybe (Channel (AdapterT m))) +resolveChannel = A.liftAdapterAction . A.resolveChannel -- | Get the human readable name of a channel. -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 +getChannelName :: (HasConfigAccess m, AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel (AdapterT m) -> m L.Text +getChannelName = A.liftAdapterAction . A.getChannelName -- | Send a message to the channel the original message came from and address the user that sent the original message. @@ -369,16 +360,14 @@ -- | Send a message to a Channel (by name) -messageChannel :: (AccessAdapter m, IsAdapter (AdapterT m), MonadLoggerIO m) => L.Text -> L.Text -> m () +messageChannel :: (HasConfigAccess m, 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 (AdapterT m) -> L.Text -> m () -messageChannel' chan msg = do - a <- getAdapter - A.liftAdapterAction $ A.messageChannel a chan msg +messageChannel' :: (HasConfigAccess m, AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel (AdapterT m) -> L.Text -> m () +messageChannel' chan = A.liftAdapterAction . A.messageChannel chan @@ -506,3 +495,5 @@ extractAction ac = ScriptDefinition $ fmap (runStderrLoggingT . runReaderT (runReaction ac)) $ BotActionState <$> use scriptId <*> use config <*> use adapter <*> pure () + + 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,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Marvin.Internal.Types where @@ -19,6 +20,9 @@ import Data.Time.Clock.POSIX import Marvin.Interpolate.Text import Text.Read (readMaybe) +import Control.Monad.Reader +import Control.Monad.Base +import Control.Monad.Trans.Control type Topic = L.Text @@ -33,9 +37,19 @@ | TopicChangeEvent (User a) (Channel a) Topic TimeStamp +newtype AdapterM a r = AdapterM { runAdapterAction :: ReaderT (C.Config, a) RunnerM r } deriving (MonadIO, Monad, Applicative, Functor, MonadLogger, MonadLoggerIO, MonadBase IO) + +instance MonadBaseControl IO (AdapterM a) where + type StM (AdapterM a) r = r + liftBaseWith f = AdapterM $ liftBaseWith $ \q -> f (q . runAdapterAction) + restoreM = AdapterM . restoreM + +instance AccessAdapter (AdapterM a) where + type AdapterT (AdapterM a) = a + getAdapter = AdapterM $ snd <$> ask + type EventHandler a = Event a -> IO () -type InitEventHandler a = a -> IO (EventHandler a) -type RunWithAdapter a = C.Config -> InitEventHandler a -> RunnerM () +type RunWithAdapter a = EventHandler a -> AdapterM a () -- | Basic functionality required of any adapter class IsAdapter a where @@ -44,15 +58,17 @@ -- | 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 () + messageChannel :: Channel a -> L.Text -> AdapterM a () + -- | Initialize the adapter state + initAdapter :: RunnerM a -- | Initialize and run the bot runWithAdapter :: RunWithAdapter a -- | Resolve a username given the internal user identifier - getUsername :: a -> User a -> RunnerM L.Text + getUsername :: User a -> AdapterM a L.Text -- | Resolve the human readable name for a channel given the internal channel identifier - getChannelName :: a -> Channel a -> RunnerM L.Text + getChannelName :: Channel a -> AdapterM a L.Text -- | Resolve to the internal channel identifier given a human readable name - resolveChannel :: a -> L.Text -> RunnerM (Maybe (Channel a)) + resolveChannel :: L.Text -> AdapterM a (Maybe (Channel a)) newtype User' a = User' {unwrapUser' :: User a} @@ -127,3 +143,6 @@ _ -> Nothing convert _ = Nothing +class AccessAdapter m where + type AdapterT m + getAdapter :: m (AdapterT m) diff --git a/src/Marvin/Run.hs b/src/Marvin/Run.hs --- a/src/Marvin/Run.hs +++ b/src/Marvin/Run.hs @@ -35,7 +35,7 @@ import qualified Data.Text.Lazy as L import Data.Traversable (for) import Data.Vector (Vector) -import Marvin.Adapter as A +import qualified Marvin.Adapter as A import Marvin.Internal import Marvin.Internal.Types hiding (channel) import Marvin.Interpolate.Text @@ -67,6 +67,10 @@ lookupFromAppConfig :: C.Configured a => C.Config -> C.Name -> IO (Maybe a) lookupFromAppConfig cfg = C.lookup (C.subconfig (unwrapScriptId applicationScriptId) cfg) + +runWAda :: a -> C.Config -> AdapterM a r -> RunnerM r +runWAda ada cfg ac = runReaderT (runAdapterAction ac) (cfg, ada) + -- TODO add timeouts for handlers mkApp :: forall a. IsAdapter a => LoggingFn -> [Script a] -> C.Config -> a -> EventHandler a mkApp log scripts cfg adapter = flip runLoggingT log . genericHandler @@ -91,7 +95,7 @@ -> Channel a -> RunnerM () changeHandlerHelper wildcards specifics other chan = do - cName <- A.getChannelName adapter chan + cName <- runWAda adapter cfg $ A.getChannelName chan let applicables = fromMaybe mempty $ specifics^?ix cName @@ -125,9 +129,8 @@ foldMap (^.actions) scripts --- | Create a wai compliant application -application :: IsAdapter a => LoggingFn -> [ScriptInit a] -> C.Config -> InitEventHandler a -application log inits config ada = flip runLoggingT log $ do +application :: IsAdapter a => LoggingFn -> [ScriptInit a] -> C.Config -> a -> RunnerM (EventHandler a) +application log inits config ada = do logInfoNS logSource "Initializing scripts" s <- catMaybes <$> mapM (\(ScriptInit (sid, s)) -> catch (Just <$> s ada config) (onInitExcept sid)) inits return $ mkApp log s config ada @@ -166,9 +169,10 @@ setLoggingLevelIn loggingLevel $ do oldLogFn <- askLoggerIO - liftIO $ flip runLoggingT (loggingAddSourcePrefix adapterPrefix oldLogFn) $ runWithAdapter - (C.subconfig adapterPrefix cfg) - $ application oldLogFn s' cfg + let runAdaLogging = liftIO . flip runLoggingT (loggingAddSourcePrefix adapterPrefix oldLogFn) + ada <- runAdaLogging initAdapter + handler <- application oldLogFn s' cfg ada + runWAda ada cfg $ runWithAdapter handler where adapterPrefix = $(isT "adapter.#{adapterId :: AdapterId a}") infoParser = info