diff --git a/marvin.cabal b/marvin.cabal --- a/marvin.cabal +++ b/marvin.cabal @@ -1,5 +1,5 @@ name: marvin -version: 0.0.9 +version: 0.1.0 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -38,10 +38,10 @@ Marvin.Util.HTTP Marvin.Adapter Marvin.Adapter.Shell - Marvin.Adapter.Slack - Marvin.Adapter.Telegram - Marvin.Internal - Marvin.Internal.Types + Marvin.Adapter.Slack.RTM + Marvin.Adapter.Slack.EventsAPI + Marvin.Adapter.Telegram.Push + Marvin.Adapter.Telegram.Poll build-depends: base >=4.7 && <5, wreq >=0.4.1.0 && <0.5, @@ -63,24 +63,34 @@ text >=1.2.2.1 && <1.3, unordered-containers >=0.2.7.1 && <0.3, stm >=2.4.4.1 && <2.5, - marvin-interpolate >0.4 && <0.5, + marvin-interpolate ==1.0.*, lifted-base >=0.2.3.8 && <0.3, lifted-async >=0.9.0 && <0.10, wai >=3.2.1.1 && <3.3, warp >=3.2.8 && <3.3, + warp-tls >=3.2.2 && <3.3, 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, transformers-base >=0.4.4 && <0.5, - monad-control >=1.0.1.0 && <1.1 + monad-control >=1.0.1.0 && <1.1, + deepseq >=1.4.2.0 && <1.5, + http-types >=0.9.1 && <0.10, + http-client >=0.4.31.1 && <0.5, + http-client-tls >=0.2.4.1 && <0.3 default-language: Haskell2010 default-extensions: OverloadedStrings TypeFamilies - MultiParamTypeClasses TupleSections GADTs TemplateHaskell - QuasiQuotes + MultiParamTypeClasses TupleSections LambdaCase GADTs + TemplateHaskell QuasiQuotes hs-source-dirs: src other-modules: Util + Marvin.Internal + Marvin.Internal.Types + Marvin.Internal.Values + Marvin.Adapter.Slack.Types + Marvin.Adapter.Slack.Common + Marvin.Adapter.Telegram.Common executable marvin-pp main-is: Main.hs @@ -89,7 +99,7 @@ mustache ==2.1.*, directory >=1.2.6.2 && <1.3, filepath >=1.4.1.0 && <1.5, - marvin >=0.0.9 && <0.1, + marvin >=0.1.0 && <0.2, 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,14 +27,15 @@ slackRtmData :: (String, String) -slackRtmData = ("Marvin.Adapter.Slack", "(SlackAdapter RTM)") +slackRtmData = ("Marvin.Adapter.Slack.RTM", "(SlackAdapter RTM)") adapters :: [(String, (String, String))] adapters = [ ("slack-rtm", slackRtmData) - , ("telegram-poll", ("Marvin.Adapter.Telegram", "(TelegramAdapter Poll)")) - , ("telegram-push", ("Marvin.Adapter.Telegram", "(TelegramAdapter Push)")) + , ("slack-events", ("Marvin.Adapter.Slack.EventsAPI", "(SlackAdapter EventsAPI)")) + , ("telegram-poll", ("Marvin.Adapter.Telegram.Poll", "(TelegramAdapter Poll)")) + , ("telegram-push", ("Marvin.Adapter.Telegram.Push", "(TelegramAdapter Push)")) , ("shell", ("Marvin.Adapter.Shell", "ShellAdapter")) ] diff --git a/src/Marvin.hs b/src/Marvin.hs --- a/src/Marvin.hs +++ b/src/Marvin.hs @@ -13,28 +13,27 @@ module Marvin ( -- * The Script - Script(..), defineScript, ScriptInit + Script, defineScript, ScriptInit , ScriptId , ScriptDefinition, IsAdapter -- * Reacting + , BotReacting -- ** Reaction Functions , hear, respond, enter, exit, enterIn, exitFrom, topic, topicIn, customTrigger -- ** Getting data - , getData, getMessage, getMatch, getTopic, getChannel, getUser, getUsername, getChannelName, resolveChannel + , getData, getMessage, getMatch, getTopic, getChannel, getUser, getUsername, getChannelName, resolveUser, resolveChannel -- ** Sending messages , send, reply, messageChannel, messageChannel' -- ** Interaction with the config , getConfigVal, requireConfigVal, getBotName -- ** Handler Types - , Message(..), User, Channel, BotReacting + , Message, User, Channel, Topic -- ** Advanced actions , extractAction, extractReaction - -- ** Misc - , Topic ) where import Marvin.Adapter (IsAdapter) import Marvin.Internal import Marvin.Internal.Types hiding (getChannelName, getUsername, messageChannel, - resolveChannel) + resolveChannel, resolveUser) diff --git a/src/Marvin/Adapter.hs b/src/Marvin/Adapter.hs --- a/src/Marvin/Adapter.hs +++ b/src/Marvin/Adapter.hs @@ -8,27 +8,29 @@ Portability : POSIX -} {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} module Marvin.Adapter - ( Event(..) - , RunWithAdapter, EventHandler, RunnerM - , IsAdapter(..), AdapterId + ( RunWithAdapter, EventHandler + , IsAdapter(..), AdapterId, mkAdapterId, unwrapAdapterId + , AdapterM, Event(..) , lookupFromAdapterConfig, requireFromAdapterConfig - , lookupFromAppConfig, requireFromAppConfig - , getAdapterConfig, getAppConfig + , lookupFromAppConfig, requireFromAppConfig, getBotname + , getAdapterConfig, getAppConfig, getAdapter , liftAdapterAction ) where import Control.Monad.IO.Class import Control.Monad.Logger +import Control.Monad.Reader +import qualified Data.Configurator as C import qualified Data.Configurator.Types as C -import qualified Data.Configurator as C +import Data.Maybe (fromMaybe) import qualified Data.Text.Lazy as L import Marvin.Internal.Types -import Control.Monad.Reader -import Marvin.Interpolate.Text +import Marvin.Internal.Values +import Marvin.Interpolate.Text liftAdapterAction :: (MonadIO m, HasConfigAccess m, AccessAdapter m, IsAdapter a, a ~ AdapterT m) => AdapterM a r -> m r @@ -39,7 +41,7 @@ getAppConfig :: AdapterM a C.Config -getAppConfig = AdapterM $ +getAppConfig = AdapterM $ C.subconfig $(isT "#{applicationScriptId}") . fst <$> ask @@ -51,9 +53,13 @@ requireFromAppConfig n = getAppConfig >>= liftIO . flip C.require n +getBotname :: AdapterM a L.Text +getBotname = fromMaybe defaultBotName <$> lookupFromAppConfig "name" + + getAdapterConfig :: forall a. IsAdapter a => AdapterM a C.Config getAdapterConfig = AdapterM $ - C.subconfig $(isT "adapter.#{adapterId :: AdapterId a}") . fst <$> ask + C.subconfig $(isT "#{adapterConfigKey}.#{adapterId :: AdapterId a}") . fst <$> ask lookupFromAdapterConfig :: (IsAdapter a, C.Configured v) => C.Name -> AdapterM a (Maybe v) 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 @@ -1,5 +1,14 @@ +{-| +Module : $Header$ +Description : Adapter for communicating with a shell prompt. +Copyright : (c) Justus Adam, 2017 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} {-# LANGUAGE NamedFieldPuns #-} -module Marvin.Adapter.Shell where +module Marvin.Adapter.Shell (ShellAdapter) where import Control.Concurrent.Async.Lifted @@ -8,19 +17,16 @@ import Control.Monad.IO.Class import Control.Monad.Loops import Data.Char (isSpace) -import Data.Maybe (fromMaybe) -import qualified Data.Text as T import qualified Data.Text.Lazy as L import Data.Time.Clock (getCurrentTime) import Marvin.Adapter -import Marvin.Internal (defaultBotName) -import Marvin.Internal.Types import Marvin.Interpolate.String import Marvin.Interpolate.Text.Lazy +import Marvin.Types import System.Console.Haskeline -import qualified Data.Configurator as C +-- | Adapter for a shell prompt data ShellAdapter = ShellAdapter { output :: MVar (Maybe L.Text) } @@ -39,19 +45,26 @@ instance IsAdapter ShellAdapter where + -- | Stores the username type User ShellAdapter = L.Text + -- | Stores channel name type Channel ShellAdapter = L.Text adapterId = "shell" - messageChannel _ chan = do + messageChannel _ chan = do ShellAdapter{output} <- getAdapter putMVar output $ Just chan + -- | Just returns the value again getUsername = return + -- | Just returns the value again getChannelName = return + -- | Just returns the value again resolveChannel = return . Just + -- | Just returns the value again + resolveUser = return . Just initAdapter = ShellAdapter <$> newEmptyMVar runWithAdapter handler = do - bot <- fromMaybe defaultBotName <$> lookupFromAppConfig "name" + bot <- getBotname histfile <- lookupFromAdapterConfig "history-file" ShellAdapter out <- getAdapter liftIO $ runInputT defaultSettings {historyFile=histfile} $ do diff --git a/src/Marvin/Adapter/Slack.hs b/src/Marvin/Adapter/Slack.hs deleted file mode 100644 --- a/src/Marvin/Adapter/Slack.hs +++ /dev/null @@ -1,496 +0,0 @@ -{-| -Module : $Header$ -Description : Adapter for communicating with Slack via its real time event API -Copyright : (c) Justus Adam, 2016 -License : BSD3 -Maintainer : dev@justus.science -Stability : experimental -Portability : POSIX --} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE 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, newEmptyMVar, putMVar, readMVar, takeMVar) -import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar, takeTMVar) -import Control.Exception.Lifted -import Control.Lens hiding ((.=)) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Logger -import Data.Aeson hiding (Error) -import Data.Aeson.TH -import Data.Aeson.Types hiding (Error) -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.Char (isSpace) -import qualified Data.Configurator as C -import qualified Data.Configurator.Types as C -import Data.Containers -import Data.Foldable (asum, 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.Internal -import Marvin.Internal.Types as Types -import Marvin.Interpolate.Text -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 - - -instance ToJSON URI where - toJSON = toJSON . show - - -data RTMData = RTMData - { ok :: Bool - , url :: URI - -- , self :: BotData - } - -data APIResponse a = APIResponse - { responseOk :: Bool - , 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 :: SlackChannelId - , limitedChannelInfoName :: L.Text - , limitedChannelInfoTopic :: L.Text - } deriving Show - |] - -declareFields [d| - data UserInfo = UserInfo - { userInfoUsername :: L.Text - , userInfoIdValue :: SlackUserId - } - |] - - -declareFields [d| - data ChannelCache = ChannelCache - { channelCacheInfoCache :: HashMap SlackChannelId LimitedChannelInfo - , channelCacheNameResolver :: HashMap L.Text SlackChannelId - } - |] - - -data InternalType - = Error - { code :: Int - , msg :: String - } - | Unhandeled String - | Ignored - | ChannelArchiveStatusChange SlackChannelId Bool - | ChannelCreated LimitedChannelInfo - | ChannelDeleted SlackChannelId - | ChannelRename LimitedChannelInfo - | UserChange UserInfo - - -deriveJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } ''RTMData - - -messageParser :: Value -> Parser (Event (SlackAdapter a)) -messageParser (Object o) = MessageEvent - <$> o .: "user" - <*> o .: "channel" - <*> o .: "text" - <*> (o .: "ts" >>= timestampFromNumber) -messageParser _ = mzero - - -eventParser :: Value -> Parser (Either InternalType (Event (SlackAdapter a))) -eventParser v@(Object o) = isErrParser <|> hasTypeParser - where - isErrParser = do - e <- o .: "error" - case e of - (Object eo) -> do - ev <- Error <$> eo .: "code" <*> eo .: "msg" - return $ Left ev - _ -> mzero - hasTypeParser = do - t <- o .: "type" - - -- https://api.slack.com/rtm - case t of - "error" -> do - ev <- Error <$> o .: "code" <*> o .: "msg" - return $ Left ev - "message" -> do - subt <- o .:? "subtype" - case (subt :: Maybe T.Text) of - Just str -> - case str of - "channel_join" -> cJoin - "group_join" -> cJoin - "channel_leave" -> cLeave - "group_leave" -> cLeave - "channel_topic" -> do - t <- TopicChangeEvent <$> user <*> channel <*> o .: "topic" <*> ts - return $ Right t - _ -> msgEv - - _ -> msgEv - where - ts = o .: "ts" >>= timestampFromNumber - msgEv = Right <$> messageParser v - user = o .: "user" - channel = o .: "channel" - cJoin = do - ev <- ChannelJoinEvent <$> user <*> channel <*> ts - return $ Right ev - cLeave = do - ev <- ChannelLeaveEvent <$> user <*> channel <*> ts - return $ Right ev - "reconnect_url" -> return $ Left Ignored - "channel_archive" -> do - ev <- ChannelArchiveStatusChange <$> o .: "channel" <*> pure True - return $ Left ev - "channel_unarchive" -> do - ev <- ChannelArchiveStatusChange <$> o .: "channel" <*> pure False - return $ Left ev - "channel_created" -> do - ev <- o .: "channel" >>= lciParser - return $ Left $ ChannelCreated ev - "channel_deleted" -> Left . ChannelDeleted <$> o .: "channel" - "channel_rename" -> do - ev <- o .: "channel" >>= lciParser - pure $ Left $ ChannelRename ev - "user_change" -> do - ev <- o .: "user" >>= userInfoParser - pure $ Left $ UserChange ev - _ -> return $ Left $ Unhandeled t -eventParser _ = mzero - - -rawBS :: BS.ByteString -> String -rawBS bs = "\"" ++ BS.unpack bs ++ "\"" - - -helloParser :: Value -> Parser Bool -helloParser (Object o) = do - t <- o .: "type" - return $ (t :: T.Text) == "hello" -helloParser _ = mzero - - -userInfoParser :: Value -> Parser UserInfo -userInfoParser (Object o) = do - usr <- o .: "user" - case usr of - (Object o) -> UserInfo <$> o .: "name" <*> o .: "id" - _ -> mzero -userInfoParser _ = mzero - - -apiResponseParser :: (Value -> Parser a) -> Value -> Parser (APIResponse a) -apiResponseParser f v@(Object o) = APIResponse <$> o .: "ok" <*> f v -apiResponseParser _ _ = mzero - -data SlackAdapter a = SlackAdapter - { midTracker :: TMVar Int - , channelChache :: IORef ChannelCache - , userInfoCache :: IORef (HashMap SlackUserId UserInfo) - , connectionTracker :: MVar Connection - } - - -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 - Left err -> logErrorN $(isT "Error decoding rtm json #{err}") - Right js -> do - let uri = url js - authority = fromMaybe (error "URI lacks authority") (uriAuthority uri) - host = uriUserInfo authority ++ uriRegName authority - path = uriPath uri - portOnErr v = do - logErrorN $(isT "Unreadable port #{v}") - return 443 - port <- case uriPort authority of - v@(':':r) -> maybe (portOnErr v) return $ readMaybe r - v -> portOnErr v - $logDebug $(isT "connecting to socket '#{uri}'") - logFn <- askLoggerIO - catch - (liftIO $ runSecureClient host port path $ \conn -> flip runLoggingT logFn $ do - logInfoN "Connection established" - d <- liftIO $ receiveData conn - case eitherDecode d >>= parseEither helloParser of - Right True -> $logDebug "Recieved hello packet" - Left _ -> error $ "Hello packet not readable: " ++ BS.unpack d - _ -> error $ "First packet was not hello packet: " ++ BS.unpack d - putMVar connectionTracker conn - forever $ do - d <- liftIO $ receiveData conn - writeChan messageChan d) - $ \e -> do - void $ takeMVar connectionTracker - logErrorN $(isT "#{e :: ConnectionException}") - - -stripWhiteSpaceMay :: L.Text -> Maybe L.Text -stripWhiteSpaceMay t = - case L.uncons t of - Just (c, _) | isSpace c -> Just $ L.stripStart t - _ -> Nothing - - -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 <$> 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 - Just m' -> CommandEvent u c m' t - - 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 info - ChannelDeleted chan -> deleteChannel chan - ChannelRename info -> renameChannel info - UserChange ui -> void $ refreshUserInfo (ui^.idValue) - - -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 handler = do - messageChan <- newChan - void $ async $ mkEventGetter messageChan - runHandlerLoop messageChan handler - - -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) - - -newMid :: AdapterM (SlackAdapter a) Int -newMid = do - SlackAdapter{midTracker} <- getAdapter - liftIO $ atomically $ do - id <- takeTMVar midTracker - putTMVar midTracker (id + 1) - return id - - -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 - , "text" .= msg - ] - - -getUserInfoImpl :: MkSlack a => SlackUserId -> AdapterM (SlackAdapter a) UserInfo -getUserInfoImpl user@(SlackUserId user') = do - adapter <- getAdapter - uc <- readIORef $ userInfoCache adapter - maybe (refreshUserInfo user) return $ lookup user uc - - -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 - atomicModifyIORef (userInfoCache adapter) ((, ()) . insertMap user v) - return v - Right (APIResponse False _) -> error "Server denied getting user info request" - - -lciParser :: Value -> Parser LimitedChannelInfo -lciParser (Object o) = LimitedChannelInfo <$> o .: "id" <*> o .: "name" <*> (o .: "topic" >>= withObject "object" (.: "value")) -lciParser _ = mzero - - -lciListParser :: Value -> Parser [LimitedChannelInfo] -lciListParser = withArray "array" $ fmap toList . mapM lciParser - - -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 - let cmap = mapFromList $ map ((^. idValue) &&& id) v - nmap = mapFromList $ map ((^. name) &&& (^. idValue)) v - cache = ChannelCache cmap nmap - atomicWriteIORef (channelChache adapter) cache - return $ Right cache - Right (APIResponse False _) -> return $ Left "Server denied getting channel info request" - - -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 - case refreshed of - Left err -> logErrorN $(isT "#{err}") >> return Nothing - Right ncc -> return $ ncc ^? nameResolver . ix name - Just found -> return (Just found) - where name = L.tail name' - - -getChannelNameImpl :: 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 - return $ (^.name) $ fromMaybe (error "Channel not found") $ ncc ^? infoCache . ix channel - Just found -> return $ found ^. 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 :: SlackChannelId -> AdapterM (SlackAdapter a) () -deleteChannel channel = do - SlackAdapter{channelChache} <- getAdapter - void $ atomicModifyIORef channelChache $ \cache -> - case cache ^? infoCache . ix channel of - Nothing -> (cache, ()) - Just (LimitedChannelInfo _ name _) -> - (, ()) $ cache & infoCache . at channel .~ Nothing - & nameResolver . at name .~ Nothing - - -renameChannel :: 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 - in case cache ^? infoCache . ix id of - Just (LimitedChannelInfo _ oldName _) | oldName /= name -> - (, ()) $ inserted & nameResolver . at oldName .~ Nothing - _ -> (inserted, ()) - - -class MkSlack a where - mkAdapterId :: SlackAdapter a -> AdapterId (SlackAdapter a) - mkEventGetter :: Chan BS.ByteString -> AdapterM (SlackAdapter a) () - - -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 - 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 = fmap (^.username) . getUserInfoImpl - getChannelName = getChannelNameImpl - resolveChannel = resolveChannelImpl - diff --git a/src/Marvin/Adapter/Slack/Common.hs b/src/Marvin/Adapter/Slack/Common.hs new file mode 100644 --- /dev/null +++ b/src/Marvin/Adapter/Slack/Common.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +module Marvin.Adapter.Slack.Common 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 (modifyMVar, modifyMVar_, newMVar, readMVar) +import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.Aeson hiding (Error) +import Data.Aeson.Types hiding (Error) +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Char (isSpace) +import Data.Foldable (asum) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import Marvin.Adapter hiding (mkAdapterId) +import Marvin.Adapter.Slack.Types +import Marvin.Interpolate.All +import Marvin.Types +import Network.Wreq +import Util + + + +messageParser :: Value -> Parser (Event (SlackAdapter a)) +messageParser = withObject "expected object" $ \o -> + MessageEvent + <$> o .: "user" + <*> o .: "channel" + <*> o .: "text" + <*> (o .: "ts" >>= timestampFromNumber) + + +eventParser :: Value -> Parser (InternalType a) +eventParser v@(Object o) = isErrParser <|> hasTypeParser + where + isErrParser = do + e <- o .: "error" + flip (withObject "expected object") e $ \eo -> + Error <$> eo .: "code" <*> eo .: "msg" + hasTypeParser = do + t <- o .: "type" + + -- https://api.slack.com/rtm + case t of + "error" -> Error <$> o .: "code" <*> o .: "msg" + "message" -> messageTypeEvent + "message.channels" -> messageTypeEvent + "message.groups" -> messageTypeEvent + "message.im" -> messageTypeEvent + "message.mpim" -> messageTypeEvent + "reconnect_url" -> return Ignored + "channel_archive" -> ChannelArchiveStatusChange <$> o .: "channel" <*> pure True + "channel_unarchive" -> ChannelArchiveStatusChange <$> o .: "channel" <*> pure False + "channel_created" -> ChannelCreated <$> (o .: "channel" >>= lciParser) + "channel_deleted" -> ChannelDeleted <$> o .: "channel" + "channel_rename" -> ChannelRename <$> (o .: "channel" >>= lciParser) + "user_change" -> UserChange <$> (o .: "user" >>= userInfoParser) + _ -> return $ Unhandeled t + messageTypeEvent = do + subt <- o .:? "subtype" + SlackEvent <$> case (subt :: Maybe T.Text) of + Just str -> + case str of + "channel_join" -> cJoin + "group_join" -> cJoin + "channel_leave" -> cLeave + "group_leave" -> cLeave + "channel_topic" -> + TopicChangeEvent <$> user <*> channel <*> o .: "topic" <*> ts + _ -> msgEv + + _ -> msgEv + where + ts = o .: "ts" >>= timestampFromNumber + msgEv = messageParser v + user = o .: "user" + channel = o .: "channel" + cJoin = ChannelJoinEvent <$> user <*> channel <*> ts + cLeave = ChannelLeaveEvent <$> user <*> channel <*> ts +eventParser _ = fail "expected object" + + +stripWhiteSpaceMay :: L.Text -> Maybe L.Text +stripWhiteSpaceMay t = + case L.uncons t of + Just (c, _) | isSpace c -> Just $ L.stripStart t + _ -> Nothing + + +runHandlerLoop :: MkSlack a => Chan (InternalType a) -> EventHandler (SlackAdapter a) -> AdapterM (SlackAdapter a) () +runHandlerLoop evChan handler = + forever $ do + d <- readChan evChan + void $ async $ case d of + SlackEvent ev@(MessageEvent u c m t) -> do + + botname <- L.toLower <$> getBotname + let strippedMsg = L.stripStart m + let lmsg = L.toLower strippedMsg + liftIO $ handler $ case asum $ map ((\prefix -> if prefix `L.isPrefixOf` lmsg then Just $ L.drop (L.length prefix) strippedMsg else Nothing) >=> stripWhiteSpaceMay) [botname, L.cons '@' botname, L.cons '/' botname] of + Nothing -> ev + Just m' -> CommandEvent u c m' t + + SlackEvent event -> liftIO $ handler event + Unhandeled type_ -> + logDebugN $(isT "Unhandeled event type #{type_} payload") + 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 info + ChannelDeleted chan -> deleteChannel chan + ChannelRename info -> renameChannel info + UserChange ui -> void $ refreshSingleUserInfo (ui^.idValue) + + +runnerImpl :: MkSlack a => RunWithAdapter (SlackAdapter a) +runnerImpl handler = do + messageChan <- newChan + void $ async $ initIOConnections messageChan + runHandlerLoop messageChan handler + + +execAPIMethod :: MkSlack a => (Object -> Parser v) -> String -> [FormParam] -> AdapterM (SlackAdapter a) (Either String v) +execAPIMethod innerParser method params = do + token <- requireFromAdapterConfig "token" + response <- liftIO $ post $(isS "https://slack.com/api/#{method}") (("token" := (token :: T.Text)):params) + return $ eitherDecode (response^.responseBody) >>= join . parseEither (apiResponseParser innerParser) + + +messageChannelImpl :: SlackChannelId -> L.Text -> AdapterM (SlackAdapter a) () +messageChannelImpl cid msg = do + SlackAdapter{outChannel} <- getAdapter + writeChan outChannel (cid, msg) + + +getUserInfoImpl :: MkSlack a => SlackUserId -> AdapterM (SlackAdapter a) UserInfo +getUserInfoImpl user = do + adapter <- getAdapter + uc <- readMVar $ userInfoCache adapter + maybe (refreshSingleUserInfo user) return $ uc ^? infoCache. ix user + + +refreshSingleUserInfo :: MkSlack a => SlackUserId -> AdapterM (SlackAdapter a) UserInfo +refreshSingleUserInfo user@(SlackUserId user') = do + adapter <- getAdapter + usr <- execAPIMethod (\o -> o .: "user" >>= userInfoParser) "users.info" ["user" := user'] + case usr of + Left err -> error ("Parse error when getting user data " ++ err) + Right v -> do + modifyMVar_ (userInfoCache adapter) (return . (infoCache . at user .~ Just v)) + return v + + +refreshChannels :: MkSlack a => AdapterM (SlackAdapter a) (Either String ChannelCache) +refreshChannels = do + chans <- execAPIMethod (\o -> o .: "channels" >>= lciListParser) "channels.list" [] + case chans of + Left err -> return $ Left $ "Error when getting channel data " ++ err + Right v -> do + let cmap = HM.fromList $ map ((^. idValue) &&& id) v + nmap = HM.fromList $ map ((^. name) &&& (^. idValue)) v + cache = ChannelCache cmap nmap + return $ Right cache + + +refreshSingleChannelInfo :: MkSlack a => SlackChannelId -> AdapterM (SlackAdapter a) LimitedChannelInfo +refreshSingleChannelInfo chan = do + res <- execAPIMethod (\o -> o .: "channel" >>= lciParser) "channels.info" [] + case res of + Left err -> error $ "Parse error when getting channel data " ++ err + Right v -> do + adapter <- getAdapter + modifyMVar_ (channelCache adapter) (return . (infoCache . at chan .~ Just v)) + return v + + +resolveChannelImpl :: MkSlack a => L.Text -> AdapterM (SlackAdapter a) (Maybe SlackChannelId) +resolveChannelImpl name' = do + adapter <- getAdapter + modifyMVar (channelCache adapter) $ \cc -> + case cc ^? nameResolver . ix name of + Nothing -> do + refreshed <- refreshChannels + case refreshed of + Left err -> logErrorN $(isT "#{err}") >> return (cc, Nothing) + Right ncc -> return (ncc, ncc ^? nameResolver . ix name) + Just found -> return (cc, Just found) + where name = L.tail name' + + +refreshUserInfo :: MkSlack a => AdapterM (SlackAdapter a) (Either String UserCache) +refreshUserInfo = do + users <- execAPIMethod (\o -> o .: "members" >>= userInfoListParser) "users.list" [] + case users of + Left err -> return $ Left $ "Error when getting channel data " ++ err + Right v -> do + let cmap = HM.fromList $ map ((^. idValue) &&& id) v + nmap = HM.fromList $ map ((^. username) &&& (^. idValue)) v + cache = UserCache cmap nmap + return $ Right cache + + +resolveUserImpl :: MkSlack a => L.Text -> AdapterM (SlackAdapter a) (Maybe SlackUserId) +resolveUserImpl name = do + adapter <- getAdapter + modifyMVar (userInfoCache adapter) $ \cc -> + case cc ^? nameResolver . ix name of + Nothing -> do + refreshed <- refreshUserInfo + case refreshed of + Left err -> logErrorN $(isT "#{err}") >> return (cc, Nothing) + Right ncc -> return (ncc, ncc ^? nameResolver . ix name) + Just found -> return (cc, Just found) + + +getChannelNameImpl :: MkSlack a => SlackChannelId -> AdapterM (SlackAdapter a) L.Text +getChannelNameImpl channel = do + adapter <- getAdapter + cc <- readMVar $ channelCache adapter + L.cons '#' <$> + case cc ^? infoCache . ix channel of + Nothing -> (^.name) <$> refreshSingleChannelInfo channel + Just found -> return $ found ^. name + + + +putChannel :: LimitedChannelInfo -> AdapterM (SlackAdapter a) () +putChannel channelInfo@(LimitedChannelInfo id name _) = do + SlackAdapter{channelCache} <- getAdapter + modifyMVar_ channelCache $ \cache -> + return $ cache + & infoCache . at id .~ Just channelInfo + & nameResolver . at name .~ Just id + + +deleteChannel :: SlackChannelId -> AdapterM (SlackAdapter a) () +deleteChannel channel = do + SlackAdapter{channelCache} <- getAdapter + modifyMVar_ channelCache $ \cache -> + return $ case cache ^? infoCache . ix channel of + Nothing -> cache + Just (LimitedChannelInfo _ name _) -> + cache + & infoCache . at channel .~ Nothing + & nameResolver . at name .~ Nothing + + +renameChannel :: LimitedChannelInfo -> AdapterM (SlackAdapter a) () +renameChannel channelInfo@(LimitedChannelInfo id name _) = do + SlackAdapter{channelCache} <- getAdapter + modifyMVar_ channelCache $ \cache -> + return $ + let inserted = cache + & infoCache . at id .~ Just channelInfo + & nameResolver . at name .~ Just id + in case cache ^? infoCache . ix id of + Just (LimitedChannelInfo _ oldName _) | oldName /= name -> + inserted & nameResolver . at oldName .~ Nothing + _ -> inserted + + +-- | Class to enable polymorphism for 'SlackAdapter' over the method used for retrieving updates. ('RTM' or 'EventsAPI') +class MkSlack a where + mkAdapterId :: AdapterId (SlackAdapter a) + initIOConnections :: Chan (InternalType a) -> AdapterM (SlackAdapter a) () + + +instance MkSlack a => IsAdapter (SlackAdapter a) where + type User (SlackAdapter a) = SlackUserId + type Channel (SlackAdapter a) = SlackChannelId + initAdapter = SlackAdapter + <$> newMVar (ChannelCache mempty mempty) + <*> newMVar (UserCache mempty mempty) + <*> newChan + adapterId = mkAdapterId + messageChannel = messageChannelImpl + runWithAdapter = runnerImpl + getUsername = fmap (^.username) . getUserInfoImpl + getChannelName = getChannelNameImpl + resolveChannel = resolveChannelImpl + resolveUser = resolveUserImpl + diff --git a/src/Marvin/Adapter/Slack/EventsAPI.hs b/src/Marvin/Adapter/Slack/EventsAPI.hs new file mode 100644 --- /dev/null +++ b/src/Marvin/Adapter/Slack/EventsAPI.hs @@ -0,0 +1,113 @@ +{-| +Module : $Header$ +Description : Adapter for communicating with Slack via the webhook based Events API +Copyright : (c) Justus Adam, 2016 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} +{-# LANGUAGE NamedFieldPuns #-} +module Marvin.Adapter.Slack.EventsAPI + ( SlackAdapter, EventsAPI + , SlackUserId, SlackChannelId + , MkSlack + ) where + + +import Control.Concurrent.Async.Lifted +import Control.Concurrent.Chan.Lifted +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.Aeson +import Data.Aeson.Types +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Encoding as L +import Marvin.Adapter +import Marvin.Adapter.Slack.Common +import Marvin.Adapter.Slack.Types +import Marvin.Interpolate.All +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Handler.WarpTLS +import Network.Wreq + + +eventAPIeventParser :: Value -> Parser (T.Text, Either L.Text (InternalType a)) +eventAPIeventParser = withObject "expected object" $ \o -> do + token <- o .: "token" + type_ <- o .: "type" + + (token,) <$> case (type_ :: T.Text) of + "url_verification" -> Left <$> o .: "challenge" + "event_callback" -> Right <$> (o .: "event" >>= eventParser) + _ -> fail "unknown wrapper event type" + + +runEventReceiver :: Chan (InternalType EventsAPI) -> AdapterM (SlackAdapter EventsAPI) () +runEventReceiver evChan = do + useTLS <- fromMaybe True <$> lookupFromAdapterConfig "use-tls" + server <- if useTLS + then do + certfile <- requireFromAdapterConfig "certfile" + keyfile <- requireFromAdapterConfig "keyfile" + return $ runTLS $ tlsSettings certfile keyfile + else return runSettings + port <- fromMaybe 7000 <$> lookupFromAdapterConfig "port" + expectedToken <- requireFromAdapterConfig "token" + + let warpSet = setPort port defaultSettings + + logFn <- askLoggerIO + + liftIO $ server warpSet $ \req resp -> flip runLoggingT logFn $ + let + respond status headers body = liftIO $ resp $ responseLBS status headers body + in if requestMethod req == methodPost + then do + bod <- liftIO $ lazyRequestBody req + case eitherDecode bod >>= parseEither eventAPIeventParser of + Left err -> do + logErrorN $(isT "Unreadable JSON event: '#{err}'") + respond notAcceptable406 [] "" + Right (token,_) | token /= expectedToken -> do + logErrorN $(isT "Recieved incorrect token: '#{token}'") + respond unauthorized401 [] "" + Right (_, Left challenge) -> do + logInfoN $(isT "Recieved challenge event: '#{challenge}'") + respond ok200 [] (L.encodeUtf8 challenge) + Right (_, Right ev) -> do + writeChan evChan ev + respond ok200 [] "" + else respond methodNotAllowed405 [] "" + + +sendMessageLoop :: AdapterM (SlackAdapter EventsAPI) () +sendMessageLoop = do + SlackAdapter{outChannel} <- getAdapter + forever $ do + (SlackChannelId chan, msg) <- readChan outChannel + res <- execAPIMethod + (const $ return ()) + "chat.postMessage" + [ "channel" := chan + , "text" := msg + ] + case res of + Left err -> logErrorN $(isT "Sending message failed: #{err}") + Right () -> return () + + +-- | Recieve events as a server via HTTP webhook (not implemented yet) +data EventsAPI + + +instance MkSlack EventsAPI where + mkAdapterId = "slack-events" + initIOConnections inChan = do + void $ async $ runEventReceiver inChan + sendMessageLoop diff --git a/src/Marvin/Adapter/Slack/RTM.hs b/src/Marvin/Adapter/Slack/RTM.hs new file mode 100644 --- /dev/null +++ b/src/Marvin/Adapter/Slack/RTM.hs @@ -0,0 +1,125 @@ +{-| +Module : $Header$ +Description : Adapter for communicating with Slack via its real time messaging API +Copyright : (c) Justus Adam, 2016 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} +{-# LANGUAGE NamedFieldPuns #-} +module Marvin.Adapter.Slack.RTM + ( SlackAdapter, RTM + , SlackUserId, SlackChannelId + , MkSlack + ) where + + +import Control.Concurrent.Async.Lifted (async) +import Control.Concurrent.Chan.Lifted +import Control.Concurrent.MVar.Lifted +import Control.Concurrent.STM (atomically, newTMVar, putTMVar, takeTMVar) +import Control.Exception.Lifted +import Control.Lens hiding ((.=)) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.Aeson hiding (Error) +import Data.Aeson.Types hiding (Error) +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Marvin.Adapter +import Marvin.Adapter.Slack.Common +import Marvin.Adapter.Slack.Types +import Marvin.Interpolate.Text +import Network.URI +import Network.WebSockets +import Network.Wreq +import Text.Read (readMaybe) +import Wuss + + +runConnectionLoop :: Chan (InternalType RTM) -> MVar Connection -> AdapterM (SlackAdapter RTM) () +runConnectionLoop eventChan connectionTracker = forever $ do + token <- requireFromAdapterConfig "token" + messageChan <- newChan + void $ async $ forever $ do + msg <- readChan messageChan + case eitherDecode msg >>= parseEither eventParser of + Left e -> logErrorN $(isT "Error parsing json: #{e} original data: #{rawBS msg}") + Right v -> writeChan eventChan v + logDebugN "initializing socket" + r <- liftIO $ post "https://slack.com/api/rtm.start" [ "token" := (token :: T.Text) ] + case eitherDecode (r^.responseBody) of + Left err -> logErrorN $(isT "Error decoding rtm json #{err}") + Right js -> do + let uri = url js + authority = fromMaybe (error "URI lacks authority") (uriAuthority uri) + host = uriUserInfo authority ++ uriRegName authority + path = uriPath uri + portOnErr v = do + logErrorN $(isT "Unreadable port #{v}") + return 443 + port <- case uriPort authority of + v@(':':r) -> maybe (portOnErr v) return $ readMaybe r + v -> portOnErr v + logDebugN $(isT "connecting to socket '#{uri}'") + logFn <- askLoggerIO + catch + (liftIO $ runSecureClient host port path $ \conn -> flip runLoggingT logFn $ do + logInfoN "Connection established" + d <- liftIO $ receiveData conn + case eitherDecode d >>= parseEither helloParser of + Right True -> logDebugN "Recieved hello packet" + Left _ -> error $ "Hello packet not readable: " ++ BS.unpack d + _ -> error $ "First packet was not hello packet: " ++ BS.unpack d + putMVar connectionTracker conn + forever $ do + d <- liftIO $ receiveData conn + writeChan messageChan d) + $ \e -> do + void $ takeMVar connectionTracker + logErrorN $(isT "#{e :: ConnectionException}") + + +senderLoop :: MVar Connection -> AdapterM (SlackAdapter a) () +senderLoop connectionTracker = do + SlackAdapter{outChannel} <- getAdapter + midTracker <- liftIO $ atomically $ newTMVar (0 :: Int) + forever $ do + (SlackChannelId sid, msg) <- readChan outChannel + mid <- liftIO $ atomically $ do + id <- takeTMVar midTracker + putTMVar midTracker (id + 1) + return id + let encoded = encode $ object + [ "id" .= mid + , "type" .= ("message" :: T.Text) + , "channel" .= sid + , "text" .= msg + ] + + go 0 = logErrorN "Connection error, quitting retry." + go n = + catch + (do + conn <- readMVar connectionTracker + liftIO $ sendTextData conn encoded) + $ \e -> do + logErrorN $(isT "#{e :: ConnectionException}") + go (n-1) + go (3 :: Int) + + +-- | Recieve events by opening a websocket to the Real Time Messaging API +data RTM + + +instance MkSlack RTM where + mkAdapterId = "slack-rtm" + initIOConnections inChan = do + connTracker <- newEmptyMVar + async $ runConnectionLoop inChan connTracker + senderLoop connTracker + diff --git a/src/Marvin/Adapter/Slack/Types.hs b/src/Marvin/Adapter/Slack/Types.hs new file mode 100644 --- /dev/null +++ b/src/Marvin/Adapter/Slack/Types.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Marvin.Adapter.Slack.Types where + +import Control.Concurrent.Chan.Lifted (Chan) +import Control.Concurrent.MVar.Lifted (MVar) +import Control.Lens hiding ((.=)) +import Data.Aeson hiding (Error) +import Data.Aeson.TH +import Data.Aeson.Types hiding (Error) +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Foldable (toList) +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import Data.String (IsString (..)) +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import Marvin.Adapter +import Network.URI + + +jsonParseURI :: Value -> Parser URI +jsonParseURI = withText "expected text" $ maybe (fail "string not parseable as uri") return . parseURI . T.unpack + + +data RTMData = RTMData + { ok :: Bool + , url :: URI + } + +type APIResponse a = Either String a + + +-- | Identifier for a user (internal and not equal to the username) +newtype SlackUserId = SlackUserId T.Text deriving (IsString, Eq, Hashable) +-- | Identifier for a channel (internal and not 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 :: SlackChannelId + , limitedChannelInfoName :: L.Text + , limitedChannelInfoTopic :: L.Text + } deriving Show + |] + +declareFields [d| + data UserInfo = UserInfo + { userInfoUsername :: L.Text + , userInfoIdValue :: SlackUserId + } + |] + + +declareFields [d| + data ChannelCache = ChannelCache + { channelCacheInfoCache :: HashMap SlackChannelId LimitedChannelInfo + , channelCacheNameResolver :: HashMap L.Text SlackChannelId + } + |] + + +declareFields [d| + data UserCache = UserCache + { userCacheInfoCache :: HashMap SlackUserId UserInfo + , userCacheNameResolver :: HashMap L.Text SlackUserId + } + |] + + + +data InternalType a + = SlackEvent (Event (SlackAdapter a)) + | Error + { code :: Int + , msg :: String + } + | Unhandeled String + | Ignored + | ChannelArchiveStatusChange SlackChannelId Bool + | ChannelCreated LimitedChannelInfo + | ChannelDeleted SlackChannelId + | ChannelRename LimitedChannelInfo + | UserChange UserInfo + + +-- | Adapter for interacting with Slack API\'s. Polymorphic over the method for retrieving events. +data SlackAdapter a = SlackAdapter + { channelCache :: MVar ChannelCache + , userInfoCache :: MVar UserCache + , outChannel :: Chan (SlackChannelId, L.Text) + } + + +instance FromJSON RTMData where + parseJSON = withObject "expected object" $ \o -> + RTMData <$> o .: "ok" <*> (o .: "url" >>= jsonParseURI) + + +rawBS :: BS.ByteString -> String +rawBS bs = "\"" ++ BS.unpack bs ++ "\"" + + +helloParser :: Value -> Parser Bool +helloParser = withObject "expected object" $ \o -> do + t <- o .: "type" + return $ (t :: T.Text) == "hello" + + +userInfoParser :: Value -> Parser UserInfo +userInfoParser = withObject "expected object" $ \o -> + o .: "user" >>= withObject "expected object" (\o' -> UserInfo <$> o' .: "name" <*> o' .: "id") + + +userInfoListParser :: Value -> Parser [UserInfo] +userInfoListParser = withArray "expected array" (fmap toList . mapM userInfoParser) + + +apiResponseParser :: (Object -> Parser a) -> Value -> Parser (APIResponse a) +apiResponseParser f = withObject "expected object" $ \o -> do + succ <- o .: "ok" + if succ + then Right <$> f o + else Left <$> o .: "error" + + +lciParser :: Value -> Parser LimitedChannelInfo +lciParser = withObject "expected object" $ \o -> + LimitedChannelInfo + <$> o .: "id" + <*> o .: "name" + <*> (o .: "topic" >>= withObject "object" (.: "value")) + +lciListParser :: Value -> Parser [LimitedChannelInfo] +lciListParser = withArray "array" $ fmap toList . mapM lciParser + diff --git a/src/Marvin/Adapter/Telegram.hs b/src/Marvin/Adapter/Telegram.hs deleted file mode 100644 --- a/src/Marvin/Adapter/Telegram.hs +++ /dev/null @@ -1,235 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -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.Internal.Types -import Marvin.Interpolate.String -import Marvin.Interpolate.Text -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 - - -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 msg - isPost = Ev <$> (o .: "channel_post" >>= msgParser) - isUnhandeled = return Unhandeled - - -msgParser :: Value -> Parser (Event (TelegramAdapter a)) -msgParser = withObject "expected message object" $ \o -> - MessageEvent - <$> o .: "from" - <*> o .: "chat" - <*> o .: "text" - <*> (o .: "date" >>= timestampFromNumber) - - - -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 :: 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) - - -getUsernameImpl :: TelegramUser -> AdapterM (TelegramAdapter a) L.Text -getUsernameImpl u = return $ fromMaybe (u^.firstName) $ u^.username - - -getChannelNameImpl :: TelegramChat -> AdapterM (TelegramAdapter a) L.Text -getChannelNameImpl c = return $ fromMaybe "" $ - c^.username <|> (L.unwords <$> sequence [c^.firstName, c^.lastName]) <|> c^.firstName - - -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 () - Right (Error code desc) -> - logErrorN $(isT "Sending message failed with #{code}: #{desc}") - - - -runnerImpl :: forall a. MkTelegram a => RunWithAdapter (TelegramAdapter a) -runnerImpl handler = do - msgChan <- newChan - let eventGetter = mkEventGetter msgChan - async eventGetter - - forever $ do - d <- readChan msgChan - case d of - Ev ev -> liftIO $ handler ev - Ignored -> return () - Unhandeled -> logDebugN $(isT "Unhadeled event.") - - - -pollEventGetter :: Chan (TelegramUpdate Poll) -> AdapterM (TelegramAdapter Poll) () -pollEventGetter msgChan = - forever $ do - response <- execAPIMethod parseJSON "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 :: Chan (TelegramUpdate Push) -> AdapterM (TelegramAdapter Push) () -pushEventGetter msgChan = - -- port <- liftIO $ C.require cfg "port" - -- url <- liftIO $ C.require cfg "url" - return () - - - -scriptIdImpl :: forall a. MkTelegram a => TelegramAdapter a -> AdapterId (TelegramAdapter a) -scriptIdImpl _ = mkAdapterId (error "phantom value" :: a) - - -class MkTelegram a where - mkEventGetter :: Chan (TelegramUpdate a) -> AdapterM (TelegramAdapter a) () - 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) - initAdapter = return TelegramAdapter - 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/Adapter/Telegram/Common.hs b/src/Marvin/Adapter/Telegram/Common.hs new file mode 100644 --- /dev/null +++ b/src/Marvin/Adapter/Telegram/Common.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Marvin.Adapter.Telegram.Common 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 Data.Char (isSpace) +import Data.Foldable (asum) +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import Marvin.Adapter hiding (mkAdapterId) +import Marvin.Interpolate.All +import Network.Wreq +import Util + +import Control.Exception.Lifted + +data APIResponse a + = Success { description :: Maybe T.Text, result :: a} + | Error { errorCode :: Int, errDescription :: T.Text} + + +-- | The telegram adapter type for a particular update type. Either 'Push' or 'Poll' +data TelegramAdapter updateType = TelegramAdapter + + +data TelegramUpdate any + = Ev (Event (TelegramAdapter any)) + | Ignored + | Unhandeled + + +-- | Chat type as defined by the telegram api +data ChatType + = PrivateChat + | GroupChat + | SupergroupChat + | ChannelChat + + +-- | A user object as contained in the telegram update objects +declareFields [d| + data TelegramUser = TelegramUser + { telegramUserId_ :: Integer + , telegramUserFirstName :: L.Text + , telegramUserLastName :: Maybe L.Text + , telegramUserUsername :: Maybe L.Text + } + |] + +-- | A telegram chat object as contained in telegram updates +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" $ + \case + "private" -> pure PrivateChat + "group" -> pure GroupChat + "supergroup" -> pure SupergroupChat + "channel" -> pure ChannelChat + a -> fail $(isS "Unknown chat type #{a}") + +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 msg + isPost = Ev <$> (o .: "channel_post" >>= msgParser) + isUnhandeled = return Unhandeled + + +telegramSupportedUpdates :: [T.Text] +telegramSupportedUpdates = + [ "message" + , "channel_post" + ] + + +msgParser :: Value -> Parser (Event (TelegramAdapter a)) +msgParser = withObject "expected message object" $ \o -> + MessageEvent + <$> o .: "from" + <*> o .: "chat" + <*> o .: "text" + <*> (o .: "date" >>= timestampFromNumber) + + + +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 :: MkTelegram b => (Value -> Parser a) -> String -> [FormParam] -> AdapterM (TelegramAdapter b) (Either String (APIResponse a)) +execAPIMethod = execAPIMethodWith defaults + +execAPIMethodWith :: MkTelegram b => Options -> (Value -> Parser a) -> String -> [FormParam] -> AdapterM (TelegramAdapter b) (Either String (APIResponse a)) +execAPIMethodWith opts innerParser methodName params = do + token <- requireFromAdapterConfig "token" + res <- retry 3 (liftIO (postWith opts $(isS "https://api.telegram.org/bot#{token :: String}/#{methodName}") params)) + return $ res >>= eitherDecode . (^. responseBody) >>= parseEither (apiResponseParser innerParser) + where + retry n a = (Right <$> a) `catch` \e -> if n <= 0 + then -- TODO only catch appropriate exceptions + return $ Left $ displayException (e :: SomeException) + else retry (succ n) a + + +getUsernameImpl :: TelegramUser -> AdapterM (TelegramAdapter a) L.Text +getUsernameImpl u = return $ fromMaybe (u^.firstName) $ u^.username + + +getChannelNameImpl :: TelegramChat -> AdapterM (TelegramAdapter a) L.Text +getChannelNameImpl c = return $ fromMaybe "" $ + c^.username <|> (L.unwords <$> sequence [c^.firstName, c^.lastName]) <|> c^.firstName + + +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 () + Right (Error code desc) -> + logErrorN $(isT "Sending message failed with #{code}: #{desc}") + +stripWhiteSpaceMay :: L.Text -> Maybe L.Text +stripWhiteSpaceMay t = + case L.uncons t of + Just (c, _) | isSpace c -> Just $ L.stripStart t + _ -> Nothing + +runnerImpl :: forall a. MkTelegram a => RunWithAdapter (TelegramAdapter a) +runnerImpl handler = do + msgChan <- newChan + let eventGetter = mkEventGetter msgChan + async $ eventGetter `catch` \e -> do + logErrorN $(isT "Unexpected exception in event getter: #{e :: SomeException}") + throw e + + forever $ do + logDebugN "Starting to read" + d <- readChan msgChan + logDebugN "Recieved message" + case d of + Ev ev@(MessageEvent u chat msg ts) -> do + botname <- L.toLower <$> getBotname + let strippedMsg = L.stripStart msg + let lmsg = L.toLower strippedMsg + liftIO $ handler $ case (chat^.type_, asum $ map ((\prefix -> if prefix `L.isPrefixOf` lmsg then Just $ L.drop (L.length prefix) strippedMsg else Nothing) >=> stripWhiteSpaceMay) [botname, L.cons '@' botname, L.cons '/' botname]) of + (PrivateChat, _) -> CommandEvent u chat msg ts + (_, Nothing) -> ev + (_, Just m') -> CommandEvent u chat m' ts + Ev ev -> liftIO $ handler ev + Ignored -> return () + Unhandeled -> logDebugN $(isT "Unhadeled event.") + + +-- | Class to enable polymorphism over update mechanics for 'TelegramAdapter' +class MkTelegram a where + mkEventGetter :: Chan (TelegramUpdate a) -> AdapterM (TelegramAdapter a) () + mkAdapterId :: AdapterId (TelegramAdapter a) + + +instance MkTelegram a => IsAdapter (TelegramAdapter a) where + type User (TelegramAdapter a) = TelegramUser + type Channel (TelegramAdapter a) = TelegramChat + adapterId = mkAdapterId + initAdapter = return TelegramAdapter + runWithAdapter = runnerImpl + getUsername = getUsernameImpl + getChannelName = getChannelNameImpl + -- | Not supported in this adapter and always returns 'Nothing' + resolveChannel _ = do + logErrorN "Channel resolving not supported" + return Nothing + -- | Not supported in this adapter and always returns 'Nothing' + resolveUser _ = do + logErrorN "User resolving not supported" + return Nothing + messageChannel = messageChannelImpl diff --git a/src/Marvin/Adapter/Telegram/Poll.hs b/src/Marvin/Adapter/Telegram/Poll.hs new file mode 100644 --- /dev/null +++ b/src/Marvin/Adapter/Telegram/Poll.hs @@ -0,0 +1,77 @@ +{-| +Module : $Header$ +Description : Adapter for communicating with Telegram via its http poll API. +Copyright : (c) Justus Adam, 2017 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} +module Marvin.Adapter.Telegram.Poll + ( TelegramAdapter, Poll + , TelegramChat(..), ChatType(..) + , TelegramUser(..) + , MkTelegram + ) where + + + +import Control.Concurrent.Chan.Lifted +import Control.Concurrent.Lifted +import Control.Lens +import Control.Monad +import Control.Monad.Logger +import Data.Aeson hiding (Error, Success) +import Data.Aeson.Types hiding (Error, Success) +import Data.IORef.Lifted +import Marvin.Adapter +import Marvin.Adapter.Telegram.Common +import Marvin.Interpolate.Text +import Network.HTTP.Client (managerResponseTimeout) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.Wreq + + +data UpdateWithId = UpdateWithId {updateId :: Integer, updateContent :: TelegramUpdate Poll } + +instance FromJSON UpdateWithId where + parseJSON = withObject "expected object" $ \o -> UpdateWithId <$> o .: "update_id" <*> parseJSON (Object o) + +pollEventGetter :: Chan (TelegramUpdate Poll) -> AdapterM (TelegramAdapter Poll) () +pollEventGetter msgChan = do + idRef <- newIORef Nothing + forever $ do + timeout <- lookupFromAdapterConfig "polling-timeout" >>= readTimeout + let defParams = ["timeout" := (timeout :: Int) ] + nextId <- readIORef idRef + let pollSettings = defaults & manager . _Left .~ tlsManagerSettings { managerResponseTimeout = Just ((timeout + 3) * 1000)} + response <- execAPIMethodWith pollSettings parseJSON "getUpdates" $ maybe defParams ((:defParams) . ("offset" :=)) nextId + 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=[]} -> return () + Right Success {result=updates} -> do + writeIORef idRef $ Just $ succ $ maximum $ map updateId updates + logDebugN "Writing messages" + writeList2Chan msgChan $ map updateContent updates + where + defaultTimeout = 120 + readTimeout Nothing = return defaultTimeout + readTimeout (Just n) + | n < 0 = do + logErrorN $(isT "Telegram adapter poll timeout must be positive, was #{n} (using default timeout instead)") + return defaultTimeout + | otherwise = return n + + +-- | Use the telegram API by fetching updates via HTTP +data Poll + + +instance MkTelegram Poll where + mkAdapterId = "telegram-poll" + mkEventGetter = pollEventGetter diff --git a/src/Marvin/Adapter/Telegram/Push.hs b/src/Marvin/Adapter/Telegram/Push.hs new file mode 100644 --- /dev/null +++ b/src/Marvin/Adapter/Telegram/Push.hs @@ -0,0 +1,88 @@ +{-| +Module : $Header$ +Description : Adapter for communicating with Telegram via its webhook based push API. +Copyright : (c) Justus Adam, 2017 +License : BSD3 +Maintainer : dev@justus.science +Stability : experimental +Portability : POSIX +-} +{-# LANGUAGE NamedFieldPuns #-} +module Marvin.Adapter.Telegram.Push + ( TelegramAdapter, Push + , TelegramChat(..), ChatType(..) + , TelegramUser(..) + , MkTelegram + ) where + + +import Control.Concurrent.Async.Lifted +import Control.Concurrent.Chan.Lifted +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger +import Data.Aeson hiding (Error, Success) +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Marvin.Adapter +import Marvin.Adapter.Telegram.Common +import Marvin.Interpolate.All +import Marvin.Types +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Handler.WarpTLS +import Network.Wreq + + +pushEventGetter :: Chan (TelegramUpdate Push) -> AdapterM (TelegramAdapter Push) () +pushEventGetter evChan = do + void $ async $ do + url <- requireFromAdapterConfig "url" + r <- execAPIMethod parseJSON "setWebhook" + [ "url" := (url :: T.Text) + , "allowed_updates" := show telegramSupportedUpdates + ] + case r of + Right Success{ result = True } -> return () + Left err -> error $(isS "Parsing result from setting webhook failed #{err}") + Right Error{errDescription} -> error $(isS "Setting the webhook failed: #{errDescription}") + useTLS <- fromMaybe True <$> lookupFromAdapterConfig "use-tls" + port <- requireFromAdapterConfig "port" + + runServer <- if useTLS + then do + certfile <- requireFromAdapterConfig "certfile" + keyfile <- requireFromAdapterConfig "keyfile" + return $ runTLS $ tlsSettings certfile keyfile + else return runSettings + + let warpSet = setPort port defaultSettings + + logFn <- askLoggerIO + + liftIO $ runServer warpSet $ \req resp -> flip runLoggingT logFn $ do + let meth = requestMethod req + if meth == methodPost + then do + bod <- liftIO $ lazyRequestBody req + case eitherDecode bod of + Left err -> do + logErrorN $(isT "Unreadable JSON event: '#{err}'") + liftIO $ resp $ responseLBS notAcceptable406 [] "" + Right update -> do + writeChan evChan update + liftIO $ resp $ responseLBS ok200 [] "" + else liftIO $ resp $ responseLBS methodNotAllowed405 [] "" + + + +-- | Use the telegram API by recieving updates as a server via webhook +-- +-- Note: The initialization for this adapter _includes_ registering or clearing its own webhook. +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 @@ -17,7 +17,7 @@ -- ** Sending messages , send, reply, messageChannel, messageChannel' -- ** Getting Data - , getData, getUser, getMatch, getMessage, getChannel, getTopic, getBotName, getChannelName, resolveChannel, getUsername + , getData, getUser, getMatch, getMessage, getChannel, getTopic, getBotName, getChannelName, resolveChannel, getUsername, resolveUser -- ** Interacting with the config , getConfigVal, requireConfigVal -- *** Access config (advanced, internal) @@ -41,166 +41,33 @@ ) where -import Control.Monad.Reader -import Control.Monad.State -import qualified Data.Configurator as C -import qualified Data.Configurator.Types as C - -import Control.Arrow import Control.Exception.Lifted -import Control.Lens hiding (cons) +import Control.Lens hiding (cons) import Control.Monad.Logger -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 Control.Monad.Reader +import Control.Monad.State +import qualified Data.Configurator as C +import qualified Data.Configurator.Types as C +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, resolveUser) +import Marvin.Internal.Values import Marvin.Interpolate.String -import Marvin.Util.Regex (Match, Regex) +import Marvin.Interpolate.Text +import Marvin.Util.Regex (Match, Regex) import Util -import Control.Monad.Base -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 - , botActionStatePayload :: d - } - |] - - -declareFields [d| - data Handlers a = Handlers - { handlersResponds :: Vector (Regex, (User' a, Channel' a, Match, Message, TimeStamp) -> RunnerM ()) - , handlersHears :: Vector (Regex, (User' a, Channel' a, Match, Message, TimeStamp) -> RunnerM ()) - , handlersCustoms :: Vector (Event a -> Maybe (RunnerM ())) - , handlersJoins :: Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ()) - , handlersLeaves :: Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ()) - , handlersTopicChange :: Vector ((User' a, Channel' a, Topic, TimeStamp) -> RunnerM ()) - , handlersJoinsIn :: HM.HashMap L.Text (Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ())) - , handlersLeavesFrom :: HM.HashMap L.Text (Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ())) - , handlersTopicChangeIn :: HM.HashMap L.Text (Vector ((User' a, Channel' a, Topic, TimeStamp) -> RunnerM ())) - } - |] - - -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) (HM.unionWith mappend ji1 ji2) (HM.unionWith mappend li1 li2) (HM.unionWith mappend 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'. --- --- The type parameter @d@ is the accessible data provided by the trigger for this action and can be obtained with 'getData' or other custom functions like 'getMessage' and 'getMatch' which typically depend on a particular type of data in @d@. --- For message handlers like 'hear' and 'respond' this would be a regex 'Match' and a 'Message' for instance. --- --- For completeness: @a@ is the adapter type and @r@ is the return type of the monadic computation. --- --- This is also a 'MonadReader' instance, there you can inspect the entire state of this reaction. --- This is 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, MonadBase IO) - --- | An abstract type describing a marvin script. --- --- This is basically a collection of event handlers. --- --- Internal structure is exposed for people wanting to extend this. -declareFields [d| - data Script a = Script - { scriptActions :: Handlers a - , scriptScriptId :: ScriptId - , scriptConfig :: C.Config - , scriptAdapter :: a - } - |] - - --- | 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, MonadBase IO) - - --- | Initializer for a script. This gets run by the server during startup and creates a 'Script' -newtype ScriptInit a = ScriptInit (ScriptId, a -> C.Config -> RunnerM (Script a)) - - --- | Class which says that there is a way to get to a 'Message' from this type @m@. -class Get a b where - getLens :: Lens' a b - -instance Get (User' a, b, c) (User' a) where - getLens = _1 - -instance Get (User' a, b, c, d) (User' a) where - getLens = _1 - -instance Get (User' a, b, c, d, e) (User' a) where - getLens = _1 - -instance Get (a, Channel' b, c) (Channel' b) where - getLens = _2 - -instance Get (a, Channel' b, c, d) (Channel' b) where - getLens = _2 - -instance Get (a, Channel' b, c, d, e) (Channel' b) where - getLens = _2 - -instance Get (a, b, TimeStamp) TimeStamp where - getLens = _3 - -instance Get (a, b, c, TimeStamp) TimeStamp where - getLens = _4 - -instance Get (a, b, c, d, TimeStamp) TimeStamp where - getLens = _5 - -instance Get (a, b, Match, d, e) Match where - getLens = _3 - -instance Get (a, b, c, Message, e) Message where - getLens = _4 - -instance Get (a, b, Topic, d) Topic where - getLens = _3 - -instance HasConfigAccess (ScriptDefinition a) where - getConfigInternal = ScriptDefinition $ use config - -instance HasConfigAccess (BotReacting a b) where - getConfigInternal = view config - -instance IsScript (ScriptDefinition a) where - getScriptId = ScriptDefinition $ use scriptId - -instance IsScript (BotReacting a b) where - getScriptId = view scriptId - -instance AccessAdapter (ScriptDefinition a) where - type AdapterT (ScriptDefinition a) = a - getAdapter = ScriptDefinition $ use adapter - -instance AccessAdapter (BotReacting a b) where - type AdapterT (BotReacting a b) = a - getAdapter = view adapter - getSubConfFor :: HasConfigAccess m => ScriptId -> m C.Config -getSubConfFor (ScriptId name) = C.subconfig ("script." <> name) <$> getConfigInternal +getSubConfFor (ScriptId name) = C.subconfig $(isT "#{scriptConfigKey}.#{name}") <$> getConfigInternal -- | Get the config part for the currect script @@ -212,7 +79,7 @@ runBotAction scriptId config adapter trigger data_ action = do oldLogFn <- askLoggerIO catch - (liftIO $ flip runLoggingT (loggingAddSourcePrefix $(isT "script.#{scriptId}") oldLogFn) $ flip runReaderT actionState $ runReaction action) + (liftIO $ flip runLoggingT (loggingAddSourcePrefix $(isT "#{scriptConfigKey}.#{scriptId}") oldLogFn) $ flip runReaderT actionState $ runReaction action) (onScriptExcept scriptId trigger) where actionState = BotActionState scriptId config adapter data_ @@ -320,7 +187,7 @@ -- 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 a -> Maybe d) -> BotReacting a d () -> ScriptDefinition a () +customTrigger :: (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) @@ -335,20 +202,30 @@ messageChannel' o msg --- | Get the username of a registered user. -getUsername :: (HasConfigAccess m, AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => User (AdapterT m) -> m L.Text +-- | Get the username of a registered user. The type signature is so large to allow this function to be used both in 'BotReacting' and 'ScriptDefinition'. +getUsername :: (HasConfigAccess m, AccessAdapter m, IsAdapter a, MonadIO m, AdapterT m ~ a) + => User a -> m L.Text getUsername = A.liftAdapterAction . A.getUsername -resolveChannel :: (HasConfigAccess m, AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => L.Text -> m (Maybe (Channel (AdapterT m))) +-- | Try to get the channel with a particular human readable name. The type signature is so large to allow this function to be used both in 'BotReacting' and 'ScriptDefinition'. +resolveChannel :: (HasConfigAccess m, AccessAdapter m, IsAdapter a, MonadIO m, AdapterT m ~ a) + => L.Text -> m (Maybe (Channel a)) resolveChannel = A.liftAdapterAction . A.resolveChannel --- | Get the human readable name of a channel. -getChannelName :: (HasConfigAccess m, AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel (AdapterT m) -> m L.Text +-- | Get the human readable name of a channel. The type signature is so large to allow this function to be used both in 'BotReacting' and 'ScriptDefinition'. +getChannelName :: (HasConfigAccess m, AccessAdapter m, IsAdapter a, MonadIO m, AdapterT m ~ a) + => Channel a -> m L.Text getChannelName = A.liftAdapterAction . A.getChannelName +-- | Try to get the user with a particular username. The type signature is so large to allow this function to be used both in 'BotReacting' and 'ScriptDefinition'. +resolveUser :: (HasConfigAccess m, AccessAdapter m, IsAdapter a, MonadIO m, AdapterT m ~ a) + => L.Text -> m (Maybe (User a)) +resolveUser = A.liftAdapterAction . A.resolveUser + + -- | 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 @@ -366,6 +243,7 @@ maybe ($logError $(isT "No channel known with the name #{name}")) (`messageChannel'` msg) mchan +-- | Send a message to a channel (by adapter dependent channel object) messageChannel' :: (HasConfigAccess m, AccessAdapter m, IsAdapter (AdapterT m), MonadIO m) => Channel (AdapterT m) -> L.Text -> m () messageChannel' chan = A.liftAdapterAction . A.messageChannel chan @@ -373,7 +251,7 @@ -- | Define a new script for marvin -- --- You need to provide a ScriptId (which can simple be written as a non-empty string). +-- You need to provide a ScriptId (which can be written as a non-empty string, needs the @OverloadedStrings@ language extension). -- This id is used as the key for the section in the bot config belonging to this script and in logging output. -- -- Roughly equivalent to "module.exports" in hubot. @@ -418,7 +296,7 @@ getChannel = (unwrapChannel' :: Channel' a -> Channel a) <$> view (payload . getLens) --- | Get the user whihc was part of the triggered action. +-- | Get the user which was part of the triggered action. getUser :: forall m a. Get m (User' a) => BotReacting a m (User a) getUser = (unwrapUser' :: User' a -> User a) <$> view (payload . getLens) 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,33 +1,43 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Marvin.Internal.Types where +import Control.DeepSeq import Control.Lens -import Control.Monad +import Control.Monad.Base import Control.Monad.IO.Class import Control.Monad.Logger -import Data.Aeson -import Data.Aeson.Types -import Data.Char (isAlphaNum, isLetter) -import qualified Data.Configurator.Types as C +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Control +import Data.Char (isAlphaNum, isLetter) +import qualified Data.Configurator.Types as C +import qualified Data.HashMap.Strict as HM +import Data.Monoid import Data.String -import qualified Data.Text as T -import qualified Data.Text.Lazy as L +import qualified Data.Text as T +import qualified Data.Text.Lazy as L import Data.Time.Clock -import Data.Time.Clock.POSIX +import Data.Vector (Vector) +import GHC.Generics +import Marvin.Interpolate.String import Marvin.Interpolate.Text -import Text.Read (readMaybe) -import Control.Monad.Reader -import Control.Monad.Base -import Control.Monad.Trans.Control +import Marvin.Util.Regex +-- | The topic in a channel type Topic = L.Text +-- | The contents of a recieved message type Message = L.Text +-- | A timestamp type. Supplied with most 'Event' types +newtype TimeStamp = TimeStamp { unwrapTimeStamp :: UTCTime } deriving Show + + -- | Representation for the types of events which can occur data Event a = MessageEvent (User a) (Channel a) Message TimeStamp @@ -36,24 +46,21 @@ | ChannelLeaveEvent (User a) (Channel a) TimeStamp | TopicChangeEvent (User a) (Channel a) Topic TimeStamp +-- | Basic monad which most internal actions run in +type RunnerM = LoggingT IO +-- | Monad in which adapter actions run in 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 RunWithAdapter a = EventHandler a -> AdapterM a () -- | Basic functionality required of any adapter class IsAdapter a where + -- | Concrete, adapter specific representation of a user. Could be an id string or a full object for instance type User a + -- | Concrete, adapter specific representation of a channel. Could be an id string or a full object for instance type Channel a -- | Used for scoping config and logging adapterId :: AdapterId a @@ -61,68 +68,237 @@ messageChannel :: Channel a -> L.Text -> AdapterM a () -- | Initialize the adapter state initAdapter :: RunnerM a - -- | Initialize and run the bot + -- | Run the bot runWithAdapter :: RunWithAdapter a -- | Resolve a username given the internal user identifier getUsername :: User a -> AdapterM a L.Text -- | Resolve the human readable name for a channel given the internal channel identifier getChannelName :: Channel a -> AdapterM a L.Text - -- | Resolve to the internal channel identifier given a human readable name + -- | Resolve to the internal channel structure given a human readable name resolveChannel :: L.Text -> AdapterM a (Maybe (Channel a)) + -- | Resolve to the internal user structure given a human readable name + resolveUser :: L.Text -> AdapterM a (Maybe (User a)) +-- | Wrapping type for users. Only used to enable 'Get' typeclass instances. newtype User' a = User' {unwrapUser' :: User a} +-- | Wrapping type for channels. Only used to enable 'Get' typeclass instances. newtype Channel' a = Channel' {unwrapChannel' :: Channel a} -newtype TimeStamp = TimeStamp { unwrapTimeStamp :: UTCTime } deriving Show - -timestampFromNumber :: Value -> Parser TimeStamp -timestampFromNumber (Number n) = return $ TimeStamp $ posixSecondsToUTCTime $ realToFrac n -timestampFromNumber (String s) = maybe mzero (return . TimeStamp . posixSecondsToUTCTime . realToFrac) (readMaybe (T.unpack s) :: Maybe Double) -timestampFromNumber _ = mzero - - - -- | A type, basically a String, which identifies a script to the config and the logging facilities. +-- +-- For conversion please use 'mkScriptId' and 'unwrapScriptId'. They will perform necessary checks. newtype ScriptId = ScriptId { unwrapScriptId :: T.Text } deriving (Show, Eq) -- | A type, basically a String, which identifies an adapter to the config and the logging facilities. +-- +-- For conversion please use 'mkAdapterId' and 'unwrapAdapterId'. They will perform necessary checks. newtype AdapterId a = AdapterId { unwrapAdapterId :: T.Text } deriving (Show, Eq) -instance ShowT ScriptId where showT = unwrapScriptId +class HasScriptId s a | s -> a where + scriptId :: Lens' s a -instance ShowT (AdapterId a) where showT = unwrapAdapterId +-- | 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 + , botActionStatePayload :: d + } + |] -applicationScriptId :: ScriptId -applicationScriptId = ScriptId "bot" +declareFields [d| + data Handlers a = Handlers + { handlersResponds :: Vector (Regex, (User' a, Channel' a, Match, Message, TimeStamp) -> RunnerM ()) + , handlersHears :: Vector (Regex, (User' a, Channel' a, Match, Message, TimeStamp) -> RunnerM ()) + , handlersCustoms :: Vector (Event a -> Maybe (RunnerM ())) + , handlersJoins :: Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ()) + , handlersLeaves :: Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ()) + , handlersTopicChange :: Vector ((User' a, Channel' a, Topic, TimeStamp) -> RunnerM ()) + , handlersJoinsIn :: HM.HashMap L.Text (Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ())) + , handlersLeavesFrom :: HM.HashMap L.Text (Vector ((User' a, Channel' a, TimeStamp) -> RunnerM ())) + , handlersTopicChangeIn :: HM.HashMap L.Text (Vector ((User' a, Channel' a, Topic, TimeStamp) -> RunnerM ())) + } deriving Generic + |] -type RunnerM = LoggingT IO +instance NFData (Handlers a) -verifyIdString :: String -> (String -> a) -> String -> a -verifyIdString name _ "" = error $ name ++ " must not be empty" -verifyIdString name f s@(x:xs) - | isLetter x && all (\c -> isAlphaNum c || c == '-' || c == '_' ) xs = f s - | otherwise = error $ "first character of " ++ name ++ " must be a letter, all other characters can be alphanumeric, '-' or '_'" +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) (HM.unionWith mappend ji1 ji2) (HM.unionWith mappend li1 li2) (HM.unionWith mappend ti1 ti2) + + +-- | Monad for reacting in the bot. Allows use of functions like 'Marvin.send', 'Marvin.reply' and 'Marvin.messageChannel' as well as any arbitrary 'IO' action using 'liftIO'. +-- +-- The type parameter @d@ is the accessible data provided by the trigger for this action and can be obtained with 'Marvin.getData' or other custom functions like 'Marvin.getMessage' and 'Marvin.getMatch' which typically depend on a particular type of data in @d@. +-- +-- For completeness: @a@ is the adapter type and @r@ is the return type of the monadic computation. +-- +-- This is also a 'MonadReader' instance, there you can inspect the entire state of this reaction. +-- This is 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, MonadBase IO) + +-- | An abstract type describing a marvin script. +-- +-- This is basically a collection of event handlers. +-- +-- Internal structure is exposed for people wanting to extend this. +declareFields [d| + data Script a = Script + { scriptActions :: Handlers a + , scriptScriptId :: ScriptId + , scriptConfig :: C.Config + , scriptAdapter :: a + } + |] + + +-- | A monad for gradually defining a 'Script' using 'Marvin.respond' and 'Marvin.hear' as well as any 'IO' action. +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' +newtype ScriptInit a = ScriptInit (ScriptId, a -> C.Config -> RunnerM (Script a)) + + +instance MonadBaseControl IO (AdapterM a) where + type StM (AdapterM a) r = r + liftBaseWith f = AdapterM $ liftBaseWith $ \q -> f (q . runAdapterAction) + restoreM = AdapterM . restoreM + + + +-- | Class which says that there is a way to get to @b@ from this type @a@. +-- +-- This typeclass is used to allow handlers with different types of payload to share common +-- accessor functions such as 'Marvin.getUser' and 'Marvin.getMessage'. +-- +-- The instances specify for each type of payload which pieces of data can be extracted and how. +class Get a b where + getLens :: Lens' a b + +instance Get (User' a, b, c) (User' a) where + getLens = _1 + +instance Get (User' a, b, c, d) (User' a) where + getLens = _1 + +instance Get (User' a, b, c, d, e) (User' a) where + getLens = _1 + +instance Get (a, Channel' b, c) (Channel' b) where + getLens = _2 + +instance Get (a, Channel' b, c, d) (Channel' b) where + getLens = _2 + +instance Get (a, Channel' b, c, d, e) (Channel' b) where + getLens = _2 + +instance Get (a, b, TimeStamp) TimeStamp where + getLens = _3 + +instance Get (a, b, c, TimeStamp) TimeStamp where + getLens = _4 + +instance Get (a, b, c, d, TimeStamp) TimeStamp where + getLens = _5 + +instance Get (a, b, Match, d, e) Match where + getLens = _3 + +instance Get (a, b, c, Message, e) Message where + getLens = _4 + +instance Get (a, b, Topic, d) Topic where + getLens = _3 + +instance HasConfigAccess (ScriptDefinition a) where + getConfigInternal = ScriptDefinition $ use config + +instance HasConfigAccess (BotReacting a b) where + getConfigInternal = view config + +-- | Similar to 'AccessAdapter', this class says there is a 'ScriptId' reachable from the type (usually a monad) @m@. +class IsScript m where + -- | Retrieve the script id out of @m@, ususally a monad. + getScriptId :: m ScriptId + +instance IsScript (ScriptDefinition a) where + getScriptId = ScriptDefinition $ use scriptId + +instance IsScript (BotReacting a b) where + getScriptId = view scriptId + + +-- | Similar to 'IsScript', this class says that there is an adapter 'AdapterT' available from this type (usually a monad) @m@. +-- +-- The type of adapter depends on the monad itself. +-- This class can be thought of as 'MonadReader' specified to 'AdapterT'. +class AccessAdapter m where + -- | The concrete type of adapter accessible from @m@. + type AdapterT m + getAdapter :: m (AdapterT m) + +instance AccessAdapter (ScriptDefinition a) where + type AdapterT (ScriptDefinition a) = a + getAdapter = ScriptDefinition $ use adapter + +instance AccessAdapter (BotReacting a b) where + type AdapterT (BotReacting a b) = a + getAdapter = view adapter + + +instance AccessAdapter (AdapterM a) where + type AdapterT (AdapterM a) = a + getAdapter = AdapterM $ snd <$> ask + +instance ShowT ScriptId where showT = unwrapScriptId + +instance ShowT (AdapterId a) where showT = unwrapAdapterId + + +type LoggingFn = Loc -> LogSource -> LogLevel -> LogStr -> IO () + + +verifyIdString :: String -> (T.Text -> a) -> T.Text -> Either String a +verifyIdString name _ "" = Left $(isS "#{name} must not be empty") +verifyIdString name f s + | isLetter x && T.all (\c -> isAlphaNum c || c == '-' || c == '_' ) xs = Right $ f s + | otherwise = Left $(isS "first character of #{name} must be a letter, all other characters can be alphanumeric, '-' or '_'") + where Just (x, xs) = T.uncons s + + instance IsString ScriptId where - fromString = verifyIdString "script id" (ScriptId . fromString) + fromString = either error id . verifyIdString "script id" ScriptId . fromString instance IsString (AdapterId a) where - fromString = verifyIdString "adapter id" (AdapterId . fromString) + fromString = either error id . verifyIdString "adapter id" AdapterId . fromString -class HasScriptId s a | s -> a where - scriptId :: Lens' s a +-- | Attempt to create a script id from 'Text' +mkScriptId :: T.Text -> Either String ScriptId +mkScriptId = verifyIdString "script id" ScriptId +-- | Attempt to create an adapter id from 'Text' +mkAdapterId :: T.Text -> Either String (AdapterId a) +mkAdapterId = verifyIdString "adapter id" AdapterId + + -- | Denotes a place from which we may access the configuration. -- -- During script definition or when handling a request we can obtain the config with 'getConfigVal' or 'requireConfigVal'. @@ -133,9 +309,6 @@ getConfigInternal :: m C.Config -class IsScript m where - getScriptId :: m ScriptId - instance C.Configured LogLevel where convert (C.String s) = case T.strip $ T.toLower s of @@ -146,6 +319,3 @@ _ -> Nothing convert _ = Nothing -class AccessAdapter m where - type AdapterT m - getAdapter :: m (AdapterT m) diff --git a/src/Marvin/Internal/Values.hs b/src/Marvin/Internal/Values.hs new file mode 100644 --- /dev/null +++ b/src/Marvin/Internal/Values.hs @@ -0,0 +1,23 @@ +module Marvin.Internal.Values where + + +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import Marvin.Internal.Types + + +-- | Script id sed for the bot itself +applicationScriptId :: ScriptId +applicationScriptId = ScriptId "bot" + + +defaultBotName :: L.Text +defaultBotName = "marvin" + + +scriptConfigKey :: T.Text +scriptConfigKey = "script" + + +adapterConfigKey :: T.Text +adapterConfigKey = "adapter" diff --git a/src/Marvin/Prelude.hs b/src/Marvin/Prelude.hs --- a/src/Marvin/Prelude.hs +++ b/src/Marvin/Prelude.hs @@ -9,23 +9,23 @@ -} module Marvin.Prelude ( - -- | Common functions and Types for scripts + -- ** Common functions and Types for scripts module Marvin - -- | Mutable references in marvin scripts + -- ** Mutable references in marvin scripts , module Marvin.Util.Mutable - -- | Logging in Scripts + -- ** Logging in Scripts , module Control.Monad.Logger - -- | Random numbers and convenience functions + -- ** Random numbers and convenience functions , module Marvin.Util.Random - -- | Marvins regex type and how to work with it + -- ** Marvins regex type and how to work with it , module Marvin.Util.Regex - -- | Dealing with JSON + -- ** Dealing with JSON , module Marvin.Util.JSON - -- | Interpolated strings a la Scala and CoffeeScript - , isL, isT - -- | Arbitrary IO in scripts + -- ** Interpolated strings a la Scala and CoffeeScript + , isL, isT, isS + -- ** Arbitrary IO in scripts , MonadIO, liftIO - -- | Useful functions not in the normal Prelude + -- ** Useful functions not in the normal Prelude , when, unless, for, for_, fromMaybe ) where @@ -36,6 +36,7 @@ import Data.Maybe (fromMaybe) import Data.Traversable (for) import Marvin +import Marvin.Interpolate.String (isS) import Marvin.Interpolate.Text (isT) import Marvin.Interpolate.Text.Lazy (isL) import Marvin.Util.JSON diff --git a/src/Marvin/Run.hs b/src/Marvin/Run.hs --- a/src/Marvin/Run.hs +++ b/src/Marvin/Run.hs @@ -7,6 +7,7 @@ Stability : experimental Portability : POSIX -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -21,6 +22,7 @@ import Control.Concurrent.Async.Lifted (async, wait) +import Control.DeepSeq import Control.Exception.Lifted import Control.Lens hiding (cons) import Control.Monad.Logger @@ -29,15 +31,16 @@ import qualified Data.Configurator.Types as C import Data.Foldable (for_) import qualified Data.HashMap.Strict as HM -import Data.Maybe (fromMaybe) +import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust) import Data.Monoid ((<>)) -import Data.Sequences import qualified Data.Text.Lazy as L import Data.Traversable (for) import Data.Vector (Vector) +import qualified Data.Vector as V import qualified Marvin.Adapter as A import Marvin.Internal import Marvin.Internal.Types hiding (channel) +import Marvin.Internal.Values import Marvin.Interpolate.Text import Marvin.Util.Regex import Options.Applicative @@ -45,6 +48,9 @@ import Util +vcatMaybes = V.map fromJust . V.filter isJust + + data CmdOptions = CmdOptions { configPath :: Maybe FilePath , verbose :: Bool @@ -52,6 +58,7 @@ } +-- | Default name for the config file defaultConfigName :: FilePath defaultConfigName = "config.cfg" @@ -60,10 +67,12 @@ defaultLoggingLevel = LevelWarn +-- | Retrieve a value from the application config, given the whole config structure. Fails if value not parseable as @a@ or not present. requireFromAppConfig :: C.Configured a => C.Config -> C.Name -> IO a requireFromAppConfig cfg = C.require (C.subconfig (unwrapScriptId applicationScriptId) cfg) +-- | Retrieve a value from the application config, given the whole config structure. Returns 'Nothing' if value not parseable as @a@ or not present. lookupFromAppConfig :: C.Configured a => C.Config -> C.Name -> IO (Maybe a) lookupFromAppConfig cfg = C.lookup (C.subconfig (unwrapScriptId applicationScriptId) cfg) @@ -72,12 +81,12 @@ 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 +mkApp :: forall a. IsAdapter a => LoggingFn -> Handlers a -> C.Config -> a -> EventHandler a +mkApp log handlers cfg adapter = flip runLoggingT log . genericHandler where genericHandler ev = do generics <- async $ do - let applicables = catMaybes $ fmap ($ ev) customsV + let applicables = vcatMaybes $ fmap ($ ev) customsV asyncs <- for applicables async for_ asyncs wait handler ev @@ -118,21 +127,20 @@ mapM_ wait lDispatches where doIfMatch things = - catMaybes <$> for things (\(trigger, action) -> + vcatMaybes <$> for things (\(trigger, action) -> case match trigger msg of Nothing -> return Nothing Just m -> Just <$> async (action (User' user, Channel' chan, m, msg, ts))) handleCommand = handleMessageLike respondsV handleMessage = handleMessageLike hearsV - Handlers respondsV hearsV customsV joinsV leavesV topicsV joinsInV leavesFromV topicsInV = - foldMap (^.actions) scripts + Handlers respondsV hearsV customsV joinsV leavesV topicsV joinsInV leavesFromV topicsInV = handlers 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 + !s <- force . foldMap (^.actions) . catMaybes <$> mapM (\(ScriptInit (sid, s)) -> catch (Just <$> s ada config) (onInitExcept sid)) inits return $ mkApp log s config ada where logSource = $(isT "#{applicationScriptId}.init") @@ -156,13 +164,13 @@ args <- liftIO $ execParser infoParser cfgLoc <- maybe - ($logInfoS $(isT "#{applicationScriptId}") "Using default config: config.cfg" >> return defaultConfigName) + (logInfoNS $(isT "#{applicationScriptId}") $(isT "Using default config: #{defaultConfigName}") >> return defaultConfigName) return (configPath args) (cfg, _) <- liftIO $ C.autoReload C.autoConfig [C.Required cfgLoc] loggingLevelFromCfg <- liftIO $ C.lookup cfg $(isT "#{applicationScriptId}.logging") - let loggingLevel + let !loggingLevel | debug args = LevelDebug | verbose args = LevelInfo | otherwise = fromMaybe defaultLoggingLevel loggingLevelFromCfg diff --git a/src/Marvin/Types.hs b/src/Marvin/Types.hs --- a/src/Marvin/Types.hs +++ b/src/Marvin/Types.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK not-home #-} {-| Module : $Header$ Description : Common types in marvin. @@ -8,10 +9,16 @@ Portability : POSIX -} module Marvin.Types - ( User(..), Channel(..), Message(..), ScriptId(..) + ( User(..), Channel(..), Message(..), Script(..) + , ScriptId, mkScriptId, unwrapScriptId , applicationScriptId, IsScript, getScriptId - , HasConfigAccess + , HasConfigAccess, TimeStamp(..) + , AccessAdapter(AdapterT) + , User'(..), Channel'(..) + , Get(getLens) + , Event(..), RunnerM ) where import Marvin.Internal.Types +import Marvin.Internal.Values diff --git a/src/Marvin/Util/JSON.hs b/src/Marvin/Util/JSON.hs --- a/src/Marvin/Util/JSON.hs +++ b/src/Marvin/Util/JSON.hs @@ -22,9 +22,11 @@ import qualified Data.ByteString.Lazy as B +-- | Read a file containing JSON encoded data readJSON :: (MonadIO m, FromJSON a) => FilePath -> m (Either String a) -readJSON = fmap eitherDecode . liftIO . B.readFile +readJSON = liftIO . fmap eitherDecode . B.readFile +-- | Write some data to a file using JSON serialization writeJSON :: (MonadIO m, ToJSON a) => FilePath -> a -> m () writeJSON fp = liftIO . B.writeFile fp . encode diff --git a/src/Marvin/Util/Mutable.hs b/src/Marvin/Util/Mutable.hs --- a/src/Marvin/Util/Mutable.hs +++ b/src/Marvin/Util/Mutable.hs @@ -52,7 +52,7 @@ -- @ -- val <- takeSynchronized -- obtain the value and leave it empty to block concurrent reads -- let mod = modify val -- modify the value --- writeSynchronized val -- write back the result +-- writeSynchronized mod -- write back the result -- @ -- -- Another use for this type is as a message channel, where we have a producer and a consumer, diff --git a/src/Marvin/Util/Random.hs b/src/Marvin/Util/Random.hs --- a/src/Marvin/Util/Random.hs +++ b/src/Marvin/Util/Random.hs @@ -14,8 +14,6 @@ import Control.Monad.IO.Class -import Data.MonoTraversable -import Data.Sequences import System.Random @@ -35,7 +33,7 @@ -- Uses the global random number generator. -- -- Usable in all IO capable monads, such as 'BotReacting' and 'ScriptDefinition'. -randomFrom :: (IsSequence s, Index s ~ Int, MonadIO m) => s -> m (Element s) +randomFrom :: MonadIO m => [e] -> m e randomFrom list = do - n <- randomValFromRange (0, pred $ olength list) - return $ list `indexEx` n + n <- randomValFromRange (0, pred $ length list) + return $ list !! n diff --git a/src/Marvin/Util/Regex.hs b/src/Marvin/Util/Regex.hs --- a/src/Marvin/Util/Regex.hs +++ b/src/Marvin/Util/Regex.hs @@ -12,15 +12,19 @@ , Re.MatchOption(..) ) where +import Control.DeepSeq import Data.String -import qualified Data.Text.ICU as Re -import qualified Data.Text.Lazy as L +import qualified Data.Text.ICU as Re +import qualified Data.Text.Lazy as L -- | Abstract Wrapper for a reglar expression implementation. Has an 'IsString' implementation, so literal strings can be used to create a 'Regex'. -- Alternatively use 'r' to create one with custom options. newtype Regex = Regex Re.Regex +instance NFData Regex where + rnf (Regex a) = a `seq` () + -- Warning: This exposes the underlying repreentation of a 'Regex' and under no curcumstances should be considered stable. unwrapRegex :: Regex -> Re.Regex unwrapRegex (Regex r) = r @@ -30,7 +34,7 @@ show = show . unwrapRegex --- | A match to a 'Regex'. Index 0 is the full match, all other indexes are match groups. +-- | A match to a 'Regex'. Index 0 is the full match, all other indices are match groups. type Match = [L.Text] -- | Compile a regex with options diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -1,9 +1,13 @@ module Util where -import Control.Monad.Logger +import Control.Monad +import Data.Aeson.Types import qualified Data.Text as T +import Data.Time.Clock.POSIX +import Marvin.Internal.Types import Marvin.Interpolate.Text +import Text.Read (readMaybe) notImplemented :: a @@ -24,4 +28,7 @@ loggingAddSourcePrefix = adaptLoggingSource . addPrefix -type LoggingFn = Loc -> LogSource -> LogLevel -> LogStr -> IO () +timestampFromNumber :: Value -> Parser TimeStamp +timestampFromNumber (Number n) = return $ TimeStamp $ posixSecondsToUTCTime $ realToFrac n +timestampFromNumber (String s) = maybe mzero (return . TimeStamp . posixSecondsToUTCTime . realToFrac) (readMaybe (T.unpack s) :: Maybe Double) +timestampFromNumber _ = mzero