htalkat-0.1.2.2: CursesClient.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/.

{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

module CursesClient (cursesClient) where

import           Prelude                        hiding (lines)

import           Control.Concurrent
import           Control.Exception              (bracket, bracket_)
import           Control.Monad.State
import           Data.Char                      (isSpace)
import           Data.Function                  (on)
import           Data.Int                       (Int64)
import           Data.List                      (uncons, (\\))
import           Data.Maybe                     (fromMaybe)
import           Safe                           (headMay)
import           System.Exit                    (exitFailure)
import           System.IO                      (Handle, hFlush)
import           UI.HSCurses.Curses             hiding (ls)

import qualified Data.ByteString.Lazy.Char8     as BLC
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 Data.Text.Lazy.IO              as T
import qualified Network.Socket                 as S
import qualified Network.Socket.ByteString.Lazy as SL
import           UI.HSCurses.CursesHelper       as CH

import           Mundanities
import           Util
import           WCWidth

#ifndef WINDOWS
import           System.Posix.Signals
#endif

#if !(MIN_VERSION_base(4,11,0))
import           Data.Semigroup
#endif

newtype Reversed = Reversed {getReversed :: T.Text}

data StreamState = StreamState
    { streamWin     :: Window
    , streamLines   :: [T.Text]
    , streamHeights :: [Int]
    , streamCurLine :: Reversed
    , streamView    :: Int
    }

resetSS :: Int -> Window -> StreamState -> StreamState
resetSS w win ss = ss
    { streamWin = win
    , streamHeights = lineHeight w <$> streamLines ss
    , streamView = 0
    }

curLineHeight :: Int -> StreamState -> Int
curLineHeight w = lineHeight w . T.reverse . getReversed . streamCurLine

mapCurLine :: (T.Text -> T.Text) -> StreamState -> StreamState
mapCurLine f s = s { streamCurLine = Reversed . f . getReversed $ streamCurLine s }

allHeights :: Int -> StreamState -> [Int]
allHeights w ss = curLineHeight w ss : streamHeights ss

allLines :: StreamState -> [T.Text]
allLines ss = (T.reverse . getReversed $ streamCurLine ss) : streamLines ss

data TalkStream = OutStream | InStream
    deriving Eq

data CState = CState
    { otherName        :: String
    , connectionClosed :: Bool
    , monitor          :: Bool
    , logHandle        :: Maybe Handle
    , lastMoved        :: TalkStream
    , onTop            :: TalkStream
    , outStream        :: StreamState
    , inStream         :: StreamState
    }

initCState :: String -> TalkStream -> Maybe Handle -> (Window,Window) -> CState
initCState name top mLog (w,w') = CState
    { otherName = name
    , connectionClosed = False
    , monitor = False
    , lastMoved = OutStream
    , onTop = top
    , logHandle = mLog
    , outStream = emptySS $ if top == OutStream then w else w'
    , inStream = emptySS $ if top == InStream then w else w'
    } where emptySS x = StreamState x [] [] (Reversed "") 0

resetWindows :: Int -> TalkStream -> (Window,Window) -> CState -> CState
resetWindows ww top (w,w') =
    mapSS OutStream (resetSS ww $ winOf OutStream) .
    mapSS InStream (resetSS ww $ winOf InStream)
    where winOf str = if str == top then w else w'

getSS :: TalkStream -> CState -> StreamState
getSS OutStream = outStream
getSS InStream  = inStream

mapSS :: TalkStream -> (StreamState -> StreamState) -> CState -> CState
mapSS OutStream f ss = ss { outStream = f $ outStream ss }
mapSS InStream f ss  = ss { inStream = f $ inStream ss }


wcwidthNonNeg :: Char -> Int
wcwidthNonNeg = max 0 . wcwidth

wcLength :: T.Text -> Int
wcLength = sum . (wcwidthNonNeg <$>) . T.unpack


resetTerm :: IO ()
resetTerm = nl True >> raw False >> cBreak True

getGeom :: IO ((Int,Int),Int)
getGeom = do
    (lines,cols) <- scrSize
    let (d,m) = divMod lines 2
    pure ((d + m - 1, d), cols)

getWidth :: IO Int
getWidth = snd <$> getGeom

getDividerY :: IO Int
getDividerY = fst . fst <$> getGeom

checkSize :: IO ()
checkSize = do
    dy <- getDividerY
    ww <- getWidth
    when (dy == 0 || ww <= maxWCWidth) $
        CH.end >> putStrLn "Terminal too small." >> exitFailure
    where maxWCWidth = 2

initWindows :: IO (Window,Window)
initWindows = do
    ((wh,wh'),ww) <- getGeom
    liftM2 (,)
        (newWin wh (ww + 1) 0 0)
        (newWin wh' (ww + 1) (wh+1) 0)

data Event = InCharEv Char | KeyEv Key | ConnectionClosed | NeedReset | Quit
    deriving (Eq)

isQuit :: Event -> Bool
isQuit =
    -- Handle ^C, in case it doesn't generate a signal (as on windows?)
    (`elem` [Quit, KeyEv (KeyChar '\ETX')])

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

cursesClient :: Bool -> Maybe Handle -> String -> FilePath -> IO ()
cursesClient localTop mLog name path = connectingNamedSocket path $ \sock -> do
    charStream <- T.unpack . T.decodeUtf8With T.lenientDecode <$> SL.getContents sock
    putStrLn "Waiting for answer..."
    case uncons charStream of
        Nothing -> putStrLn "Connection closed."
        Just ('T', charStream') -> bracket_ CH.start CH.end $ do
            checkSize
            resetTerm
            eventChan <- newChan
#ifndef WINDOWS
            let suspHandler = CatchOnce $ do
                    raiseSignal sigTSTP
                    void installTSTP
                    writeChan eventChan NeedReset
                installTSTP = installHandler sigTSTP suspHandler Nothing
            _ <- installTSTP
            _ <- installHandler sigINT (Catch $ writeChan eventChan Quit) Nothing
#endif
            let top = if localTop then OutStream else InStream
            st <- initCState name top mLog <$> initWindows
            _ <- forkIO $ do
                mapM_ (writeChan eventChan . InCharEv) charStream'
                writeChan eventChan ConnectionClosed
            _ <- forkIO $ writeList2Chan eventChan . (KeyEv <$>) =<< getContentsCurses
            void . (`runStateT` st) $ do
                redrawAll
                mapM_ (handleEvent sock) . takeWhile (not . isQuit) =<<
                    liftIO (getChanContents eventChan)
        _ -> error "Impossible handshake char!"

-- hscurses doesn't bind get_wch, so we do utf8 decoding by hand.
getContentsCurses :: IO [Key]
getContentsCurses = do
    cChan <- newChan
    kChan <- newChan
    _ <- forkIO . forever $ getCh >>= \case
        (KeyChar c) -> writeChan cChan c
        k           -> writeChan kChan k
    _ <- forkIO . writeList2Chan kChan . (KeyChar <$>) .
        T.unpack . T.decodeUtf8With T.lenientDecode . BLC.concat . (BLC.singleton <$>) =<<
            getChanContents cChan
    getChanContents kChan

handleEvent :: S.Socket -> Event -> StateT CState IO ()
handleEvent _ (InCharEv c) = do
    gets monitor >>? do
        liftIO beep
        modify $ \cs -> cs { monitor = False }
        redrawIndicators
    addCharToStream InStream $ if allowedTalkatChar c then c else '?'
handleEvent _ (KeyEv (KeyChar '\DLE')) = -- ^P
    viewAddPg InStream 1
handleEvent _ (KeyEv (KeyChar '\SO')) = -- ^N
    viewAddPg InStream $ -1
handleEvent _ (KeyEv KeyPPage) = viewAddPg OutStream 1
handleEvent _ (KeyEv KeyNPage) = viewAddPg OutStream $ -1
handleEvent _ (KeyEv KeyUp) = modView InStream (+1)
handleEvent _ (KeyEv KeyDown) = modView InStream (+ (-1))
handleEvent _ (KeyEv KeyLeft) = modView OutStream (+1)
handleEvent _ (KeyEv KeyRight) = modView OutStream (+ (-1))
handleEvent sock (KeyEv (KeyChar '\ETB')) = do -- ^W
    l <- gets $ getReversed . streamCurLine . getSS OutStream
    let (spaces, rest) = break (> 0) . (fromIntegral . T.length <$>) $ T.split isSpace l
        n = length spaces + fromMaybe 0 (headMay rest)
    replicateM_ n $ handleEvent sock (KeyEv (KeyChar '\b'))
handleEvent _ (KeyEv (KeyChar '\a')) = do
    modify $ \cs -> cs { monitor = not $ monitor cs }
    redrawIndicators
handleEvent _ (KeyEv (KeyChar '\f')) = redrawAll
handleEvent sock (KeyEv k) | k `elem` [KeyBackspace, KeyDC, KeyChar '\DEL'] =
    handleEvent sock (KeyEv (KeyChar '\b'))
handleEvent sock (KeyEv KeyEnter) =
    handleEvent sock (KeyEv (KeyChar '\n'))
handleEvent _ (KeyEv KeyResize) = do
    liftIO checkSize
    forM_ [InStream,OutStream] $ \strm -> liftIO . delWin =<< gets (streamWin . getSS strm)
    ww <- liftIO $ CH.resizeui >> getWidth
    top <- gets onTop
    modify . resetWindows ww top =<< liftIO initWindows
    redrawAll
handleEvent sock (KeyEv (KeyChar c)) | allowedTalkatChar c =
    gets connectionClosed >>! do
        addCharToStream OutStream c
        liftIO . ignoreIOErr . SL.sendAll sock . T.encodeUtf8 $ T.singleton c
handleEvent _ (KeyEv _) = liftIO showHelp
handleEvent _ ConnectionClosed = do
    modify $ \cs -> cs { connectionClosed = True }
    redrawIndicators
handleEvent _ NeedReset = do
    liftIO resetTerm
    redrawAll
handleEvent _ _ = pure ()

allowedTalkatChar :: Char -> Bool
allowedTalkatChar c =
    -- disallow C0 control chars without special meaning
    -- (curses displays them with the wrong width)
    c `notElem` (['\0'..'\31'] \\ "\b\NAK\n")

addCharToStream :: TalkStream -> Char -> StateT CState IO ()
addCharToStream strm c = do
    modify (\cs -> cs { lastMoved = strm })
    case c of
        '\b' -> eraseLast strm 1
        '\NAK' -> do
            n <- gets $ T.length . getReversed . streamCurLine . getSS strm
            eraseLast strm n
        '\n' -> do
            ww <- liftIO getWidth
            curLine <- gets $ T.reverse . getReversed . streamCurLine . getSS strm
            modify . mapSS strm $ \ss -> ss
                { streamLines = curLine : streamLines ss
                , streamHeights = curLineHeight ww ss : streamHeights ss
                , streamCurLine = Reversed ""
                }
            maybe (pure ()) (liftIO . logLine strm curLine) =<< gets logHandle
            redrawStream strm
        _ -> do
            modify . mapSS strm $ mapCurLine (T.cons c)
            p <- gets (streamView . getSS strm)
            win <- gets $ streamWin . getSS strm
            (_,x) <- liftIO $ getYX win
            ww <- liftIO getWidth
            if x + wcwidthNonNeg c <= ww
                then when (p == 0) . liftIO $
                    wAddStr win [c] >> wRefresh win
                else redrawStream strm
    placeCursor

logLine :: TalkStream -> T.Text -> Handle -> IO ()
logLine strm s h = (>> hFlush h) . T.hPutStrLn h . (<> s) $ case strm of
    InStream  -> "<< "
    OutStream -> ">> "

redrawAll :: StateT CState IO ()
redrawAll = do
    liftIO $ wclear stdScr >> refresh
    forM_ [InStream,OutStream] redrawStream
    redrawIndicators
    placeCursor

placeCursor :: StateT CState IO ()
placeCursor = do
    lst <- gets lastMoved
    scrolled <- gets $ (>0) . streamView . getSS lst
    closed <- gets connectionClosed
    if scrolled || closed
        then liftIO $ do
            dy <- getDividerY
            wMove stdScr dy 0
        else
            liftIO . wRefresh =<< gets (streamWin . getSS lst)

redrawIndicators :: StateT CState IO ()
redrawIndicators = do
    ov <- gets $ streamView . getSS OutStream
    iv <- gets $ streamView . getSS InStream
    name <- gets otherName
    closed <- gets connectionClosed
    mtr <- gets monitor
    let os = if ov > 0 then "[you ^ " <> show ov <> "]" else ""
        is = "[" <> name <> (if iv > 0 then " ^ " <> show iv else "") <>
            (if mtr then "*" else "") <> "]"
        cs = "[Connection lost; ^C to quit]"
        csShort = "[Closed]"
    liftIO $ do
        ww <- getWidth
        dy <- getDividerY
        mvWAddStr stdScr dy 0 $ replicate ww '─'
        when closed $ do
            let drawCentred s = mvWAddStr stdScr dy ((ww - length s) `div` 2) s
            if ww > length cs + 4 then drawCentred cs
            else when (ww > length csShort + 4) $ drawCentred csShort
        when (ww > 12 + length is + length os + (if closed then length cs + 2 else 0)) $
            sequence_ [ unless (null s) $ mvWAddStr stdScr dy p s
                | (s,p) <- [(is,5), (os, ww - 5 - length os)] ]
        wMove stdScr dy 0
        refresh

showHelp :: IO ()
showHelp = do
    ww <- liftIO getWidth
    dy <- liftIO getDividerY
    mvWAddStr stdScr dy 0 $ replicate ww '─'
    mvWAddStr stdScr dy (max 1 ((ww - length helpStr) `div` 2)) $
        take (ww - 2) helpStr
    wMove stdScr dy 0
    refresh
    where helpStr = "^P/^N,PgUp/PgDn,arrows scroll; ^W/^U erase; ^C quit; ^G monitor; ^L redraw"


getStreamHeight :: TalkStream -> StateT CState IO Int
getStreamHeight strm = do
    top <- gets onTop
    ((wh,wh'),_) <- liftIO getGeom
    pure $ if top == strm then wh else wh'

redrawStream :: TalkStream -> StateT CState IO ()
redrawStream strm = do
    ww <- liftIO getWidth
    wh <- getStreamHeight strm
    ss <- gets $ getSS strm
    let v = streamView ss
        (len,n) = lenToSum (wh + v) $ allHeights ww ss
        ls = reverse . take len $ allLines ss
        pls = take wh . drop (n - (wh + v)) . concat $
            reverse . zip (False:repeat True) . reverse .
            wrap ww <$> ls
        win = streamWin ss
    liftIO $ do
        werase win
        sequence_ [ do
                mvWAddStr win y 0 $ T.unpack s
                when isWrap $ do
                    CH.wSetStyle win $ CH.mkCursesStyle [CH.Reverse]
                    mvWAddStr win y (ww-1) " "
                    CH.wResetStyle win
            | ((isWrap,s),y) <- zip pls [(wh - length pls) ..] ]
        wRefresh win
    where
    lenToSum :: (Num n, Ord n) => n -> [n] -> (Int,n)
    lenToSum m = go 0 0 where
        go l n (a:as) | n < m = go (l + 1) (n + a) as
        go l n _ = (l,n)


wrap :: Int -> T.Text -> [T.Text]
wrap wrapWidth _ | wrapWidth < 2 = error "Tried to wrap with too small width!"
wrap wrapWidth line = wrap' "" 0 . mergeSpaces $ T.groupBy ((==) `on` isSpace) line
    where
    mergeSpaces (s:ws) | isSpace (T.head s) = s : mergeSpaces ws
    mergeSpaces (w:s:ws) = (w <> s) : mergeSpaces ws
    mergeSpaces ws = ws

    wrap' l n ws | n > wrapWidth =
        let (a,b) = splitAtWC (wrapWidth - 1) l in a : wrap' b (n - wcLength a) ws
    wrap' l _ [] = [l]
    wrap' l n (w:ws) =
        let l' = l <> w
            nw = wcLength w
            n' = n + nw
        in if n' > wrapWidth
            then (if T.null l then id else (l:)) $ wrap' w nw ws
            else wrap' l' n' ws

    splitAtWC :: Int -> T.Text -> (T.Text,T.Text)
    splitAtWC m = go m T.empty where
        go !n !acc t
            | Just (c,r) <- T.uncons t = let w = max 0 $ wcwidth c in
                if w > max 0 n then (T.reverse acc,t)
                else go (n - w) (T.cons c acc) r
            | otherwise = (T.reverse acc, T.empty)

lineHeight :: Int -> T.Text -> Int
lineHeight w = length . wrap w

eraseLast :: TalkStream -> Int64 -> StateT CState IO ()
eraseLast strm n = do
    ss <- gets $ getSS strm
    ww <- liftIO getWidth
    p <- gets (streamView . getSS strm)
    let cur = getReversed $ streamCurLine ss
        mightDecreaseHeight =
            -- +1 to handle case of wrapping at double-width char
            wcLength cur + 1 > ww
        wErase = wcLength $ T.take n cur
    modify . mapSS strm . mapCurLine $ T.drop n
    if mightDecreaseHeight
        then redrawStream strm
        else when (p == 0) . liftIO $ do
            let win = streamWin ss
            (y,x) <- getYX win
            mvWAddStr win y (x - wErase) (replicate wErase ' ')
            wMove win y $ x - wErase
            wRefresh win


viewAddPg :: TalkStream -> Int -> StateT CState IO ()
viewAddPg strm n = do
    wh <- getStreamHeight strm
    modView strm (+ (n * wh))

modView :: TalkStream -> (Int -> Int) -> StateT CState IO ()
modView strm f = do
    ww <- liftIO getWidth
    wh <- getStreamHeight strm
    ss <- gets $ getSS strm
    let h = (+ (-wh)) . sum . allHeights ww $ ss
        oldView = streamView ss
        newView = max 0 . min h $ f oldView
    when (newView /= oldView) $ do
        modify . mapSS strm $ \s -> s { streamView = newView }
        redrawStream strm
        redrawIndicators
        placeCursor