{-|
Module      : Z.IO.IPC
Description : Named pipe\/Unix domain servers and clients
Copyright   : (c) Dong Han, 2018
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

This module provides an API for creating IPC servers and clients. IPC Support is implemented with named pipes on Windows, and UNIX domain sockets on other operating systems.

On UNIX, the local domain is also known as the UNIX domain. The path is a filesystem path name. It gets truncated to sizeof(sockaddr_un.sun_path) - 1, which varies on different operating system between 91 and 107 bytes. The typical values are 107 on Linux and 103 on macOS. The path is subject to the same naming conventions and permissions checks as would be done on file creation. It will be visible in the filesystem, and will persist until unlinked.

On Windows, the local domain is implemented using a named pipe. The path must refer to an entry in \\?\pipe\ or \\.\pipe\. Any characters are permitted, but the latter may do some processing of pipe names, such as resolving .. sequences. Despite appearances, the pipe name space is flat. Pipes will not persist, they are removed when the last reference to them is closed.

-}

module Z.IO.Network.IPC (
  -- * IPC Client
    IPCClientConfig(..)
  , UVStream
  , defaultIPCClientConfig
  , initIPCClient
  -- * IPC Server
  , IPCServerConfig(..)
  , defaultIPCServerConfig
  , startIPCServer
  -- * For test
  , helloWorld
  , echo
  -- * Internal helper
  , initIPCStream
  ) where

import           Control.Monad
import           Control.Monad.IO.Class
import           GHC.Generics
import           Z.Data.CBytes
import           Z.Data.Text.Print   (Print)
import           Z.Data.JSON         (JSON)
import           Z.IO.Exception
import           Z.IO.Resource
import           Z.IO.Network.TCP    (startServerLoop)
import           Z.IO.UV.FFI
import           Z.IO.UV.Manager
import           Z.IO.UV.UVStream

--------------------------------------------------------------------------------

-- | A IPC client configuration
--
data IPCClientConfig = IPCClientConfig
    { IPCClientConfig -> Maybe CBytes
ipcClientName :: Maybe CBytes -- ^ bind to a local file path (Unix) or name (Windows),
                                    -- won't bind if set to 'Nothing'.
    , IPCClientConfig -> CBytes
ipcTargetName :: CBytes       -- ^ target path (Unix) or a name (Windows).
    } deriving (IPCClientConfig -> IPCClientConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IPCClientConfig -> IPCClientConfig -> Bool
$c/= :: IPCClientConfig -> IPCClientConfig -> Bool
== :: IPCClientConfig -> IPCClientConfig -> Bool
$c== :: IPCClientConfig -> IPCClientConfig -> Bool
Eq, Eq IPCClientConfig
IPCClientConfig -> IPCClientConfig -> Bool
IPCClientConfig -> IPCClientConfig -> Ordering
IPCClientConfig -> IPCClientConfig -> IPCClientConfig
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IPCClientConfig -> IPCClientConfig -> IPCClientConfig
$cmin :: IPCClientConfig -> IPCClientConfig -> IPCClientConfig
max :: IPCClientConfig -> IPCClientConfig -> IPCClientConfig
$cmax :: IPCClientConfig -> IPCClientConfig -> IPCClientConfig
>= :: IPCClientConfig -> IPCClientConfig -> Bool
$c>= :: IPCClientConfig -> IPCClientConfig -> Bool
> :: IPCClientConfig -> IPCClientConfig -> Bool
$c> :: IPCClientConfig -> IPCClientConfig -> Bool
<= :: IPCClientConfig -> IPCClientConfig -> Bool
$c<= :: IPCClientConfig -> IPCClientConfig -> Bool
< :: IPCClientConfig -> IPCClientConfig -> Bool
$c< :: IPCClientConfig -> IPCClientConfig -> Bool
compare :: IPCClientConfig -> IPCClientConfig -> Ordering
$ccompare :: IPCClientConfig -> IPCClientConfig -> Ordering
Ord, Int -> IPCClientConfig -> ShowS
[IPCClientConfig] -> ShowS
IPCClientConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IPCClientConfig] -> ShowS
$cshowList :: [IPCClientConfig] -> ShowS
show :: IPCClientConfig -> String
$cshow :: IPCClientConfig -> String
showsPrec :: Int -> IPCClientConfig -> ShowS
$cshowsPrec :: Int -> IPCClientConfig -> ShowS
Show, ReadPrec [IPCClientConfig]
ReadPrec IPCClientConfig
Int -> ReadS IPCClientConfig
ReadS [IPCClientConfig]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [IPCClientConfig]
$creadListPrec :: ReadPrec [IPCClientConfig]
readPrec :: ReadPrec IPCClientConfig
$creadPrec :: ReadPrec IPCClientConfig
readList :: ReadS [IPCClientConfig]
$creadList :: ReadS [IPCClientConfig]
readsPrec :: Int -> ReadS IPCClientConfig
$creadsPrec :: Int -> ReadS IPCClientConfig
Read, forall x. Rep IPCClientConfig x -> IPCClientConfig
forall x. IPCClientConfig -> Rep IPCClientConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IPCClientConfig x -> IPCClientConfig
$cfrom :: forall x. IPCClientConfig -> Rep IPCClientConfig x
Generic)
      deriving anyclass (Int -> IPCClientConfig -> Builder ()
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> IPCClientConfig -> Builder ()
$ctoUTF8BuilderP :: Int -> IPCClientConfig -> Builder ()
Print, Value -> Converter IPCClientConfig
IPCClientConfig -> Value
IPCClientConfig -> Builder ()
forall a.
(Value -> Converter a)
-> (a -> Value) -> (a -> Builder ()) -> JSON a
encodeJSON :: IPCClientConfig -> Builder ()
$cencodeJSON :: IPCClientConfig -> Builder ()
toValue :: IPCClientConfig -> Value
$ctoValue :: IPCClientConfig -> Value
fromValue :: Value -> Converter IPCClientConfig
$cfromValue :: Value -> Converter IPCClientConfig
JSON)

