Paste number 12803: TRIVIAL-HTTP with user defined headers

Paste number 12803: TRIVIAL-HTTP with user defined headers
Pasted by: brianr
When:11 years, 5 months ago
Share:Tweet this! | http://paste.lisp.org/+9VN
Channel:None
Paste contents:
Raw Source | XML | Display As
(defpackage :trivial-http
  (:use :cl :trivial-sockets)
  (:nicknames :thttp)
  (:export :http-get :http-post :escape-url-query))
(in-package :trivial-http)

(defparameter *user-agent* "Trivial HTTP for Common Lisp")

(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)))

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

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

(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)))
	 (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
	       (string-trim (list #\Space (code-char 13) (code-char 10))
			    (subseq line (1+ colon)))))))

(defun http-get (url &key headers connection)
  "headers is an alist"
  (let* ((host (url-host url))
         (port (url-port url))
	 (http-headers (add-headers
			`(("Host" . ,host) ("User-Agent" . ,*user-agent*))
			headers :overwrite nil))
	 (stream (if connection
		     connection
		     (open-stream host port))))

    ;; Send the request
    (format stream "GET ~A HTTP/1.0~A" url +crlf+)
    (write-headers http-headers stream)
    (format stream "~A" +crlf+)	; write-headers writes a trailing +crlf+
    (force-output stream)

    ;; Read in the response
    (list
     (response-read-code stream)
     (response-read-headers stream)
     stream)))

(defun http-post (url content-type content &key headers connection)
  (let* ((host (url-host url))
         (port (url-port url))
	 (http-headers (add-headers
			`(("Host" . ,host) ("User-Agent" . ,*user-agent*)
			  ("Content-Type" . ,content-type)
			  ("Content-Length" . ,(length content)))
			headers :overwrite nil))
         (stream (if connection
		     connection
		     (open-stream host port))))
    
    ;; Send the request
    (format stream "POST ~A HTTP/1.0~A" url +crlf+)
    (write-headers http-headers stream)
    (format stream "~A" +crlf+) ; write-headers writes a trailing +crlf+
    (format stream "~A" content)
    (force-output stream)

    ;; Read in the response
    (list
     (response-read-code stream)
     (response-read-headers stream)
     stream)))

;; this next method stolen from Araneida

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

(defun escape-url-query (query)
  (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 write-headers (headers stream)
  (dolist (header headers)
    (format stream "~A: ~A~A" (car header) (cdr header) +crlf+)))

(defun add-headers (new-headers header-list &key (overwrite t))
  (dolist (header new-headers)
    (if (assoc (first header) header-list :test #'string=)
	(when overwrite
	  (setf (cdr (assoc (car header) header-list :test #'string=))
		(cdr header)))
	(push header header-list)))
  header-list)

This paste has no annotations.

Colorize as:
Show Line Numbers

Lisppaste pastes can be made by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively.