diff --git a/quicklisp/http.lisp b/quicklisp/http.lisp index d942fb8..0764466 100644 --- a/quicklisp/http.lisp +++ b/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)))