CursesClient.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 {-# LANGUAGE BangPatterns      #-}
  12 {-# LANGUAGE LambdaCase        #-}
  13 {-# LANGUAGE OverloadedStrings #-}
  14
  15 module CursesClient (cursesClient) where
  16
  17 import           Prelude                        hiding (lines)
  18
  19 import           Control.Concurrent
  20 import           Control.Exception              (bracket, bracket_)
  21 import           Control.Monad.State
  22 import           Data.Char                      (isSpace)
  23 import           Data.Function                  (on)
  24 import           Data.Int                       (Int64)
  25 import           Data.List                      (uncons, (\\))
  26 import           Data.Maybe                     (fromMaybe)
  27 import           Safe                           (headMay)
  28 import           System.Exit                    (exitFailure)
  29 import           System.IO                      (Handle, hFlush)
  30 import           UI.HSCurses.Curses             hiding (ls)
  31
  32 import qualified Data.ByteString.Lazy.Char8     as BLC
  33 import qualified Data.Text.Encoding.Error       as T
  34 import qualified Data.Text.Lazy                 as T
  35 import qualified Data.Text.Lazy.Encoding        as T
  36 import qualified Data.Text.Lazy.IO              as T
  37 import qualified Network.Socket                 as S
  38 import qualified Network.Socket.ByteString.Lazy as SL
  39 import           UI.HSCurses.CursesHelper       as CH
  40
  41 import           Mundanities
  42 import           Util
  43 import           WCWidth
  44
  45 #ifndef WINDOWS
  46 import           System.Posix.Signals
  47 #endif
  48
  49 #if !(MIN_VERSION_base(4,11,0))
  50 import           Data.Semigroup
  51 #endif
  52
  53 newtype Reversed = Reversed {getReversed :: T.Text}
  54
  55 data StreamState = StreamState
  56     { streamWin     :: Window
  57     , streamLines   :: [T.Text]
  58     , streamHeights :: [Int]
  59     , streamCurLine :: Reversed
  60     , streamView    :: Int
  61     }
  62
  63 resetSS :: Int -> Window -> StreamState -> StreamState
  64 resetSS w win ss = ss
  65     { streamWin = win
  66     , streamHeights = lineHeight w <$> streamLines ss
  67     , streamView = 0
  68     }
  69
  70 curLineHeight :: Int -> StreamState -> Int
  71 curLineHeight w = lineHeight w . T.reverse . getReversed . streamCurLine
  72
  73 mapCurLine :: (T.Text -> T.Text) -> StreamState -> StreamState
  74 mapCurLine f s = s { streamCurLine = Reversed . f . getReversed $ streamCurLine s }
  75
  76 allHeights :: Int -> StreamState -> [Int]
  77 allHeights w ss = curLineHeight w ss : streamHeights ss
  78
  79 allLines :: StreamState -> [T.Text]
  80 allLines ss = (T.reverse . getReversed $ streamCurLine ss) : streamLines ss
  81
  82 data TalkStream = OutStream | InStream
  83     deriving Eq
  84
  85 data CState = CState
  86     { otherName        :: String
  87     , connectionClosed :: Bool
  88     , monitor          :: Bool
  89     , logHandle        :: Maybe Handle
  90     , lastMoved        :: TalkStream
  91     , onTop            :: TalkStream
  92     , outStream        :: StreamState
  93     , inStream         :: StreamState
  94     }
  95
  96 initCState :: String -> TalkStream -> Maybe Handle -> (Window,Window) -> CState
  97 initCState name top mLog (w,w') = CState
  98     { otherName = name
  99     , connectionClosed = False
 100     , monitor = False
 101     , lastMoved = OutStream
 102     , onTop = top
 103     , logHandle = mLog
 104     , outStream = emptySS $ if top == OutStream then w else w'
 105     , inStream = emptySS $ if top == InStream then w else w'
 106     } where emptySS x = StreamState x [] [] (Reversed "") 0
 107
 108 resetWindows :: Int -> TalkStream -> (Window,Window) -> CState -> CState
 109 resetWindows ww top (w,w') =
 110     mapSS OutStream (resetSS ww $ winOf OutStream) .
 111     mapSS InStream (resetSS ww $ winOf InStream)
 112     where winOf str = if str == top then w else w'
 113
 114 getSS :: TalkStream -> CState -> StreamState
 115 getSS OutStream = outStream
 116 getSS InStream  = inStream
 117
 118 mapSS :: TalkStream -> (StreamState -> StreamState) -> CState -> CState
 119 mapSS OutStream f ss = ss { outStream = f $ outStream ss }
 120 mapSS InStream f ss  = ss { inStream = f $ inStream ss }
 121
 122
 123 wcwidthNonNeg :: Char -> Int
 124 wcwidthNonNeg = max 0 . wcwidth
 125
 126 wcLength :: T.Text -> Int
 127 wcLength = sum . (wcwidthNonNeg <$>) . T.unpack
 128
 129
 130 resetTerm :: IO ()
 131 resetTerm = nl True >> raw False >> cBreak True
 132
 133 getGeom :: IO ((Int,Int),Int)
 134 getGeom = do
 135     (lines,cols) <- scrSize
 136     let (d,m) = divMod lines 2
 137     pure ((d + m - 1, d), cols)
 138
 139 getWidth :: IO Int
 140 getWidth = snd <$> getGeom
 141
 142 getDividerY :: IO Int
 143 getDividerY = fst . fst <$> getGeom
 144
 145 checkSize :: IO ()
 146 checkSize = do
 147     dy <- getDividerY
 148     ww <- getWidth
 149     when (dy == 0 || ww <= maxWCWidth) $
 150         CH.end >> putStrLn "Terminal too small." >> exitFailure
 151     where maxWCWidth = 2
 152
 153 initWindows :: IO (Window,Window)
 154 initWindows = do
 155     ((wh,wh'),ww) <- getGeom
 156     liftM2 (,)
 157         (newWin wh (ww + 1) 0 0)
 158         (newWin wh' (ww + 1) (wh+1) 0)
 159
 160 data Event = InCharEv Char | KeyEv Key | ConnectionClosed | NeedReset | Quit
 161     deriving (Eq)
 162
 163 isQuit :: Event -> Bool
 164 isQuit =
 165     -- Handle ^C, in case it doesn't generate a signal (as on windows?)
 166     (`elem` [Quit, KeyEv (KeyChar '\ETX')])
 167
 168 connectingNamedSocket :: FilePath -> (S.Socket -> IO a) -> IO a
 169 connectingNamedSocket path =
 170     (`bracket` (`S.gracefulClose` 1000)) $ do
 171         sock <- S.socket S.AF_UNIX S.Stream 0
 172         S.connect sock $ S.SockAddrUnix path
 173         pure sock
 174
 175 cursesClient :: Bool -> Maybe Handle -> String -> FilePath -> IO ()
 176 cursesClient localTop mLog name path = connectingNamedSocket path $ \sock -> do
 177     charStream <- T.unpack . T.decodeUtf8With T.lenientDecode <$> SL.getContents sock
 178     putStrLn "Waiting for answer..."
 179     case uncons charStream of
 180         Nothing -> putStrLn "Connection closed."
 181         Just ('T', charStream') -> bracket_ CH.start CH.end $ do
 182             checkSize
 183             resetTerm
 184             eventChan <- newChan
 185 #ifndef WINDOWS
 186             let suspHandler = CatchOnce $ do
 187                     raiseSignal sigTSTP
 188                     void installTSTP
 189                     writeChan eventChan NeedReset
 190                 installTSTP = installHandler sigTSTP suspHandler Nothing
 191             _ <- installTSTP
 192             _ <- installHandler sigINT (Catch $ writeChan eventChan Quit) Nothing
 193 #endif
 194             let top = if localTop then OutStream else InStream
 195             st <- initCState name top mLog <$> initWindows
 196             _ <- forkIO $ do
 197                 mapM_ (writeChan eventChan . InCharEv) charStream'
 198                 writeChan eventChan ConnectionClosed
 199             _ <- forkIO $ writeList2Chan eventChan . (KeyEv <$>) =<< getContentsCurses
 200             void . (`runStateT` st) $ do
 201                 redrawAll
 202                 mapM_ (handleEvent sock) . takeWhile (not . isQuit) =<<
 203                     liftIO (getChanContents eventChan)
 204         _ -> error "Impossible handshake char!"
 205
 206 -- hscurses doesn't bind get_wch, so we do utf8 decoding by hand.
 207 getContentsCurses :: IO [Key]
 208 getContentsCurses = do
 209     cChan <- newChan
 210     kChan <- newChan
 211     _ <- forkIO . forever $ getCh >>= \case
 212         (KeyChar c) -> writeChan cChan c
 213         k           -> writeChan kChan k
 214     _ <- forkIO . writeList2Chan kChan . (KeyChar <$>) .
 215         T.unpack . T.decodeUtf8With T.lenientDecode . BLC.concat . (BLC.singleton <$>) =<<
 216             getChanContents cChan
 217     getChanContents kChan
 218
 219 handleEvent :: S.Socket -> Event -> StateT CState IO ()
 220 handleEvent _ (InCharEv c) = do
 221     gets monitor >>? do
 222         liftIO beep
 223         modify $ \cs -> cs { monitor = False }
 224         redrawIndicators
 225     addCharToStream InStream $ if allowedTalkatChar c then c else '?'
 226 handleEvent _ (KeyEv (KeyChar '\DLE')) = -- ^P
 227     viewAddPg InStream 1
 228 handleEvent _ (KeyEv (KeyChar '\SO')) = -- ^N
 229     viewAddPg InStream $ -1
 230 handleEvent _ (KeyEv KeyPPage) = viewAddPg OutStream 1
 231 handleEvent _ (KeyEv KeyNPage) = viewAddPg OutStream $ -1
 232 handleEvent _ (KeyEv KeyUp) = modView InStream (+1)
 233 handleEvent _ (KeyEv KeyDown) = modView InStream (+ (-1))
 234 handleEvent _ (KeyEv KeyLeft) = modView OutStream (+1)
 235 handleEvent _ (KeyEv KeyRight) = modView OutStream (+ (-1))
 236 handleEvent sock (KeyEv (KeyChar '\ETB')) = do -- ^W
 237     l <- gets $ getReversed . streamCurLine . getSS OutStream
 238     let (spaces, rest) = break (> 0) . (fromIntegral . T.length <$>) $ T.split isSpace l
 239         n = length spaces + fromMaybe 0 (headMay rest)
 240     replicateM_ n $ handleEvent sock (KeyEv (KeyChar '\b'))
 241 handleEvent _ (KeyEv (KeyChar '\a')) = do
 242     modify $ \cs -> cs { monitor = not $ monitor cs }
 243     redrawIndicators
 244 handleEvent _ (KeyEv (KeyChar '\f')) = redrawAll
 245 handleEvent sock (KeyEv k) | k `elem` [KeyBackspace, KeyDC, KeyChar '\DEL'] =
 246     handleEvent sock (KeyEv (KeyChar '\b'))
 247 handleEvent sock (KeyEv KeyEnter) =
 248     handleEvent sock (KeyEv (KeyChar '\n'))
 249 handleEvent _ (KeyEv KeyResize) = do
 250     liftIO checkSize
 251     forM_ [InStream,OutStream] $ \strm -> liftIO . delWin =<< gets (streamWin . getSS strm)
 252     ww <- liftIO $ CH.resizeui >> getWidth
 253     top <- gets onTop
 254     modify . resetWindows ww top =<< liftIO initWindows
 255     redrawAll
 256 handleEvent sock (KeyEv (KeyChar c)) | allowedTalkatChar c =
 257     gets connectionClosed >>! do
 258         addCharToStream OutStream c
 259         liftIO . ignoreIOErr . SL.sendAll sock . T.encodeUtf8 $ T.singleton c
 260 handleEvent _ (KeyEv _) = liftIO showHelp
 261 handleEvent _ ConnectionClosed = do
 262     modify $ \cs -> cs { connectionClosed = True }
 263     redrawIndicators
 264 handleEvent _ NeedReset = do
 265     liftIO resetTerm
 266     redrawAll
 267 handleEvent _ _ = pure ()
 268
 269 allowedTalkatChar :: Char -> Bool
 270 allowedTalkatChar c =
 271     -- disallow C0 control chars without special meaning
 272     -- (curses displays them with the wrong width)
 273     c `notElem` (['\0'..'\31'] \\ "\b\NAK\n")
 274
 275 addCharToStream :: TalkStream -> Char -> StateT CState IO ()
 276 addCharToStream strm c = do
 277     modify (\cs -> cs { lastMoved = strm })
 278     case c of
 279         '\b' -> eraseLast strm 1
 280         '\NAK' -> do
 281             n <- gets $ T.length . getReversed . streamCurLine . getSS strm
 282             eraseLast strm n
 283         '\n' -> do
 284             ww <- liftIO getWidth
 285             curLine <- gets $ T.reverse . getReversed . streamCurLine . getSS strm
 286             modify . mapSS strm $ \ss -> ss
 287                 { streamLines = curLine : streamLines ss
 288                 , streamHeights = curLineHeight ww ss : streamHeights ss
 289                 , streamCurLine = Reversed ""
 290                 }
 291             maybe (pure ()) (liftIO . logLine strm curLine) =<< gets logHandle
 292             redrawStream strm
 293         _ -> do
 294             modify . mapSS strm $ mapCurLine (T.cons c)
 295             p <- gets (streamView . getSS strm)
 296             win <- gets $ streamWin . getSS strm
 297             (_,x) <- liftIO $ getYX win
 298             ww <- liftIO getWidth
 299             if x + wcwidthNonNeg c <= ww
 300                 then when (p == 0) . liftIO $
 301                     wAddStr win [c] >> wRefresh win
 302                 else redrawStream strm
 303     placeCursor
 304
 305 logLine :: TalkStream -> T.Text -> Handle -> IO ()
 306 logLine strm s h = (>> hFlush h) . T.hPutStrLn h . (<> s) $ case strm of
 307     InStream  -> "<< "
 308     OutStream -> ">> "
 309
 310 redrawAll :: StateT CState IO ()
 311 redrawAll = do
 312     liftIO $ wclear stdScr >> refresh
 313     forM_ [InStream,OutStream] redrawStream
 314     redrawIndicators
 315     placeCursor
 316
 317 placeCursor :: StateT CState IO ()
 318 placeCursor = do
 319     lst <- gets lastMoved
 320     scrolled <- gets $ (>0) . streamView . getSS lst
 321     closed <- gets connectionClosed
 322     if scrolled || closed
 323         then liftIO $ do
 324             dy <- getDividerY
 325             wMove stdScr dy 0
 326         else
 327             liftIO . wRefresh =<< gets (streamWin . getSS lst)
 328
 329 redrawIndicators :: StateT CState IO ()
 330 redrawIndicators = do
 331     ov <- gets $ streamView . getSS OutStream
 332     iv <- gets $ streamView . getSS InStream
 333     name <- gets otherName
 334     closed <- gets connectionClosed
 335     mtr <- gets monitor
 336     let os = if ov > 0 then "[you ^ " <> show ov <> "]" else ""
 337         is = "[" <> name <> (if iv > 0 then " ^ " <> show iv else "") <>
 338             (if mtr then "*" else "") <> "]"
 339         cs = "[Connection lost; ^C to quit]"
 340         csShort = "[Closed]"
 341     liftIO $ do
 342         ww <- getWidth
 343         dy <- getDividerY
 344         mvWAddStr stdScr dy 0 $ replicate ww '─'
 345         when closed $ do
 346             let drawCentred s = mvWAddStr stdScr dy ((ww - length s) `div` 2) s
 347             if ww > length cs + 4 then drawCentred cs
 348             else when (ww > length csShort + 4) $ drawCentred csShort
 349         when (ww > 12 + length is + length os + (if closed then length cs + 2 else 0)) $
 350             sequence_ [ unless (null s) $ mvWAddStr stdScr dy p s
 351                 | (s,p) <- [(is,5), (os, ww - 5 - length os)] ]
 352         wMove stdScr dy 0
 353         refresh
 354
 355 showHelp :: IO ()
 356 showHelp = do
 357     ww <- liftIO getWidth
 358     dy <- liftIO getDividerY
 359     mvWAddStr stdScr dy 0 $ replicate ww '─'
 360     mvWAddStr stdScr dy (max 1 ((ww - length helpStr) `div` 2)) $
 361         take (ww - 2) helpStr
 362     wMove stdScr dy 0
 363     refresh
 364     where helpStr = "^P/^N,PgUp/PgDn,arrows scroll; ^W/^U erase; ^C quit; ^G monitor; ^L redraw"
 365
 366
 367 getStreamHeight :: TalkStream -> StateT CState IO Int
 368 getStreamHeight strm = do
 369     top <- gets onTop
 370     ((wh,wh'),_) <- liftIO getGeom
 371     pure $ if top == strm then wh else wh'
 372
 373 redrawStream :: TalkStream -> StateT CState IO ()
 374 redrawStream strm = do
 375     ww <- liftIO getWidth
 376     wh <- getStreamHeight strm
 377     ss <- gets $ getSS strm
 378     let v = streamView ss
 379         (len,n) = lenToSum (wh + v) $ allHeights ww ss
 380         ls = reverse . take len $ allLines ss
 381         pls = take wh . drop (n - (wh + v)) $ concatMap
 382             (reverse . zip (False:repeat True) . reverse . wrap ww) ls
 383         win = streamWin ss
 384     liftIO $ do
 385         werase win
 386         sequence_ [ do
 387                 mvWAddStr win y 0 $ T.unpack s
 388                 when isWrap $ do
 389                     CH.wSetStyle win $ CH.mkCursesStyle [CH.Reverse]
 390                     mvWAddStr win y (ww-1) " "
 391                     CH.wResetStyle win
 392             | ((isWrap,s),y) <- zip pls [(wh - length pls) ..] ]
 393         wRefresh win
 394     where
 395     lenToSum :: (Num n, Ord n) => n -> [n] -> (Int,n)
 396     lenToSum m = go 0 0 where
 397         go l n (a:as) | n < m = go (l + 1) (n + a) as
 398         go l n _ = (l,n)
 399
 400
 401 wrap :: Int -> T.Text -> [T.Text]
 402 wrap wrapWidth _ | wrapWidth < 2 = error "Tried to wrap with too small width!"
 403 wrap wrapWidth line = wrap' "" 0 . mergeSpaces $ T.groupBy ((==) `on` isSpace) line
 404     where
 405     mergeSpaces (s:ws) | isSpace (T.head s) = s : mergeSpaces ws
 406     mergeSpaces (w:s:ws) = (w <> s) : mergeSpaces ws
 407     mergeSpaces ws = ws
 408
 409     wrap' l n ws | n > wrapWidth =
 410         let (a,b) = splitAtWC (wrapWidth - 1) l in a : wrap' b (n - wcLength a) ws
 411     wrap' l _ [] = [l]
 412     wrap' l n (w:ws) =
 413         let l' = l <> w
 414             nw = wcLength w
 415             n' = n + nw
 416         in if n' > wrapWidth
 417             then (if T.null l then id else (l:)) $ wrap' w nw ws
 418             else wrap' l' n' ws
 419
 420     splitAtWC :: Int -> T.Text -> (T.Text,T.Text)
 421     splitAtWC m = go m T.empty where
 422         go !n !acc t
 423             | Just (c,r) <- T.uncons t = let w = max 0 $ wcwidth c in
 424                 if w > max 0 n then (T.reverse acc,t)
 425                 else go (n - w) (T.cons c acc) r
 426             | otherwise = (T.reverse acc, T.empty)
 427
 428 lineHeight :: Int -> T.Text -> Int
 429 lineHeight w = length . wrap w
 430
 431 eraseLast :: TalkStream -> Int64 -> StateT CState IO ()
 432 eraseLast strm n = do
 433     ss <- gets $ getSS strm
 434     ww <- liftIO getWidth
 435     p <- gets (streamView . getSS strm)
 436     let cur = getReversed $ streamCurLine ss
 437         mightDecreaseHeight =
 438             -- +1 to handle case of wrapping at double-width char
 439             wcLength cur + 1 > ww
 440         wErase = wcLength $ T.take n cur
 441     modify . mapSS strm . mapCurLine $ T.drop n
 442     if mightDecreaseHeight
 443         then redrawStream strm
 444         else when (p == 0) . liftIO $ do
 445             let win = streamWin ss
 446             (y,x) <- getYX win
 447             mvWAddStr win y (x - wErase) (replicate wErase ' ')
 448             wMove win y $ x - wErase
 449             wRefresh win
 450
 451
 452 viewAddPg :: TalkStream -> Int -> StateT CState IO ()
 453 viewAddPg strm n = do
 454     wh <- getStreamHeight strm
 455     modView strm (+ (n * wh))
 456
 457 modView :: TalkStream -> (Int -> Int) -> StateT CState IO ()
 458 modView strm f = do
 459     ww <- liftIO getWidth
 460     wh <- getStreamHeight strm
 461     ss <- gets $ getSS strm
 462     let h = (+ (-wh)) . sum . allHeights ww $ ss
 463         oldView = streamView ss
 464         newView = max 0 . min h $ f oldView
 465     when (newView /= oldView) $ do
 466         modify . mapSS strm $ \s -> s { streamView = newView }
 467         redrawStream strm
 468         redrawIndicators
 469         placeCursor