Mirror of GNU Guix
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.

396 lines
12 KiB

  1. ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
  2. ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of Guix.
  5. ;;;
  6. ;;; 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. ;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (guix store)
  19. #:use-module (rnrs bytevectors)
  20. #:use-module (rnrs io ports)
  21. #:use-module (srfi srfi-1)
  22. #:use-module (srfi srfi-9)
  23. #:use-module (srfi srfi-26)
  24. #:use-module (srfi srfi-34)
  25. #:use-module (srfi srfi-35)
  26. #:use-module (srfi srfi-39)
  27. #:use-module (ice-9 match)
  28. #:use-module (ice-9 rdelim)
  29. #:use-module (ice-9 ftw)
  30. #:export (nix-server?
  31. nix-server-major-version
  32. nix-server-minor-version
  33. nix-server-socket
  34. &nix-error nix-error?
  35. &nix-protocol-error nix-protocol-error?
  36. nix-protocol-error-message
  37. nix-protocol-error-status
  38. hash-algo
  39. open-connection
  40. set-build-options
  41. add-text-to-store
  42. add-to-store
  43. build-derivations
  44. %store-prefix
  45. store-path?
  46. derivation-path?))
  47. (define %protocol-version #x109)
  48. (define %worker-magic-1 #x6e697863)
  49. (define %worker-magic-2 #x6478696f)
  50. (define (protocol-major magic)
  51. (logand magic #xff00))
  52. (define (protocol-minor magic)
  53. (logand magic #x00ff))
  54. (define-syntax define-enumerate-type
  55. (syntax-rules ()
  56. ((_ name->int (name id) ...)
  57. (define-syntax name->int
  58. (syntax-rules (name ...)
  59. ((_ name) id) ...)))))
  60. (define-enumerate-type operation-id
  61. ;; operation numbers from worker-protocol.hh
  62. (quit 0)
  63. (valid-path? 1)
  64. (has-substitutes? 3)
  65. (query-path-hash 4)
  66. (query-references 5)
  67. (query-referrers 6)
  68. (add-to-store 7)
  69. (add-text-to-store 8)
  70. (build-derivations 9)
  71. (ensure-path 10)
  72. (add-temp-root 11)
  73. (add-indirect-root 12)
  74. (sync-with-gc 13)
  75. (find-roots 14)
  76. (export-path 16)
  77. (query-deriver 18)
  78. (set-options 19)
  79. (collect-garbage 20)
  80. (query-substitutable-path-info 21)
  81. (query-derivation-outputs 22)
  82. (query-valid-paths 23)
  83. (query-failed-paths 24)
  84. (clear-failed-paths 25)
  85. (query-path-info 26)
  86. (import-paths 27)
  87. (query-derivation-output-names 28))
  88. (define-enumerate-type hash-algo
  89. ;; hash.hh
  90. (md5 1)
  91. (sha1 2)
  92. (sha256 3))
  93. (define %nix-state-dir "/nix/var/nix")
  94. (define %default-socket-path
  95. (string-append %nix-state-dir "/daemon-socket/socket"))
  96. ;; serialize.cc
  97. (define (write-int n p)
  98. (let ((b (make-bytevector 8 0)))
  99. (bytevector-u32-set! b 0 n (endianness little))
  100. (put-bytevector p b)))
  101. (define (read-int p)
  102. (let ((b (get-bytevector-n p 8)))
  103. (bytevector-u32-ref b 0 (endianness little))))
  104. (define (write-long-long n p)
  105. (let ((b (make-bytevector 8 0)))
  106. (bytevector-u64-set! b 0 n (endianness little))
  107. (put-bytevector p b)))
  108. (define write-padding
  109. (let ((zero (make-bytevector 8 0)))
  110. (lambda (n p)
  111. (let ((m (modulo n 8)))
  112. (or (zero? m)
  113. (put-bytevector p zero 0 (- 8 m)))))))
  114. (define (write-string s p)
  115. (let ((b (string->utf8 s)))
  116. (write-int (bytevector-length b) p)
  117. (put-bytevector p b)
  118. (write-padding (bytevector-length b) p)))
  119. (define (read-string p)
  120. (let* ((len (read-int p))
  121. (m (modulo len 8))
  122. (bv (get-bytevector-n p len))
  123. (str (utf8->string bv)))
  124. (or (zero? m)
  125. (get-bytevector-n p (- 8 m)))
  126. str))
  127. (define (write-string-list l p)
  128. (write-int (length l) p)
  129. (for-each (cut write-string <> p) l))
  130. (define (read-store-path p)
  131. (read-string p)) ; TODO: assert path
  132. (define (write-contents file p)
  133. "Write the contents of FILE to output port P."
  134. (define (dump in size)
  135. (define buf-size 65536)
  136. (define buf (make-bytevector buf-size))
  137. (let loop ((left size))
  138. (if (<= left 0)
  139. 0
  140. (let ((read (get-bytevector-n! in buf 0 buf-size)))
  141. (if (eof-object? read)
  142. left
  143. (begin
  144. (put-bytevector p buf 0 read)
  145. (loop (- left read))))))))
  146. (let ((size (stat:size (lstat file))))
  147. (write-string "contents" p)
  148. (write-long-long size p)
  149. (call-with-input-file file
  150. (lambda (p)
  151. (dump p size)))
  152. (write-padding size p)))
  153. (define (write-file f p)
  154. (define %archive-version-1 "nix-archive-1")
  155. (write-string %archive-version-1 p)
  156. (let dump ((f f))
  157. (let ((s (lstat f)))
  158. (write-string "(" p)
  159. (case (stat:type s)
  160. ((regular)
  161. (write-string "type" p)
  162. (write-string "regular" p)
  163. (if (not (zero? (logand (stat:mode s) #o100)))
  164. (begin
  165. (write-string "executable" p)
  166. (write-string "" p)))
  167. (write-contents f p))
  168. ((directory)
  169. (write-string "type" p)
  170. (write-string "directory" p)
  171. (let ((entries (remove (cut member <> '("." ".."))
  172. (scandir f))))
  173. (for-each (lambda (e)
  174. (let ((f (string-append f "/" e)))
  175. (write-string "entry" p)
  176. (write-string "(" p)
  177. (write-string "name" p)
  178. (write-string e p)
  179. (write-string "node" p)
  180. (dump f)
  181. (write-string ")" p)))
  182. entries)))
  183. (else
  184. (error "ENOSYS")))
  185. (write-string ")" p))))
  186. (define-syntax write-arg
  187. (syntax-rules (integer boolean file string string-list)
  188. ((_ integer arg p)
  189. (write-int arg p))
  190. ((_ boolean arg p)
  191. (write-int (if arg 1 0) p))
  192. ((_ file arg p)
  193. (write-file arg p))
  194. ((_ string arg p)
  195. (write-string arg p))
  196. ((_ string-list arg p)
  197. (write-string-list arg p))))
  198. (define-syntax read-arg
  199. (syntax-rules (integer boolean string store-path)
  200. ((_ integer p)
  201. (read-int p))
  202. ((_ boolean p)
  203. (not (zero? (read-int p))))
  204. ((_ string p)
  205. (read-string p))
  206. ((_ store-path p)
  207. (read-store-path p))))
  208. ;; remote-store.cc
  209. (define-record-type <nix-server>
  210. (%make-nix-server socket major minor)
  211. nix-server?
  212. (socket nix-server-socket)
  213. (major nix-server-major-version)
  214. (minor nix-server-minor-version))
  215. (define-condition-type &nix-error &error
  216. nix-error?)
  217. (define-condition-type &nix-protocol-error &nix-error
  218. nix-protocol-error?
  219. (message nix-protocol-error-message)
  220. (status nix-protocol-error-status))
  221. (define* (open-connection #:optional (file %default-socket-path))
  222. (let ((s (with-fluids ((%default-port-encoding #f))
  223. ;; This trick allows use of the `scm_c_read' optimization.
  224. (socket PF_UNIX SOCK_STREAM 0)))
  225. (a (make-socket-address PF_UNIX file)))
  226. (connect s a)
  227. (write-int %worker-magic-1 s)
  228. (let ((r (read-int s)))
  229. (and (eqv? r %worker-magic-2)
  230. (let ((v (read-int s)))
  231. (and (eqv? (protocol-major %protocol-version)
  232. (protocol-major v))
  233. (begin
  234. (write-int %protocol-version s)
  235. (let ((s (%make-nix-server s
  236. (protocol-major v)
  237. (protocol-minor v))))
  238. (process-stderr s)
  239. s))))))))
  240. (define (process-stderr server)
  241. (define p
  242. (nix-server-socket server))
  243. ;; magic cookies from worker-protocol.hh
  244. (define %stderr-next #x6f6c6d67)
  245. (define %stderr-read #x64617461) ; data needed from source
  246. (define %stderr-write #x64617416) ; data for sink
  247. (define %stderr-last #x616c7473)
  248. (define %stderr-error #x63787470)
  249. (let ((k (read-int p)))
  250. (cond ((= k %stderr-write)
  251. (read-string p))
  252. ((= k %stderr-read)
  253. (let ((len (read-int p)))
  254. (read-string p) ; FIXME: what to do?
  255. ))
  256. ((= k %stderr-next)
  257. (let ((s (read-string p)))
  258. (display s (current-error-port))
  259. s))
  260. ((= k %stderr-error)
  261. (let ((error (read-string p))
  262. (status (if (>= (nix-server-minor-version server) 8)
  263. (read-int p)
  264. 1)))
  265. (raise (condition (&nix-protocol-error
  266. (message error)
  267. (status status))))))
  268. ((= k %stderr-last)
  269. #t)
  270. (else
  271. (raise (condition (&nix-protocol-error
  272. (message "invalid error code")
  273. (status k))))))))
  274. (define* (set-build-options server
  275. #:key keep-failed? keep-going? try-fallback?
  276. (verbosity 0)
  277. (max-build-jobs (current-processor-count))
  278. (max-silent-time 3600)
  279. (use-build-hook? #t)
  280. (build-verbosity 0)
  281. (log-type 0)
  282. (print-build-trace #t))
  283. ;; Must be called after `open-connection'.
  284. (define socket
  285. (nix-server-socket server))
  286. (let-syntax ((send (syntax-rules ()
  287. ((_ option ...)
  288. (for-each (lambda (i)
  289. (cond ((boolean? i)
  290. (write-int (if i 1 0) socket))
  291. ((integer? i)
  292. (write-int i socket))
  293. (else
  294. (error "invalid build option"
  295. i))))
  296. (list option ...))))))
  297. (send (operation-id set-options)
  298. keep-failed? keep-going? try-fallback? verbosity
  299. max-build-jobs max-silent-time)
  300. (if (>= (nix-server-minor-version server) 2)
  301. (send use-build-hook?))
  302. (if (>= (nix-server-minor-version server) 4)
  303. (send build-verbosity log-type print-build-trace))
  304. (process-stderr server)))
  305. (define-syntax define-operation
  306. (syntax-rules ()
  307. ((_ (name (type arg) ...) docstring return)
  308. (define (name server arg ...)
  309. docstring
  310. (let ((s (nix-server-socket server)))
  311. (write-int (operation-id name) s)
  312. (write-arg type arg s)
  313. ...
  314. (process-stderr server)
  315. (read-arg return s))))))
  316. (define-operation (add-text-to-store (string name) (string text)
  317. (string-list references))
  318. "Add TEXT under file NAME in the store."
  319. store-path)
  320. (define-operation (add-to-store (string basename)
  321. (boolean fixed?) ; obsolete, must be #t
  322. (boolean recursive?)
  323. (string hash-algo)
  324. (file file-name))
  325. "Add the contents of FILE-NAME under BASENAME to the store."
  326. store-path)
  327. (define-operation (build-derivations (string-list derivations))
  328. "Build DERIVATIONS; return #t on success."
  329. boolean)
  330. ;;;
  331. ;;; Store paths.
  332. ;;;
  333. (define %store-prefix
  334. ;; Absolute path to the Nix store.
  335. (make-parameter "/nix/store"))
  336. (define store-path?
  337. (let ((store-path-rx
  338. (delay (make-regexp
  339. (string-append "^.*" (%store-prefix) "/[^-]{32}-(.+)$")))))
  340. (lambda (path)
  341. "Return #t if PATH is a store path."
  342. (not (not (regexp-exec (force store-path-rx) path))))))
  343. (define (derivation-path? path)
  344. "Return #t if PATH is a derivation path."
  345. (and (store-path? path) (string-suffix? ".drv" path)))