diff --git a/Foreign/Ruby/Safe.hs b/Foreign/Ruby/Safe.hs new file mode 100644 --- /dev/null +++ b/Foreign/Ruby/Safe.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE LambdaCase, ForeignFunctionInterface #-} +-- | This modules materializes the ruby interpreters as the +-- 'RubyInterpreter' data type. All the calls using these APIs are +-- garanteed to run in the OS thread that the interpreter expects. +module Foreign.Ruby.Safe + ( -- * Initialization and finalization + startRubyInterpreter + , closeRubyInterpreter + -- * Data types + , RubyError(..) + , RValue + , RubyInterpreter + -- * Safe variants of other funtions + , loadFile + , embedHaskellValue + , safeMethodCall + , makeSafe + -- * Wrapping Haskell function and registering them + , RubyFunction1 + , RubyFunction2 + , RubyFunction3 + , RubyFunction4 + , RubyFunction5 + , registerGlobalFunction1 + , registerGlobalFunction2 + , registerGlobalFunction3 + , registerGlobalFunction4 + , registerGlobalFunction5 + ) where + +import Foreign hiding (void) +import qualified Foreign.Ruby as FR +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Foreign.Ruby.Bindings + +type NoOutput = TMVar (Maybe RubyError) + +data IMessage = MsgStop + | MsgLoadFile !FilePath !NoOutput + | RegisterGlobalFunction1 !String !RubyFunction1 !NoOutput + | RegisterGlobalFunction2 !String !RubyFunction2 !NoOutput + | RegisterGlobalFunction3 !String !RubyFunction3 !NoOutput + | RegisterGlobalFunction4 !String !RubyFunction4 !NoOutput + | RegisterGlobalFunction5 !String !RubyFunction5 !NoOutput + | MakeSafe !(IO ()) !NoOutput + +data RubyError = Stack !String !String + | WithOutput !String !RValue + deriving Show + +-- | This is acutally a newtype around a 'TQueue'. +newtype RubyInterpreter = RubyInterpreter (TQueue IMessage) + +-- | All those function types can be used to register functions to the Ruby +-- runtime. Please note that the first argument is always set (it is +-- \"self\"). For this reason, there is no @RubyFunction0@ type. +type RubyFunction1 = RValue -> IO RValue +type RubyFunction2 = RValue -> RValue -> IO RValue +type RubyFunction3 = RValue -> RValue -> RValue -> IO RValue +type RubyFunction4 = RValue -> RValue -> RValue -> RValue -> IO RValue +type RubyFunction5 = RValue -> RValue -> RValue -> RValue -> RValue -> IO RValue + +foreign import ccall "wrapper" mkRegisteredRubyFunction1 :: RubyFunction1 -> IO (FunPtr RubyFunction1) +foreign import ccall "wrapper" mkRegisteredRubyFunction2 :: RubyFunction2 -> IO (FunPtr RubyFunction2) +foreign import ccall "wrapper" mkRegisteredRubyFunction3 :: RubyFunction3 -> IO (FunPtr RubyFunction3) +foreign import ccall "wrapper" mkRegisteredRubyFunction4 :: RubyFunction4 -> IO (FunPtr RubyFunction4) +foreign import ccall "wrapper" mkRegisteredRubyFunction5 :: RubyFunction5 -> IO (FunPtr RubyFunction5) + +registerGlobalFunction1 :: RubyInterpreter -> String -> RubyFunction1 -> IO (Either RubyError ()) +registerGlobalFunction1 int fname f = runMessage_ int (RegisterGlobalFunction1 fname f) +registerGlobalFunction2 :: RubyInterpreter -> String -> RubyFunction2 -> IO (Either RubyError ()) +registerGlobalFunction2 int fname f = runMessage_ int (RegisterGlobalFunction2 fname f) +registerGlobalFunction3 :: RubyInterpreter -> String -> RubyFunction3 -> IO (Either RubyError ()) +registerGlobalFunction3 int fname f = runMessage_ int (RegisterGlobalFunction3 fname f) +registerGlobalFunction4 :: RubyInterpreter -> String -> RubyFunction4 -> IO (Either RubyError ()) +registerGlobalFunction4 int fname f = runMessage_ int (RegisterGlobalFunction4 fname f) +registerGlobalFunction5 :: RubyInterpreter -> String -> RubyFunction5 -> IO (Either RubyError ()) +registerGlobalFunction5 int fname f = runMessage_ int (RegisterGlobalFunction5 fname f) + +loadFile :: RubyInterpreter -> FilePath -> IO (Either RubyError ()) +loadFile int fp = runMessage_ int (MsgLoadFile fp) + +-- | Runs an arbitrary computation in the Ruby interpreter thread. This is +-- useful if you want to embed calls from lower level functions. You still +-- need to be careful about the GC's behavior. +makeSafe :: RubyInterpreter -> IO a -> IO (Either RubyError a) +makeSafe int a = do + -- the IO a computation is embedded in an IO () computation, so that + -- all is type safe + mv <- newEmptyTMVarIO + let embedded = a >>= atomically . putTMVar mv + msg <- runMessage_ int (MakeSafe embedded) + case msg of + Right _ -> Right `fmap` atomically (readTMVar mv) + Left rr -> return (Left rr) + +-- | A safe version of the corresponding "Foreign.Ruby" function. +embedHaskellValue :: RubyInterpreter -> a -> IO (Either RubyError RValue) +embedHaskellValue int v = makeSafe int $ FR.embedHaskellValue v + +-- | A safe version of the corresponding "Foreign.Ruby" function. +safeMethodCall :: RubyInterpreter + -> String + -> String + -> [RValue] + -> IO (Either RubyError RValue) +safeMethodCall int className methodName args = do + o <- makeSafe int $ FR.safeMethodCall className methodName args + case o of + Left x -> return (Left x) + Right (Right v) -> return (Right v) + Right (Left (s,v)) -> return (Left (WithOutput s v)) + +runMessage_ :: RubyInterpreter -> (NoOutput -> IMessage) -> IO (Either RubyError ()) +runMessage_ (RubyInterpreter q) pm = do + o <- newEmptyTMVarIO + atomically (writeTQueue q (pm o)) + atomically (readTMVar o) >>= \case + Nothing -> return (Right ()) + Just r -> return (Left r) + +-- | Initializes a Ruby interpreter. This should only be called once. It +-- actually runs an internal server in a dedicated OS thread. +startRubyInterpreter :: IO RubyInterpreter +startRubyInterpreter = do + q <- newTQueueIO + void $ forkOS (FR.initialize >> go q) + return (RubyInterpreter q) + +go :: TQueue IMessage -> IO () +go q = do + let continue = return False + stop = return True + runNoOutput :: NoOutput -> IO () -> IO Bool + runNoOutput no a = do + a -- TODO catch exceptions + atomically $ putTMVar no Nothing + continue + runReturns0 :: NoOutput -> IO Int -> String -> IO Bool + runReturns0 no a errmsg = do + s <- a -- TODO catch exceptions + if s == 0 + then atomically (putTMVar no Nothing) + else do + stack <- FR.showErrorStack + atomically $ putTMVar no $ Just $ Stack errmsg stack + continue + + finished <- atomically (readTQueue q) >>= \case + MsgStop -> stop + MsgLoadFile fp mv -> runReturns0 mv (rb_load_protect fp 0) ("Could not load " ++ fp) + RegisterGlobalFunction1 fname f no -> runNoOutput no $ mkRegisteredRubyFunction1 f >>= \rf -> rb_define_global_function fname rf 0 + RegisterGlobalFunction2 fname f no -> runNoOutput no $ mkRegisteredRubyFunction2 f >>= \rf -> rb_define_global_function fname rf 1 + RegisterGlobalFunction3 fname f no -> runNoOutput no $ mkRegisteredRubyFunction3 f >>= \rf -> rb_define_global_function fname rf 2 + RegisterGlobalFunction4 fname f no -> runNoOutput no $ mkRegisteredRubyFunction4 f >>= \rf -> rb_define_global_function fname rf 3 + RegisterGlobalFunction5 fname f no -> runNoOutput no $ mkRegisteredRubyFunction5 f >>= \rf -> rb_define_global_function fname rf 4 + MakeSafe a no -> runNoOutput no a + if finished + then FR.finalize + else go q + +-- | This will shut the internal server down. +closeRubyInterpreter :: RubyInterpreter -> IO () +closeRubyInterpreter (RubyInterpreter q) = atomically (writeTQueue q MsgStop) + diff --git a/hruby.cabal b/hruby.cabal --- a/hruby.cabal +++ b/hruby.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: hruby -version: 0.1.2 +version: 0.1.3 synopsis: Embed Ruby in your Haskell program. description: Warning: this is completely experimental. Everything you need should be in "Foreign.Ruby". license: BSD3 @@ -28,16 +28,17 @@ library - exposed-modules: Foreign.Ruby, Foreign.Ruby.Bindings, Foreign.Ruby.Helpers + exposed-modules: Foreign.Ruby, Foreign.Ruby.Bindings, Foreign.Ruby.Helpers, Foreign.Ruby.Safe ghc-options: -Wall extensions: BangPatterns, OverloadedStrings build-depends: base ==4.6.* , aeson >= 0.6.2.0 && < 0.7 - , bytestring + , bytestring >= 0.10.0.2 + , text >= 0.11 , attoparsec >= 0.10 && < 0.11 , vector >= 0.10 && < 0.11 - , text >= 0.11 && < 0.12 , unordered-containers >= 0.2 && < 0.3 + , stm >= 2.4 && < 2.5 c-sources: cbits/shim.c install-includes: cbits/shim.h include-dirs: cbits