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