(load "regexp") (load "sock") (load "http") (use-package "HTTP")
Making an HTTP HEAD request:
> (http-head "www.stat.umn.edu")
; => #S(HTTP::HTTP-HEADER HTTP::TABLE
; (("accept-ranges" "bytes")
; ("content-length" "7818")
; ("etag" "\"4c980-1e8a-348591b5\"")
; ("last-modified" "Wed, 03 Dec 1997 17:07:01 GMT")
; ("content-type" "text/html")
; ("connection" "close")
; ("server" "Apache/1.2b7")
; ("date" "Wed, 03 Dec 1997 23:47:49 GMT")
; ("http" "HTTP/1.1 200 OK")))
Getting a text URL:
> (http-get-content "www.umn.edu") "<html> <head> <meta name=\"DESCRIPTION\" content=\"No summary\"> <title>University of Minnesota</title> </head> <!-- BACKGROUND IMAGE --> <body background=\"/tc/images/burg2.jpg\" text=\"CCCCCC\" link=\"CCCCCC\" alink=\"777777\" vlink=\"777777\"> <center> <a href=\"/system/welcome.html\"><img border=0 src=\"/tc/images/UofM.jpg\" ALT= \"University of Minnesota graphic\"></a><p> ..."
Getting a Gopher URL:
> (gopher-get-content "gopher://gopher.stat.umn.edu") "1DOCS\t1/DOCS\tstpaul.stat.umn.edu\t70\t+ 1LIBRARY\t1/LIBRARY\tstpaul.stat.umn.edu\t70\t+ 1Paper Pre-Print Archive\t1/pre-prints\tstpaul.stat.umn.edu\t70\t+ 0README\t0/README\tstpaul.stat.umn.edu\t70\t+ 1SOFTWARE\t1/SOFTWARE\tstpaul.stat.umn.edu\t70\t+ ... . "
http.lsp.
<http.lsp>=
;;;;
;;;; HTTP Stuff
;;;;
;;;; Needs sock.lsp and regex.lsp
(defpackage "HTTP" (:use "XLISP" "SOCKETS" "REGEXP"))
(in-package "HTTP")
;;;;
;;;; Private Functions
;;;;
(defstruct http-config proxy-host proxy-port (user-agent "XLS http"))
(defvar *http-config* (make-http-config))
;;**** do this differently?
(defun get-default-port (proto)
(let* ((port-data '(("http" 80) ("telnet" 23) ("gopher" 70)))
(port (second (assoc proto port-data :test #'string-equal))))
(if port
port
(error "can't find default port for ~s protocol" proto))))
(defun parse-url (url)
(flet ((bad-url (url) (error "~s is not a proper URL" url)))
(let ((vals (regexp "^(([^:]+)://)?([^:/]+)(:([0-9]+))?(/.*)?" url)))
(if vals
(let ((proto (third vals))
(server (fourth vals))
(port (sixth vals))
(path (seventh vals)))
(unless proto (setf proto "http"))
(unless server (bad-url url))
(setf port (if port (parse-integer port) (get-default-port proto)))
(unless path (setf path "/"))
(values proto server port path))
(bad-url url)))))
(defun http-open (action command query url config)
(unless config (setf config *http-config*))
(multiple-value-bind (proto server port path)
(parse-url url)
(unless (equal proto "http") (error "~s is not the HTTP protocol" proto))
(let* ((proxy-host (http-config-proxy-host config))
(proxy-port (http-config-proxy-port config))
(myhost (if proxy-host proxy-host server))
(myport (if proxy-port proxy-port port))
(user-agent (http-config-user-agent config)))
(with-client-socket (sock myport myhost)
(http-open-write-command proxy-host command server port path sock)
(socket-write-line (format nil "User-Agent: ~s" user-agent) sock)
(socket-write-line (format nil "Host: ~a" server) sock)
(when query (http-open-write-query query sock))
(socket-write-line "" sock)
(socket-force-output sock)
(when action (funcall action sock))))))
(defun http-open-write-command (proxy command server port path sock)
(if proxy
(socket-write-line
(format nil "~a http://~/:~d~a HTTP/1.0" command server port path)
sock)
(socket-write-line (format nil "~a ~a HTTP/1.0" command path) sock)))
(defun http-open-write-query (query sock)
(socket-write-line (format nil "Content-Length: ~d" (length query)) sock)
(socket-write-line "" sock)
(socket-write-line query sock))
(defstruct (http-header (:print-function print-http-header)) table)
(defun print-http-header (header stream depth)
(let ((table (http-header-table header)))
(if *print-escape*
(format stream "#S(~s ~s ~s)" 'http-header 'table table)
(dolist (pair table)
(format stream "~&~a: ~a~%" (first pair) (second pair))))))
(defun set-http-header-value (header key val)
(let ((entry (assoc key (http-header-table header) :test #'string-equal)))
(if entry
(push val (rest entry))
(push (list key val) (http-header-table header)))))
(defsetf http-header-value set-http-header-value)
(defun http-header-value (header key)
(first (rest (assoc key (http-header-table header) :test #'string-equal))))
(defun http-header-content-length (header)
(parse-integer (http-header-value header "content-length")))
(defun http-header-http-status (header)
(second (regexp "HTTP/1\\.[0-9]* *([0-9].*$)"
(http-header-value header "http"))))
(defun read-http-header (sock)
(let ((code (socket-read-line sock nil nil))
(header (make-http-header)))
(when code
(setf (http-header-value header "http") code)
(loop
(let ((line (socket-read-line sock nil nil)))
(unless (and line (not (equal line ""))) (return header))
(let* ((kv (rest (regexp "^([^:]+): *(.*)$" line)))
(name (string-downcase (first kv)))
(value (second kv)))
(setf (http-header-value header name) value)))))))
(defun http-get (user-action command query url &optional config)
(flet ((action (sock)
(let* ((header (read-http-header sock))
(status (http-header-http-status header)))
(unless status (error "no status code"))
(case (char status 0)
(#\2 (when user-action (funcall user-action header sock)))
(#\3 (http-get user-action command query
(http-header-value header "location")
config))
(otherwise (error status))))))
(http-open #'action command query url config)))
;;;;
;;;; Public Functions
;;;;
(export '(http-head http-get-content gopher-get-content))
(defun http-head (url &optional config)
(http-get #'(lambda (h s) h) "HEAD" nil url config))
(defun http-get-content (url &optional config)
(flet ((action (header sock)
(let* ((size (http-header-content-length header))
(buf (make-string size)))
(dotimes (i size buf)
(setf (char buf i)
(int-char (sockets::socket-read-byte sock)))))))
(http-get #'action "GET" nil url config)))
(defun gopher-get-content (url)
(multiple-value-bind (proto server port path)
(parse-url url)
(with-client-socket (sock port server)
(socket-write-line path sock)
(socket-force-output sock)
(with-output-to-string (s)
(loop
(multiple-value-bind (line nlmissing)
(socket-read-line sock nil nil)
(unless line (return))
(write-string line s)
(unless nlmissing (terpri s))))))))
[1] Brent B. Welch. Practical Programming in Tcl and Tk. Prentice-Hall, Upper Saddle River, NJ, 2nd edition, 1997.