Merge pull request #124 from snmsts/support-scheme

add 'scheme' on ql-http:url. 'cl-http:fetch' support adding handler f…

Author: quicklisp

quicklisp/http.lisp

@@ -322,10 +322,10 @@
 
 (defun full-proxy-path (host port path)
   (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A"
-                       (= port 443)
+                       (eql port 443)
                        host
-                       (or (= port 80)
-                           (= port 443))
+                       (or (eql port 80)
+                           (eql port 443))
                        port
                        path))
 
@@ -365,7 +365,7 @@ information."
              (apply #'add-strings sink strings)
              (add-newline sink)))
       (add-line method " " path " HTTP/1.1")
-      (add-line "Host: " host (if (= port 80) ""
+      (add-line "Host: " host (if (eql port 80) ""
                                   (format nil ":~D" port)))
       (add-line "Connection: close")
       (add-line "User-Agent: " (user-agent-string))
@@ -589,24 +589,31 @@ the indexes in the header accordingly."
 ;;; HTTP URL parsing
 
 (defclass url ()
-  ((hostname
+  ((scheme
+    :initarg :scheme
+    :accessor scheme
+    :initform nil)
+   (hostname
     :initarg :hostname
     :accessor hostname
     :initform nil)
    (port
     :initarg :port
     :accessor port
-    :initform 80)
+    :initform nil)
    (path
     :initarg :path
     :accessor path
     :initform "/")))
 
 (defun parse-urlstring (urlstring)
   (setf urlstring (string-trim " " urlstring))
-  (let* ((pos (mismatch urlstring "http://" :test 'char-equal))
+  (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)))
+    (setf (scheme url) scheme)
     (labels ((save ()
                (subseq urlstring mark pos))
              (mark ()
@@ -673,13 +680,14 @@ the indexes in the header accordingly."
 (defgeneric request-buffer (method url)
   (:method (method url)
     (setf url (url url))
-    (make-request-buffer (hostname url) (port url) (path url)
+    (make-request-buffer (hostname url) (port url) (or (path url) 80)
                          :method method)))
 
 (defun urlstring (url)
-  (format nil "~@[http://~A~]~@[:~D~]~A"
+  (format nil "~@[~A://~]~@[~A~]~@[:~D~]~A"
+          (and (hostname url) (scheme url))
           (hostname url)
-          (and (/= 80 (port url)) (port url))
+          (port url)
           (path url)))
 
 (defmethod print-object ((url url) stream)
@@ -690,6 +698,8 @@ the indexes in the header accordingly."
   (setf url1 (url url1))
   (setf url2 (url url2))
   (make-instance 'url
+                 :scheme (or (scheme url1)
+                             (scheme url2))
                  :hostname (or (hostname url1)
                                (hostname url2))
                  :port (or (port url1)
@@ -780,10 +790,22 @@ the indexes in the header accordingly."
              (too-many-redirects-count condition)
              (too-many-redirects-url condition)))))
 
-(defun fetch (url file &key (follow-redirects t) quietly
+(defvar *fetch-scheme-functions*
+  '(("http" . http-fetch))
+  "assoc list to decide which scheme-function are called by FETCH function.")
+
+(defun fetch (url file &rest rest)
+  "Request URL and write the body of the response to FILE."
+  (let* ((url (merge-urls url *default-url-defaults*))
+         (call (cdr (assoc (scheme url) *fetch-scheme-functions* :test 'equal))))
+    (if call
+        (apply call (urlstring url) file rest)
+        (error "Unknow scheme ~S" url))))
+         
+(defun http-fetch (url file &key (follow-redirects t) quietly
               (if-exists :rename-and-delete)
               (maximum-redirects *maximum-redirects*))
-  "Request URL and write the body of the response to FILE."
+  "default scheme-function for http protocol."
   (setf url (merge-urls url *default-url-defaults*))
   (setf file (merge-pathnames file))
   (let ((redirect-count 0)
@@ -797,7 +819,7 @@ the indexes in the header accordingly."
        (error 'too-many-redirects
               :url original-url
               :redirect-count redirect-count))
-     (with-connection (connection (hostname connect-url) (port connect-url))
+     (with-connection (connection (hostname connect-url) (or (port connect-url) 80))
        (let ((cbuf (make-instance 'cbuf :connection connection))
              (request (request-buffer "GET" url)))
          (write-octets request connection)

quicklisp/package.lisp

@@ -96,6 +96,9 @@
   (:use #:cl #:ql-network #:ql-progress #:ql-config)
   (:export #:*proxy-url*
            #:fetch
+           #:http-fetch
+           #:*fetch-scheme-functions*
+           #:scheme
            #:hostname
            #:port
            #:path