diff --git a/Foreign/Ruby.hs b/Foreign/Ruby.hs --- a/Foreign/Ruby.hs +++ b/Foreign/Ruby.hs @@ -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 diff --git a/Foreign/Ruby/Helpers.hs b/Foreign/Ruby/Helpers.hs --- a/Foreign/Ruby/Helpers.hs +++ b/Foreign/Ruby/Helpers.hs @@ -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 diff --git a/Foreign/Ruby/Safe.hs b/Foreign/Ruby/Safe.hs --- a/Foreign/Ruby/Safe.hs +++ b/Foreign/Ruby/Safe.hs @@ -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 () diff --git a/hruby.cabal b/hruby.cabal --- a/hruby.cabal +++ b/hruby.cabal @@ -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 diff --git a/test/roundtrip.hs b/test/roundtrip.hs --- a/test/roundtrip.hs +++ b/test/roundtrip.hs @@ -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