;;;;
;;;; HTTP Stuff
;;;;
;;;; Needs sock.lsp and regex.lsp

(defpackage "HTTP" (:use "XLISP" "SOCKETS" "REGEXP"))
(in-package "HTTP")


;;;;
;;;; Private Functions
;;;;

(defstruct http-config proxy-host proxy-port (user-agent "XLS http"))

(defvar *http-config* (make-http-config))

;;**** do this differently?
(defun get-default-port (proto)
  (let* ((port-data '(("http" 80) ("telnet" 23) ("gopher" 70)))
         (port (second (assoc proto port-data :test #'string-equal))))
    (if port
        port
      (error "can't find default port for ~s protocol" proto))))

(defun parse-url (url)
  (flet ((bad-url (url) (error "~s is not a proper URL" url)))
    (let ((vals (regexp "^(([^:]+)://)?([^:/]+)(:([0-9]+))?(/.*)?" url)))
      (if vals
          (let ((proto (third vals))
                (server (fourth vals))
                (port (sixth vals))
                (path (seventh vals)))
            (unless proto (setf proto "http"))
            (unless server (bad-url url))
            (setf port (if port (parse-integer port) (get-default-port proto)))
            (unless path (setf path "/"))
            (values proto server port path))
        (bad-url url)))))

(defun http-open (action command query url config)
  (unless config (setf config *http-config*))
  (multiple-value-bind (proto server port path)
                       (parse-url url)
    (unless (equal proto "http") (error "~s is not the HTTP protocol" proto))
    (let* ((proxy-host (http-config-proxy-host config))
           (proxy-port (http-config-proxy-port config))
           (myhost (if proxy-host proxy-host server))
           (myport (if proxy-port proxy-port port))
           (user-agent (http-config-user-agent config)))
      (with-client-socket (sock myport myhost)
        (http-open-write-command proxy-host command server port path sock)
        (socket-write-line (format nil "User-Agent: ~s" user-agent) sock)
        (socket-write-line (format nil "Host: ~a" server) sock)
        (when query (http-open-write-query query sock))
        (socket-write-line "" sock)
        (socket-force-output sock)
        (when action (funcall action sock))))))

(defun http-open-write-command (proxy command server port path sock)
  (if proxy
      (socket-write-line
       (format nil "~a http://~/:~d~a HTTP/1.0" command server port path)
       sock)
    (socket-write-line (format nil "~a ~a HTTP/1.0" command path) sock)))

(defun http-open-write-query (query sock)
  (socket-write-line (format nil "Content-Length: ~d" (length query)) sock)
  (socket-write-line "" sock)
  (socket-write-line query sock))

(defstruct (http-header (:print-function print-http-header)) table)

(defun print-http-header (header stream depth)
  (let ((table (http-header-table header)))
    (if *print-escape*
        (format stream "#S(~s ~s ~s)" 'http-header 'table table)
      (dolist (pair table)
        (format stream "~&~a: ~a~%" (first pair) (second pair))))))

(defun set-http-header-value (header key val)
  (let ((entry (assoc key (http-header-table header) :test #'string-equal)))
    (if entry
        (push val (rest entry))
      (push (list key val) (http-header-table header)))))
(defsetf http-header-value set-http-header-value)

(defun http-header-value (header key)
  (first (rest (assoc key (http-header-table header) :test #'string-equal))))

(defun http-header-content-length (header)
  (parse-integer (http-header-value header "content-length")))

(defun http-header-http-status (header)
  (second (regexp "HTTP/1\\.[0-9]* *([0-9].*$)"
                  (http-header-value header "http"))))

(defun read-http-header (sock)
  (let ((code (socket-read-line sock nil nil))
        (header (make-http-header)))
    (when code
          (setf (http-header-value header "http") code)
          (loop
           (let ((line (socket-read-line sock nil nil)))
             (unless (and line (not (equal line ""))) (return header))
             (let* ((kv (rest (regexp "^([^:]+): *(.*)$" line)))
                    (name (string-downcase (first kv)))
                    (value (second kv)))
               (setf (http-header-value header name) value)))))))

(defun http-get (user-action command query url &optional config)
  (flet ((action (sock)
           (let* ((header (read-http-header sock))
                  (status (http-header-http-status header)))
             (unless status (error "no status code"))
             (case (char status 0)
                   (#\2 (when user-action (funcall user-action header sock)))
                   (#\3 (http-get user-action command query
                                  (http-header-value header "location")
                                  config))
                   (otherwise (error status))))))
    (http-open #'action command query url config)))


;;;;
;;;; Public Functions
;;;;

(export '(http-head http-get-content gopher-get-content))

(defun http-head (url &optional config)
  (http-get #'(lambda (h s) h) "HEAD" nil url config))

(defun http-get-content (url &optional config)
  (flet ((action (header sock)
           (let* ((size (http-header-content-length header))
                  (buf (make-string size)))
             (dotimes (i size buf)
               (setf (char buf i)
                     (int-char (sockets::socket-read-byte sock)))))))
    (http-get #'action "GET" nil url config)))

(defun gopher-get-content (url)
  (multiple-value-bind (proto server port path)
                       (parse-url url)
    (with-client-socket (sock port server)
      (socket-write-line path sock)
      (socket-force-output sock)
      (with-output-to-string (s)
        (loop
         (multiple-value-bind (line nlmissing)
                              (socket-read-line sock nil nil)
           (unless line (return))
           (write-string line s)
           (unless nlmissing (terpri s))))))))