module Z.IO.UV.UVStream
(
initUVStream
, UVStream(..)
, getUVStreamFD
, closeUVStream
, shutdownUVStream
, helloWorld, echo
) where
import Control.Concurrent
import Control.Monad
import qualified Z.Data.Text.Print as T
import Z.IO.UV.Errno
import Z.IO.UV.FFI
import Z.IO.UV.Manager
import Z.IO.Buffered
import Z.IO.Exception
import Z.IO.Resource
import Data.IORef
import GHC.Ptr
data UVStream = UVStream
{ UVStream -> Ptr UVHandle
uvsHandle :: {-# UNPACK #-} !(Ptr UVHandle)
, UVStream -> UVSlot
uvsSlot :: {-# UNPACK #-} !UVSlot
, UVStream -> UVManager
uvsManager :: UVManager
, UVStream -> IORef Bool
uvsClosed :: {-# UNPACK #-} !(IORef Bool)
}
instance Show UVStream where show :: UVStream -> String
show = forall a. Print a => a -> String
T.toString
instance T.Print UVStream where
{-# INLINABLE toUTF8BuilderP #-}
toUTF8BuilderP :: UVSlot -> UVStream -> Builder ()
toUTF8BuilderP UVSlot
_ (UVStream Ptr UVHandle
hdl UVSlot
slot UVManager
uvm IORef Bool
_) = do
Builder ()
"UVStream{uvsHandle=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Print a => a -> Builder ()
T.toUTF8Builder Ptr UVHandle
hdl
Builder ()
",uvsSlot=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Print a => a -> Builder ()
T.toUTF8Builder UVSlot
slot
Builder ()
",uvsManager=" forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Print a => a -> Builder ()
T.toUTF8Builder UVManager
uvm
Char -> Builder ()
T.char7 Char
'}'
initUVStream :: HasCallStack
=> (Ptr UVLoop -> Ptr UVHandle -> IO ())
-> UVManager
-> Resource UVStream
{-# INLINABLE initUVStream #-}
initUVStream :: HasCallStack =>
(Ptr UVLoop -> Ptr UVHandle -> IO ())
-> UVManager -> Resource UVStream
initUVStream Ptr UVLoop -> Ptr UVHandle -> IO ()
f UVManager
uvm = forall a. IO a -> (a -> IO ()) -> Resource a
initResource
(forall a. HasCallStack => UVManager -> (Ptr UVLoop -> IO a) -> IO a
withUVManager UVManager
uvm 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
UVSlot
slot <- HasCallStack => UVManager -> IO UVSlotUnsafe -> IO UVSlot
getUVSlot UVManager
uvm (Ptr UVHandle -> IO UVSlotUnsafe
peekUVHandleData Ptr UVHandle
hdl)
Maybe UVSlot
_ <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UVManager -> UVSlot -> IO (MVar UVSlot)
getBlockMVar UVManager
uvm UVSlot
slot
Ptr UVLoop -> Ptr UVHandle -> IO ()
f Ptr UVLoop
loop Ptr UVHandle
hdl
IORef Bool
closed <- forall a. a -> IO (IORef a)
newIORef Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr UVHandle -> UVSlot -> UVManager -> IORef Bool -> UVStream
UVStream Ptr UVHandle
hdl UVSlot
slot UVManager
uvm IORef Bool
closed))
UVStream -> IO ()
closeUVStream
closeUVStream :: UVStream -> IO ()
{-# INLINABLE closeUVStream #-}
closeUVStream :: UVStream -> IO ()
closeUVStream (UVStream Ptr UVHandle
hdl UVSlot
_ UVManager
uvm IORef Bool
closed) = forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm forall a b. (a -> b) -> a -> b
$ do
Bool
c <- forall a. IORef a -> IO a
readIORef IORef Bool
closed
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
c forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
closed Bool
True forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr UVHandle -> IO ()
hs_uv_handle_close Ptr UVHandle
hdl
shutdownUVStream :: HasCallStack => UVStream -> IO ()
{-# INLINABLE shutdownUVStream #-}
shutdownUVStream :: HasCallStack => UVStream -> IO ()
shutdownUVStream (UVStream Ptr UVHandle
hdl UVSlot
_ UVManager
uvm IORef Bool
closed) = do
Bool
c <- forall a. IORef a -> IO a
readIORef IORef Bool
closed
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c forall a. HasCallStack => IO a
throwECLOSED
MVar UVSlot
m <- forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm forall a b. (a -> b) -> a -> b
$ do
UVSlot
reqSlot <- HasCallStack => UVManager -> IO UVSlotUnsafe -> IO UVSlot
getUVSlot UVManager
uvm (Ptr UVHandle -> IO UVSlotUnsafe
hs_uv_shutdown Ptr UVHandle
hdl)
MVar UVSlot
m <- UVManager -> UVSlot -> IO (MVar UVSlot)
getBlockMVar UVManager
uvm UVSlot
reqSlot
Maybe UVSlot
_ <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar UVSlot
m
forall (m :: * -> *) a. Monad m => a -> m a
return MVar UVSlot
m
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (forall a. IO a -> IO a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar UVSlot
m)
getUVStreamFD :: HasCallStack => UVStream -> IO FD
{-# INLINABLE getUVStreamFD #-}
getUVStreamFD :: HasCallStack => UVStream -> IO FD
getUVStreamFD (UVStream Ptr UVHandle
hdl UVSlot
_ UVManager
_ IORef Bool
closed) = do
Bool
c <- forall a. IORef a -> IO a
readIORef IORef Bool
closed
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c forall a. HasCallStack => IO a
throwECLOSED
forall a. (HasCallStack, Integral a) => IO a -> IO a
throwUVIfMinus (Ptr UVHandle -> IO FD
hs_uv_fileno Ptr UVHandle
hdl)
instance Input UVStream where
{-# INLINABLE readInput #-}
readInput :: UVStream -> Ptr Word8 -> UVSlot -> IO UVSlot
readInput (UVStream Ptr UVHandle
hdl UVSlot
slot UVManager
uvm IORef Bool
closed) Ptr Word8
buf UVSlot
len = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
Bool
c <- forall a. IORef a -> IO a
readIORef IORef Bool
closed
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c forall a. HasCallStack => IO a
throwECLOSED
UVManager -> UVSlot -> Ptr Word8 -> UVSlot -> IO ()
pokeBufferTable UVManager
uvm UVSlot
slot Ptr Word8
buf UVSlot
len
MVar UVSlot
m <- UVManager -> UVSlot -> IO (MVar UVSlot)
getBlockMVar UVManager
uvm UVSlot
slot
Maybe UVSlot
_ <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar UVSlot
m
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (Ptr UVHandle -> IO FD
hs_uv_read_start Ptr UVHandle
hdl)
UVSlot
r <- forall a. MVar a -> IO a
takeMVar MVar UVSlot
m forall a b. IO a -> IO b -> IO a
`onException` (do
FD
_ <- forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm (Ptr UVHandle -> IO FD
uv_read_stop Ptr UVHandle
hdl)
forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar UVSlot
m))
if | UVSlot
r forall a. Ord a => a -> a -> Bool
> UVSlot
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return UVSlot
r
| UVSlot
r forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral FD
UV_EOF -> forall (m :: * -> *) a. Monad m => a -> m a
return UVSlot
0
| UVSlot
r forall a. Ord a => a -> a -> Bool
< UVSlot
0 -> forall a. (HasCallStack, Integral a) => IO a -> IO a
throwUVIfMinus (forall (m :: * -> *) a. Monad m => a -> m a
return UVSlot
r)
| Bool
otherwise -> forall a. FD -> IOEInfo -> IO a
throwUVError FD
UV_UNKNOWN IOEInfo{
ioeName :: Text
ioeName = Text
"UVStream read error"
, ioeDescription :: Text
ioeDescription = Text
"UVStream read should never return 0 before EOF"
, ioeCallStack :: CallStack
ioeCallStack = HasCallStack => CallStack
callStack
}
instance Output UVStream where
{-# INLINABLE writeOutput #-}
writeOutput :: UVStream -> Ptr Word8 -> UVSlot -> IO ()
writeOutput (UVStream Ptr UVHandle
hdl UVSlot
_ UVManager
uvm IORef Bool
closed) Ptr Word8
buf UVSlot
len = forall a. IO a -> IO a
mask_ forall a b. (a -> b) -> a -> b
$ do
Bool
c <- forall a. IORef a -> IO a
readIORef IORef Bool
closed
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c forall a. HasCallStack => IO a
throwECLOSED
UVSlot
r <- Ptr UVHandle -> Ptr Word8 -> UVSlot -> IO UVSlot
hs_uv_try_write Ptr UVHandle
hdl Ptr Word8
buf UVSlot
len
if | UVSlot
r forall a. Eq a => a -> a -> Bool
== UVSlot
len -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| UVSlot
r forall a. Ord a => a -> a -> Bool
< UVSlot
0 Bool -> Bool -> Bool
&& UVSlot
r forall a. Eq a => a -> a -> Bool
/= forall a b. (Integral a, Num b) => a -> b
fromIntegral FD
UV_EAGAIN -> forall a b. (Integral a, HasCallStack) => a -> IO b
throwUV UVSlot
r
| Bool
otherwise -> do
MVar UVSlot
m <- forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
uvm forall a b. (a -> b) -> a -> b
$ do
UVSlot
reqSlot <- if UVSlot
r forall a. Ord a => a -> a -> Bool
> UVSlot
0
then HasCallStack => UVManager -> IO UVSlotUnsafe -> IO UVSlot
getUVSlot UVManager
uvm (Ptr UVHandle -> Ptr Word8 -> UVSlot -> IO UVSlotUnsafe
hs_uv_write Ptr UVHandle
hdl (Ptr Word8
buf forall a b. Ptr a -> UVSlot -> Ptr b
`plusPtr` UVSlot
r) (UVSlot
len forall a. Num a => a -> a -> a
- UVSlot
r))
else HasCallStack => UVManager -> IO UVSlotUnsafe -> IO UVSlot
getUVSlot UVManager
uvm (Ptr UVHandle -> Ptr Word8 -> UVSlot -> IO UVSlotUnsafe
hs_uv_write Ptr UVHandle
hdl Ptr Word8
buf UVSlot
len)
MVar UVSlot
m <- UVManager -> UVSlot -> IO (MVar UVSlot)
getBlockMVar UVManager
uvm UVSlot
reqSlot
Maybe UVSlot
_ <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar UVSlot
m
forall (m :: * -> *) a. Monad m => a -> m a
return MVar UVSlot
m
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (forall a. IO a -> IO a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar UVSlot
m)
helloWorld :: UVStream -> IO ()
{-# INLINABLE helloWorld #-}
helloWorld :: UVStream -> IO ()
helloWorld UVStream
uvs = forall o. Output o => o -> Ptr Word8 -> UVSlot -> IO ()
writeOutput UVStream
uvs (forall a. Addr# -> Ptr a
Ptr Addr#
"hello world"#) UVSlot
11
echo :: UVStream -> IO ()
{-# INLINABLE echo #-}
echo :: UVStream -> IO ()
echo UVStream
uvs = do
BufferedInput
i <- forall i. Input i => i -> IO BufferedInput
newBufferedInput UVStream
uvs
BufferedOutput
o <- forall o. Output o => o -> IO BufferedOutput
newBufferedOutput UVStream
uvs
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ HasCallStack => BufferedInput -> IO Bytes
readBuffer BufferedInput
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => BufferedOutput -> Bytes -> IO ()
writeBuffer BufferedOutput
o forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HasCallStack => BufferedOutput -> IO ()
flushBuffer BufferedOutput
o