marvin 0.0.9 → 0.1.0
raw patch · 25 files changed
+1481/−1020 lines, 25 filesdep +deepseqdep +http-clientdep +http-client-tlsdep ~marvindep ~marvin-interpolate
Dependencies added: deepseq, http-client, http-client-tls, http-types, warp-tls
Dependency ranges changed: marvin, marvin-interpolate
Files
- marvin.cabal +21/−11
- preprocessor/Main.hs +4/−3
- src/Marvin.hs +5/−6
- src/Marvin/Adapter.hs +17/−11
- src/Marvin/Adapter/Shell.hs +21/−8
- src/Marvin/Adapter/Slack.hs +0/−496
- src/Marvin/Adapter/Slack/Common.hs +294/−0
- src/Marvin/Adapter/Slack/EventsAPI.hs +113/−0
- src/Marvin/Adapter/Slack/RTM.hs +125/−0
- src/Marvin/Adapter/Slack/Types.hs +144/−0
- src/Marvin/Adapter/Telegram.hs +0/−235
- src/Marvin/Adapter/Telegram/Common.hs +224/−0
- src/Marvin/Adapter/Telegram/Poll.hs +77/−0
- src/Marvin/Adapter/Telegram/Push.hs +88/−0
- src/Marvin/Internal.hs +41/−163
- src/Marvin/Internal/Types.hs +222/−52
- src/Marvin/Internal/Values.hs +23/−0
- src/Marvin/Prelude.hs +11/−10
- src/Marvin/Run.hs +19/−11
- src/Marvin/Types.hs +9/−2
- src/Marvin/Util/JSON.hs +3/−1
- src/Marvin/Util/Mutable.hs +1/−1
- src/Marvin/Util/Random.hs +3/−5
- src/Marvin/Util/Regex.hs +7/−3
- src/Util.hs +9/−2
marvin.cabal view
@@ -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,
preprocessor/Main.hs view
@@ -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")) ]
src/Marvin.hs view
@@ -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)
src/Marvin/Adapter.hs view
@@ -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)
src/Marvin/Adapter/Shell.hs view
@@ -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
− src/Marvin/Adapter/Slack.hs
@@ -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-
+ src/Marvin/Adapter/Slack/Common.hs view
@@ -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+
+ src/Marvin/Adapter/Slack/EventsAPI.hs view
@@ -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
+ src/Marvin/Adapter/Slack/RTM.hs view
@@ -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+
+ src/Marvin/Adapter/Slack/Types.hs view
@@ -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+
− src/Marvin/Adapter/Telegram.hs
@@ -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 "<unnamed>" $- 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
+ src/Marvin/Adapter/Telegram/Common.hs view
@@ -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 "<unnamed>" $+ 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
+ src/Marvin/Adapter/Telegram/Poll.hs view
@@ -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
+ src/Marvin/Adapter/Telegram/Push.hs view
@@ -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
src/Marvin/Internal.hs view
@@ -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)
src/Marvin/Internal/Types.hs view
@@ -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)
+ src/Marvin/Internal/Values.hs view
@@ -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"
src/Marvin/Prelude.hs view
@@ -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
src/Marvin/Run.hs view
@@ -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
src/Marvin/Types.hs view
@@ -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
src/Marvin/Util/JSON.hs view
@@ -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
src/Marvin/Util/Mutable.hs view
@@ -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,
src/Marvin/Util/Random.hs view
@@ -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
src/Marvin/Util/Regex.hs view
@@ -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
src/Util.hs view
@@ -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