Changeset 14376


Ignore:
Timestamp:
Oct 26, 2010, 6:51:10 PM (9 years ago)
Author:
gz
Message:

Implement loading a file from a url, e.g. (load "http://beta.quicklisp.org/quicklisp.lisp")

Location:
trunk/source/level-1
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-files.lisp

    r14353 r14376  
    12451245            (*readtable* *readtable*))
    12461246        (load-from-stream file-name print))
     1247      (return-from %load file-name))
     1248    (when (and (stringp file-name)
     1249               (eql (length "http://") (string-lessp "http://" file-name)))
     1250      (when verbose
     1251        (format t "~&;Loading from URL ~S..." file-name)
     1252        (force-output))
     1253      (let* ((vec (if if-does-not-exist
     1254                    (snarf-url file-name)
     1255                    (handler-case (snarf-url file-name)
     1256                      (error () (return-from %load nil)))))
     1257             (*package* *package*)
     1258             (*readtable* *readtable*)
     1259             (*loading-file-source-file* file-name)
     1260             (*loading-files* (cons file-name (specialv *loading-files*))))
     1261        (with-input-from-vector (stream vec :external-format external-format)
     1262          (load-from-stream stream print)))
    12471263      (return-from %load file-name))
    12481264    (unless (streamp file-name)
  • trunk/source/level-1/l1-sockets.lisp

    r14153 r14376  
    15191519(defmethod stream-io-error ((stream socket) errno where)
    15201520  (socket-error stream where errno))
     1521
     1522
     1523;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     1524
     1525(defun snarf-url (url &key max-redirects (user-agent "CCL") &aux conn)
     1526  "GET the contents of the url as a (VECTOR (UNSIGNED-BYTE 8))"
     1527  (labels ((is-prefix (prefix string) (eql (length prefix) (string-lessp prefix string)))
     1528           (header (prefix lines)
     1529             (let ((line (find prefix lines :test #'is-prefix)))
     1530               (and line (string-trim ccl::wsp (subseq line (length prefix))))))
     1531           (header-value (prefix lines)
     1532             (let ((line (find prefix lines :test #'is-prefix)))
     1533               (and line (parse-integer line :start (length prefix)))))
     1534           (split-url (string)
     1535             (if (is-prefix "/" string)
     1536               (list nil 80 string)
     1537               (if (not (is-prefix "http://" string))
     1538                 (error "Unknown scheme in ~s" string)
     1539                 (let* ((start (length "http://"))
     1540                        (end (length string))
     1541                        (ppos (or (position #\/ string :start start) end))
     1542                        (hend (or (position #\: string :start start :end ppos) ppos)))
     1543                   (list (subseq string start hend)
     1544                         (if (< hend ppos) (parse-integer string :start (1+ hend) :end ppos) 80)
     1545                         (if (< ppos end) (subseq string ppos) "/"))))))
     1546           (read-header (conn)
     1547             (loop as lines = (loop for line = (read-line conn nil)
     1548                                    until (= 0 (length line)) ; eof or empty line
     1549                                    collect line)
     1550                   as status = (let ((status-line (pop lines)))
     1551                                 (or (parse-integer status-line
     1552                                                    :start (position #\Space status-line)
     1553                                                    :junk-allowed t)
     1554                                     0))
     1555                   while (= status 100)
     1556                   finally (return (values lines status)))))
     1557    (unwind-protect
     1558       (loop with original-url = url
     1559             with redirects = (or max-redirects 20)
     1560             with (host port path) = (split-url original-url)
     1561             do (setq conn (make-socket :remote-host host
     1562                                        :remote-port port
     1563                                        :external-format '(:character-encoding :us-ascii
     1564                                                           :line-termination :crlf)))
     1565             do (format conn "GET ~a HTTP/1.1~%Host: ~a:~d~%Connection: close~%User-Agent: ~a~2%"
     1566                        path host port user-agent)
     1567             do (finish-output conn)
     1568             do (multiple-value-bind (header-lines status) (read-header conn)
     1569                  (when (= status 200)
     1570                    (let ((encoding (header "transfer-encoding:" header-lines)))
     1571                      ;; Here would recognize chunked encoding if cared about that...
     1572                      (when (and encoding (not (string-equal encoding "identity")))
     1573                        (error "Unsupported encoding ~s" encoding)))
     1574                    (return
     1575                      (let* ((count (header-value "content-length:" header-lines)))
     1576                        (if count
     1577                            (let ((vec (make-array count :element-type '(unsigned-byte 8))))
     1578                              (loop for i from 0 below count
     1579                                    do (setf (aref vec i) (read-byte conn)))
     1580                              vec)
     1581                            (let ((vec (make-array 1000
     1582                                                   :element-type '(unsigned-byte 8)
     1583                                                   :fill-pointer 0
     1584                                                   :adjustable t)))
     1585                              (loop for byte = (read-byte conn nil) while byte
     1586                                    do (vector-push-extend byte vec))
     1587                              (subseq vec 0 (length vec)))))))
     1588                  (unless (and (<= 300 status 399) (<= 0 (decf redirects)))
     1589                    (if (<= 300 status 399)
     1590                        (error "Too many redirects")
     1591                        (error "Unknown response ~s" status)))
     1592                  (let* ((new (or (header "location:" header-lines)
     1593                                  (error "Missing Location: header"))))
     1594                    (destructuring-bind (new-host new-port new-path) (split-url new)
     1595                      (when new-host
     1596                        (setq host new-host port new-port))
     1597                      (setq path new-path))
     1598                    (close conn)
     1599                    (setq conn nil)))
     1600      (when conn (close conn))))))
Note: See TracChangeset for help on using the changeset viewer.