-- | Default config, connect to ".\/ipc".
--
defaultIPCClientConfig :: IPCClientConfig
{-# INLINABLE defaultIPCClientConfig #-}
defaultIPCClientConfig :: IPCClientConfig
defaultIPCClientConfig = Maybe CBytes -> CBytes -> IPCClientConfig
IPCClientConfig forall a. Maybe a
Nothing CBytes
"./ipc"

-- | init a IPC client 'Resource', which open a new connect when used.
--
initIPCClient :: IPCClientConfig -> Resource UVStream
{-# INLINABLE initIPCClient #-}
initIPCClient :: IPCClientConfig -> Resource UVStream
initIPCClient (IPCClientConfig Maybe CBytes
cname CBytes
tname) = do
    UVManager
uvm <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UVManager
getUVManager
    UVStream
client <- HasCallStack => UVManager -> Resource UVStream
initIPCStream UVManager
uvm
    let hdl :: Ptr UVHandle
hdl = UVStream -> Ptr UVHandle
uvsHandle UVStream
client
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe CBytes
cname forall a b. (a -> b) -> a -> b
$ \ CBytes
cname' ->
            forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
withCBytesUnsafe CBytes
cname' forall a b. (a -> b) -> a -> b
$ \ BA# Word8
cname_p ->
                -- bind is safe without withUVManager
                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)
        forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
withCBytesUnsafe CBytes
tname forall a b. (a -> b) -> a -> b
$ \ BA# Word8
tname_p -> do
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack =>
UVManager -> (Ptr UVLoop -> IO UVSlotUnsafe) -> IO Int
withUVRequest UVManager
uvm 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
    forall (m :: * -> *) a. Monad m => a -> m a
return UVStream
client

--------------------------------------------------------------------------------

-- | A IPC server configuration
--
data IPCServerConfig = IPCServerConfig
    { IPCServerConfig -> CBytes
ipcListenName       :: CBytes      -- ^ listening path (Unix) or a name (Windows).
    , IPCServerConfig -> Int
ipcListenBacklog    :: Int           -- ^ listening pipe's backlog size, should be large enough(>128)
    } deriving (IPCServerConfig -> IPCServerConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IPCServerConfig -> IPCServerConfig -> Bool
$c/= :: IPCServerConfig -> IPCServerConfig -> Bool
== :: IPCServerConfig -> IPCServerConfig -> Bool
$c== :: IPCServerConfig -> IPCServerConfig -> Bool
Eq, Eq IPCServerConfig
IPCServerConfig -> IPCServerConfig -> Bool
IPCServerConfig -> IPCServerConfig -> Ordering
IPCServerConfig -> IPCServerConfig -> IPCServerConfig
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: IPCServerConfig -> IPCServerConfig -> IPCServerConfig
$cmin :: IPCServerConfig -> IPCServerConfig -> IPCServerConfig
max :: IPCServerConfig -> IPCServerConfig -> IPCServerConfig
$cmax :: IPCServerConfig -> IPCServerConfig -> IPCServerConfig
>= :: IPCServerConfig -> IPCServerConfig -> Bool
$c>= :: IPCServerConfig -> IPCServerConfig -> Bool
> :: IPCServerConfig -> IPCServerConfig -> Bool
$c> :: IPCServerConfig -> IPCServerConfig -> Bool
<= :: IPCServerConfig -> IPCServerConfig -> Bool
$c<= :: IPCServerConfig -> IPCServerConfig -> Bool
< :: IPCServerConfig -> IPCServerConfig -> Bool
$c< :: IPCServerConfig -> IPCServerConfig -> Bool
compare :: IPCServerConfig -> IPCServerConfig -> Ordering
$ccompare :: IPCServerConfig -> IPCServerConfig -> Ordering
Ord, Int -> IPCServerConfig -> ShowS
[IPCServerConfig] -> ShowS
IPCServerConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IPCServerConfig] -> ShowS
$cshowList :: [IPCServerConfig] -> ShowS
show :: IPCServerConfig -> String
$cshow :: IPCServerConfig -> String
showsPrec :: Int -> IPCServerConfig -> ShowS
$cshowsPrec :: Int -> IPCServerConfig -> ShowS
Show, ReadPrec [IPCServerConfig]
ReadPrec IPCServerConfig
Int -> ReadS IPCServerConfig
ReadS [IPCServerConfig]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [IPCServerConfig]
$creadListPrec :: ReadPrec [IPCServerConfig]
readPrec :: ReadPrec IPCServerConfig
$creadPrec :: ReadPrec IPCServerConfig
readList :: ReadS [IPCServerConfig]
$creadList :: ReadS [IPCServerConfig]
readsPrec :: Int -> ReadS IPCServerConfig
$creadsPrec :: Int -> ReadS IPCServerConfig
Read, forall x. Rep IPCServerConfig x -> IPCServerConfig
forall x. IPCServerConfig -> Rep IPCServerConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IPCServerConfig x -> IPCServerConfig
$cfrom :: forall x. IPCServerConfig -> Rep IPCServerConfig x
Generic)
      deriving anyclass (Int -> IPCServerConfig -> Builder ()
forall a. (Int -> a -> Builder ()) -> Print a
toUTF8BuilderP :: Int -> IPCServerConfig -> Builder ()
$ctoUTF8BuilderP :: Int -> IPCServerConfig -> Builder ()
Print, Value -> Converter IPCServerConfig
IPCServerConfig -> Value
IPCServerConfig -> Builder ()
forall a.
(Value -> Converter a)
-> (a -> Value) -> (a -> Builder ()) -> JSON a
encodeJSON :: IPCServerConfig -> Builder ()
$cencodeJSON :: IPCServerConfig -> Builder ()
toValue :: IPCServerConfig -> Value
$ctoValue :: IPCServerConfig -> Value
fromValue :: Value -> Converter IPCServerConfig
$cfromValue :: Value -> Converter IPCServerConfig
JSON)

