You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

233 lines
8.9 KiB

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