htalkat-0.1.1: DumbClient.hs

-- This file is part of htalkat
-- Copyright (C) 2021 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program.  If not, see http://www.gnu.org/licenses/.

module DumbClient (dumbClient) where

import           Control.Concurrent             (forkIO)
import           Control.Exception              (bracket)
import           Control.Monad                  (foldM_)
import           System.IO
import           System.IO.Unsafe               (unsafeInterleaveIO)

import qualified Data.ByteString                as BS
import qualified Data.ByteString.Lazy           as BL
import qualified Data.Text.Encoding.Error       as T
import qualified Data.Text.Lazy                 as T
import qualified Data.Text.Lazy.Encoding        as T
import qualified Network.Socket                 as S
import qualified Network.Socket.ByteString      as SS
import qualified Network.Socket.ByteString.Lazy as SL

import           WCWidth

connectingNamedSocket :: FilePath -> (S.Socket -> IO a) -> IO a
connectingNamedSocket path =
    (`bracket` S.close) $ do
        sock <- S.socket S.AF_UNIX S.Stream 0
        S.connect sock $ S.SockAddrUnix path
        pure sock

getContentsBS :: IO [BS.ByteString]
getContentsBS = unsafeInterleaveIO $ do
    s <- BS.hGetSome stdin 256
    if BS.null s then pure []
        else (s :) <$> getContentsBS

dumbClient :: FilePath -> IO ()
dumbClient path = connectingNamedSocket path $ \sock -> do
    _ <- forkIO $ do
        printWithErasures . T.decodeUtf8With T.lenientDecode . BL.drop 1 =<<
            SL.getContents sock
        putStrLn "\n[Connection closed; ^C to quit]"
    hSetBuffering stdin NoBuffering
    hSetEcho stdin False
    hSetBuffering stdout NoBuffering
    mapM_ (SS.sendAll sock) =<< getContentsBS

printWithErasures :: T.Text -> IO ()
printWithErasures = mapM_ (doLine . T.unpack) . T.lines where
    doLine :: String -> IO ()
    doLine = foldM_ go []

    go [] '\b'    = pure []
    go (h:t) '\b' = erase (charWidth h) >> pure t
    go s '\NAK'   = (erase . sum $ charWidth <$> s) >> pure []
    go s c        = putChar c >> pure (c:s)

    -- This doesn't correctly erase wide characters which are wrapped onto the
    -- next line earlier than a normal char would have been.
    -- I don't see how to deal with that dumbly.
    erase n = putStr . concat $ replicate n "\b \b"

    charWidth = max 0 . wcwidth