From 3e64b04f5baad6b90c19346778481ebd1ac960e9 Mon Sep 17 00:00:00 2001 From: Shao Cheng Date: Sun, 16 Dec 2018 22:26:57 +0800 Subject: [PATCH] Implement the persistent vault feature #48 (+3 squashed commit) --- .circleci/config.yml | 2 + README.md | 1 + asterius/package.yaml | 8 ++++ asterius/rts/rts.js | 18 ++++++++- asterius/test/vault.hs | 26 +++++++++++++ asterius/test/vault/vault.hs | 21 ++++++++++ docs/vault.md | 17 +++++++++ ghc-toolkit/boot-libs/base/Asterius/Vault.hs | 40 ++++++++++++++++++++ ghc-toolkit/boot-libs/base/base.cabal | 1 + mkdocs.yml | 1 + 10 files changed, 134 insertions(+), 1 deletion(-) create mode 100644 asterius/test/vault.hs create mode 100644 asterius/test/vault/vault.hs create mode 100644 docs/vault.md create mode 100644 ghc-toolkit/boot-libs/base/Asterius/Vault.hs diff --git a/.circleci/config.yml b/.circleci/config.yml index 855b0f50..8d64b2c5 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -58,6 +58,7 @@ jobs: stack --no-terminal test asterius:teletype stack --no-terminal test asterius:bytearray stack --no-terminal test asterius:bigint + stack --no-terminal test asterius:vault stack --no-terminal test asterius:fib --test-arguments="--binaryen" stack --no-terminal test asterius:jsffi --test-arguments="--binaryen" stack --no-terminal test asterius:array --test-arguments="--binaryen" @@ -66,6 +67,7 @@ jobs: stack --no-terminal test asterius:teletype --test-arguments="--binaryen" stack --no-terminal test asterius:bytearray --test-arguments="--binaryen" stack --no-terminal test asterius:bigint --test-arguments="--binaryen" + stack --no-terminal test asterius:vault --test-arguments="--binaryen" asterius-build-docker: docker: diff --git a/README.md b/README.md index 6853752b..4dd07179 100644 --- a/README.md +++ b/README.md @@ -28,6 +28,7 @@ What works currently: * All GHC language features except Template Haskell. * Non-IO parts in `ghc-prim`/`integer-simple`/`base`/`array`/`deepseq`/`containers`/`transformers`/`mtl`/`pretty`/`bytestring`/`binary`/`xhtml`. IO is achieved via rts primitives like `print_i64` or JavaScript FFI. * Fast arbitrary-precision `Integer` operations backed by `BigInt`s. +* Persistent "vault"s which are KV stores transferrable across asterius instances. * Importing JavaScript expressions via the `foreign import javascript` syntax. First-class `JSVal` type in Haskell land. * Fast conversion between Haskell/JavaScript types (strings, arrays and ArrayBuffers at the moment) * Calling Haskell functions from JavaScript via the `foreign export javascript` syntax. Haskell closures can be passed between Haskell/JavaScript boundary via `StablePtr`. diff --git a/asterius/package.yaml b/asterius/package.yaml index 02dca268..fe66009e 100644 --- a/asterius/package.yaml +++ b/asterius/package.yaml @@ -28,6 +28,7 @@ extra-source-files: - test/teletype/**/*.hs - test/bytearray/**/*.hs - test/bigint/**/*.hs + - test/vault/**/*.hs data-files: - rts/rts.js @@ -209,3 +210,10 @@ tests: ghc-options: -threaded -feager-blackholing -rtsopts dependencies: - asterius + + vault: + source-dirs: test + main: vault.hs + ghc-options: -threaded -feager-blackholing -rtsopts + dependencies: + - asterius diff --git a/asterius/rts/rts.js b/asterius/rts/rts.js index 74eebb46..b4c89148 100644 --- a/asterius/rts/rts.js +++ b/asterius/rts/rts.js @@ -71,7 +71,8 @@ __asterius_mem_size = null, __asterius_last_mblock = null, __asterius_last_block = null, - __asterius_TSOs = [,]; + __asterius_TSOs = [,], + __asterius_vault = req.vault ? req.vault : new Map(); function __asterius_show_I(x) { return x.toString(16).padStart(8, "0"); } @@ -135,12 +136,26 @@ ); } } + function __asterius_decodeLatin1(buf) { + return new Uint8Array(buf).reduce( + (tot, byte) => tot + String.fromCodePoint(byte), + "" + ); + } const __asterius_jsffi_instance = { JSRefs: __asterius_jsffi_JSRefs, newJSRef: __asterius_jsffi_newJSRef, newTempJSRef: __asterius_jsffi_newTempJSRef, mutTempJSRef: __asterius_jsffi_mutTempJSRef, freezeTempJSRef: __asterius_jsffi_freezeTempJSRef, + vaultInsert: (k, v) => + __asterius_jsffi_instance.vault.set(__asterius_decodeLatin1(k), v), + vaultHas: k => + __asterius_jsffi_instance.vault.has(__asterius_decodeLatin1(k)), + vaultLookup: k => + __asterius_jsffi_instance.vault.get(__asterius_decodeLatin1(k)), + vaultDelete: k => + __asterius_jsffi_instance.vault.delete(__asterius_decodeLatin1(k)), makeHaskellCallback: s => () => { const export_funcs = __asterius_wasm_instance.exports; export_funcs.rts_evalIO(__asterius_deRefStablePtr(s)); @@ -898,6 +913,7 @@ wasmInstance: resultObject.instance, staticsSymbolMap: req.staticsSymbolMap, functionSymbolMap: req.functionSymbolMap, + vault: __asterius_vault, __asterius_jsffi_JSRefs: __asterius_jsffi_JSRefs, __asterius_SPT: __asterius_SPT }); diff --git a/asterius/test/vault.hs b/asterius/test/vault.hs new file mode 100644 index 00000000..d101388d --- /dev/null +++ b/asterius/test/vault.hs @@ -0,0 +1,26 @@ +import System.Environment +import System.Process + +main :: IO () +main = do + args <- getArgs + callProcess "ahc-link" $ + [ "--input" + , "test/vault/vault.hs" + , "--output-link-report" + , "test/vault/vault.link.txt" + , "--run" + ] <> + [ mconcat + [ "--asterius-instance-callback=" + , "async i => {" + , "i.wasmInstance.exports.hs_init();" + , "i.wasmInstance.exports.main();" + , "i.vault = new Map([['key', 'Vault value set from js']]);" + , "await new Promise(resolve => setTimeout(resolve, 1024));" + , "i.wasmInstance.exports.main();" + , "console.log(i.stdio.stdout());" + , "}" + ] + ] <> + args diff --git a/asterius/test/vault/vault.hs b/asterius/test/vault/vault.hs new file mode 100644 index 00000000..93a612b5 --- /dev/null +++ b/asterius/test/vault/vault.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +import Asterius.ByteString +import Asterius.Types +import Asterius.Vault + +foreign import javascript "new Date()" js_get_jsval :: IO JSVal + +foreign import javascript "${1}.toString()" js_toString :: JSVal -> JSString + +instance Show JSVal where + show = show . fromJSString . js_toString + +main :: IO () +main = do + v <- js_get_jsval + let k = byteStringToJSArrayBuffer "key" + vaultLookup k >>= print + vaultInsert k v + vaultLookup k >>= print diff --git a/docs/vault.md b/docs/vault.md new file mode 100644 index 00000000..6ff558d2 --- /dev/null +++ b/docs/vault.md @@ -0,0 +1,17 @@ +# The "Vault" + +Asterius provides a "persistent vault" feature, which provides a KV store per asterius instance, and the store can be accessed in both Haskell and JavaScript. The vault enables compiled Haskell code to reuse some state, even if the whole asterius instance is wiped and restarted. See GitHub issue [48](https://github.com/tweag/asterius/issues/48) for further explanation. + +The Haskell API is in `Asterius.Vault` in `base`: + +``` +vaultInsert :: JSArrayBuffer -> JSVal -> IO () +vaultLookup :: JSArrayBuffer -> IO (Maybe JSVal) +vaultDelete :: JSArrayBuffer -> IO () +``` + +The key of a vault is a `JSArrayBuffer`, typically converted from a `ByteString`. The value can be `JSVal`, which can be `coerce`ed from any `JS*` type. + +In JavaScript, assuming `i` is the asterius instance, then `i.vault` is the instance vault. `i.vault` defaults to empty, and can be passed around, modified and assigned. + +The `i.vault` value is a `Map` object which uses immutable `String`s converted from `ArrayBuffer`s as keys. It's only safe to manipulate keys in JavaScript when you're sure the strings only encode Latin-1 characters. diff --git a/ghc-toolkit/boot-libs/base/Asterius/Vault.hs b/ghc-toolkit/boot-libs/base/Asterius/Vault.hs new file mode 100644 index 00000000..2faec5d7 --- /dev/null +++ b/ghc-toolkit/boot-libs/base/Asterius/Vault.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Asterius.Vault + ( vaultInsert + , vaultLookup + , vaultDelete + ) where + +import Asterius.Types +import GHC.Base + +{-# INLINE vaultInsert #-} +vaultInsert :: JSArrayBuffer -> JSVal -> IO () +vaultInsert = js_vaultInsert + +{-# INLINE vaultLookup #-} +vaultLookup :: JSArrayBuffer -> IO (Maybe JSVal) +vaultLookup buf = do + f <- js_vaultHas buf + if f + then do + r <- js_vaultLookup buf + pure (Just r) + else pure Nothing + +{-# INLINE vaultDelete #-} +vaultDelete :: JSArrayBuffer -> IO () +vaultDelete = js_vaultDelete + +foreign import javascript "__asterius_jsffi.vaultInsert(${1},${2})" js_vaultInsert + :: JSArrayBuffer -> JSVal -> IO () + +foreign import javascript "__asterius_jsffi.vaultHas(${1})" js_vaultHas + :: JSArrayBuffer -> IO Bool + +foreign import javascript "__asterius_jsffi.vaultLookup(${1})" js_vaultLookup + :: JSArrayBuffer -> IO JSVal + +foreign import javascript "__asterius_jsffi.vaultDelete(${1})" js_vaultDelete + :: JSArrayBuffer -> IO () diff --git a/ghc-toolkit/boot-libs/base/base.cabal b/ghc-toolkit/boot-libs/base/base.cabal index 839fbd76..da230fad 100644 --- a/ghc-toolkit/boot-libs/base/base.cabal +++ b/ghc-toolkit/boot-libs/base/base.cabal @@ -320,6 +320,7 @@ Library Unsafe.Coerce Asterius.Prim + Asterius.Vault other-modules: Control.Monad.ST.Imp diff --git a/mkdocs.yml b/mkdocs.yml index f2896699..5b1bba73 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -6,6 +6,7 @@ pages: - 'Building guide': 'building.md' - 'Using ahc-link': 'ahc-link.md' - 'JavaScript FFI': 'jsffi.md' + - 'The Vault': 'vault.md' - 'Invoking RTS API in JavaScript': 'rts-api.md' - 'IR types and transformation passes': 'ir.md' - 'The runtime debugging feature': 'debugging.md'