#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SHP: Hypertext Processor
;;
;; a PHP like web framework for PLT Scheme
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; proxy.ss
;; basic http client: making http requests and parsing responses.
;; yc 8/18/2009 - first version
;; yc 8/26/2009 - fixed the custom header being filtered out of the headers
;;                ensure custom header overwrites the default headers
(require mzlib/trace
         scheme/contract
         "request.ss"
         (planet bzlib/http/client)
         scheme/string
         net/url
         web-server/http/request-structs
         web-server/http/response-structs
         net/base64
         )

(define (custom-header? header)
  (regexp-match #px"^bzl-.*" (car header)))

(define (convert-header header)
    (cons (regexp-replace #px"^bzl-(.+)$" (car header) "\\1")
          (cdr header)))

(define (headers->custom-headers headers) 
  (define (default-headers filtered default-headers) 
    ;; take the original headers, and filter them based on
    ;; the default headers not existing in the filtered header list.
    (let ((exists (filter (lambda (default) 
                            (assf (lambda (key) 
                                    (string-ci=? default key)) 
                                  filtered))
                          default-headers)))
      (filter (lambda (header)
                (member (car header) exists))
              headers)))
  (define (custom-headers) 
    (map convert-header (filter custom-header? headers)))
  (define (helper filtered) 
    (append filtered 
            (default-headers filtered (list "content-type" "content-length"))))
  (helper (custom-headers)))

(define (join-url segments) 
  (define (helper segments)
    (string-join segments "/"))
  (cond ((null? segments) (error 'join-url "invalid segments: ~a" segments))
        ((string-ci=? (car segments) "http:")
         (helper (list* (car segments) "" (cdr segments))))
        ((string-ci=? (car segments) "https:")
         (helper (list* (car segments) "" (cdr segments))))
        (else 
         (helper (list* "http:" "" (cdr segments))))))

(define (url-helper url)
  (cond ((url? url) url)
        ((string? url) (string->url url))
        (else ;; this is based on pathinfo...
         (let ((url (string->url (join-url url))))
           ;; keep the url query
           (set-url-query! url (url-query ($uri)))
           (display (format "~a\n" (url->string url)) (current-error-port))
           url))))

(define (url->auth-header url) 
  ;; helper removes the additional \r\n appended by base64-encode
  (define (remove-extra-crlf auth) 
    (substring auth 0 (- (string-length auth) 2)))
  (if (not (url-user url))
      #f 
      (cons "Authorization"
            (string-append "Basic "
                           (remove-extra-crlf 
                            (bytes->string/utf-8
                             (base64-encode
                              (string->bytes/utf-8 (url-user url)))))))))

(define (normalize-url+headers url headers) 
  (let ((url (url-helper url))
        (headers (headers->custom-headers headers)))
    (let ((auth (url->auth-header url))) ;; in case the auth info is passed in via url.
      (let ((headers (if (not auth) headers
                         (cons auth headers))))
        (values url headers)))))

(define (http-client-response->response r content-type)
  (define (get-content-type r)
    (define (helper header)
      (string->bytes/utf-8 
       (content-type (if (not header) 
                         "text/html; charset=utf-8"
                         (cdr header)))))
     (helper (assf (lambda (key)
                     (string-ci=? key "content-type"))
                   (http-client-response-headers r))))
  (define (normalize-headers r)
    (map (lambda (kv)
           (make-header (string->bytes/utf-8 (car kv))
                        (string->bytes/utf-8 (cdr kv))))
         (http-client-response-headers r)))
  (define (make-generator)
    (lambda (output) 
      (let loop ((b (read-bytes 8192 r)))
        (cond ((eof-object? b)
               ;; what if the download is interrupted? it is possible to leak input-port...
               (close-input-port r)
               (void))
              (else
               (output b)
               (loop (read-bytes 4095 r)))))))
  (make-response/incremental (http-client-response-code r)
                             (string->bytes/utf-8 (http-client-response-reason r))
                             (current-seconds)
                             (get-content-type r)
                             (normalize-headers r)
                             (make-generator)))
 
(define (proxy! (url ($pathinfo)) (headers ($headers))
                #:content-type (content-type (lambda (x) x)))
  (define (helper url headers)
    (raise 
     (http-client-response->response
      (case ($method)
        ((post) (http-post url (request-post-data/raw ($request)) headers))
        ((get) (http-get url headers))
        (else (error 'proxy "proxy method ~a not supported" ($method))))
      content-type)))
  (call-with-values 
   (lambda () 
     (normalize-url+headers url headers))
   helper))


;; CONTRACT
(provide/contract 
 (proxy! (->* () 
              ((or/c string? url? (listof string?))
               (listof (cons/c string? string?))
               #:content-type (-> string? string?))
              any))
 (http-client-response->response 
  (-> http-client-response? 
      (-> string? string?) 
      response/c))
 )