module THSH.Internal.ProcessUtils
  ( binaryCat, binaryCat'
  , pollProcessExitCode
  ) where

import           Control.Concurrent (threadDelay, yield)
import           Control.Monad      (unless)
import           Foreign            (Ptr, allocaBytes)
import           System.Exit        (ExitCode)
import           System.IO
import           System.Process     (ProcessHandle, getProcessExitCode)


binaryCat :: Handle -> Handle -> IO ()
binaryCat :: Handle -> Handle -> IO ()
binaryCat Handle
hr Handle
hw = Int -> (Ptr Any -> IO ()) -> IO ()
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
cBUFFER_SIZE (String -> Handle -> Handle -> Ptr Any -> IO ()
forall a. String -> Handle -> Handle -> Ptr a -> IO ()
binary_cat_with_ptr String
"" Handle
hr Handle
hw)

binaryCat' :: String -> Handle -> Handle -> IO ()
binaryCat' :: String -> Handle -> Handle -> IO ()
binaryCat' String
l Handle
hr Handle
hw = Int -> (Ptr Any -> IO ()) -> IO ()
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
cBUFFER_SIZE (String -> Handle -> Handle -> Ptr Any -> IO ()
forall a. String -> Handle -> Handle -> Ptr a -> IO ()
binary_cat_with_ptr String
l Handle
hr Handle
hw)

pollProcessExitCode :: ProcessHandle -> IO ExitCode
pollProcessExitCode :: ProcessHandle -> IO ExitCode
pollProcessExitCode ProcessHandle
ph = ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
ph IO (Maybe ExitCode)
-> (Maybe ExitCode -> IO ExitCode) -> IO ExitCode
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe ExitCode
Nothing -> IO ()
yield IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
threadDelay Int
cPROCESS_POLL_INTERVAL IO () -> IO ExitCode -> IO ExitCode
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProcessHandle -> IO ExitCode
pollProcessExitCode ProcessHandle
ph
  Just ExitCode
ec -> ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
ec

{- INTERNAL FUNCTIONS -}

cPROCESS_POLL_INTERVAL :: Int
cPROCESS_POLL_INTERVAL :: Int
cPROCESS_POLL_INTERVAL = Int
10_000

-- https://stackoverflow.com/questions/68639266/size-of-buffered-input-in-c
-- By many accounts, it seems "gnu cat" uses 128 KB as buffer size
cBUFFER_SIZE :: Int
cBUFFER_SIZE :: Int
cBUFFER_SIZE = Int
128 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024

binary_cat_with_ptr :: String -> Handle -> Handle -> Ptr a -> IO ()
binary_cat_with_ptr :: forall a. String -> Handle -> Handle -> Ptr a -> IO ()
binary_cat_with_ptr String
l Handle
hr Handle
hw Ptr a
ptr = IO ()
go where
  go :: IO ()
go = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (String -> IO ()
put_err_ln (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"!! cat " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
l String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" go")
    Int
n <- Handle -> Ptr a -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBufSome Handle
hr Ptr a
ptr Int
cBUFFER_SIZE
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (String -> IO ()
put_err_ln (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"!! cat " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
l String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" n " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Ptr a -> Int -> IO ()
forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
hw Ptr a
ptr Int
n IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
go

put_err_ln :: String -> IO ()
put_err_ln :: String -> IO ()
put_err_ln = Handle -> String -> IO ()
hPutStrLn Handle
stderr