[WIP] Add support for wrapping modules in capabilities

crates/steel-core/Cargo.toml

@@ -68,6 +68,9 @@ anyhow = { version = "1", optional = true }
 
 stacker = { version = "0.1.15", optional = true }
 
+# For capabilities
+glob = { version = "0.3.1" }
+
 [target.'cfg(target_arch = "wasm32")'.dependencies]
 getrandom = { version = "*", features = ["js"] }
 

crates/steel-core/src/compiler/program.rs

@@ -403,6 +403,7 @@ define_symbols! {
     FOR_SYNTAX => "for-syntax",
     PREFIX_IN => "prefix-in",
     ONLY_IN => "only-in",
+    CAPABILITIES_IN => "capabilities-in",
     DATUM_SYNTAX => "datum->syntax",
     SYNTAX_SPAN => "#%syntax-span",
     IF => "if",

crates/steel-core/src/primitives/fs.rs

@@ -1,5 +1,6 @@
 use crate::rvals::{Custom, Result, SteelString, SteelVal};
 use crate::steel_vm::builtin::BuiltInModule;
+use crate::values::capabilities::{FileSystemAccessKind, FileSystemAccessRequest};
 use crate::{steelerr, stop, throw};
 use dirs;
 use std::env::current_dir;
@@ -59,13 +60,27 @@ pub fn fs_module() -> BuiltInModule {
 /// Deletes the directory
 #[steel_derive::function(name = "delete-directory!")]
 pub fn delete_directory(directory: &SteelString) -> Result<SteelVal> {
+    // Check that we have access to this directory at all
+    FileSystemAccessRequest {
+        kind: FileSystemAccessKind::Write,
+        resource: directory.as_str(),
+    }
+    .check()?;
+
     std::fs::remove_dir_all(directory.as_str())?;
     Ok(SteelVal::Void)
 }
 
 /// Creates the directory
 #[steel_derive::function(name = "create-directory!")]
 pub fn create_directory(directory: &SteelString) -> Result<SteelVal> {
+    // Check that we have access to this directory at all
+    FileSystemAccessRequest {
+        kind: FileSystemAccessKind::Write,
+        resource: directory.as_str(),
+    }
+    .check()?;
+
     std::fs::create_dir_all(directory.as_str())?;
 
     Ok(SteelVal::Void)
@@ -77,6 +92,20 @@ pub fn copy_directory_recursively(
     source: &SteelString,
     destination: &SteelString,
 ) -> Result<SteelVal> {
+    // Check that we have access to read this directory at all
+    FileSystemAccessRequest {
+        kind: FileSystemAccessKind::Read,
+        resource: source.as_str(),
+    }
+    .check()?;
+
+    // Check that we have access to this directory at all
+    FileSystemAccessRequest {
+        kind: FileSystemAccessKind::Write,
+        resource: destination.as_str(),
+    }
+    .check()?;
+
     copy_recursively(source.as_str(), destination.as_str())?;
 
     Ok(SteelVal::Void)
@@ -85,18 +114,39 @@ pub fn copy_directory_recursively(
 /// Checks if a path exists
 #[steel_derive::function(name = "path-exists?")]
 pub fn path_exists(path: &SteelString) -> Result<SteelVal> {
+    // Check that we have access to read this path at all
+    FileSystemAccessRequest {
+        kind: FileSystemAccessKind::Read,
+        resource: path.as_str(),
+    }
+    .check()?;
+
     Ok(SteelVal::BoolV(Path::new(path.as_ref()).exists()))
 }
 
 /// Checks if a path is a file
 #[steel_derive::function(name = "is-file?")]
 pub fn is_file(path: &SteelString) -> Result<SteelVal> {
+    // Check that we have access to read this path at all
+    FileSystemAccessRequest {
+        kind: FileSystemAccessKind::Read,
+        resource: path.as_str(),
+    }
+    .check()?;
+
     Ok(SteelVal::BoolV(Path::new(path.as_ref()).is_file()))
 }
 
 /// Checks if a path is a directory
 #[steel_derive::function(name = "is-dir?")]
 pub fn is_dir(path: &SteelString) -> Result<SteelVal> {
+    // Check that we have access to read this path at all
+    FileSystemAccessRequest {
+        kind: FileSystemAccessKind::Read,
+        resource: path.as_str(),
+    }
+    .check()?;
+
     Ok(SteelVal::BoolV(Path::new(path.as_ref()).is_dir()))
 }
 
@@ -125,6 +175,13 @@ pub fn file_name(path: &SteelString) -> Result<SteelVal> {
 /// Returns canonical path with all components normalized
 #[steel_derive::function(name = "canonicalize-path")]
 pub fn canonicalize_path(path: &SteelString) -> Result<SteelVal> {
+    // Check that we have access to read this path at all
+    FileSystemAccessRequest {
+        kind: FileSystemAccessKind::Read,
+        resource: path.as_str(),
+    }
+    .check()?;
+
     let path = path.as_str();
     let canonicalized = if path.len() > 0 && path.starts_with('~') {
         if path.len() > 1 && !path.starts_with("~/") {
@@ -151,6 +208,13 @@ pub fn canonicalize_path(path: &SteelString) -> Result<SteelVal> {
 /// Returns the contents of the directory as a list
 #[steel_derive::function(name = "read-dir")]
 pub fn read_dir(path: &SteelString) -> Result<SteelVal> {
+    // Check that we have access to read this path at all
+    FileSystemAccessRequest {
+        kind: FileSystemAccessKind::Read,
+        resource: path.as_str(),
+    }
+    .check()?;
+
     let p = Path::new(path.as_ref());
     if p.is_dir() {
         let iter = p.read_dir();

crates/steel-core/src/scheme/modules/parameters.scm

@@ -3,7 +3,10 @@
          call/cc
          call-with-current-continuation
          make-parameter
-         continuation?)
+         continuation?
+
+         (for-syntax with-capability)
+         #%wrap-with-capability)
 
 ;;;;;; Parameters ;;;;;
 
@@ -165,3 +168,29 @@
       (set! winders (cdr winders))
       (out)
       ans*)))
+
+;; Use this during macro expansion to make sure that things
+;; get wrapped in the proper capabilities
+(define-syntax with-capability
+  (syntax-rules ()
+    [(_ capability-expr guarded-expr)
+     ; (let ([evaluated-capability capability-expr])
+     (dynamic-wind (lambda () (#%push-capability capability-expr))
+                   (lambda () guarded-expr)
+                   (lambda () (#%pop-capability)))]))
+
+(define-syntax #%with-capabilities
+  (syntax-rules ()
+    [(_ guarded-expr capabilities ...)
+     (let ([evaluated-capabilities (list capabilities ...)])
+       (dynamic-wind (lambda () (apply #%push-capabilities evaluated-capabilities))
+                     (lambda () guarded-expr)
+                     (lambda () (#%pop-n-capabilities (length evaluated-capabilities)))))]))
+
+;; Wrap the function with a given capability.
+;; At the moment, this does not attempt to specialize the arity, however
+;; we definitely should because otherwise this becomes rather slow
+(define (#%wrap-with-capability capability maybe-function)
+  (if (function? maybe-function)
+      (lambda args (with-capability capability (apply maybe-function args)))
+      maybe-function))

crates/steel-core/src/steel_vm/primitives.rs

@@ -41,6 +41,7 @@ use crate::{
         vm::threads::threading_module,
     },
     values::{
+        capabilities::capabilities_module,
         closed::HeapRef,
         functions::{attach_contract_struct, get_contract, LambdaMetadataTable},
         lists::List,
@@ -316,6 +317,8 @@ thread_local! {
     pub static TYPE_ID_MODULE: BuiltInModule = build_type_id_module();
     pub static OPTION_MODULE: BuiltInModule = build_option_structs();
 
+    pub static CAPABILITIES_MODULE: BuiltInModule = capabilities_module();
+
     #[cfg(feature = "dylibs")]
     pub static FFI_MODULE: BuiltInModule = ffi_module();
 
@@ -340,7 +343,6 @@ pub fn prelude() -> BuiltInModule {
         .with_module(STRING_MODULE.with(|x| x.clone()))
         .with_module(VECTOR_MODULE.with(|x| x.clone()))
         .with_module(STREAM_MODULE.with(|x| x.clone()))
-        // .with_module(CONTRACT_MODULE.with(|x| x.clone()))
         .with_module(IDENTITY_MODULE.with(|x| x.clone()))
         .with_module(NUMBER_MODULE.with(|x| x.clone()))
         .with_module(EQUALITY_MODULE.with(|x| x.clone()))
@@ -361,6 +363,7 @@ pub fn prelude() -> BuiltInModule {
         .with_module(TIME_MODULE.with(|x| x.clone()))
         .with_module(THREADING_MODULE.with(|x| x.clone()))
         .with_module(BYTEVECTOR_MODULE.with(|x| x.clone()))
+        .with_module(CAPABILITIES_MODULE.with(|x| x.clone()))
 }
 
 pub fn register_builtin_modules_without_io(engine: &mut Engine) {
@@ -383,20 +386,18 @@ pub fn register_builtin_modules_without_io(engine: &mut Engine) {
         .register_module(STRING_MODULE.with(|x| x.clone()))
         .register_module(VECTOR_MODULE.with(|x| x.clone()))
         .register_module(STREAM_MODULE.with(|x| x.clone()))
-        // .register_module(CONTRACT_MODULE.with(|x| x.clone()))
         .register_module(IDENTITY_MODULE.with(|x| x.clone()))
         .register_module(NUMBER_MODULE.with(|x| x.clone()))
         .register_module(EQUALITY_MODULE.with(|x| x.clone()))
         .register_module(ORD_MODULE.with(|x| x.clone()))
         .register_module(TRANSDUCER_MODULE.with(|x| x.clone()))
         .register_module(SYMBOL_MODULE.with(|x| x.clone()))
         .register_module(SANDBOXED_IO_MODULE.with(|x| x.clone()))
-        // .register_module(FS_MODULE.with(|x| x.clone()))
-        // .register_module(PORT_MODULE.with(|x| x.clone()))
         .register_module(SANDBOXED_META_MODULE.with(|x| x.clone()))
         .register_module(JSON_MODULE.with(|x| x.clone()))
         .register_module(CONSTANTS_MODULE.with(|x| x.clone()))
         .register_module(SYNTAX_MODULE.with(|x| x.clone()))
+        .register_module(CAPABILITIES_MODULE.with(|x| x.clone()))
         .register_module(PRELUDE_MODULE.with(|x| x.clone()));
 }
 
@@ -477,7 +478,8 @@ pub fn register_builtin_modules(engine: &mut Engine) {
         .register_module(TIME_MODULE.with(|x| x.clone()))
         .register_module(RANDOM_MODULE.with(|x| x.clone()))
         .register_module(THREADING_MODULE.with(|x| x.clone()))
-        .register_module(BYTEVECTOR_MODULE.with(|x| x.clone()));
+        .register_module(BYTEVECTOR_MODULE.with(|x| x.clone()))
+        .register_module(CAPABILITIES_MODULE.with(|x| x.clone()));
 
     #[cfg(feature = "dylibs")]
     engine.register_module(FFI_MODULE.with(|x| x.clone()));
@@ -572,6 +574,7 @@ pub static ALL_MODULES: &str = r#"
     (require-builtin steel/core/types)
     (require-builtin steel/threads)
     (require-builtin steel/bytevectors)
+    (require-builtin steel/capabilities)
 
     (require-builtin steel/hash as #%prim.)
     (require-builtin steel/sets as #%prim.)
@@ -598,6 +601,7 @@ pub static ALL_MODULES: &str = r#"
     (require-builtin steel/core/types as #%prim.)
     (require-builtin steel/threads as #%prim.)
     (require-builtin steel/bytevectors as #%prim.)
+    (require-builtin steel/capabilities as #%prim.)
 "#;
 
 pub static ALL_MODULES_RESERVED: &str = r#"
@@ -626,6 +630,7 @@ pub static ALL_MODULES_RESERVED: &str = r#"
     (require-builtin steel/core/types as #%prim.)
     (require-builtin steel/threads as #%prim.)
     (require-builtin steel/bytevectors as #%prim.)
+    (require-builtin steel/capabilities as #%prim.)
 "#;
 
 pub static SANDBOXED_MODULES: &str = r#"
@@ -646,6 +651,7 @@ pub static SANDBOXED_MODULES: &str = r#"
     (require-builtin steel/json)
     (require-builtin steel/constants)
     (require-builtin steel/syntax)
+    (require-builtin steel/capabilities)
 "#;
 
 // TODO: Clean this up a lot