diff options
| author | EuAndreh <eu@euandre.org> | 2020-11-30 01:06:30 -0300 |
|---|---|---|
| committer | EuAndreh <eu@euandre.org> | 2020-11-30 01:07:31 -0300 |
| commit | 14eaed3f8e8fec161885044d167e28cf1e968ff0 (patch) | |
| tree | 01a0cdf7e0ca70d63dd654440e7940c32bb8da59 /sync/vps.scm | |
| parent | vps.scm: WIP test wrapping code in '(with-imported-modules ...)' (diff) | |
| download | server-14eaed3f8e8fec161885044d167e28cf1e968ff0.tar.gz server-14eaed3f8e8fec161885044d167e28cf1e968ff0.tar.xz | |
vps.scm: Add heredoc reader, '(cmd -> ->>) helpers and refactor code to use them
Diffstat (limited to '')
| -rw-r--r-- | sync/vps.scm | 139 |
1 files changed, 58 insertions, 81 deletions
diff --git a/sync/vps.scm b/sync/vps.scm index 5f9df1e..3f6ca69 100644 --- a/sync/vps.scm +++ b/sync/vps.scm @@ -47,8 +47,6 @@ ;; custom extensions -;; FIXME: with-open-pipe - (define (slurp f) (string-trim-both (call-with-input-file f textual-ports:get-string-all))) @@ -77,75 +75,64 @@ (read-hash-extend #\" hash-double-quote-reader) -;; (defun |#"-reader| (stream sub-char numarg) -;; (declare (ignore sub-char numarg)) -;; (let (chars) -;; (do ((prev (read-char stream) curr) -;; (curr (read-char stream) (read-char stream))) -;; ((and (char= prev #\") (char= curr #\#))) -;; (push prev chars)) -;; (coerce (nreverse chars) 'string))) - -;; (set-dispatch-macro-character -;; #\# #\" #'|#"-reader|) +(define (heredoc-reader _char port) + "Taken almost verbatim from let-over-lambda." + (let ((chars '())) + (do ((curr (read-char port) + (read-char port))) + ((equal? #\newline curr)) + (set! chars (cons curr chars))) + (let* ((pattern (reverse! chars)) + (pointer pattern) + (output '())) + (do ((curr (read-char port) + (when (not (null? pointer)) + (read-char port)))) + ((null? pointer)) + (set! output (cons curr output)) + (set! pointer + (if (equal? (car pointer) curr) + (cdr pointer) + pattern))) + (list->string + (reverse! + (srfi-1:drop output + (length pattern))))))) +(read-hash-extend #\> heredoc-reader) -;; (define (heredoc-reader _char port) -;; "Taken almost verbatim from let-over-lambda." -;; (let ((chars '())) -;; (do ((curr (read-char port) -;; (read-char port))) -;; ((equal? #\newline curr)) -;; (push! curr chars)) -;; (let* ((pattern (reverse! chars)) -;; (pointer pattern) -;; (output '())) -;; (do ((curr (read-char port) -;; (read-char port))) -;; ((null? pointer)) -;; (push! curr output) -;; (set! pointer -;; (if (equal? (car pointer) curr) -;; (cdr pointer) -;; pattern)) -;; ;; (if (null? pointer) -;; ;; (return)) -;; ) -;; (list->string (reverse! output))))) +(define-macro (-> x . sexps) + (srfi-1:fold + (lambda (el acc) + (if (list? el) + (append (list (car el) + acc) + (cdr el)) + (list el acc))) + x + sexps)) -;; (read-hash-extend #\> heredoc-reader) +(define-macro (->> x . sexps) + (srfi-1:fold + (lambda (el acc) + (if (list? el) + (append el (list acc)) + (list el acc))) + x + sexps)) -;; (defun |#>-reader| (stream sub-char numarg) -;; (declare (ignore sub-char numarg)) -;; (let (chars) -;; (do ((curr (read-char stream) -;; (read-char stream))) -;; ((char= #\newline curr)) -;; (push curr chars)) -;; (let* ((pattern (nreverse chars)) -;; (pointer pattern) -;; (output)) -;; (do ((curr (read-char stream) -;; (read-char stream))) -;; ((null pointer)) -;; (push curr output) -;; (setf pointer -;; (if (char= (car pointer) curr) -;; (cdr pointer) -;; pattern)) -;; (if (null pointer) -;; (return))) -;; (coerce -;; (nreverse -;; (nthcdr (length pattern) output)) -;; 'string)))) +(define (cmd . args) + (let* ((port (apply popen:open-pipe* OPEN_READ args)) + (out (string-trim-right (rdelim:read-string port)))) + (popen:close-pipe port) + out)) ;; CI HTML generation -(define ci-html-beginning - #"<!DOCTYPE html> +(define ci-html-beginning #" +<!DOCTYPE html> <html lang="en"> <head> <meta charset="UTF-8" /> @@ -171,25 +158,16 @@ (define (ci-data-in-repo-notes path) (utils:with-directory-excursion path - (let* ((port (popen:open-pipe* OPEN_READ "git" "notes" "list")) - (out (rdelim:read-string port)) - (out-list (string-split (string-fun:string-replace-substring (string-trim-right out) - "\n" - " ") - #\space)) - (relevant-commits (map srfi-1:first - (filter (compose odd? srfi-1:second) - (srfi-1:zip out-list - (iota (length out-list))))))) - (popen:close-pipe port) + (let* ((out-list (-> (cmd "git" "notes" "list") + (string-fun:string-replace-substring "\n" " ") + (string-split #\space))) + (relevant-commits (->> (srfi-1:zip out-list (iota (length out-list))) + (filter (compose odd? srfi-1:second)) + (map srfi-1:first)))) (map (lambda (commit) - (let* ((data-port (popen:open-pipe* OPEN_READ "git" "notes" "--ref=refs/notes/ci-data" "show" commit)) - (logs-port (popen:open-pipe* OPEN_READ "git" "notes" "--ref=refs/notes/ci-logs" "show" commit)) - (data (string-split (string-trim-right (rdelim:read-string data-port)) - #\space)) - (logs (string-trim-right (rdelim:read-string logs-port)))) - (popen:close-pipe data-port) - (popen:close-pipe logs-port) + (let ((data (-> (cmd "git" "notes" "--ref=refs/notes/ci-data" "show" commit) + (string-split #\space))) + (logs (cmd "git" "notes" "--ref=refs/notes/ci-logs" "show" commit))) (list (cons #:status (srfi-1:first data)) (cons #:filename (srfi-1:second data)) (cons #:logs logs)))) @@ -276,7 +254,6 @@ root ALL=(ALL) ALL (string-append letsencrypt-prefix domain "/privkey.pem")) (define opensmtpd-config - ;; FIXME (plain-file "euandreh-smtpd.conf" (string-append " listen on eth0 # File comes from mail-aliases-service-type |