use assertions for path validation

palps.rkt

@@ -1,75 +1,217 @@
 #! /usr/bin/env /usr/local/bin/racket
 #lang racket
 
-;; get callsign, first thing passed by BPQ
-(define call (read-line (current-input-port) 'any))
+;; default directory used for storing dynamic application data
+(define data-dir
+  (build-path (find-system-path 'home-dir)
+              (build-path ".local" "share" "palps")))
 
-;; drop SSID
-(set! call (first (string-split call "-")))
+;; directory of the current user of the program
+(define call-dir (make-parameter (string->path "/nobody")))
 
-;; downcase callsign
-(set! call (string-downcase call))
+(struct exn:assert exn ()
+  #:extra-constructor-name make-exn:assert
+  #:transparent)
 
-;; if the sysadmin has created a directory for that callsign, then
-;; they are an authorized user.
-(when (not (directory-exists? call))
-  (displayln "sorry, but you are not an authorized user of the PALPS system")
-  (displayln "visit https://gitea.farpn.net/w6vvn/palps for an explanation")
-  (flush-output)
-  (exit))
+;; 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)
 
-;; change to the authroized users directory
-(current-directory call)
+;; 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))))
 
-(printf "welcome ~a. now starting (r)ed, the standard text editor~n" call)
-(flush-output)
+;; 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)
+   (andmap
+    (or/c char-numeric? char-alphabetic? (curry char=? #\-))
+    (string->list call))))
+
+(define (our-make-temporary-file [copy-from #f])
+  ;; when deployed as a systemd socket, this program is expected to be
+  ;; ran with PrivateTmp. however, in case this is not true, we still
+  ;; make our own directory. "red", the restricted version of "ed",
+  ;; has no facility for getting outside of the directory we start it
+  ;; in.
+  (make-temporary-file "red.~a"
+                       #:copy-from copy-from
+                       #:base-dir (make-temporary-directory)))
 
 ;; unfortunately, we cannot just exec red and let it take over the
 ;; I/O. ed, being the standard text editor, only works with standard
 ;; line endings, \n. telnet and BPQ, however, use \r\n. \r\n upsets
 ;; ed, the standard text editor.  so we need to wrap the input and
 ;; output ports ourselves in order to provide this translation.
+(define (ed [path (our-make-temporary-file)])
+  (match-define
+    (list stdout stdin pid stderr proc)
+    (parameterize ([current-directory (path-only path)])
+      (process* "/usr/bin/red"
+                "-p*"
+                (path->string (file-name-from-path path))
+                #:set-pwd? #t)))
 
-(match-define
-  (list stdout stdin pid stderr proc)
-  (process* "/usr/bin/red"
-            "-p*"
-            #:set-pwd? #t))
+  (define buffer (make-bytes 128))
 
-(define buffer (make-bytes 128))
+  (define (loop)
+    (let ([evt-result
+           (sync
+            (choice-evt (read-bytes-avail!-evt buffer stdout)
+                        (read-line-evt (current-input-port) 'any)))])
 
-(define (loop)
-  (let ([evt-result
-         (sync
-          (choice-evt (read-bytes-avail!-evt buffer stdout)
-                      (read-line-evt (current-input-port) 'any)))])
+      (cond
+        ;; read-line-evt results in a string. we have something to write
+        ;; on stdin.
+        [(string? evt-result)
+         (displayln evt-result stdin)
+         (flush-output stdin)
+         (loop)]
 
-    (cond
-      ;; read-line-evt results in a string. we have something to write
-      ;; on stdin.
-      [(string? evt-result)
-       (displayln evt-result stdin)
-       (flush-output stdin)
-       (loop)]
+        ;; read-bytes-avail!-evt results in an integer. we have
+        ;; something to read from stdout.
+        [(integer? evt-result)
+         (display (bytes->string/utf-8 (subbytes buffer 0 evt-result)))
+         (flush-output)
+         (loop)]
 
-      ;; read-bytes-avail!-evt results in an integer. we have
-      ;; something to read from stdout.
-      [(integer? evt-result)
-       (display (bytes->string/utf-8 (subbytes buffer 0 evt-result)))
+        ;; either event may EOF, which means that ed has died.
+        [(eof-object? evt-result)
+
+         ;; clean up
+         (close-output-port stdin)
+         (close-input-port stdout)
+         (close-input-port stderr)
+         (proc 'kill)
+
+         path])))
+  (loop))
+
+;; "main" procedure to be executed in an interactive context i.e. for
+;; BPQ
+(define (session-startup)
+  (define call (string-downcase (read-line (current-input-port) 'any)))
+
+  ;; something is seriously aswiss.
+  (when (not (call-valid? call))
+    (raise-user-error 'palps-session "invalid callsign"))
+
+  ;; drop SSID, if there is one.
+  (set! call (first (string-split call "-")))
+
+  (parameterize ([call-dir (build-path data-dir call)])
+    ;; at the moment, "being authorized" just means that the sysadmin
+    ;; has granted a directory for that callsign.
+    (when (not (directory-exists? (call-dir)))
+      (displayln "sorry, but you are not an authorized user of the PALPS system")
+      (displayln "visit https://gitea.farpn.net/w6vvn/palps for an explanation")
+      (flush-output)
+
+      (raise-user-error 'palps-session "unauthorized user"))
+
+    (parameterize ([current-directory (call-dir)])
+      (session))))
+
+(define (session)
+  (with-handlers
+    ([exn:assert?
+      (λ (exn)
+        (displayln (exn-message exn)))])
+
+    (display "palps > ")
+    (flush-output)
+
+    (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))]
+
+      [(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)]
+
+      [(or (list _ "bye" _)
+           (list _ "b" _)
+           (list _ "quit" _)
+           (list _ "q" _))
+       (displayln "goodbye")
        (flush-output)
-       (loop)]
+       (exit)]
 
-      ;; either event may EOF, which means that ed has died.
-      [(eof-object? evt-result)
-       ;; clean up
-       (close-output-port stdin)
-       (close-input-port stdout)
-       (close-input-port stderr)
-       (proc 'kill)])))
+      [else
+       (displayln "no such command")
+       (flush-output)]))
 
-(loop)
+  (session))
 
-(displayln "goodbye")
-(flush-output)
-
-(exit)
+;(session-startup)