-- | A default hello world server on @.\/ipc@
--
-- Test it with @main = startIPCServer defaultIPCServerConfig@
--
defaultIPCServerConfig :: IPCServerConfig
{-# INLINABLE defaultIPCServerConfig #-}
defaultIPCServerConfig :: IPCServerConfig
defaultIPCServerConfig = CBytes -> Int -> IPCServerConfig
IPCServerConfig
    CBytes
"./ipc"
    Int
256

-- | Start a server
--
-- Fork new worker thread upon a new connection.
--
startIPCServer :: HasCallStack
               => IPCServerConfig
               -> (UVStream -> IO ())  -- ^ worker which get an accepted IPC stream,
                                        -- run in a seperated haskell thread,
                                       --  will be closed upon exception or worker finishes.
               -> IO ()
{-# INLINABLE startIPCServer #-}
startIPCServer :: HasCallStack => IPCServerConfig -> (UVStream -> IO ()) -> IO ()
startIPCServer IPCServerConfig{Int
CBytes
ipcListenBacklog :: Int
ipcListenName :: CBytes
ipcListenBacklog :: IPCServerConfig -> Int
ipcListenName :: IPCServerConfig -> CBytes
..} = HasCallStack =>
Int
-> (UVManager -> Resource UVStream)
-> (Ptr UVHandle -> IO ())
-> (CInt -> (UVStream -> IO ()) -> IO ())
-> (UVStream -> IO ())
-> IO ()
startServerLoop
    (forall a. Ord a => a -> a -> a
max Int
ipcListenBacklog Int
128)
    HasCallStack => UVManager -> Resource UVStream
initIPCStream
    (\ Ptr UVHandle
serverHandle ->
        forall a. CBytes -> (BA# Word8 -> IO a) -> IO a
withCBytesUnsafe CBytes
ipcListenName forall a b. (a -> b) -> a -> b
$ \ BA# Word8
name_p -> do
            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))
    ( \ CInt
fd UVStream -> IO ()
worker -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkBa forall a b. (a -> b) -> a -> b
$ do
        UVManager
uvm <- IO UVManager
getUVManager
        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
initUVStream (\ Ptr UVLoop
loop Ptr UVHandle
hdl -> do
            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)
            forall a. (HasCallStack, Integral a) => IO a -> IO ()
throwUVIfMinus_ (Ptr UVHandle -> CInt -> IO CInt
uv_pipe_open Ptr UVHandle
hdl CInt
fd)) UVManager
uvm) forall a b. (a -> b) -> a -> b
$ \ UVStream
uvs -> do
            UVStream -> IO ()
worker UVStream
uvs)

--------------------------------------------------------------------------------

initIPCStream :: HasCallStack => UVManager -> Resource UVStream
{-# INLINABLE initIPCStream #-}
initIPCStream :: HasCallStack => UVManager -> Resource UVStream
initIPCStream = HasCallStack =>
(Ptr UVLoop -> Ptr UVHandle -> IO ())
-> UVManager -> Resource UVStream
initUVStream (\ Ptr UVLoop
loop Ptr UVHandle
hdl ->
    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))