aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authortv <tv@krebsco.de>2019-01-23 00:02:42 +0100
committertv <tv@krebsco.de>2019-01-23 00:57:36 +0100
commitd40815fd56bf1895af89b72b1171675a2e0ae5f7 (patch)
tree83b96a701f16b13915836c3a6c94463732a9f6d8
parenta00da57346c195b1b15d1c6aca2891483901aae6 (diff)
src: use more simple functionsv0.1.0
-rw-r--r--reaktor2.cabal6
-rw-r--r--src/Control/Concurrent/Extended.hs24
-rw-r--r--src/Prelude/Extended.hs8
-rw-r--r--src/Reaktor.hs355
-rw-r--r--src/Reaktor/Config.hs76
-rw-r--r--src/Reaktor/Internal.hs102
-rw-r--r--src/Reaktor/Message.hs14
-rw-r--r--src/Reaktor/Nick.hs (renamed from src/Reaktor/Utils.hs)29
-rw-r--r--src/Reaktor/Parser.hs20
-rw-r--r--src/Reaktor/Plugins.hs28
-rw-r--r--src/Reaktor/Plugins/Mention.hs28
-rw-r--r--src/Reaktor/Plugins/NickServ.hs92
-rw-r--r--src/Reaktor/Plugins/Ping.hs28
-rw-r--r--src/Reaktor/Plugins/Register.hs188
-rw-r--r--src/Reaktor/Plugins/System.hs101
-rw-r--r--src/Reaktor/Plugins/System/Internal.hs18
-rw-r--r--src/main.hs46
17 files changed, 535 insertions, 628 deletions
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 <tv@krebsco.de>
maintainer: tv <tv@krebsco.de>
@@ -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 "<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)
+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/Utils.hs b/src/Reaktor/Nick.hs
index a31cd15..591ea4b 100644
--- a/src/Reaktor/Utils.hs
+++ b/src/Reaktor/Nick.hs
@@ -1,14 +1,14 @@
-module Reaktor.Utils where
+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 Reaktor.Internal
import System.Random (getStdRandom, randomR)
-nextNick :: Nickname -> Nickname
-nextNick nick_ = nick'
+getNext :: ByteString -> ByteString
+getNext nick_ = nick'
where
splitNick s =
(prefix, maybe 0 fst (BS.readInt suffix))
@@ -19,8 +19,8 @@ nextNick nick_ = nick'
nick' = nickPrefix <> (BS.pack . show $ nickSuffix + 1)
-randomNick :: IO Nickname
-randomNick = do
+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]
@@ -28,10 +28,17 @@ randomNick = do
where
getRandomChar cs = (cs!!) <$> getStdRandom (randomR (0, length cs - 1))
- nickhead = letters <> specials
- nicktail = letters <> digits <> specials <> minus
+ -- 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]
- digits = map chr $ [0x30..0x39]
- specials = map chr $ [0x5B..0x60] <> [0x7B..0x7D]
- minus = map chr $ [0x2D]
+ 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 _ "<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