me/guix
Archived
1
0
Fork 0
Code Activity

download: Use basic authentication when userinfo is present in URI.

Browse source 
* guix/download.scm (url-fetch): Include (guix base64) module on the
  build-side.
* guix/build/download.scm (http-fetch): Add "Authorization" header when
  userinfo is present in the URI.
This commit is contained in:
David Thompson 2016-06-28 09:36:34 -04:00
parent 8dec2229a2
commit 242ad41c01
No known key found for this signature in database
GPG key ID: 8328C7470FF1D807
2 changed files with 14 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
guix/build/download.scm
View file

@ -23,9 +23,11 @@
#:use-module (web http) #:use-module (web http)
#:use-module ((web client) #:hide (open-socket-for-uri)) #:use-module ((web client) #:hide (open-socket-for-uri))
#:use-module (web response) #:use-module (web response)
#:use-module (guix base64)
#:use-module (guix ftp-client) #:use-module (guix ftp-client)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (rnrs io ports) #:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
@ -598,14 +600,22 @@ FILE on success."
(string>? (version) "2.0.7"))) (string>? (version) "2.0.7")))
(define headers (define headers
'(;; Some web sites, such as http://dist.schmorp.de, would block you if `(;; Some web sites, such as http://dist.schmorp.de, would block you if
;; there's no 'User-Agent' header, presumably on the assumption that ;; there's no 'User-Agent' header, presumably on the assumption that
;; you're a spammer. So work around that. ;; you're a spammer. So work around that.
(User-Agent . "GNU Guile") (User-Agent . "GNU Guile")
;; Some servers, such as https://alioth.debian.org, return "406 Not ;; Some servers, such as https://alioth.debian.org, return "406 Not
;; Acceptable" when not explicitly told that everything is accepted. ;; Acceptable" when not explicitly told that everything is accepted.
(Accept . "*/*"))) (Accept . "*/*")
;; Basic authentication, if needed.
,@(match (uri-userinfo uri)
((? string? str)
`((Authorization . ,(string-append "Basic "
(base64-encode
(string->utf8 str))))))
(_ '()))))
(let*-values (((connection) (let*-values (((connection)
(open-connection-for-uri uri #:timeout timeout)) (open-connection-for-uri uri #:timeout timeout))

3
guix/download.scm
View file

@ -328,7 +328,8 @@ in the store."
#:modules '((guix build download) #:modules '((guix build download)
(guix build utils) (guix build utils)
(guix ftp-client) (guix ftp-client)
(guix base32)) (guix base32)
(guix base64))
;; Use environment variables and a fixed script ;; Use environment variables and a fixed script
;; name so there's only one script in store for ;; name so there's only one script in store for