diff --git a/Foreign/Ruby.hs b/Foreign/Ruby.hs new file mode 100644 --- /dev/null +++ b/Foreign/Ruby.hs @@ -0,0 +1,61 @@ +-- | 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. +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 + ) +where + +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/Bindings.hsc b/Foreign/Ruby/Bindings.hsc new file mode 100644 --- /dev/null +++ b/Foreign/Ruby/Bindings.hsc @@ -0,0 +1,275 @@ +{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances #-} + +#include "shim.h" + +module Foreign.Ruby.Bindings where + +import Foreign +import Foreign.C + +-- | This is the type of Ruby values. It is defined as a pointer to some unsigned long, just like Ruby does. The actual value is either pointed to, or encoded in the pointer. +type RValue = Ptr CULong + +-- | The Ruby ID type, mostly used for symbols. +type RID = CULong + +data ShimDispatch = ShimDispatch String String [RValue] +instance Storable ShimDispatch where + sizeOf _ = (#size struct s_dispatch) + alignment = sizeOf + peek ptr = do a <- peekCString ((#ptr struct s_dispatch, classname) ptr) + b <- peekCString ((#ptr struct s_dispatch, methodname) ptr) + return (ShimDispatch a b []) + poke ptr (ShimDispatch c m vals) = do + cs <- newCString c + cm <- newCString m + (#poke struct s_dispatch, classname) ptr cs + (#poke struct s_dispatch, methodname) ptr cm + (#poke struct s_dispatch, nbargs) ptr (length vals) + let arrayblock = (#ptr struct s_dispatch, args) ptr + pokeArray arrayblock vals + +builtinToInt :: RBuiltin -> CULong +builtinToInt RNONE = 0x00 +builtinToInt RNIL = 0x01 +builtinToInt ROBJECT = 0x02 +builtinToInt RCLASS = 0x03 +builtinToInt RICLASS = 0x04 +builtinToInt RMODULE = 0x05 +builtinToInt RFLOAT = 0x06 +builtinToInt RSTRING = 0x07 +builtinToInt RREGEXP = 0x08 +builtinToInt RARRAY = 0x09 +builtinToInt RFIXNUM = 0x0a +builtinToInt RHASH = 0x0b +builtinToInt RSTRUCT = 0x0c +builtinToInt RBIGNUM = 0x0d +builtinToInt RFILE = 0x0e +builtinToInt RTRUE = 0x20 +builtinToInt RFALSE = 0x21 +builtinToInt RDATA = 0x22 +builtinToInt RMATCH = 0x23 +builtinToInt RSYMBOL = 0x24 +builtinToInt RBLKTAG = 0x3b +builtinToInt RUNDEF = 0x3c +builtinToInt RVARMAP = 0x3d +builtinToInt RSCOPE = 0x3e +builtinToInt RNODE = 0x3f + +intToBuiltin :: CULong -> RBuiltin +-- intToBuiltin 0x00 = RNONE +intToBuiltin 0x01 = RNIL +intToBuiltin 0x02 = ROBJECT +intToBuiltin 0x03 = RCLASS +intToBuiltin 0x04 = RICLASS +intToBuiltin 0x05 = RMODULE +intToBuiltin 0x06 = RFLOAT +intToBuiltin 0x07 = RSTRING +intToBuiltin 0x08 = RREGEXP +intToBuiltin 0x09 = RARRAY +intToBuiltin 0x0a = RFIXNUM +intToBuiltin 0x0b = RHASH +intToBuiltin 0x0c = RSTRUCT +intToBuiltin 0x0d = RBIGNUM +intToBuiltin 0x0e = RFILE +intToBuiltin 0x20 = RTRUE +intToBuiltin 0x21 = RFALSE +intToBuiltin 0x22 = RDATA +intToBuiltin 0x23 = RMATCH +intToBuiltin 0x24 = RSYMBOL +intToBuiltin 0x3b = RBLKTAG +intToBuiltin 0x3c = RUNDEF +intToBuiltin 0x3d = RVARMAP +intToBuiltin 0x3e = RSCOPE +intToBuiltin 0x3f = RNODE +intToBuiltin _ = RNONE + +-- | The ruby built-in types +data RBuiltin = RNONE + | RNIL + | ROBJECT + | RCLASS + | RICLASS + | RMODULE + | RFLOAT + | RSTRING + | RREGEXP + | RARRAY + | RFIXNUM + | RHASH + | RSTRUCT + | RBIGNUM + | RFILE + | RTRUE + | RFALSE + | RDATA + | RMATCH + | RSYMBOL + | RBLKTAG + | RUNDEF + | RVARMAP + | RSCOPE + | RNODE + deriving (Show) + +-- | Ruby native types, as encoded in the Value type. +data RType = RFixNum + | RNil + | RFalse + | RTrue + | RSymbol + | RBuiltin RBuiltin + deriving (Show) + +type Registered0 = IO RValue +type Registered1 = RValue -> IO RValue +type Registered2 = RValue -> RValue -> IO RValue + +-- | Creates a function pointer suitable for usage with `rb_define_global_function` of type `Registered0` (with 0 arguments). +foreign import ccall "wrapper" mkRegistered0 :: Registered0 -> IO (FunPtr Registered0) +-- | Creates a function pointer suitable for usage with `rb_define_global_function` of type `Registered1` (with 1 `RValue` arguments). +foreign import ccall "wrapper" mkRegistered1 :: Registered1 -> IO (FunPtr Registered1) +-- | Creates a function pointer suitable for usage with `rb_define_global_function` of type `Registered2` (with 2 `RValue` arguments). +foreign import ccall "wrapper" mkRegistered2 :: Registered2 -> IO (FunPtr Registered2) + +type RegisteredCB3 = RValue -> RValue -> RValue -> IO Int +foreign import ccall "wrapper" mkRegisteredCB3 :: RegisteredCB3 -> IO (FunPtr RegisteredCB3) + +foreign import ccall "ruby_init" ruby_init :: IO () +foreign import ccall "ruby_finalize" ruby_finalize :: IO () +foreign import ccall "ruby_init_loadpath" ruby_init_loadpath :: IO () +foreign import ccall "rb_str_new2" c_rb_str_new2 :: CString -> IO RValue +foreign import ccall "rb_load_protect" c_rb_load_protect :: RValue -> Int -> Ptr Int -> IO () +foreign import ccall "rb_funcall" c_rb_funcall_0 :: RValue -> RID -> Int -> IO RValue +foreign import ccall "rb_funcall" c_rb_funcall_1 :: RValue -> RID -> Int -> RValue -> IO RValue +foreign import ccall "rb_funcall" c_rb_funcall_2 :: RValue -> RID -> Int -> RValue -> RValue -> IO RValue +foreign import ccall "rb_funcall" c_rb_funcall_3 :: RValue -> RID -> Int -> RValue -> RValue -> RValue -> IO RValue +foreign import ccall "rb_funcall" c_rb_funcall_4 :: RValue -> RID -> Int -> RValue -> RValue -> RValue -> RValue -> IO RValue +foreign import ccall "rb_funcall" c_rb_funcall_5 :: RValue -> RID -> Int -> RValue -> RValue -> RValue -> RValue -> RValue -> IO RValue +foreign import ccall "rb_gv_get" c_rb_gv_get :: CString -> IO RValue +foreign import ccall "rb_intern" c_rb_intern :: CString -> IO RID +foreign import ccall "rb_id2name" rb_id2name :: RID -> IO CString +foreign import ccall "rb_string_value_ptr" c_rb_string_value_ptr :: Ptr RValue -> IO CString +foreign import ccall "&rb_cObject" rb_cObject :: Ptr RValue +foreign import ccall "&ruby_errinfo" ruby_errinfo :: Ptr RValue +foreign import ccall "rb_define_class" c_rb_define_class :: CString -> RValue -> IO RValue +foreign import ccall "rb_define_method" c_rb_define_method :: RValue -> CString -> FunPtr a -> Int -> IO () +foreign import ccall "rb_define_global_function" c_rb_define_global_function :: CString -> FunPtr a -> Int -> IO () +foreign import ccall "rb_const_get" rb_const_get :: RValue -> RID -> IO RValue +foreign import ccall "&safeCall" safeCallback :: FunPtr (RValue -> IO RValue) +foreign import ccall "rb_protect" c_rb_protect :: FunPtr (RValue -> IO RValue) -> RValue -> Ptr Int -> IO RValue +foreign import ccall "rb_string_value_cstr" c_rb_string_value_cstr :: Ptr RValue -> IO CString +foreign import ccall "rb_ary_new" rb_ary_new :: IO RValue +foreign import ccall "rb_ary_new2" rb_ary_new2 :: CLong -> IO RValue +foreign import ccall "rb_ary_new4" rb_ary_new4 :: CLong -> Ptr RValue -> IO RValue +foreign import ccall "rb_ary_push" rb_ary_push :: RValue -> RValue -> IO RValue +foreign import ccall "rb_ary_entry" rb_ary_entry :: RValue -> CLong -> IO RValue +foreign import ccall "rb_hash_foreach" rb_hash_foreach :: RValue -> FunPtr a -> RValue -> IO () +foreign import ccall "rb_big2str" rb_big2str :: RValue -> CInt -> IO RValue +foreign import ccall "rb_cstr_to_inum" rb_cstr_to_inum :: CString -> CInt -> CInt -> IO RValue +foreign import ccall "rb_float_new" rb_float_new :: Double -> IO RValue +foreign import ccall "rb_hash_new" rb_hash_new :: IO RValue +foreign import ccall "rb_hash_aset" rb_hash_aset :: RValue -> RValue -> RValue -> IO RValue +foreign import ccall "rb_define_module" c_rb_define_module :: CString -> IO () + +sym2id :: RValue -> RID +sym2id x = (fromIntegral (ptrToIntPtr x)) `shiftR` 8 + +id2sym :: RID -> RValue +id2sym x = intPtrToPtr (fromIntegral ( (x `shiftL` 8) .|. 0x0e )) + +rbFalse :: RValue +rbFalse = intPtrToPtr 0 +rbTrue :: RValue +rbTrue = intPtrToPtr 2 +rbNil :: RValue +rbNil = intPtrToPtr 4 + +rtype :: RValue -> IO RType +rtype rv | ptrToIntPtr rv .&. 1 == 1 = return RFixNum + | ptrToIntPtr rv == 0 = return RFalse + | ptrToIntPtr rv == 2 = return RTrue + | ptrToIntPtr rv == 4 = return RNil + | ptrToIntPtr rv .&. 0xff == 0x0e = return RSymbol + | otherwise = fmap (RBuiltin . intToBuiltin . (.&. 0x3f)) (peek rv) + + +peekArrayLength :: RValue -> IO CLong +peekArrayLength = (#peek struct RArray, len) + +peekRFloatValue :: RValue -> IO Double +peekRFloatValue = (#peek struct RFloat, value) + +rb_string_value_cstr :: RValue -> IO String +rb_string_value_cstr v = do + pv <- new v + o <- c_rb_string_value_cstr pv >>= peekCString + free pv + return o + +-- | Defines a global function that can be called from the Ruby world. This function must only accept `RValue`s as arguments. +rb_define_global_function :: String -- ^ Name of the function + -> FunPtr a -- ^ Pointer to the function (created with something like `mkRegistered0`) + -> Int -- ^ Number of arguments the function accepts. + -> IO () +rb_define_global_function s f i = withCString s (\cs -> c_rb_define_global_function cs f i) + +rb_define_method :: RValue -> String -> FunPtr a -> Int -> IO () +rb_define_method r s f i = withCString s (\cs -> c_rb_define_method r cs f i) + +rb_define_class :: String -> RValue -> IO RValue +rb_define_class str rv = withCString str (\s -> c_rb_define_class s rv) + +rb_str_new2 :: String -> IO RValue +rb_str_new2 str = withCString str c_rb_str_new2 + +rb_define_module :: String -> IO () +rb_define_module str = withCString str c_rb_define_module + +-- | Loads a ruby script (and executes it). +rb_load_protect :: String -- ^ Path to the script + -> Int -- ^ Just set this to 0, unless you know what you are doing + -> IO Int -- ^ Return code, equal to 0 if everything went right. `showErrorStack` can be used in case of errors. +rb_load_protect rv a = do + bptr <- new 0 + rvs <- rb_str_new2 rv + c_rb_load_protect rvs a bptr + status <- peek bptr + free bptr + return status + +rb_funcall :: RValue -> RID -> [RValue] -> IO RValue +rb_funcall a b [] = c_rb_funcall_0 a b 0 +rb_funcall a b [d] = c_rb_funcall_1 a b 1 d +rb_funcall a b [d,e] = c_rb_funcall_2 a b 2 d e +rb_funcall a b [d,e,f] = c_rb_funcall_3 a b 3 d e f +rb_funcall a b [d,e,f,g] = c_rb_funcall_4 a b 4 d e f g +rb_funcall a b [d,e,f,g,h] = c_rb_funcall_5 a b 5 d e f g h +rb_funcall _ _ _ = error "Can't call functions with that many arguments" + +rbMethodCall :: String -> String -> [RValue] -> IO RValue +rbMethodCall classname methodname args = do + c <- getClass classname + m <- rb_intern methodname + rb_funcall c m args + +getClass :: String -> IO RValue +getClass s = do + i <- rb_intern s + o <- peek rb_cObject + rb_const_get o i + +rb_gv_get :: String -> IO RValue +rb_gv_get s = withCString s c_rb_gv_get + +rb_intern :: String -> IO RID +rb_intern s = withCString s c_rb_intern + +rb_string_value_ptr :: RValue -> IO String +rb_string_value_ptr rv = do + rvp <- new rv + o <- c_rb_string_value_ptr rvp >>= peekCString + free rvp + return o + + diff --git a/Foreign/Ruby/Helpers.hs b/Foreign/Ruby/Helpers.hs new file mode 100644 --- /dev/null +++ b/Foreign/Ruby/Helpers.hs @@ -0,0 +1,267 @@ +module Foreign.Ruby.Helpers where + +import Foreign.Ruby.Bindings + +import Data.Maybe (fromMaybe) +import Foreign +import Data.Aeson +import Control.Monad +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Char8 as BS +import Data.Attoparsec.Number +import qualified Data.Vector as V +import Data.IORef +import qualified Data.HashMap.Strict as HM + +-- | 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 (Maybe 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 r = do + t <- rtype r + case t of + RFixNum -> return (Just (fromIntegral (ptrToIntPtr r `shiftR` 1))) + _ -> return Nothing +toRubyIntegral :: Integral n => n -> IO RValue +toRubyIntegral n = return (intPtrToPtr ( (fromIntegral n `shiftL` 1) .|. 1)) + +fromRubyArray :: FromRuby a => RValue -> IO (Maybe [a]) +fromRubyArray v = do + nbelems <- peekArrayLength 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 + _ -> putStrLn ("not an array! " ++ show t) >> return Nothing + +instance ToRuby a => ToRuby [a] where + 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 Just (BS.packCString cstr) + RSymbol -> fmap Just (rb_id2name (sym2id v) >>= BS.packCString) + _ -> return Nothing +instance ToRuby BS.ByteString where + toRuby s = BS.useAsCString s c_rb_str_new2 + +instance FromRuby T.Text where + fromRuby = fmap (fmap T.decodeUtf8) . fromRuby +instance ToRuby T.Text where + toRuby = toRuby . T.encodeUtf8 + +instance ToRuby Double where + toRuby = rb_float_new +instance FromRuby Double where + fromRuby = fmap Just . peekRFloatValue + +instance FromRuby Integer where + fromRuby = fromRubyIntegral +instance ToRuby Integer where + toRuby = toRubyIntegral +instance FromRuby Int where + fromRuby = fromRubyIntegral +instance ToRuby Int where + toRuby = toRubyIntegral + +-- | 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 . I)) (fromRuby v) + RNil -> return (Just Null) + RFalse -> return (Just (Bool False)) + RTrue -> return (Just (Bool True)) + RSymbol -> fmap (fmap (String . T.decodeUtf8)) (fromRuby v) + RBuiltin RNIL -> return (Just 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 RFLOAT -> fmap (fmap (Number . D)) (fromRuby v) + RBuiltin RBIGNUM -> do + bs <- rb_big2str v 10 >>= fromRuby + case fmap BS.readInteger bs of + Just (Just (x,"")) -> return (Just (Number (I x))) + _ -> return Nothing + RBuiltin RNONE -> return (Just 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 + (Just jk, Just 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 + +instance ToRuby Value where + toRuby (Number (I x)) = do + let maxRubyInt = fromIntegral (maxBound :: IntPtr) `shiftR` 1 :: Integer + if x >= maxRubyInt + then BS.useAsCString (BS.pack (show x)) (\cs -> rb_cstr_to_inum cs 10 0) + else toRubyIntegral x + toRuby (Number (D 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 + +-- | 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 :: a -> IO RValue +embedHaskellValue v = do + 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 +-- exploitable security bug if you use something modified from Ruby land. +-- You should always free the `RValue` you generated from +-- `embedHaskellValue`. +freeHaskellValue :: RValue -> IO () +freeHaskellValue v = do + intptr <- fromRuby v :: IO (Maybe Integer) + case intptr of + Just i -> freeStablePtr (castPtrToStablePtr (intPtrToPtr (fromIntegral i))) + Nothing -> error "Could not decode embedded value during free!" + +-- | This is unsafe as hell, so you'd better be certain this RValue has not +-- been tempered with : GC frozen, bugfree Ruby scripts. +-- +-- If it has been tempered by an attacker, you are probably looking at +-- a good vector for arbitrary code execution. +extractHaskellValue :: RValue -> IO a +extractHaskellValue v = do + intptr <- fromRuby v :: IO (Maybe Integer) + case intptr of + Just i -> deRefStablePtr (castPtrToStablePtr (intPtrToPtr (fromIntegral i))) + Nothing -> error "Could not decode embedded value!" + +runscript :: String -> IO (Either String ()) +runscript filename = do + ruby_init + ruby_init_loadpath + 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 + +-- | Runs a Ruby method, capturing errors. +safeMethodCall :: String -- ^ Class name. + -> 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 classname methodname args = + if length args > 16 + then return (Left ("too many arguments", rbNil)) + else do + dispatch <- new (ShimDispatch classname methodname args) + pstatus <- new 0 + o <- c_rb_protect safeCallback (castPtr dispatch) pstatus + status <- peek pstatus + free dispatch + free pstatus + if status == 0 + then return (Right o) + else do + err <- showErrorStack + return (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 (fromMaybe "undeserializable error") (rb_funcall runtimeerror message [] >>= fromRuby) + rbt <- rb_gv_get "$@" + bt <- if rbt == rbNil + then return [] + else fmap (fromMaybe []) (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 nw = do + let method = if nw + then "enable" + else "disable" + safeMethodCall "GC" method [] + +-- | Runs the Ruby garbage collector. +startGC :: IO () +startGC = Control.Monad.void (safeMethodCall "GC" "start" []) + +-- | Runs a computation with the Ruby GC disabled. Once the computation is over, GC +-- 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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Simon Marechal + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Simon Marechal nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits1.8/shim.c b/cbits1.8/shim.c new file mode 100644 --- /dev/null +++ b/cbits1.8/shim.c @@ -0,0 +1,12 @@ +#include "shim.h" + +VALUE safeCall(VALUE args) +{ + struct s_dispatch * d = (struct s_dispatch *) args; + VALUE myclass = rb_const_get(rb_cObject, rb_intern(d->classname)); + VALUE o = rb_funcall2(myclass, rb_intern(d->methodname), d->nbargs, d->args); + free(d->methodname); + free(d->classname); + return o; +} + diff --git a/cbits1.8/shim.h b/cbits1.8/shim.h new file mode 100644 --- /dev/null +++ b/cbits1.8/shim.h @@ -0,0 +1,11 @@ +#include "/usr/lib/ruby/1.8/x86_64-linux/ruby.h" + +struct s_dispatch { + char * classname; + char * methodname; + int nbargs; + VALUE args[16]; +}; + +VALUE safeCall(VALUE args); + diff --git a/cbits1.9/shim.c b/cbits1.9/shim.c new file mode 100644 --- /dev/null +++ b/cbits1.9/shim.c @@ -0,0 +1,12 @@ +#include "shim.h" + +VALUE safeCall(VALUE args) +{ + struct s_dispatch * d = (struct s_dispatch *) args; + VALUE myclass = rb_const_get(rb_cObject, rb_intern(d->classname)); + VALUE o = rb_funcall2(myclass, rb_intern(d->methodname), d->nbargs, d->args); + free(d->methodname); + free(d->classname); + return o; +} + diff --git a/cbits1.9/shim.h b/cbits1.9/shim.h new file mode 100644 --- /dev/null +++ b/cbits1.9/shim.h @@ -0,0 +1,11 @@ +#include "/usr/lib/ruby/1.8/x86_64-linux/ruby.h" + +struct s_dispatch { + char * classname; + char * methodname; + int nbargs; + VALUE args[16]; +}; + +VALUE safeCall(VALUE args); + diff --git a/hruby.cabal b/hruby.cabal new file mode 100644 --- /dev/null +++ b/hruby.cabal @@ -0,0 +1,50 @@ +-- Initial hruby.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: hruby +version: 0.0.3 +synopsis: Embed Ruby in your Haskell program. +description: Warning: this is completely experimental. Everything you need should be in "Foreign.Ruby". +license: BSD3 +license-file: LICENSE +author: Simon Marechal +maintainer: bartavelle@gmail.com +-- copyright: +category: Language +build-type: Simple +cabal-version: >=1.8 + +Flag Ruby19 + Description: Enable when you use Ruby 1.9 (not implemented yet). It will default to Ruby 1.8. + Default: False + +source-repository head + type: git + location: git://github.com/bartavelle/hruby.git + + +library + exposed-modules: Foreign.Ruby, Foreign.Ruby.Bindings, Foreign.Ruby.Helpers + ghc-options: -Wall + extensions: BangPatterns, OverloadedStrings + build-depends: base ==4.6.*, aeson, bytestring, attoparsec, vector, text, unordered-containers + if flag(ruby19) + extra-libraries: ruby1.9 + c-sources: cbits1.9/shim.c + install-includes: cbits1.9/shim.h + include-dirs: cbits1.9 + else + extra-libraries: ruby1.8 + c-sources: cbits1.8/shim.c + install-includes: cbits1.8/shim.h + include-dirs: cbits1.8 + +Test-Suite test-roundtrip + hs-source-dirs: test + type: exitcode-stdio-1.0 + ghc-options: -Wall + extensions: OverloadedStrings + build-depends: base,hruby,aeson,QuickCheck,text,attoparsec,vector + main-is: roundtrip.hs + + diff --git a/test/roundtrip.hs b/test/roundtrip.hs new file mode 100644 --- /dev/null +++ b/test/roundtrip.hs @@ -0,0 +1,65 @@ +module Main where + +import Foreign.Ruby.Helpers +import Foreign.Ruby.Bindings +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)] + +str :: Gen T.Text +str = fmap T.pack (listOf (elements (['A'..'Z'] ++ ['a' .. 'z'] ++ ['0'..'9']))) + +s :: Gen Value +s = fmap String str + +a :: Gen Value +a = fmap (Array . V.fromList) (resize 100 (listOf subvalue)) + +b :: Gen Value +b = fmap Bool arbitrary + +n :: Gen Value +n = fmap Number arbitrary + +h :: Gen Value +h = fmap object $ do + k <- listOf str + v <- listOf subvalue + return (zip k v) + +instance Arbitrary Value where + arbitrary = frequency [(1,s),(5,a),(1,b),(1,n),(5,h)] + +roundTrip :: Property +roundTrip = monadicIO $ do + v <- pick (arbitrary :: Gen Value) + void (run (setGC False)) + rub <- run (toRuby v) + nxt <- run (safeMethodCall "TestClass" "testfunc" [rub]) + case nxt of + Right x -> do + out <- run (fromRuby x) + void (run (setGC True)) + run startGC + assert (Just v == out) + Left (rr,_) -> run (print rr) >> assert False + +main :: IO () +main = do + ruby_init + ruby_init_loadpath + rb_define_module "test" + st <- rb_load_protect "test/test.rb" 0 + unless (st == 0) (showErrorStack >>= error) + quickCheckWith (stdArgs { maxSuccess = 1000 } ) roundTrip + ruby_finalize