all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
blob 0f6c3bf90627b2ab57309550c4a971b1bf8126bd 4239 bytes (raw)
name: guix/docker.scm 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
 
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix docker)
  #:use-module (guix hash)
  #:use-module (guix store)
  #:use-module ((guix build utils)
                #:select (delete-file-recursively
                          with-directory-excursion))
  #:use-module (json)
  #:use-module (rnrs bytevectors)
  #:export (build-docker-image))

(define (hexencode bv)
  "Return the hexadecimal representation of the bytevector BV."
  (format #f "~{~2,'0x~}" (bytevector->u8-list bv)))

(define (docker-id path)
  "Generate a 256-bit identifier in hexadecimal encoding for the Docker image
containing the closure at PATH."
  (hexencode (sha256 (string->utf8 path))))

(define (layer-diff-id layer)
  "Generate a layer DiffID for the given LAYER archive."
  (string-append "sha256:" (hexencode (file-sha256 layer))))

(define spec-version "1.0")

(define (image-description id time)
  "Generate a simple image description."
  `((id . ,id)
    (created . ,time)
    (container_config . #nil)))

(define (manifest id)
  "Generate a simple image manifest."
  `(((Config . "config.json")
     (RepoTags . #nil)
     (Layers . (,(string-append id "/layer.tar"))))))

(define (repositories path id)
  "Generate a repositories file referencing PATH and the image ID."
  `((,(basename path) . ((latest . ,id)))))

;; See https://github.com/opencontainers/image-spec/blob/master/config.md
(define (config layer time)
  "Generate a minimal image configuratio for the given LAYER file."
  `((architecture . "amd64")
    (comment . "Generated by GNU Guix")
    (created . ,time)
    (config . #nil)
    (container_config . #nil)
    (os . "linux")
    (rootfs . ((type . "layers")
               (diff_ids . (,(layer-diff-id layer)))))))

;; TODO: heroically copied from guix/script/pull.scm
(define (temporary-directory)
  "Make a temporary directory and return its name."
  (let ((name (tmpnam)))
    (mkdir name)
    (chmod name #o700)
    name))

(define (build-docker-image path)
  "Generate a Docker image archive from the given store PATH.  The image
contains the closure of the given store item."
  (let ((id (docker-id path))
        (directory (temporary-directory))
        (time (strftime "%FT%TZ" (localtime (current-time)))))
    (with-directory-excursion directory

      ;; Add symlink from /bin to /gnu/store/.../bin
      (symlink (string-append path "/bin") "bin")

      (mkdir id)
      (with-directory-excursion id
        (with-output-to-file "VERSION"
          (lambda () (display spec-version)))
        (with-output-to-file "json"
          (lambda () (scm->json (image-description id time))))

        ;; Wrap it up
        (let ((items (with-store store
                       (requisites store (list path)))))
          (and (zero? (apply system* "tar" "-cf" "layer.tar"
                             (cons "../bin" items)))
               (delete-file "../bin"))))

      (with-output-to-file "config.json"
        (lambda ()
          (scm->json (config (string-append id "/layer.tar") time))))

      (with-output-to-file "manifest.json"
        (lambda ()
          (scm->json (manifest id))))
      (with-output-to-file "repositories"
        (lambda ()
          (scm->json (repositories path id)))))

    (let ((name (string-append (getcwd)
                               "/docker-image-" (basename path) ".tar")))
      (and (zero? (system* "tar" "-C" directory "-cf" name "."))
           (delete-file-recursively directory)
           name))))

debug log:

solving 0f6c3bf90 ...
found 0f6c3bf90 in https://yhetil.org/guix/idj4m1gw41i.fsf@bimsb-sys02.mdc-berlin.net/

applying [1/1] https://yhetil.org/guix/idj4m1gw41i.fsf@bimsb-sys02.mdc-berlin.net/
diff --git a/guix/docker.scm b/guix/docker.scm
new file mode 100644
index 000000000..0f6c3bf90

Checking patch guix/docker.scm...
Applied patch guix/docker.scm cleanly.

index at:
100644 0f6c3bf90627b2ab57309550c4a971b1bf8126bd	guix/docker.scm

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.