diff options
Diffstat (limited to 'main.hs')
| -rw-r--r-- | main.hs | 326 |
1 files changed, 326 insertions, 0 deletions
@@ -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 "") |