diff --git a/Foreign/Ruby.hs b/Foreign/Ruby.hs --- a/Foreign/Ruby.hs +++ b/Foreign/Ruby.hs @@ -1,63 +1,56 @@ --- | This is the main module of this library. Other functionnalities are --- exposed in "Foreign.Ruby.Bindings" and "Foreign.Ruby.Helpers", but this --- should be enough for most cases. +-- | The embedded Ruby interpreter must run on its own thread. The functions +-- in this module should enforce this property. For lower level access, +-- please look at "Foreign.Ruby.Bindings" and "Foreign.Ruby.Helpers". +-- +-- > withRubyInterpreter $ \i -> do +-- > dsqsddqs module Foreign.Ruby - ( -- * Initialization / cleanup - initialize - , finalize - -- * Converting from and to Ruby values - , RValue - , RID - , FromRuby (fromRuby) - , ToRuby (toRuby) - , getSymbol - -- * Callbacks - -- | These functions could be used to call Haskell functions from the Ruby - -- world. While fancier stuff could be achieved by tapping into - -- "Foreign.Ruby.Bindings", those methods should be easy to use and should - -- cover most use cases. - -- - -- The `embedHaskellValue`, `extractHaskellValue` and - -- `freeHaskellValue` functions are very unsafe, and should be used only in very - -- controlled environments. - , embedHaskellValue - , extractHaskellValue - , freeHaskellValue - , mkRegistered0 - , mkRegistered1 - , mkRegistered2 - , rb_define_global_function - -- * GC control - -- | This is a critical part of embedding the Ruby interpreter. Data - -- created using the `toRuby` function might be collected at any time. - -- For now, the solution is to disable the GC mechanism during calls to - -- Ruby functions. If someone knows of a better solution, please - -- contact the author of this library. - , setGC - , startGC - , freezeGC - -- * Interacting with the interpreter - , rb_load_protect - , safeMethodCall - -- * Error handling - , showErrorStack - -- * Various - , rb_iv_set - ) +( -- * Initialization / cleanup + RubyInterpreter + , startRubyInterpreter + , closeRubyInterpreter + , withRubyInterpreter + -- * Running Ruby actions + , loadFile + , Foreign.Ruby.Safe.embedHaskellValue + , Foreign.Ruby.Safe.safeMethodCall + , makeSafe + , RubyError(..) + -- * Converting to and from Ruby values + , RValue + , RID + , Foreign.Ruby.Safe.fromRuby + , Foreign.Ruby.Safe.toRuby + , Foreign.Ruby.Safe.freezeGC + , getSymbol + -- * Callbacks + -- | These functions could be used to call Haskell functions from the Ruby + -- world. While fancier stuff could be achieved by tapping into + -- "Foreign.Ruby.Bindings", those methods should be easy to use and should + -- cover most use cases. + -- + -- The `embedHaskellValue`, `extractHaskellValue` and + -- `freeHaskellValue` functions are very unsafe, and should be used only in very + -- controlled environments. + , freeHaskellValue + , extractHaskellValue + , RubyFunction1 + , RubyFunction2 + , RubyFunction3 + , RubyFunction4 + , RubyFunction5 + , registerGlobalFunction1 + , registerGlobalFunction2 + , registerGlobalFunction3 + , registerGlobalFunction4 + , registerGlobalFunction5 + ) where +import Foreign.Ruby.Safe import Foreign.Ruby.Helpers import Foreign.Ruby.Bindings --- | You must run this before anything else. -initialize :: IO () -initialize = ruby_init >> ruby_init_loadpath - --- | You might want to run this when you are done with all the Ruby stuff. -finalize :: IO () -finalize = ruby_finalize - -- | Gets the `RValue` correponding to the given named symbol. getSymbol :: String -> IO RValue getSymbol = fmap id2sym . rb_intern - diff --git a/Foreign/Ruby/Helpers.hs b/Foreign/Ruby/Helpers.hs --- a/Foreign/Ruby/Helpers.hs +++ b/Foreign/Ruby/Helpers.hs @@ -3,7 +3,6 @@ import Foreign.Ruby.Bindings -import Data.Maybe (fromMaybe) import Foreign import Data.Aeson import Control.Monad @@ -21,19 +20,19 @@ class FromRuby a where -- | To define more instances, please look at the instances defined in -- "Foreign.Ruby.Helpers". - fromRuby :: RValue -> IO (Maybe a) + fromRuby :: RValue -> IO (Either String a) -- | Whenever you use `ToRuby`, don't forget to use something like -- `freezeGC` or you will get random segfaults. class ToRuby a where toRuby :: a -> IO RValue -fromRubyIntegral :: Integral n => RValue -> IO (Maybe n) -fromRubyIntegral = fmap (Just . fromIntegral) . num2long +fromRubyIntegral :: Integral n => RValue -> IO (Either String n) +fromRubyIntegral = fmap (Right . fromIntegral) . num2long toRubyIntegral :: Integral n => n -> IO RValue toRubyIntegral = int2num . fromIntegral -fromRubyArray :: FromRuby a => RValue -> IO (Maybe [a]) +fromRubyArray :: FromRuby a => RValue -> IO (Either String [a]) fromRubyArray v = do nbelems <- arrayLength v fmap sequence (forM [0..(nbelems-1)] (rb_ary_entry v >=> fromRuby)) @@ -43,7 +42,7 @@ t <- rtype v case t of RBuiltin RARRAY -> fromRubyArray v - _ -> putStrLn ("not an array! " ++ show t) >> return Nothing + _ -> return $ Left ("not an array! " ++ show t) instance ToRuby a => ToRuby [a] where toRuby lst = do @@ -58,9 +57,9 @@ pv <- new v cstr <- c_rb_string_value_cstr pv free pv - fmap Just (BS.packCString cstr) - RSymbol -> fmap Just (rb_id2name (sym2id v) >>= BS.packCString) - _ -> return Nothing + fmap Right (BS.packCString cstr) + RSymbol -> fmap Right (rb_id2name (sym2id v) >>= BS.packCString) + _ -> return (Left ("Expected a string, not " ++ show t)) instance ToRuby BS.ByteString where toRuby s = BS.useAsCString s c_rb_str_new2 @@ -72,7 +71,7 @@ instance ToRuby Double where toRuby = newFloat instance FromRuby Double where - fromRuby = fmap Just . num2dbl + fromRuby = fmap Right . num2dbl instance FromRuby Integer where fromRuby = fromRubyIntegral @@ -92,23 +91,24 @@ t <- rtype v case t of RFixNum -> fmap (fmap (Number . (fromIntegral :: Integer -> Scientific))) (fromRuby v) - RNil -> return (Just Null) - RFalse -> return (Just (Bool False)) - RTrue -> return (Just (Bool True)) + RNil -> return (Right Null) + RFalse -> return (Right (Bool False)) + RTrue -> return (Right (Bool True)) RSymbol -> fmap (fmap (String . T.decodeUtf8)) (fromRuby v) - RBuiltin RNIL -> return (Just Null) + RBuiltin RNIL -> return (Right Null) RBuiltin RSTRING -> fmap (fmap (String . T.decodeUtf8)) (fromRuby v) RBuiltin RARRAY -> fmap (fmap (Array . V.fromList)) (fromRubyArray v) - RBuiltin RTRUE -> return (Just (Bool True)) - RBuiltin RFALSE -> return (Just (Bool False)) - RBuiltin RUNDEF -> return (Just Null) + RBuiltin RTRUE -> return (Right (Bool True)) + RBuiltin RFALSE -> return (Right (Bool False)) + RBuiltin RUNDEF -> return (Right Null) RBuiltin RFLOAT -> fmap (fmap (Number . fromRational . (toRational :: Double -> Rational))) (fromRuby v) RBuiltin RBIGNUM -> do bs <- rb_big2str v 10 >>= fromRuby - case fmap BS.readInteger bs of - Just (Just (x,"")) -> return (Just (Number (fromIntegral x))) - _ -> return Nothing - RBuiltin RNONE -> return (Just Null) + return $ case fmap BS.readInteger bs of + Right (Just (x,"")) -> Right (Number (fromIntegral x)) + Right _ -> Left ("Expected an integer, not " ++ show bs) + Left rr -> Left rr + RBuiltin RNONE -> return (Right Null) RBuiltin RHASH -> do var <- newIORef [] let appender :: RValue -> RValue -> RValue -> IO Int @@ -117,16 +117,14 @@ vk <- fromRuby key vv <- fromRuby val case (vk, vv) of - (Just jk, Just jv) -> writeIORef var ( (jk,jv) : vvar ) >> return 0 + (Right jk, Right jv) -> writeIORef var ( (jk,jv) : vvar ) >> return 0 _ -> return 1 toHash = Object . HM.fromList wappender <- mkRegisteredCB3 appender rb_hash_foreach v wappender rbNil freeHaskellFunPtr wappender - fmap (Just . toHash) (readIORef var) - _ -> do - putStrLn ("Could not decode: " ++ show t) - return Nothing + fmap (Right . toHash) (readIORef var) + _ -> return $ Left ("Could not decode: " ++ show t) instance ToRuby Scientific where toRuby s | base10Exponent s >= 0 = toRuby (coefficient s) @@ -148,14 +146,7 @@ rb_hash_aset hash rk rv return hash --- | This transforms any Haskell value into a Ruby big integer encoding the --- address of the corresponding `StablePtr`. This is useful when you want --- to pass such values to a Ruby program that will call Haskell functions. --- --- This is probably a bad idea to do this. The use case is for calling --- Haskell functions from Ruby, using values generated from the Haskell --- world. If your main program is in Haskell, you should probably wrap --- a function partially applied with the value you would want to embed. +-- | An unsafe version of the corresponding "Foreign.Ruby.Safe" function. embedHaskellValue :: a -> IO RValue embedHaskellValue v = do intptr <- fmap (fromIntegral . ptrToIntPtr . castStablePtrToPtr) (newStablePtr v) :: IO Integer @@ -168,10 +159,10 @@ -- `embedHaskellValue`. freeHaskellValue :: RValue -> IO () freeHaskellValue v = do - intptr <- fromRuby v :: IO (Maybe Integer) + intptr <- fromRuby v :: IO (Either String Integer) case intptr of - Just i -> freeStablePtr (castPtrToStablePtr (intPtrToPtr (fromIntegral i))) - Nothing -> error "Could not decode embedded value during free!" + Right i -> freeStablePtr (castPtrToStablePtr (intPtrToPtr (fromIntegral i))) + Left rr -> error ("Could not decode embedded value during free! " ++ rr) -- | This is unsafe as hell, so you'd better be certain this RValue has not -- been tempered with : GC frozen, bugfree Ruby scripts. @@ -180,10 +171,10 @@ -- a good vector for arbitrary code execution. extractHaskellValue :: RValue -> IO a extractHaskellValue v = do - intptr <- fromRuby v :: IO (Maybe Integer) + intptr <- fromRuby v :: IO (Either String Integer) case intptr of - Just i -> deRefStablePtr (castPtrToStablePtr (intPtrToPtr (fromIntegral i))) - Nothing -> error "Could not decode embedded value!" + Right i -> deRefStablePtr (castPtrToStablePtr (intPtrToPtr (fromIntegral i))) + Left rr -> error ("Could not decode embedded value! " ++ rr) runscript :: String -> IO (Either String ()) runscript filename = do @@ -230,11 +221,11 @@ then return "Unknown runtime error" else do message <- rb_intern "message" - fmap (fromMaybe "undeserializable error") (rb_funcall runtimeerror message [] >>= fromRuby) + fmap (either T.pack id) (rb_funcall runtimeerror message [] >>= fromRuby) rbt <- rb_gv_get "$@" bt <- if rbt == rbNil then return [] - else fmap (fromMaybe []) (fromRuby rbt) + else fmap (either (const []) id) (fromRuby rbt) return (T.unpack (T.unlines (m : bt))) -- | Sets the current GC operation. Please note that this could be modified diff --git a/Foreign/Ruby/Safe.hs b/Foreign/Ruby/Safe.hs --- a/Foreign/Ruby/Safe.hs +++ b/Foreign/Ruby/Safe.hs @@ -6,6 +6,7 @@ ( -- * Initialization and finalization startRubyInterpreter , closeRubyInterpreter + , withRubyInterpreter -- * Data types , RubyError(..) , RValue @@ -15,6 +16,9 @@ , embedHaskellValue , safeMethodCall , makeSafe + , fromRuby + , toRuby + , freezeGC -- * Wrapping Haskell function and registering them , RubyFunction1 , RubyFunction2 @@ -29,8 +33,10 @@ ) where import Foreign hiding (void) -import qualified Foreign.Ruby as FR +import qualified Foreign.Ruby.Helpers as FR +import Control.Applicative import Control.Concurrent +import Control.Exception.Base import Control.Concurrent.STM import Control.Monad import Foreign.Ruby.Bindings @@ -46,11 +52,12 @@ | RegisterGlobalFunction5 !String !RubyFunction5 !NoOutput | MakeSafe !(IO ()) !NoOutput -data RubyError = Stack !String !String - | WithOutput !String !RValue +data RubyError = Stack String String + | WithOutput String RValue + | OtherError String deriving Show --- | This is acutally a newtype around a 'TQueue'. +-- | This is actually a newtype around a 'TQueue'. newtype RubyInterpreter = RubyInterpreter (TQueue IMessage) -- | All those function types can be used to register functions to the Ruby @@ -89,14 +96,21 @@ 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 + mv <- newEmptyMVar + let embedded = a >>= putMVar mv msg <- runMessage_ int (MakeSafe embedded) case msg of - Right _ -> Right `fmap` atomically (readTMVar mv) + Right _ -> Right <$> takeMVar mv Left rr -> return (Left rr) --- | A safe version of the corresponding "Foreign.Ruby" function. +-- | This transforms any Haskell value into a Ruby big integer encoding the +-- address of the corresponding `StablePtr`. This is useful when you want +-- to pass such values to a Ruby program that will call Haskell functions. +-- +-- This is probably a bad idea to do this. The use case is for calling +-- Haskell functions from Ruby, using values generated from the Haskell +-- world. If your main program is in Haskell, you should probably wrap +-- a function partially applied with the value you would want to embed. embedHaskellValue :: RubyInterpreter -> a -> IO (Either RubyError RValue) embedHaskellValue int v = makeSafe int $ FR.embedHaskellValue v @@ -117,35 +131,41 @@ runMessage_ (RubyInterpreter q) pm = do o <- newEmptyTMVarIO atomically (writeTQueue q (pm o)) - atomically (readTMVar o) >>= \case - Nothing -> return (Right ()) - Just r -> return (Left r) + maybe (Right ()) Left <$> atomically (readTMVar o) -- | 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) + void $ forkOS (ruby_init >> ruby_init_loadpath >> go q) return (RubyInterpreter q) +{-| This is basically : + +> bracket startRubyInterpreter closeRubyInterpreter +-} +withRubyInterpreter :: (RubyInterpreter -> IO a) -> IO a +withRubyInterpreter = bracket startRubyInterpreter closeRubyInterpreter + 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 + try a >>= atomically . putTMVar no . either (\e -> Just $ OtherError $ show (e :: SomeException)) + (const 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 + s <- try a + case s of + Right 0 -> atomically (putTMVar no Nothing) + Right _ -> do stack <- FR.showErrorStack atomically $ putTMVar no $ Just $ Stack errmsg stack + Left e -> atomically $ putTMVar no $ Just $ OtherError $ show (e :: SomeException) continue finished <- atomically (readTQueue q) >>= \case @@ -158,10 +178,22 @@ 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 + then ruby_finalize else go q -- | This will shut the internal server down. closeRubyInterpreter :: RubyInterpreter -> IO () closeRubyInterpreter (RubyInterpreter q) = atomically (writeTQueue q MsgStop) +-- | Converts a Ruby value to some Haskell type.. +fromRuby :: FR.FromRuby a => RubyInterpreter -> RValue -> IO (Either RubyError a) +fromRuby ri rv = either Left (either (Left . OtherError) Right) <$> makeSafe ri (FR.fromRuby rv) + +-- | Insert a value in the Ruby runtime. You must always use such +-- a function and the resulting RValue ina 'freezeGC' call. +toRuby :: FR.ToRuby a => RubyInterpreter -> a -> IO (Either RubyError RValue) +toRuby ri = makeSafe ri . FR.toRuby + +-- | Runs a computation with the Ruby GC disabled. Once the computation is over, GC will be re-enabled and the `startGC` function run. +freezeGC :: RubyInterpreter -> IO a -> IO a +freezeGC ri c = makeSafe ri (FR.setGC False) *> c <* makeSafe ri (FR.setGC True >> FR.startGC) 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.2.9 +version: 0.3.0 synopsis: Embed a Ruby intepreter in your Haskell program ! description: This doesn't work with Ruby 1.9. Everything you need should be in Foreign.Ruby.Safe. license: BSD3 @@ -22,6 +22,7 @@ library exposed-modules: Foreign.Ruby, Foreign.Ruby.Bindings, Foreign.Ruby.Helpers, Foreign.Ruby.Safe ghc-options: -Wall + ghc-prof-options: -caf-all -auto-all extensions: BangPatterns, OverloadedStrings build-depends: base >= 4.6 && < 4.8 , aeson >= 0.7 && < 0.9 @@ -40,6 +41,7 @@ hs-source-dirs: test type: exitcode-stdio-1.0 ghc-options: -Wall -threaded + ghc-prof-options: -caf-all -auto-all extensions: OverloadedStrings build-depends: base >= 4.6 && < 4.8,hruby,aeson,QuickCheck,text,attoparsec,vector main-is: roundtrip.hs diff --git a/test/roundtrip.hs b/test/roundtrip.hs --- a/test/roundtrip.hs +++ b/test/roundtrip.hs @@ -1,19 +1,13 @@ module Main where -import Foreign.Ruby.Helpers(toRuby,fromRuby,freezeGC) -import Foreign.Ruby.Bindings -import Foreign.Ruby.Safe +import Foreign.Ruby import Data.Aeson import Control.Monad import Test.QuickCheck import Test.QuickCheck.Monadic import qualified Data.Text as T -import Data.Attoparsec.Number import qualified Data.Vector as V -instance Arbitrary Number where - arbitrary = frequency [ (1, fmap D arbitrary) , (1, fmap I arbitrary) ] - subvalue :: Gen Value subvalue = frequency [(50,s),(20,b),(20,n),(1,h),(1,a)] @@ -38,33 +32,26 @@ v <- listOf subvalue return (zip k v) -instance Arbitrary Value where - arbitrary = frequency [(1,s),(5,a),(1,b),(1,n),(5,h)] +avalue :: Gen Value +avalue = frequency [(1,s),(5,a),(1,b),(1,n),(5,h)] roundTrip :: RubyInterpreter -> Property roundTrip i = monadicIO $ do - v <- pick (arbitrary :: Gen Value) - ex <- run $ freezeGC $ do - rub <- makeSafe i (toRuby v) >>= \r -> case r of - Right r' -> return r' - Left rr -> error (show rr) + v <- pick avalue + ex <- run $ freezeGC i $ do + rub <- toRuby i v >>= either (error . show) return nxt <- safeMethodCall i "TestClass" "testfunc" [rub] case nxt of Right x -> do - out <- makeSafe i (fromRuby x) >>= \r -> case r of - Right r' -> return r' - Left rr -> error (show rr) - when (out /= Just v) (print out) - return (Just v == out) + out <- fromRuby i x >>= \r -> case r of + Right r' -> return r' + Left rr -> error (show rr) + when (out /= v) (print out) + return (v == out) Left rr -> print rr >> return False assert ex main :: IO () -main = do - i <- startRubyInterpreter - putStrLn "loading" - loadFile i "./test/test.rb" >>= \o -> case o of - Right () -> return () - Left rr -> error (show rr) +main = withRubyInterpreter $ \i -> do + loadFile i "./test/test.rb" >>= either (error . show) return quickCheckWith (stdArgs { maxSuccess = 1000 } ) (roundTrip i) - closeRubyInterpreter i