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.

267 lines
10 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2014, 2016, 2017 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 config)
  22. #:use-module (srfi srfi-1)
  23. #:use-module (srfi srfi-19)
  24. #:use-module (ice-9 match)
  25. #:export (build))
  26. ;;; Commentary:
  27. ;;;
  28. ;;; When loaded, this module returns a monadic procedure of at least one
  29. ;;; argument: the source tree to build. It returns a derivation that
  30. ;;; builds it.
  31. ;;;
  32. ;;; This file uses modules provided by the already-installed Guix. Those
  33. ;;; modules may be arbitrarily old compared to the version we want to
  34. ;;; build. Because of that, it must rely on the smallest set of features
  35. ;;; that are likely to be provided by the (guix) and (gnu) modules, and by
  36. ;;; Guile itself, forever and ever.
  37. ;;;
  38. ;;; Code:
  39. ;; The dependencies. Don't refer explicitly to the variables because they
  40. ;; could be renamed or shuffled around in modules over time. Conversely,
  41. ;; 'find-best-packages-by-name' is expected to always have the same semantics.
  42. (define libgcrypt
  43. (first (find-best-packages-by-name "libgcrypt" #f)))
  44. (define zlib
  45. (first (find-best-packages-by-name "zlib" #f)))
  46. (define gzip
  47. (first (find-best-packages-by-name "gzip" #f)))
  48. (define bzip2
  49. (first (find-best-packages-by-name "bzip2" #f)))
  50. (define xz
  51. (first (find-best-packages-by-name "xz" #f)))
  52. (define (false-if-wrong-guile package)
  53. "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g.,
  54. 2.0 instead of 2.2), otherwise return PACKAGE."
  55. (let ((guile (any (match-lambda
  56. ((label (? package? dep) _ ...)
  57. (and (string=? (package-name dep) "guile")
  58. dep)))
  59. (package-direct-inputs package))))
  60. (and (or (not guile)
  61. (string-prefix? (effective-version)
  62. (package-version guile)))
  63. package)))
  64. (define (package-for-current-guile . names)
  65. "Return the package with one of the given NAMES that depends on the current
  66. Guile major version (2.0 or 2.2), or #f if none of the packages matches."
  67. (let loop ((names names))
  68. (match names
  69. (()
  70. #f)
  71. ((name rest ...)
  72. (match (find-best-packages-by-name name #f)
  73. (()
  74. (loop rest))
  75. ((first _ ...)
  76. (or (false-if-wrong-guile first)
  77. (loop rest))))))))
  78. (define guile-json
  79. (package-for-current-guile "guile-json"
  80. "guile2.2-json"
  81. "guile2.0-json"))
  82. (define guile-ssh
  83. (package-for-current-guile "guile-ssh"
  84. "guile2.2-ssh"
  85. "guile2.0-ssh"))
  86. (define guile-git
  87. (package-for-current-guile "guile-git"
  88. "guile2.0-git"))
  89. (define guile-bytestructures
  90. (package-for-current-guile "guile-bytestructures"
  91. "guile2.0-bytestructures"))
  92. ;; The actual build procedure.
  93. (define (top-source-directory)
  94. "Return the name of the top-level directory of this source tree."
  95. (and=> (assoc-ref (current-source-location) 'filename)
  96. (lambda (file)
  97. (string-append (dirname file) "/.."))))
  98. (define (date-version-string)
  99. "Return the current date and hour in UTC timezone, for use as a poor
  100. person's version identifier."
  101. ;; XXX: Replace with a Git commit id.
  102. (date->string (current-date 0) "~Y~m~d.~H"))
  103. (define (guile-for-build)
  104. "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently
  105. running Guile."
  106. (package->derivation (cond-expand
  107. (guile-2.2
  108. (canonical-package
  109. (specification->package "guile@2.2")))
  110. (else
  111. (canonical-package
  112. (specification->package "guile@2.0"))))))
  113. ;; The procedure below is our return value.
  114. (define* (build source
  115. #:key verbose? (version (date-version-string))
  116. #:allow-other-keys
  117. #:rest rest)
  118. "Return a derivation that unpacks SOURCE into STORE and compiles Scheme
  119. files."
  120. ;; The '%xxxdir' variables were added to (guix config) in July 2016 so we
  121. ;; cannot assume that they are defined. Try to guess their value when
  122. ;; they're undefined (XXX: we get an incorrect guess when environment
  123. ;; variables such as 'NIX_STATE_DIR' are defined!).
  124. (define storedir
  125. (if (defined? '%storedir) %storedir %store-directory))
  126. (define localstatedir
  127. (if (defined? '%localstatedir) %localstatedir (dirname %state-directory)))
  128. (define sysconfdir
  129. (if (defined? '%sysconfdir) %sysconfdir (dirname %config-directory)))
  130. (define sbindir
  131. (if (defined? '%sbindir) %sbindir (dirname %guix-register-program)))
  132. (define builder
  133. #~(begin
  134. (use-modules (guix build pull))
  135. (letrec-syntax ((maybe-load-path
  136. (syntax-rules ()
  137. ((_ item rest ...)
  138. (let ((tail (maybe-load-path rest ...)))
  139. (if (string? item)
  140. (cons (string-append item
  141. "/share/guile/site/"
  142. #$(effective-version))
  143. tail)
  144. tail)))
  145. ((_)
  146. '()))))
  147. (set! %load-path
  148. (append
  149. (maybe-load-path #$guile-json #$guile-ssh
  150. #$guile-git #$guile-bytestructures)
  151. %load-path)))
  152. (letrec-syntax ((maybe-load-compiled-path
  153. (syntax-rules ()
  154. ((_ item rest ...)
  155. (let ((tail (maybe-load-compiled-path rest ...)))
  156. (if (string? item)
  157. (cons (string-append item
  158. "/lib/guile/"
  159. #$(effective-version)
  160. "/site-ccache")
  161. tail)
  162. tail)))
  163. ((_)
  164. '()))))
  165. (set! %load-compiled-path
  166. (append
  167. (maybe-load-compiled-path #$guile-json #$guile-ssh
  168. #$guile-git #$guile-bytestructures)
  169. %load-compiled-path)))
  170. ;; XXX: The 'guile-ssh' package prior to Guix commit 92b7258 was
  171. ;; broken: libguile-ssh could not be found. Work around that.
  172. ;; FIXME: We want Guile-SSH 0.10.2 or later anyway.
  173. #$(if (string-prefix? "0.9." (package-version guile-ssh))
  174. #~(setenv "LTDL_LIBRARY_PATH" (string-append #$guile-ssh "/lib"))
  175. #t)
  176. (build-guix #$output #$source
  177. #:system #$%system
  178. #:storedir #$storedir
  179. #:localstatedir #$localstatedir
  180. #:sysconfdir #$sysconfdir
  181. #:sbindir #$sbindir
  182. #:package-name #$%guix-package-name
  183. #:package-version #$version
  184. #:bug-report-address #$%guix-bug-report-address
  185. #:home-page-url #$%guix-home-page-url
  186. #:libgcrypt #$libgcrypt
  187. #:zlib #$zlib
  188. #:gzip #$gzip
  189. #:bzip2 #$bzip2
  190. #:xz #$xz
  191. ;; XXX: This is not perfect, enabling VERBOSE? means
  192. ;; building a different derivation.
  193. #:debug-port (if #$verbose?
  194. (current-error-port)
  195. (%make-void-port "w")))))
  196. (unless guile-git
  197. ;; XXX: Guix before February 2017 lacks a 'guile-git' package altogether.
  198. ;; If we try to upgrade anyway, the logic in (guix scripts pull) will not
  199. ;; build (guix git), which will leave us with an unusable 'guix pull'. To
  200. ;; avoid that, fail early.
  201. (format (current-error-port)
  202. "\
  203. Your installation is too old and lacks a '~a' package.
  204. Please upgrade to an intermediate version first, for instance with:
  205. guix pull --url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.13.0.tar.gz
  206. \n"
  207. (match (effective-version)
  208. ("2.0" "guile2.0-git")
  209. (_ "guile-git")))
  210. (exit 1))
  211. (mlet %store-monad ((guile (guile-for-build)))
  212. (gexp->derivation "guix-latest" builder
  213. #:modules '((guix build pull)
  214. (guix build utils)
  215. ;; Closure of (guix modules).
  216. (guix modules)
  217. (guix memoization)
  218. (guix sets))
  219. ;; Arrange so that our own (guix build …) modules are
  220. ;; used.
  221. #:module-path (list (top-source-directory))
  222. #:guile-for-build guile)))
  223. ;; This file is loaded by 'guix pull'; return it the build procedure.
  224. build
  225. ;; Local Variables:
  226. ;; eval: (put 'with-load-path 'scheme-indent-function 1)
  227. ;; End:
  228. ;;; build-self.scm ends here