aboutsummaryrefslogtreecommitdiffstats
path: root/src/Reaktor.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Reaktor.hs')
-rw-r--r--src/Reaktor.hs355
1 files changed, 145 insertions, 210 deletions
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