assertion for path validation

palps.rkt

@@ -9,71 +9,6 @@
 ;; directory of the current user of the program
 (define call-dir (make-parameter (string->path "/nobody")))
 
-(struct exn:assert exn ()
-  #:extra-constructor-name make-exn:assert
-  #:transparent)
-
-;; raised by assert-confined-to-call-dir when attemping to traverse
-;; outside of (call-dir)
-(struct exn:assert:illegal-path exn:assert ()
-  #:extra-constructor-name make-exn:assert:illegal-path
-  #:transparent)
-
-;; check if path, once resolved, is a child of base
-(define (confined-path? base path)
-  (string-prefix?
-   (path->string (simplify-path (build-path base path)))
-   (path->string (simplify-path base))))
-
-;; asserts that path is within (call-dir), and raises
-;; exn:fail:contract:illegal-path otherwise.
-(define (assert-confined-to-call-dir path)
-  (when (string? path)
-    (set! path (string->path path)))
-
-  (when (not (confined-path? (call-dir) path))
-    (raise (make-exn:assert:illegal-path
-            (format (string-append "assert-confined-to-call-dir: traversed outside of root~n"
-                                   "  path: ~a")
-                    (path->string path))
-            (current-continuation-marks)))))
-
-(struct exn:assert:no-such-directory exn:assert ()
-  #:extra-constructor-name make-exn:assert:no-such-directory
-  #:transparent)
-
-(define (assert-directory-exists path)
-  (when (string? path)
-    (set! path (string->path path)))
-
-  ;; path-only returns #f when path is a single element. this is taken
-  ;; to mean that path is in the root (current-directory), which
-  ;; necessarily exists. this is structured to short circuit such that
-  ;; (directory-exists? #f) is never called (which would raise an
-  ;; exception).
-  (when (not (or (not (path-only path))
-                 (directory-exists? (path-only path))))
-    (raise (make-exn:assert:no-such-directory
-            (format (string-append "assert-directory-exists: directory does not exist~n"
-                                   "  path: ~a")
-                    (path->string (find-relative-path (call-dir) path)))
-            (current-continuation-marks)))))
-
-(struct exn:assert:no-such-file exn:assert ()
-  #:extra-constructor-name make-exn:assert:no-such-file
-  #:transparent)
-
-(define (assert-file-exists path)
-  (when (string? path)
-    (set! path (string->path path)))
-
-  (when (not (file-exists? path))
-    (raise (make-exn:assert:no-such-file
-            (format (string-append "assert-file-exists: file does not exist~n"
-                                   "  path: ~a")
-                    (path->string (find-relative-path (call-dir) path)))
-            (current-continuation-marks)))))
-
 (define (call-valid? call)
   (and
    (<= (string-length call) 9)
@@ -140,6 +75,26 @@
          path])))
   (loop))
 
+;; raised by assert-confined-to-call-dir when attemping to traverse
+;; outside of (call-dir)
+(struct exn:fail:contract:illegal-path exn:fail:contract ()
+  #:extra-constructor-name make-exn:fail:contract:illegal-path
+  #:transparent)
+
+;; check if path, once resolved, is a child of base
+(define (confined-path? base path)
+  (string-prefix?
+   (path->string (simplify-path (build-path base path)))
+   (path->string (simplify-path base))))
+
+;; asserts that path is within (call-dir), and raises
+;; exn:fail:contract:illegal-path otherwise.
+(define (assert-confined-to-call-dir path)
+  (when (not (confined-path? (call-dir) path))
+    (raise (make-exn:fail:contract:illegal-path
+            "assert-confined-to-call-dir: traversed outside of root"
+            (current-continuation-marks)))))
+
 ;; "main" procedure to be executed in an interactive context i.e. for
 ;; BPQ
 (define (session-startup)
@@ -166,52 +121,45 @@
       (session))))
 
 (define (session)
-  (with-handlers
+  (display "palps > ")
-    ([exn:assert?
+  (flush-output)
-      (λ (exn)
-        (displayln (exn-message exn)))])
 
-    (display "palps > ")
+  (match (regexp-match #px"(\\w+)\\s*(.*)"
-    (flush-output)
+                       (read-line (current-input-port) 'any))
+    [(list _ "ls" _)
+     (for-each (λ (p) (displayln (path->string p)))
+               (directory-list))
+     (flush-output)]
 
-    (match (regexp-match #px"(\\w+)\\s*(.*)"
+    [(list _ "ed" name)
-                         (read-line (current-input-port) 'any))
+     (let ([path (build-path (current-directory)
-      [(list _ "ls" _)
+                             (string->path-element name))])
-       (for-each (λ (p) (displayln (path->string p)))
+       (let ([path (if (file-exists? path)
-                 (directory-list))
+                       (ed (our-make-temporary-file path))
-       (flush-output)]
-
-      [(list _ "ed" name)
-       (assert-confined-to-call-dir name)
-       (assert-directory-exists name)
-
-       (let ([path (if (file-exists? name)
-                       (ed (our-make-temporary-file name))
                        (ed))])
-         (copy-file path name #:exists-ok? #t))]
+         (copy-file path name #:exists-ok? #t)))]
 
-      [(list _ "rm" name)
+    [(list _ "rm" name)
-       (assert-confined-to-call-dir name)
+     (let ([path (build-path (current-directory)
-       (assert-file-exists name)
+                             (string->path-element name))])
-
+       (if (file-exists? path)
-       (if (file-exists? name)
+           (delete-file path)
-           (delete-file name)
            (displayln "file does not exist"))
 
-       (flush-output)]
+       (flush-output))]
 
-      [(or (list _ "bye" _)
+    [(or (list _ "bye" _)
-           (list _ "b" _)
+         (list _ "b" _)
-           (list _ "quit" _)
+         (list _ "quit" _)
-           (list _ "q" _))
+         (list _ "q" _))
-       (displayln "goodbye")
+     (displayln "goodbye")
-       (flush-output)
+     (flush-output)
-       (exit)]
+     (exit)]
 
-      [else
+    [else
-       (displayln "no such command")
+     (displayln "no such command")
-       (flush-output)]))
+     (flush-output)])
 
   (session))
 
-;(session-startup)
+(session-startup)