Compare commits
1 Commits
df188a31f6
...
master
| Author | SHA1 | Date | |
|---|---|---|---|
| fe2109e5ef |
59
palps.rkt
59
palps.rkt
@@ -9,10 +9,14 @@
|
|||||||
;; directory of the current user of the program
|
;; directory of the current user of the program
|
||||||
(define call-dir (make-parameter (string->path "/nobody")))
|
(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
|
;; raised by assert-confined-to-call-dir when attemping to traverse
|
||||||
;; outside of (call-dir)
|
;; outside of (call-dir)
|
||||||
(struct exn:fail:contract:illegal-path exn:fail:contract ()
|
(struct exn:assert:illegal-path exn:assert ()
|
||||||
#:extra-constructor-name make-exn:fail:contract:illegal-path
|
#:extra-constructor-name make-exn:assert:illegal-path
|
||||||
#:transparent)
|
#:transparent)
|
||||||
|
|
||||||
;; check if path, once resolved, is a child of base
|
;; check if path, once resolved, is a child of base
|
||||||
@@ -24,9 +28,50 @@
|
|||||||
;; asserts that path is within (call-dir), and raises
|
;; asserts that path is within (call-dir), and raises
|
||||||
;; exn:fail:contract:illegal-path otherwise.
|
;; exn:fail:contract:illegal-path otherwise.
|
||||||
(define (assert-confined-to-call-dir path)
|
(define (assert-confined-to-call-dir path)
|
||||||
|
(when (string? path)
|
||||||
|
(set! path (string->path path)))
|
||||||
|
|
||||||
(when (not (confined-path? (call-dir) path))
|
(when (not (confined-path? (call-dir) path))
|
||||||
(raise (make-exn:fail:contract:illegal-path
|
(raise (make-exn:assert:illegal-path
|
||||||
"assert-confined-to-call-dir: traversed outside of root"
|
(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)))))
|
(current-continuation-marks)))))
|
||||||
|
|
||||||
(define (call-valid? call)
|
(define (call-valid? call)
|
||||||
@@ -122,9 +167,9 @@
|
|||||||
|
|
||||||
(define (session)
|
(define (session)
|
||||||
(with-handlers
|
(with-handlers
|
||||||
([exn:fail:contract:illegal-path?
|
([exn:assert?
|
||||||
(λ (exn)
|
(λ (exn)
|
||||||
(displayln "cannot traverse higher than root"))])
|
(displayln (exn-message exn)))])
|
||||||
|
|
||||||
(display "palps > ")
|
(display "palps > ")
|
||||||
(flush-output)
|
(flush-output)
|
||||||
@@ -138,6 +183,7 @@
|
|||||||
|
|
||||||
[(list _ "ed" name)
|
[(list _ "ed" name)
|
||||||
(assert-confined-to-call-dir name)
|
(assert-confined-to-call-dir name)
|
||||||
|
(assert-directory-exists name)
|
||||||
|
|
||||||
(let ([path (if (file-exists? name)
|
(let ([path (if (file-exists? name)
|
||||||
(ed (our-make-temporary-file name))
|
(ed (our-make-temporary-file name))
|
||||||
@@ -146,6 +192,7 @@
|
|||||||
|
|
||||||
[(list _ "rm" name)
|
[(list _ "rm" name)
|
||||||
(assert-confined-to-call-dir name)
|
(assert-confined-to-call-dir name)
|
||||||
|
(assert-file-exists name)
|
||||||
|
|
||||||
(if (file-exists? name)
|
(if (file-exists? name)
|
||||||
(delete-file name)
|
(delete-file name)
|
||||||
|
|||||||
Reference in New Issue
Block a user