From 242ad41c0129eabfdc6678ae9eebd1c887ece55e Mon Sep 17 00:00:00 2001
From: David Thompson <davet@gnu.org>
Date: Tue, 28 Jun 2016 09:36:34 -0400
Subject: download: Use basic authentication when userinfo is present in URI.

* 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.
---
 guix/build/download.scm | 14 ++++++++++++--
 guix/download.scm       |  3 ++-
 2 files changed, 14 insertions(+), 3 deletions(-)

(limited to 'guix')

diff --git a/guix/build/download.scm b/guix/build/download.scm
index bd011ce878..103e784bb1 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -23,9 +23,11 @@
   #:use-module (web http)
   #:use-module ((web client) #:hide (open-socket-for-uri))
   #:use-module (web response)
+  #:use-module (guix base64)
   #:use-module (guix ftp-client)
   #:use-module (guix build utils)
   #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-19)
@@ -598,14 +600,22 @@ FILE on success."
         (string>? (version) "2.0.7")))
 
   (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
       ;; you're a spammer.  So work around that.
       (User-Agent . "GNU Guile")
 
       ;; Some servers, such as https://alioth.debian.org, return "406 Not
       ;; 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)
                  (open-connection-for-uri uri #:timeout timeout))
diff --git a/guix/download.scm b/guix/download.scm
index 9b238dcbdf..c3f34f5520 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -328,7 +328,8 @@ in the store."
                             #:modules '((guix build download)
                                         (guix build utils)
                                         (guix ftp-client)
-                                        (guix base32))
+                                        (guix base32)
+                                        (guix base64))
 
                             ;; Use environment variables and a fixed script
                             ;; name so there's only one script in store for
-- 
cgit v1.2.3