diff --git a/palps.rkt b/palps.rkt index 879099e..b7d5a4e 100755 --- a/palps.rkt +++ b/palps.rkt @@ -9,6 +9,71 @@ ;; 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) @@ -101,45 +166,52 @@ (session)))) (define (session) - (display "palps > ") - (flush-output) + (with-handlers + ([exn:assert? + (λ (exn) + (displayln (exn-message exn)))]) - (match (regexp-match #px"(\\w+)\\s*(.*)" - (read-line (current-input-port) 'any)) - [(list _ "ls" _) - (for-each (λ (p) (displayln (path->string p))) - (directory-list)) - (flush-output)] + (display "palps > ") + (flush-output) - [(list _ "ed" name) - (let ([path (build-path (current-directory) - (string->path-element name))]) - (let ([path (if (file-exists? path) - (ed (our-make-temporary-file path)) + (match (regexp-match #px"(\\w+)\\s*(.*)" + (read-line (current-input-port) 'any)) + [(list _ "ls" _) + (for-each (λ (p) (displayln (path->string p))) + (directory-list)) + (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) - (let ([path (build-path (current-directory) - (string->path-element name))]) - (if (file-exists? path) - (delete-file path) + [(list _ "rm" name) + (assert-confined-to-call-dir name) + (assert-file-exists name) + + (if (file-exists? name) + (delete-file name) (displayln "file does not exist")) - (flush-output))] + (flush-output)] - [(or (list _ "bye" _) - (list _ "b" _) - (list _ "quit" _) - (list _ "q" _)) - (displayln "goodbye") - (flush-output) - (exit)] + [(or (list _ "bye" _) + (list _ "b" _) + (list _ "quit" _) + (list _ "q" _)) + (displayln "goodbye") + (flush-output) + (exit)] - [else - (displayln "no such command") - (flush-output)]) + [else + (displayln "no such command") + (flush-output)])) (session)) -(session-startup) +;(session-startup)