01/03: http-client: Support basic authentication.

[Ricardo Wurmus]

rekado pushed a commit to branch master
in repository guix.

commit 0cb5bc2cffbc176afa55a116730f81f5afc2dde5
Author: Ricardo Wurmus <address@hidden>
Date:   Wed Dec 16 11:12:46 2015 +0100

    http-client: Support basic authentication.
    
    * guix/http-client.scm (http-fetch): Add Authorization header to request
      when the URI contains userinfo.
---
 guix/http-client.scm |   15 ++++++++++++---
 1 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/guix/http-client.scm b/guix/http-client.scm
index eb2c3f4..c7cbc82 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -32,6 +32,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (guix ui)
   #:use-module (guix utils)
+  #:use-module (guix base64)
   #:use-module ((guix build utils)
                 #:select (mkdir-p dump-port))
   #:use-module ((guix build download)
@@ -210,15 +211,23 @@ Raise an '&http-get-error' condition if downloading 
fails."
   (let loop ((uri (if (string? uri)
                       (string->uri uri)
                       uri)))
-    (let ((port (or port (open-connection-for-uri uri))))
+    (let ((port (or port (open-connection-for-uri uri)))
+          (auth-header (match (uri-userinfo uri)
+                         ((? string? str)
+                          (list (cons 'Authorization
+                                      (string-append "Basic "
+                                                     (base64-encode
+                                                      (string->utf8 str))))))
+                         (_ '()))))
       (unless buffered?
         (setvbuf port _IONBF))
       (let*-values (((resp data)
                      ;; Try hard to use the API du jour to get an input port.
                      (if (guile-version>? "2.0.7")
-                         (http-get uri #:streaming? #t #:port port) ; 2.0.9+
+                         (http-get uri #:streaming? #t #:port port
+                                   #:headers auth-header) ; 2.0.9+
                          (http-get* uri #:decode-body? text?        ; 2.0.7
-                                    #:port port)))
+                                    #:port port #:headers auth-header)))
                     ((code)
                      (response-code resp)))
         (case code