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

-- | An 'IPC' represents an opaque bi-directional message port. There are
-- middleware functions in this module which modify 'IPC' fields.
data IPC = IPC
  { -- | Send a 'Msg'.
    IPC -> Msg -> IO ()
send :: Msg -> IO (),
    -- | Receive a 'Msg'. Should block when there's no incoming 'Msg' yet, and
    -- throw when the 'IPC' is closed.
    IPC -> IO Msg
recv :: IO Msg,
    -- | Callback for each incoming 'Msg'.
    IPC -> Msg -> IO ()
onRecv :: Msg -> IO (),
    -- | The callback to be called when 'recv' throws, which indicates the
    -- remote device has closed. Will only be called once.
    IPC -> IO ()
postClose :: IO ()
  }

instance Show IPC where
  show :: IPC -> String
show IPC {} = String
"IPC"

-- | Given the 'Handle's for send/recv, this function creates the 'send' /
-- 'recv' fields of an 'IPC' value.
--
-- The protocol for preserving message boundaries is simple: first comes the
-- message header, which is just a little-endian 64-bit unsigned integer,
-- representing the message byte length (sans header). Then follows the actual
-- message.

-- The 'Handle' for send is flushed after each 'send' call to allow the remote
-- device to get the 'Msg' immediately.
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)
    }

-- | This function forks the recv thread. In the result 'IPC' value, only the
-- 'send' field remain valid and can be used by the user.
--
-- The recv thread repeatedly fetches incoming 'Msg's and invokes the 'onRecv'
-- callback on them. When an exception is raised, it invokes the 'postClose'
-- callback and exits. Since 'onRecv' is run in the recv thread, the user should
-- ensure it doesn't throw and doesn't take too long to complete, otherwise
-- it'll block later incoming messages.
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"
      }