Implement the persistent vault feature #48 (+3 squashed commit)

.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:

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`.

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

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
     });

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

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

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.

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 ()

ghc-toolkit/boot-libs/base/base.cabal

@@ -320,6 +320,7 @@ Library
         Unsafe.Coerce
 
         Asterius.Prim
+        Asterius.Vault
 
     other-modules:
         Control.Monad.ST.Imp

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'