;;; Wrapper around HTTP-REQUEST to do the common GET/POST tasks.

(define-record-type url
  (make-url url credentials host port path)
  url?
  (url url-url)
  (credentials url-credentials)
  (host url-host)
  (port url-port)
  (path url-path))

(define (http-get url . headers)
  (let ((headers (if (null? headers)
                     '()
                     (car headers))))
    (handle-reply (request "GET" (parse-url url) headers #f)
                  headers)))

(define (http-post url body . headers)
  (let ((headers (if (null? headers)
                     '()
                     (car headers))))
    (handle-reply (request "POST" (parse-url url) headers body)
                  headers)))

(define (handle-reply reply headers)
  (cond
   ((string=? (http-reply-status-code reply)
              "200")
    (let ((body (http-read-reply-body reply)))
      (close-socket (http-reply-socket reply))
      body))
   ((member (http-reply-status-code reply)
            '("301" "302" "303" "307"))
    (cond
     ((assoc "Location" (http-reply-headers reply))
      => (lambda (header)
           (http-get (cdr header)
                     headers)))
     (else
      (close-socket (http-reply-socket reply))
      (error "HTTP redirection without location header"
             (http-reply-status-code reply)
             (http-reply-status-description reply)))))
   (else
    (close-socket (http-reply-socket reply))
    (error "HTTP request failed"
           (http-reply-status-code reply)
           (http-reply-status-description reply)))))

(define (request method parsed-url headers body)
  (cond
   ((getenv "http_proxy")
    => (lambda (proxy)
         (let ((proxy-url (parse-url proxy)))
           (http-send-request "HTTP/1.0"
                              method
                              (url-url parsed-url)
                              (add-default-headers parsed-url proxy-url headers body)
                              body
                              (socket-connect protocol-family/internet
                                              socket-type/stream
                                              (url-host proxy-url)
                                              (url-port proxy-url))))))
   (else
    (http-send-request "HTTP/1.0"
                       method
                       (url-path parsed-url)
                       (add-default-headers parsed-url #f headers body)
                       body
                       (socket-connect protocol-family/internet
                                       socket-type/stream
                                       (url-host parsed-url)
                                       (url-port parsed-url))))))

(define (add-default-headers parsed-url proxy-url headers body)
  (define (add-header header headers)
    (let ((name (car header))
          (value (cdr header)))
      (if (assoc name headers)
          headers
          (cons (cons name value)
                headers))))
  (fold-right add-header
              '()
              `(("Host" . ,(url-host parsed-url))
                ,@(if (url-credentials parsed-url)
                      `(("Authorization"
                         . ,(string-append "Basic "
                                           (base64-encode
                                            (url-credentials parsed-url)))))
                      '())
                ,@(if (and proxy-url
                           (url-credentials proxy-url))
                      `(("Proxy-Authorization"
                         . ,(string-append "Basic "
                                           (base64-encode
                                            (url-credentials proxy-url)))))
                      '())
                ,@(if body
                      `(("Content-Length" . ,(string-length body)))
                      '())
                ("Connection" . "close"))))


(define (parse-url url)
  (let ((match (regexp-search (rx (? "http://")
                                  (? (submatch (* (~ "@")))
                                     "@")
                                  (submatch (+ (~ ":" "/")))
                                  (? ":"
                                     (submatch (+ digit)))
                                  (submatch (* any)))
                              url)))
    (make-url url
              (match:substring match 1)
              (match:substring match 2)
              (if (match:substring match 3)
                  (string->number (match:substring match 3))
                  80)
              (if (zero? (string-length (match:substring match 4)))
                  "/"
                  (match:substring match 4)))))