Commit 0.1 versions published to snow-fort.org
This commit is contained in:
parent
978ea23728
commit
1886e4e52f
|
|
@ -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 "*")))))))))
|
||||
|
|
@ -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))))
|
||||
|
|
@ -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"))
|
||||
|
|
@ -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")))
|
||||
|
|
@ -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)
|
||||
|
|
@ -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"))
|
||||
|
|
@ -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 ...))))))
|
||||
|
|
@ -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"))
|
||||
Loading…
Reference in New Issue