(in-package :http-utils) (defparameter *gdft-user-agent* "GDFT/0.1") (defconstant +crlf+ (let ((str (make-string 2))) (setf (aref str 0) #\Return (aref str 1) #\Linefeed) str)) (defvar *http-debug-stream* nil) (defmacro with-http-debugging-stream ((stream) &body body) `(let ((*http-debug-stream* ,stream)) ,@body)) ;; Note that a :utf-8 encoding of a null in a latin-1 string is ;; also null, and vice versa. So don't have to worry about ;; null-termination or length. (If we were translating to/from ;; :unicode, this would become an issue.) (defun translate-string-via-fli (string from to) (fli:with-foreign-string (ptr elements bytes :external-format from) string (declare (ignore elements bytes)) (fli:convert-from-foreign-string ptr :external-format to))) ;; convert between utf8 and latin-1 (defun encode-lisp-string (string) (translate-string-via-fli string :utf-8 :latin-1)) (defun decode-external-string (string) (translate-string-via-fli string :latin-1 :utf-8)) (defun format-to-http (stream string &rest args) (let ((formatted-string (apply #'format nil string args))) (when *http-debug-stream* (princ formatted-string *http-debug-stream*)) (princ (encode-lisp-string formatted-string) stream))) (defun read-line-from-http (stream &optional content-length) (let ((line (if content-length (let ((seq (make-string content-length))) (read-sequence seq stream :end content-length) seq) (read-line stream nil nil)))) (when line (decode-external-string line)))) (defun skip-http-headers (stream) (let ((content-length nil)) (loop for line = (read-line-from-http stream) while (and line (string/= line " ")) when (string-equal line "Content-Length:" :end1 (min (length line) #.(length "Content-Length:"))) do (setq content-length (parse-integer line :start #.(1+ (length "Content-Length:")) :junk-allowed t)) when *http-debug-stream* do (print line)) Content-Length)) (defun html-response-p (line) (or (string-equal line "") (string-equal line "= (1+ i) len) for pad2p = (>= (+ i 2) len) for b1 = (aref byte-array i) for b2 = (if pad1p 0 (aref byte-array (1+ i))) for b3 = (if pad2p 0 (aref byte-array (+ i 2))) for ch1 = (ldb (byte 6 2) b1) for ch2 = (dpb (ldb (byte 2 0) b1) (byte 2 4) (ldb (byte 4 4) b2)) for ch3 = (dpb (ldb (byte 4 0) b2) (byte 4 2) (ldb (byte 2 6) b3)) for ch4 = (ldb (byte 6 0) b3) do (setf (aref result j) (aref +base64-lookup+ ch1) (aref result (1+ j)) (aref +base64-lookup+ ch2) (aref result (+ j 2)) (if pad1p +base64-pad+ (aref +base64-lookup+ ch3)) (aref result (+ j 3)) (if pad2p +base64-pad+ (aref +base64-lookup+ ch4)))) result)) (defun base64-decode (string) (let ((result (make-array (- (/ (* 3 (length string)) 4) (count +base64-pad+ string :test #'char=)) :element-type '(unsigned-byte 8)))) (loop for i below (length string) by 4 for j from 0 by 3 for ch1 = (aref string i) for ch2 = (aref string (1+ i)) for ch3 = (aref string (+ i 2)) for ch4 = (aref string (+ i 3)) for pad1p = (char= ch3 +base64-pad+) for pad2p = (char= ch4 +base64-pad+) for bitblock1 = (position ch1 +base64-lookup+ :test #'char=) for bitblock2 = (position ch2 +base64-lookup+ :test #'char=) for bitblock3 = (unless pad1p (position ch3 +base64-lookup+ :test #'char=)) for bitblock4 = (unless pad2p (position ch4 +base64-lookup+ :test #'char=)) for byte1 = (dpb bitblock1 (byte 6 2) (ldb (byte 2 4) bitblock2)) for byte2 = (unless pad1p (dpb (ldb (byte 4 0) bitblock2) (byte 4 4) (ldb (byte 4 2) bitblock3))) for byte3 = (unless pad2p (dpb (ldb (byte 2 0) bitblock3) (byte 2 6) bitblock4)) do (progn (setf (aref result j) byte1) (unless pad1p (setf (aref result (1+ j)) byte2)) (unless pad2p (setf (aref result (+ j 2)) byte3)))) result))