hruby 0.3.8.1 → 0.4.0.0
raw patch · 5 files changed
+405/−343 lines, 5 filesdep ~aeson
Dependency ranges changed: aeson
Files
- Foreign/Ruby.hs +46/−42
- Foreign/Ruby/Helpers.hs +196/−163
- Foreign/Ruby/Safe.hs +134/−109
- hruby.cabal +3/−3
- test/roundtrip.hs +26/−26
Foreign/Ruby.hs view
@@ -5,52 +5,56 @@ -- > withRubyInterpreter $ \i -> do -- > dsqsddqs module Foreign.Ruby-( -- * Initialization / cleanup- RubyInterpreter- , startRubyInterpreter- , closeRubyInterpreter- , withRubyInterpreter- -- * Running Ruby actions- , loadFile- , Foreign.Ruby.Safe.embedHaskellValue- , Foreign.Ruby.Safe.safeMethodCall- , Foreign.Ruby.Safe.safeFunCall- , 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+ ( -- * Initialization / cleanup+ RubyInterpreter,+ startRubyInterpreter,+ closeRubyInterpreter,+ withRubyInterpreter,++ -- * Running Ruby actions+ loadFile,+ Foreign.Ruby.Safe.embedHaskellValue,+ Foreign.Ruby.Safe.safeMethodCall,+ Foreign.Ruby.Safe.safeFunCall,+ 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+import Foreign.Ruby.Helpers+import Foreign.Ruby.Safe -- | Gets the `RValue` correponding to the given named symbol. getSymbol :: String -> IO RValue
Foreign/Ruby/Helpers.hs view
@@ -1,157 +1,177 @@ {-# LANGUAGE OverloadedStrings #-}-module Foreign.Ruby.Helpers where+{-# LANGUAGE TypeApplications #-} -import Foreign.Ruby.Bindings+module Foreign.Ruby.Helpers where -import Foreign-import Foreign.C (withCString)-import Data.Aeson import Control.Monad-import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import Data.Aeson+import Data.Aeson.Key (coercionToText, fromText, toText)+import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Char8 as BS-import qualified Data.Vector as V import Data.IORef-import qualified Data.HashMap.Strict as HM import Data.Scientific+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Type.Coercion (coerceWith)+import qualified Data.Vector as V+import Foreign+import Foreign.C (withCString)+import Foreign.Ruby.Bindings -- | The class of things that can be converted from Ruby values. Note that -- there are a ton of stuff that are Ruby values, hence the `Maybe` type, -- as the instances will probably be incomplete. class FromRuby a where- -- | To define more instances, please look at the instances defined in- -- "Foreign.Ruby.Helpers".- fromRuby :: RValue -> IO (Either String a)+ -- | To define more instances, please look at the instances defined in+ -- "Foreign.Ruby.Helpers".+ 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+ toRuby :: a -> IO RValue 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 (Either String [a]) fromRubyArray v = do- nbelems <- arrayLength v- fmap sequence (forM [0..(nbelems-1)] (rb_ary_entry v >=> fromRuby))+ nbelems <- arrayLength v+ fmap sequence (forM [0 .. (nbelems - 1)] (rb_ary_entry v >=> fromRuby)) instance FromRuby a => FromRuby [a] where- fromRuby v = do- t <- rtype v- case t of- RBuiltin RARRAY -> fromRubyArray v- _ -> return $ Left ("not an array! " ++ show t)+ fromRuby v = do+ t <- rtype v+ case t of+ RBuiltin RARRAY -> fromRubyArray v+ _ -> return $ Left ("not an array! " ++ show t) instance ToRuby a => ToRuby [a] where- toRuby lst = do- vals <- mapM toRuby lst- Foreign.withArray vals (rb_ary_new4 (fromIntegral (length lst)))+ toRuby lst = do+ vals <- mapM toRuby lst+ Foreign.withArray vals (rb_ary_new4 (fromIntegral (length lst))) instance FromRuby BS.ByteString where- fromRuby v = do- t <- rtype v- case t of- RBuiltin RSTRING -> do- pv <- new v- cstr <- c_rb_string_value_cstr pv- free pv- fmap Right (BS.packCString cstr)- RSymbol -> fmap Right (rb_id2name (sym2id v) >>= BS.packCString)- _ -> return (Left ("Expected a string, not " ++ show t))+ fromRuby v = do+ t <- rtype v+ case t of+ RBuiltin RSTRING -> do+ pv <- new v+ cstr <- c_rb_string_value_cstr pv+ free pv+ 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+ toRuby s = BS.useAsCString s c_rb_str_new2 instance FromRuby T.Text where- fromRuby = fmap (fmap T.decodeUtf8) . fromRuby+ fromRuby = fmap (fmap T.decodeUtf8) . fromRuby+ instance ToRuby T.Text where- toRuby = toRuby . T.encodeUtf8+ toRuby = toRuby . T.encodeUtf8 instance ToRuby Double where- toRuby = newFloat+ toRuby = newFloat+ instance FromRuby Double where- fromRuby = fmap Right . num2dbl+ fromRuby = fmap Right . num2dbl instance FromRuby Integer where- fromRuby = fromRubyIntegral+ fromRuby = fromRubyIntegral+ instance ToRuby Integer where- toRuby = toRubyIntegral+ toRuby = toRubyIntegral+ instance FromRuby Int where- fromRuby = fromRubyIntegral+ fromRuby = fromRubyIntegral+ instance ToRuby Int where- toRuby = toRubyIntegral+ toRuby = toRubyIntegral +instance FromRuby Key where+ fromRuby = fmap (fmap fromText) . fromRuby @T.Text+ -- | This is the most complete instance that is provided in this module. -- Please note that it is far from being sufficient for even basic -- requirements. For example, the `Value` type can only encode -- dictionnaries with keys that can be converted to strings. instance FromRuby Value where- fromRuby v = do- t <- rtype v- case t of- RFixNum -> fmap (fmap (Number . (fromIntegral :: Integer -> Scientific))) (fromRuby v)- 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 (Right Null)- RBuiltin RSTRING -> fmap (fmap (String . T.decodeUtf8)) (fromRuby v)- RBuiltin RARRAY -> fmap (fmap (Array . V.fromList)) (fromRubyArray v)- 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- 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- appender key val _ = do- vvar <- readIORef var- vk <- fromRuby key- vv <- fromRuby val- case (vk, vv) of- (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 (Right . toHash) (readIORef var)- _ -> return $ Left ("Could not decode: " ++ show t)+ fromRuby v = do+ t <- rtype v+ case t of+ RFixNum -> fmap (fmap (Number . (fromIntegral :: Integer -> Scientific))) (fromRuby v)+ 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 (Right Null)+ RBuiltin RSTRING -> fmap (fmap (String . T.decodeUtf8)) (fromRuby v)+ RBuiltin RARRAY -> fmap (fmap (Array . V.fromList)) (fromRubyArray v)+ 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+ 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+ appender key val _ = do+ vvar <- readIORef var+ vk <- fromRuby key+ vv <- fromRuby val+ case (vk, vv) of+ (Right jk, Right jv) -> writeIORef var ((jk, jv) : vvar) >> return 0+ _ -> return 1+ toHash = Object . KM.fromList+ wappender <- mkRegisteredCB3 appender+ rb_hash_foreach v wappender rbNil+ freeHaskellFunPtr wappender+ fmap (Right . toHash) (readIORef var)+ _ -> return $ Left ("Could not decode: " ++ show t) instance ToRuby Scientific where- toRuby s | base10Exponent s >= 0 = toRuby (coefficient s)- | otherwise = toRuby (fromRational (toRational s) :: Double)+ toRuby s+ | base10Exponent s >= 0 = toRuby (coefficient s)+ | otherwise = toRuby (fromRational (toRational s) :: Double) instance ToRuby Value where- toRuby (Number x) = toRuby x- toRuby (String t) = let bs = T.encodeUtf8 t- in BS.useAsCString bs c_rb_str_new2- toRuby Null = return rbNil- toRuby (Bool True) = return rbTrue- toRuby (Bool False) = return rbFalse- toRuby (Array ar) = toRuby (V.toList ar)- toRuby (Object m) = do- hash <- rb_hash_new- forM_ (HM.toList m) $ \(k, v) -> do- rk <- toRuby k- rv <- toRuby v- rb_hash_aset hash rk rv- return hash+ toRuby (Number x) = toRuby x+ toRuby (String t) =+ let bs = T.encodeUtf8 t+ in BS.useAsCString bs c_rb_str_new2+ toRuby Null = return rbNil+ toRuby (Bool True) = return rbTrue+ toRuby (Bool False) = return rbFalse+ toRuby (Array ar) = toRuby (V.toList ar)+ toRuby (Object m) = do+ hash <- rb_hash_new+ forM_ (KM.toList m) $ \(k, v) -> do+ rk <- toRuby k+ rv <- toRuby v+ rb_hash_aset hash rk rv+ return hash +instance ToRuby Key where+ toRuby k = toRuby $ case coercionToText of+ Nothing -> toText k+ Just co -> coerceWith co k+ -- | 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- toRuby intptr+ intptr <- fmap (fromIntegral . ptrToIntPtr . castStablePtrToPtr) (newStablePtr v) :: IO Integer+ toRuby intptr -- | Frees the Haskell value represented by the corresponding `RValue`. -- This is probably extremely unsafe to do, and will most certainly lead to@@ -160,10 +180,10 @@ -- `embedHaskellValue`. freeHaskellValue :: RValue -> IO () freeHaskellValue v = do- intptr <- fromRuby v :: IO (Either String Integer)- case intptr of- Right i -> freeStablePtr (castPtrToStablePtr (intPtrToPtr (fromIntegral i)))- Left rr -> error ("Could not decode embedded value during free! " ++ rr)+ intptr <- fromRuby v :: IO (Either String Integer)+ case intptr of+ 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.@@ -172,21 +192,21 @@ -- a good vector for arbitrary code execution. extractHaskellValue :: RValue -> IO a extractHaskellValue v = do- intptr <- fromRuby v :: IO (Either String Integer)- case intptr of- Right i -> deRefStablePtr (castPtrToStablePtr (intPtrToPtr (fromIntegral i)))- Left rr -> error ("Could not decode embedded value! " ++ rr)+ intptr <- fromRuby v :: IO (Either String Integer)+ case intptr of+ Right i -> deRefStablePtr (castPtrToStablePtr (intPtrToPtr (fromIntegral i)))+ Left rr -> error ("Could not decode embedded value! " ++ rr) runscript :: String -> IO (Either String ()) runscript filename = do- ruby_initialization- status <- rb_load_protect filename 0- if status == 0- then ruby_finalize >> return (Right ())- else do- r <- showErrorStack- ruby_finalize- return (Left r)+ ruby_initialization+ status <- rb_load_protect filename 0+ if status == 0+ then ruby_finalize >> return (Right ())+ else do+ r <- showErrorStack+ ruby_finalize+ return (Left r) defineGlobalClass :: String -> IO RValue defineGlobalClass s = peek rb_cObject >>= rb_define_class s@@ -195,20 +215,25 @@ safeGetClass :: String -> IO (Either (String, RValue) RValue) safeGetClass s = withCString s $ \cs ->- with 0 $ \pstatus -> do- o <- c_rb_protect getRubyCObjectCallback (castPtr cs) pstatus- status <- peek pstatus- if status == 0- then pure $ Right o- else do- err <- showErrorStack- pure $ Left (err, o)+ with 0 $ \pstatus -> do+ o <- c_rb_protect getRubyCObjectCallback (castPtr cs) pstatus+ status <- peek pstatus+ if status == 0+ then pure $ Right o+ else do+ err <- showErrorStack+ pure $ Left (err, o) -- | Runs a Ruby singleton method, capturing errors.-safeMethodCall :: String -- ^ Name of a class or a module.- -> String -- ^ Method name.- -> [RValue] -- ^ Arguments. Please note that the maximum number of arguments is 16.- -> IO (Either (String, RValue) RValue) -- ^ Returns either an error message / value couple, or the value returned by the function.+safeMethodCall ::+ -- | Name of a class or a module.+ String ->+ -- | Method name.+ String ->+ -- | Arguments. Please note that the maximum number of arguments is 16.+ [RValue] ->+ -- | Returns either an error message / value couple, or the value returned by the function.+ IO (Either (String, RValue) RValue) safeMethodCall classname methodname args = do erecv <- safeGetClass classname case erecv of@@ -216,50 +241,59 @@ Left err -> pure $ Left err -- | Runs a Ruby method, capturing errors.-safeFunCall- :: RValue -- ^ Receiver.- -> String -- ^ Method name.- -> [RValue] -- ^ Arguments. Please note that the maximum number of arguments is 16.- -> IO (Either (String, RValue) RValue) -- ^ Returns either an error message / value couple, or the value returned by the function.+safeFunCall ::+ -- | Receiver.+ RValue ->+ -- | Method name.+ String ->+ -- | Arguments. Please note that the maximum number of arguments is 16.+ [RValue] ->+ -- | Returns either an error message / value couple, or the value returned by the function.+ IO (Either (String, RValue) RValue) safeFunCall recv methodname args | length args > 16 = pure $ Left ("too many arguments", rbNil) | otherwise =- rb_intern methodname >>= \methodid ->+ rb_intern methodname >>= \methodid -> with (ShimDispatch recv methodid args) $ \dispatch ->- with 0 $ \pstatus -> do- o <- c_rb_protect safeCallback (castPtr dispatch) pstatus- status <- peek pstatus- if status == 0- then pure $ Right o- else do- err <- showErrorStack- pure $ Left (err, o)+ with 0 $ \pstatus -> do+ o <- c_rb_protect safeCallback (castPtr dispatch) pstatus+ status <- peek pstatus+ if status == 0+ then pure $ Right o+ else do+ err <- showErrorStack+ pure $ Left (err, o) -- | Gives a (multiline) error friendly string representation of the last -- error. showErrorStack :: IO String showErrorStack = do- runtimeerror <- rb_gv_get "$!"- m <- if runtimeerror == rbNil- then return "Unknown runtime error"- else do- message <- rb_intern "message"- fmap (either T.pack id) (rb_funcall runtimeerror message [] >>= fromRuby)- rbt <- rb_gv_get "$@"- bt <- if rbt == rbNil- then return []- else fmap (either (const []) id) (fromRuby rbt)- return (T.unpack (T.unlines (m : bt)))+ runtimeerror <- rb_gv_get "$!"+ m <-+ if runtimeerror == rbNil+ then return "Unknown runtime error"+ else do+ message <- rb_intern "message"+ fmap (either T.pack id) (rb_funcall runtimeerror message [] >>= fromRuby)+ rbt <- rb_gv_get "$@"+ bt <-+ if rbt == rbNil+ then return []+ 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 -- from Ruby scripts.-setGC :: Bool -- ^ Set to `True` to enable GC, and to `False` to disable it.- -> IO (Either (String, RValue) RValue)+setGC ::+ -- | Set to `True` to enable GC, and to `False` to disable it.+ Bool ->+ IO (Either (String, RValue) RValue) setGC nw = do- let method = if nw- then "enable"- else "disable"- safeMethodCall "GC" method []+ let method =+ if nw+ then "enable"+ else "disable"+ safeMethodCall "GC" method [] -- | Runs the Ruby garbage collector. startGC :: IO ()@@ -269,9 +303,8 @@ -- will be re-enabled and the `startGC` function run. freezeGC :: IO a -> IO a freezeGC computation = do- Control.Monad.void (setGC False)- o <- computation- Control.Monad.void (setGC True)- startGC- return o-+ Control.Monad.void (setGC False)+ o <- computation+ Control.Monad.void (setGC True)+ startGC+ return o
Foreign/Ruby/Safe.hs view
@@ -1,63 +1,71 @@-{-# LANGUAGE LambdaCase, ForeignFunctionInterface #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE LambdaCase #-}+ -- | 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- , withRubyInterpreter+ ( -- * Initialization and finalization+ startRubyInterpreter,+ closeRubyInterpreter,+ withRubyInterpreter,+ -- * Data types- , RubyError(..)- , RValue- , RubyInterpreter+ RubyError (..),+ RValue,+ RubyInterpreter,+ -- * Safe variants of other funtions- , loadFile- , embedHaskellValue- , safeMethodCall- , safeFunCall- , makeSafe- , fromRuby- , toRuby- , freezeGC+ loadFile,+ embedHaskellValue,+ safeMethodCall,+ safeFunCall,+ makeSafe,+ fromRuby,+ toRuby,+ freezeGC,+ -- * Wrapping Haskell function and registering them- , RubyFunction1- , RubyFunction2- , RubyFunction3- , RubyFunction4- , RubyFunction5- , registerGlobalFunction1- , registerGlobalFunction2- , registerGlobalFunction3- , registerGlobalFunction4- , registerGlobalFunction5- ) where+ RubyFunction1,+ RubyFunction2,+ RubyFunction3,+ RubyFunction4,+ RubyFunction5,+ registerGlobalFunction1,+ registerGlobalFunction2,+ registerGlobalFunction3,+ registerGlobalFunction4,+ registerGlobalFunction5,+ )+where -import Foreign hiding (void)-import qualified Foreign.Ruby.Helpers as FR import Control.Applicative import Control.Concurrent-import Control.Exception.Base import Control.Concurrent.STM+import Control.Exception.Base import Control.Monad+import Foreign hiding (void) import Foreign.Ruby.Bindings+import qualified Foreign.Ruby.Helpers as FR import Prelude 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 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- | OtherError String- deriving Show+data RubyError+ = Stack String String+ | WithOutput String RValue+ | OtherError String+ deriving (Show) -- | This is actually a newtype around a 'TQueue'. newtype RubyInterpreter = RubyInterpreter (TQueue IMessage)@@ -66,25 +74,37 @@ -- 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) @@ -96,14 +116,14 @@ -- 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 <- newEmptyMVar- let embedded = a >>= putMVar mv- msg <- runMessage_ int (MakeSafe embedded)- case msg of- Right _ -> Right <$> takeMVar mv- Left rr -> return (Left rr)+ -- the IO a computation is embedded in an IO () computation, so that+ -- all is type safe+ mv <- newEmptyMVar+ let embedded = a >>= putMVar mv+ msg <- runMessage_ int (MakeSafe embedded)+ case msg of+ Right _ -> Right <$> takeMVar mv+ Left rr -> return (Left rr) -- | This transforms any Haskell value into a Ruby big integer encoding the -- address of the corresponding `StablePtr`. This is useful when you want@@ -117,84 +137,89 @@ embedHaskellValue int v = makeSafe int $ FR.embedHaskellValue v -- | A safe version of the corresponding "Foreign.Ruby.Helper" function.-safeMethodCall :: RubyInterpreter- -> String- -> String- -> [RValue]- -> IO (Either RubyError RValue)+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))+ 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)) -- | A safe version of the corresponding "Foreign.Ruby.Helper" function.-safeFunCall :: RubyInterpreter- -> RValue- -> String- -> [RValue]- -> IO (Either RubyError RValue)+safeFunCall ::+ RubyInterpreter ->+ RValue ->+ String ->+ [RValue] ->+ IO (Either RubyError RValue) safeFunCall int receiver methodName args = do- o <- makeSafe int $ FR.safeFunCall receiver 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))+ o <- makeSafe int $ FR.safeFunCall receiver 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))- maybe (Right ()) Left <$> atomically (readTMVar o)+ o <- newEmptyTMVarIO+ atomically (writeTQueue q (pm o))+ 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 (ruby_initialization >> go q)- return (RubyInterpreter q)--{-| This is basically :+ q <- newTQueueIO+ void $ forkOS (ruby_initialization >> go q)+ return (RubyInterpreter q) -> bracket startRubyInterpreter closeRubyInterpreter--}+-- | 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- 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 <- 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+ let continue = return False+ stop = return True+ runNoOutput :: NoOutput -> IO () -> IO Bool+ runNoOutput no a = do+ 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 <- 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- 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 ruby_finalize- else go q+ 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 ruby_finalize+ else go q -- | This will shut the internal server down. closeRubyInterpreter :: RubyInterpreter -> IO ()
hruby.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: hruby-version: 0.3.8.1+version: 0.4.0.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@@ -11,7 +11,7 @@ category: Language build-type: Custom extra-source-files: test/*.rb-Tested-With: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.1+Tested-With: GHC == 8.8.1, GHC == 8.10.2, GHC == 9.0.1 custom-setup setup-depends: Cabal, base, process@@ -25,7 +25,7 @@ exposed-modules: Foreign.Ruby, Foreign.Ruby.Bindings, Foreign.Ruby.Helpers, Foreign.Ruby.Safe ghc-options: -Wall build-depends: base >= 4.6 && < 5- , aeson >= 0.7+ , aeson >= 2 , bytestring >= 0.10.0.2 , text >= 0.11 , attoparsec >= 0.11 && < 0.15
test/roundtrip.hs view
@@ -1,19 +1,20 @@ module Main where -import Foreign.Ruby-import Data.Aeson import Control.Monad+import Data.Aeson+import Data.Aeson.Key (fromText)+import qualified Data.Text as T+import qualified Data.Vector as V+import Foreign.Ruby import System.Exit (exitFailure) import Test.QuickCheck import Test.QuickCheck.Monadic-import qualified Data.Text as T-import qualified Data.Vector as V subvalue :: Gen Value-subvalue = frequency [(50,s),(20,b),(20,n),(1,h),(1,a)]+subvalue = frequency [(50, s), (20, b), (20, n), (1, h), (1, a)] str :: Gen T.Text-str = fmap T.pack (listOf (elements (['A'..'Z'] ++ ['a' .. 'z'] ++ ['0'..'9'])))+str = fmap T.pack (listOf (elements (['A' .. 'Z'] ++ ['a' .. 'z'] ++ ['0' .. '9']))) s :: Gen Value s = fmap String str@@ -29,31 +30,30 @@ h :: Gen Value h = fmap object $ do- k <- listOf str- v <- listOf subvalue- return (zip k v)+ k <- map fromText <$> listOf str+ v <- listOf subvalue+ return (zip k v) avalue :: Gen Value-avalue = frequency [(1,s),(5,a),(1,b),(1,n),(5,h)]+avalue = frequency [(1, s), (5, a), (1, b), (1, n), (5, h)] roundTrip :: RubyInterpreter -> Property roundTrip i = monadicIO $ do- 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 <- 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+ 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 <- fromRuby i x >>= either (error . show) pure+ when (out /= v) (print out)+ return (v == out)+ Left rr -> print rr >> return False+ assert ex main :: IO () main = withRubyInterpreter $ \i -> do- loadFile i "./test/test.rb" >>= either (error . show) return- result <- quickCheckWithResult (stdArgs { maxSuccess = 1000 } ) (roundTrip i)- unless (isSuccess result) exitFailure+ loadFile i "./test/test.rb" >>= either (error . show) return+ result <- quickCheckWithResult (stdArgs {maxSuccess = 1000}) (roundTrip i)+ unless (isSuccess result) exitFailure