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.
 
 
 
 
 
 

415 lines
18 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2014, 2016, 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. (define-module (build-self)
  19. #:use-module (gnu)
  20. #:use-module (guix)
  21. #:use-module (guix ui)
  22. #:use-module (guix config)
  23. #:use-module (guix modules)
  24. #:use-module (guix build-system gnu)
  25. #:use-module (srfi srfi-1)
  26. #:use-module (srfi srfi-19)
  27. #:use-module (rnrs io ports)
  28. #:use-module (ice-9 match)
  29. #:use-module (ice-9 popen)
  30. #:export (build))
  31. ;;; Commentary:
  32. ;;;
  33. ;;; When loaded, this module returns a monadic procedure of at least one
  34. ;;; argument: the source tree to build. It returns a derivation that
  35. ;;; builds it.
  36. ;;;
  37. ;;; This file uses modules provided by the already-installed Guix. Those
  38. ;;; modules may be arbitrarily old compared to the version we want to
  39. ;;; build. Because of that, it must rely on the smallest set of features
  40. ;;; that are likely to be provided by the (guix) and (gnu) modules, and by
  41. ;;; Guile itself, forever and ever.
  42. ;;;
  43. ;;; Code:
  44. ;;;
  45. ;;; Generating (guix config).
  46. ;;;
  47. ;;; This is copied from (guix self) because we cannot assume (guix self) is
  48. ;;; available at this point.
  49. ;;;
  50. (define %dependency-variables
  51. ;; (guix config) variables corresponding to dependencies.
  52. '(%libgcrypt %libz %xz %gzip %bzip2))
  53. (define %persona-variables
  54. ;; (guix config) variables that define Guix's persona.
  55. '(%guix-package-name
  56. %guix-version
  57. %guix-bug-report-address
  58. %guix-home-page-url))
  59. (define %config-variables
  60. ;; (guix config) variables corresponding to Guix configuration.
  61. (letrec-syntax ((variables (syntax-rules ()
  62. ((_)
  63. '())
  64. ((_ variable rest ...)
  65. (cons `(variable . ,variable)
  66. (variables rest ...))))))
  67. (variables %localstatedir %storedir %sysconfdir %system)))
  68. (define* (make-config.scm #:key zlib gzip xz bzip2
  69. (package-name "GNU Guix")
  70. (package-version "0")
  71. (bug-report-address "bug-guix@gnu.org")
  72. (home-page-url "https://gnu.org/s/guix"))
  73. ;; Hack so that Geiser is not confused.
  74. (define defmod 'define-module)
  75. (scheme-file "config.scm"
  76. #~(begin
  77. (#$defmod (guix config)
  78. #:export (%guix-package-name
  79. %guix-version
  80. %guix-bug-report-address
  81. %guix-home-page-url
  82. %store-directory
  83. %state-directory
  84. %store-database-directory
  85. %config-directory
  86. %libz
  87. %gzip
  88. %bzip2
  89. %xz))
  90. ;; XXX: Work around <http://bugs.gnu.org/15602>.
  91. (eval-when (expand load eval)
  92. #$@(map (match-lambda
  93. ((name . value)
  94. #~(define-public #$name #$value)))
  95. %config-variables)
  96. (define %store-directory
  97. (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
  98. %storedir))
  99. (define %state-directory
  100. ;; This must match `NIX_STATE_DIR' as defined in
  101. ;; `nix/local.mk'.
  102. (or (getenv "NIX_STATE_DIR")
  103. (string-append %localstatedir "/guix")))
  104. (define %store-database-directory
  105. (or (getenv "NIX_DB_DIR")
  106. (string-append %state-directory "/db")))
  107. (define %config-directory
  108. ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as
  109. ;; defined in `nix/local.mk'.
  110. (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
  111. (string-append %sysconfdir "/guix")))
  112. (define %guix-package-name #$package-name)
  113. (define %guix-version #$package-version)
  114. (define %guix-bug-report-address #$bug-report-address)
  115. (define %guix-home-page-url #$home-page-url)
  116. (define %gzip
  117. #+(and gzip (file-append gzip "/bin/gzip")))
  118. (define %bzip2
  119. #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
  120. (define %xz
  121. #+(and xz (file-append xz "/bin/xz")))
  122. (define %libz
  123. #+(and zlib
  124. (file-append zlib "/lib/libz")))))))
  125. ;;;
  126. ;;; 'gexp->script'.
  127. ;;;
  128. ;;; This is our own variant of 'gexp->script' with an extra #:module-path
  129. ;;; parameter, which was unavailable in (guix gexp) until commit
  130. ;;; 1ae16033f34cebe802023922436883867010850f (March 2018.)
  131. ;;;
  132. (define (load-path-expression modules path)
  133. "Return as a monadic value a gexp that sets '%load-path' and
  134. '%load-compiled-path' to point to MODULES, a list of module names. MODULES
  135. are searched for in PATH."
  136. (mlet %store-monad ((modules (imported-modules modules
  137. #:module-path path))
  138. (compiled (compiled-modules modules
  139. #:module-path path)))
  140. (return (gexp (eval-when (expand load eval)
  141. (set! %load-path
  142. (cons (ungexp modules) %load-path))
  143. (set! %load-compiled-path
  144. (cons (ungexp compiled)
  145. %load-compiled-path)))))))
  146. (define* (gexp->script name exp
  147. #:key (guile (default-guile))
  148. (module-path %load-path))
  149. "Return an executable script NAME that runs EXP using GUILE, with EXP's
  150. imported modules in its search path."
  151. (mlet %store-monad ((set-load-path
  152. (load-path-expression (gexp-modules exp)
  153. module-path)))
  154. (gexp->derivation name
  155. (gexp
  156. (call-with-output-file (ungexp output)
  157. (lambda (port)
  158. ;; Note: that makes a long shebang. When the store
  159. ;; is /gnu/store, that fits within the 128-byte
  160. ;; limit imposed by Linux, but that may go beyond
  161. ;; when running tests.
  162. (format port
  163. "#!~a/bin/guile --no-auto-compile~%!#~%"
  164. (ungexp guile))
  165. (write '(ungexp set-load-path) port)
  166. (write '(ungexp exp) port)
  167. (chmod port #o555))))
  168. #:module-path module-path)))
  169. (define (date-version-string)
  170. "Return the current date and hour in UTC timezone, for use as a poor
  171. person's version identifier."
  172. ;; XXX: Replace with a Git commit id.
  173. (date->string (current-date 0) "~Y~m~d.~H"))
  174. (define guile-gcrypt
  175. ;; The host Guix may or may not have 'guile-gcrypt', which was introduced in
  176. ;; August 2018. If it has it, it's at least version 0.1.0, which is good
  177. ;; enough. If it doesn't, specify our own package because the target Guix
  178. ;; requires it.
  179. (match (find-best-packages-by-name "guile-gcrypt" #f)
  180. (()
  181. (package
  182. (name "guile-gcrypt")
  183. (version "0.1.0")
  184. (home-page "https://notabug.org/cwebber/guile-gcrypt")
  185. (source (origin
  186. (method url-fetch)
  187. (uri (string-append home-page "/archive/v" version ".tar.gz"))
  188. (sha256
  189. (base32
  190. "1gir7ifknbmbvjlql5j6wzk7bkb5lnmq80q59ngz43hhpclrk5k3"))
  191. (file-name (string-append name "-" version ".tar.gz"))))
  192. (build-system gnu-build-system)
  193. (native-inputs
  194. `(("pkg-config" ,(specification->package "pkg-config"))
  195. ("autoconf" ,(specification->package "autoconf"))
  196. ("automake" ,(specification->package "automake"))
  197. ("texinfo" ,(specification->package "texinfo"))))
  198. (inputs
  199. `(("guile" ,(specification->package "guile"))
  200. ("libgcrypt" ,(specification->package "libgcrypt"))))
  201. (synopsis "Cryptography library for Guile using Libgcrypt")
  202. (description
  203. "Guile-Gcrypt provides a Guile 2.x interface to a subset of the
  204. GNU Libgcrypt crytographic library. It provides modules for cryptographic
  205. hash functions, message authentication codes (MAC), public-key cryptography,
  206. strong randomness, and more. It is implemented using the foreign function
  207. interface (FFI) of Guile.")
  208. (license #f))) ;license:gpl3+
  209. ((package . _)
  210. package)))
  211. (define* (build-program source version
  212. #:optional (guile-version (effective-version))
  213. #:key (pull-version 0))
  214. "Return a program that computes the derivation to build Guix from SOURCE."
  215. (define select?
  216. ;; Select every module but (guix config) and non-Guix modules.
  217. (match-lambda
  218. (('guix 'config) #f)
  219. (('guix _ ...) #t)
  220. (('gnu _ ...) #t)
  221. (_ #f)))
  222. (define fake-gcrypt-hash
  223. ;; Fake (gcrypt hash) module; see below.
  224. (scheme-file "hash.scm"
  225. #~(define-module (gcrypt hash)
  226. #:export (sha1 sha256))))
  227. (with-imported-modules `(((guix config)
  228. => ,(make-config.scm))
  229. ;; To avoid relying on 'with-extensions', which was
  230. ;; introduced in 0.15.0, provide a fake (gcrypt
  231. ;; hash) just so that we can build modules, and
  232. ;; adjust %LOAD-PATH later on.
  233. ((gcrypt hash) => ,fake-gcrypt-hash)
  234. ,@(source-module-closure `((guix store)
  235. (guix self)
  236. (guix derivations)
  237. (gnu packages bootstrap))
  238. (list source)
  239. #:select? select?))
  240. (gexp->script "compute-guix-derivation"
  241. #~(begin
  242. (use-modules (ice-9 match))
  243. (eval-when (expand load eval)
  244. ;; Don't augment '%load-path'.
  245. (unsetenv "GUIX_PACKAGE_PATH")
  246. ;; (gnu packages …) modules are going to be looked up
  247. ;; under SOURCE. (guix config) is looked up in FRONT.
  248. (match (command-line)
  249. ((_ source _ ...)
  250. (match %load-path
  251. ((front _ ...)
  252. (unless (string=? front source) ;already done?
  253. (set! %load-path
  254. (list source
  255. (string-append #$guile-gcrypt
  256. "/share/guile/site/"
  257. (effective-version))
  258. front)))))))
  259. ;; Only load Guile-Gcrypt, our own modules, or those
  260. ;; of Guile.
  261. (match %load-compiled-path
  262. ((front _ ... sys1 sys2)
  263. (unless (string-prefix? #$guile-gcrypt front)
  264. (set! %load-compiled-path
  265. (list (string-append #$guile-gcrypt
  266. "/lib/guile/"
  267. (effective-version)
  268. "/site-ccache")
  269. front sys1 sys2))))))
  270. (use-modules (guix store)
  271. (guix self)
  272. (guix derivations)
  273. (srfi srfi-1))
  274. (define (spin system)
  275. (define spin
  276. (circular-list "-" "\\" "|" "/" "-" "\\" "|" "/"))
  277. (format (current-error-port)
  278. "Computing Guix derivation for '~a'... "
  279. system)
  280. (let loop ((spin spin))
  281. (display (string-append "\b" (car spin))
  282. (current-error-port))
  283. (force-output (current-error-port))
  284. (sleep 1)
  285. (loop (cdr spin))))
  286. (match (command-line)
  287. ((_ source system version protocol-version)
  288. ;; The current input port normally wraps a file
  289. ;; descriptor connected to the daemon, or it is
  290. ;; connected to /dev/null. In the former case, reuse
  291. ;; the connection such that we inherit build options
  292. ;; such as substitute URLs and so on; in the latter
  293. ;; case, attempt to open a new connection.
  294. (let* ((proto (string->number protocol-version))
  295. (store (if (integer? proto)
  296. (port->connection (duplicate-port
  297. (current-input-port)
  298. "w+0")
  299. #:version proto)
  300. (open-connection))))
  301. (call-with-new-thread
  302. (lambda ()
  303. (spin system)))
  304. (display
  305. (and=>
  306. (run-with-store store
  307. (guix-derivation source version
  308. #$guile-version
  309. #:pull-version
  310. #$pull-version)
  311. #:system system)
  312. derivation-file-name))))))
  313. #:module-path (list source))))
  314. ;; The procedure below is our return value.
  315. (define* (build source
  316. #:key verbose? (version (date-version-string)) system
  317. (guile-version (match ((@ (guile) version))
  318. ("2.2.2" "2.2.2")
  319. (_ (effective-version))))
  320. (pull-version 0)
  321. #:allow-other-keys
  322. #:rest rest)
  323. "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
  324. files."
  325. ;; Build the build program and then use it as a trampoline to build from
  326. ;; SOURCE.
  327. (mlet %store-monad ((build (build-program source version guile-version
  328. #:pull-version pull-version))
  329. (system (if system (return system) (current-system)))
  330. (port ((store-lift nix-server-socket)))
  331. (major ((store-lift nix-server-major-version)))
  332. (minor ((store-lift nix-server-minor-version))))
  333. (mbegin %store-monad
  334. (show-what-to-build* (list build))
  335. (built-derivations (list build))
  336. ;; Use the port beneath the current store as the stdin of BUILD. This
  337. ;; way, we know 'open-pipe*' will not close it on 'exec'. If PORT is
  338. ;; not a file port (e.g., it's an SSH channel), then the subprocess's
  339. ;; stdin will actually be /dev/null.
  340. (let* ((pipe (with-input-from-port port
  341. (lambda ()
  342. (setenv "GUILE_WARN_DEPRECATED" "no") ;be quiet and drive
  343. (open-pipe* OPEN_READ
  344. (derivation->output-path build)
  345. source system version
  346. (if (file-port? port)
  347. (number->string
  348. (logior major minor))
  349. "none")))))
  350. (str (get-string-all pipe))
  351. (status (close-pipe pipe)))
  352. (match str
  353. ((? eof-object?)
  354. (error "build program failed" (list build status)))
  355. ((? derivation-path? drv)
  356. (mbegin %store-monad
  357. (return (newline (current-output-port)))
  358. ((store-lift add-temp-root) drv)
  359. (return (read-derivation-from-file drv))))
  360. ("#f"
  361. ;; Unsupported PULL-VERSION.
  362. (return #f))
  363. ((? string? str)
  364. (error "invalid build result" (list build str))))))))
  365. ;; This file is loaded by 'guix pull'; return it the build procedure.
  366. build
  367. ;; Local Variables:
  368. ;; eval: (put 'with-load-path 'scheme-indent-function 1)
  369. ;; End:
  370. ;;; build-self.scm ends here