├── stack.yaml ├── .gitignore ├── Setup.hs ├── src └── FFI │ └── Anything │ ├── TypeUncurry.hs │ ├── TH.hs │ └── TypeUncurry │ ├── DataKinds.hs │ └── Msgpack.hs ├── .travis.yml ├── CHANGELOG.md ├── call-haskell-from-anything.cabal ├── test.rb ├── test.py ├── test └── Test1.hs └── README.md /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.11 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virthualenv 8 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMainWithHooks autoconfUserHooks 3 | -------------------------------------------------------------------------------- /src/FFI/Anything/TypeUncurry.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, TypeOperators #-} 2 | {-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleContexts #-} 3 | 4 | module FFI.Anything.TypeUncurry ( 5 | -- | You see this because your compiler supports DataKinds. 6 | module FFI.Anything.TypeUncurry.DataKinds 7 | ) where 8 | 9 | 10 | import FFI.Anything.TypeUncurry.DataKinds 11 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | ghc: 4 | - 8.0 5 | 6 | before_install: 7 | - sudo apt-get install msgpack-python 8 | 9 | install: 10 | # TravisCI currently uses Ubuntu 12.04 which doesn't have a ruby-msgpack package. 11 | - gem install ffi msgpack 12 | - cabal install --only-dependencies --enable-tests --enable-shared 13 | 14 | script: 15 | - cabal configure --enable-tests --enable-shared 16 | - cabal build 17 | 18 | # Cabal 1.22 puts the library .so files into dist/build. 19 | # In older cabals, it "magically" worked, see: 20 | # https://github.com/haskell/cabal/issues/2330#issuecomment-69201669 21 | - LD_LIBRARY_PATH=dist/build python test.py 22 | - LD_LIBRARY_PATH=dist/build ruby test.rb 23 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # call-haskell-from-anything changelog 2 | 3 | ## 1.1.0.0 -- 2017-08-03 4 | 5 | * Backwards incompatible change! Wrappers have to be updated (see examples) 6 | * Fixed significant memory truncation bug #20 7 | * Fixed potential use-after-free stack return bug (see fix for #20) 8 | 9 | ## 1.0.1.0 -- 2015-02-01 10 | 11 | * Remove no-longer-needed instance for IO, fixes "overlapping instances" error in clients 12 | 13 | ## 1.0.0.0 -- 2015-01-31 14 | 15 | * Use closed type families to remove need for `Identity` monad at the end of functions. 16 | **You can now export any pure function of type `a -> b -> ... -> r`**. 17 | This is what I've been waiting for for years. Fixes #9. 18 | * Remove all helpers, wrappers, and support for exporting functions of type `a -> b -> ... -> Identity r`. If you need those for some reasons, just `runIdentity` on them before passing them to `export`. 19 | 20 | ## 0.2.0.0 -- 2015-01-31 21 | 22 | * Update to `msgpack-1.0.0`. Fixes #5. 23 | * Fix compilation under GHC 7.10 24 | * Require GHC >= 7.10 25 | * Remove support for compilers that don't support `DataKinds` 26 | * `stack` support. 27 | * With `msgpack-1.0.0` we unfortunately lose the ability to give clear messages; if there is a number-of-arguments mismatch, `unpack` now returns `Nothing`. 28 | -------------------------------------------------------------------------------- /call-haskell-from-anything.cabal: -------------------------------------------------------------------------------- 1 | name: call-haskell-from-anything 2 | version: 1.1.0.0 3 | license: MIT 4 | author: Niklas Hambüchen (mail@nh2.me) 5 | maintainer: Niklas Hambüchen (mail@nh2.me) 6 | category: Network 7 | build-type: Simple 8 | synopsis: Call Haskell functions from other languages via serialization and dynamic libraries 9 | description: FFI via serialisation. See https://github.com/nh2/call-haskell-from-anything for details. 10 | stability: experimental 11 | tested-with: GHC==8.0.2 12 | cabal-version: >= 1.10 13 | homepage: https://github.com/nh2/call-haskell-from-anything 14 | bug-reports: https://github.com/nh2/call-haskell-from-anything/issues 15 | 16 | 17 | source-repository head 18 | type: git 19 | location: git://github.com/nh2/call-haskell-from-anything.git 20 | 21 | 22 | library 23 | default-language: Haskell2010 24 | hs-source-dirs: 25 | src 26 | exposed-modules: 27 | FFI.Anything.TH 28 | FFI.Anything.TypeUncurry 29 | FFI.Anything.TypeUncurry.Msgpack 30 | FFI.Anything.TypeUncurry.DataKinds 31 | build-depends: 32 | base >= 4.8 && < 5 33 | , bytestring >= 0.10.0.0 34 | , data-msgpack >= 0.0.10 35 | , storable-endian >= 0.2.6 36 | , template-haskell >= 2.11.0 37 | , mtl >= 2.1.2 38 | ghc-options: 39 | -Wall -fwarn-unused-imports 40 | 41 | 42 | foreign-library call-haskell-from-anything 43 | type: native-shared 44 | default-language: Haskell2010 45 | hs-source-dirs: 46 | test 47 | other-modules: 48 | Test1 49 | build-depends: 50 | call-haskell-from-anything 51 | 52 | -- Packages that already have version bounds in the library: 53 | , base 54 | , bytestring 55 | , data-msgpack 56 | , mtl 57 | -------------------------------------------------------------------------------- /test.rb: -------------------------------------------------------------------------------- 1 | #!/bin/env ruby 2 | 3 | require 'ffi' 4 | require 'msgpack' 5 | 6 | # For finding where the built .so file is, independent on whether it was built with stack or cabal 7 | require 'find' 8 | def find_file_ending_with(ending_with_str, path='.') 9 | Find.find('.') do |path| 10 | if path.end_with? ending_with_str 11 | return path 12 | end 13 | end 14 | abort("Could not find " + ending_with_str + " in " + path) 15 | end 16 | 17 | 18 | module Test1 19 | extend FFI::Library 20 | ffi_lib FFI::Library::LIBC 21 | 22 | attach_function :free, [:pointer], :void 23 | 24 | ffi_lib find_file_ending_with('call-haskell-from-anything.so') 25 | 26 | attach_function :f1_t_export, [:pointer], :pointer 27 | attach_function :fib_export, [:pointer], :pointer 28 | 29 | attach_function :hs_init, [:pointer, :pointer], :void 30 | attach_function :hs_exit, [], :void 31 | 32 | def self.make_msgpack_fun(fun_sym) 33 | attach_function fun_sym, [:pointer], :pointer 34 | 35 | proc { |*args| 36 | packed = MessagePack.pack(args) 37 | length_64bits = [packed.length].pack("q>") # big-endian 38 | resptr = method(fun_sym).call(length_64bits + packed) 39 | msg_length = resptr.read_string_length(8).unpack("q>")[0] 40 | resmsg = (resptr + 8).read_string_length(msg_length) 41 | Test1.free(resptr) 42 | MessagePack.unpack(resmsg) 43 | } 44 | end 45 | end 46 | 47 | Test1.hs_init(nil, nil) 48 | 49 | msg = [1,2.23].to_msgpack 50 | length_64bits = [msg.length].pack("q>") # big-endian 51 | resptr = Test1.f1_t_export(length_64bits + msg) 52 | msg_length = resptr.read_string_length(8).unpack("q>")[0] 53 | resmsg = (resptr + 8).read_string_length(msg_length) 54 | Test1.free(resptr) 55 | 56 | puts "Haskell said: #{MessagePack.unpack(resmsg)}" 57 | 58 | fib = Test1.make_msgpack_fun(:fib_export) 59 | 60 | puts "Haskell fib: #{fib.call(13)}" 61 | 62 | sum = 0 63 | (0..99999).each do |i| 64 | sum += fib.call(15) 65 | end 66 | 67 | puts sum 68 | 69 | Test1.hs_exit 70 | -------------------------------------------------------------------------------- /test.py: -------------------------------------------------------------------------------- 1 | from ctypes import * 2 | import glob 3 | import struct 4 | import msgpack 5 | import itertools 6 | 7 | # For finding where the built .so file is, independent on whether it was built with stack or cabal 8 | def find_file_ending_with(ending_with_str, path='.'): 9 | # `glob` `**` does not match dotfiles (such as `.stack_work`), so we have to do that explicitly. 10 | glob_result_generator = itertools.chain( 11 | glob.glob(path + "/**/*" + ending_with_str, recursive=True), 12 | glob.glob(path + "/.*/**/*" + ending_with_str, recursive=True), 13 | ) 14 | for path_str in glob_result_generator: 15 | return path_str 16 | else: 17 | raise Exception("Could not find " + ending_with_str + " in " + path) 18 | so_file_path = find_file_ending_with('call-haskell-from-anything.so') 19 | 20 | 21 | free = cdll.LoadLibrary("libc.so.6").free 22 | lib = cdll.LoadLibrary(so_file_path) 23 | 24 | lib.hs_init(0, 0) 25 | 26 | # Set function return type to string 27 | fun = lib.f1_t_export 28 | fun.restype = POINTER(c_char) 29 | 30 | # Call function 31 | msg = msgpack.packb([1, 2.23]) 32 | length_64bits = struct.pack(">q", len(msg)) # big-endian 33 | ptr = fun(length_64bits + msg) 34 | data_length = struct.unpack(">q", ptr[:8])[0] 35 | res = msgpack.unpackb(ptr[8:8+data_length]) 36 | free(ptr) 37 | 38 | print("Haskell said:", res) 39 | 40 | 41 | # Some shortcuts 42 | def make_msgpack_fun(fun): 43 | fun.restype = POINTER(c_char) 44 | 45 | def f(*args): 46 | packed = msgpack.packb(args) 47 | length_64bits = struct.pack(">q", len(packed)) # big-endian 48 | ptr = fun(length_64bits + packed) 49 | data_length = struct.unpack(">q", ptr[:8])[0] 50 | res = msgpack.unpackb(ptr[8:8+data_length]) 51 | free(ptr) 52 | return res 53 | 54 | return f 55 | 56 | 57 | # Now this is the only thing required 58 | fib = make_msgpack_fun(lib.fib_export) 59 | 60 | print("Haskell fib:", fib(13)) 61 | 62 | 63 | # def fib(n): 64 | # if n == 0 or n == 1: return 1 65 | # return fib(n-1) + fib(n-2) 66 | 67 | sum = 0 68 | for x in range(100000): 69 | sum += fib(15) 70 | print(sum) 71 | 72 | lib.hs_exit() 73 | -------------------------------------------------------------------------------- /test/Test1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Test1 where 5 | 6 | import Data.ByteString (ByteString) 7 | import qualified Data.ByteString as BS 8 | import qualified Data.ByteString.Lazy as BSL 9 | import qualified Data.MessagePack as MSG 10 | 11 | import Foreign.C 12 | 13 | -- import FFI.Anything.TH (deriveCallable) 14 | import FFI.Anything.TypeUncurry.Msgpack 15 | 16 | 17 | 18 | -- | Example function to be called from Python. 19 | f1 :: Int -> Double -> String 20 | f1 i f = "Called with params: " ++ show i ++ ", " ++ show f 21 | 22 | 23 | -- To be translated to: 24 | f1' :: ByteString -> ByteString 25 | f1' bs = BSL.toStrict $ MSG.pack (uncurry f1 $ msg) 26 | where 27 | msg = case MSG.unpack (BSL.fromStrict bs) of 28 | Nothing -> error "could not unpack" 29 | Just r -> r 30 | 31 | 32 | -- TODO check who deallocs - it seems to work magically! 33 | foreign export ccall f1_hs :: CString -> IO CString 34 | f1_hs :: CString -> IO CString 35 | f1_hs cs = do 36 | cs_bs <- BS.packCString cs 37 | let res_bs = f1' cs_bs 38 | res_cs <- BS.useAsCString res_bs return 39 | return res_cs 40 | 41 | 42 | f1_t :: ByteString -> ByteString 43 | f1_t = uncurryMsgpack f1 44 | 45 | foreign export ccall f1_t_export :: CString -> IO CString 46 | f1_t_export :: CString -> IO CString 47 | f1_t_export = byteStringToCStringFun f1_t 48 | 49 | 50 | 51 | fib :: Int -> Int 52 | fib 0 = 1 53 | fib 1 = 1 54 | fib n = fib (n-1) + fib (n-2) 55 | 56 | 57 | fib_print :: Int -> IO Int 58 | fib_print x = putStrLn ("fib_print: " ++ show f) >> return f 59 | where 60 | f = fib x 61 | 62 | 63 | foreign export ccall fib_export :: CString -> IO CString 64 | fib_export :: CString -> IO CString 65 | fib_export = export fib 66 | 67 | 68 | -- TODO the sole *presence* of this function seems to make the calls in Python slower 69 | -- foreign export ccall fib_print_export :: CString -> IO CString 70 | -- fib_print_export :: CString -> IO CString 71 | -- fib_print_export = exportIO fib_print 72 | 73 | -- -- TODO the sole *presence* of this function seems to make the calls in Python slower 74 | -- foreign export ccall fib_print_export2 :: CString -> IO CString 75 | -- fib_print_export2 :: CString -> IO CString 76 | -- fib_print_export2 = exportIO fib_print 77 | 78 | 79 | -- $(deriveCallable 'f1 "f1_hs") 80 | 81 | 82 | foreign export ccall fib_export_ffi :: CInt -> CInt 83 | fib_export_ffi :: CInt -> CInt 84 | fib_export_ffi = fromIntegral . fib . fromIntegral 85 | -------------------------------------------------------------------------------- /src/FFI/Anything/TH.hs: -------------------------------------------------------------------------------- 1 | module FFI.Anything.TH where 2 | 3 | import Language.Haskell.TH 4 | 5 | import Debug.Trace 6 | 7 | 8 | 9 | 10 | parameters :: Type -> [Type] -- Result list are "ground" types 11 | parameters t = case t of 12 | AppT t1 t2 -> parameters t1 ++ parameters t2 13 | ArrowT -> [] 14 | ConT name -> [ConT name] 15 | -- TODO handle ListT, TupleT and so on 16 | _ -> error $ "parameters: unhandled Type " ++ show t 17 | 18 | 19 | -- TODO better use custom data type, tuples are quite finite 20 | argTypesToTuple :: [Type] -> Type 21 | argTypesToTuple types = foldl f (TupleT n) types 22 | where 23 | f a next = AppT a next 24 | n = length types 25 | 26 | 27 | debug :: (Show a, Monad m) => a -> m () 28 | debug x = trace ("\n" ++ show x ++ "\n") $ return () 29 | 30 | 31 | deriveCallable :: Name -> String -> Q [Dec] 32 | deriveCallable funName exportedName = do 33 | info <- reify funName 34 | case info of 35 | VarI name typ _mDec -> do 36 | let _nameString = nameBase name 37 | signatureList = parameters typ 38 | paramTypes = init signatureList 39 | returnType = last signatureList 40 | 41 | typ' = [ SigD 42 | (mkName exportedName) 43 | (AppT 44 | (AppT 45 | ArrowT 46 | (argTypesToTuple paramTypes) 47 | ) 48 | returnType 49 | ) 50 | ] 51 | 52 | debug typ' 53 | debug $ pprint typ' 54 | return [] 55 | 56 | _ -> error "deriveCallable: can only derive functions" 57 | 58 | 59 | -- Example: 60 | -- 61 | -- VarI 62 | -- -- Name 63 | -- FFI.Anything.f 64 | -- -- Type 65 | -- (AppT (AppT ArrowT (ConT GHC.Types.Int)) (AppT (AppT ArrowT (ConT GHC.Types.Double)) (ConT GHC.Base.String))) 66 | -- -- Maybe Dec 67 | -- Nothing 68 | -- -- Fixity 69 | -- (Fixity 9 InfixL) 70 | -- 71 | -- Where the type "f :: Int -> Double -> String" is: 72 | -- 73 | -- AppT 74 | -- (AppT ArrowT (ConT GHC.Types.Int)) 75 | -- (AppT 76 | -- (AppT ArrowT (ConT GHC.Types.Double)) 77 | -- (ConT GHC.Base.String) 78 | -- ) 79 | -- 80 | -- 81 | -- The target is: runQ f_hs :: (Int, Double) -> String 82 | -- so e.g.: 83 | -- 84 | -- runQ [d| f_hs :: (Int, Double) -> String; f_hs = f_hs |] 85 | -- 86 | -- which is: 87 | -- 88 | -- [ SigD -- This is the type 89 | -- f_hs 90 | -- (AppT 91 | -- (AppT 92 | -- ArrowT 93 | -- (AppT 94 | -- (AppT (TupleT 2) (ConT GHC.Types.Int)) 95 | -- (ConT GHC.Types.Double) 96 | -- ) 97 | -- ) 98 | -- (ConT GHC.Base.String) 99 | -- ) 100 | -- , ValD -- This is the unimportant `f_hs = f_hs` part needed for the quasiquoter to complile 101 | -- (VarP f_hs_2) 102 | -- (NormalB (VarE f_hs_2)) 103 | -- [] 104 | -- ] 105 | -------------------------------------------------------------------------------- /src/FFI/Anything/TypeUncurry/DataKinds.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, GADTs, TypeOperators, MultiParamTypeClasses, FlexibleInstances, TypeFamilies, PolyKinds, ScopedTypeVariables #-} 2 | 3 | -- | Converts function arguments to tuple-like types. 4 | -- 5 | -- For example, take @f :: a -> b -> c -> r@. 6 | -- This module can convert it to @f' :: (a, b, c) -> r@, at compile time. 7 | -- 8 | -- This is especially useful for (de)serialization. 9 | -- Suppose you have a function that takes multiple arguments 10 | -- and you want to obtain all of its arguments from some serialized data. 11 | -- The serialization library will make it very easy to unpack types 12 | -- like tuples/lists, but de-serializing *fuction arguments* is not that simple. 13 | -- 14 | -- Using this module, you can write an instance how to unpack the 'TypeList' type, 15 | -- and then use 'translate' to make any function take such a single 'TypeList' 16 | -- instead of multiple function arguments. 17 | module FFI.Anything.TypeUncurry.DataKinds where 18 | 19 | import Data.Proxy 20 | 21 | 22 | -- * Type-level lists (containing types) 23 | 24 | -- NOTE: GHC 7.4 cannot deal with DataKinds 25 | -- (see http://hackage.haskell.org/trac/ghc/ticket/5881) 26 | -- 27 | -- This is why we have two separate implementations: 28 | -- - one with DataKinds for GHC >= 7.6 29 | -- - one with a standard Nil / Cons type-level list for older 30 | -- compilers which is not kind-safe 31 | 32 | -- | Type-level list that can contain arbitrarily mixed types. 33 | -- 34 | -- Example: 35 | -- 36 | -- >1 ::: "hello" ::: 2.3 :: TypeList '[Int, String, Double] 37 | data TypeList l where 38 | Nil :: TypeList '[] -- TODO make singleton list, not empty list, base type? 39 | (:::) :: a -> TypeList l -> TypeList (a ': l) 40 | 41 | -- Right-associativity, like (->) 42 | infixr ::: 43 | 44 | -- Example: You can write: 45 | -- 46 | -- exampleTypeList :: TypeList '[String, Int] 47 | -- exampleTypeList = "a" ::: 3 ::: Nil 48 | 49 | 50 | -- * \"Uncurrying\" functions 51 | 52 | {- In the following, we try to not use Template Haskell, 53 | using an instance of (a -> ...) to convert functions to TypeLists automatically 54 | (similar to how you make variadic functions). 55 | -} 56 | 57 | -- | Arguments to a function, e.g. @[String, Int]@ for @String -> Int -> r@. 58 | type family Param f :: [*] where 59 | Param (a -> f) = a ': Param f 60 | Param r = '[] 61 | 62 | -- | The result of a function, e.g. @r@ for @String -> Int -> r@. 63 | type family Result f :: * where 64 | Result (a -> f) = Result f 65 | Result r = r 66 | 67 | 68 | -- | Function f can be translated to 'TypeList' l with result type r. 69 | class (Param f ~ l, Result f ~ r) => ToTypeList f l r where 70 | -- | Translates a function taking multiple arguments to a function 71 | -- taking a single 'TypeList' containing the types of all arguments. 72 | -- 73 | -- Example: @t1 -> ... -> tn -> r@ becomes @TypeList [t1, ..., tn] -> r@. 74 | translate :: f -> TypeList l -> r 75 | 76 | 77 | -- | Base case: A "pure" function without arguments 78 | -- can be translated to @TypeList Nil -> r@. 79 | instance (ToTypeList f l r) => ToTypeList (a -> f) (a ': l) r where 80 | translate f (a ::: l) = translate (f a) l 81 | 82 | -- | Base case: A value @r@ can be translated to @TypeList Nil -> r@. 83 | instance (Param f ~ '[], Result f ~ r, f ~ r) => ToTypeList f '[] r where 84 | -- Could also be written as 85 | -- (Param r ~ '[], Result r ~ r) => ToTypeList r '[] r 86 | -- but I find the other way clearer. 87 | translate r Nil = r 88 | 89 | 90 | -- Now an example: 91 | -- 92 | -- someFunction :: Int -> Double -> String 93 | -- someFunction _i _d = return "asdf" 94 | -- 95 | -- exampleAutoTranslate = translate someFunction 96 | -- 97 | -- -- ghci would give as type for this: TypeList ((:) * Int ((:) * Double ([] *))) -> [Char] 98 | 99 | 100 | -- * Length of type-level lists 101 | 102 | -- | Allows to calculate the length of a 'TypeList', at compile time. 103 | -- 104 | -- We need to use a 'Proxy' for this. 105 | class ParamLength (l :: [*]) where 106 | -- | Calculates the length of a type list, put into a proxy. Usage: 107 | -- 108 | -- >paramLength (Proxy :: Proxy l) 109 | paramLength :: Proxy l -> Int 110 | 111 | instance ParamLength '[] where 112 | paramLength _ = 0 113 | 114 | instance (ParamLength l) => ParamLength (a ': l) where 115 | paramLength _ = succ $ paramLength (Proxy :: Proxy l) 116 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | call-haskell-from-anything 2 | ========================== 3 | 4 | [![Build Status](https://travis-ci.org/nh2/call-haskell-from-anything.png)](https://travis-ci.org/nh2/call-haskell-from-anything) 5 | 6 | Call Haskell functions from any programming language via serialization and dynamic libraries. 7 | 8 | [Skip the philosophy, jump right to the code!](#usage) 9 | 10 | 11 | I just want to call that function 12 | --------------------------------- 13 | 14 | ``` 15 | Want to call Haskell from Python? 16 | Want to call Haskell from Ruby? 17 | Want to call Haskell from C? 18 | Want to call Haskell from Node.js? 19 | Want to call Haskell from C#? 20 | Want to call Haskell from Java? 21 | Want to call Haskell from browsers? 22 | ``` 23 | 24 | Yes, Haskell can do that. 25 | 26 | Using the Foreign Function Interface (FFI) you can expose Haskell functions at the C level. 27 | 28 | But damn, it's so hard! 29 | 30 | You have two high-level languages here (Haskell and X), but even though you "just want to call that function", you have to think about and write low-level system code on both sides. 31 | Going via C is painful: An interface that does not even support the idea of *many of something* is not very supportive (no, C doesn't even have *arrays*, it only has pointers to the start of something). 32 | 33 | What we really want for most cases: 34 | * a slightly higher level, intuitive interface 35 | * as invisible as possible 36 | * just calling that function. 37 | 38 | ``` 39 | Want to call Haskell from ... anything? 40 | ``` 41 | 42 | 43 | The simplest FFI: Serialization 44 | ------------------------------- 45 | 46 | > In the end, the C calling convention is just another wire format: 47 | > Data is to be shipped from one function to another. 48 | 49 | So we could just as well use a wire format that is not as uncomfortable as the C FFI. 50 | 51 | *Any* serialization library does that for us, and most of them (e.g. JSON) are simpler to reason about and manage than raw memory in C. 52 | 53 | *call-haskell-from-anything* implements FFI function calls where function arguments and return value are serialized using [MessagePack](http://msgpack.org). 54 | Any function is then exported via the standard FFI as a raw bytes (`CString -> IO CString`) interface. 55 | 56 | 57 | Usage 58 | ----- 59 | 60 | *call-haskell-from-anything* allows you to write a function, say: 61 | 62 | ```haskell 63 | chooseMax :: [Int] -> Int 64 | chooseMax xs = ... 65 | ``` 66 | 67 | Add this: 68 | 69 | ```haskell 70 | foreign export ccall chooseMax_export :: CString -> IO CString 71 | chooseMax_export = export chooseMax 72 | ``` 73 | 74 | and compile it into a shared library (`.so` or `.dll`). 75 | You can now call it from any language that supports MessagePack, e.g. Python: 76 | 77 | ```python 78 | chooseMax = wrap_into_msgpack(cdll.LoadLibrary('mylib.so').chooseMax_export) 79 | 80 | print chooseMax([1,5,3]) 81 | ``` 82 | 83 | -- 84 | 85 | In detail, it will transform your functions of type 86 | 87 | ```haskell 88 | f :: a -> b -> ... -> r 89 | ``` 90 | 91 | to an equivalent (it is actually a type-level list) of 92 | 93 | ```haskell 94 | f' :: (a, b, ...) -> r 95 | ``` 96 | 97 | so that the function *input* (arguments) can be easily de-serialized. 98 | 99 | The `wrap_into_msgpack` function used above sets the return type of the foreign function to raw bytes and wraps arguments and return value into MessagePack, prepended by a 64-bit length: 100 | 101 | ```python 102 | def wrap_into_msgpack(foreign_fun): 103 | foreign_fun.restype = c_char_p 104 | 105 | def wrapped_fun(*args): 106 | packed = msgpack.packb(args) 107 | length_64bits = struct.pack("q", len(packed)) # native-endian 108 | ptr = fun(length_64bits + packed) 109 | data_length = cast(ptr[:8], POINTER(c_longlong))[0] 110 | res = msgpack.unpackb(ptr[8:8+data_length]) 111 | free(ptr) 112 | return res 113 | 114 | return wrapped_fun 115 | ``` 116 | 117 | 118 | A full example 119 | -------------- 120 | 121 | You can run the stock example in this repository: 122 | 123 | ```bash 124 | sudo apt-get install python-msgpack ruby-msgpack # or equivalent for your system 125 | stack build 126 | 127 | # If any of these work, you're all fine! 128 | python test.py 129 | ruby test.rb 130 | ``` 131 | 132 | FAQ 133 | --- 134 | 135 | ### Is *call-haskell-from-anything* an RPC framework? 136 | 137 | No. RPC means *Remote Procedure Call*, and nothing in *call-haskell-from-anything* assumes to be remote. 138 | 139 | Calls are blocking as you would expect from standard C libraries. 140 | 141 | 142 | ### Are there restrictions on what arguments functions can take? 143 | 144 | Yes: all arguments and the return value must be serializable. 145 | 146 | This means you cannot pass around pointers or callback functions; you have to use the C style FFI or an RPC mechanism for that. 147 | 148 | 149 | ### Why is MsgPack used for serialization? 150 | 151 | Because it is simple, available (there are implementations for most programming languages, and writing new ones is easy due to its simplicity), supports dumb binary (passing around arbitrary custom data does not require to think about encoding), and fast (in many implementations). 152 | 153 | However, *call-haskell-from-anything* is not fixed to use only MsgPack as wire-format; anything that can conveniently encode lists/arrays is suitable (`FFI.Anything.TypeUncurry.Msgpack` is the only implementation so far, though). 154 | 155 | 156 | ### How fast are serialized FFI calls? What is the trade-off compared to a C style FFI? 157 | 158 | Calls from one programming language into another are usually slower than calls inside the programming language, so it does make sense to check if a foreign call is worth it. 159 | 160 | In some preliminary cPython 2.7 benchmark using functions that take a single `Int` and return a single `Int` (e.g. the *+1* function), a foreign call using MsgPack serialization takes around 15 times longer than an in-Python function call (on the tested Core i5 machine, 1M calls took 15s, in pure Python they took 1s). However, as soon as you perform a somewhat expensive computation, the call into native Haskell code becomes worth it (take for example a naive recursive `fibonacci` implementation for 100000 calls of `fib(15)`; in-Python: 90s, with *call-haskell-from-anything*: 4.5s). 161 | 162 | In comparison to a C style FFI to an immediately returning `Int -> Int` function, the overhead of a serializing function call is around 6 times higher, and, as usual, becomes insignificant as soon as the function does something. 163 | 164 | More detailed benchmarks are planned, and **contributions are welcome**. 165 | -------------------------------------------------------------------------------- /src/FFI/Anything/TypeUncurry/Msgpack.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | {-# LANGUAGE DataKinds, TypeOperators #-} 4 | {-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleContexts #-} 5 | {-# LANGUAGE MonoLocalBinds #-} 6 | 7 | -- | Easy FFI via MessagePack. 8 | -- 9 | -- You can use this module to expose any Haskell function to other Programming languages. 10 | -- 11 | -- It allows to convert functions that take multiple arguments 12 | -- into functions that take one argument: 13 | -- A 'ByteString' which contains all arguments encoded as a MessagePack array. 14 | -- 15 | -- Common use cases: 16 | -- 17 | -- * Write functions in fast native Haskell code, compile them into a dynamic. 18 | -- library (@.so@ \/ @.dll@) and call them via C\/Python\/Ruby\/whatever via @dlopen()@ or equivalents. 19 | -- 20 | -- * Expose Haskell functions via a socket / the web 21 | module FFI.Anything.TypeUncurry.Msgpack ( 22 | MessagePackRec (..) 23 | , getTypeListFromMsgpackArray 24 | , uncurryMsgpack 25 | , tryUncurryMsgpack 26 | , tryUncurryMsgpackIO 27 | , byteStringToCStringFun 28 | , byteStringToCStringFunIO 29 | , export 30 | , exportIO 31 | ) where 32 | 33 | import Data.ByteString (ByteString) 34 | import qualified Data.ByteString as BS 35 | import qualified Data.ByteString.Lazy as BSL 36 | import Data.ByteString.Unsafe (unsafeUseAsCStringLen) 37 | import Data.Int (Int64) 38 | import Data.Maybe (fromMaybe) 39 | import qualified Data.MessagePack as MSG 40 | import Data.Proxy 41 | import Data.Storable.Endian (peekBE, pokeBE) 42 | import Foreign.C 43 | import Foreign.Marshal.Alloc (mallocBytes) 44 | import Foreign.Marshal.Utils (copyBytes) 45 | import Foreign.Ptr (castPtr, plusPtr) 46 | 47 | import FFI.Anything.TypeUncurry 48 | 49 | 50 | -- | Helper to allow writing a 'MSG.MessagePack' instance for 'TypeList's. 51 | -- 52 | -- We need this because we have to call 'parseArray' at the top-level 53 | -- 'MSG.MessagePack' instance, but not at each function argument step. 54 | class MessagePackRec l where 55 | fromObjectRec :: (MonadFail m) => [MSG.Object] -> m (TypeList l) 56 | 57 | -- | When no more types need to be unpacked, we are done. 58 | instance MessagePackRec '[] where 59 | fromObjectRec v | null v = pure Nil 60 | fromObjectRec _ = fail "fromObjectRec: passed object is not expected []" 61 | 62 | -- | Unpack one type by just parsing the next element. 63 | instance (MSG.MessagePack a, MessagePackRec l) => MessagePackRec (a ': l) where 64 | fromObjectRec (x:xs) = (:::) <$> MSG.fromObject x <*> fromObjectRec xs 65 | fromObjectRec _ = fail "fromObjectRec: passed object is not expected (x:xs)" 66 | 67 | -- | Parses a tuple of arbitrary size ('TypeList's) from a MessagePack array. 68 | getTypeListFromMsgpackArray :: forall m l . (MessagePackRec l, ParamLength l, MonadFail m) => MSG.Object -> m (TypeList l) 69 | getTypeListFromMsgpackArray obj = case obj of 70 | MSG.ObjectArray v | length v == len -> fromObjectRec v 71 | _ -> fail "getTypeListFromMsgpackArray: wrong object length" 72 | where 73 | len = paramLength (Proxy :: Proxy l) 74 | 75 | instance (MessagePackRec l, ParamLength l) => MSG.MessagePack (TypeList l) where 76 | fromObject = getTypeListFromMsgpackArray 77 | toObject = error "call-haskell-from-anything: Serialising a TypeList is not supported (and not needed)!" 78 | 79 | 80 | -- | Standard error message when unpacking failed. 81 | errorMsg :: String -> String 82 | errorMsg locationStr = "call-haskell-from-anything: " ++ locationStr ++ ": got wrong number of function arguments or non-array" 83 | 84 | 85 | -- | Translates a function of type @a -> b -> ... -> r@ to 86 | -- a function that: 87 | -- 88 | -- * takes as a single argument a 'ByteString' containing all arguments serialized in a MessagePack array 89 | -- 90 | -- * returns its result serialized in a 'ByteString' via MessagePack 'MSG.pack' 91 | -- 92 | -- This function throws an 'error' if the de-serialization of the arguments fails! 93 | -- It is recommended to use 'tryUncurryMsgpack' instead. 94 | uncurryMsgpack :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> (ByteString -> ByteString) 95 | uncurryMsgpack f = \bs -> BSL.toStrict . MSG.pack $ (translate f $ fromMaybe (error (errorMsg "uncurryMsgpack")) $ MSG.unpack $ BSL.fromStrict bs) 96 | 97 | 98 | -- | Like 'uncurryMsgpack', but for 'IO' functions. 99 | -- 100 | -- This function throws an 'error' if the de-serialization of the arguments fails! 101 | -- It is recommended to use 'tryUncurryMsgpackIO' instead. 102 | uncurryMsgpackIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> (ByteString -> IO ByteString) 103 | uncurryMsgpackIO f = \bs -> BSL.toStrict . MSG.pack <$> (translate f $ fromMaybe (error (errorMsg "uncurryMsgpackIO")) $ MSG.unpack $ BSL.fromStrict bs) 104 | 105 | 106 | -- | Like 'uncurryMsgpack', but makes it clear when the 'ByteString' containing 107 | -- the function arguments does not contain the right number/types of arguments. 108 | tryUncurryMsgpack :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> (ByteString -> Maybe ByteString) 109 | tryUncurryMsgpack f = \bs -> case MSG.unpack $ BSL.fromStrict bs of 110 | Nothing -> Nothing 111 | Just args -> Just . BSL.toStrict . MSG.pack $ (translate f $ args) 112 | 113 | 114 | -- | Like 'uncurryMsgpack', but makes it clear when the 'ByteString' containing 115 | -- the function arguments does not contain the right number/types of arguments. 116 | tryUncurryMsgpackIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> (ByteString -> Maybe (IO ByteString)) 117 | tryUncurryMsgpackIO f = \bs -> case MSG.unpack $ BSL.fromStrict bs of 118 | Nothing -> Nothing 119 | Just args -> Just $ BSL.toStrict . MSG.pack <$> (translate f $ args) 120 | 121 | 122 | -- | O(n). Makes a copy of the ByteString's contents into a malloc()ed area. 123 | -- You need to free() the returned string when you're done with it. 124 | byteStringToMallocedCStringWith64bitLength :: ByteString -> IO CString 125 | byteStringToMallocedCStringWith64bitLength bs = 126 | unsafeUseAsCStringLen bs $ \(ptr, len) -> do 127 | targetPtr <- mallocBytes (8 + len) 128 | pokeBE (castPtr targetPtr) (fromIntegral len :: Int64) 129 | copyBytes (targetPtr `plusPtr` 8) ptr len 130 | return targetPtr 131 | 132 | 133 | -- * Exporting 134 | 135 | -- TODO implement via byteStringToCStringFunIO? 136 | -- | Transforms a 'ByteString'-mapping function to 'CString'-mapping function 137 | -- for use in the FFI. 138 | byteStringToCStringFun :: (ByteString -> ByteString) -> CString -> IO CString 139 | byteStringToCStringFun f cs = do 140 | msgLength :: Int64 <- peekBE (castPtr cs) 141 | cs_bs <- BS.packCStringLen (cs `plusPtr` 8, fromIntegral msgLength) 142 | let res_bs = f cs_bs 143 | res_cs <- byteStringToMallocedCStringWith64bitLength res_bs 144 | return res_cs 145 | 146 | 147 | -- | Transforms a 'ByteString'-mapping 'IO' function to 'CString'-mapping function 148 | -- for use in the FFI. 149 | byteStringToCStringFunIO :: (ByteString -> IO ByteString) -> CString -> IO CString 150 | byteStringToCStringFunIO f cs = do 151 | msgLength :: Int64 <- peekBE (castPtr cs) 152 | cs_bs <- BS.packCStringLen (cs `plusPtr` 8, fromIntegral msgLength) 153 | res_bs <- f cs_bs 154 | res_cs <- byteStringToMallocedCStringWith64bitLength res_bs 155 | return res_cs 156 | 157 | 158 | -- | Exports a "pure" function 159 | -- to an FFI function that takes its arguments as a serialized MessagePack message. 160 | -- 161 | -- Calling this function throws an 'error' if the de-serialization of the arguments fails! 162 | -- Use 'tryExport' if you want to handle this case. 163 | export :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> CString -> IO CString 164 | export = byteStringToCStringFun . uncurryMsgpack 165 | 166 | 167 | -- | Exports an 'IO' function to an FFI function that takes its arguments as a serialized MessagePack message. 168 | -- 169 | -- Calling this function throws an 'error' if the de-serialization of the arguments fails! 170 | -- Use 'tryExportIO' if you want to handle this case. 171 | exportIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> CString -> IO CString 172 | exportIO = byteStringToCStringFunIO . uncurryMsgpackIO 173 | 174 | 175 | -- TODO make equivalent using tryUncurryMsgpack (tryExport) 176 | -- TODO make equivalent using tryUncurryMsgpackIO (tryExport) 177 | --------------------------------------------------------------------------------