path: root/main.hs

{-# 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 "")