Merge pull request #10 from BeFunctional/edsko/improve-external

Improve external buffer API

cbits/wrap-rust-haskell-ffi.c

@@ -0,0 +1,10 @@
+// Forward-declare the Rust-exported function
+void haskell_ffi_external_free(void* vec);
+
+// Wrapper around the Rust function that takes an additional (unused) argument,
+// which makes it match the Haskell `FinalizerEnvPtr` type. The wrapper also
+// avoids linker errors when the Rust library is not available (of course,
+// the Rust library must be linked into the final application).
+void haskell_ffi_external_free_env(void* vec, void* ptr) {
+    haskell_ffi_external_free(vec);
+}

foreign-rust.cabal

@@ -48,6 +48,7 @@ common lang
       TypeFamilies
       TypeOperators
       UndecidableInstances
+      ViewPatterns
 
 library
   import:
@@ -56,6 +57,7 @@ library
       Foreign.Rust.External.JSON
       Foreign.Rust.External.Bincode
       Foreign.Rust.Failure
+      Foreign.Rust.Marshall.External
       Foreign.Rust.Marshall.Fixed
       Foreign.Rust.Marshall.Variable
       Foreign.Rust.SafeConv
@@ -91,6 +93,8 @@ library
     , th-abstraction
     , vector
     , wide-word
+  c-sources:
+    cbits/wrap-rust-haskell-ffi.c
 
 test-suite test-foreign-rust
   import:

src/Data/Structured.hs

@@ -123,6 +123,9 @@ data Value where
   -- These are shown assuming @NumericUnderscores@.
   Integral :: forall a. (Prelude.Show a, Integral a) => a -> Value
 
+  -- | Floating point numbers
+  Floating :: Double -> Value
+
   -- | Quasi-quote
   --
   -- We separate out the quasi-quoter from the quoted string proper.
@@ -259,6 +262,9 @@ instance Show Int128  where toValue = Integral
 
 instance Show Integer where toValue = Integral
 
