src: use more simple functionsv0.1.0

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