new file mode 100644

@@ -0,0 +1,13 @@

+;;;; http-streams.asd

+

+(asdf:defsystem #:http-streams

+  :description "Describe http-streams here"

+  :author "Your Name <your.name@example.com>"

+  :license "Specify license here"

+  :depends-on (#:fwoar.lisputils

+               #:alexandria

+               #:serapeum)

+  :serial t

+  :components ((:file "package")

+               (:file "http-streams")))

+

new file mode 100644

@@ -0,0 +1,154 @@

+;;;; http-streams.lisp

+

+(in-package #:http-streams)

+

+;;; "http-streams" goes here. Hacks and glory await!

+

+(define-condition no-pipe (error)

+  ())

+

+(defclass piped-object ()

+  ((%pipe :reader pipe :initarg :pipe :initform (error 'no-pipe))))

+

+(defun end-line (stream)

+  (princ #. (coerce '(#\return #\newline) 'string) stream))

+

+(defmacro with-line ((stream) form)

+  `(prog1 ,form

+     (end-line ,stream)))

+

+(defun request (method path out-stream)

+  (with-line (out-stream)

+    (format out-stream "~a ~a HTTP/1.1" method path))

+  out-stream)

+

+(defun header (name value out-stream)

+  (with-line (out-stream)

+    (format out-stream "~a: ~a" name value))

+  out-stream)

+

+(defun body (value out-stream)

+  (end-line out-stream)

+  (etypecase value

+    (stream (loop with buffer = (make-string 1000)

+	       for end-read = (read-sequence buffer value)

+	       while (/= end-read 0)

+	       do (write-sequence buffer out-stream :end end-read)))

+    (string (write-sequence value out-stream))))

+

+(defmacro define-header-function (name header)

+  (alexandria:once-only (header)

+    `(defun ,name (value out-stream)

+       (header ,header value out-stream))))

+

+(defmacro define-header-functions (() &body definitions)

+  `(progn ,@(mapcar (fw.lu:destructuring-lambda ((name header))

+		      `(define-header-function ,name ,header))

+		    definitions)))

+

+(define-header-functions ()

+  (content-type "Content-Type")

+  (host "Host")

+  (accept "Accept")

+  (pragma "Pragma")

+  (user-agent "User-Agent")

+  (cache-control "Cache-Control")

+  (accept-encoding "Accept-Encoding")

+  (accept-language "Accept-Language"))

+

+(defmacro /> (name (&rest args)  &body funs)

+  (alexandria:with-gensyms (out)

+    `(defun ,name (,@args ,out)

+       ,@(mapcar (serapeum:op `(,@_ ,out))

+		 funs))))

+

+(/> build-subreddit-request (method subreddit)

+  (request method (format nil "/r/~a.rss" subreddit))

+  (accept "text/html")

+  (accept-language "en-US,en;q=0.8")

+  (cache-control "no-cache")

+  (host "www.reddit.com")

+  (pragma "no-cache")

+  (header "Upgrade-Insecure-Requests" "1")

+  (user-agent "foobar 0.0")

+  (body ""))

+

+(defun read-in-header (stream)

+  (values (read-line stream)

+	  (loop with headers = ()

+	     for line = (read-line stream nil)

+	     while line

+	     until (string= line "
")

+	     do

+	       (push (map 'list 'metatilities:strip-whitespace

+			  (fwoar.string-utils:split #\: (metatilities:strip-whitespace line) :count 2))

+		     headers)

+	     finally

+	       (return (nreverse headers)))))

+

+(defmacro with-subreddit-request ((subreddit stream) &body body)

+  (alexandria:with-gensyms (socket sock-stream ssl-stream)

+    `(usocket:with-client-socket (,socket ,sock-stream "reddit.com" 443 :element-type '(unsigned-byte 8))

+       (let* ((,ssl-stream (cl+ssl:make-ssl-client-stream ,sock-stream :hostname "reddit.com"))

+	      (,stream (flexi-streams:make-flexi-stream ,ssl-stream :external-format :iso-8859-1)))

+	 (build-subreddit-request :GET ,subreddit ,stream)

+	 (finish-output ,stream)

+	 (unwind-protect (progn ,@body)

+	   (close ,ssl-stream))))))

+

+(defun get-header (name headers)

+  (cadr (assoc name headers :test 'equalp)))

+

+(defun get-content-length (headers)

+  (parse-integer (get-header "Content-Length" headers)))

+

+(defmacro with-parsed-response (char-stream (result headers reply-buf content-length) &body body)

+  (alexandria:once-only (char-stream)

+    `(multiple-value-bind (,result ,headers) (read-in-header ,char-stream)

+       (let* ((,reply-buf (make-string (get-content-length ,headers)))

+	      (,content-length (read-sequence ,reply-buf ,char-stream)))

+	 ,@body))))

+

+(defun get-subreddit-feed (&optional (subreddit "lisp"))

+  (with-subreddit-request (subreddit char-stream)

+    (with-parsed-response char-stream (result headers reply-buf content-length)

+      (values reply-buf

+	      result

+	      headers

+	      content-length))))

+

+

+#|

+(defun get-subreddit-feed ()

+  (usocket:with-client-socket (so st "reddit.com" 443 :element-type '(unsigned-byte 8))

+    (let* ((ssl-stream (cl+ssl:make-ssl-client-stream st :hostname "reddit.com"))

+	   (char-stream (flexi-streams:make-flexi-stream ssl-stream :external-format :iso-8859-1)))

+      (unwind-protect (locally (declare (optimize (debug 3)))

+			(progn (build-subreddit-request :GET "lisp" char-stream)

+			       (finish-output char-stream)

+			       (multiple-value-bind (result headers) (read-in-header char-stream)

+				 (let ((reply-buf (make-string (parse-integer (cadr (assoc "Content-Length" headers

+											   :test 'equalp))))))

+				   (values reply-buf

+					   result

+					   headers

+					   (read-sequence reply-buf char-stream))))))

+	(close ssl-stream)))))

+

+(defparameter *old-readtable* (copy-readtable *readtable*))

+(set-macro-character #\] 'identity nil)

+(set-dispatch-macro-character

+ #\# #\[

+ (lambda (s c n)

+   (let ((list (read-delimited-list #\] s t)))

+     (fw.lu:rollup-list

+      (loop with result = ()

+	 for (arg op) on list by #'cddr

+	 while op

+	 do

+	   (push `(,op ,arg)

+		 result)

+	 finally

+	   (push arg result)

+	   (return (nreverse result)))))))

+|#

new file mode 100644

@@ -0,0 +1,5 @@

+;;;; package.lisp

+

+(defpackage #:http-streams

+  (:use #:cl))

+