+instance Show Float  where toValue = Floating . realToFrac
+instance Show Double where toValue = Floating
+
 instance {-# OVERLAPPABLE #-} Show a => Show [a] where
   toValue = List . map toValue
 
@@ -451,6 +457,7 @@ render = \contextNeedsBrackets ->
         bracketIf (contextneedsBrackets && requiresBrackets val) $
           case val of
             Integral x     -> simple $ addNumericUnderscores (Prelude.show x)
+            Floating x     -> simple $ Prelude.show x
             String x       -> simple $ Prelude.show x
             Constr c ts xs -> renderComposite (compositeConstr c ts) $
                                 map (go True) xs

src/Foreign/Rust/External/JSON.hs

@@ -16,12 +16,15 @@ module Foreign.Rust.External.JSON (
   ) where
 
 import Codec.Borsh
+import Foreign.Rust.Failure
+import GHC.Stack
 
 import qualified Data.Aeson                 as Aeson
 import qualified Data.Aeson.Encoding        as Aeson (unsafeToEncoding)
 import qualified Data.Aeson.Types           as Aeson (parseFail)
 import qualified Data.Binary.Builder        as Binary
 import qualified Data.ByteString.Lazy       as Lazy (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8
 
 {-------------------------------------------------------------------------------
   Serialisation
@@ -32,13 +35,16 @@ newtype JSON = JSON Lazy.ByteString
   deriving stock (Eq)
   deriving newtype (BorshSize, ToBorsh, FromBorsh)
 
--- | Types with an external JSON renderer (typically, in Rust)
+instance Show JSON where
+  show (JSON bs) = Lazy.Char8.unpack bs
+
+-- | Types with a Rust-side JSON renderer
 class ToJSON a where
   toJSON :: a -> JSON
 
--- | Types with an external JSON parser (typically, in Rust)
+-- | Types with a Rust-side JSON parser
 class FromJSON a where
-  fromJSON :: JSON -> Either String a
+  fromJSON :: HasCallStack => JSON -> Either Failure a
 
 {-------------------------------------------------------------------------------
   Deriving-via: derive Aeson instances using external (de)serialiser
@@ -67,6 +73,6 @@ instance ToJSON a => Aeson.ToJSON (UseExternalJSON a) where
 instance FromJSON a => Aeson.FromJSON (UseExternalJSON a) where
   parseJSON val =
       case fromJSON (JSON (Aeson.encode val)) of
-        Left failure -> Aeson.parseFail failure
+        Left failure -> Aeson.parseFail (show failure)
         Right tx     -> return $ UseExternalJSON tx
 

src/Foreign/Rust/Marshall/External.hs

@@ -0,0 +1,72 @@
+-- | Marshall from a Rust-side allocated buffer
+--
+-- Intended for unqualified import.
+module Foreign.Rust.Marshall.External (
+    fromExternalBorsh
+  ) where
+
+import Codec.Borsh
+import Data.Typeable
+import Data.Word
+import Foreign.C
+import Foreign.Ptr
+
+import qualified Data.ByteString.Internal as Strict
+
+import Foreign.Rust.Marshall.Util
+import Foreign.ForeignPtr
+
+data ExternalBuffer
+
+{-------------------------------------------------------------------------------
+  Foreign imports
+
+  Although 'externalPtr' and 'externalLen' are morally pure, we make
+  them live in IO to make reasoning about order of operations easier in
+  'fromExternalBorsh'.
+
+  These C functions are defined in the companion Rust @haskell-ffi@ library.
+-------------------------------------------------------------------------------}
+
+foreign import ccall unsafe "haskell_ffi_external_ptr"
+     externalPtr
+  :: Ptr ExternalBuffer -> IO (Ptr Word8)
+
+foreign import ccall unsafe "haskell_ffi_external_len"
+     externalLen
+  :: Ptr ExternalBuffer -> IO CSize
+
+foreign import ccall unsafe "&haskell_ffi_external_free_env"
+     externalFree
+  :: FinalizerEnvPtr ExternalBuffer Word8
+
+{-------------------------------------------------------------------------------
+  Internal auxiliary
+-------------------------------------------------------------------------------}
+
+-- | Cast pointer
+--
+-- For ease of integration with c2hs, 'fromExternalBorsh' takes a @Ptr ()@ as
+-- input instead of the more accurate @Ptr ExternalBuffer@.
+castToExternal :: Ptr () -> Ptr ExternalBuffer
+castToExternal = castPtr
+
+{-------------------------------------------------------------------------------
+  Public API
+-------------------------------------------------------------------------------}
+
+-- | Output marshaller for values stored in Rust-allocated buffer
+--
+-- Should be used together with the Rust function @marshall_to_haskell_external@
+-- (from @haskell-ffi@).
+fromExternalBorsh :: (FromBorsh a, Typeable a) => Ptr () -> IO a
+fromExternalBorsh (castToExternal -> vec) = do
+    ptr  <- externalPtr vec
+    len  <- fromIntegral <$> externalLen vec
+    fptr <- newForeignPtrEnv externalFree vec ptr
+
+    let bs :: Strict.ByteString
+        bs = Strict.fromForeignPtr fptr 0 len
+
+    return $ deserialiseStrictOrPanic bs
+

src/Foreign/Rust/Marshall/Variable.hs

@@ -11,26 +11,20 @@ module Foreign.Rust.Marshall.Variable (
   , Buffer -- opaque
   , getVarBuffer
   , withBorshVarBuffer
-  , withBorshFailure
   , withBorshBufferOfInitSize
     -- ** Pure variants
   , withPureBorshVarBuffer
-  , withPureBorshFailure
   ) where
 
 import Codec.Borsh
-import Data.Bifunctor
-import Data.Text (Text)
 import Data.Typeable
 import Foreign
 import Foreign.C.Types
-import GHC.Stack
 import System.IO.Unsafe (unsafePerformIO)
 
 import qualified Data.ByteString as Strict
 
 import Foreign.Rust.Marshall.Util
-import Foreign.Rust.Failure
 
 {-------------------------------------------------------------------------------
   Haskell to Rust
@@ -72,16 +66,6 @@ withBorshVarBuffer :: forall a.
   => (Buffer a -> IO ()) -> IO a
 withBorshVarBuffer = withBorshBufferOfInitSize 1024
 
--- | Wrapper around 'withBorshVarBuffer' with explicit support for failures
-withBorshFailure :: forall a.
-     ( FromBorsh a
-     , StaticBorshSize a ~ 'HasVariableSize
-     , Typeable a
-     , HasCallStack
-     )
-  => (Buffer (Either Text a) -> IO ()) -> IO (Either Failure a)
-withBorshFailure = fmap (first mkFailure) . withBorshVarBuffer
-
 {-------------------------------------------------------------------------------
   Pure variants
 -------------------------------------------------------------------------------}
@@ -94,15 +78,6 @@ withPureBorshVarBuffer :: forall a.
   => (Buffer a -> IO ()) -> a
 withPureBorshVarBuffer = unsafePerformIO . withBorshVarBuffer
 
-withPureBorshFailure :: forall a.
-     ( FromBorsh a
-     , StaticBorshSize a ~ 'HasVariableSize
-     , Typeable a
-     , HasCallStack
-     )
-  => (Buffer (Either Text a) -> IO ()) -> Either Failure a
-withPureBorshFailure = unsafePerformIO . withBorshFailure
-
 {-------------------------------------------------------------------------------
   Generalization
 -------------------------------------------------------------------------------}