From d40815fd56bf1895af89b72b1171675a2e0ae5f7 Mon Sep 17 00:00:00 2001 From: tv Date: Wed, 23 Jan 2019 00:02:42 +0100 Subject: src: use more simple functions --- reaktor2.cabal | 6 +- src/Control/Concurrent/Extended.hs | 24 +++ src/Prelude/Extended.hs | 8 + src/Reaktor.hs | 355 ++++++++++++++------------------- src/Reaktor/Config.hs | 76 ------- src/Reaktor/Internal.hs | 102 +++++----- src/Reaktor/Message.hs | 14 -- src/Reaktor/Nick.hs | 44 ++++ src/Reaktor/Parser.hs | 20 +- src/Reaktor/Plugins.hs | 28 --- src/Reaktor/Plugins/Mention.hs | 28 ++- src/Reaktor/Plugins/NickServ.hs | 92 --------- src/Reaktor/Plugins/Ping.hs | 28 +-- src/Reaktor/Plugins/Register.hs | 188 ++++++++++++----- src/Reaktor/Plugins/System.hs | 101 +++++----- src/Reaktor/Plugins/System/Internal.hs | 18 +- src/Reaktor/Utils.hs | 37 ---- src/main.hs | 46 ++++- 18 files changed, 561 insertions(+), 654 deletions(-) create mode 100644 src/Control/Concurrent/Extended.hs create mode 100644 src/Prelude/Extended.hs delete mode 100644 src/Reaktor/Config.hs delete mode 100644 src/Reaktor/Message.hs create mode 100644 src/Reaktor/Nick.hs delete mode 100644 src/Reaktor/Plugins.hs delete mode 100644 src/Reaktor/Plugins/NickServ.hs delete mode 100644 src/Reaktor/Utils.hs diff --git a/reaktor2.cabal b/reaktor2.cabal index 3ce81c4..72a3b34 100644 --- a/reaktor2.cabal +++ b/reaktor2.cabal @@ -1,5 +1,5 @@ name: reaktor2 -version: 0.0.0 +version: 0.1.0 license: MIT author: tv maintainer: tv @@ -14,7 +14,10 @@ executable reaktor blessings, bytestring, containers, + data-default, filepath, + lens, + lens-aeson, network, network-simple, network-simple-tls, @@ -25,6 +28,7 @@ executable reaktor text, time, transformers, + unagi-chan, unix, unordered-containers default-language: Haskell2010 diff --git a/src/Control/Concurrent/Extended.hs b/src/Control/Concurrent/Extended.hs new file mode 100644 index 0000000..933e3a6 --- /dev/null +++ b/src/Control/Concurrent/Extended.hs @@ -0,0 +1,24 @@ +module Control.Concurrent.Extended + ( module Exports + , newChan + , newRef + , newRelay + , newSemaphore + ) where + +import Control.Arrow +import Control.Concurrent as Exports hiding (newChan,readChan,writeChan) +import qualified Control.Concurrent.Chan.Unagi as U +import Data.IORef + +newChan :: IO (a -> IO (), IO a) +newChan = (U.writeChan *** U.readChan) <$> U.newChan + +newRef :: a -> IO (a -> IO (), IO a) +newRef v0 = (atomicWriteIORef &&& readIORef) <$> newIORef v0 + +newRelay :: IO (a -> IO (), IO a) +newRelay = (putMVar &&& takeMVar) <$> newEmptyMVar + +newSemaphore :: IO (IO (), IO ()) +newSemaphore = first ($()) <$> newRelay diff --git a/src/Prelude/Extended.hs b/src/Prelude/Extended.hs new file mode 100644 index 0000000..5885033 --- /dev/null +++ b/src/Prelude/Extended.hs @@ -0,0 +1,8 @@ +module Prelude.Extended + ( module Exports + ) where + +import Control.Monad as Exports (forever,unless,when) +import Data.Default as Exports (Default,def) +import Data.Maybe as Exports (fromMaybe,isJust) +import Prelude as Exports diff --git a/src/Reaktor.hs b/src/Reaktor.hs index fd943c7..2d3e7f5 100644 --- a/src/Reaktor.hs +++ b/src/Reaktor.hs @@ -1,236 +1,171 @@ {-# 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.Extended as BS -import Data.Foldable (toList) -import qualified Data.Text as T -import Data.Time.Clock.System -import Data.Time.Format +{-# LANGUAGE RecordWildCards #-} +module Reaktor + ( module Exports + , privmsg + , run + ) where + +import Blessings +import Control.Concurrent.Extended +import Control.Exception +import Data.Attoparsec.ByteString.Char8 +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Foldable (toList) +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.Internal -import Reaktor.Parser (message) -import qualified Reaktor.Plugins -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 +import Network.Socket as Exports (HostName,ServiceName) +import Prelude.Extended +import Reaktor.Internal +import Reaktor.Internal as Exports (Actions(..)) +import Reaktor.Internal as Exports (Message(Message,Start)) +import Reaktor.Internal as Exports (formatMessage) +import Reaktor.Nick as Exports +import Reaktor.Nick as Nick +import qualified Reaktor.Parser as Parser +import qualified System.IO +import System.IO (BufferMode(LineBuffering),hSetBuffering) +import System.IO (hIsTerminalDevice) +import System.Posix.Signals + + +run :: Config -> (Actions -> IO [Message -> IO ()]) -> IO () +run Config{..} getPlugins = + if cUseTLS then do + s <- TLS.getDefaultClientSettings (cHostName, BS.pack cServiceName) + TLS.connect s cHostName cServiceName $ \(ctx, sockAddr) -> + withSocket sockAddr (TLS.send ctx) (TLS.recv ctx) + else do + TCP.connect cHostName cServiceName $ \(sock, sockAddr) -> + withSocket sockAddr (TCP.send sock) (TCP.recv sock 512) + where + withSocket _sockAddr sockSend sockRecv = do + + hSetBuffering cLogHandle LineBuffering -- TODO reset + logToTTY <- hIsTerminalDevice cLogHandle + (putLog, takeLog0) <- newChan + let + takeLog1 = if cLogTime then takeLog0 >>= prefixTimestamp else takeLog0 + takeLog2 = if logToTTY then takeLog1 else stripSGR <$> takeLog1 + takeLog = takeLog2 + + (putInMsg, takeInMsg) <- newChan + (putOutMsg, takeOutMsg) <- newChan (shutdown, awaitShutdown) <- newSemaphore + (aSetNick,aGetNick) <- newRef =<< maybe Nick.getRandom return cNick + + let actions = Actions{..} + aIsSecure = cUseTLS + aLog = putLog + aLogMsg msg = do + let bs = formatMessage msg + putLog $ SGR [38,5,235] "> " <> SGR [35,1] (Plain bs) + aSendQuiet = putOutMsg + aSend msg = aLogMsg msg >> aSendQuiet msg 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) + plugins <- getPlugins actions - 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_ + threads <- mapM (\f -> forkIO $ f `finally` shutdown) [ + receiver actions putInMsg sockRecv, + logger cLogHandle takeLog, + pinger aSend, + sender takeOutMsg sockSend, + splitter plugins takeInMsg ] + putInMsg Start + awaitShutdown - mapM_ killThread threadIds - hPutStrLn logh "" + mapM_ killThread threads + putStrLn "" + + +logger :: System.IO.Handle -> IO (Blessings ByteString) -> IO () +logger h takeLog = forever $ do + s <- takeLog + let s' = if lastChar s == '\n' then s else s <> Plain "\n" + System.IO.hPutStr h $ pp $ fmap BS.unpack s' + +pinger :: (Message -> IO ()) -> IO () +pinger aSend = forever $ do + threadDelay time + aSend (Message Nothing "PING" ["heartbeat"]) where + time = 300 * 1000000 - 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 "" []) - 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) +receiver :: Actions -> (Message -> IO ()) -> IO (Maybe ByteString) -> IO () +receiver Actions{..} putInMsg sockRecv = + receive "" 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" + receive "" = + sockRecv >>= \case + Nothing -> do + aLog $ SGR [34,1] (Plain "# EOL") + Just buf -> receive buf + + receive buf = + go (parse Parser.message buf) + where + go :: IResult ByteString Message -> IO () + go = \case + Done rest msg -> do + -- TODO log message only if h hasn't disabled logging for it + let bs = formatMessage msg + aLog $ SGR [38,5,235] "< " <> SGR [38,5,244] (Plain bs) + putInMsg msg + receive rest + p@(Partial _) -> do + sockRecv >>= \case + Nothing -> do + aLog $ SGR [31] (Plain "EOF") + Just msg -> + go (feed p msg) + + f@(Fail _i _errorContexts _errMessage) -> do + aLog $ SGR [31,1] (Plain (BS.pack $ show f)) + +sender :: IO Message -> (ByteString -> IO ()) -> IO () +sender takeOutMsg sockSend = + forever $ takeOutMsg >>= sockSend . formatMessage + +splitter :: [Message -> IO ()] -> IO Message -> IO () +splitter plugins takeInMsg = + forever $ do + msg <- takeInMsg + mapM_ (\f -> forkIO (f msg)) plugins -getTimestamp :: IO String -getTimestamp = - formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%SZ") - . systemToUTCTime <$> getSystemTime +privmsg :: ByteString -> [ByteString] -> Message +privmsg msgtarget xs = + Message Nothing "PRIVMSG" (msgtarget:BS.intercalate " " xs:[]) -newRelay :: IO (a -> IO (), IO a) -newRelay = (putMVar &&& takeMVar) <$> newEmptyMVar +lastChar :: Blessings ByteString -> Char +lastChar = BS.last . last . toList -newSemaphore :: IO (IO (), IO ()) -newSemaphore = first ($()) <$> newRelay +prefixTimestamp :: Blessings ByteString -> IO (Blessings ByteString) +prefixTimestamp s = do + t <- SGR [38,5,239] . Plain . BS.pack <$> getTimestamp + return (t <> " " <> s) +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 -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 +getTimestamp :: IO String +getTimestamp = + formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%SZ") + . systemToUTCTime <$> getSystemTime diff --git a/src/Reaktor/Config.hs b/src/Reaktor/Config.hs deleted file mode 100644 index 908f9a8..0000000 --- a/src/Reaktor/Config.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Reaktor.Config where - -import Data.Aeson -import qualified Data.HashMap.Lazy as HML -import qualified Data.Text as T -import Reaktor.Internal -import qualified Reaktor.Plugins - - -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/Internal.hs b/src/Reaktor/Internal.hs index d3ac9cf..26294b4 100644 --- a/src/Reaktor/Internal.hs +++ b/src/Reaktor/Internal.hs @@ -1,58 +1,68 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Reaktor.Internal (module Reaktor.Internal, 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 +{-# LANGUAGE RecordWildCards #-} +module Reaktor.Internal where + +import Blessings +import Data.Aeson +import Data.ByteString (ByteString) +import Network.Socket as Exports (HostName,ServiceName) +import Prelude.Extended import qualified Data.ByteString.Char8.Extended as BS -import Network.Socket as X (HostName,ServiceName) +import System.IO -type Prefix = BS.ByteString +data Actions = Actions + { aIsSecure :: Bool -type Nickname = BS.ByteString -type Password = BS.ByteString -type MsgTarget = BS.ByteString -type Channel = MsgTarget + , aSend :: Message -> IO () + , aSendQuiet :: Message -> IO () -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 + , aLog :: Blessings ByteString -> IO () + , aLogMsg :: Message -> IO () - -type PluginIO = StateT PluginState IO - -type PluginFunc = Message -> PluginIO () - -data Plugin = Plugin { - pluginFunc :: PluginFunc, - requireTLS :: Bool + , aSetNick :: ByteString -> IO () + , aGetNick :: IO ByteString } -simplePlugin :: FromJSON a => (a -> PluginFunc) -> Value -> IO Plugin -simplePlugin f v = - either error (\x -> return $ Plugin (f x) False) (parseEither parseJSON v) +data Config = Config + { cUseTLS :: Bool + , cHostName :: HostName + , cServiceName :: ServiceName + , cNick :: Maybe ByteString + , cLogHandle :: Handle + , cLogTime :: Bool + } -type Param = BS.ByteString -type Command = BS.ByteString -data Message = Message (Maybe Prefix) Command [Param] +instance Default Config where + def = Config False "irc.r" "6667" Nothing stderr True + +instance FromJSON Config where + parseJSON = \case + Object v -> do + cServiceName <- v .:? "port" .!= cServiceName def + cUseTLS <- v .:? "useTLS" .!= (cServiceName == tlsPort) + cHostName <- v .:? "hostname" .!= cHostName def + cNick <- v .:? "nick" + cLogHandle <- pure (cLogHandle def) + cLogTime <- v .:? "logTime" .!= cLogTime def + pure Config{..} + _ -> undefined + where + tlsPort :: ServiceName + tlsPort = "6697" + + +data Message = Message (Maybe ByteString) ByteString [ByteString] | Start deriving Show + +formatMessage :: Message -> ByteString +formatMessage = \case + Message mb_prefix cmd params -> + maybe "" ((":"<>) . (<>" ")) mb_prefix + <> cmd + <> BS.concat (map (" "<>) (init params)) + <> if null params then "" else " :" <> last params + <> "\r\n" + x -> error ("cannot format " <> show x) diff --git a/src/Reaktor/Message.hs b/src/Reaktor/Message.hs deleted file mode 100644 index c679d78..0000000 --- a/src/Reaktor/Message.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Reaktor.Message where - -import qualified Data.ByteString.Char8.Extended as BS -import Reaktor.Internal - - -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/Nick.hs b/src/Reaktor/Nick.hs new file mode 100644 index 0000000..591ea4b --- /dev/null +++ b/src/Reaktor/Nick.hs @@ -0,0 +1,44 @@ +module Reaktor.Nick where + +import Data.ByteString.Char8.Extended (ByteString) +import qualified Data.ByteString.Char8.Extended as BS +import Data.Char (chr) +import Data.Char (isDigit) +import System.Random (getStdRandom, randomR) + + +getNext :: ByteString -> ByteString +getNext nick_ = nick' + where + splitNick s = + (prefix, maybe 0 fst (BS.readInt suffix)) + where + prefix = BS.take (BS.length s - BS.length suffix) s + suffix = BS.reverse . BS.takeWhile isDigit . BS.reverse $ s + (nickPrefix, nickSuffix) = splitNick nick_ + nick' = nickPrefix <> (BS.pack . show $ nickSuffix + 1) + + +getRandom :: IO ByteString +getRandom = do + h_chr <- getRandomChar nickhead + t_len <- getStdRandom (randomR (4,8)) :: IO Int + t_str <- mapM (const $ getRandomChar nicktail) [1..t_len] + return $ BS.pack (h_chr:t_str) + where + getRandomChar cs = (cs!!) <$> getStdRandom (randomR (0, length cs - 1)) + + -- RFC2812 (doesn't work with charybdis) + --nickhead = letters <> specials + --nicktail = letters <> digits <> specials <> minus + --letters = map chr $ [0x41..0x5A] <> [0x61..0x7A] + --digits = map chr $ [0x30..0x39] + --specials = map chr $ [0x5B..0x60] <> [0x7B..0x7D] + --minus = map chr $ [0x2D] + + -- RFC1459 + nickhead = letters + nicktail = letters <> number <> special + letters = map chr $ [0x41..0x5A] <> [0x61..0x7A] + number = map chr $ [0x30..0x39] + special = map chr $ [0x5B..0x60] <> [0x7B..0x7D] <> [0x2D] diff --git a/src/Reaktor/Parser.hs b/src/Reaktor/Parser.hs index 12d5ace..1b358fc 100644 --- a/src/Reaktor/Parser.hs +++ b/src/Reaktor/Parser.hs @@ -1,35 +1,37 @@ {-# LANGUAGE OverloadedStrings #-} module Reaktor.Parser where -import Control.Applicative -import Data.Attoparsec.ByteString.Char8 -import qualified Data.ByteString.Char8.Extended as BS +import Control.Applicative +import Data.ByteString (ByteString) +import Data.Attoparsec.ByteString.Char8 +--import qualified Data.ByteString.Char8.Extended as BS +import qualified Data.ByteString.Char8 as BS import qualified Data.Char -import Reaktor.Internal +import Reaktor.Internal -prefix :: Parser Prefix +prefix :: Parser ByteString prefix = BS.pack <$> many (satisfy Data.Char.isAlphaNum <|> satisfy (flip elem (":.-@/!~[]\\`_^{|}" :: String))) -command :: Parser Command +command :: Parser ByteString command = BS.pack <$> many1 (satisfy Data.Char.isAlphaNum) nospcrlfcl :: Parser Char nospcrlfcl = satisfy (flip notElem ("\NUL\CR\LF :" :: String)) "nospcrlfcl" -middle :: Parser Param +middle :: Parser ByteString middle = BS.pack <$> ((:) <$> nospcrlfcl <*> many (char ':' <|> nospcrlfcl)) "middle" -trailing :: Parser Param +trailing :: Parser ByteString trailing = BS.pack <$> many (char ':' <|> char ' ' <|> nospcrlfcl) "trailing" -params :: Parser [Param] +params :: Parser [ByteString] params = (do a <- many (char ' ' *> middle) b <- optional (char ' ' *> char ':' *> trailing) diff --git a/src/Reaktor/Plugins.hs b/src/Reaktor/Plugins.hs deleted file mode 100644 index 86e1f2a..0000000 --- a/src/Reaktor/Plugins.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# 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.Internal (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 index 75de87c..379bd38 100644 --- a/src/Reaktor/Plugins/Mention.hs +++ b/src/Reaktor/Plugins/Mention.hs @@ -1,26 +1,22 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Reaktor.Plugins.Mention (plugin) where +{-# LANGUAGE RecordWildCards #-} +module Reaktor.Plugins.Mention (new) where -import Control.Monad (when) -import Data.Aeson +import Prelude.Extended import qualified Data.ByteString.Char8.Extended as BS import qualified Data.Char -import Reaktor.Internal -import Reaktor.Message +import Reaktor -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 () +new :: Actions -> IO (Message -> IO ()) +new Actions{..} = do + pure $ \case + Message _ "PRIVMSG" (msgtarget:text:[]) -> do + nick <- aGetNick + when (isMention nick text) $ do + aSend (privmsg msgtarget ["I'm famous!"]) + _ -> return () where isMention nick text = not (BS.isPrefixOf (nick <> ":") text) && diff --git a/src/Reaktor/Plugins/NickServ.hs b/src/Reaktor/Plugins/NickServ.hs deleted file mode 100644 index 36b8917..0000000 --- a/src/Reaktor/Plugins/NickServ.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# 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.Extended as BS -import GHC.Generics -import Reaktor.Internal -import Reaktor.Message -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 _ "" _ -> 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_, ""]) - - - _ -> return () diff --git a/src/Reaktor/Plugins/Ping.hs b/src/Reaktor/Plugins/Ping.hs index de3fe53..436ebe2 100644 --- a/src/Reaktor/Plugins/Ping.hs +++ b/src/Reaktor/Plugins/Ping.hs @@ -1,15 +1,15 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Reaktor.Plugins.Ping (plugin) where - -import Control.Monad (when) -import Data.Aeson (Value(Null)) -import Reaktor.Internal - - -plugin :: Value -> IO Plugin -plugin = simplePlugin (\Null -> run) - -run :: PluginFunc -run (Message _ ircCommand args) = - when (ircCommand == "PING") $ - sendMsg (Message Nothing "PONG" args) +{-# LANGUAGE RecordWildCards #-} +module Reaktor.Plugins.Ping where + +import Prelude.Extended +import Reaktor + +new :: Actions -> IO (Message -> IO ()) +new Actions{..} = + return $ \case + Message _ cmd args -> + when (cmd == "PING") $ + aSend (Message Nothing "PONG" args) + _ -> pure () diff --git a/src/Reaktor/Plugins/Register.hs b/src/Reaktor/Plugins/Register.hs index 5e987a7..314fc6f 100644 --- a/src/Reaktor/Plugins/Register.hs +++ b/src/Reaktor/Plugins/Register.hs @@ -1,65 +1,163 @@ -{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -module Reaktor.Plugins.Register (plugin) where +{-# LANGUAGE RecordWildCards #-} +module Reaktor.Plugins.Register where -import Control.Monad (when) -import Data.Aeson +import Blessings +import Prelude.Extended +import Data.Aeson +import Data.ByteString.Char8.Extended (ByteString) import qualified Data.ByteString.Char8.Extended as BS -import GHC.Generics -import Reaktor.Internal -import Reaktor.Utils (nextNick,randomNick) +import qualified Reaktor.Nick as Nick +import Reaktor +import System.Environment (lookupEnv) +data ConfigNickServ = ConfigNickServ + { cnsPassFile :: FilePath + , cnsPrefix :: ByteString + } +instance FromJSON ConfigNickServ where + parseJSON = \case + Object v -> + ConfigNickServ + <$> v .: "passFile" + <*> v .:? "prefix" .!= "NickServ!NickServ@services." + _ -> undefined -data RegisterConfig = RegisterConfig { - channels :: [BS.ByteString] +data Config = Config + { cNick :: Maybe ByteString + , cUser :: Maybe ByteString + , cReal :: ByteString + , cChannels :: [ByteString] + , cNickServ :: Maybe ConfigNickServ } - deriving (FromJSON,Generic) +instance Default Config where + def = Config def def "reaktor2" def def +instance FromJSON Config where + parseJSON = \case + Object v -> do + cNick <- v .:? "nick" .!= Nothing + cUser <- v .:? "user" + cReal <- v .:? "real" .!= cReal def + cChannels <- v .:? "channels" .!= [] + cNickServ <- v .:? "NickServ" .!= cNickServ def + pure Config{..} + _ -> undefined + +new :: Config -> Actions -> IO (Message -> IO ()) +new Config{..} Actions{..} = do + let + isNickServEnabled = aIsSecure && isJust cNickServ + Just ConfigNickServ{..} = cNickServ + + release nick pass = do + -- TODO Password type that doesn't get logged? + aLogMsg (privmsg "NickServ" ["RELEASE", nick, ""]) + aSendQuiet (privmsg "NickServ" ["RELEASE", nick, pass]) + channelsArg = BS.intercalate "," cChannels + -- TODO make this similar to privmsg (i.e. don't aSend) + join = do + -- TODO JOIN only if not already joined + -- i.e. not during subsequent nick changes + unless (BS.null channelsArg) $ + aSend (Message Nothing "JOIN" [channelsArg]) -plugin :: Value -> IO Plugin -plugin = simplePlugin run + start = do + nick <- maybe aGetNick pure cNick + user <- + maybe (maybe nick BS.pack <$> lookupEnv "LOGNAME") pure cUser + aSetNick nick + aSend (Message Nothing "NICK" [nick]) + aSend (Message Nothing "USER" [user, "*", "0", cReal]) + onNick newnick = do + nick <- aGetNick + when (newnick == nick) join + useRandomNick = do + nick <- Nick.getRandom + aSetNick nick + aSend (Message Nothing "NICK" [nick]) + useNextNick = do + nick0 <- aGetNick + let nick = Nick.getNext nick0 + aSetNick nick + aSend (Message Nothing "NICK" [nick]) + useNextNickTemporarily = do + nick <- aGetNick + let tmpNick = Nick.getNext nick + -- do not aSetNick tmpNick + aSend (Message Nothing "NICK" [tmpNick]) + if not isNickServEnabled then do + when (isJust cNickServ) $ do + aLog $ SGR [38,5,202] "! disabling NickServ due to insecure connection" + pure $ \case + Start -> start + Message (Just _self) "NICK" (newnick:[]) -> onNick newnick + Message _ "001" _ -> join + Message _ "432" _ -> useRandomNick + Message _ "433" _ -> useNextNick + Message _ "437" (_msgtarget:res:_reason:[]) -> do + nick <- aGetNick + when (res == nick) useNextNick + _ -> pure () -run :: RegisterConfig -> PluginFunc -run cfg msg = do - nick_ <- getNick - case msg of + else do + -- TODO do not fail, but disable NicServ + [pass] <- BS.lines <$> BS.readFile cnsPassFile + pure $ \case + Start -> start + Message (Just _self) "NICK" (newnick:[]) -> onNick newnick - Message _ "" _ -> do - sendMsg (Message Nothing "NICK" [nick_]) - sendMsg (Message Nothing "USER" [nick_, "*", "0", nick_]) + -- RFC2812 RPL_WELCOME + Message _ "001" [msgtarget,_text] -> do + nick <- aGetNick + aLogMsg (privmsg "NickServ" ["IDENTIFY", nick, ""]) + aSendQuiet (privmsg "NickServ" ["IDENTIFY", nick, pass]) + when (msgtarget /= nick) (release nick pass) - 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) ]) + -- TODO structured prefix, and check just for "NickServ"? + Message (Just prefix) "NOTICE" (msgtarget:text:[]) -> + when (prefix == cnsPrefix) $ do + nick <- aGetNick + let stx = ("\STX"<>) . (<>"\STX") + if + | text == "You are now identified for " <> stx nick <> "." -> do + -- XXX if msgtarget == nick then do + -- XXX join + -- XXX else do + -- XXX aSend (Message Nothing "NICK" [nick]) - -- 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' + -- otherwise join at NICK + when (msgtarget == nick) join - -- 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' + | text == stx nick <> " has been released." -> do + aSend (Message Nothing "NICK" [nick]) + | text == "Invalid password for " <> stx nick <> "." -> do + -- TODO change nick + warning + error (BS.unpack text) + | text == stx nick <> " is not a registered nickname." -> do + -- TODO change nick + warning + error (BS.unpack text) + | otherwise -> + pure () - -- RFC2812 ERR_UNAVAILRESOURCE - --Message (Just _servername) "437" (_msgtarget:nickunavail:_reason:[]) -> do + -- RFC1459 ERR_ERRONEUSNICKNAME + Message (Just _servername) "432" (_msgtarget:_nick:_reason:[]) -> + useRandomNick - -- RFC2812 RPL_WELCOME - Message _ "001" [_nick,_s] -> do - --logStrLn $ SGR [32,1] (Plain s) - sendMsg (Message Nothing "JOIN" [ BS.intercalate "," (channels cfg) ]) + -- RFC1459 ERR_NICKNAMEINUSE + Message (Just _servername) "433" (_msgtarget:_nick:_reason:[]) -> + -- TODO what if nick0 /= nick? OR assert/prove nick0 == nick? + useNextNickTemporarily + --RFC2812 ERR_UNAVAILRESOURCE + Message (Just _servername) "437" (msgtarget:res:_reason:[]) -> do + nick <- aGetNick + when (res == nick) $ + case msgtarget of + "*" -> useNextNickTemporarily + _ -> release nick pass - _ -> return () + _ -> pure () diff --git a/src/Reaktor/Plugins/System.hs b/src/Reaktor/Plugins/System.hs index 781409b..88b8d84 100644 --- a/src/Reaktor/Plugins/System.hs +++ b/src/Reaktor/Plugins/System.hs @@ -2,58 +2,49 @@ {-# 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 +{-# LANGUAGE RecordWildCards #-} +module Reaktor.Plugins.System (new) where + +--import Prelude.Extended +import Blessings +import Control.Applicative +import Control.Concurrent (forkIO) +import Control.Exception (finally) +--import Data.Aeson +import Data.ByteString.Char8.Extended (ByteString) import qualified Data.ByteString.Char8.Extended as BS import qualified Data.Map as M -import Reaktor.Message -import Reaktor.Internal -import Reaktor.Plugins.System.Internal -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 Reaktor +import System.Environment (getEnvironment) +import System.FilePath.Posix (takeBaseName) +import System.IO (BufferMode(LineBuffering),hSetBuffering) +import System.IO (Handle,hClose,hPutStr,hIsEOF) +import Reaktor.Plugins.System.Internal -- TODO rename to Reaktor.Plugins.System again +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 +new :: Config -> Actions -> IO (Message -> IO ()) +new config@Config{..} actions@Actions{..} = do + pure $ \case + Message (Just prefix) "PRIVMSG" (msgtarget:text:[]) -> do -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 + nick_ <- aGetNick + let hs = maybe [] id (M.lookup "PRIVMSG" cHooks) + mapM_ (\h -> run1 config actions 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 + Message (Just prefix) "JOIN" (channel:[]) -> do + nick_ <- aGetNick + let hs = maybe [] id (M.lookup "JOIN" cHooks) + mapM_ (\h -> run1 config actions nick_ h prefix channel "") hs --- TODO warning? -run _ _ = return () + _ -> pure () -run1 :: - SystemConfig - -> Nickname - -> SystemParams - -> BS.ByteString - -> BS.ByteString - -> BS.ByteString - -> PluginIO () -run1 cfg nick_ params prefix msgtarget text = do +run1 :: Config -> Actions -> ByteString -> SystemParams -> ByteString -> ByteString -> ByteString -> IO () +run1 config@Config{..} actions@Actions{..} nick_ params prefix msgtarget text = do let isActivated = case activate params of @@ -88,6 +79,7 @@ run1 cfg nick_ params prefix msgtarget text = do 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 @@ -141,36 +133,35 @@ run1 cfg nick_ params prefix msgtarget text = do case command' of Just c -> do - sendMsg_ <- gets s_sendMsg - putLog_ <- gets s_putLog + -- aSend <- gets s_sendMsg + -- putLog_ <- gets s_putLog let onErrLine s = - putLog_ $ SGR [31,1] $ + aLog $ SGR [31,1] $ Plain (BS.pack (takeBaseName $ commandPath c) <> ": "<> s) onOutLine s = - sendMsg_ (privmsg audience [s]) + aSend (privmsg audience [s]) extraEnv = [("_prefix", BS.unpack prefix), ("_from", BS.unpack from)] - lift $ fork cfg c args' (Just extraEnv) "" onOutLine onErrLine + fork config actions c args' (Just extraEnv) "" onOutLine onErrLine Nothing -> do - sendMsg (privmsg audience (resultPrefix <> [cmdName <> ": command not found"])) + aSend (privmsg audience (resultPrefix <> [cmdName <> ": command not found"])) Nothing -> return () - - -fork :: SystemConfig +fork :: Config + -> Actions -> SystemCommand -> [String] -> Maybe [(String, String)] -> String - -> (BS.ByteString -> IO ()) - -> (BS.ByteString -> IO ()) + -> (ByteString -> IO ()) + -> (ByteString -> IO ()) -> IO () -fork cfg cmd args extraEnv input onOutLine onErrLine = do +fork Config{..} Actions{..} cmd args extraEnv input onOutLine onErrLine = do baseEnv <- getEnvironment @@ -183,7 +174,7 @@ fork cfg cmd args extraEnv input onOutLine onErrLine = do (inh, outh, errh) <- do (Just inh, Just outh, Just errh, ph) <- createProcess (proc (commandPath cmd) args) { - cwd = commandWorkDir cmd <|> defaultWorkDir cfg, + cwd = commandWorkDir cmd <|> cDefaultWorkDir, env = Just procEnv, std_in = CreatePipe, std_out = CreatePipe, @@ -202,7 +193,7 @@ fork cfg cmd args extraEnv input onOutLine onErrLine = do ] -hWithLines :: Handle -> (BS.ByteString -> IO ()) -> IO () +hWithLines :: Handle -> (ByteString -> IO ()) -> IO () hWithLines h f = do hSetBuffering h LineBuffering go `finally` hClose h diff --git a/src/Reaktor/Plugins/System/Internal.hs b/src/Reaktor/Plugins/System/Internal.hs index 4a64e0b..2ed923d 100644 --- a/src/Reaktor/Plugins/System/Internal.hs +++ b/src/Reaktor/Plugins/System/Internal.hs @@ -1,10 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Reaktor.Plugins.System.Internal where -import Data.Aeson +import Prelude.Extended +import Data.Aeson import qualified Data.ByteString.Char8.Extended as BS import qualified Data.Map as M -import Reaktor.Internal () +import Reaktor () -- TODO this needs better names :) @@ -24,15 +25,18 @@ instance FromJSON Activate where parseJSON (String "query") = pure Query parseJSON _ = undefined -data SystemConfig = SystemConfig { - defaultWorkDir :: Maybe FilePath, +data Config = Config { + cDefaultWorkDir :: Maybe FilePath, -- TODO IrcCommand as key for map - hooks :: M.Map BS.ByteString [SystemParams] + cHooks :: M.Map BS.ByteString [SystemParams] } -instance FromJSON SystemConfig where +instance Default Config where + def = Config Nothing mempty + +instance FromJSON Config where parseJSON (Object v) = - SystemConfig + Config <$> v .:? "workdir" <*> v .:? "hooks" .!= M.empty parseJSON _ = pure undefined diff --git a/src/Reaktor/Utils.hs b/src/Reaktor/Utils.hs deleted file mode 100644 index a31cd15..0000000 --- a/src/Reaktor/Utils.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Reaktor.Utils where - -import qualified Data.ByteString.Char8.Extended as BS -import Data.Char (chr) -import Data.Char (isDigit) -import Reaktor.Internal -import System.Random (getStdRandom, randomR) - - -nextNick :: Nickname -> Nickname -nextNick nick_ = nick' - where - splitNick s = - (prefix, maybe 0 fst (BS.readInt suffix)) - where - prefix = BS.take (BS.length s - BS.length suffix) s - suffix = BS.reverse . BS.takeWhile isDigit . BS.reverse $ s - (nickPrefix, nickSuffix) = splitNick nick_ - nick' = nickPrefix <> (BS.pack . show $ nickSuffix + 1) - - -randomNick :: IO Nickname -randomNick = do - h_chr <- getRandomChar nickhead - t_len <- getStdRandom (randomR (4,8)) :: IO Int - t_str <- mapM (const $ getRandomChar nicktail) [1..t_len] - return $ BS.pack (h_chr:t_str) - where - getRandomChar cs = (cs!!) <$> getStdRandom (randomR (0, length cs - 1)) - - nickhead = letters <> specials - nicktail = letters <> digits <> specials <> minus - - letters = map chr $ [0x41..0x5A] <> [0x61..0x7A] - digits = map chr $ [0x30..0x39] - specials = map chr $ [0x5B..0x60] <> [0x7B..0x7D] - minus = map chr $ [0x2D] diff --git a/src/main.hs b/src/main.hs index db5e54a..89966c2 100644 --- a/src/main.hs +++ b/src/main.hs @@ -1,14 +1,52 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Data.Aeson (eitherDecodeFileStrict) +import Control.Lens +import Data.Aeson +import Data.Aeson (Value) +import Data.Aeson.Lens +import Data.Aeson.Types +import Data.Text (Text) +import Prelude.Extended import qualified Reaktor +import qualified Reaktor.Plugins.Mention +import qualified Reaktor.Plugins.Ping +import qualified Reaktor.Plugins.Register +import qualified Reaktor.Plugins.System import qualified System.Environment main :: IO () main = do [configPath] <- System.Environment.getArgs - eitherDecodeFileStrict configPath >>= \case - Right cfg -> Reaktor.run cfg - Left err -> error err + + v <- preview _Value <$> readFile configPath + + Reaktor.run (reaktorConfig v) $ \actions -> + mapM id [ + Reaktor.Plugins.Mention.new actions, + Reaktor.Plugins.Ping.new actions, + Reaktor.Plugins.Register.new (pluginConfig "register" v) actions, + Reaktor.Plugins.System.new (pluginConfig "system" v) actions + ] + + +reaktorConfig :: (FromJSON b, Default b) => Maybe Value -> b +reaktorConfig = maybe def parseOrDie + +pluginConfig :: (AsValue a, FromJSON b, Default b) => Text -> Maybe a -> b +pluginConfig k v = maybe def parseOrDie (v ^? plugin k) + + +plugin :: (Applicative f, AsValue a) => + Text -> (Value -> f Value) -> Maybe a -> f (Maybe a) +plugin k = _Just + . key "plugins" + . values + . filtered (has (key "plugin" . _String . only k)) + . key "config" + + +parseOrDie :: FromJSON p => Value -> p +parseOrDie = either error id . parseEither parseJSON -- cgit v1.2.3