{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Language.JavaScript.Inline.Core.Session where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import qualified Data.ByteString as BS
import Data.ByteString.Builder
import qualified Data.ByteString.Lazy as LBS
import Data.Maybe
import Distribution.Simple.Utils
import Foreign
import Language.JavaScript.Inline.Core.Exception
import Language.JavaScript.Inline.Core.IPC
import Language.JavaScript.Inline.Core.Message
import Language.JavaScript.Inline.Core.NodePath
import Language.JavaScript.Inline.Core.NodeVersion
import Language.JavaScript.Inline.Core.Utils
import System.Directory
import System.Environment.Blank
import System.FilePath
import System.Process

-- $session-todos
--
-- * Using closed sessions throw immediately
-- * Handle errors in send/recv thread

{-# NOINLINE evalServerSrc #-}
evalServerSrc :: BS.ByteString
evalServerSrc :: ByteString
evalServerSrc = $(embedFile $ "jsbits" </> "index.js")

data Config = Config
  { -- | Path to the @node@ executable. Defaults to @node@.
    Config -> FilePath
nodePath :: FilePath,
    -- | Extra @node@ arguments that appear before the eval server script's file
    -- path. These arguments won't show up in @process.argv@.
    Config -> [FilePath]
nodeExtraArgs :: [String],
    -- | Extra environment variables to pass to @node@. Will shadow already
    -- existing ones.
    Config -> [(FilePath, FilePath)]
nodeExtraEnv :: [(String, String)],
    -- | To @require()@ or @import()@ third-party packages, set this to the
    -- @node_modules@ directory path.
    Config -> Maybe FilePath
nodeModules :: Maybe FilePath,
    -- | Size in MiBs of the buffer for passing results of functions exported by
    -- 'exportSync'. Most users don't need to care about this. Defaults to 1.
    Config -> Int
nodeExportSyncBufferSize :: Int
  }
  deriving (Int -> Config -> ShowS
[Config] -> ShowS
Config -> FilePath
(Int -> Config -> ShowS)
-> (Config -> FilePath) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> FilePath
$cshow :: Config -> FilePath
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show)

defaultConfig :: Config
defaultConfig :: Config
defaultConfig =
  Config :: FilePath
-> [FilePath]
-> [(FilePath, FilePath)]
-> Maybe FilePath
-> Int
-> Config
Config
    { nodePath :: FilePath
nodePath = FilePath
defNodePath,
      nodeExtraArgs :: [FilePath]
nodeExtraArgs =
        [ FilePath
"--experimental-modules",
          FilePath
"--experimental-worker",
          FilePath
"--no-warnings",
          FilePath
"--unhandled-rejections=strict"
        ],
      nodeExtraEnv :: [(FilePath, FilePath)]
nodeExtraEnv = [],
      nodeModules :: Maybe FilePath
nodeModules = Maybe FilePath
forall a. Maybe a
Nothing,
      nodeExportSyncBufferSize :: Int
nodeExportSyncBufferSize = Int
1
    }

data Session = Session
  { Session -> IPC
ipc :: IPC,
    Session -> TMVar (Either SomeException ByteString)
fatalErrorInbox :: TMVar (Either SomeException LBS.ByteString),
    -- | After a 'Session' is closed, no more messages can be sent to @node@.
    -- Use this to close the 'Session' if @node@ should still run for some time
    -- to allow previous evaluation results to be sent back. Blocks until @node@
    -- process exits.
    Session -> IO ()
closeSession :: IO (),
    -- | Terminate the @node@ process immediately. Use this to close the
    -- 'Session' if @node@ doesn't need to run any more. Blocks until @node@
    -- process exits.
    Session -> IO ()
killSession :: IO ()
  }

instance Show Session where
  show :: Session -> FilePath
show Session {} = FilePath
"Session"

newSession :: Config -> IO Session
newSession :: Config -> IO Session
newSession Config {Int
FilePath
[FilePath]
[(FilePath, FilePath)]
Maybe FilePath
nodeExportSyncBufferSize :: Int
nodeModules :: Maybe FilePath
nodeExtraEnv :: [(FilePath, FilePath)]
nodeExtraArgs :: [FilePath]
nodePath :: FilePath
nodeExportSyncBufferSize :: Config -> Int
nodeModules :: Config -> Maybe FilePath
nodeExtraEnv :: Config -> [(FilePath, FilePath)]
nodeExtraArgs :: Config -> [FilePath]
nodePath :: Config -> FilePath
..} = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
rtsSupportsBoundThreads (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ NotThreadedRTS -> IO ()
forall e a. Exception e => e -> IO a
throwIO NotThreadedRTS
NotThreadedRTS
  FilePath -> IO ()
checkNodeVersion FilePath
nodePath
  (FilePath
_root, FilePath
_p) <- do
    FilePath
_tmp <- IO FilePath
getTemporaryDirectory
    FilePath
_root <- FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
_tmp FilePath
"inline-js"
    let _p :: FilePath
_p = FilePath
_root FilePath -> ShowS
</> FilePath
"index.js"
    FilePath -> ByteString -> IO ()
BS.writeFile FilePath
_p ByteString
evalServerSrc
    (FilePath, FilePath) -> IO (FilePath, FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
_root, FilePath
_p)
  [(FilePath, FilePath)]
_env <- IO [(FilePath, FilePath)]
getEnvironment
  (Just Handle
_wh, Just Handle
_rh, Maybe Handle
_, ProcessHandle
_ph) <-
    CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess
      (FilePath -> [FilePath] -> CreateProcess
proc FilePath
nodePath ([FilePath] -> CreateProcess) -> [FilePath] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ [FilePath]
nodeExtraArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath
_p])
        { env :: Maybe [(FilePath, FilePath)]
env =
            [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$
              [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall k a. Ord k => [(k, a)] -> [(k, a)]
kvDedup ([(FilePath, FilePath)] -> [(FilePath, FilePath)])
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$
                [ ( FilePath
"INLINE_JS_EXPORT_SYNC_BUFFER_SIZE",
                    Int -> FilePath
forall a. Show a => a -> FilePath
show Int
nodeExportSyncBufferSize
                  )
                ]
                  [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. Semigroup a => a -> a -> a
<> (FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
"INLINE_JS_NODE_MODULES",) (Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList Maybe FilePath
nodeModules)
                  [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. Semigroup a => a -> a -> a
<> [(FilePath, FilePath)]
nodeExtraEnv
                  [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. Semigroup a => a -> a -> a
<> [(FilePath, FilePath)]
_env,
          std_in :: StdStream
std_in = StdStream
CreatePipe,
          std_out :: StdStream
std_out = StdStream
CreatePipe
        }
  TMVar (Either SomeException ByteString)
_err_inbox <- IO (TMVar (Either SomeException ByteString))
forall a. IO (TMVar a)
newEmptyTMVarIO
  TMVar ExitCode
_exit_inbox <- IO (TMVar ExitCode)
forall a. IO (TMVar a)
newEmptyTMVarIO
  mdo
    let on_recv :: ByteString -> IO ()
on_recv ByteString
msg_buf = do
          MessageJS
msg <- Get MessageJS -> ByteString -> IO MessageJS
forall a. Typeable a => Get a -> ByteString -> IO a
runGetExact Get MessageJS
messageJSGet ByteString
msg_buf
          case MessageJS
msg of
            JSEvalResponse {Word64
Either ByteString ByteString
jsEvalResponseContent :: MessageJS -> Either ByteString ByteString
jsEvalResponseId :: MessageJS -> Word64
jsEvalResponseContent :: Either ByteString ByteString
jsEvalResponseId :: Word64
..} -> do
              let _sp :: StablePtr a
_sp = Word64 -> StablePtr a
forall a. Word64 -> StablePtr a
word64ToStablePtr Word64
jsEvalResponseId
              TMVar (Either ByteString ByteString)
_inbox <- StablePtr (TMVar (Either ByteString ByteString))
-> IO (TMVar (Either ByteString ByteString))
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr (TMVar (Either ByteString ByteString))
forall a. StablePtr a
_sp
              STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar (Either ByteString ByteString)
-> Either ByteString ByteString -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either ByteString ByteString)
_inbox Either ByteString ByteString
jsEvalResponseContent
            HSEvalRequest {Bool
[ByteString]
Word64
args :: MessageJS -> [ByteString]
hsEvalRequestFunc :: MessageJS -> Word64
hsEvalRequestId :: MessageJS -> Word64
hsEvalRequestIsSync :: MessageJS -> Bool
args :: [ByteString]
hsEvalRequestFunc :: Word64
hsEvalRequestId :: Word64
hsEvalRequestIsSync :: Bool
..} -> do
              ThreadId
_ <-
                IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally
                  ( do
                      let sp :: StablePtr a
sp = Word64 -> StablePtr a
forall a. Word64 -> StablePtr a
word64ToStablePtr Word64
hsEvalRequestFunc
                      [ByteString] -> IO JSExpr
f <- StablePtr ([ByteString] -> IO JSExpr)
-> IO ([ByteString] -> IO JSExpr)
forall a. StablePtr a -> IO a
deRefStablePtr StablePtr ([ByteString] -> IO JSExpr)
forall a. StablePtr a
sp
                      JSExpr
r <- [ByteString] -> IO JSExpr
f [ByteString]
args
                      Session -> MessageHS -> IO ()
sessionSend
                        Session
_session
                        HSEvalResponse :: Bool -> Word64 -> Either ByteString JSExpr -> MessageHS
HSEvalResponse
                          { hsEvalResponseIsSync :: Bool
hsEvalResponseIsSync = Bool
hsEvalRequestIsSync,
                            hsEvalResponseId :: Word64
hsEvalResponseId = Word64
hsEvalRequestId,
                            hsEvalResponseContent :: Either ByteString JSExpr
hsEvalResponseContent = JSExpr -> Either ByteString JSExpr
forall a b. b -> Either a b
Right JSExpr
r
                          }
                  )
                  ( \case
                      Left (SomeException e
err) -> do
                        let err_buf :: ByteString
err_buf = FilePath -> ByteString
stringToLBS (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ e -> FilePath
forall a. Show a => a -> FilePath
show e
err
                        Session -> MessageHS -> IO ()
sessionSend
                          Session
_session
                          HSEvalResponse :: Bool -> Word64 -> Either ByteString JSExpr -> MessageHS
HSEvalResponse
                            { hsEvalResponseIsSync :: Bool
hsEvalResponseIsSync = Bool
hsEvalRequestIsSync,
                              hsEvalResponseId :: Word64
hsEvalResponseId = Word64
hsEvalRequestId,
                              hsEvalResponseContent :: Either ByteString JSExpr
hsEvalResponseContent = ByteString -> Either ByteString JSExpr
forall a b. a -> Either a b
Left ByteString
err_buf
                            }
                      Right () -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                  )
              () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            FatalError ByteString
err_buf ->
              STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
                TMVar (Either SomeException ByteString)
-> Either SomeException ByteString -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either SomeException ByteString)
_err_inbox (Either SomeException ByteString -> STM ())
-> Either SomeException ByteString -> STM ()
forall a b. (a -> b) -> a -> b
$
                  SomeException -> Either SomeException ByteString
forall a b. a -> Either a b
Left (SomeException -> Either SomeException ByteString)
-> SomeException -> Either SomeException ByteString
forall a b. (a -> b) -> a -> b
$
                    EvalError -> SomeException
forall e. Exception e => e -> SomeException
toException
                      EvalError :: FilePath -> EvalError
EvalError
                        { evalErrorMessage :: FilePath
evalErrorMessage = ByteString -> FilePath
stringFromLBS ByteString
err_buf
                        }
        ipc_post_close :: IO ()
ipc_post_close = do
          ExitCode
ec <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
_ph
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Bool
_ <- TMVar (Either SomeException ByteString)
-> Either SomeException ByteString -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar (Either SomeException ByteString)
_err_inbox (Either SomeException ByteString -> STM Bool)
-> Either SomeException ByteString -> STM Bool
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException ByteString
forall a b. a -> Either a b
Left (SomeException -> Either SomeException ByteString)
-> SomeException -> Either SomeException ByteString
forall a b. (a -> b) -> a -> b
$ SessionClosed -> SomeException
forall e. Exception e => e -> SomeException
toException SessionClosed
SessionClosed
            TMVar ExitCode -> ExitCode -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ExitCode
_exit_inbox ExitCode
ec
          FilePath -> IO ()
removePathForcibly FilePath
_root
    IPC
_ipc <-
      IPC -> IO IPC
ipcFork (IPC -> IO IPC) -> IPC -> IO IPC
forall a b. (a -> b) -> a -> b
$
        Handle -> Handle -> IPC -> IPC
ipcFromHandles
          Handle
_wh
          Handle
_rh
          IPC :: (ByteString -> IO ())
-> IO ByteString -> (ByteString -> IO ()) -> IO () -> IPC
IPC
            { send :: ByteString -> IO ()
send = FilePath -> ByteString -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"newSession: send",
              recv :: IO ByteString
recv = FilePath -> IO ByteString
forall a. HasCallStack => FilePath -> a
error FilePath
"newSession: recv",
              onRecv :: ByteString -> IO ()
onRecv = ByteString -> IO ()
on_recv,
              postClose :: IO ()
postClose = IO ()
ipc_post_close
            }
    let wait_for_exit :: IO ()
wait_for_exit = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ () () -> STM ExitCode -> STM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TMVar ExitCode -> STM ExitCode
forall a. TMVar a -> STM a
readTMVar TMVar ExitCode
_exit_inbox
        session_close :: IO ()
session_close = do
          IPC -> ByteString -> IO ()
send IPC
_ipc (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ MessageHS -> Builder
messageHSPut MessageHS
Close
          IO ()
wait_for_exit
        session_kill :: IO ()
session_kill = do
          ProcessHandle -> IO ()
terminateProcess ProcessHandle
_ph
          IO ()
wait_for_exit
        _session :: Session
_session =
          Session :: IPC
-> TMVar (Either SomeException ByteString)
-> IO ()
-> IO ()
-> Session
Session
            { ipc :: IPC
ipc = IPC
_ipc,
              fatalErrorInbox :: TMVar (Either SomeException ByteString)
fatalErrorInbox = TMVar (Either SomeException ByteString)
_err_inbox,
              closeSession :: IO ()
closeSession = IO ()
session_close,
              killSession :: IO ()
killSession = IO ()
session_kill
            }
    Session -> IO Session
forall (f :: * -> *) a. Applicative f => a -> f a
pure Session
_session

sessionSend :: Session -> MessageHS -> IO ()
sessionSend :: Session -> MessageHS -> IO ()
sessionSend Session {IO ()
TMVar (Either SomeException ByteString)
IPC
killSession :: IO ()
closeSession :: IO ()
fatalErrorInbox :: TMVar (Either SomeException ByteString)
ipc :: IPC
killSession :: Session -> IO ()
closeSession :: Session -> IO ()
fatalErrorInbox :: Session -> TMVar (Either SomeException ByteString)
ipc :: Session -> IPC
..} MessageHS
msg = IPC -> ByteString -> IO ()
send IPC
ipc (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ MessageHS -> Builder
messageHSPut MessageHS
msg

-- | Create a 'Session' with 'newSession', run the passed computation, then free
-- the 'Session' with 'killSession'. The return value is forced to WHNF before
-- freeing the 'Session' to reduce the likelihood of use-after-free errors.
withSession :: Config -> (Session -> IO r) -> IO r
withSession :: Config -> (Session -> IO r) -> IO r
withSession Config
c Session -> IO r
m = IO Session -> (Session -> IO ()) -> (Session -> IO r) -> IO r
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Config -> IO Session
newSession Config
c) Session -> IO ()
killSession (r -> IO r
forall a. a -> IO a
evaluate (r -> IO r) -> (Session -> IO r) -> Session -> IO r
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Session -> IO r
m)