DumbClient.hs

   1 -- This file is part of htalkat
   2 -- Copyright (C) 2021 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 module DumbClient (dumbClient) where
  12
  13 import           Control.Concurrent             (forkIO)
  14 import           Control.Exception              (bracket)
  15 import           Control.Monad                  (foldM_)
  16 import           System.IO
  17 import           System.IO.Unsafe               (unsafeInterleaveIO)
  18
  19 import qualified Data.ByteString                as BS
  20 import qualified Data.ByteString.Lazy           as BL
  21 import qualified Data.Text.Encoding.Error       as T
  22 import qualified Data.Text.Lazy                 as T
  23 import qualified Data.Text.Lazy.Encoding        as T
  24 import qualified Network.Socket                 as S
  25 import qualified Network.Socket.ByteString      as SS
  26 import qualified Network.Socket.ByteString.Lazy as SL
  27
  28 import           WCWidth
  29
  30 connectingNamedSocket :: FilePath -> (S.Socket -> IO a) -> IO a
  31 connectingNamedSocket path =
  32     (`bracket` S.close) $ do
  33         sock <- S.socket S.AF_UNIX S.Stream 0
  34         S.connect sock $ S.SockAddrUnix path
  35         pure sock
  36
  37 getContentsBS :: IO [BS.ByteString]
  38 getContentsBS = unsafeInterleaveIO $ do
  39     s <- BS.hGetSome stdin 256
  40     if BS.null s then pure []
  41         else (s :) <$> getContentsBS
  42
  43 dumbClient :: FilePath -> IO ()
  44 dumbClient path = connectingNamedSocket path $ \sock -> do
  45     _ <- forkIO $ do
  46         printWithErasures . T.decodeUtf8With T.lenientDecode . BL.drop 1 =<<
  47             SL.getContents sock
  48         putStrLn "\n[Connection closed; ^C to quit]"
  49     hSetBuffering stdin NoBuffering
  50     hSetEcho stdin False
  51     hSetBuffering stdout NoBuffering
  52     mapM_ (SS.sendAll sock) =<< getContentsBS
  53
  54 printWithErasures :: T.Text -> IO ()
  55 printWithErasures = mapM_ (doLine . T.unpack) . T.lines where
  56     doLine :: String -> IO ()
  57     doLine s = foldM_ go [] s >> putChar '\n'
  58
  59     go [] '\b'    = pure []
  60     go (h:t) '\b' = erase (charWidth h) >> pure t
  61     go s '\NAK'   = (erase . sum $ charWidth <$> s) >> pure []
  62     go s c        = putChar c >> pure (c:s)
  63
  64     -- This doesn't correctly erase wide characters which are wrapped onto the
  65     -- next line earlier than a normal char would have been.
  66     -- I don't see how to deal with that dumbly.
  67     erase n = putStr . concat $ replicate n "\b \b"
  68
  69     charWidth = max 0 . wcwidth