added ffi/unsafe/security

collects/ffi/unsafe/security.rkt

@@ -0,0 +1,145 @@
+#lang racket/base
+(require ffi/unsafe)
+(provide security-guard-check-file
+         _file/guard
+         _file/r
+         _file/rw)
+
+(define SCHEME_GUARD_FILE_READ     #x1)
+(define SCHEME_GUARD_FILE_WRITE    #x2)
+(define SCHEME_GUARD_FILE_EXECUTE  #x4)
+(define SCHEME_GUARD_FILE_DELETE   #x8)
+(define SCHEME_GUARD_FILE_EXISTS  #x10)
+
+(define scheme_security_check_file
+  (get-ffi-obj "scheme_security_check_file" (ffi-lib #f)
+               (_fun _symbol _path _int -> _void)))
+
+(define (convert-modes who guards)
+  (unless (list? guards)
+    (raise-type-error who "list of symbols" guards))
+  (let ([read?    0]
+        [write?   0]
+        [execute? 0]
+        [delete?  0]
+        [exists?  0])
+    (for-each (lambda (guard)
+                (case guard
+                  ((read) (set! read? SCHEME_GUARD_FILE_READ))
+                  ((write) (set! write? SCHEME_GUARD_FILE_WRITE))
+                  ((execute) (set! execute? SCHEME_GUARD_FILE_EXECUTE))
+                  ((delete) (set! delete? SCHEME_GUARD_FILE_DELETE))
+                  ((exists) (set! exists? SCHEME_GUARD_FILE_EXISTS))
+                  (else (error who "bad permission symbol: ~e" guard))))
+              guards)
+    (when (and (positive? exists?)
+               (positive? (+ read? write? execute? delete?)))
+      (error who "permission 'exists must occur alone: ~e" guards))
+    (+ read? write? execute? delete? exists?)))
+
+(define (security-guard-check-file who path modes)
+  (unless (symbol? who)
+    (raise-type-error 'security-guard-check-file "symbol" 0 who path modes))
+  (unless (or (path? path) (path-string? path))
+    (raise-type-error 'security-guard-check-file "path or path string" 1 who path modes))
+  (let ([cp (cleanse-path (path->complete-path path))]
+        [mode (convert-modes 'security-guard-check-file modes)])
+    (scheme_security_check_file who cp mode)))
+
+(define (_file/guard modes [who '_file/guard])
+  (let ([mode (convert-modes '_file/guard modes)])
+    (unless (symbol? who)
+      (raise-type-error '_file/guard "symbol" who))
+    (make-ctype
+     _path
+     (lambda (p)
+       (let ([cp (cleanse-path (path->complete-path p))])
+         (scheme_security_check_file who cp mode)
+         cp))
+     #f)))
+
+(define _file/r (_file/guard '(read) '_file/r))
+(define _file/rw (_file/guard '(read write) '_file/rw))
+
+#|
+;; -- Tests --
+
+(require rackunit
+         racket/runtime-path)
+
+(define-runtime-module-path pub-mod0 racket/list)
+(define-runtime-module-path priv-mod0 racket/private/stx)
+
+(define pub-mod (resolved-module-path-name pub-mod0))
+(define priv-mod (resolved-module-path-name priv-mod0))
+
+(define (mk-fun modes)
+  ;; receives path pointer, casts as int, who cares
+  (get-ffi-obj "scheme_make_integer_value" (ffi-lib #f)
+               (_fun (path) ::
+                     (path : (_file/guard modes))
+                     -> _scheme)))
+
+(define (fun path modes)
+  ((mk-fun modes) path))
+
+(define sg0 (current-security-guard))
+
+(define sg-ro
+  (make-security-guard
+   sg0
+   (lambda (who path modes)
+     (when (or (memq 'write modes) (memq 'delete modes))
+       (error who "write/delete not allowed")))
+   void void))
+
+(define sg-priv
+  (make-security-guard
+   sg0
+   (lambda (who path modes)
+     (when (and path (regexp-match #rx"private" (path->string path)))
+       (error who "no access to private paths: ~e" path)))
+   void void))
+
+;; Test works on both strings and paths, rel and abs.
+
+(define-syntax-rule (check-ok expr) (check-not-exn (lambda () expr)))
+(define-syntax-rule (check-err expr) (check-exn exn:fail? (lambda () expr)))
+
+(define-syntax-rule (run1 expr ok?)
+  (void
+   (if ok?
+       (check-not-exn (lambda () expr))
+       (check-exn exn:fail? (lambda () expr)))))
+
+(define (run path modes ok?)
+  (run1 (security-guard-check-file 'me path modes) ok?)
+  (run1 (fun path modes) ok?))
+
+(test-case "default security guard"
+  (parameterize ((current-security-guard sg0))
+    (run "foo.txt" '(read) #t)
+    (run "bar.txt" '(write delete) #t)
+    (run pub-mod '(read) #t)
+    (run pub-mod '(write) #t)
+    (run priv-mod '(read) #t)
+    (run priv-mod '(read write delete) #t)))
+
+(test-case "read-only security-guard"
+  (parameterize ((current-security-guard sg-ro))
+    (run "foo.txt" '(read) #t)
+    (run "bar.txt" '(write delete) #f)
+    (run pub-mod '(read) #t)
+    (run pub-mod '(write) #f)
+    (run priv-mod '(read) #t)
+    (run priv-mod '(read write delete) #f)))
+
+(test-case "private security-guard"
+  (parameterize ((current-security-guard sg-priv))
+    (run pub-mod '(read) #t)
+    (run pub-mod '(write) #t)
+    (run priv-mod '(read) #f)
+    (run priv-mod '(read write delete) #f)))
+
+(provide (all-defined-out))
+|#

collects/scribblings/foreign/derived.scrbl

@@ -13,3 +13,4 @@
 @include-section["atomic.scrbl"]
 @include-section["try-atomic.scrbl"]
 @include-section["objc.scrbl"]
+@include-section["security.scrbl"]

collects/scribblings/foreign/security.scrbl

@@ -0,0 +1,42 @@
+#lang scribble/doc
+@(require "utils.ss"
+          (for-label ffi/unsafe/security))
+
+@title[#:tag "security-guard-checks"]{Security-Guard Checks}
+
+@defmodule[ffi/unsafe/security]
+
+@defproc[(security-guard-check-file
+           [who symbol?]
+           [path path-string?]
+           [perms (listof (or/c 'read 'write 'execute 'delete 'exists))])
+         void?]{
+
+Checks whether @racket[(current-security-guard)] permits access to the
+file specified by @racket[path] with the permissions
+@racket[perms]. See @racket[make-security-guard] for more information
+on @racket[perms].
+
+The symbol @racket[who] should be the name of the function on whose
+behalf the security check is performed; it is passed to the security
+guard to use in access-denied errors.
+}
+
+@defproc[(_file/guard [perms (listof (or/c 'read 'write 'execute 'delete 'exists))]
+                      [who symbol? '_file/guard])
+         ctype?]{
+
+Like @racket[_file] and @racket[_path], but conversion from Racket to
+C first completes the path using @racket[path->complete-path] then
+cleanses it using @racket[cleanse-path], then checks that the current
+security guard grants access on the resulting complete path with
+@racket[perms]. As an output value, identical to @racket[_path].
+}
+
+@deftogether[[
+@defthing[_file/r ctype?]
+@defthing[_file/rw ctype?]]]{
+
+Equivalent to @racket[(_file/guard '(read))] and @racket[(_file/guard
+'(read write))], respectively.
+}