From ef344c57945d455c6752c2032c701d7f9315f69b Mon Sep 17 00:00:00 2001 From: tv Date: Sat, 17 Oct 2015 19:08:15 +0200 Subject: replace hirc.hs by main.hs --- Event.hs | 16 +++ Hirc.hs | 6 ++ Hirc/Bot.hs | 79 ++++++++++++++ Hirc/Format.hs | 15 +++ Hirc/Parser.hs | 8 ++ Hirc/Types.hs | 43 ++++++++ hirc.hs | 111 -------------------- main.hs | 326 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 8 files changed, 493 insertions(+), 111 deletions(-) create mode 100644 Event.hs create mode 100644 Hirc.hs create mode 100644 Hirc/Bot.hs create mode 100644 Hirc/Format.hs delete mode 100644 hirc.hs create mode 100644 main.hs 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 "") -- cgit v1.2.3