From 1886e4e52fbb590e5296c0f74adffec1ff1f2962 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Mon, 18 Nov 2019 00:49:37 +0200 Subject: [PATCH] Commit 0.1 versions published to snow-fort.org --- dockerfile-test.scm | 16 ++++++ dockerfile.scm | 124 +++++++++++++++++++++++++++++++++++++++++++ dockerfile.sld | 11 ++++ shell-quote-test.scm | 19 +++++++ shell-quote.scm | 103 +++++++++++++++++++++++++++++++++++ shell-quote.sld | 12 +++++ unpack-assoc.scm | 123 ++++++++++++++++++++++++++++++++++++++++++ unpack-assoc.sld | 20 +++++++ 8 files changed, 428 insertions(+) create mode 100644 dockerfile-test.scm create mode 100644 dockerfile.scm create mode 100644 dockerfile.sld create mode 100644 shell-quote-test.scm create mode 100644 shell-quote.scm create mode 100644 shell-quote.sld create mode 100644 unpack-assoc.scm create mode 100644 unpack-assoc.sld diff --git a/dockerfile-test.scm b/dockerfile-test.scm new file mode 100644 index 0000000..466c292 --- /dev/null +++ b/dockerfile-test.scm @@ -0,0 +1,16 @@ +;; Copyright 2019 Lassi Kortela +;; SPDX-License-Identifier: ISC + +(import (scheme base) (scheme write) (dockerfile)) + +(display + (quote-dockerfile + '((from (image "debian") (as "build")) + (copy (dst "bar") (src "foo") (from "build")) + (entrypoint (exec "executable" "arg1" "arg2")) + (entrypoint (shell (cmd "executable"))) + (run (shell (and (cmd "apt-get" "update") + (cmd "apt-get" "-y" "--no-install-recommends" + "install" "build-essential") + (cmd "rm" "-rf" (arg "/var/lib/apt/lists/" + (verbatim "*"))))))))) diff --git a/dockerfile.scm b/dockerfile.scm new file mode 100644 index 0000000..62d0fb3 --- /dev/null +++ b/dockerfile.scm @@ -0,0 +1,124 @@ +;; Emacs: this is -*- Scheme -*- code, not a Dockerfile. + +;; Copyright 2019 Lassi Kortela +;; SPDX-License-Identifier: ISC + +(define-syntax only-when + (syntax-rules () + ((_ condition body ...) + (if condition (begin body ...) #f)))) + +(define (delimit delimiter strings) + (if (null? strings) "" + (let loop ((strings (cdr strings)) (acc (car strings))) + (if (null? strings) acc + (loop (cdr strings) + (string-append acc delimiter (car strings))))))) + +(define (stringify s) + (cond ((string? s) s) + ((number? s) (number->string s)) + (else (error "Don't know how to stringify that")))) + +(define (tight . ss) (delimit "" (map stringify ss))) + +(define (words . ss) (delimit " " (delete #f ss))) + +(define (name=value name value) + (string-append name "=" value)) + +(define (string-list->json strings) + (call-with-port (open-output-string) + (lambda (out) + (parameterize ((current-output-port out)) + (write-char #\[) + (unless (null? strings) + (write (car strings)) + (for-each (lambda (s) (write-string ", ") (write s)) + (cdr strings))) + (write-char #\])) + (get-output-string out)))) + +(define (quote-string-with-vars s) + s) + +(define string-or-glob? string?) +(define string-with-vars string?) +(define name? string?) +(define shellcmd list?) +(define (any? x) #t) +(define (nat x) (and (integer? x) (exact? x) (>= x 0))) + +;; + +(define (quote-dockerfile-instruction instruction) + (unpack-case instruction + ((blank-line) + "") + ((comment (text string?)) + ;; TODO: Multi-line string should produce multi-line comment. + (string-append "# " text)) + ((from (image name?) (as name? ?)) + (words "FROM" image (only-when as (words "AS" as)))) + ((run (shell shellcmd ?) (exec string? *)) + (exactly-one-of shell exec) + (words "RUN" (cond (shell (shell-quote shell)) + (exec (string-list->json exec))))) + ((cmd (shell shellcmd ?) (exec string? *)) + (exactly-one-of shell exec) + (words "CMD" (cond (shell (shell-quote shell)) + (exec (string-list->json exec))))) + ((label (name string?) (value string?)) + (words "LABEL" (name=value name value))) + ((expose (port nat) (protocol string? ?)) + (words "EXPOSE" (if protocol (tight port "/" protocol) port))) + ((env (name string?) (value string?)) + (words "ENV" (name=value name value))) + ((add (user name? ?) (group name? ?) (dst string?) (src string-or-glob? +)) + (words "ADD" + (only-when (or user group) (tight "--chown=" user ":" group)) + (string-list->json (append src (list dst))))) + ((copy (from string? ?) (user string? ?) (group string? ?) + (dst string?) (src string-or-glob? +)) + (words "COPY" + (only-when from (tight "--from=" from)) + (only-when (or user group) (tight "--chown=" user ":" group)) + (string-list->json (append src (list dst))))) + ((entrypoint (shell shellcmd ?) (exec string? *)) + (exactly-one-of shell exec) + (words "ENTRYPOINT" (cond (shell (shell-quote shell)) + (exec (string-list->json exec))))) + ((volume (mountpoint string?)) + (words "VOLUME" (string-list->json (list mountpoint)))) + ((user (user string? ?) (group string? ?) (uid nat ?) (gid nat ?)) + (exactly-one-of uid user) + (at-most-one-of gid group) + (at-most-one-of uid group) + (at-most-one-of gid user) + (words "USER" (tight (or user uid) + (only-when (or group gid) + (tight ":" (or group gid)))))) + ((workdir (path string-with-vars)) + (words "WORKDIR" (quote-string-with-vars path))) + ((arg (name string?) (value string?)) + (words "ARG" (name=value name value))) + ((stopsignal (signal name?)) + (words "STOPSIGNAL" signal)) + ((healthcheck (shell shellcmd ?) (exec string? *) (none any? *) #;option*) + #;(at-most-one-of none option*) + (exactly-one-of shell exec none) + (words "HEALTHCHECK" + (cond (shell (words "CMD" (shell-quote shell))) + (exec (words "CMD" (string-list->json exec))) + (none "NONE")))) + (else (error "Unknown Dockerfile instruction" instruction)))) + +(define (quote-dockerfile instructions) + (call-with-port + (open-output-string) + (lambda (out) + (for-each (lambda (x) + (write-string (quote-dockerfile-instruction x) out) + (newline out)) + instructions) + (get-output-string out)))) diff --git a/dockerfile.sld b/dockerfile.sld new file mode 100644 index 0000000..dec838d --- /dev/null +++ b/dockerfile.sld @@ -0,0 +1,11 @@ +;; Emacs: this is -*- Scheme -*- code, not a Dockerfile. + +;; Copyright 2019 Lassi Kortela +;; SPDX-License-Identifier: ISC + +(define-library (dockerfile) + (export quote-dockerfile-instruction + quote-dockerfile) + (import (scheme base) (scheme write) (srfi 1) + (chibi match) (unpack-assoc) (shell-quote)) + (include "dockerfile.scm")) diff --git a/shell-quote-test.scm b/shell-quote-test.scm new file mode 100644 index 0000000..567f38d --- /dev/null +++ b/shell-quote-test.scm @@ -0,0 +1,19 @@ +;; Copyright 2019 Lassi Kortela +;; SPDX-License-Identifier: ISC + +(import (scheme base) (scheme write) (shell-quote)) + +(define (q x) + (display (shell-quote x)) + (newline)) + +(q '(pipe (cmd "date" "+%Y/%m/%d") + (cmd "tr" "/" "X"))) + +(q '(and (cmd "test" "-e" "/etc/rc") + (cmd "test" "-l" "/etc/localtime"))) + +(q '(begin (cmd "echo" "hello world"))) + +(q '(redirect (cmd "echo" "hello world") + (out 2 "/dev/null"))) diff --git a/shell-quote.scm b/shell-quote.scm new file mode 100644 index 0000000..5117285 --- /dev/null +++ b/shell-quote.scm @@ -0,0 +1,103 @@ +;; Copyright 2019 Lassi Kortela +;; SPDX-License-Identifier: ISC + +(define (delimit delimiter strings) + (if (null? strings) "" + (let loop ((strings (cdr strings)) (acc (car strings))) + (if (null? strings) acc + (loop (cdr strings) + (string-append acc delimiter (car strings))))))) + +(define (error* . strings) (error (delimit " " strings))) + +(define (natural? x) (and (integer? x) (exact? x) (>= x 0))) + +(define (the-natural x what) + (if (natural? x) (number->string x) (error* what "must be an integer"))) + +(define (the-string x what) + (if (string? x) x (error* what "must be a string"))) + +(define (the-natural-or-string x what) + (cond ((string? x) x) + ((natural? x) (number->string x)) + (else (error* what "must be an integer or string")))) + +(define (bare-char? char) + (case char ((#\- #\. #\/ #\_) #t) (else (ascii-alphanumeric? char)))) + +(define (bare-argument? string) + (and (not (string=? "" string)) + (call-with-port (open-input-string string) + (lambda (in) + (let loop () + (let ((char (read-char in))) + (or (eof-object? char) + (and (bare-char? char) (loop))))))))) + +(define (quote-string string) + (if (bare-argument? string) string + (call-with-port + (open-input-string string) + (lambda (in) + (call-with-port + (open-output-string) + (lambda (out) + (write-char #\" out) + (let loop () + (let ((char (read-char in))) + (unless (eof-object? char) + (case char ((#\$ #\` #\" #\\) (write-char #\\ out))) + (write-char char out) + (loop)))) + (write-char #\" out) + (get-output-string out))))))) + +(define (quote-arg arg) + (cond ((string? arg) (quote-string arg)) + ((and (pair? arg) (eq? 'arg (car arg))) + (let loop ((parts (cdr arg)) (acc "")) + (if (null? parts) acc + (let ((part (car parts))) + (cond ((and (pair? part) (eq? 'verbatim (car part))) + (unless (= 2 (length part)) + (error "Bad (verbatim ...) argument")) + (loop (cdr parts) (string-append acc (cadr part)))) + (else + (loop (cdr parts) (string-append acc part)))))))) + (else (error "command line argument not a string or glob" arg)))) + +(define (redir1 operator path) + (string-append operator (quote-string (the-string path "redirect path")))) + +(define (redir2 operator fd path-or-fd) + (string-append + (the-natural fd "file descriptor") + operator + (the-natural-or-string path-or-fd "redirect path or file descriptor"))) + +(define (cmdgroup group) + (match group + (('redirect group . fd-map) + (let loop ((fd-map fd-map) (acc (cmdgroup group))) + (if (null? fd-map) acc + (loop (cdr fd-map) + (string-append + acc " " + (match (car fd-map) + (('in path) (redir1 "<" path)) + (('in fd from) (redir2 "<" fd from)) + (('out path) (redir1 ">" path)) + (('out fd to) (redir2 ">" fd to)) + (('append path) (redir1 ">>" path)) + (('append fd to) (redir2 ">>" fd to)))))))) + (('subshell group) (string-append "(" (cmdgroup group) ")")) + (('begin . groups) + (string-append "{ " (delimit "; " (append (map cmdgroup groups) + '("}"))))) + (('and . groups) (delimit " && " (map cmdgroup groups))) + (('or . groups) (delimit " || " (map cmdgroup groups))) + (('pipe . groups) (delimit " | " (map cmdgroup groups))) + (('cmd c . args) (delimit " " (map quote-arg (cons c args)))))) + +(define shell-quote cmdgroup) diff --git a/shell-quote.sld b/shell-quote.sld new file mode 100644 index 0000000..59f0aaf --- /dev/null +++ b/shell-quote.sld @@ -0,0 +1,12 @@ +;; Copyright 2019 Lassi Kortela +;; SPDX-License-Identifier: ISC + +(define-library (shell-quote) + (export shell-quote) + (import (scheme base) (scheme write) (chibi match)) + (cond-expand + ((library (srfi 175)) (import (srfi 175))) + (else (import (scheme char)) + (begin (define (ascii-alphanumeric? char) + (or (char-alphabetic? char) (char-numeric? char)))))) + (include "shell-quote.scm")) diff --git a/unpack-assoc.scm b/unpack-assoc.scm new file mode 100644 index 0000000..3ba7cc3 --- /dev/null +++ b/unpack-assoc.scm @@ -0,0 +1,123 @@ +;; Copyright 2019 Lassi Kortela +;; SPDX-License-Identifier: ISC + +(define (unpack-using/many need? type key entry) + (if (not entry) + (and need? (error "Required key missing" key)) + (let check ((tail (cdr entry))) + (cond ((null? tail) + (cdr entry)) + ((not (pair? tail)) + (error "Values do not form a proper list" key (cdr entry))) + ((not (type (car tail))) + (error "Key has value of the wrong type" key (car tail))) + (else (check (cdr tail))))))) + +(define (unpack-using/one need? type key entry) + (cond ((not entry) + (and need? (error "Required key missing" key))) + ((not (pair? (cdr entry))) + (error "Key is present but has no value" key)) + ((not (null? (cddr entry))) + (error "Key has more than one value" key (cdr entry))) + ((not (type (cadr entry))) + (error "Key has value of the wrong type" key (cadr entry))) + (else (cadr entry)))) + +(define-syntax unpack-using/let + (syntax-rules () + ((_ (lets ...) () body ...) + (let (lets ...) body ...)) + ((_ (lets ...) ((key more-stuff ...) more-rules ...) body ...) + (unpack-using/let (lets ... (key #f)) (more-rules ...) body ...)))) + +(define-syntax unpack-using/case + (syntax-rules () + ((_ (cases ...) this-key val) + (case this-key + cases ... + (else (error "Unknown key" this-key)))) + ((_ (cases ...) this-key val (key more-stuff ...) more-rules ...) + (unpack-using/case (cases ... ((key) + (when key (error "Duplicate key" 'key)) + (set! key (cons 'key val)))) + this-key val more-rules ...)))) + +(define-syntax unpack-using/rule + (syntax-rules (* + ?) + ((_ (key type *)) (set! key (unpack-using/many #f type 'key key))) + ((_ (key type +)) (set! key (unpack-using/many #t type 'key key))) + ((_ (key type ?)) (set! key (unpack-using/one #f type 'key key))) + ((_ (key type)) (set! key (unpack-using/one #t type 'key key))))) + +(define-syntax unpack-using/set + (syntax-rules () + ((_ (sets ...)) + (begin sets ...)) + ((_ (sets ...) rule rules ...) + (unpack-using/set (sets ... (unpack-using/rule rule)) rules ...)))) + +(define-syntax unpack-using + (syntax-rules (key val) + ((_ for-each-pair pairs (rules ...) body ...) + (unpack-using/let () (rules ...) + (for-each-pair + (lambda (key val) (unpack-using/case () key val rules ...)) + pairs) + (unpack-using/set () rules ...) + body ...)))) + +;; + +(define (alist-for-each proc alist) + (cond ((null? alist) #f) + ((not (pair? alist)) (error "Not a proper list" alist)) + ((not (pair? (car alist))) (error "Alist entry is not a pair" alist)) + (else (proc (caar alist) (cdar alist)) + (alist-for-each proc (cdr alist))))) + +(define-syntax unpack + (syntax-rules () + ((_ alist (rules ...) body ...) + (unpack-using alist-for-each alist (rules ...) body ...)))) + +(define-syntax unpack-case/aux + (syntax-rules () + ((_ (cases ...) entry) + (case (car entry) cases ...)) + ((_ (cases ...) entry (else body ...)) + (unpack-case/aux + (cases ... (else body ...)) + entry)) + ((_ (cases ...) entry ((head rules ...) body ...)) + (unpack-case/aux + (cases ... ((head) (unpack (cdr entry) (rules ...) body ...))) + entry)) + ((_ (cases ...) entry ((head rules ...) body ...) more-cases ...) + (unpack-case/aux + (cases ... ((head) (unpack (cdr entry) (rules ...) body ...))) + entry more-cases ...)))) + +(define-syntax unpack-case + (syntax-rules (entry) + ((_ entry-expr cases ...) + (let ((entry entry-expr)) + (unpack-case/aux () entry cases ...))))) + +;; + +(define (count-truthy . lis) + (let loop ((lis lis) (n 0)) + (if (null? lis) n (loop (cdr lis) (if (car lis) (+ n 1) n))))) + +(define-syntax at-most-one-of + (syntax-rules () + ((_ identifiers ...) + (unless (<= (count-truthy identifiers ...) 1) + (error "At most one of these must be given" '(identifiers ...)))))) + +(define-syntax exactly-one-of + (syntax-rules () + ((_ identifiers ...) + (unless (= (count-truthy identifiers ...) 1) + (error "Exactly one of these must be given" '(identifiers ...)))))) diff --git a/unpack-assoc.sld b/unpack-assoc.sld new file mode 100644 index 0000000..db312f3 --- /dev/null +++ b/unpack-assoc.sld @@ -0,0 +1,20 @@ +;; Copyright 2019 Lassi Kortela +;; SPDX-License-Identifier: ISC + +(define-library (unpack-assoc) + (export unpack + unpack-case + unpack-using + at-most-one-of + exactly-one-of + + unpack-using/many + unpack-using/one + unpack-using/let + unpack-using/case + unpack-using/rule + unpack-using/set + + unpack-case/aux) + (import (scheme base)) + (include "unpack-assoc.scm"))