simple-http.lisp

(defpackage #:simple-http
  (:use #:cl #:trivial-sockets)
  (:nicknames #:shttp)
  (:export #:http-get 
           #:http-post 
           #:http-head
	   #:http-download
           #:http-resolve
           #:escape-url-query
           
           #:header-value
           #:header-pair
           
           ;; conditions
           #:download-error
           #:download-url
	   #:download-command
           #:download-response

	   #:incompatible-stream-error
	   #:stream-from
	   #:stream-to

	   #:mismatched-download-size-error
	   #:download-length-claimed
	   #:download-length-downloaded)
  (:documentation 
   "simple-http is a simple networking library for doing HTTP POST and GET over a socket interface. It establishes a package simple-HTTP, also called SHTTP, from which the following functions are exported: http-get, http-post, escape-url-query and http-head."))

(in-package #:simple-http)

;;; ---------------------------------------------------------------------------
;;; constants
;;; ---------------------------------------------------------------------------

(defconstant +crlf+
  (if (boundp '+crlf+)
      (symbol-value '+crlf+)
      (concatenate 'string
                   (string (code-char 13))
                   (string (code-char 10)))))

;;; ---------------------------------------------------------------------------
;;; conditions
;;; ---------------------------------------------------------------------------

(define-condition trivial-http-error ()
  ())

;; from ASDF-Install
(define-condition download-error (trivial-http-error)
  ((url :initform "?" :initarg :url :reader download-url)
   (command :initform "?" :initarg :command :reader download-command)
   (response :initform "?" :initarg :response :reader download-response))
  (:report (lambda (c s)
	     (format s "Server responded ~A for ~A ~A"
		     (download-response c)
		     (download-command c)
                     (download-url c)))))

(define-condition incompatible-stream-error (trivial-http-error)
  ((from :initarg :from :reader stream-from)
   (to :initarg :to :reader stream-to))
  (:report (lambda (c s)
	     (format s "Incompatible streams ~A and ~A." 
		     (stream-from c) (stream-to c)))))

(define-condition mismatched-download-size-error (download-error)
                  ((length-claimed :initarg :length-claimed :reader download-length-claimed)
                   (length-downloaded :initarg :length-downloaded :reader download-length-downloaded))
  (:report (lambda (c s)
	     (format s "There was problem when downloading ~A. The header claimed size was ~D but only downloaded ~D"
		     (download-url c)
                     (download-length-claimed c) 
                     (download-length-downloaded c)))))

;;; ---------------------------------------------------------------------------
;;; http commands
;;; ---------------------------------------------------------------------------

(defun http-head (url)
  "Returns a list of two elements: a response code as an integer and an association list of headers returned from the server."
  (let* ((host (url-host url))
         (port (url-port url))
         (stream (open-stream host port)))
    (format stream "HEAD ~A HTTP/1.0~AHost: ~A~AUser-Agent: simple HTTP for Common Lisp~A~A"
	    url +crlf+ host +crlf+ +crlf+ +crlf+)
    (force-output stream)
    (prog1
	(list
	 (response-read-code stream)
	 (response-read-headers stream))
      (close stream))))

(defun http-get (url)
  "returns a list of three elements: a response code as integer, an association list of headers returned from the server, and a stream from which the response can be read."
  (let* ((host (url-host url))
         (port (url-port url))
         (stream (open-stream host port)))
    (format stream "GET ~A HTTP/1.0~AHost: ~A~AUser-Agent: simple HTTP for Common Lisp~A~A"
	    url +crlf+ host +crlf+ +crlf+ +crlf+)
    (force-output stream)
    (list
     (response-read-code stream)
     (response-read-headers stream)
     stream)))

(defun http-post (url content-type content)
  "given a URL, a MIME content type, and the content as a character stream, POST to the URL and return the list of three elements as described for HTTP-GET."
  (let* ((host (url-host url))
         (port (url-port url))
         (stream (open-stream host port)))
    (format stream "POST ~A HTTP/1.0~AHost: ~A~AUser-Agent: simple HTTP for Common Lisp~AContent-Type: ~A~AContent-Length: ~D~A~A~A" url +crlf+ host +crlf+ +crlf+ content-type +crlf+ (length content) +crlf+ +crlf+ content)
    (force-output stream)
    (list
     (response-read-code stream)
     (response-read-headers stream)
     stream)))

(defun http-resolve (url &key (http-method 'http-get)
		     (signal-error? t) (verbose? nil))
  "Similar to http-get, http-resolve returns a list of four elements: the HTTP response code, the headers, the stream and the reslved URL. HTTP-response resolves 301 and 302 responses, and signals an error on responses greater than 400. If there is not an error, then the caller is responsible for closing the HTTP stream."
  (handler-case 
      (destructuring-bind (response headers stream)
	  (block got
	    (loop
	       (destructuring-bind (response headers &optional stream)
		   (funcall http-method url)
		 (when verbose? 
		   (format *debug-io* "~% ~A -> ~A" url response))
		 (unless (member response '(301 302))	       
		   (return-from got (list response headers stream)))
		 (when stream 
		   (close stream))
		 (setf url (header-value :location headers)))))
	(when (>= response 400)
	  (when stream (close stream))
	  (when signal-error?
	    (error 'download-error 
		   :url url :command http-method :response response)))
	(list response headers stream url))
    (error (c)
      (when signal-error?
	(error c))
      (list nil nil nil nil))))

(defun http-download (url destination)
  "Resolves `url` using http-resolve and downloads the contents of the stream it to `destination`. Destination is assumed to be a file. Returns (as multiple values) the number of elements downloaded (e.g., bytes) and the actual URL."
  ;; mostly from ASDF-Install
  (destructuring-bind (response headers stream actual-url)
                      (http-resolve url)
    (declare (ignore response))
    (unwind-protect
    (let ((length (parse-integer (or (header-value :content-length headers) "")
				 :junk-allowed t))
          (total 0))
      #+:clisp (setf (stream-element-type stream)
		     '(unsigned-byte 8))
      (let ((ok? nil) (o nil))
	(unwind-protect
	     (progn
	       (setf o (apply #'open destination
			      :direction :output :if-exists :supersede
			      (open-file-arguments)))
	       (setf total (copy-stream stream o))
	       (when length
		 (unless (= length total)
		   (error 'mismatched-download-size-error
			  :length-claimed length
			  :length-downloaded total)))
	       (setf ok? t)
	       (values total actual-url))
	  (when o (close o :abort (null ok?))))))
      (close stream))))

;;; ---------------------------------------------------------------------------
;;; 'utilities'
;;; ---------------------------------------------------------------------------

(defun open-file-arguments ()
  (append 
   #+sbcl
   '(:external-format :latin1)
   #+(or :clisp :digitool (and :lispworks :win32))
   '(:element-type (unsigned-byte 8))))

(defun url-path (url)
  (assert (string-equal url "http://" :end1 7))
  (let* ((port-start (position #\: url :start 7))
	 (host-end (min (or (position #\/ url :start 7) (length url))
			(or port-start (length url)))))
    (subseq url host-end)))

(defun url-port (url)
  (assert (string-equal url "http://" :end1 7))
  (let ((path-start (position #\/ url :start 7)))
    (let ((port-start (position #\: url :start 7 :end path-start)))
      (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80))))

(defun url-host (url)
  (assert (string-equal url "http://" :end1 7))
  (let* ((port-start (position #\: url :start 7))
	 (host-end (min (or (position #\/ url :start 7) (length url))
			(or port-start (length url)))))
    (subseq url 7 host-end)))

(defun response-read-code (stream)
  (let* ((l (read-line stream))
            (space (position #\Space l)))
    (if space
      (parse-integer l :start (1+ space) :junk-allowed t)
      0)))

(defun response-read-headers (stream)
  (loop for line = (read-line stream nil nil)
     until (or (eql (length line) 0)
	       (eql (elt line 0) (code-char 13))
	       (eql (elt line 0) (code-char 10)))
     collect
       (let ((colon (position #\: line)))
         (if colon
	   (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
	         (string-trim (list #\Space (code-char 13) (code-char 10))
			      (subseq line (1+ colon))))
           nil))))

;;; SBCL has it's own but IMHO #+/#- gets crazy fast
(defvar *stream-buffer-size* 8192)

(defun copy-stream (from to)
  "Copy into TO from FROM until end of the input stream, in blocks of
*stream-buffer-size*.  The streams should have the same element type.
Returns the total number of 'elements' read and written."
  (unless (subtypep (stream-element-type to) (stream-element-type from))
    (error 'incompatible-stream-error
	   :from from :to to))
  (let ((buf (make-array *stream-buffer-size*
			 :element-type (stream-element-type from)))
        (total 0))
    (loop
      (let ((pos #-(or :clisp :cmu) (read-sequence buf from)
                 #+:clisp (ext:read-byte-sequence buf from :no-hang nil)
                 #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
        (when (zerop pos) (return total))
        (incf total pos)
        (write-sequence buf to :end pos)))))

;; this next method stolen from Araneida

(defun url-reserved-character-p (c)
  (not (or (member c '(#\- #\_ #\. #\! #\~ #\* #\' #\( #\) ))
           (alphanumericp c))))

(defun escape-url-query (query)
  "Escapes a query string in accordance with the HTTP specification."
  (apply #'concatenate 'string
   (loop for c across query
         if (url-reserved-character-p c)
         collect (format nil "%~2,'0X" (char-code c))
         else
         collect (string c))))

(defun header-value (name headers)
  "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the value if name is found or nil if it is not."
  (cdr (header-pair name headers)))

(defun header-pair (name headers)
  "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the \(name value\) pair if name is found or nil if it is not."
  (assoc name headers 
         :test (lambda (a b) 
                 (string-equal (symbol-name a) (symbol-name b)))))