;;;; -*-Mode:LISP; Package:LISP; Base:10; Syntax:ISLISP -*-
;;;; Title:     httpget.lsp
;;;; Author:    C. Jullien
;;;; License:   New BSD license
;;;; SVN:       "$Id: httpget.lsp 5018 2022-04-09 13:44:17Z jullien $"

;;;
;;;     httpget.lsp:    Get a resource from URL (see RFC 2616).
;;;
;;;     Example: (http-get "http://linuxtoday.com/backend/biglt.rss")

;;;
;;; TODO: parse response header.
;;;

(require "setf")
(require "defstruct")
(require "datetime")
(require "sysinfo")
(require "url")
(require "http")

(in-package #:http)
(export '(http-get http-post))

(defglobal *http-port*  80)
(defglobal *http-debug* nil)
(defglobal *http-agent* nil)

;;;
;;; Connection structure
;;;

(defstruct (<http-connection>
             (:copier    nil)
             (:predicate nil))
    (url    nil)      ;; requested resource
    (socket nil)      ;; system socket used for connection.
    (status nil)      ;; response status ("HTTP/1.1" "200" "Ok")
    (header nil)      ;; response header (list of ..)
    (body   nil)      ;; message body (not used yet)
)

(defun http-agent ()
   ;; compute the User-Agent information header.
   (or *http-agent*
       (let ((info (system-info)))
            (setf *http-agent*
                  (format ()
                          "~a (compatible; Openlisp/~s; ~a ~a; ~a; ~s bit; ~a)"
                          "Mozilla/5.0"
                          (version)
                          (sysinfo-sysname       info)
                          (sysinfo-sysrelease    info)
                          (sysinfo-sysversion    info)
                          (sysinfo-address-size  info)
                          (sysinfo-character-set info))))))

(defun http-get-response (connection)
   ;; get server response.
   (let ((so     (http-connection-socket connection))
         (reply  nil)
         (lines  nil)
         (header t)
         (loop   t))
        (while (and loop
                    (setf reply (read-line so nil nil))
                    (stringp reply))
               (push reply lines)
               (when *http-debug*
                     (format (standard-output) "-- ~a~%" reply))
               (when (= (length reply) 0)
                     (if (null header)
                         ;; first blank line after header
                         (setf header t)
                         ;; first blank line in message body, end of response.
                         ;; it should go to body structure field
                         (setf loop nil))))
        (cond
              ((consp lines)
               (setf lines (http-decode-header (nreverse lines)))
               (setf (http-connection-status connection) (car lines))
               (setf (http-connection-header connection) lines)
               (http-read-body connection))
              (t
               (setf (http-connection-status connection)
                     '("http/1.1" "404" "Not Found"))))))

(defun http-make-connection (url)
   ;; create a new connection form domain associated to url.  It
   ;; returns a connection structure if the connection has been
   ;; established, nil otherwise.
   (let ((so     (socket))
         (res    nil)
         (ipaddr nil))
        (when so
              (setf res    (url:url-from-string url))
              (setf ipaddr (get-host-address (url:url-authority res)))
              (cond
                    ((null ipaddr)
                     (close so)
                     nil)
                    ((connect
                        (bind so t 0) ;; addr == INADDR_ANY, port == 0
                        ipaddr
                        (url:url-port res)
                        :TCP)
                     (make-http-connection :url res :socket so))
                    (t
                     (close so)
                     nil)))))

(defun http-send-request (connection type mime-type extra-header content)
   ;; type may be "GET" or "POST"
   (let ((so  (http-connection-socket connection))
         (res (http-connection-url connection)))
        (http-format-nl so "~a ~a HTTP/1.1" type (url::url-resource res))
        (http-format-nl so "Host: ~a" (url:url-authority res))
        (http-format-nl so "Accept: text*")
        (http-format-nl so "Date: ~a" (get-internal-date nil :GMT))
        (http-format-nl so "User-Agent: ~a" (http-agent))
;       (http-format-nl so "Connection: close")
        (cond
              ((string= type "POST")
               (cond
                     ((null content)
                      (when (null mime-type)
                            (setf mime-type "text/plain"))
                      (http-format-nl so "Content-Type: ~a" mime-type)
                      (when extra-header
                            (http-format-nl so extra-header))
                      (http-format-nl so "Content-Length: 0")
                      (http-format-nl so))
                     (t
                      (unless (stringp content)
                              (setf content (format nil "~a" content)))
                      (http-format-nl so "Content-Type: ~a" mime-type)
                      (when extra-header
                            (http-format-nl so extra-header))
                      (http-format-nl so "Content-Length: ~a" (length content))
                      (http-format-nl so)
                      (http-format    so "~a" content))))
              (t
               (http-format-nl so)))))

(defun http-read-body (connection)
   ;; read message body
   (let ((reply nil)
         (size  nil)
         (buf   nil)
         (loop  t)
         (so    (http-connection-socket connection)))
        (setf size (cassoc :Content-Length
                           (http-connection-header connection)))
        (socket-receive-timeout so 5)
        (cond
              (size
                (if (consp size)
                    (setf size (parse-number (car size)))
                    (setf size (parse-number size)))
                (setf buf (create-string size #\Space))
                (receive so buf size))
              ((member "chunked"
                       (cassoc :Transfer-Encoding
                               (http-connection-header connection))
                       :test #'equal)
               (while loop
                      (setf size (string-trim " " (read-line so nil nil)))
                      (setf size (parse-number (string-append "#x" size)))
                      (cond
                            ((= size 0)
                             (setf loop nil))
                            (t
                             (setf reply (create-string size #\Space))
                             (receive so reply size)
                             (push reply buf)
                             ;; skip blank
                             (read-line so nil nil))))
               (setf buf (apply #'string-append (nreverse buf))))
              (t
;                (socket-nonblocking so nil)
                (setf buf nil)
                (while (and loop
                            (setf reply (read-line so nil nil)))
                       (push reply buf))
;                     (setf loop (= (length reply) 0)))
                (setf buf (apply #'string-append (nreverse buf)))))
        (setf (http-connection-body connection) buf)))

(defun http-get/post (url type mime-type extra-header content)
   ;; get url string contents.
   (let ((connection (http-get-connection-handle url
                                                 type
                                                 mime-type
                                                 extra-header
                                                 content))
         (redirect   nil))
        (unless connection
                (error "HTTP-~a: error connecting to ~s~%" type url))
        (case-using #'string-equal (nth 1 (http-connection-status connection))
           (("301" "302" "303" "307")
            (setf redirect
                  (some (lambda (line)
                           (when (and (consp line) (eq (car line) :location))
                                 (cadr line)))
                        (http-connection-header connection)))
            (when *http-debug*
                  (format (standard-output) ";; redirected to '~a'~%" redirect))
            (http-get redirect))
           (("200")
            (http-connection-body connection))
           (t
            ;; add (http-connection-header connection) for details
            (error "HTTP-~a: error ~a~%~a"
                   type
                   (http-connection-status connection)
                   (http-connection-body connection))))))

(defun http-get-connection-handle (url type mime-type extra-header content)
   ;; get URL resource.
   ;; type may be "GET" or "POST"
   (let ((connection (http-make-connection url)))
        (when connection
              (http-send-request connection
                                 type
                                 mime-type
                                 extra-header
                                 content)
              (http-get-response connection)
              (close (http-connection-socket connection))
              (setf (http-connection-socket connection) nil))
        connection))

(defun http-get (url &rest extra-header)
    (http-get/post url "GET" nil (and extra-header (car extra-header)) nil))

(defun http-post (url mime-type extra-header content)
   (http-get/post url "POST" mime-type extra-header content))

#|

(defun test ()
   (let ((connection (http::make-http-connection)))
        (mapc (lambda (x)
                 (url:url-from-string x connection)
                 (format t "~a ->~t~a~%" x connection))
              '(
                 "http:/www.eligis.com"
                 "http:/www.eligis.com/"
                 "http:/www.eligis.com:8080"
                 "http:/www.eligis.com:8080/"
                 "http:/www.eligis.com/foo"
                 "http:/www.eligis.com/foo/bar.html"
               ))))

(defun foo-get (&rest x)
   (if x
       (http-get  "http:/localhost:8080")
       (http-post "http:/localhost:8080" "text/plain" nil 'foo)))


(defun foo ()
   (dotimes (unused 100000)
      (format t "~d~%" (length (foo-get)))))

|#

(provide "httpget")