aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--src/Reaktor.hs236
-rw-r--r--src/Reaktor/Config.hs76
-rw-r--r--src/Reaktor/Message.hs14
-rw-r--r--src/Reaktor/Parser.hs45
-rw-r--r--src/Reaktor/Plugins.hs28
-rw-r--r--src/Reaktor/Plugins/Mention.hs27
-rw-r--r--src/Reaktor/Plugins/NickServ.hs92
-rw-r--r--src/Reaktor/Plugins/Ping.hs15
-rw-r--r--src/Reaktor/Plugins/Register.hs65
-rw-r--r--src/Reaktor/Plugins/System.hs213
-rw-r--r--src/Reaktor/Plugins/System/Types.hs75
-rw-r--r--src/Reaktor/Types.hs68
-rw-r--r--src/Reaktor/Utils.hs37
-rw-r--r--src/main.hs14
14 files changed, 1005 insertions, 0 deletions
diff --git a/src/Reaktor.hs b/src/Reaktor.hs
new file mode 100644
index 0000000..110485f
--- /dev/null
+++ b/src/Reaktor.hs
@@ -0,0 +1,236 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor (run) where
+
+import Blessings (Blessings(Append,Empty,Plain,SGR),pp)
+import Control.Arrow
+import Control.Concurrent (forkIO,killThread,threadDelay)
+import Control.Concurrent (newEmptyMVar,putMVar,takeMVar)
+import Control.Exception (finally)
+import Control.Monad (foldM,forever,unless)
+import Control.Monad.Trans.State.Lazy
+import Data.Aeson
+import Data.Attoparsec.ByteString.Char8 (IResult(Done,Fail,Partial))
+import Data.Attoparsec.ByteString.Char8 (feed,parse)
+import qualified Data.ByteString.Char8 as BS
+import Data.Foldable (toList)
+import qualified Data.Text as T
+import Data.Time.Clock.System
+import Data.Time.Format
+import qualified Network.Simple.TCP as TCP
+import qualified Network.Simple.TCP.TLS as TLS
+import Reaktor.Config
+import Reaktor.Parser (message)
+import qualified Reaktor.Plugins
+import Reaktor.Types
+import System.IO (BufferMode(LineBuffering),hSetBuffering)
+import System.IO (Handle)
+import System.IO (hIsTerminalDevice)
+import System.IO (hPutStr,hPutStrLn,stderr)
+import System.Posix.Signals
+
+
+run :: Config -> IO ()
+run cfg0 = do
+
+ let logh = stderr
+
+ let cfg1 = addPlugin "ping" (Reaktor.Plugins.get "ping" Null) cfg0
+
+ cfg <- initPlugins cfg1
+
+ let tlsPlugins =
+ T.unpack $
+ T.intercalate ", " $
+ map pi_name $
+ filter (requireTLS . either undefined id . pi_plugin)
+ (pluginInstances cfg)
+
+ unless (useTLS cfg || null tlsPlugins) $ do
+ error $ "Not using TLS, but following plugins require it: " <> tlsPlugins
+
+ -- TODO reset when done?
+ hSetBuffering logh LineBuffering
+ logToTTY <- hIsTerminalDevice logh
+ let logFilter = if logToTTY then id else stripSGR
+
+ connect cfg $ \send_ recv_ -> do
+ (putLog, takeLog) <- newRelay
+ (putMsg, takeMsg) <- newRelay
+ (shutdown, awaitShutdown) <- newSemaphore
+
+ mapM_ (\(s, f) -> installHandler s (Catch f) Nothing) [
+ (sigINT, shutdown)
+ ]
+
+ let prefixTimestamp s = do
+ t <- SGR [38,5,239] . Plain . BS.pack <$> getTimestamp
+ return (t <> " " <> s)
+
+ takeLog' =
+ if logTime cfg
+ then takeLog >>= prefixTimestamp
+ else takeLog
+
+ threadIds <- mapM (\f -> forkIO $ f `finally` shutdown) [
+ driver cfg putLog putMsg recv_,
+ logger logFilter takeLog' logh,
+ pinger putLog putMsg,
+ sender takeMsg send_
+ ]
+
+ awaitShutdown
+ mapM_ killThread threadIds
+ hPutStrLn logh ""
+ where
+
+ pinger :: (Blessings BS.ByteString -> IO ()) -> (Message -> IO ()) -> IO ()
+ pinger putLog putMsg = forever $ do
+ threadDelay time
+ sendIO putLog putMsg (Message Nothing "PING" ["heartbeat"])
+ where
+ time = 300 * 1000000
+
+ sender :: IO Message -> (BS.ByteString -> IO ()) -> IO ()
+ sender takeMsg send_ =
+ forever $ takeMsg >>= send_ . formatMessage
+
+ logger :: (Blessings BS.ByteString -> Blessings BS.ByteString)
+ -> IO (Blessings BS.ByteString)
+ -> Handle
+ -> IO ()
+ logger f takeLog h = forever $ do
+ s <- takeLog
+ let s' = if lastChar s == '\n' then s else s <> Plain "\n"
+ hPutStr h $ pp $ fmap BS.unpack (f s')
+ where
+ lastChar :: Blessings BS.ByteString -> Char
+ lastChar = BS.last . last . toList
+
+ stripSGR :: Blessings a -> Blessings a
+ stripSGR = \case
+ Append t1 t2 -> Append (stripSGR t1) (stripSGR t2)
+ SGR _ t -> stripSGR t
+ Plain x -> Plain x
+ Empty -> Empty
+
+
+connect :: Config
+ -> ((BS.ByteString -> IO ()) -> IO (Maybe BS.ByteString) -> IO ())
+ -> IO ()
+connect cfg action = do
+ if useTLS cfg then do
+ s <- TLS.getDefaultClientSettings (hostname cfg, BS.pack (port cfg))
+ TLS.connect s (hostname cfg) (port cfg) $ \(ctx, _sockAddr) -> do
+ let send = TLS.send ctx
+ recv = TLS.recv ctx
+ action send recv
+ else do
+ TCP.connect (hostname cfg) (port cfg) $ \(sock, _sockAddr) -> do
+ let send = TCP.send sock
+ recv = TCP.recv sock 512
+ action send recv
+
+driver :: Config
+ -> (Blessings BS.ByteString -> IO ())
+ -> (Message -> IO ())
+ -> IO (Maybe BS.ByteString)
+ -> IO ()
+
+driver cfg putLog putMsg recv_ = do
+ cfg' <- handleMessage cfg putMsg putLog (Message Nothing "<start>" [])
+ drive cfg' putMsg putLog recv_ ""
+
+drive :: Config
+ -> (Message -> IO ())
+ -> (Blessings BS.ByteString -> IO ())
+ -> IO (Maybe BS.ByteString)
+ -> BS.ByteString
+ -> IO ()
+drive cfg putMsg putLog recv_ "" =
+ recv_ >>= \case
+ Nothing -> putLog $ SGR [34,1] (Plain "# EOL")
+ Just msg -> drive cfg putMsg putLog recv_ msg
+
+drive cfg putMsg putLog recv_ buf =
+ go (parse message buf)
+ where
+ go :: IResult BS.ByteString Message -> IO ()
+ go = \case
+ Done rest msg -> do
+ -- TODO log message only if h hasn't disabled logging for it
+ let s = formatMessage msg
+ putLog $ SGR [38,5,235] "< " <> SGR [38,5,244] (Plain s)
+ cfg' <- handleMessage cfg putMsg putLog msg
+ drive cfg' putMsg putLog recv_ rest
+
+ p@(Partial _) -> do
+ recv_ >>= \case
+ Nothing -> do
+ putLog $ SGR [34,1] (Plain "# EOL")
+ Just msg ->
+ go (feed p msg)
+
+ f@(Fail _i _errorContexts _errMessage) ->
+ putLog $ SGR [31,1] (Plain (BS.pack $ show f))
+
+handleMessage :: Config
+ -> (Message -> IO ())
+ -> (Blessings BS.ByteString -> IO ())
+ -> Message
+ -> IO Config
+handleMessage cfg putMsg putLog msg = do
+ let
+ q0 = PluginState {
+ s_putLog = putLog,
+ s_nick = nick cfg,
+ s_sendMsg = sendIO putLog putMsg,
+ s_sendMsg' = sendIO' putLog putMsg
+ }
+
+ f q i =
+ execStateT (pluginFunc (either undefined id (pi_plugin i)) msg) q
+
+ q' <- foldM f q0 (pluginInstances cfg)
+
+ return cfg { nick = s_nick q' }
+
+
+formatMessage :: Message -> BS.ByteString
+formatMessage (Message mb_prefix cmd params) =
+ maybe "" (\x -> ":" <> x <> " ") mb_prefix
+ <> cmd
+ <> BS.concat (map (" "<>) (init params))
+ <> if null params then "" else " :" <> last params
+ <> "\r\n"
+
+
+getTimestamp :: IO String
+getTimestamp =
+ formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%SZ")
+ . systemToUTCTime <$> getSystemTime
+
+
+newRelay :: IO (a -> IO (), IO a)
+newRelay = (putMVar &&& takeMVar) <$> newEmptyMVar
+
+
+newSemaphore :: IO (IO (), IO ())
+newSemaphore = first ($()) <$> newRelay
+
+
+sendIO :: (Blessings BS.ByteString -> IO ())
+ -> (Message -> IO ())
+ -> Message
+ -> IO ()
+sendIO putLog putMsg msg =
+ sendIO' putLog putMsg msg msg
+
+sendIO' :: (Blessings BS.ByteString -> IO ())
+ -> (Message -> IO ())
+ -> Message
+ -> Message
+ -> IO ()
+sendIO' putLog putMsg msg logMsg = do
+ putLog $ SGR [38,5,235] "> " <> SGR [35,1] (Plain $ formatMessage logMsg)
+ putMsg msg
diff --git a/src/Reaktor/Config.hs b/src/Reaktor/Config.hs
new file mode 100644
index 0000000..8330be9
--- /dev/null
+++ b/src/Reaktor/Config.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor.Config where
+
+import Data.Aeson
+import qualified Data.HashMap.Lazy as HML
+import qualified Data.Text as T
+import qualified Reaktor.Plugins
+import Reaktor.Types
+
+
+instance FromJSON Config where
+ parseJSON (Object v) = do
+ p <- v .:? "port" .!= defaultPort
+
+ Config
+ <$> v .: "hostname"
+ <*> pure p
+ <*> v .: "nick"
+ <*> v .:? "useTLS" .!= (p == tlsPort)
+ <*> v .:? "logTime" .!= True
+ <*> v .:? "plugins" .!= []
+ parseJSON _ = pure undefined
+
+
+data Config = Config {
+ hostname :: HostName,
+ port :: ServiceName,
+ nick :: Nickname,
+ useTLS :: Bool,
+ logTime :: Bool,
+ pluginInstances :: [PluginInstance]
+ }
+
+
+addPlugin :: T.Text -> IO Plugin -> Config -> Config
+addPlugin name p r =
+ r { pluginInstances = pluginInstances r <> [PluginInstance name (Left p)] }
+
+
+defaultPort :: ServiceName
+defaultPort = tlsPort
+
+tlsPort :: ServiceName
+tlsPort = "6697"
+
+
+data PluginInstance = PluginInstance {
+ pi_name :: T.Text,
+ pi_plugin :: Either (IO Plugin) Plugin
+ }
+
+instance FromJSON PluginInstance where
+ parseJSON o@(Object v) =
+ case HML.lookup "plugin" v of
+ Just (String name) -> do
+ let p = Reaktor.Plugins.get name
+ c = HML.lookupDefault (Object HML.empty) "config" v
+ pure $ PluginInstance name (Left $ p c)
+ Just _ -> error ("bad plugin object: " <> show o)
+ _ -> error ("mising 'plugin' attribute: " <> show o)
+ parseJSON x =
+ error ("bad plugin type: " <> show x)
+
+
+initPlugins :: Config -> IO Config
+initPlugins cfg = do
+ plugins' <- mapM initPlugin (pluginInstances cfg)
+ return cfg { pluginInstances = plugins' }
+ where
+ initPlugin :: PluginInstance -> IO PluginInstance
+ initPlugin i = do
+ p <-
+ case pi_plugin i of
+ Right p -> return p
+ Left f -> f
+ return i { pi_plugin = Right p }
diff --git a/src/Reaktor/Message.hs b/src/Reaktor/Message.hs
new file mode 100644
index 0000000..f929471
--- /dev/null
+++ b/src/Reaktor/Message.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor.Message where
+
+import qualified Data.ByteString.Char8 as BS
+import Reaktor.Types
+
+
+privmsg :: BS.ByteString -> [BS.ByteString] -> Message
+privmsg msgtarget xs =
+ Message Nothing "PRIVMSG" (msgtarget:BS.intercalate " " xs:[])
+
+notice :: BS.ByteString -> [BS.ByteString] -> Message
+notice msgtarget xs =
+ Message Nothing "NOTICE" (msgtarget:BS.intercalate " " xs:[])
diff --git a/src/Reaktor/Parser.hs b/src/Reaktor/Parser.hs
new file mode 100644
index 0000000..bdd2f98
--- /dev/null
+++ b/src/Reaktor/Parser.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor.Parser where
+
+import Control.Applicative
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Char
+import Reaktor.Types
+
+
+prefix :: Parser Prefix
+prefix = BS.pack <$> many (satisfy Data.Char.isAlphaNum <|>
+ satisfy (flip elem (":.-@/!~[]\\`_^{|}" :: String)))
+
+command :: Parser Command
+command = BS.pack <$> many1 (satisfy Data.Char.isAlphaNum)
+
+nospcrlfcl :: Parser Char
+nospcrlfcl =
+ satisfy (flip notElem ("\NUL\CR\LF :" :: String)) <?> "nospcrlfcl"
+
+middle :: Parser Param
+middle =
+ BS.pack <$> ((:) <$> nospcrlfcl <*> many (char ':' <|> nospcrlfcl))
+ <?> "middle"
+
+trailing :: Parser Param
+trailing =
+ BS.pack <$> many (char ':' <|> char ' ' <|> nospcrlfcl)
+ <?> "trailing"
+
+params :: Parser [Param]
+params = (do
+ a <- many (char ' ' *> middle)
+ b <- optional (char ' ' *> char ':' *> trailing)
+ return $ a <> (maybe [] (:[]) b))
+ <?> "params"
+
+message :: Parser Message
+message =
+ Message
+ <$> optional (char ':' *> prefix <* char ' ')
+ <*> command
+ <*> params
+ <* string "\r\n"
diff --git a/src/Reaktor/Plugins.hs b/src/Reaktor/Plugins.hs
new file mode 100644
index 0000000..83677bb
--- /dev/null
+++ b/src/Reaktor/Plugins.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor.Plugins (get,registry) where
+
+import Data.Aeson (Value)
+import qualified Data.Map as M
+import qualified Data.Text as T
+import qualified Reaktor.Plugins.Mention
+import qualified Reaktor.Plugins.NickServ
+import qualified Reaktor.Plugins.Ping
+import qualified Reaktor.Plugins.Register
+import qualified Reaktor.Plugins.System
+import Reaktor.Types (Plugin)
+
+
+get :: T.Text -> Value -> IO Plugin
+get name =
+ case M.lookup name registry of
+ Just p -> p
+ Nothing -> error ("unknown plugin: " <> T.unpack name)
+
+registry :: M.Map T.Text (Value -> IO Plugin)
+registry = M.fromList [
+ ("mention", Reaktor.Plugins.Mention.plugin),
+ ("NickServ", Reaktor.Plugins.NickServ.plugin),
+ ("ping", Reaktor.Plugins.Ping.plugin),
+ ("register", Reaktor.Plugins.Register.plugin),
+ ("system", Reaktor.Plugins.System.plugin)
+ ]
diff --git a/src/Reaktor/Plugins/Mention.hs b/src/Reaktor/Plugins/Mention.hs
new file mode 100644
index 0000000..0c86d74
--- /dev/null
+++ b/src/Reaktor/Plugins/Mention.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor.Plugins.Mention (plugin) where
+
+import Control.Monad (when)
+import Data.Aeson
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Char
+import Reaktor.Message
+import Reaktor.Types
+
+
+plugin :: Value -> IO Plugin
+plugin _ = return (Plugin run False)
+
+
+run :: PluginFunc
+run = \case
+ Message _ "PRIVMSG" (msgtarget:text:[]) -> do
+ nick <- getNick
+ when (isMention nick text) $ do
+ sendMsg (privmsg msgtarget ["I'm famous!"])
+ _ -> return ()
+ where
+ isMention nick text =
+ not (BS.isPrefixOf (nick <> ":") text) &&
+ any (==nick) (BS.splitWith (not . Data.Char.isAlphaNum) text)
diff --git a/src/Reaktor/Plugins/NickServ.hs b/src/Reaktor/Plugins/NickServ.hs
new file mode 100644
index 0000000..3987774
--- /dev/null
+++ b/src/Reaktor/Plugins/NickServ.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor.Plugins.NickServ (plugin) where
+
+import Control.Monad (when)
+import Data.Aeson
+import Data.Aeson.Types (parseEither)
+import qualified Data.ByteString.Char8 as BS
+import GHC.Generics
+import Reaktor.Message
+import Reaktor.Types
+import Reaktor.Utils (randomNick)
+
+
+data NickServConfig = NickServConfig {
+ passFile :: FilePath,
+ prefix :: BS.ByteString,
+ channels :: [BS.ByteString]
+ }
+ deriving (FromJSON,Generic)
+
+
+plugin :: Value -> IO Plugin
+plugin v =
+ case parseEither parseJSON v of
+ Right cfg -> do
+ pass <- do
+ [pass] <- lines <$> readFile (passFile cfg)
+ return (BS.pack pass)
+
+ return $ Plugin (run pass cfg) True
+ Left err ->
+ error err
+
+
+run :: BS.ByteString -> NickServConfig -> PluginFunc
+run pass cfg msg = do
+ nick_ <- getNick
+ case msg of
+
+ Message _ "<start>" _ -> do
+ nick0 <- lift randomNick
+ sendMsg (Message Nothing "NICK" [nick0])
+ sendMsg (Message Nothing "USER" [nick_, "*", "0", nick_])
+
+ -- TODO structured prefix, and check just for "NickServ"
+ Message (Just _prefix@"NickServ!NickServ@services.")
+ "NOTICE"
+ (_msgtarget:text:[]) -> do
+ if
+ | text == "You are now identified for \STX" <> nick_ <> "\STX." -> do
+ sendMsg (Message Nothing "NICK" [nick_])
+ | text == "\STX" <> nick_ <> "\STX has been released." -> do
+ sendMsg (Message Nothing "NICK" [nick_])
+ | text == "Invalid password for \STX" <> nick_ <> "\STX." -> do
+ error (BS.unpack text)
+ | text == "\STX" <> nick_ <> "\STX is not a registered nickname." -> do
+ error (BS.unpack text)
+ | otherwise ->
+ return ()
+
+
+ Message (Just _self) "NICK" (newnick:[]) -> do
+ when (newnick == nick_) $ do
+ -- TODO JOIN only if not already joined
+ -- i.e. not during subsequent nick changes
+ sendMsg (Message Nothing "JOIN" [ BS.intercalate "," (channels cfg) ])
+
+
+ -- RFC1459 ERR_NICKNAMEINUSE
+ Message (Just _servername) "433" (_msgtarget:nickinuse:_reason:[]) -> do
+ if nickinuse == nick_
+ then do
+ sendMsg (privmsg "NickServ" ["RELEASE", nickinuse])
+ else do
+ nick0 <- lift randomNick
+ sendMsg (Message Nothing "NICK" [nick0])
+
+ --RFC2812 ERR_UNAVAILRESOURCE
+ Message (Just _servername) "437" (_msgtarget:nickunavail:_reason:[]) -> do
+ when (nickunavail == nick_) $ do
+ sendMsg (privmsg "NickServ" ["RELEASE", nickunavail])
+
+ --RFC2812 RPL_WELCOME
+ Message _ "001" [_nick,_s] -> do
+ sendMsg' (privmsg "NickServ" ["IDENTIFY", nick_, pass])
+ (privmsg "NickServ" ["IDENTIFY", nick_, "<password>"])
+
+
+ _ -> return ()
diff --git a/src/Reaktor/Plugins/Ping.hs b/src/Reaktor/Plugins/Ping.hs
new file mode 100644
index 0000000..83b3ac4
--- /dev/null
+++ b/src/Reaktor/Plugins/Ping.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor.Plugins.Ping (plugin) where
+
+import Control.Monad (when)
+import Data.Aeson (Value(Null))
+import Reaktor.Types
+
+
+plugin :: Value -> IO Plugin
+plugin = simplePlugin (\Null -> run)
+
+run :: PluginFunc
+run (Message _ ircCommand args) =
+ when (ircCommand == "PING") $
+ sendMsg (Message Nothing "PONG" args)
diff --git a/src/Reaktor/Plugins/Register.hs b/src/Reaktor/Plugins/Register.hs
new file mode 100644
index 0000000..fd17f48
--- /dev/null
+++ b/src/Reaktor/Plugins/Register.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor.Plugins.Register (plugin) where
+
+import Control.Monad (when)
+import Data.Aeson
+import qualified Data.ByteString.Char8 as BS
+import GHC.Generics
+import Reaktor.Types
+import Reaktor.Utils (nextNick,randomNick)
+
+
+data RegisterConfig = RegisterConfig {
+ channels :: [BS.ByteString]
+ }
+ deriving (FromJSON,Generic)
+
+
+plugin :: Value -> IO Plugin
+plugin = simplePlugin run
+
+
+run :: RegisterConfig -> PluginFunc
+run cfg msg = do
+ nick_ <- getNick
+ case msg of
+
+ Message _ "<start>" _ -> do
+ sendMsg (Message Nothing "NICK" [nick_])
+ sendMsg (Message Nothing "USER" [nick_, "*", "0", nick_])
+
+ Message (Just _self) "NICK" (newnick:[]) -> do
+ when (newnick == nick_) $ do
+ -- TODO JOIN only if not already joined
+ -- i.e. not during subsequent nick changes
+ sendMsg (Message Nothing "JOIN" [ BS.intercalate "," (channels cfg) ])
+
+ -- RFC1459 ERR_NICKNAMEINUSE
+ Message (Just _servername) "433" (_msgtarget:nickinuse:_reason:[]) -> do
+ if nickinuse == nick_ then do
+ let nick' = nextNick nickinuse
+ sendMsg (Message Nothing "NICK" [nick'])
+ -- TODO change state on "NICK"
+ setNick nick'
+
+ -- TODO is this just for NickServ? (also check that module if it has
+ -- stuff only for "Register")
+ else do
+ nick' <- lift randomNick
+ sendMsg (Message Nothing "NICK" [nick'])
+ -- TODO set nick on "NICK" message
+ setNick nick'
+
+ -- RFC2812 ERR_UNAVAILRESOURCE
+ --Message (Just _servername) "437" (_msgtarget:nickunavail:_reason:[]) -> do
+
+ -- RFC2812 RPL_WELCOME
+ Message _ "001" [_nick,_s] -> do
+ --logStrLn $ SGR [32,1] (Plain s)
+ sendMsg (Message Nothing "JOIN" [ BS.intercalate "," (channels cfg) ])
+
+
+ _ -> return ()
diff --git a/src/Reaktor/Plugins/System.hs b/src/Reaktor/Plugins/System.hs
new file mode 100644
index 0000000..c8d40be
--- /dev/null
+++ b/src/Reaktor/Plugins/System.hs
@@ -0,0 +1,213 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor.Plugins.System (plugin) where
+
+import Blessings
+import Control.Applicative
+import Control.Concurrent (forkIO)
+import Control.Exception (finally)
+import Data.Aeson
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Map as M
+import Reaktor.Message
+import Reaktor.Plugins.System.Types
+import Reaktor.Types
+import System.Environment (getEnvironment)
+import System.FilePath.Posix (takeBaseName)
+import System.IO (Handle,hClose,hPutStr,hIsEOF)
+import System.IO (BufferMode(LineBuffering),hSetBuffering)
+import System.Process (StdStream(CreatePipe),waitForProcess)
+import System.Process (createProcess,CreateProcess(..),proc)
+import qualified Text.Regex.PCRE.Heavy as RE
+import qualified Text.Regex.PCRE.Light as RE
+
+
+plugin :: Value -> IO Plugin
+plugin = simplePlugin run
+
+
+-- TODO indicated whether other plugins should run
+run :: SystemConfig -> PluginFunc
+
+run cfg (Message (Just prefix) "PRIVMSG" (msgtarget:text:[])) = do
+ nick_ <- getNick
+ let hs = maybe [] id (M.lookup "PRIVMSG" (hooks cfg))
+ mapM_ (\h -> run1 cfg nick_ h prefix msgtarget text) hs
+
+run cfg (Message (Just prefix) "JOIN" (channel:[])) = do
+ nick_ <- getNick
+ let hs = maybe [] id (M.lookup "JOIN" (hooks cfg))
+ mapM_ (\h -> run1 cfg nick_ h prefix channel "") hs
+
+-- TODO warning?
+run _ _ = return ()
+
+
+run1 ::
+ SystemConfig
+ -> Nickname
+ -> SystemParams
+ -> BS.ByteString
+ -> BS.ByteString
+ -> BS.ByteString
+ -> PluginIO ()
+run1 cfg nick_ params prefix msgtarget text = do
+ let
+ isActivated =
+ case activate params of
+ Always -> Just ""
+ Match ->
+ case pattern params of
+ Nothing -> Nothing
+ Just pat ->
+ let
+ result = RE.scan patternRE text
+ patternRE = RE.compile pat []
+ in
+ if null result
+ then Nothing
+ else Just ""
+ Query ->
+ if
+ | BS.isPrefixOf (nick_ <> ":") text ->
+ Just (nick_ <> ":")
+ | BS.isPrefixOf "*:" text ->
+ Just "*:"
+ | isQuery ->
+ Just ""
+ | otherwise ->
+ Nothing
+
+ audience = if isQuery then from else msgtarget
+
+ -- TODO check if msgtarget is one of our channels?
+ -- what if our nick has changed?
+ isQuery = msgtarget == nick_
+
+ from = BS.takeWhile (/='!') prefix
+ --maybe prefix (flip BS.take prefix) $ BS.findIndex (=='!') prefix
+ case isActivated of
+ Just trigger -> do
+ let cmdline = BS.dropWhile (==' ') $ BS.drop (BS.length trigger) text
+ resultPrefix = if isQuery then [] else [from <> ":"]
+
+ parseCommandLine' pat s =
+ if null result then [] else snd (head result)
+ where
+ result = RE.scan patternRE s
+ patternRE = RE.compile pat []
+
+ parse' =
+ case pattern params of
+ Nothing -> [] -- TODO everything
+ Just pat -> parseCommandLine' pat cmdline
+
+ headMaybe x = if null x then Nothing else Just (head x)
+
+ -- TODO rename "command" to something like "commandSpec"
+ command' = case command params of
+ Capture i ->
+ case headMaybe (drop (fromIntegral i - 1) parse') of
+ Nothing -> Nothing
+ Just k -> M.lookup k (commands params)
+
+ CaptureOr c -> Just c
+
+ cmdName = case command params of
+ Capture i ->
+ case headMaybe (drop (fromIntegral i - 1) parse') of
+ Nothing -> "<CMDERP>"
+ Just k -> k
+
+ CaptureOr c -> BS.pack (takeBaseName $ commandPath c)
+
+ args' =
+ map BS.unpack $
+ map (maybe "" id) $
+ reverse $
+ dropWhile (==Nothing) $
+ reverse $
+ map f (arguments params)
+ where
+ f arg = case arg of
+ Capture i ->
+ case headMaybe (drop (fromIntegral i - 1) parse') of
+ Nothing -> Nothing
+ Just k -> Just k
+
+ CaptureOr x -> Just x
+
+ case command' of
+ Just c -> do
+ sendMsg_ <- gets s_sendMsg
+ putLog_ <- gets s_putLog
+ let onErrLine s =
+ putLog_ $ SGR [31,1] $
+ Plain (BS.pack (takeBaseName $ commandPath c) <> ": "<> s)
+
+ onOutLine s =
+ sendMsg_ (privmsg audience [s])
+
+ extraEnv = [("_prefix", BS.unpack prefix),
+ ("_from", BS.unpack from)]
+
+ lift $ fork cfg c args' (Just extraEnv) "" onOutLine onErrLine
+
+ Nothing -> do
+ sendMsg (privmsg audience (resultPrefix <> [cmdName <> ": command not found"]))
+
+ Nothing -> return ()
+
+
+
+fork :: SystemConfig
+ -> SystemCommand
+ -> [String]
+ -> Maybe [(String, String)]
+ -> String
+ -> (BS.ByteString -> IO ())
+ -> (BS.ByteString -> IO ())
+ -> IO ()
+fork cfg cmd args extraEnv input onOutLine onErrLine = do
+
+ baseEnv <- getEnvironment
+
+ let procEnv = M.toList $ mconcat [
+ maybe mempty M.fromList extraEnv,
+ maybe mempty id (commandEnv cmd),
+ M.fromList baseEnv
+ ]
+
+ (inh, outh, errh) <- do
+ (Just inh, Just outh, Just errh, ph) <-
+ createProcess (proc (commandPath cmd) args) {
+ cwd = commandWorkDir cmd <|> defaultWorkDir cfg,
+ env = Just procEnv,
+ std_in = CreatePipe,
+ std_out = CreatePipe,
+ std_err = CreatePipe,
+ close_fds = True,
+ create_group = True,
+ new_session = True
+ }
+ _ <- forkIO $ waitForProcess ph >> return ()
+ return (inh, outh, errh)
+
+ mapM_ forkIO [
+ hPutStr inh input `finally` hClose inh,
+ hWithLines outh onOutLine,
+ hWithLines errh onErrLine
+ ]
+
+
+hWithLines :: Handle -> (BS.ByteString -> IO ()) -> IO ()
+hWithLines h f = do
+ hSetBuffering h LineBuffering
+ go `finally` hClose h
+ where
+ go =
+ hIsEOF h >>= \case
+ True -> return ()
+ False -> BS.hGetLine h >>= f >> go
diff --git a/src/Reaktor/Plugins/System/Types.hs b/src/Reaktor/Plugins/System/Types.hs
new file mode 100644
index 0000000..48ec51a
--- /dev/null
+++ b/src/Reaktor/Plugins/System/Types.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Reaktor.Plugins.System.Types where
+
+import Data.Aeson
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Map as M
+import Reaktor.Types ()
+
+
+-- TODO this needs better names :)
+data CaptureOr a = Capture Integer | CaptureOr a
+ deriving Show -- TODO killme
+
+instance FromJSON a => FromJSON (CaptureOr a) where
+ parseJSON o@(Number _) = Capture <$> parseJSON o -- TODO don't parse twice
+ parseJSON o = CaptureOr <$> parseJSON o
+
+-- TODO query means via direct privmsg and <nick>:
+data Activate = Always | Match | Query
+
+instance FromJSON Activate where
+ parseJSON (String "always") = pure Always
+ parseJSON (String "match") = pure Match
+ parseJSON (String "query") = pure Query
+ parseJSON _ = undefined
+
+data SystemConfig = SystemConfig {
+ defaultWorkDir :: Maybe FilePath,
+ -- TODO IrcCommand as key for map
+ hooks :: M.Map BS.ByteString [SystemParams]
+}
+
+instance FromJSON SystemConfig where
+ parseJSON (Object v) =
+ SystemConfig
+ <$> v .:? "workdir"
+ <*> v .:? "hooks" .!= M.empty
+ parseJSON _ = pure undefined
+
+data SystemParams = SystemParams {
+ activate :: Activate,
+ pattern :: Maybe BS.ByteString, -- TODO RE
+ command :: CaptureOr SystemCommand,
+ arguments :: [CaptureOr BS.ByteString],
+ workDir :: Maybe FilePath,
+ commands :: M.Map BS.ByteString SystemCommand
+}
+
+instance FromJSON SystemParams where
+ parseJSON (Object v) =
+ SystemParams
+ <$> v .:? "activate" .!= Query
+ <*> v .:? "pattern"
+ <*> v .: "command"
+ <*> v .:? "arguments" .!= []
+ <*> v .:? "workdir"
+ <*> v .:? "commands" .!= M.empty
+ parseJSON _ = pure undefined
+
+
+data SystemCommand = SystemCommand {
+ commandPath :: FilePath,
+ commandWorkDir :: Maybe FilePath,
+ commandEnv :: Maybe (M.Map String String)
+ }
+ deriving Show -- TODO killme
+
+instance FromJSON SystemCommand where
+ parseJSON (Object v) =
+ SystemCommand
+ <$> v .: "filename"
+ <*> v .:? "workdir"
+ <*> v .:? "env"
+ parseJSON _ = pure undefined
+
diff --git a/src/Reaktor/Types.hs b/src/Reaktor/Types.hs
new file mode 100644
index 0000000..f2115be
--- /dev/null
+++ b/src/Reaktor/Types.hs
@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Reaktor.Types (module Reaktor.Types, module X) where
+
+import Blessings (Blessings)
+import Control.Monad.Trans.Class as X (lift)
+import Control.Monad.Trans.State as X (gets,modify)
+import Control.Monad.Trans.State (StateT)
+import Data.Aeson
+import Data.Aeson.Types
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Text.Encoding as T
+import Network.Socket as X (HostName,ServiceName)
+
+
+type Prefix = BS.ByteString
+
+type Nickname = BS.ByteString
+type Password = BS.ByteString
+type MsgTarget = BS.ByteString
+type Channel = MsgTarget
+
+data PluginState = PluginState {
+ s_putLog :: Blessings BS.ByteString -> IO (),
+ s_nick :: BS.ByteString,
+ s_sendMsg :: Message -> IO (),
+ s_sendMsg' :: Message -> Message -> IO ()
+ }
+
+setNick :: Nickname -> PluginIO ()
+setNick newnick = modify (\q -> q { s_nick = newnick })
+
+getNick :: PluginIO Nickname
+getNick = gets s_nick
+
+sendMsg :: Message -> PluginIO ()
+sendMsg msg = gets s_sendMsg >>= \f -> lift $ f msg
+
+sendMsg' :: Message -> Message -> PluginIO ()
+sendMsg' msg logMsg = gets s_sendMsg' >>= \f -> lift $ f msg logMsg
+
+
+type PluginIO = StateT PluginState IO
+
+type PluginFunc = Message -> PluginIO ()
+
+data Plugin = Plugin {
+ pluginFunc :: PluginFunc,
+ requireTLS :: Bool
+ }
+
+simplePlugin :: FromJSON a => (a -> PluginFunc) -> Value -> IO Plugin
+simplePlugin f v =
+ either error (\x -> return $ Plugin (f x) False) (parseEither parseJSON v)
+
+
+type Param = BS.ByteString
+type Command = BS.ByteString
+data Message = Message (Maybe Prefix) Command [Param]
+ deriving Show
+
+
+instance FromJSON BS.ByteString where
+ parseJSON (String t) = pure (T.encodeUtf8 t)
+ parseJSON _ = pure undefined
+
+instance FromJSONKey B