palps/palps.rkt

#! /usr/bin/env /usr/local/bin/racket
#lang racket

;; default directory used for storing dynamic application data
(define data-dir
  (build-path (find-system-path 'home-dir)
              (build-path ".local" "share" "palps")))

;; 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)
   (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)))

  (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)))])

      (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)]

        ;; 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)
       (exit)]

      [else
       (displayln "no such command")
       (flush-output)]))

  (session))

;(session-startup)