marvin 0.0.7 → 0.0.8
raw patch · 8 files changed
+247/−176 lines, 8 filesdep +monad-controldep +transformers-basedep ~marvin
Dependencies added: monad-control, transformers-base
Dependency ranges changed: marvin
Files
- marvin.cabal +5/−3
- src/Marvin/Adapter.hs +39/−4
- src/Marvin/Adapter/Shell.hs +52/−28
- src/Marvin/Adapter/Slack.hs +79/−77
- src/Marvin/Adapter/Telegram.hs +21/−27
- src/Marvin/Internal.hs +14/−23
- src/Marvin/Internal/Types.hs +25/−6
- src/Marvin/Run.hs +12/−8
marvin.cabal view
@@ -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,
src/Marvin/Adapter.hs view
@@ -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
src/Marvin/Adapter/Shell.hs view
@@ -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 <user> ~ make <user> join the channel"+ , ":join <user> <channel> ~ make <user> join the channel <channel>"+ , ":leave <user> ~ make <user> leave the channel"+ , ":leave <user> <channel> ~ make <user> leave the channel <channel>"+ , ":topic <...topic> ~ change the topic to <topic>"+ ]++ 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
src/Marvin/Adapter/Slack.hs view
@@ -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
src/Marvin/Adapter/Telegram.hs view
@@ -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 "<unnamed>" $+getChannelNameImpl :: TelegramChat -> AdapterM (TelegramAdapter a) 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]+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
src/Marvin/Internal.hs view
@@ -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 ()++
src/Marvin/Internal/Types.hs view
@@ -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)
src/Marvin/Run.hs view
@@ -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