module Z.IO.StdStream
(
StdStream
, getStdStreamFD
, isStdStreamTTY
, setStdinTTYMode
, getStdoutWinSize
, stdin, stdout, stderr
, stdinBuf, stdoutBuf, stderrBuf
, readStd, printStd, putStd
, withMVar
, TTYMode
, pattern TTY_MODE_NORMAL
, pattern TTY_MODE_RAW
) where
import Control.Monad
import Control.Concurrent.MVar
import Foreign.Ptr
import System.IO.Unsafe
import qualified Z.Data.Builder as B
import qualified Z.Data.Text.Print as T
import qualified Z.Data.Vector as V
import Z.IO.UV.FFI
import Z.IO.UV.Manager
import Z.IO.UV.Errno
import Z.IO.Exception
import Z.IO.Buffered
import Z.Foreign
data StdStream
= StdStream Bool {-# UNPACK #-}!(Ptr UVHandle) {-# UNPACK #-}!UVSlot UVManager
| StdFile {-# UNPACK #-}!FD
instance Show StdStream where show :: StdStream -> String
show = StdStream -> String
forall a. Print a => a -> String
T.toString
instance T.Print StdStream where
{-# INLINE toUTF8BuilderP #-}
toUTF8BuilderP :: Int -> StdStream -> Builder ()
toUTF8BuilderP Int
p (StdStream Bool
istty Ptr UVHandle
ptr Int
slot UVManager
uvm) = Bool -> Builder () -> Builder ()
T.parenWhen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
if Bool
istty
then Builder ()
"StdStream(TTY) "
else Builder ()
"StdStream "
Ptr UVHandle -> Builder ()
forall a. Print a => a -> Builder ()
T.toUTF8Builder Ptr UVHandle
ptr
Char -> Builder ()
T.char7 Char
' '
Int -> Builder ()
forall a. Print a => a -> Builder ()
T.toUTF8Builder Int
slot
Char -> Builder ()
T.char7 Char
' '
Int -> UVManager -> Builder ()
forall a. Print a => Int -> a -> Builder ()
T.toUTF8BuilderP Int
11 UVManager
uvm
toUTF8BuilderP Int
p (StdFile FD
fd) = Bool -> Builder () -> Builder ()
T.parenWhen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Builder () -> Builder ()) -> Builder () -> Builder ()
forall a b. (a -> b) -> a -> b
$ do
Builder ()
"StdFile "
FD -> Builder ()
forall a. Print a => a -> Builder ()
T.toUTF8Builder FD
fd
isStdStreamTTY :: StdStream -> Bool
isStdStreamTTY :: StdStream -> Bool
isStdStreamTTY (StdStream Bool
istty Ptr UVHandle
_ Int
_ UVManager
_) = Bool
istty
isStdStreamTTY StdStream
_ = Bool
False
getStdStreamFD :: StdStream -> IO FD
getStdStreamFD :: StdStream -> IO FD
getStdStreamFD (StdStream Bool
_ Ptr UVHandle
hdl Int
_ UVManager
_) = IO FD -> IO FD
forall a. (HasCallStack, Integral a) => IO a -> IO a
throwUVIfMinus (Ptr UVHandle -> IO FD
hs_uv_fileno Ptr UVHandle
hdl)
getStdStreamFD (StdFile FD
fd) = FD -> IO FD
forall (m :: * -> *) a. Monad m => a -> m a
return FD
fd
instance Input StdStream where
{-# INLINE readInput #-}
readInput :: StdStream -> Ptr Word8 -> Int -> IO Int
readInput (StdStream Bool
_ Ptr UVHandle
hdl Int
slot UVManager
uvm) Ptr Word8
buf Int
len = IO Int -> IO Int
forall a. IO a -> IO a
mask_ (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ do
UVManager -> Int -> Ptr Word8 -> Int -> IO ()
pokeBufferTable UVManager
uvm Int
slot Ptr Word8
buf Int
len
MVar Int
m <- UVManager -> Int -> IO (MVar Int)
getBlockMVar UVManager
uvm Int
slot
Maybe Int
_ <- MVar Int -> IO (Maybe Int)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Int
m
IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (IO FD -> IO ()) -> IO FD -> IO ()
forall a b. (a -> b) -> a -> b
$ UVManager -> IO FD -> IO FD
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (Ptr UVHandle -> IO FD
hs_uv_read_start Ptr UVHandle
hdl)
Int
r <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
m IO Int -> IO () -> IO Int
forall a b. IO a -> IO b -> IO a
`onException` (do
FD
_ <- UVManager -> IO FD -> IO FD
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (Ptr UVHandle -> IO FD
uv_read_stop Ptr UVHandle
hdl)
IO (Maybe Int) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (MVar Int -> IO (Maybe Int)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Int
m))
if | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
r
| Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== FD -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral FD
UV_EOF -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
| Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> IO Int -> IO Int
forall a. (HasCallStack, Integral a) => IO a -> IO a
throwUVIfMinus (Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
r)
| Bool
otherwise -> FD -> IOEInfo -> IO Int
forall a. FD -> IOEInfo -> IO a
throwUVError FD
UV_UNKNOWN IOEInfo :: Text -> Text -> CallStack -> IOEInfo
IOEInfo{
ioeName :: Text
ioeName = Text
"StdStream read error"
, ioeDescription :: Text
ioeDescription = Text
"StdStream read should never return 0 before EOF"
, ioeCallStack :: CallStack
ioeCallStack = CallStack
HasCallStack => CallStack
callStack
}
readInput (StdFile FD
fd) Ptr Word8
buf Int
len =
IO Int -> IO Int
forall a. (HasCallStack, Integral a) => IO a -> IO a
throwUVIfMinus (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ FD -> Ptr Word8 -> Int -> Int64 -> IO Int
hs_uv_fs_read FD
fd Ptr Word8
buf Int
len (-Int64
1)
instance Output StdStream where
{-# INLINE writeOutput #-}
writeOutput :: StdStream -> Ptr Word8 -> Int -> IO ()
writeOutput (StdStream Bool
_ Ptr UVHandle
hdl Int
_ UVManager
uvm) Ptr Word8
buf Int
len = IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
MVar Int
m <- UVManager -> IO (MVar Int) -> IO (MVar Int)
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (IO (MVar Int) -> IO (MVar Int)) -> IO (MVar Int) -> IO (MVar Int)
forall a b. (a -> b) -> a -> b
$ do
Int
reqSlot <- HasCallStack => UVManager -> IO UVSlotUnsafe -> IO Int
UVManager -> IO UVSlotUnsafe -> IO Int
getUVSlot UVManager
uvm (Ptr UVHandle -> Ptr Word8 -> Int -> IO UVSlotUnsafe
hs_uv_write Ptr UVHandle
hdl Ptr Word8
buf Int
len)
MVar Int
m <- UVManager -> Int -> IO (MVar Int)
getBlockMVar UVManager
uvm Int
reqSlot
Maybe Int
_ <- MVar Int -> IO (Maybe Int)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Int
m
MVar Int -> IO (MVar Int)
forall (m :: * -> *) a. Monad m => a -> m a
return MVar Int
m
IO Int -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (IO Int -> IO Int
forall a. IO a -> IO a
uninterruptibleMask_ (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
m)
writeOutput (StdFile FD
fd) Ptr Word8
buf Int
len = Ptr Word8 -> Int -> IO ()
go Ptr Word8
buf Int
len
where
go :: Ptr Word8 -> Int -> IO ()
go !Ptr Word8
b !Int
bufSiz = do
Int
written <- IO Int -> IO Int
forall a. (HasCallStack, Integral a) => IO a -> IO a
throwUVIfMinus
(FD -> Ptr Word8 -> Int -> Int64 -> IO Int
hs_uv_fs_write FD
fd Ptr Word8
b Int
bufSiz (-Int64
1))
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
written Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bufSiz)
(Ptr Word8 -> Int -> IO ()
go (Ptr Word8
b Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
written) (Int
bufSizInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
written))
stdin :: StdStream
{-# NOINLINE stdin #-}
stdin :: StdStream
stdin = IO StdStream -> StdStream
forall a. IO a -> a
unsafePerformIO (HasCallStack => FD -> IO StdStream
FD -> IO StdStream
makeStdStream FD
0)
stdout :: StdStream
{-# NOINLINE stdout #-}
stdout :: StdStream
stdout = IO StdStream -> StdStream
forall a. IO a -> a
unsafePerformIO (HasCallStack => FD -> IO StdStream
FD -> IO StdStream
makeStdStream FD
1)
stderr :: StdStream
{-# NOINLINE stderr #-}
stderr :: StdStream
stderr = IO StdStream -> StdStream
forall a. IO a -> a
unsafePerformIO (HasCallStack => FD -> IO StdStream
FD -> IO StdStream
makeStdStream FD
2)
stdinBuf :: MVar BufferedInput
{-# NOINLINE stdinBuf #-}
stdinBuf :: MVar BufferedInput
stdinBuf = IO (MVar BufferedInput) -> MVar BufferedInput
forall a. IO a -> a
unsafePerformIO (StdStream -> IO BufferedInput
forall i. Input i => i -> IO BufferedInput
newBufferedInput StdStream
stdin IO BufferedInput
-> (BufferedInput -> IO (MVar BufferedInput))
-> IO (MVar BufferedInput)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufferedInput -> IO (MVar BufferedInput)
forall a. a -> IO (MVar a)
newMVar)
stdoutBuf :: MVar BufferedOutput
{-# NOINLINE stdoutBuf #-}
stdoutBuf :: MVar BufferedOutput
stdoutBuf = IO (MVar BufferedOutput) -> MVar BufferedOutput
forall a. IO a -> a
unsafePerformIO (StdStream -> IO BufferedOutput
forall o. Output o => o -> IO BufferedOutput
newBufferedOutput StdStream
stdout IO BufferedOutput
-> (BufferedOutput -> IO (MVar BufferedOutput))
-> IO (MVar BufferedOutput)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufferedOutput -> IO (MVar BufferedOutput)
forall a. a -> IO (MVar a)
newMVar)
stderrBuf :: MVar BufferedOutput
{-# NOINLINE stderrBuf #-}
stderrBuf :: MVar BufferedOutput
stderrBuf = IO (MVar BufferedOutput) -> MVar BufferedOutput
forall a. IO a -> a
unsafePerformIO (StdStream -> IO BufferedOutput
forall o. Output o => o -> IO BufferedOutput
newBufferedOutput StdStream
stderr IO BufferedOutput
-> (BufferedOutput -> IO (MVar BufferedOutput))
-> IO (MVar BufferedOutput)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= BufferedOutput -> IO (MVar BufferedOutput)
forall a. a -> IO (MVar a)
newMVar)
makeStdStream :: HasCallStack => FD -> IO StdStream
makeStdStream :: FD -> IO StdStream
makeStdStream FD
fd = do
FD
typ <- FD -> IO FD
uv_guess_handle FD
fd
if FD
typ FD -> FD -> Bool
forall a. Eq a => a -> a -> Bool
== FD
UV_FILE
then StdStream -> IO StdStream
forall (m :: * -> *) a. Monad m => a -> m a
return (FD -> StdStream
StdFile FD
fd)
else IO StdStream -> IO StdStream
forall a. IO a -> IO a
mask_ (IO StdStream -> IO StdStream) -> IO StdStream -> IO StdStream
forall a b. (a -> b) -> a -> b
$ do
UVManager
uvm <- IO UVManager
getUVManager
UVManager -> (Ptr UVLoop -> IO StdStream) -> IO StdStream
forall a. HasCallStack => UVManager -> (Ptr UVLoop -> IO a) -> IO a
withUVManager UVManager
uvm ((Ptr UVLoop -> IO StdStream) -> IO StdStream)
-> (Ptr UVLoop -> IO StdStream) -> IO StdStream
forall a b. (a -> b) -> a -> b
$ \ Ptr UVLoop
loop -> do
Ptr UVHandle
hdl <- Ptr UVLoop -> IO (Ptr UVHandle)
hs_uv_handle_alloc Ptr UVLoop
loop
Int
slot <- HasCallStack => UVManager -> IO UVSlotUnsafe -> IO Int
UVManager -> IO UVSlotUnsafe -> IO Int
getUVSlot UVManager
uvm (Ptr UVHandle -> IO UVSlotUnsafe
peekUVHandleData Ptr UVHandle
hdl)
Maybe Int
_ <- MVar Int -> IO (Maybe Int)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar (MVar Int -> IO (Maybe Int)) -> IO (MVar Int) -> IO (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UVManager -> Int -> IO (MVar Int)
getBlockMVar UVManager
uvm Int
slot
case FD
typ of
FD
UV_TTY -> do
IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVLoop -> Ptr UVHandle -> FD -> IO FD
uv_tty_init Ptr UVLoop
loop Ptr UVHandle
hdl (FD -> FD
forall a b. (Integral a, Num b) => a -> b
fromIntegral FD
fd))
StdStream -> IO StdStream
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Ptr UVHandle -> Int -> UVManager -> StdStream
StdStream Bool
True Ptr UVHandle
hdl Int
slot UVManager
uvm)
FD
UV_TCP -> do
IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVLoop -> Ptr UVHandle -> IO FD
uv_tcp_init Ptr UVLoop
loop Ptr UVHandle
hdl)
IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> FD -> IO FD
uv_tcp_open Ptr UVHandle
hdl FD
fd)
StdStream -> IO StdStream
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Ptr UVHandle -> Int -> UVManager -> StdStream
StdStream Bool
False Ptr UVHandle
hdl Int
slot UVManager
uvm)
FD
UV_UDP ->
FD -> IOEInfo -> IO StdStream
forall a. FD -> IOEInfo -> IO a
throwUVError FD
UV_EXDEV IOEInfo :: Text -> Text -> CallStack -> IOEInfo
IOEInfo{
ioeName :: Text
ioeName = Text
"EXDEV"
, ioeDescription :: Text
ioeDescription = Text
"redirect to UDP is not supported"
, ioeCallStack :: CallStack
ioeCallStack = CallStack
HasCallStack => CallStack
callStack
}
FD
_ -> do
IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVLoop -> Ptr UVHandle -> FD -> IO FD
uv_pipe_init Ptr UVLoop
loop Ptr UVHandle
hdl FD
0)
IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> FD -> IO FD
uv_pipe_open Ptr UVHandle
hdl FD
fd)
StdStream -> IO StdStream
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Ptr UVHandle -> Int -> UVManager -> StdStream
StdStream Bool
False Ptr UVHandle
hdl Int
slot UVManager
uvm)
setStdinTTYMode :: TTYMode -> IO ()
setStdinTTYMode :: FD -> IO ()
setStdinTTYMode FD
mode = case StdStream
stdin of
StdStream Bool
True Ptr UVHandle
hdl Int
_ UVManager
uvm ->
UVManager -> IO () -> IO ()
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (IO () -> IO ()) -> (IO FD -> IO ()) -> IO FD -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (IO FD -> IO ()) -> IO FD -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr UVHandle -> FD -> IO FD
uv_tty_set_mode Ptr UVHandle
hdl FD
mode
StdStream
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
getStdoutWinSize :: HasCallStack => IO (CInt, CInt)
getStdoutWinSize :: IO (FD, FD)
getStdoutWinSize = case StdStream
stdout of
StdStream Bool
True Ptr UVHandle
hdl Int
_ UVManager
uvm ->
UVManager -> IO (FD, FD) -> IO (FD, FD)
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (IO (FD, FD) -> IO (FD, FD)) -> IO (FD, FD) -> IO (FD, FD)
forall a b. (a -> b) -> a -> b
$ do
(FD
w, (FD
h, ())) <- (MBA# FD -> IO (FD, ())) -> IO (FD, (FD, ()))
forall a b. Prim a => (MBA# FD -> IO b) -> IO (a, b)
allocPrimUnsafe ((MBA# FD -> IO (FD, ())) -> IO (FD, (FD, ())))
-> (MBA# FD -> IO (FD, ())) -> IO (FD, (FD, ()))
forall a b. (a -> b) -> a -> b
$ \ MBA# FD
w ->
(MBA# FD -> IO ()) -> IO (FD, ())
forall a b. Prim a => (MBA# FD -> IO b) -> IO (a, b)
allocPrimUnsafe ((MBA# FD -> IO ()) -> IO (FD, ()))
-> (MBA# FD -> IO ()) -> IO (FD, ())
forall a b. (a -> b) -> a -> b
$ \ MBA# FD
h -> IO FD -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (IO FD -> IO ()) -> IO FD -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr UVHandle -> MBA# FD -> MBA# FD -> IO FD
uv_tty_get_winsize Ptr UVHandle
hdl MBA# FD
w MBA# FD
h
(FD, FD) -> IO (FD, FD)
forall (m :: * -> *) a. Monad m => a -> m a
return (FD
w, FD
h)
StdStream
_ -> (FD, FD) -> IO (FD, FD)
forall (m :: * -> *) a. Monad m => a -> m a
return (-FD
1, -FD
1)
printStd :: (HasCallStack, T.Print a) => a -> IO ()
printStd :: a -> IO ()
printStd a
s = Builder () -> IO ()
forall a. HasCallStack => Builder a -> IO ()
putStd (a -> Builder ()
forall a. Print a => a -> Builder ()
T.toUTF8Builder a
s)
putStd :: HasCallStack => B.Builder a -> IO ()
putStd :: Builder a -> IO ()
putStd Builder a
b = MVar BufferedOutput -> (BufferedOutput -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar BufferedOutput
stdoutBuf ((BufferedOutput -> IO ()) -> IO ())
-> (BufferedOutput -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BufferedOutput
o -> do
BufferedOutput -> Builder () -> IO ()
forall a. HasCallStack => BufferedOutput -> Builder a -> IO ()
writeBuilder BufferedOutput
o (Builder a
b Builder a -> Builder () -> Builder ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Builder ()
B.char8 Char
'\n')
HasCallStack => BufferedOutput -> IO ()
BufferedOutput -> IO ()
flushBuffer BufferedOutput
o
readStd :: HasCallStack => IO V.Bytes
readStd :: IO Bytes
readStd = MVar BufferedInput -> (BufferedInput -> IO Bytes) -> IO Bytes
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar BufferedInput
stdinBuf ((BufferedInput -> IO Bytes) -> IO Bytes)
-> (BufferedInput -> IO Bytes) -> IO Bytes
forall a b. (a -> b) -> a -> b
$ \ BufferedInput
s -> do
Maybe Bytes
line <- HasCallStack => BufferedInput -> IO (Maybe Bytes)
BufferedInput -> IO (Maybe Bytes)
readLine BufferedInput
s
case Maybe Bytes
line of Just Bytes
line' -> Bytes -> IO Bytes
forall (m :: * -> *) a. Monad m => a -> m a
return Bytes
line'
Maybe Bytes
Nothing -> ResourceVanished -> IO Bytes
forall e a. Exception e => e -> IO a
throwIO (IOEInfo -> ResourceVanished
ResourceVanished
(Text -> Text -> CallStack -> IOEInfo
IOEInfo Text
"ECLOSED" Text
"stdin is closed" CallStack
HasCallStack => CallStack
callStack))