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.
 
 
 
 
 
 

740 lines
28 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2014 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 offload)
  19. #:use-module (guix config)
  20. #:use-module (guix records)
  21. #:use-module (guix store)
  22. #:use-module (guix derivations)
  23. #:use-module (guix nar)
  24. #:use-module (guix utils)
  25. #:use-module ((guix build utils) #:select (which mkdir-p))
  26. #:use-module (guix ui)
  27. #:use-module (srfi srfi-1)
  28. #:use-module (srfi srfi-11)
  29. #:use-module (srfi srfi-26)
  30. #:use-module (srfi srfi-34)
  31. #:use-module (srfi srfi-35)
  32. #:use-module (ice-9 popen)
  33. #:use-module (ice-9 rdelim)
  34. #:use-module (ice-9 match)
  35. #:use-module (ice-9 regex)
  36. #:use-module (ice-9 format)
  37. #:use-module (rnrs io ports)
  38. #:export (build-machine
  39. build-requirements
  40. guix-offload))
  41. ;;; Commentary:
  42. ;;;
  43. ;;; Attempt to offload builds to the machines listed in
  44. ;;; /etc/guix/machines.scm, transferring missing dependencies over SSH, and
  45. ;;; retrieving the build output(s) over SSH upon success.
  46. ;;;
  47. ;;; This command should not be used directly; instead, it is called on-demand
  48. ;;; by the daemon, unless it was started with '--no-build-hook' or a client
  49. ;;; inhibited build hooks.
  50. ;;;
  51. ;;; Code:
  52. (define-record-type* <build-machine>
  53. build-machine make-build-machine
  54. build-machine?
  55. (name build-machine-name) ; string
  56. (port build-machine-port ; number
  57. (default 22))
  58. (system build-machine-system) ; string
  59. (user build-machine-user) ; string
  60. (private-key build-machine-private-key ; file name
  61. (default (user-lsh-private-key)))
  62. (parallel-builds build-machine-parallel-builds ; number
  63. (default 1))
  64. (speed build-machine-speed ; inexact real
  65. (default 1.0))
  66. (features build-machine-features ; list of strings
  67. (default '())))
  68. (define-record-type* <build-requirements>
  69. build-requirements make-build-requirements
  70. build-requirements?
  71. (system build-requirements-system) ; string
  72. (features build-requirements-features ; list of strings
  73. (default '())))
  74. (define %machine-file
  75. ;; File that lists machines available as build slaves.
  76. (string-append %config-directory "/machines.scm"))
  77. (define %lsh-command
  78. "lsh")
  79. (define %lshg-command
  80. ;; FIXME: 'lshg' fails to pass large amounts of data, see
  81. ;; <http://lists.lysator.liu.se/pipermail/lsh-bugs/2014q1/000639.html>.
  82. "lsh")
  83. (define (user-lsh-private-key)
  84. "Return the user's default lsh private key, or #f if it could not be
  85. determined."
  86. (and=> (getenv "HOME")
  87. (cut string-append <> "/.lsh/identity")))
  88. (define %user-module
  89. ;; Module in which the machine description file is loaded.
  90. (let ((module (make-fresh-user-module)))
  91. (module-use! module (resolve-interface '(guix scripts offload)))
  92. module))
  93. (define* (build-machines #:optional (file %machine-file))
  94. "Read the list of build machines from FILE and return it."
  95. (catch #t
  96. (lambda ()
  97. ;; Avoid ABI incompatibility with the <build-machine> record.
  98. (set! %fresh-auto-compile #t)
  99. (save-module-excursion
  100. (lambda ()
  101. (set-current-module %user-module)
  102. (primitive-load file))))
  103. (lambda args
  104. (match args
  105. (('system-error . _)
  106. (let ((err (system-error-errno args)))
  107. ;; Silently ignore missing file since this is a common case.
  108. (if (= ENOENT err)
  109. '()
  110. (leave (_ "failed to open machine file '~a': ~a~%")
  111. file (strerror err)))))
  112. (('syntax-error proc message properties form . rest)
  113. (let ((loc (source-properties->location properties)))
  114. (leave (_ "~a: ~a~%")
  115. (location->string loc) message)))
  116. (_
  117. (leave (_ "failed to load machine file '~a': ~s~%")
  118. file args))))))
  119. ;;; FIXME: The idea was to open the connection to MACHINE once for all, but
  120. ;;; lshg is currently non-functional.
  121. ;; (define (open-ssh-gateway machine)
  122. ;; "Initiate an SSH connection gateway to MACHINE, and return the PID of the
  123. ;; running lsh gateway upon success, or #f on failure."
  124. ;; (catch 'system-error
  125. ;; (lambda ()
  126. ;; (let* ((port (open-pipe* OPEN_READ %lsh-command
  127. ;; "-l" (build-machine-user machine)
  128. ;; "-i" (build-machine-private-key machine)
  129. ;; ;; XXX: With lsh 2.1, passing '--write-pid'
  130. ;; ;; last causes the PID not to be printed.
  131. ;; "--write-pid" "--gateway" "--background"
  132. ;; (build-machine-name machine)))
  133. ;; (line (read-line port))
  134. ;; (status (close-pipe port)))
  135. ;; (if (zero? status)
  136. ;; (let ((pid (string->number line)))
  137. ;; (if (integer? pid)
  138. ;; pid
  139. ;; (begin
  140. ;; (warning (_ "'~a' did not write its PID on stdout: ~s~%")
  141. ;; %lsh-command line)
  142. ;; #f)))
  143. ;; (begin
  144. ;; (warning (_ "failed to initiate SSH connection to '~a':\
  145. ;; '~a' exited with ~a~%")
  146. ;; (build-machine-name machine)
  147. ;; %lsh-command
  148. ;; (status:exit-val status))
  149. ;; #f))))
  150. ;; (lambda args
  151. ;; (leave (_ "failed to execute '~a': ~a~%")
  152. ;; %lsh-command (strerror (system-error-errno args))))))
  153. (define-syntax with-error-to-port
  154. (syntax-rules ()
  155. ((_ port exp0 exp ...)
  156. (let ((new port)
  157. (old (current-error-port)))
  158. (dynamic-wind
  159. (lambda ()
  160. (set-current-error-port new))
  161. (lambda ()
  162. exp0 exp ...)
  163. (lambda ()
  164. (set-current-error-port old)))))))
  165. (define* (remote-pipe machine mode command
  166. #:key (error-port (current-error-port)) (quote? #t))
  167. "Run COMMAND (a string list) on MACHINE, assuming an lsh gateway has been
  168. set up. When QUOTE? is true, perform shell-quotation of all the elements of
  169. COMMAND. Return either a pipe opened with MODE, or #f if the lsh client could
  170. not be started."
  171. (define (shell-quote str)
  172. ;; Sort-of shell-quote STR so it can be passed as an argument to the
  173. ;; shell.
  174. (with-output-to-string
  175. (lambda ()
  176. (write str))))
  177. (catch 'system-error
  178. (lambda ()
  179. ;; Let the child inherit ERROR-PORT.
  180. (with-error-to-port error-port
  181. (apply open-pipe* mode %lshg-command
  182. "-l" (build-machine-user machine)
  183. "-p" (number->string (build-machine-port machine))
  184. ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
  185. "-i" (build-machine-private-key machine)
  186. (build-machine-name machine)
  187. (if quote?
  188. (map shell-quote command)
  189. command))))
  190. (lambda args
  191. (warning (_ "failed to execute '~a': ~a~%")
  192. %lshg-command (strerror (system-error-errno args)))
  193. #f)))
  194. ;;;
  195. ;;; Synchronization.
  196. ;;;
  197. (define (lock-file file)
  198. "Wait and acquire an exclusive lock on FILE. Return an open port."
  199. (mkdir-p (dirname file))
  200. (let ((port (open-file file "w0")))
  201. (fcntl-flock port 'write-lock)
  202. port))
  203. (define (unlock-file lock)
  204. "Unlock LOCK."
  205. (fcntl-flock lock 'unlock)
  206. (close-port lock)
  207. #t)
  208. (define-syntax-rule (with-file-lock file exp ...)
  209. "Wait to acquire a lock on FILE and evaluate EXP in that context."
  210. (let ((port (lock-file file)))
  211. (dynamic-wind
  212. (lambda ()
  213. #t)
  214. (lambda ()
  215. exp ...)
  216. (lambda ()
  217. (unlock-file port)))))
  218. (define-syntax-rule (with-machine-lock machine hint exp ...)
  219. "Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that
  220. context."
  221. (with-file-lock (machine-lock-file machine hint)
  222. exp ...))
  223. (define (machine-slot-file machine slot)
  224. "Return the file name of MACHINE's file for SLOT."
  225. ;; For each machine we have a bunch of files representing each build slot.
  226. ;; When choosing a build machine, we attempt to get an exclusive lock on one
  227. ;; of these; if we fail, that means all the build slots are already taken.
  228. ;; Inspired by Nix's build-remote.pl.
  229. (string-append (string-append %state-directory "/offload/"
  230. (build-machine-name machine)
  231. "/" (number->string slot))))
  232. (define (acquire-build-slot machine)
  233. "Attempt to acquire a build slot on MACHINE. Return the port representing
  234. the slot, or #f if none is available.
  235. This mechanism allows us to set a hard limit on the number of simultaneous
  236. connections allowed to MACHINE."
  237. (mkdir-p (dirname (machine-slot-file machine 0)))
  238. (with-machine-lock machine 'slots
  239. (any (lambda (slot)
  240. (let ((port (open-file (machine-slot-file machine slot)
  241. "w0")))
  242. (catch 'flock-error
  243. (lambda ()
  244. (fcntl-flock port 'write-lock #:wait? #f)
  245. ;; Got it!
  246. (format (current-error-port)
  247. "process ~a acquired build slot '~a'~%"
  248. (getpid) (port-filename port))
  249. port)
  250. (lambda args
  251. ;; PORT is already locked by another process.
  252. (close-port port)
  253. #f))))
  254. (iota (build-machine-parallel-builds machine)))))
  255. (define (release-build-slot slot)
  256. "Release SLOT, a build slot as returned as by 'acquire-build-slot'."
  257. (close-port slot))
  258. ;;;
  259. ;;; Offloading.
  260. ;;;
  261. (define (build-log-port)
  262. "Return the default port where build logs should be sent. The default is
  263. file descriptor 4, which is open by the daemon before running the offload
  264. hook."
  265. (let ((port (fdopen 4 "w0")))
  266. ;; Make sure file descriptor 4 isn't closed when PORT is GC'd.
  267. (set-port-revealed! port 1)
  268. port))
  269. (define %gc-root-file
  270. ;; File name of the temporary GC root we install.
  271. (format #f "offload-~a-~a" (gethostname) (getpid)))
  272. (define (register-gc-root file machine)
  273. "Mark FILE, a store item, as a garbage collector root on MACHINE."
  274. (define script
  275. `(begin
  276. (use-modules (guix config))
  277. ;; Note: we can't use 'add-indirect-root' because dangling links under
  278. ;; gcroots/auto are automatically deleted by the GC. This strategy
  279. ;; doesn't have this problem, but it requires write access to that
  280. ;; directory.
  281. (let ((root-directory (string-append %state-directory
  282. "/gcroots/tmp")))
  283. (false-if-exception (mkdir root-directory))
  284. (catch 'system-error
  285. (lambda ()
  286. (symlink ,file
  287. (string-append root-directory "/" ,%gc-root-file)))
  288. (lambda args
  289. ;; If FILE already exists, we can assume that either it's a stale
  290. ;; reference (which is fine), or another process is already
  291. ;; building the derivation represented by FILE (which is fine
  292. ;; too.) Thus, do nothing in that case.
  293. (unless (= EEXIST (system-error-errno args))
  294. (apply throw args)))))))
  295. (let ((pipe (remote-pipe machine OPEN_READ
  296. `("guile" "-c" ,(object->string script)))))
  297. (get-string-all pipe)
  298. (let ((status (close-pipe pipe)))
  299. (unless (zero? status)
  300. ;; Better be safe than sorry: if we ignore the error here, then FILE
  301. ;; may be GC'd just before we start using it.
  302. (leave (_ "failed to register GC root for '~a' on '~a' (status: ~a)~%")
  303. file machine status)))))
  304. (define (remove-gc-roots machine)
  305. "Remove from MACHINE the GC roots previously installed with
  306. 'register-gc-root'."
  307. (define script
  308. `(begin
  309. (use-modules (guix config) (ice-9 ftw)
  310. (srfi srfi-1) (srfi srfi-26))
  311. (let ((root-directory (string-append %state-directory
  312. "/gcroots/tmp")))
  313. (false-if-exception
  314. (delete-file
  315. (string-append root-directory "/" ,%gc-root-file)))
  316. ;; These ones were created with 'guix build -r' (there can be more
  317. ;; than one in case of multiple-output derivations.)
  318. (let ((roots (filter (cut string-prefix? ,%gc-root-file <>)
  319. (scandir "."))))
  320. (for-each (lambda (file)
  321. (false-if-exception (delete-file file)))
  322. roots)))))
  323. (let ((pipe (remote-pipe machine OPEN_READ
  324. `("guile" "-c" ,(object->string script)))))
  325. (get-string-all pipe)
  326. (close-pipe pipe)))
  327. (define* (offload drv machine
  328. #:key print-build-trace? (max-silent-time 3600)
  329. build-timeout (log-port (build-log-port)))
  330. "Perform DRV on MACHINE, assuming DRV and its prerequisites are available
  331. there, and write the build log to LOG-PORT. Return the exit status."
  332. (format (current-error-port) "offloading '~a' to '~a'...~%"
  333. (derivation-file-name drv) (build-machine-name machine))
  334. (format (current-error-port) "@ build-remote ~a ~a~%"
  335. (derivation-file-name drv) (build-machine-name machine))
  336. ;; Normally DRV has already been protected from GC when it was transferred.
  337. ;; The '-r' flag below prevents the build result from being GC'd.
  338. (let ((pipe (remote-pipe machine OPEN_READ
  339. `("guix" "build"
  340. "-r" ,%gc-root-file
  341. ,(format #f "--max-silent-time=~a"
  342. max-silent-time)
  343. ,@(if build-timeout
  344. (list (format #f "--timeout=~a"
  345. build-timeout))
  346. '())
  347. ,(derivation-file-name drv))
  348. ;; Since 'guix build' writes the build log to its
  349. ;; stderr, everything will go directly to LOG-PORT.
  350. #:error-port log-port)))
  351. (let loop ((line (read-line pipe)))
  352. (unless (eof-object? line)
  353. (display line log-port)
  354. (newline log-port)
  355. (loop (read-line pipe))))
  356. (close-pipe pipe)))
  357. (define* (transfer-and-offload drv machine
  358. #:key
  359. (inputs '())
  360. (outputs '())
  361. (max-silent-time 3600)
  362. build-timeout
  363. print-build-trace?)
  364. "Offload DRV to MACHINE. Prior to the actual offloading, transfer all of
  365. INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from
  366. MACHINE."
  367. ;; Acquire MACHINE's upload or download lock to serialize file transfers in
  368. ;; a given direction to/from MACHINE in the presence of several 'offload'
  369. ;; hook instance.
  370. (when (with-machine-lock machine 'upload
  371. (register-gc-root (derivation-file-name drv) machine)
  372. (send-files (cons (derivation-file-name drv) inputs)
  373. machine))
  374. (let ((status (offload drv machine
  375. #:print-build-trace? print-build-trace?
  376. #:max-silent-time max-silent-time
  377. #:build-timeout build-timeout)))
  378. (if (zero? status)
  379. (begin
  380. ;; Likewise (see above.)
  381. (with-machine-lock machine 'download
  382. (retrieve-files outputs machine))
  383. (remove-gc-roots machine)
  384. (format (current-error-port)
  385. "done with offloaded '~a'~%"
  386. (derivation-file-name drv)))
  387. (begin
  388. (remove-gc-roots machine)
  389. (format (current-error-port)
  390. "derivation '~a' offloaded to '~a' failed \
  391. with exit code ~a~%"
  392. (derivation-file-name drv)
  393. (build-machine-name machine)
  394. (status:exit-val status))
  395. ;; Use exit code 100 for a permanent build failure. The daemon
  396. ;; interprets other non-zero codes as transient build failures.
  397. (primitive-exit 100))))))
  398. (define (send-files files machine)
  399. "Send the subset of FILES that's missing to MACHINE's store. Return #t on
  400. success, #f otherwise."
  401. (define (missing-files files)
  402. ;; Return the subset of FILES not already on MACHINE.
  403. (let*-values (((files)
  404. (format #f "~{~a~%~}" files))
  405. ((missing pids)
  406. (filtered-port
  407. (list (which %lshg-command)
  408. "-l" (build-machine-user machine)
  409. "-p" (number->string (build-machine-port machine))
  410. "-i" (build-machine-private-key machine)
  411. (build-machine-name machine)
  412. "guix" "archive" "--missing")
  413. (open-input-string files)))
  414. ((result)
  415. (get-string-all missing)))
  416. (for-each waitpid pids)
  417. (string-tokenize result)))
  418. (with-store store
  419. (guard (c ((nix-protocol-error? c)
  420. (warning (_ "failed to export files for '~a': ~s~%")
  421. (build-machine-name machine)
  422. c)
  423. #f))
  424. ;; Compute the subset of FILES missing on MACHINE, and send them in
  425. ;; topologically sorted order so that they can actually be imported.
  426. (let* ((files (missing-files (topologically-sorted store files)))
  427. (pipe (remote-pipe machine OPEN_WRITE
  428. '("xz" "-dc" "|"
  429. "guix" "archive" "--import")
  430. #:quote? #f)))
  431. (format #t (_ "sending ~a store files to '~a'...~%")
  432. (length files) (build-machine-name machine))
  433. (call-with-compressed-output-port 'xz pipe
  434. (lambda (compressed)
  435. (catch 'system-error
  436. (lambda ()
  437. (export-paths store files compressed))
  438. (lambda args
  439. (warning (_ "failed while exporting files to '~a': ~a~%")
  440. (build-machine-name machine)
  441. (strerror (system-error-errno args)))))))
  442. ;; Wait for the 'lsh' process to complete.
  443. (zero? (close-pipe pipe))))))
  444. (define (retrieve-files files machine)
  445. "Retrieve FILES from MACHINE's store, and import them."
  446. (define host
  447. (build-machine-name machine))
  448. (let ((pipe (remote-pipe machine OPEN_READ
  449. `("guix" "archive" "--export" ,@files
  450. "|" "xz" "-c")
  451. #:quote? #f)))
  452. (and pipe
  453. (with-store store
  454. (guard (c ((nix-protocol-error? c)
  455. (warning (_ "failed to import files from '~a': ~s~%")
  456. host c)
  457. #f))
  458. (format (current-error-port) "retrieving ~a files from '~a'...~%"
  459. (length files) host)
  460. ;; We cannot use the 'import-paths' RPC here because we already
  461. ;; hold the locks for FILES.
  462. (call-with-decompressed-port 'xz pipe
  463. (lambda (decompressed)
  464. (restore-file-set decompressed
  465. #:log-port (current-error-port)
  466. #:lock? #f)))
  467. ;; Wait for the 'lsh' process to complete.
  468. (zero? (close-pipe pipe)))))))
  469. ;;;
  470. ;;; Scheduling.
  471. ;;;
  472. (define (machine-matches? machine requirements)
  473. "Return #t if MACHINE matches REQUIREMENTS."
  474. (and (string=? (build-requirements-system requirements)
  475. (build-machine-system machine))
  476. (lset<= string=?
  477. (build-requirements-features requirements)
  478. (build-machine-features machine))))
  479. (define (machine-load machine)
  480. "Return the load of MACHINE, divided by the number of parallel builds
  481. allowed on MACHINE."
  482. (let* ((pipe (remote-pipe machine OPEN_READ `("cat" "/proc/loadavg")))
  483. (line (read-line pipe)))
  484. (close-pipe pipe)
  485. (if (eof-object? line)
  486. +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
  487. (match (string-tokenize line)
  488. ((one five fifteen . _)
  489. (let* ((raw (string->number five))
  490. (jobs (build-machine-parallel-builds machine))
  491. (normalized (/ raw jobs)))
  492. (format (current-error-port) "load on machine '~a' is ~s\
  493. (normalized: ~s)~%"
  494. (build-machine-name machine) raw normalized)
  495. normalized))
  496. (_
  497. +inf.0))))) ;something's fishy about MACHINE, so avoid it
  498. (define (machine-power-factor m)
  499. "Return a factor that aggregates the speed and load of M. The higher the
  500. better."
  501. (/ (build-machine-speed m)
  502. (+ 1 (machine-load m))))
  503. (define (machine-less-loaded-or-faster? m1 m2)
  504. "Return #t if M1 is either less loaded or faster than M2. (This relation
  505. defines a total order on machines.)"
  506. (> (machine-power-factor m1) (machine-power-factor m2)))
  507. (define (machine-lock-file machine hint)
  508. "Return the name of MACHINE's lock file for HINT."
  509. (string-append %state-directory "/offload/"
  510. (build-machine-name machine)
  511. "." (symbol->string hint) ".lock"))
  512. (define (machine-choice-lock-file)
  513. "Return the name of the file used as a lock when choosing a build machine."
  514. (string-append %state-directory "/offload/machine-choice.lock"))
  515. (define %slots
  516. ;; List of acquired build slots (open ports).
  517. '())
  518. (define (choose-build-machine machines)
  519. "Return the best machine among MACHINES, or #f."
  520. ;; Proceed like this:
  521. ;; 1. Acquire the global machine-choice lock.
  522. ;; 2. For all MACHINES, attempt to acquire a build slot, and filter out
  523. ;; those machines for which we failed.
  524. ;; 3. Choose the best machine among those that are left.
  525. ;; 4. Release the previously-acquired build slots of the other machines.
  526. ;; 5. Release the global machine-choice lock.
  527. (with-file-lock (machine-choice-lock-file)
  528. (define machines+slots
  529. (filter-map (lambda (machine)
  530. (let ((slot (acquire-build-slot machine)))
  531. (and slot (list machine slot))))
  532. machines))
  533. (define (undecorate pred)
  534. (lambda (a b)
  535. (match a
  536. ((machine1 slot1)
  537. (match b
  538. ((machine2 slot2)
  539. (if (pred machine1 machine2)
  540. (list machine1 slot1)
  541. (list machine2 slot2))))))))
  542. (let loop ((machines+slots
  543. (sort machines+slots
  544. (undecorate machine-less-loaded-or-faster?))))
  545. (match machines+slots
  546. (((best slot) others ...)
  547. ;; Return the best machine unless it's already overloaded.
  548. (if (< (machine-load best) 2.)
  549. (match others
  550. (((machines slots) ...)
  551. ;; Release slots from the uninteresting machines.
  552. (for-each release-build-slot slots)
  553. ;; Prevent SLOT from being GC'd.
  554. (set! %slots (cons slot %slots))
  555. best))
  556. (begin
  557. ;; BEST is overloaded, so try the next one.
  558. (release-build-slot slot)
  559. (loop others))))
  560. (() #f)))))
  561. (define* (process-request wants-local? system drv features
  562. #:key
  563. print-build-trace? (max-silent-time 3600)
  564. build-timeout)
  565. "Process a request to build DRV."
  566. (let* ((local? (and wants-local? (string=? system (%current-system))))
  567. (reqs (build-requirements
  568. (system system)
  569. (features features)))
  570. (candidates (filter (cut machine-matches? <> reqs)
  571. (build-machines))))
  572. (match candidates
  573. (()
  574. ;; We'll never be able to match REQS.
  575. (display "# decline\n"))
  576. ((_ ...)
  577. (let ((machine (choose-build-machine candidates)))
  578. (if machine
  579. (begin
  580. ;; Offload DRV to MACHINE.
  581. (display "# accept\n")
  582. (let ((inputs (string-tokenize (read-line)))
  583. (outputs (string-tokenize (read-line))))
  584. (transfer-and-offload drv machine
  585. #:inputs inputs
  586. #:outputs outputs
  587. #:max-silent-time max-silent-time
  588. #:build-timeout build-timeout
  589. #:print-build-trace? print-build-trace?)))
  590. ;; Not now, all the machines are busy.
  591. (display "# postpone\n")))))))
  592. (define-syntax-rule (with-nar-error-handling body ...)
  593. "Execute BODY with any &nar-error suitably reported to the user."
  594. (guard (c ((nar-error? c)
  595. (let ((file (nar-error-file c)))
  596. (if (condition-has-type? c &message)
  597. (leave (_ "while importing file '~a': ~a~%")
  598. file (gettext (condition-message c)))
  599. (leave (_ "failed to import file '~a'~%")
  600. file)))))
  601. body ...))
  602. ;;;
  603. ;;; Entry point.
  604. ;;;
  605. (define (guix-offload . args)
  606. (define request-line-rx
  607. ;; The request format. See 'tryBuildHook' method in build.cc.
  608. (make-regexp "([01]) ([a-z0-9_-]+) (/[[:graph:]]+.drv) ([[:graph:]]*)"))
  609. (define not-coma
  610. (char-set-complement (char-set #\,)))
  611. ;; Make sure $HOME really corresponds to the current user. This is
  612. ;; necessary since lsh uses that to determine the location of the yarrow
  613. ;; seed file, and fails if it's owned by someone else.
  614. (and=> (passwd:dir (getpw (getuid)))
  615. (cut setenv "HOME" <>))
  616. (match args
  617. ((system max-silent-time print-build-trace? build-timeout)
  618. (let ((max-silent-time (string->number max-silent-time))
  619. (build-timeout (string->number build-timeout))
  620. (print-build-trace? (string=? print-build-trace? "1")))
  621. (parameterize ((%current-system system))
  622. (let loop ((line (read-line)))
  623. (unless (eof-object? line)
  624. (cond ((regexp-exec request-line-rx line)
  625. =>
  626. (lambda (match)
  627. (with-nar-error-handling
  628. (process-request (equal? (match:substring match 1) "1")
  629. (match:substring match 2) ; system
  630. (call-with-input-file
  631. (match:substring match 3)
  632. read-derivation)
  633. (string-tokenize
  634. (match:substring match 4) not-coma)
  635. #:print-build-trace? print-build-trace?
  636. #:max-silent-time max-silent-time
  637. #:build-timeout build-timeout))))
  638. (else
  639. (leave (_ "invalid request line: ~s~%") line)))
  640. (loop (read-line)))))))
  641. (("--version")
  642. (show-version-and-exit "guix offload"))
  643. (("--help")
  644. (format #t (_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE
  645. Process build offload requests written on the standard input, possibly
  646. offloading builds to the machines listed in '~a'.~%")
  647. %machine-file)
  648. (display (_ "
  649. This tool is meant to be used internally by 'guix-daemon'.\n"))
  650. (show-bug-report-information))
  651. (x
  652. (leave (_ "invalid arguments: ~{~s ~}~%") x))))
  653. ;;; Local Variables:
  654. ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2)
  655. ;;; eval: (put 'with-file-lock 'scheme-indent-function 1)
  656. ;;; eval: (put 'with-error-to-port 'scheme-indent-function 1)
  657. ;;; End:
  658. ;;; offload.scm ends here