HTTP Clients

Here is a little fun with the sockets and regular expression stuff. These are a couple of functions for talking to an HTTP server. Tis is based on the Tcl examples in Welch [cite welch97:_pract_progr_tcl_tk, P. 189ff].


These examplse assume you have done something like
(load "regexp")
(load "sock")
(load "http")
(use-package "HTTP")

Making an HTTP HEAD request:

> (http-head "")
;  (("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 "")
<meta name=\"DESCRIPTION\" content=\"No summary\">

<title>University of Minnesota</title>

<body background=\"/tc/images/burg2.jpg\" text=\"CCCCCC\" link=\"CCCCCC\"
alink=\"777777\" vlink=\"777777\">


<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://")
1Paper Pre-Print Archive\t1/pre-prints\\t70\t+


The implementation is in file 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
      (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
       (format nil "~a http://~/:~d~a HTTP/1.0" command server port path)
    (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)
           (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")
                   (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)
         (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.