summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Event.hs16
-rw-r--r--Hirc.hs6
-rw-r--r--Hirc/Bot.hs79
-rw-r--r--Hirc/Format.hs15
-rw-r--r--Hirc/Parser.hs8
-rw-r--r--Hirc/Types.hs43
-rw-r--r--hirc.hs111
-rw-r--r--main.hs326
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 "")