scheme/dockerfile.scm

125 lines
5.3 KiB
Scheme
Raw Permalink Normal View History

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