[jackhill/guix/guix.git] / guix / scripts / substitute-binary.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 scripts substitute-binary)
  #:use-module (guix ui)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web response)
  #:export (guix-substitute-binary))

;;; Comment:
;;;
;;; This is the "binary substituter".  It is invoked by the daemon do check
;;; for the existence of available "substitutes" (pre-built binaries), and to
;;; actually use them as a substitute to building things locally.
;;;
;;; If possible, substitute a binary for the requested store path, using a Nix
;;; "binary cache".  This program implements the Nix "substituter" protocol.
;;;
;;; Code:

(define (fields->alist port)
  "Read recutils-style record from PORT and return them as a list of key/value
pairs."
  (define field-rx
    (make-regexp "^([[:graph:]]+): (.*)$"))

  (let loop ((line   (read-line port))
             (result '()))
    (cond ((eof-object? line)
           (reverse result))
          ((regexp-exec field-rx line)
           =>
           (lambda (match)
             (loop (read-line port)
                   (alist-cons (match:substring match 1)
                               (match:substring match 2)
                               result))))
          (else
           (error "unmatched line" line)))))

(define (alist->record alist make keys)
  "Apply MAKE to the values associated with KEYS in ALIST."
  (let ((args (map (cut assoc-ref alist <>) keys)))
    (apply make args)))

(define (fetch uri)
  (case (uri-scheme uri)
    ((file)
     (open-input-file (uri-path uri)))
    ((http)
     (let*-values (((resp port)
                    ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated
                    ;; in 2.0.8 (!).  Assume it is available here.
                    (if (version>? "2.0.7" (version))
                        (http-get* uri #:decode-body? #f)
                        (http-get uri #:streaming? #t)))
                   ((code)
                    (response-code resp))
                   ((size)
                    (response-content-length resp)))
       (case code
         ((200)                                   ; OK
          port)
         ((301                                    ; moved permanently
           302)                                   ; found (redirection)
          (let ((uri (response-location resp)))
            (format #t "following redirection to `~a'...~%"
                    (uri->string uri))
            (fetch uri)))
         (else
          (error "download failed" (uri->string uri)
                 code (response-reason-phrase resp))))))))

(define-record-type <cache>
  (%make-cache url store-directory wants-mass-query?)
  cache?
  (url               cache-url)
  (store-directory   cache-store-directory)
  (wants-mass-query? cache-wants-mass-query?))

(define (open-cache url)
  "Open the binary cache at URL.  Return a <cache> object on success, or #f on
failure."
  (define (download-cache-info url)
    ;; Download the `nix-cache-info' from URL, and return its contents as an
    ;; list of key/value pairs.
    (and=> (false-if-exception (fetch (string->uri url)))
           fields->alist))

  (and=> (download-cache-info (string-append url "/nix-cache-info"))
         (lambda (properties)
           (alist->record properties
                          (cut %make-cache url <...>)
                          '("StoreDir" "WantMassQuery")))))

(define-record-type <narinfo>
  (%make-narinfo path url compression file-hash file-size nar-hash nar-size
                 references deriver system)
  narinfo?
  (path         narinfo-path)
  (url          narinfo-url)
  (compression  narinfo-compression)
  (file-hash    narinfo-file-hash)
  (file-size    narinfo-file-size)
  (nar-hash     narinfo-hash)
  (nar-size     narinfo-size)
  (references   narinfo-references)
  (deriver      narinfo-deriver)
  (system       narinfo-system))

(define (make-narinfo path url compression file-hash file-size nar-hash nar-size
                      references deriver system)
  "Return a new <narinfo> object."
  (%make-narinfo path url compression file-hash
                 (and=> file-size string->number)
                 nar-hash
                 (and=> nar-size string->number)
                 (string-tokenize references)
                 (match deriver
                   ((or #f "") #f)
                   (_ deriver))
                 system))

(define (fetch-narinfo cache path)
  "Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
  (define (download url)
    ;; Download the `nix-cache-info' from URL, and return its contents as an
    ;; list of key/value pairs.
    (and=> (false-if-exception (fetch (string->uri url)))
           fields->alist))

  (and=> (download (string-append (cache-url cache) "/"
                                  (store-path-hash-part path)
                                  ".narinfo"))
         (lambda (properties)
           (alist->record properties make-narinfo
                          '("StorePath" "URL" "Compression"
                            "FileHash" "FileSize" "NarHash" "NarSize"
                            "References" "Deriver" "System")))))

(define %cache-url
  (or (getenv "GUIX_BINARY_SUBSTITUTE_URL")
      "http://hydra.gnu.org"))

\f
;;;
;;; Entry point.
;;;

(define (guix-substitute-binary . args)
  "Implement the build daemon's substituter protocol."
  (match args
    (("--query")
     (let ((cache (open-cache %cache-url)))
       (let loop ((command (read-line)))
         (or (eof-object? command)
             (begin
               (match (string-tokenize command)
                 (("have" paths ..1)
                  ;; Return the subset of PATHS available in CACHE.
                  (let ((substitutable
                         (if cache
                             (par-map (cut fetch-narinfo cache <>)
                                      paths)
                             '())))
                    (for-each (lambda (narinfo)
                                (when narinfo
                                  (format #t "~a~%" (narinfo-path narinfo))))
                              (filter narinfo? substitutable))
                    (newline)))
                 (("info" paths ..1)
                  ;; Reply info about PATHS if it's in CACHE.
                  (let ((substitutable
                         (if cache
                             (par-map (cut fetch-narinfo cache <>)
                                      paths)
                             '())))
                    (for-each (lambda (narinfo)
                                (format #t "~a\n~a\n~a\n"
                                        (narinfo-path narinfo)
                                        (or (and=> (narinfo-deriver narinfo)
                                                   (cute string-append
                                                         (%store-prefix) "/"
                                                         <>))
                                            "")
                                        (length (narinfo-references narinfo)))
                                (for-each (cute format #t "~a/~a~%"
                                                (%store-prefix) <>)
                                          (narinfo-references narinfo))
                                (format #t "~a\n~a\n"
                                        (or (narinfo-file-size narinfo) 0)
                                        (or (narinfo-size narinfo) 0)))
                              (filter narinfo? substitutable))
                    (newline)))
                 (wtf
                  (error "unknown `--query' command" wtf)))
               (loop (read-line)))))))
    (("--substitute" store-path destination)
     ;; Download PATH and add it to the store.
     ;; TODO: Implement.
     (format (current-error-port) "substitution not implemented yet~%")
     #f)
    (("--version")
     (show-version-and-exit "guix substitute-binary"))))

;;; substitute-binary.scm ends here
Commit	Line	Data
f65cf81a LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2013 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 scripts substitute-binary)
	20	#:use-module (guix ui)
	21	#:use-module (guix store)
	22	#:use-module (guix utils)
	23	#:use-module (ice-9 rdelim)
	24	#:use-module (ice-9 regex)
	25	#:use-module (ice-9 match)
	26	#:use-module (ice-9 threads)
	27	#:use-module (srfi srfi-1)
	28	#:use-module (srfi srfi-9)
	29	#:use-module (srfi srfi-11)
	30	#:use-module (srfi srfi-26)
	31	#:use-module (web uri)
	32	#:use-module (web client)
	33	#:use-module (web response)
	34	#:export (guix-substitute-binary))
	35
	36	;;; Comment:
	37	;;;
	38	;;; This is the "binary substituter". It is invoked by the daemon do check
	39	;;; for the existence of available "substitutes" (pre-built binaries), and to
	40	;;; actually use them as a substitute to building things locally.
	41	;;;
	42	;;; If possible, substitute a binary for the requested store path, using a Nix
	43	;;; "binary cache". This program implements the Nix "substituter" protocol.
	44	;;;
	45	;;; Code:
	46
	47	(define (fields->alist port)
	48	"Read recutils-style record from PORT and return them as a list of key/value
	49	pairs."
	50	(define field-rx
	51	(make-regexp "^([[:graph:]]+): (.*)$"))
	52
	53	(let loop ((line (read-line port))
	54	(result '()))
	55	(cond ((eof-object? line)
	56	(reverse result))
	57	((regexp-exec field-rx line)
	58	=>
	59	(lambda (match)
	60	(loop (read-line port)
	61	(alist-cons (match:substring match 1)
	62	(match:substring match 2)
	63	result))))
	64	(else
65	(error "unmatched line" line)))))
66
67	(define (alist->record alist make keys)
68	"Apply MAKE to the values associated with KEYS in ALIST."
69	(let ((args (map (cut assoc-ref alist <>) keys)))
70	(apply make args)))
71
72	(define (fetch uri)
73	(case (uri-scheme uri)
74	((file)
75	(open-input-file (uri-path uri)))
76	((http)
77	(let*-values (((resp port)
78	;; XXX: `http-get*' was introduced in 2.0.7, and deprecated
79	;; in 2.0.8 (!). Assume it is available here.
80	(if (version>? "2.0.7" (version))
81	(http-get* uri #:decode-body? #f)
82	(http-get uri #:streaming? #t)))
83	((code)
84	(response-code resp))
85	((size)
86	(response-content-length resp)))
87	(case code
88	((200) ; OK
89	port)
90	((301 ; moved permanently
91	302) ; found (redirection)
92	(let ((uri (response-location resp)))
93	(format #t "following redirection to `~a'...~%"
94	(uri->string uri))
95	(fetch uri)))
96	(else
97	(error "download failed" (uri->string uri)
98	code (response-reason-phrase resp))))))))
99
100	(define-record-type <cache>
101	(%make-cache url store-directory wants-mass-query?)
102	cache?
103	(url cache-url)
104	(store-directory cache-store-directory)
105	(wants-mass-query? cache-wants-mass-query?))
106
107	(define (open-cache url)
108	"Open the binary cache at URL. Return a <cache> object on success, or #f on
109	failure."
110	(define (download-cache-info url)
111	;; Download the `nix-cache-info' from URL, and return its contents as an
112	;; list of key/value pairs.
113	(and=> (false-if-exception (fetch (string->uri url)))
114	fields->alist))
115
116	(and=> (download-cache-info (string-append url "/nix-cache-info"))
117	(lambda (properties)
118	(alist->record properties
119	(cut %make-cache url <...>)
120	'("StoreDir" "WantMassQuery")))))
121
122	(define-record-type <narinfo>
123	(%make-narinfo path url compression file-hash file-size nar-hash nar-size
124	references deriver system)
125	narinfo?
126	(path narinfo-path)
127	(url narinfo-url)
128	(compression narinfo-compression)
129	(file-hash narinfo-file-hash)
130	(file-size narinfo-file-size)
131	(nar-hash narinfo-hash)
132	(nar-size narinfo-size)
133	(references narinfo-references)
134	(deriver narinfo-deriver)
135	(system narinfo-system))
136
137	(define (make-narinfo path url compression file-hash file-size nar-hash nar-size
138	references deriver system)
139	"Return a new <narinfo> object."
140	(%make-narinfo path url compression file-hash
141	(and=> file-size string->number)
142	nar-hash
143	(and=> nar-size string->number)
144	(string-tokenize references)
145	(match deriver
146	((or #f "") #f)
147	(_ deriver))
148	system))
149
150	(define (fetch-narinfo cache path)
151	"Return the <narinfo> record for PATH, or #f if CACHE does not hold PATH."
152	(define (download url)
153	;; Download the `nix-cache-info' from URL, and return its contents as an
154	;; list of key/value pairs.
155	(and=> (false-if-exception (fetch (string->uri url)))
156	fields->alist))
157
158	(and=> (download (string-append (cache-url cache) "/"
159	(store-path-hash-part path)
160	".narinfo"))
161	(lambda (properties)
162	(alist->record properties make-narinfo
163	'("StorePath" "URL" "Compression"
164	"FileHash" "FileSize" "NarHash" "NarSize"
165	"References" "Deriver" "System")))))
166
167	(define %cache-url
168	(or (getenv "GUIX_BINARY_SUBSTITUTE_URL")
169	"http://hydra.gnu.org"))
170
171	\f
172	;;;
173	;;; Entry point.
174	;;;
175
176	(define (guix-substitute-binary . args)
177	"Implement the build daemon's substituter protocol."
178	(match args
179	(("--query")
180	(let ((cache (open-cache %cache-url)))
181	(let loop ((command (read-line)))
182	(or (eof-object? command)
183	(begin
184	(match (string-tokenize command)
185	(("have" paths ..1)
186	;; Return the subset of PATHS available in CACHE.
187	(let ((substitutable
188	(if cache
189	(par-map (cut fetch-narinfo cache <>)
190	paths)
191	'())))
192	(for-each (lambda (narinfo)
193	(when narinfo
462f8e9f	194	(format #t "~a~%" (narinfo-path narinfo))))
d7c5d277	195	(filter narinfo? substitutable))
462f8e9f	196	(newline)))
f65cf81a LC	197	(("info" paths ..1)
	198	;; Reply info about PATHS if it's in CACHE.
	199	(let ((substitutable
	200	(if cache
	201	(par-map (cut fetch-narinfo cache <>)
	202	paths)
	203	'())))
	204	(for-each (lambda (narinfo)
	205	(format #t "~a\n~a\n~a\n"
	206	(narinfo-path narinfo)
	207	(or (and=> (narinfo-deriver narinfo)
	208	(cute string-append
	209	(%store-prefix) "/"
	210	<>))
	211	"")
	212	(length (narinfo-references narinfo)))
	213	(for-each (cute format #t "~a/~a~%"
	214	(%store-prefix) <>)
	215	(narinfo-references narinfo))
	216	(format #t "~a\n~a\n"
	217	(or (narinfo-file-size narinfo) 0)
462f8e9f	218	(or (narinfo-size narinfo) 0)))
d7c5d277	219	(filter narinfo? substitutable))
462f8e9f	220	(newline)))
f65cf81a LC	221	(wtf
	222	(error "unknown `--query' command" wtf)))
	223	(loop (read-line)))))))
	224	(("--substitute" store-path destination)
	225	;; Download PATH and add it to the store.
	226	;; TODO: Implement.
	227	(format (current-error-port) "substitution not implemented yet~%")
	228	#f)
	229	(("--version")
	230	(show-version-and-exit "guix substitute-binary"))))
	231
	232	;;; substitute-binary.scm ends here