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.

179 lines
5.8 KiB

  1. #!/bin/sh
  2. # aside from this initial boilerplate, this is actually -*- scheme -*- code
  3. prefix="@prefix@"
  4. datarootdir="@datarootdir@"
  5. GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
  6. export GUILE_LOAD_COMPILED_PATH
  7. main='(module-ref (resolve-interface '\''(guix-download)) '\'guix-download')'
  8. exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
  9. -c "(apply $main (cdr (command-line)))" "$@"
  10. !#
  11. ;;; Guix --- Nix package management from Guile.
  12. ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
  13. ;;;
  14. ;;; This file is part of Guix.
  15. ;;;
  16. ;;; Guix is free software; you can redistribute it and/or modify it
  17. ;;; under the terms of the GNU General Public License as published by
  18. ;;; the Free Software Foundation; either version 3 of the License, or (at
  19. ;;; your option) any later version.
  20. ;;;
  21. ;;; Guix is distributed in the hope that it will be useful, but
  22. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  23. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  24. ;;; GNU General Public License for more details.
  25. ;;;
  26. ;;; You should have received a copy of the GNU General Public License
  27. ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
  28. (define-module (guix-download)
  29. #:use-module (web uri)
  30. #:use-module (web client)
  31. #:use-module (guix ui)
  32. #:use-module (guix store)
  33. #:use-module (guix utils)
  34. #:use-module (guix ftp-client)
  35. #:use-module (ice-9 match)
  36. #:use-module (srfi srfi-1)
  37. #:use-module (srfi srfi-11)
  38. #:use-module (srfi srfi-26)
  39. #:use-module (srfi srfi-37)
  40. #:use-module (rnrs bytevectors)
  41. #:use-module (rnrs io ports)
  42. #:export (guix-download))
  43. (define (call-with-temporary-output-file proc)
  44. (let* ((template (string-copy "guix-download.XXXXXX"))
  45. (out (mkstemp! template)))
  46. (dynamic-wind
  47. (lambda ()
  48. #t)
  49. (lambda ()
  50. (proc template out))
  51. (lambda ()
  52. (false-if-exception (delete-file template))))))
  53. (define (http-fetch url port)
  54. "Fetch from URL over HTTP and write the result to PORT."
  55. (let-values (((response data) (http-get url #:decode-body? #f)))
  56. (put-bytevector port data)))
  57. (define (ftp-fetch url port)
  58. "Fetch from URL over FTP and write the result to PORT."
  59. (let* ((conn (ftp-open (uri-host url)
  60. (or (uri-port url) 21)))
  61. (dir (dirname (uri-path url)))
  62. (file (basename (uri-path url)))
  63. (in (ftp-retr conn file dir)))
  64. (define len 65536)
  65. (define buffer
  66. (make-bytevector len))
  67. (let loop ((count (get-bytevector-n! in buffer 0 len)))
  68. (if (eof-object? count)
  69. (ftp-close conn)
  70. (begin
  71. (put-bytevector port buffer 0 count)
  72. (loop (get-bytevector-n! in buffer 0 len)))))))
  73. ;;;
  74. ;;; Command-line options.
  75. ;;;
  76. (define %default-options
  77. ;; Alist of default option values.
  78. `((format . ,bytevector->nix-base32-string)))
  79. (define (show-version)
  80. (display "guix-download (@PACKAGE_NAME@) @PACKAGE_VERSION@\n"))
  81. (define (show-help)
  82. (display (_ "Usage: guix-download [OPTION]... URL
  83. Download the file at URL, add it to the store, and print its store path
  84. and the hash of its contents.\n"))
  85. (format #t (_ "
  86. -f, --format=FMT write the hash in the given format (default: `nix-base32')"))
  87. (newline)
  88. (display (_ "
  89. -h, --help display this help and exit"))
  90. (display (_ "
  91. -V, --version display version information and exit"))
  92. (newline)
  93. (format #t (_ "
  94. Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
  95. (define %options
  96. ;; Specifications of the command-line options.
  97. (list (option '(#\f "format") #t #f
  98. (lambda (opt name arg result)
  99. (define fmt-proc
  100. (match arg
  101. ("nix-base32"
  102. bytevector->nix-base32-string)
  103. ("base32"
  104. bytevector->base32-string)
  105. ((or "base16" "hex" "hexadecimal")
  106. bytevector->base16-string)
  107. (x
  108. (format (current-error-port)
  109. "unsupported hash format: ~a~%" arg))))
  110. (alist-cons 'format fmt-proc
  111. (alist-delete 'format result))))
  112. (option '(#\h "help") #f #f
  113. (lambda args
  114. (show-help)
  115. (exit 0)))
  116. (option '(#\V "version") #f #f
  117. (lambda args
  118. (show-version)
  119. (exit 0)))))
  120. ;;;
  121. ;;; Entry point.
  122. ;;;
  123. (define (guix-download . args)
  124. (define (parse-options)
  125. ;; Return the alist of option values.
  126. (args-fold args %options
  127. (lambda (opt name arg result)
  128. (leave (_ "~A: unrecognized option~%") name))
  129. (lambda (arg result)
  130. (alist-cons 'argument arg result))
  131. %default-options))
  132. (setlocale LC_ALL "")
  133. (textdomain "guix")
  134. (setvbuf (current-output-port) _IOLBF)
  135. (setvbuf (current-error-port) _IOLBF)
  136. (let* ((opts (parse-options))
  137. (store (open-connection))
  138. (uri (string->uri (assq-ref opts 'argument)))
  139. (fetch (case (uri-scheme uri)
  140. ((http) http-fetch)
  141. ((ftp) ftp-fetch)
  142. (else
  143. (begin
  144. (format (current-error-port)
  145. (_ "guix-download: ~a: unsupported URI scheme~%")
  146. (uri-scheme uri))
  147. (exit 1)))))
  148. (path (call-with-temporary-output-file
  149. (lambda (name port)
  150. (fetch uri port)
  151. (close port)
  152. (add-to-store store (basename (uri-path uri))
  153. #f #f "sha256" name))))
  154. (fmt (assq-ref opts 'format)))
  155. (format #t "~a~%~a~%"
  156. path
  157. (fmt (query-path-hash store path)))
  158. #t))