;;;; 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 lookup-status (status)
   (ecase status
     (200 "OK")
     (400 "Bad Request")
     (404 "Not Found")
     (301 "Moved Permanently")
     (302 "Moved Temporarily")
     ))
 
 (defun response (status out-stream)
   (with-line (out-stream)
     (format out-stream "HTTP/1.1 ~d ~a" status (lookup-status status)))
   out-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))))