132 lines
4.1 KiB
Racket
Executable File
132 lines
4.1 KiB
Racket
Executable File
#! /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")))
|
|
|
|
(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)
|
|
(display "palps > ")
|
|
(flush-output)
|
|
|
|
(match (regexp-match #px"(\\w+)\\s*(.*)"
|
|
(read-line (current-input-port) 'any))
|
|
[(list _ "ls" url)
|
|
(for-each (λ (p) (displayln (path->string p)))
|
|
(directory-list))]
|
|
|
|
[(list _ "ed" name)
|
|
(let ([path (if (file-exists? name)
|
|
(ed (our-make-temporary-file name))
|
|
(ed))])
|
|
(copy-file path name #:exists-ok? #t))]
|
|
|
|
[(or (list _ "bye" _)
|
|
(list _ "b" _)
|
|
(list _ "quit" _)
|
|
(list _ "q" _))
|
|
(displayln "goodbye")
|
|
(exit)]
|
|
|
|
[else
|
|
(displayln "no such command")])
|
|
|
|
(session))
|
|
|
|
(session-startup)
|