replace hirc.hs by main.hs

8 files changed, 493 insertions, 111 deletions

diff --git a/Event.hs b/Event.hs
new file mode 100644
index 0000000..87fc4e7
--- /dev/null
+++ b/Event.hs
@@ -0,0 +1,16 @@
+module Event where
+
+import Blessings
+import Scanner
+import qualified Hirc
+
+data Event =
+    EFlash (Blessings String) |
+    EScan Scan |
+    EReload |
+    EResize Int Int |
+    EPutLn String |
+    EHircConnect Hirc.Bot |
+    EHircMessage Hirc.Message |
+    EHircError Hirc.Error |
+    ETick
diff --git a/Hirc.hs b/Hirc.hs
new file mode 100644
index 0000000..8874fb7
--- /dev/null
+++ b/Hirc.hs
@@ -0,0 +1,6 @@
+module Hirc (module Export) where
+
+import Hirc.Bot as Export
+import Hirc.Format as Export
+import Hirc.Parser as Export
+import Hirc.Types as Export
diff --git a/Hirc/Bot.hs b/Hirc/Bot.hs
new file mode 100644
index 0000000..9cdeeaf
--- /dev/null
+++ b/Hirc/Bot.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Hirc.Bot where
+
+import Prelude hiding (read)
+import Network
+import System.IO
+import Control.Concurrent.STM
+import Control.Monad.Reader
+import Control.Exception
+import Hirc.Parser as P
+import Hirc.Types
+import Text.Parsec (parse)
+
+runBot :: Config -> Hooks -> IO ()
+runBot Config{..} Hooks{..} =
+    bracket (connect config_server) disconnect run
+  where
+    connect Server{..} = do
+      socket <- connectTo hostname (PortNumber (fromIntegral port))
+      nick <- atomically $ newTVar config_nick
+      chan <- atomically $ newTVar config_chan
+      hSetBuffering socket NoBuffering
+      return Bot {
+        bot_server = config_server,
+        bot_nick = nick,
+        bot_chan = chan,
+        bot_socket = socket
+      }
+
+    disconnect bot@Bot{bot_socket=h} = do
+        hClose h
+        runReaderT hooks_onDisconnect bot
+
+    run bot = do
+      runReaderT (hooks_onConnect >> receive hooks_onMessage hooks_onError) bot
+
+    receive :: (Message -> Net ()) -> (Error -> Net ()) -> Net ()
+    receive onMessage onError = do
+      server <- asks bot_server
+      socket <- asks bot_socket
+      forever $ do
+        s <- init <$> liftIO (hGetLine socket)
+        case parse P.message (show server) s of
+          Right m -> do
+              case m of
+                  Message _ "PING" [x] -> do
+                      h <- asks bot_socket
+                      liftIO $ hPutStr h $ "PONG :" ++ x ++ "\r\n"
+                  _ -> return ()
+              onMessage m
+          e -> onError $ BadMessage $ show e -- TODO
+
+atomic :: (Bot -> a) -> (a -> STM b) -> Net b
+atomic v f = asks v >>= liftIO . atomically . f
+
+read :: (Bot -> TVar a) -> Net a
+read v = atomic v readTVar
+
+write :: (Bot -> TVar a) -> a -> Net ()
+write v = atomic v . flip writeTVar
+
+
+bumpNick :: Net String
+bumpNick =
+    atomic bot_nick $ flip updateTVar $ \nick ->
+      case parse P.nickNum "bumpNick" nick of
+        Right (n,i) -> n ++ show (i+1)
+        _ -> nick ++ "_"
+
+
+-- Like modifyTVar but returns the new value.
+updateTVar :: TVar a -> (a -> a) -> STM a
+updateTVar v f = do
+    x <- readTVar v
+    let x' = f x
+    writeTVar v x'
+    return x'
diff --git a/Hirc/Format.hs b/Hirc/Format.hs
new file mode 100644
index 0000000..bf6546a
--- /dev/null
+++ b/Hirc/Format.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+module Hirc.Format where
+
+import Hirc.Types
+
+formatMessage :: Message -> String
+formatMessage Message{..} =
+    maybe "" prefix m_prefix ++ m_command ++ params
+  where
+    prefix Prefix{..} =
+      ":" ++ p_name ++ maybe "" user p_user ++ maybe "" host p_host ++ " "
+    user x = "!" ++ x
+    host x = "@" ++ x
+    params = concatMap (" "++) (init m_params) ++ " :" ++ last m_params
diff --git a/Hirc/Parser.hs b/Hirc/Parser.hs
index f52564b..7014171 100644
--- a/Hirc/Parser.hs
+++ b/Hirc/Parser.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 module Hirc.Parser where
 
 import Data.Char
