module Z.IO.Network.IPC (
IPCClientConfig(..)
, UVStream
, defaultIPCClientConfig
, initIPCClient
, IPCServerConfig(..)
, defaultIPCServerConfig
, startIPCServer
, helloWorld
, echo
, initIPCStream
) where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Data.Primitive.PrimArray
import Foreign.Ptr
import Z.Data.CBytes
import Z.IO.Exception
import Z.IO.Resource
import Z.IO.UV.FFI
import Z.IO.UV.Manager
import Z.IO.UV.UVStream
import Data.Coerce
data IPCClientConfig = IPCClientConfig
{ IPCClientConfig -> Maybe CBytes
ipcClientName :: Maybe CBytes
, IPCClientConfig -> CBytes
ipcTargetName :: CBytes
}
defaultIPCClientConfig :: IPCClientConfig
defaultIPCClientConfig :: IPCClientConfig
defaultIPCClientConfig = Maybe CBytes -> CBytes -> IPCClientConfig
IPCClientConfig Maybe CBytes
forall a. Maybe a
Nothing CBytes
"./ipc"
initIPCClient :: IPCClientConfig -> Resource UVStream
initIPCClient :: IPCClientConfig -> Resource UVStream
initIPCClient (IPCClientConfig Maybe CBytes
cname CBytes
tname) = do
UVManager
uvm <- IO UVManager -> Resource UVManager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UVManager
getUVManager
UVStream
client <- HasCallStack => UVManager -> Resource UVStream
UVManager -> Resource UVStream
initIPCStream UVManager
uvm
let hdl :: Ptr UVHandle
hdl = UVStream -> Ptr UVHandle
uvsHandle UVStream
client
IO () -> Resource ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Resource ()) -> IO () -> Resource ()
forall a b. (a -> b) -> a -> b
$ do
Maybe CBytes -> (CBytes -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe CBytes
cname ((CBytes -> IO ()) -> IO ()) -> (CBytes -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ CBytes
cname' ->
CBytes -> (BA# Word8 -> IO ()) -> IO ()
forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
withCBytesUnsafe CBytes
cname' ((BA# Word8 -> IO ()) -> IO ()) -> (BA# Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
cname_p ->
IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> BA# Word8 -> IO CInt
uv_pipe_bind Ptr UVHandle
hdl BA# Word8
cname_p)
CBytes -> (BA# Word8 -> IO ()) -> IO ()
forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
withCBytesUnsafe CBytes
tname ((BA# Word8 -> IO ()) -> IO ()) -> (BA# Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
tname_p -> do
IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ())
-> ((Ptr UVLoop -> IO UVSlotUnsafe) -> IO Int)
-> (Ptr UVLoop -> IO UVSlotUnsafe)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack =>
UVManager -> (Ptr UVLoop -> IO UVSlotUnsafe) -> IO Int
UVManager -> (Ptr UVLoop -> IO UVSlotUnsafe) -> IO Int
withUVRequest UVManager
uvm ((Ptr UVLoop -> IO UVSlotUnsafe) -> IO ())
-> (Ptr UVLoop -> IO UVSlotUnsafe) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr UVLoop
_ -> Ptr UVHandle -> BA# Word8 -> IO UVSlotUnsafe
hs_uv_pipe_connect Ptr UVHandle
hdl BA# Word8
tname_p
UVStream -> Resource UVStream
forall (m :: * -> *) a. Monad m => a -> m a
return UVStream
client
data IPCServerConfig = IPCServerConfig
{ IPCServerConfig -> CBytes
ipcListenName :: CBytes
, IPCServerConfig -> Int
ipcListenBacklog :: Int
}
defaultIPCServerConfig :: IPCServerConfig
defaultIPCServerConfig :: IPCServerConfig
defaultIPCServerConfig = CBytes -> Int -> IPCServerConfig
IPCServerConfig
CBytes
"./ipc"
Int
256
startIPCServer :: HasCallStack
=> IPCServerConfig
-> (UVStream -> IO ())
-> IO ()
startIPCServer :: IPCServerConfig -> (UVStream -> IO ()) -> IO ()
startIPCServer IPCServerConfig{Int
CBytes
ipcListenBacklog :: Int
ipcListenName :: CBytes
ipcListenBacklog :: IPCServerConfig -> Int
ipcListenName :: IPCServerConfig -> CBytes
..} UVStream -> IO ()
ipcServerWorker = do
let backLog :: Int
backLog = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
ipcListenBacklog Int
128
UVManager
serverUVManager <- IO UVManager
getUVManager
Resource UVStream -> (UVStream -> IO ()) -> IO ()
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m, HasCallStack) =>
Resource a -> (a -> m b) -> m b
withResource (HasCallStack => UVManager -> Resource UVStream
UVManager -> Resource UVStream
initIPCStream UVManager
serverUVManager) ((UVStream -> IO ()) -> IO ()) -> (UVStream -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ (UVStream Ptr UVHandle
serverHandle Int
serverSlot UVManager
_ IORef Bool
_) -> do
CBytes -> (BA# Word8 -> IO ()) -> IO ()
forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
withCBytesUnsafe CBytes
ipcListenName ((BA# Word8 -> IO ()) -> IO ()) -> (BA# Word8 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
name_p -> do
IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> BA# Word8 -> IO CInt
uv_pipe_bind Ptr UVHandle
serverHandle BA# Word8
name_p)
IO (Ptr UVHandle)
-> (Ptr UVHandle -> IO ()) -> (Ptr UVHandle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
(do Ptr UVHandle
check <- IO (Ptr UVHandle) -> IO (Ptr UVHandle)
forall a. HasCallStack => IO (Ptr a) -> IO (Ptr a)
throwOOMIfNull (IO (Ptr UVHandle) -> IO (Ptr UVHandle))
-> IO (Ptr UVHandle) -> IO (Ptr UVHandle)
forall a b. (a -> b) -> a -> b
$ IO (Ptr UVHandle)
hs_uv_check_alloc
IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> Ptr UVHandle -> IO CInt
hs_uv_check_init Ptr UVHandle
check Ptr UVHandle
serverHandle)
Ptr UVHandle -> IO (Ptr UVHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr UVHandle
check)
Ptr UVHandle -> IO ()
hs_uv_check_close ((Ptr UVHandle -> IO ()) -> IO ())
-> (Ptr UVHandle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
\ Ptr UVHandle
check -> do
MutablePrimArray RealWorld CInt
acceptBuf <- Int -> IO (MutablePrimArray (PrimState IO) CInt)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray Int
backLog
let acceptBufPtr :: Ptr Word8
acceptBufPtr = Ptr CInt -> Ptr Word8
coerce (MutablePrimArray RealWorld CInt -> Ptr CInt
forall s a. MutablePrimArray s a -> Ptr a
mutablePrimArrayContents MutablePrimArray RealWorld CInt
acceptBuf :: Ptr FD)
UVManager -> IO () -> IO ()
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
serverUVManager (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
UVManager -> Int -> Ptr Word8 -> Int -> IO ()
pokeBufferTable UVManager
serverUVManager Int
serverSlot Ptr Word8
acceptBufPtr (Int
backLogInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> CInt -> IO CInt
hs_uv_listen Ptr UVHandle
serverHandle (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
backLog))
IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr UVHandle -> IO CInt
hs_uv_accept_check_start Ptr UVHandle
check
MVar Int
m <- UVManager -> Int -> IO (MVar Int)
getBlockMVar UVManager
serverUVManager Int
serverSlot
IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Int
_ <- MVar Int -> IO Int
forall a. MVar a -> IO a
takeMVar MVar Int
m
PrimArray CInt
acceptBufCopy <- UVManager -> IO (PrimArray CInt) -> IO (PrimArray CInt)
forall a. HasCallStack => UVManager -> IO a -> IO a
withUVManager' UVManager
serverUVManager (IO (PrimArray CInt) -> IO (PrimArray CInt))
-> IO (PrimArray CInt) -> IO (PrimArray CInt)
forall a b. (a -> b) -> a -> b
$ do
Maybe Int
_ <- MVar Int -> IO (Maybe Int)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Int
m
Int
acceptCountDown <- UVManager -> Int -> IO Int
peekBufferSizeTable UVManager
serverUVManager Int
serverSlot
UVManager -> Int -> Int -> IO ()
pokeBufferSizeTable UVManager
serverUVManager Int
serverSlot (Int
backLogInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
acceptCountDown Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1) (Ptr UVHandle -> IO ()
hs_uv_listen_resume Ptr UVHandle
serverHandle)
let acceptCount :: Int
acceptCount = Int
backLog Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
acceptCountDown
MutablePrimArray RealWorld CInt
acceptBuf' <- Int -> IO (MutablePrimArray (PrimState IO) CInt)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray Int
acceptCount
MutablePrimArray (PrimState IO) CInt
-> Int
-> MutablePrimArray (PrimState IO) CInt
-> Int
-> Int
-> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> MutablePrimArray (PrimState m) a -> Int -> Int -> m ()
copyMutablePrimArray MutablePrimArray RealWorld CInt
MutablePrimArray (PrimState IO) CInt
acceptBuf' Int
0 MutablePrimArray RealWorld CInt
MutablePrimArray (PrimState IO) CInt
acceptBuf (Int
acceptCountDownInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
acceptCount
MutablePrimArray (PrimState IO) CInt -> IO (PrimArray CInt)
forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld CInt
MutablePrimArray (PrimState IO) CInt
acceptBuf'
[Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0..PrimArray CInt -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray CInt
acceptBufCopyInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
let fd :: CInt
fd = PrimArray CInt -> Int -> CInt
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray CInt
acceptBufCopy Int
i
if CInt
fd CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0
then IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return CInt
fd)
else IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkBa (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
UVManager
uvm <- IO UVManager
getUVManager
Resource UVStream -> (UVStream -> IO ()) -> IO ()
forall (m :: * -> *) a b.
(MonadMask m, MonadIO m, HasCallStack) =>
Resource a -> (a -> m b) -> m b
withResource (HasCallStack =>
(Ptr UVLoop -> Ptr UVHandle -> IO ())
-> UVManager -> Resource UVStream
(Ptr UVLoop -> Ptr UVHandle -> IO ())
-> UVManager -> Resource UVStream
initUVStream (\ Ptr UVLoop
loop Ptr UVHandle
hdl -> do
IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVLoop -> Ptr UVHandle -> CInt -> IO CInt
uv_pipe_init Ptr UVLoop
loop Ptr UVHandle
hdl CInt
0)
IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> CInt -> IO CInt
hs_uv_pipe_open Ptr UVHandle
hdl CInt
fd)) UVManager
uvm) ((UVStream -> IO ()) -> IO ()) -> (UVStream -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ UVStream
uvs -> do
UVStream -> IO ()
ipcServerWorker UVStream
uvs
initIPCStream :: HasCallStack => UVManager -> Resource UVStream
initIPCStream :: UVManager -> Resource UVStream
initIPCStream = HasCallStack =>
(Ptr UVLoop -> Ptr UVHandle -> IO ())
-> UVManager -> Resource UVStream
(Ptr UVLoop -> Ptr UVHandle -> IO ())
-> UVManager -> Resource UVStream
initUVStream (\ Ptr UVLoop
loop Ptr UVHandle
hdl ->
IO CInt -> IO ()
forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVLoop -> Ptr UVHandle -> CInt -> IO CInt
uv_pipe_init Ptr UVLoop
loop Ptr UVHandle
hdl CInt
0))