module Language.JavaScript.Inline.Core.IPC where
import Control.Concurrent
import Control.Monad
import Data.Binary.Get
import qualified Data.ByteString as BS
import Data.ByteString.Builder
import qualified Data.ByteString.Lazy as LBS
import Foreign
import Language.JavaScript.Inline.Core.Utils
import System.IO
type Msg = LBS.ByteString
data IPC = IPC
{
IPC -> Msg -> IO ()
send :: Msg -> IO (),
IPC -> IO Msg
recv :: IO Msg,
IPC -> Msg -> IO ()
onRecv :: Msg -> IO (),
IPC -> IO ()
postClose :: IO ()
}
instance Show IPC where
show :: IPC -> String
show IPC {} = String
"IPC"
ipcFromHandles :: Handle -> Handle -> IPC -> IPC
ipcFromHandles :: Handle -> Handle -> IPC -> IPC
ipcFromHandles Handle
h_send Handle
h_recv IPC
ipc =
IPC
ipc
{ send :: Msg -> IO ()
send = \Msg
msg -> do
Handle -> ByteString -> IO ()
BS.hPut Handle
h_send (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
Msg -> ByteString
LBS.toStrict (Msg -> ByteString) -> Msg -> ByteString
forall a b. (a -> b) -> a -> b
$
Builder -> Msg
toLazyByteString (Builder -> Msg) -> Builder -> Msg
forall a b. (a -> b) -> a -> b
$
Int64 -> Builder
forall a. Storable a => a -> Builder
storablePut (Msg -> Int64
LBS.length Msg
msg)
Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Msg -> Builder
lazyByteString Msg
msg
Handle -> IO ()
hFlush Handle
h_send,
recv :: IO Msg
recv = do
Word64
len <- Get Word64 -> Msg -> Word64
forall a. Get a -> Msg -> a
runGet Get Word64
forall a. Storable a => Get a
storableGet (Msg -> Word64) -> IO Msg -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> Int -> IO Msg
hGetExact Handle
h_recv Int
8
Handle -> Int -> IO Msg
hGetExact Handle
h_recv (Int -> IO Msg) -> Int -> IO Msg
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
len :: Word64)
}
ipcFork :: IPC -> IO IPC
ipcFork :: IPC -> IO IPC
ipcFork IPC
ipc = do
let io_recv_loop :: IO b
io_recv_loop = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
Msg
msg <- IPC -> IO Msg
recv IPC
ipc
IPC -> Msg -> IO ()
onRecv IPC
ipc Msg
msg
ThreadId
_ <- IO Any -> (Either SomeException Any -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally IO Any
forall b. IO b
io_recv_loop ((Either SomeException Any -> IO ()) -> IO ThreadId)
-> (Either SomeException Any -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \Either SomeException Any
_ -> IPC -> IO ()
postClose IPC
ipc
IPC -> IO IPC
forall (f :: * -> *) a. Applicative f => a -> f a
pure
IPC
ipc
{ recv :: IO Msg
recv = String -> IO Msg
forall a. HasCallStack => String -> a
error String
"fork: recv",
onRecv :: Msg -> IO ()
onRecv = String -> Msg -> IO ()
forall a. HasCallStack => String -> a
error String
"fork: onRecv",
postClose :: IO ()
postClose = String -> IO ()
forall a. HasCallStack => String -> a
error String
"fork: postClose"
}