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.
 
 
 
 
 
 

164 lines
6.0 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 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 pull)
  19. #:use-module (guix ui)
  20. #:use-module (guix store)
  21. #:use-module (guix config)
  22. #:use-module (guix packages)
  23. #:use-module (guix derivations)
  24. #:use-module (guix download)
  25. #:use-module (guix gexp)
  26. #:use-module (guix monads)
  27. #:use-module (gnu packages base)
  28. #:use-module (gnu packages guile)
  29. #:use-module ((gnu packages bootstrap)
  30. #:select (%bootstrap-guile))
  31. #:use-module (gnu packages compression)
  32. #:use-module (gnu packages gnupg)
  33. #:use-module (srfi srfi-1)
  34. #:use-module (srfi srfi-37)
  35. #:export (guix-pull))
  36. (define %snapshot-url
  37. ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download"
  38. "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
  39. )
  40. (define* (unpack tarball #:key verbose?)
  41. "Return a derivation that unpacks TARBALL into STORE and compiles Scheme
  42. files."
  43. (define builder
  44. #~(begin
  45. (use-modules (guix build pull))
  46. (build-guix #$output #$tarball
  47. ;; XXX: This is not perfect, enabling VERBOSE? means
  48. ;; building a different derivation.
  49. #:debug-port (if #$verbose?
  50. (current-error-port)
  51. (%make-void-port "w"))
  52. #:tar #$tar
  53. #:gzip #$gzip
  54. #:gcrypt #$libgcrypt)))
  55. (gexp->derivation "guix-latest" builder
  56. #:modules '((guix build pull)
  57. (guix build utils))))
  58. ;;;
  59. ;;; Command-line options.
  60. ;;;
  61. (define %default-options
  62. ;; Alist of default option values.
  63. `((tarball-url . ,%snapshot-url)))
  64. (define (show-help)
  65. (display (_ "Usage: guix pull [OPTION]...
  66. Download and deploy the latest version of Guix.\n"))
  67. (display (_ "
  68. --verbose produce verbose output"))
  69. (display (_ "
  70. --url=URL download the Guix tarball from URL"))
  71. (display (_ "
  72. --bootstrap use the bootstrap Guile to build the new Guix"))
  73. (newline)
  74. (display (_ "
  75. -h, --help display this help and exit"))
  76. (display (_ "
  77. -V, --version display version information and exit"))
  78. (newline)
  79. (show-bug-report-information))
  80. (define %options
  81. ;; Specifications of the command-line options.
  82. (list (option '("verbose") #f #f
  83. (lambda (opt name arg result)
  84. (alist-cons 'verbose? #t result)))
  85. (option '("url") #t #f
  86. (lambda (opt name arg result)
  87. (alist-cons 'tarball-url arg
  88. (alist-delete 'tarball-url result))))
  89. (option '("bootstrap") #f #f
  90. (lambda (opt name arg result)
  91. (alist-cons 'bootstrap? #t result)))
  92. (option '(#\h "help") #f #f
  93. (lambda args
  94. (show-help)
  95. (exit 0)))
  96. (option '(#\V "version") #f #f
  97. (lambda args
  98. (show-version-and-exit "guix pull")))))
  99. (define what-to-build
  100. (store-lift show-what-to-build))
  101. (define indirect-root-added
  102. (store-lift add-indirect-root))
  103. (define* (build-and-install tarball config-dir
  104. #:key verbose?)
  105. "Build the tool from TARBALL, and install it in CONFIG-DIR."
  106. (mlet* %store-monad ((source (unpack tarball #:verbose? verbose?))
  107. (source-dir -> (derivation->output-path source))
  108. (to-do? (what-to-build (list source))))
  109. (if to-do?
  110. (mlet* %store-monad ((built? (built-derivations (list source))))
  111. (if built?
  112. (mlet* %store-monad
  113. ((latest -> (string-append config-dir "/latest"))
  114. (done (indirect-root-added latest)))
  115. (switch-symlinks latest source-dir)
  116. (format #t
  117. (_ "updated ~a successfully deployed under `~a'~%")
  118. %guix-package-name latest)
  119. (return #t))
  120. (leave (_ "failed to update Guix, check the build log~%"))))
  121. (begin
  122. (display (_ "Guix already up to date\n"))
  123. (return #t)))))
  124. (define (guix-pull . args)
  125. (define (parse-options)
  126. ;; Return the alist of option values.
  127. (args-fold* args %options
  128. (lambda (opt name arg result)
  129. (leave (_ "~A: unrecognized option~%") name))
  130. (lambda (arg result)
  131. (leave (_ "~A: unexpected argument~%") arg))
  132. %default-options))
  133. (with-error-handling
  134. (let* ((opts (parse-options))
  135. (store (open-connection))
  136. (url (assoc-ref opts 'tarball-url)))
  137. (let ((tarball (download-to-store store url "guix-latest.tar.gz")))
  138. (unless tarball
  139. (leave (_ "failed to download up-to-date source, exiting\n")))
  140. (parameterize ((%guile-for-build
  141. (package-derivation store
  142. (if (assoc-ref opts 'bootstrap?)
  143. %bootstrap-guile
  144. (canonical-package guile-2.0)))))
  145. (run-with-store store
  146. (build-and-install tarball (config-directory)
  147. #:verbose? (assoc-ref opts 'verbose?))))))))