add support proxy authentication

quicklisp/http.lisp

@@ -356,23 +356,60 @@ information."
             (encode (lisp-implementation-type))
             (version-string (lisp-implementation-version)))))
 
+(defun base64-enc (str)
+  "create base64 encoded string from argument"
+  (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"
+  (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))
-  (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 (integerp port)
-                                  (format nil ":~D" port)
-                                  ""))
-      (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 (integerp port)
+                                    (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)))
@@ -608,13 +645,24 @@ 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 (position #\: urlstring))
          (scheme (or (and pos (subseq  urlstring 0 pos)) "http"))
          (pos (mismatch urlstring "://" :test 'char-equal :start1 pos))
          (mark pos)
-         (url (make-instance 'url)))
+         (url (make-instance 'proxy-url)))
     (setf (scheme url) scheme)
     (labels ((save ()
                (subseq urlstring mark pos))
@@ -629,10 +677,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)
@@ -674,9 +747,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)
@@ -692,6 +769,11 @@ the indexes in the header accordingly."
           (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)))