guix/build/store-copy.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix build store-copy)
  20   #:use-module (guix build utils)
  21   #:use-module (guix sets)
  22   #:use-module (guix progress)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-9)
  25   #:use-module (srfi srfi-26)
  26   #:use-module (ice-9 match)
  27   #:use-module (ice-9 rdelim)
  28   #:use-module (ice-9 ftw)
  29   #:use-module (ice-9 vlist)
  30   #:export (store-info?
  31             store-info
  32             store-info-item
  33             store-info-deriver
  34             store-info-references
  35
  36             read-reference-graph
  37
  38             file-size
  39             closure-size
  40             populate-store))
  41
  42 ;;; Commentary:
  43 ;;;
  44 ;;; This module provides the tools to copy store items and their dependencies
  45 ;;; to another store.  It relies on the availability of "reference graph"
  46 ;;; files as produced by 'gexp->derivation' et al. with the
  47 ;;; #:references-graphs parameter.
  48 ;;;
  49 ;;; Code:
  50
  51 ;; Information about a store item as produced by #:references-graphs.
  52 (define-record-type <store-info>
  53   (store-info item deriver references)
  54   store-info?
  55   (item        store-info-item)                   ;string
  56   (deriver     store-info-deriver)                ;#f | string
  57   (references  store-info-references))            ;?
  58
  59 ;; TODO: Factorize with that in (guix store).
  60 (define (topological-sort nodes edges)
  61   "Return NODES in topological order according to EDGES.  EDGES must be a
  62 one-argument procedure that takes a node and returns the nodes it is connected
  63 to."
  64   (define (traverse)
  65     ;; Do a simple depth-first traversal of all of PATHS.
  66     (let loop ((nodes nodes)
  67                (visited (setq))
  68                (result '()))
  69       (match nodes
  70         ((head tail ...)
  71          (if (set-contains? visited head)
  72              (loop tail visited result)
  73              (call-with-values
  74                  (lambda ()
  75                    (loop (edges head)
  76                          (set-insert head visited)
  77                          result))
  78                (lambda (visited result)
  79                  (loop tail visited (cons head result))))))
  80         (()
  81          (values visited result)))))
  82
  83   (call-with-values traverse
  84     (lambda (_ result)
  85       (reverse result))))
  86
  87 (define (read-reference-graph port)
  88   "Read the reference graph as produced by #:references-graphs from PORT and
  89 return it as a list of <store-info> records in topological order--i.e., leaves
  90 come first.  IOW, store items in the resulting list can be registered in the
  91 order in which they appear.
  92
  93 The reference graph format consists of sequences of lines like this:
  94
  95      FILE
  96      DERIVER
  97      NUMBER-OF-REFERENCES
  98      REF1
  99      ...
 100      REFN
 101
 102 It is meant as an internal format."
 103   (let loop ((result '())
 104              (table vlist-null)
 105              (referrers vlist-null))
 106     (match (read-line port)
 107       ((? eof-object?)
 108        ;; 'guix-daemon' gives us something that's in "reverse topological
 109        ;; order"--i.e., leaves (items with zero references) come last.  Here
 110        ;; we compute the topological order that we want: leaves come first.
 111        (let ((unreferenced? (lambda (item)
 112                               (let ((referrers (vhash-fold* cons '()
 113                                                             (store-info-item item)
 114                                                             referrers)))
 115                                 (or (null? referrers)
 116                                     (equal? (list item) referrers))))))
 117          (topological-sort (filter unreferenced? result)
 118                            (lambda (item)
 119                              (map (lambda (item)
 120                                     (match (vhash-assoc item table)
 121                                       ((_ . node) node)))
 122                                   (store-info-references item))))))
 123       (item
 124        (let* ((deriver (match (read-line port)
 125                          ("" #f)
 126                          (line line)))
 127               (count   (string->number (read-line port)))
 128               (refs    (unfold-right (cut >= <> count)
 129                                      (lambda (n)
 130                                        (read-line port))
 131                                      1+
 132                                      0))
 133               (item    (store-info item deriver refs)))
 134          (loop (cons item result)
 135                (vhash-cons (store-info-item item) item table)
 136                (fold (cut vhash-cons <> item <>)
 137                      referrers
 138                      refs)))))))
 139
 140 (define (file-size file)
 141   "Return the size of bytes of FILE, entering it if FILE is a directory."
 142   (file-system-fold (const #t)
 143                     (lambda (file stat result)    ;leaf
 144                       (+ (stat:size stat) result))
 145                     (lambda (directory stat result) ;down
 146                       (+ (stat:size stat) result))
 147                     (lambda (directory stat result) ;up
 148                       result)
 149                     (lambda (file stat result)    ;skip
 150                       result)
 151                     (lambda (file stat errno result)
 152                       (format (current-error-port)
 153                               "file-size: ~a: ~a~%" file
 154                               (strerror errno))
 155                       result)
 156                     0
 157                     file
 158                     lstat))
 159
 160 (define (closure-size reference-graphs)
 161   "Return an estimate of the size of the closure described by
 162 REFERENCE-GRAPHS, a list of reference-graph files."
 163   (define (graph-from-file file)
 164     (map store-info-item
 165          (call-with-input-file file read-reference-graph)))
 166
 167   (define items
 168     (delete-duplicates (append-map graph-from-file reference-graphs)))
 169
 170   (reduce + 0 (map file-size items)))
 171
 172 (define (reset-permissions file)
 173   "Reset the permissions on FILE and its sub-directories so that they are all
 174 read-only."
 175   ;; XXX: This procedure exists just to work around the inability of
 176   ;; 'copy-recursively' to preserve permissions.
 177   (file-system-fold (const #t)                    ;enter?
 178                     (lambda (file stat _)         ;leaf
 179                       (unless (eq? 'symlink (stat:type stat))
 180                         (chmod file
 181                                (if (zero? (logand (stat:mode stat)
 182                                                   #o100))
 183                                    #o444
 184                                    #o555))))
 185                     (const #t)                    ;down
 186                     (lambda (directory stat _)    ;up
 187                       (chmod directory #o555))
 188                     (const #f)                    ;skip
 189                     (const #f)                    ;error
 190                     #t
 191                     file
 192                     lstat))
 193
 194 (define* (populate-store reference-graphs target
 195                          #:key (log-port (current-error-port)))
 196   "Populate the store under directory TARGET with the items specified in
 197 REFERENCE-GRAPHS, a list of reference-graph files."
 198   (define store
 199     (string-append target (%store-directory)))
 200
 201   (define (things-to-copy)
 202     ;; Return the list of store files to copy to the image.
 203     (define (graph-from-file file)
 204       (map store-info-item
 205            (call-with-input-file file read-reference-graph)))
 206
 207     (delete-duplicates (append-map graph-from-file reference-graphs)))
 208
 209   (mkdir-p store)
 210   (chmod store #o1775)
 211
 212   (let* ((things   (things-to-copy))
 213          (len      (length things))
 214          (progress (progress-reporter/bar len
 215                                           (format #f "copying ~a store items"
 216                                                   len)
 217                                           log-port)))
 218     (call-with-progress-reporter progress
 219       (lambda (report)
 220         (for-each (lambda (thing)
 221                     (copy-recursively thing
 222                                       (string-append target thing)
 223                                       #:keep-mtime? #t
 224                                       #:log (%make-void-port "w"))
 225
 226                     ;; XXX: Since 'copy-recursively' doesn't allow us to
 227                     ;; preserve permissions, we have to traverse TARGET to
 228                     ;; make sure everything is read-only.
 229                     (reset-permissions (string-append target thing))
 230                     (report))
 231                   things)))))
 232
 233 ;;; store-copy.scm ends here