@@ -21,3 +22,10 @@ message =
     trailing = char ':' *> many anyChar
     middle = many1 nonspace
     nonspace = satisfy (not . isSpace)
+
+
+
+nickNum :: Parser (String, Int)
+nickNum =
+  (,) <$> (many1 (satisfy (not . isDigit)))
+      <*> ((digitToInt <$> digit) <|> pure 0)
diff --git a/Hirc/Types.hs b/Hirc/Types.hs
index 2567b53..c516ba7 100644
--- a/Hirc/Types.hs
+++ b/Hirc/Types.hs
@@ -1,5 +1,11 @@
+{-# LANGUAGE RecordWildCards #-}
+
 module Hirc.Types where
 
+import System.IO (Handle)
+import Control.Concurrent.STM (TVar)
+import Control.Monad.Reader (ReaderT)
+
 type Command = String
 type Param = String
 type Receiver = String
@@ -12,6 +18,10 @@ data Message =
   }
   deriving Show
 
+data Error =
+    BadMessage String
+  deriving Show
+
 data Prefix =
   Prefix {
     p_name :: String,
@@ -20,3 +30,36 @@ data Prefix =
   }
   deriving Show
 
+type Net = ReaderT Bot IO
+
+data Bot = Bot {
+  bot_server :: Server,
+  bot_nick :: TVar String,
+  bot_chan :: TVar String,
+  bot_socket :: Handle
+}
+
+data Config =
+    Config {
+      config_server :: Server,
+      config_nick :: String,
+      config_chan :: String
+    }
+  deriving Show
+
+data Hooks =
+    Hooks {
+      hooks_onConnect :: Net (),
+      hooks_onDisconnect :: Net (),
+      hooks_onError :: Error -> Net (),
+      hooks_onMessage :: Message -> Net ()
+      --hooks_shell :: Net()
+    }
+
+data Server =
+    Server {
+      hostname :: String,
+      port :: Int
+    }
+instance Show Server where
+    show Server{..} = hostname ++ ":" ++ show port
diff --git a/hirc.hs b/hirc.hs
deleted file mode 100644
index 6a629fd..0000000
--- a/hirc.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RecordWildCards #-}
-import Data.List
-import Data.Monoid
-import Network
-import System.IO
-import System.Exit
-import Control.Arrow
-import Control.Monad (forever)
-import Control.Monad.Reader
-import Control.Exception
-import Hirc.Parser as P
-import Hirc.Types
-import Text.Parsec (parse)
-import Text.Printf
-
-data Config =
-    Config {
-      server :: String,
-      port :: Int,
-      chan :: String,
-      nick :: String
-    }
-  deriving Show
-
--- The 'Net' monad, a wrapper over IO, carrying the bot's immutable state.
-type Net = ReaderT Bot IO
-data Bot = Bot {
-  config :: Config,
-  socket :: Handle
-}
-
--- Set up actions to run on start and end, and run the main loop
-main :: IO ()
-main = bracket (connect c) disconnect loop
-  where
-    disconnect = hClose . socket
-    loop st    = runReaderT run st
-    c = Config {
-      server = "irc.freenode.org",
-      port   = 6667,
-      chan   = "#hirc-testing",
-      nick   = "hirc"
-    }
-
-
--- Connect to the server and return the initial bot state
-connect :: Config -> IO Bot
-connect c@Config{..} = notify $ do
-    h <- connectTo server (PortNumber (fromIntegral port))
-    hSetBuffering h NoBuffering
-    return (Bot c h)
-  where
-    notify a = bracket_
-        (printf "Connecting to %s ... " server >> hFlush stdout)
-        (putStrLn "done.")
-        a
-
--- We're in the Net monad now, so we've connected successfully
--- Join a channel, and start processing commands
-run :: Net ()
-run = do
-    Config{..} <- asks config
-    write "NICK" nick
-    write "USER" (nick++" 0 * :hirc bot")
-    ask >>= listen
-
--- Process each line from the server
-listen :: Bot -> Net ()
-listen Bot{config=c@Config{..},socket=h} = forever $ do
-    s <- init `fmap` io (hGetLine h)
-    io (putStrLn s)
-    case parse P.message filename s of
-      Right m -> eval m
-      x -> io $ putStrLn $ show x
-  where
-    filename = server <> (':' : show port)
-
--- Dispatch a command
-eval :: Message -> Net ()
-eval = \case
-    Message _ "PING" [x] ->
-      write "PONG" (':' : x)
-    Message _ "376" _ -> do -- End of /MOTD command.
-      Config{..} <- asks config
-      write "JOIN" chan
-    Message _ "PRIVMSG" [chan, "!quit"] -> do
-      write "QUIT" ":Exiting"
-      io (exitWith ExitSuccess)
-    Message _ "PRIVMSG" [chan, x] | "!id " `isPrefixOf` x -> do
-      privmsg (drop 4 x)
-    m -> do
-      io (putStrLn $ show m)
-      return () -- ignore everything else
-
--- Send a privmsg to the current chan + server
-privmsg :: String -> Net ()
-privmsg s = do
-    Config{..} <- asks config
-    write "PRIVMSG" (chan ++ " :" ++ s)
-
--- Send a message out to the server we're currently connected to
-write :: String -> String -> Net ()
-write s t = do
-    h <- asks socket
-    io $ hPrintf h "%s %s\r\n" s t
-    io $ printf    "> %s %s\n" s t
-
--- Convenience.
-io :: IO a -> Net a
-io = liftIO
diff --git a/main.hs b/main.hs
new file mode 100644
index 0000000..dc8a14b
--- /dev/null
+++ b/main.hs
@@ -0,0 +1,326 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Prelude hiding (print)
+import Scanner
+import Event
+import Blessings
+import Data.Char
+import Data.Monoid
+import Control.Arrow
+import Control.Concurrent
+import Control.Concurrent.MSampleVarX
+import Control.Exception
+import Control.Monad
+import Control.Monad.Reader (ask, asks)
+import Control.Monad.IO.Class (liftIO)
+import System.IO hiding (print)
+import System.Posix.Signals
+import Data.Time
+import Data.Time.Clock.POSIX
+import qualified Hirc
+
+
+newRelay :: IO (a -> IO (), IO a)
+newRelay = (putMVar &&& takeMVar) <$> newEmptyMVar
+
+newSampler :: IO (Maybe a -> IO (), IO a)
+newSampler = (write &&& readSV) <$> newEmptySV
+  where write v n = maybe (emptySV v) (writeSV v) n
+
+newSemaphore :: IO (IO (), IO ())
+newSemaphore = (flip putMVar () &&& takeMVar) <$> newEmptyMVar
+
+
+type Combo = [String]
+
+nop :: a -> IO ()
+nop = const (return ())
+
+data State = State
+    { s_now :: UTCTime
+    , s_input :: String
+    , s_output :: [String]
+    , s_combo :: Combo
+    , s_combo_hist :: [(UTCTime, Either Combo Combo)]
+    , s_setTick :: Maybe Int -> IO ()
+    , s_hircBot :: Maybe Hirc.Bot
+    }
+
+newState :: State
+newState = State
+    { s_now = posixSecondsToUTCTime 0
+    , s_input = ""
+    , s_output = []
+    , s_combo = []
+    , s_combo_hist = []
+    , s_setTick = nop
+    , s_hircBot = Nothing
+    }
+
+
+cleanup :: State -> IO ()
+cleanup _q = do
+    hPutStrLn stdout ""
+    hSetEcho stdin True
+
+
+main :: IO ()
+main = bracket (return newState) cleanup $ \q0 -> do
+    hSetEcho stdin False
+    hSetBuffering stdin NoBuffering
+    hSetBuffering stdout (BlockBuffering $ Just 4096)
+
+    -- communication channels
+    (sendEvent, receiveEvent) <- newRelay
+    (shutdown, awaitShutdown) <- newSemaphore
+    (setTick, getTick) <- newSampler
+
+    let q1 = q0 { s_setTick = setTick }
+
+    mapM_ (\(s, f) -> installHandler s (Catch f) Nothing)
+        [ (sigINT, shutdown)
+        -- , (28, winchHandler sendEvent)
+        ]
+
+    threadIds <- mapM forkIO
+        [ forever $ scan stdin >>= sendEvent . EScan
+        , run receiveEvent q1
+        , runTick getTick sendEvent
+        , runIrc sendEvent ic
+        ]
+
+    awaitShutdown
+    mapM_ killThread threadIds
+
+  where
+    ic = Hirc.Config
+            { Hirc.config_server = Hirc.Server "cd.retiolum" 6667
+            , Hirc.config_nick = "hirc"
+            , Hirc.config_chan = "#hirc-testing"
+            }
+
+runIrc :: (Event -> IO ()) -> Hirc.Config -> IO ()
+runIrc sendEvent c =
+    Hirc.runBot c Hirc.Hooks
+        { Hirc.hooks_onConnect = onConnect
+        , Hirc.hooks_onDisconnect = onDisconnect
+        , Hirc.hooks_onError = onError
+        , Hirc.hooks_onMessage = onMessage
+        }
+  where
+    onConnect = do
+        liftIO $ sendEvent $ EPutLn "Hirc Connect"
+        bot <- ask
+        liftIO $ sendEvent $ EHircConnect bot
+        Hirc.read Hirc.bot_nick >>= \nick -> do
+            send "NICK" nick
+            send "USER" (nick ++ " 0 * :hirc bot")
+
+    onDisconnect = do
+        liftIO $ sendEvent $ EPutLn "Hirc Disconnect"
+
+    onError e =
+        liftIO
+            $ sendEvent $ EPutLn
+            $ pp $ SGR [31,1] $ "Hirc Error: " <> Plain (show e)
+
+    onMessage m = do
+        liftIO $ sendEvent (EPutLn $ Hirc.formatMessage m)
+
+send :: String -> String -> Hirc.Net ()
+send s t = do
+    h <- asks Hirc.bot_socket
+    --liftIO $ hPrintf h "%s %s\r\n" s t
+    liftIO $ hPutStr h $ s <> " " <> t <> "\r\n"
+    --liftIO $ printf    "> %s %s\n" s t
+    --liftIO $ printf    "> %s %s\n" s t
+
+
+
+runTick :: IO Int -> (Event -> IO ()) -> IO ()
+runTick getTick sendEvent = forever $ do
+    ms <- getTick
+    sendEvent ETick
+    threadDelay (ms * 1000)
+
+
+
+
+run :: IO Event -> State -> IO ()
+run receiveEvent = rec where
+    rec q = do
+      e <- receiveEvent
+      t <- getCurrentTime -- TODO put into receiveEvent
+      processEvent q { s_now = t } e >>= decay >>= print q >>= rec
+
+decay :: State -> IO State
+decay q@State{s_now=now,s_combo_hist=hist,s_setTick=setTick} = do
+    let hist' = filter ((<1000) . msAge now . fst) hist
+    when (length hist' == 0) $ do
+        setTick Nothing
+    return q
+        { s_combo_hist = hist'
+        }
+
+
+print :: State -> State -> IO State
+
+-- print pending output if any
+print _ q@State{s_output=xs@(_:_)} = do
+    let q' = q { s_output = [] }
+    mapM_ (flip putLn q') (map ("! "<>) xs)
+    flush q'
+    return q'
+
+-- otherwise check if command line has to be redrawn
+print State{s_combo=c0,s_input=i0} q@State{s_combo=c,s_input=i} = do
+    when needRedraw (redrawCmdLn q >> flush q)
+    return q
+  where
+    needRedraw = i0 /= i || c0 /= c
+
+
+
+acceptCombo :: State -> IO State
+acceptCombo q@State{s_setTick=setTick} = do
+    setTick (Just 100)
+    return q
+        { s_combo = []
+        , s_combo_hist = (s_now q, Right $ s_combo q) : s_combo_hist q
+        }
+
+rejectCombo :: State -> IO State
+rejectCombo q@State{s_setTick=setTick} = do
+    setTick (Just 100)
+    return q
+        { s_combo = []
+        , s_combo_hist = (s_now q, Left $ s_combo q) : s_combo_hist q
+        }
+
+
+onKey :: State -> IO State
+
+-- output non-empty input buffer
+onKey q@State{s_combo=["\n"],s_input=i@(_:_),s_output=o} = do
+    case s_hircBot q of
+        Just Hirc.Bot{Hirc.bot_socket=h} ->
+            hPutStr h $ i <> "\r\n"
+        Nothing -> return ()
+    acceptCombo q
+        { s_input = ""
+        , s_output = o ++ [i]
+        }
+
+-- delete char from input buffer
+onKey q@State{s_combo=["\DEL"],s_input=i@(_:_)} =
+    acceptCombo q { s_input = init i }
+
+-- append printable chars to the input buffer
+onKey q@State{s_combo=[k0],s_input=i} | length k0 == 1 && isPrint (k0!!0) =
+    acceptCombo q { s_input = i ++ k0 }
+
+-- cancel current combo
+onKey q@State{s_combo="\ESC":_:_}=
+    acceptCombo q { s_combo = ["\ESC"] }
+
+onKey q =
+    rejectCombo q
+
+
+processEvent :: State -> Event -> IO State
+processEvent q@State{s_now=_now} = \case
+    --EFlash t ->
+    --    return q { flashMessage = t }
+
+    EScan (ScanKey s) -> onKey q { s_combo = s : s_combo q }
+
+    EPutLn s -> do
+        putLn s q
+        flush q
+        return q
+
+    ETick -> do
+        --putLn ("Tick: " ++ show now) q
+        redrawCmdLn q
+        flush q
+        return q
+
+    EHircConnect b -> do
+        return q { s_hircBot = Just b }
+
+    EHircMessage m -> do
+        return q { s_output = s_output q ++ [show m] }
+
+    _ev ->
+        return q -- $ q ++ show ev
+        --    { flashMessage = SGR [31,1] $ Plain $ "unhandled event: " <> show ev
+        --    }
+
+bell :: State -> IO ()
+bell _q = do
+    hPutStr stdout "\a"
+
+redrawCmdLn :: State -> IO ()
+redrawCmdLn q = delCmdLn q >> putCmdLn q
+
+delCmdLn :: State -> IO ()
+delCmdLn _q = do
+    hPutStr stdout $ "\ESC[2K\ESC[666D"
+
+flush :: State -> IO ()
+flush _q = do
+    hFlush stdout
+
+putLn :: String -> State -> IO ()
+putLn s q = do
+    delCmdLn q
+    hPutStrLn stdout s
+    putCmdLn q
+
+putCmdLn :: State -> IO ()
+putCmdLn q@State{s_now=now} =do
+    hPutStr stdout $ ""
+        ++ "> "
+        ++ s_input q
+        ++ "\ESC[s"
+        ++ " " ++ pp (SGR [38,5,162] $ showCombo (s_combo q))
+        -- ++ " " ++ pp (showLastCombo (s_last_combo q))
+        ++ pp (mconcat
+                  $ map (showLastCombo now) (s_combo_hist q))
+        ++ "\ESC[u"
+
+-- TODO instance Show Combo
+showCombo :: Combo -> Blessings String
+showCombo ks = mconcat (concatMap (map renderChar) (reverse ks))
+
+showLastCombo :: UTCTime -> (UTCTime, Either Combo Combo) -> Blessings String
+showLastCombo now = \case
+    (t, Right ks) -> SGR [38,5,selectByAge ackColors t] (showCombo ks)
+    (t, Left ks)  -> SGR [38,5,selectByAge nakColors t] (showCombo ks)
+  where
+    selectByAge colors t = do
+        let ms = fromIntegral (msAge now t) :: Float
+            i = round (ms / 100)
+        if i < length colors
+            then colors !! i
+            else 234
+
+    ackColors = [ 46,  46,  46,  40,  34,  28,  22]
+    nakColors = [196, 196, 196, 160, 124,  88,  52]
+
+
+
+msAge :: UTCTime -> UTCTime -> Int
+msAge t2 t1 = do
+      let (s,ms) = properFraction (diffUTCTime t2 t1)
+      s * 1000 + round (ms * 1000)
+
+
+renderChar :: Char -> Blessings String
+renderChar c =
+    if isPrint c
+        then Plain [c]
+        else SGR [1] (Plain $ showLitChar c "")