From ec2653ef3991b91ce8e85036be0d0d3c539d6952 Mon Sep 17 00:00:00 2001
From: Tamura Shingo <tamura.shingo@gmail.com>
Date: Wed, 24 Jul 2013 22:22:20 +0900
Subject: [PATCH 1/3] add support proxy authentication

---
 http.lisp    | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 package.lisp |  4 +++
 setup.lisp   | 14 +++++++--
 3 files changed, 104 insertions(+), 2 deletions(-)

diff --git a/http.lisp b/http.lisp
index 62599ae..33e49c3 100644
--- a/http.lisp
+++ b/http.lisp
@@ -319,6 +319,8 @@
   (subseq (storage sink) 0))
 
 (defvar *proxy-url* (config-value "proxy-url"))
+(defvar *proxy-user* (config-value "proxy-user"))
+(defvar *proxy-pass* (config-value "proxy-pass"))
 
 (defun full-proxy-path (host port path)
   (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A"
@@ -354,6 +356,90 @@ information."
             (encode (lisp-implementation-type))
             (version-string (lisp-implementation-version)))))
 
+(defvar *BASE64TBL* "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+-")
+
+(defun to-bit (num)
+  "convert 1 octet to binary(0/1) list"
+  (loop for x from 7 downto 0 collect (ldb (byte 1 x) num)))
+
+(defun string-to-bit (str)
+  "convert string to binary(0/1) list"
+  (map 'list #'to-bit (map 'list #'char-code str)))
+
+(defun flatten (x)
+  "flatten list"
+  (labels ((rec (x acc)
+             (cond ((null x) acc)
+                   ((atom x) (cons x acc))
+                   (t (rec (car x) (rec (cdr x) acc))))))
+    (rec x nil)))
+
+(defun take-list (list num)
+  "return taken from list(first arguments) passed as the num(second argument) and rest of the list"
+  (labels ((take-n (list num acc)
+             (if (or (<= num 0)
+                     (null list))
+                 (values (nreverse acc) list)
+                 (take-n (cdr list) (- num 1) (cons (car list) acc)))))
+    (take-n list num '())))
+
+(defun split (list num)
+  "split list. each list has num(second arguments) items."
+  (labels ((split (list acc)
+             (multiple-value-bind (six rest)
+                 (take-list list num)
+               (if (null rest)
+                   (nreverse (cons six acc))
+                   (split rest (cons six acc))))))
+    (split list '())))
+
+(defun rpad (list padsize &key (pad 0))
+  "if each list's length less than padsize(second arguments), padding pad(default 0) on right side."
+  (labels ((right-padding (list padsize acc)
+             (if (null list)
+                 (nreverse acc)
+                 (let ((item (car list)))
+                   (if (< (length item) padsize)
+                       (right-padding (cdr list) padsize (cons
+                                                           (append
+                                                             item
+                                                             (make-list
+                                                               (- padsize (length item))
+                                                               :initial-element pad))
+                                                           acc))
+                       (right-padding (cdr list) padsize (cons item acc)))))))
+    (right-padding list padsize '())))
+
+(defun bit-to-num (list)
+  "convert binary(0/1) list to number"
+  (let ((ms (length list)))
+    (loop for x in list
+          for y downfrom (1- ms)
+          sum (ash x y))))
+
+
+(defun base64-enc (str)
+  "create base64 encoded string from argument"
+  (format nil "~{~{~A~}~}"
+    (rpad
+      (split
+        (map 'list #'(lambda (x)
+                       (aref *BASE64TBL* x))
+              (map 'list #'bit-to-num
+                   (rpad
+                     (split
+                       (flatten
+                         (string-to-bit str))
+                       6)
+                     6)))
+        4)
+    4 :pad #\=)))
+
+(defun make-basic-authentication (user password)
+  "create basic authentication string"
+  (base64-enc (format nil "~A:~A" user password)))
+
+
 (defun make-request-buffer (host port path &key (method "GET"))
   "Return an octet vector suitable for sending as an HTTP 1.1 request."
   (setf method (string method))
@@ -366,6 +452,8 @@ information."
       (add-line method " " path " HTTP/1.1")
       (add-line "Host: " host (if (= port 80) ""
                                   (format nil ":~D" port)))
+      (when (and *proxy-url* *proxy-user* *proxy-pass*)
+        (add-line "Proxy-Authorization: Basic " (make-basic-authentication *proxy-user* *proxy-pass*)))
       (add-line "Connection: close")
       (add-line "User-Agent: " (user-agent-string))
       (add-newline sink)
diff --git a/package.lisp b/package.lisp
index ce7f2fa..2f70e95 100644
--- a/package.lisp
+++ b/package.lisp
@@ -91,6 +91,8 @@
    "A simple HTTP client.")
   (:use #:cl #:ql-network #:ql-progress #:ql-config)
   (:export #:*proxy-url*
+           #:*proxy-user*
+           #:*proxy-pass*
            #:fetch
            #:hostname
            #:port
@@ -271,6 +273,8 @@
            #:*quicklisp-home*
            #:*initial-dist-url*
            #:*proxy-url*
+           #:*proxy-user*
+           #:*proxy-pass*
            #:config-value
            #:setup
            #:provided-systems
diff --git a/setup.lisp b/setup.lisp
index 1879532..27f7ea0 100644
--- a/setup.lisp
+++ b/setup.lisp
@@ -200,10 +200,20 @@ dependencies too if possible."
   (let ((bootstrap-package (find-package 'quicklisp-quickstart)))
     (when bootstrap-package
       (let* ((proxy (find-symbol (string '#:*proxy-url*) bootstrap-package))
-             (proxy-value (and proxy (symbol-value proxy))))
+             (proxy-value (and proxy (symbol-value proxy)))
+             (puser (find-symbol (string '#:*proxy-user*) bootstrap-package))
+             (puser-value (and puser (symbol-value puser)))
+             (ppass (find-symbol (string '#:*proxy-pass*) bootstrap-package))
+             (ppass-value (and ppass (symbol-value ppass))))
         (when (and proxy-value (not *proxy-url*))
           (setf *proxy-url* proxy-value)
-          (setf (config-value "proxy-url") proxy-value)))))
+          (setf (config-value "proxy-url") proxy-value))
+        (when (and puser-value (not *proxy-user*))
+          (setf *proxy-user* puser-value)
+          (setf (config-value "proxy-user") puser-value))
+        (when (and ppass-value (not *proxy-pass*))
+          (setf *proxy-pass* ppass-value)
+          (setf (config-value "proxy-pass") ppass-value)))))
   (unless (ignore-errors (truename (qmerge "dists/")))
     (let ((target (qmerge "dists/quicklisp/distinfo.txt")))
       (ensure-directories-exist target)

From 75ec907c9c0c78082e6e4f3c4b8ccc955938f826 Mon Sep 17 00:00:00 2001
From: Tamura Shingo <tamura.shingo@gmail.com>
Date: Fri, 30 Oct 2015 09:49:33 +0900
Subject: [PATCH 2/3] mod base64-enc

---
 quicklisp/http.lisp | 97 ++++++++++-----------------------------------
 1 file changed, 21 insertions(+), 76 deletions(-)

diff --git a/quicklisp/http.lisp b/quicklisp/http.lisp
index fc67658..ffc11ae 100644
--- a/quicklisp/http.lisp
+++ b/quicklisp/http.lisp
@@ -357,84 +357,29 @@ information."
             (encode (lisp-implementation-type))
             (version-string (lisp-implementation-version)))))
 
-(defvar *BASE64TBL* "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+-")
-
-(defun to-bit (num)
-  "convert 1 octet to binary(0/1) list"
-  (loop for x from 7 downto 0 collect (ldb (byte 1 x) num)))
-
-(defun string-to-bit (str)
-  "convert string to binary(0/1) list"
-  (map 'list #'to-bit (map 'list #'char-code str)))
-
-(defun flatten (x)
-  "flatten list"
-  (labels ((rec (x acc)
-             (cond ((null x) acc)
-                   ((atom x) (cons x acc))
-                   (t (rec (car x) (rec (cdr x) acc))))))
-    (rec x nil)))
-
-(defun take-list (list num)
-  "return taken from list(first arguments) passed as the num(second argument) and rest of the list"
-  (labels ((take-n (list num acc)
-             (if (or (<= num 0)
-                     (null list))
-                 (values (nreverse acc) list)
-                 (take-n (cdr list) (- num 1) (cons (car list) acc)))))
-    (take-n list num '())))
-
-(defun split (list num)
-  "split list. each list has num(second arguments) items."
-  (labels ((split (list acc)
-             (multiple-value-bind (six rest)
-                 (take-list list num)
-               (if (null rest)
-                   (nreverse (cons six acc))
-                   (split rest (cons six acc))))))
-    (split list '())))
-
-(defun rpad (list padsize &key (pad 0))
-  "if each list's length less than padsize(second arguments), padding pad(default 0) on right side."
-  (labels ((right-padding (list padsize acc)
-             (if (null list)
-                 (nreverse acc)
-                 (let ((item (car list)))
-                   (if (< (length item) padsize)
-                       (right-padding (cdr list) padsize (cons
-                                                           (append
-                                                             item
-                                                             (make-list
-                                                               (- padsize (length item))
-                                                               :initial-element pad))
-                                                           acc))
-                       (right-padding (cdr list) padsize (cons item acc)))))))
-    (right-padding list padsize '())))
-
-(defun bit-to-num (list)
-  "convert binary(0/1) list to number"
-  (let ((ms (length list)))
-    (loop for x in list
-          for y downfrom (1- ms)
-          sum (ash x y))))
-
-
 (defun base64-enc (str)
   "create base64 encoded string from argument"
-  (format nil "~{~{~A~}~}"
-    (rpad
-      (split
-        (map 'list #'(lambda (x)
-                       (aref *BASE64TBL* x))
-              (map 'list #'bit-to-num
-                   (rpad
-                     (split
-                       (flatten
-                         (string-to-bit str))
-                       6)
-                     6)))
-        4)
-    4 :pad #\=)))
+  (flet ((to-enc (x)
+           (aref "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+-" x))
+         (pad (enc-list)
+           (let ((pad-len (mod (- (length enc-list)) 4)))
+             (format nil "~{~C~}~{~C~}" enc-list
+                                        (make-sequence 'list pad-len :initial-element #\=)))))
+    (let ((enc '()))
+      (loop for ch in (map 'list #'char-code str)
+            for buf = ch then (logior (ash buf 8) ch)
+            for bitlen = 8 then (+ bitlen 8)
+            do (loop repeat (truncate bitlen 6)
+                  do
+                    (let* ((remain (- bitlen 6))
+                           (6bit (ldb (byte bitlen remain) buf)))
+                      (push (to-enc 6bit) enc)
+                      (setf buf (ldb (byte remain 0) buf))
+                      (setf bitlen (- bitlen 6))))
+            finally
+              (when (/= bitlen 0)
+                (push (to-enc (ash buf (- 6 bitlen))) enc)))
+      (pad (nreverse enc)))))
 
 (defun make-basic-authentication (user password)
   "create basic authentication string"

From a287a9d0fb66b09a60d925d16ead82b33e7da0e0 Mon Sep 17 00:00:00 2001
From: Tamura Shingo <tamura.shingo@gmail.com>
Date: Tue, 3 Nov 2015 11:24:18 +0900
Subject: [PATCH 3/3] support credentials embedded in *proxy-url*

---
 quicklisp/http.lisp    | 91 ++++++++++++++++++++++++++++++++----------
 quicklisp/package.lisp |  4 --
 2 files changed, 70 insertions(+), 25 deletions(-)

diff --git a/quicklisp/http.lisp b/quicklisp/http.lisp
index ffc11ae..efd5a4a 100644
--- a/quicklisp/http.lisp
+++ b/quicklisp/http.lisp
@@ -319,8 +319,6 @@
   (subseq (storage sink) 0))
 
 (defvar *proxy-url* (config-value "proxy-url"))
-(defvar *proxy-user* (config-value "proxy-user"))
-(defvar *proxy-pass* (config-value "proxy-pass"))
 
 (defun full-proxy-path (host port path)
   (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A"
@@ -389,21 +387,27 @@ information."
 (defun make-request-buffer (host port path &key (method "GET"))
   "Return an octet vector suitable for sending as an HTTP 1.1 request."
   (setf method (string method))
-  (when *proxy-url*
-    (setf path (full-proxy-path host port path)))
-  (let ((sink (make-instance 'octet-sink)))
-    (flet ((add-line (&rest strings)
-             (apply #'add-strings sink strings)
-             (add-newline sink)))
-      (add-line method " " path " HTTP/1.1")
-      (add-line "Host: " host (if (= port 80) ""
-                                  (format nil ":~D" port)))
-      (when (and *proxy-url* *proxy-user* *proxy-pass*)
-        (add-line "Proxy-Authorization: Basic " (make-basic-authentication *proxy-user* *proxy-pass*)))
-      (add-line "Connection: close")
-      (add-line "User-Agent: " (user-agent-string))
-      (add-newline sink)
-      (sink-buffer sink))))
+  (let ((proxy-user nil)
+        (proxy-pass nil))
+    (when *proxy-url*
+      (setf path (full-proxy-path host port path))
+      (when (need-proxyauthenticate-p *proxy-url*)
+        (let ((proxy (parse-urlstring *proxy-url* :proxy-auth t)))
+          (setf proxy-user (proxy-user proxy))
+          (setf proxy-pass (proxy-pass proxy)))))
+    (let ((sink (make-instance 'octet-sink)))
+      (flet ((add-line (&rest strings)
+               (apply #'add-strings sink strings)
+               (add-newline sink)))
+        (add-line method " " path " HTTP/1.1")
+        (add-line "Host: " host (if (= port 80) ""
+                                    (format nil ":~D" port)))
+        (when (and proxy-user proxy-pass)
+          (add-line "Proxy-Authorization: Basic " (make-basic-authentication proxy-user proxy-pass)))
+        (add-line "Connection: close")
+        (add-line "User-Agent: " (user-agent-string))
+        (add-newline sink)
+        (sink-buffer sink)))))
 
 (defun sink-until-matching (matcher cbuf)
   (let ((sink (make-instance 'octet-sink)))
@@ -635,11 +639,22 @@ the indexes in the header accordingly."
     :accessor path
     :initform "/")))
 
-(defun parse-urlstring (urlstring)
+(defclass proxy-url (url)
+  ((proxy-user
+    :initarg :proxy-user
+    :accessor proxy-user
+    :initform nil)
+   (proxy-pass
+    :initarg :proxy-pass
+    :accessor proxy-pass
+    :initform nil)))
+
+
+(defun parse-urlstring (urlstring &key (proxy-auth nil))
   (setf urlstring (string-trim " " urlstring))
   (let* ((pos (mismatch urlstring "http://" :test 'char-equal))
          (mark pos)
-         (url (make-instance 'url)))
+         (url (make-instance 'proxy-url)))
     (labels ((save ()
                (subseq urlstring mark pos))
              (mark ()
@@ -653,10 +668,35 @@ the indexes in the header accordingly."
                (case char
                  (#\/
                   (setf (port url) nil)
+                  (incf pos)
                   (mark)
                   #'in-path)
                  (t
-                  #'in-host)))
+                  (if proxy-auth
+                      #'in-proxy-user
+                      #'in-host))))
+             (in-proxy-user (char)
+               (case char
+                 (:end
+                  (error "~S is not a valid PROXY URL" urlstring))
+                 (#\:
+                  (setf (proxy-user url) (save))
+                  (incf pos)
+                  (mark)
+                  #'in-proxy-pass)
+                 (t
+                  #'in-proxy-user)))
+             (in-proxy-pass (char)
+               (case char
+                 (:end
+                  (error "~S is not a valid PROXY URL" urlstring))
+                 (#\@
+                  (setf (proxy-pass url) (save))
+                  (incf pos)
+                  (mark)
+                  #'in-host)
+                 (t
+                  #'in-proxy-pass)))
              (in-host (char)
                (case char
                  ((#\/ :end)
@@ -698,9 +738,13 @@ the indexes in the header accordingly."
          (setf state (funcall state (aref urlstring pos)))
          (incf pos))))))
 
+(defun need-proxyauthenticate-p (proxy-url)
+  (and (find #\@ proxy-url)
+       t))
+
 (defun url (thing)
   (if (stringp thing)
-      (parse-urlstring thing)
+      (parse-urlstring thing :proxy-auth (need-proxyauthenticate-p thing))
       thing))
 
 (defgeneric request-buffer (method url)
@@ -715,6 +759,11 @@ the indexes in the header accordingly."
           (and (/= 80 (port url)) (port url))
           (path url)))
 
+(defun proxyurlstring (proxy-url)
+  (format nil "~@[http://~A~]~@[:~D~]"
+          (hostname proxy-url)
+          (and (/= 80 (port proxy-url)) (port proxy-url))))
+
 (defmethod print-object ((url url) stream)
   (print-unreadable-object (url stream :type t)
     (prin1 (urlstring url) stream)))
diff --git a/quicklisp/package.lisp b/quicklisp/package.lisp
index 1200e66..8d0fc03 100644
--- a/quicklisp/package.lisp
+++ b/quicklisp/package.lisp
@@ -95,8 +95,6 @@
    "A simple HTTP client.")
   (:use #:cl #:ql-network #:ql-progress #:ql-config)
   (:export #:*proxy-url*
-           #:*proxy-user*
-           #:*proxy-pass*
            #:fetch
            #:hostname
            #:port
@@ -306,8 +304,6 @@
            #:*quicklisp-home*
            #:*initial-dist-url*
            #:*proxy-url*
-           #:*proxy-user*
-           #:*proxy-pass*
            #:config-value
            #:setup
            #:provided-systems