main.ss
#lang scheme

(require (prefix-in channel: "channel.ss"))

(require (prefix-in pool: "pool.ss"))
(require (prefix-in parse: "parse.ss"))
(require (only-in "parse.ss" headers/c headers?))

(require (prefix-in log: (planet synx/log)))

(require net/url-structs)

(require scheme/async-channel)
(require srfi/19)

(define (redirection? code)
  (and (> code 300) (< code 304)))

; for a redirect, the redirect response does not post the semaphore,
; but passes it to the sub-get in tail position, which itself does
; not wait on the semaphore, but launches a thread with it, in tail
; position. End result: all data associated with the redirection
; is collectable, and once the real page is retrieved, the semaphore posted
; will notify the topmost getter that waited on it, not any of the
; redirected getters.

(define (do method uri headers #:data [data #f] #:size [size #f] #:follow-redirect [follow-redirect? #f])
  (local
    [(define request-headers
       (parse:set-headers
        headers
        `(("Host" . ,(url-host uri))
          ("Date" . ,(current-date))
          ,(if size
               `("Content-Length" . ,size)
               '("Transfer-Encoding" . ("chunked"))))))
     (define-values (request response) (pool:connect method uri request-headers))]
    (when (or (eq? method 'put) (eq? method 'post))
      (let ([output (channel:get request)])
        (if (input-port? data) 
            (copy-port data output)
            (display data output))))
    (local
      [(define-values (version code message response-headers) (channel:get response))
       (define input
         (if (eq? method 'head)
             #f
             (channel:get response)))]
      (if (and follow-redirect? (redirection? code))
          (let ([location (parse:get-header response-headers "Location")]
                [method (if (= code 303) 'get method)]) ; a 303 means they got the POST correctly, now just need a GET
            (when (not (eq? method 'head))
              (copy-port input (open-output-nowhere)))
            (log:log "Redirected, redoing connection to ~s" location)
            (do method location request-headers #:size size #:follow-redirect follow-redirect?))
          (values code response-headers input )))))

(define (get uri [headers #f] [follow-redirect #t])
  (let-values ([(code headers input)
                (do 'get uri headers #:size 0 #:follow-redirect follow-redirect)])
    (values code headers input)))

(define (get-string uri [headers #f] [follow-redirect #t])
  (let-values ([(code headers input) (get uri headers follow-redirect)])
    (values code headers (port->bytes input))))

(define (upp method)
  (λ (uri #:data data #:headers [headers #f] #:size [size #f] #:follow-redirect [follow-redirect #f])
    (let-values ([(code headers input)
                  (do method uri headers #:data data #:size size #:follow-redirect follow-redirect)])
      (values (port->bytes input) code headers))))

(define post (upp 'post))
(define put (upp 'put))

(define (head uri [headers #f])
  (let-values ([(code headers input) (do 'head uri headers #:size 0)])
    (when input
      (error "Head should not return any input"))
    (values code headers)))

(define (been-modified? filename remote)
  (and remote
       (time>? (date->time-utc remote) (make-time 'time-utc 0 (file-or-directory-modify-seconds filename)))))

(define (download uri filename [headers #f])
  (if (file-exists? filename)
      (let-values
          ([(code response-headers) (head uri headers)])
        (when (or (< code 200) (>= code 300))
          (error "Error requesting file code ~s~n" code))
        (let ([ranges (parse:get-header response-headers "Accept-Ranges")]
              [length (parse:get-header response-headers "Content-Length")]
              [modified (parse:get-header response-headers "Last-Modified")])
          (display "renutihou\n")
          (if (and length (< (file-size filename) length))
              (if (and ranges (parse:is-in? ranges "bytes"))
                  (download-partial uri filename headers modified)
                  (download-basic uri filename headers modified))
              (if (been-modified? filename modified)
                (download-basic uri filename headers modified)
                (values "" modified)))))
      (download-basic uri filename headers #f)))

(define (download-partial uri filename headers modified)
  (download-basic uri filename 
                  (parse:set-header headers "Range" (format "~a-" (file-size filename)))
                  modified
                  'append))

(define (download-basic uri filename headers modified [exists 'truncate])
  (let-values
      ([(code response-headers input)
        (do 'get uri headers #:size 0 #:follow-redirect #t)])
    (call-with-output-file filename
      #:exists exists
      (λ (output)
        (copy-port input output)))
    (let ([modified (or (parse:get-header response-headers "Last-Modified")
                        modified)])
      (when modified
        (file-or-directory-modify-seconds filename (time-second (date->time-utc modified))))

      (values (parse:get-header response-headers "Content-Type") modified))))

(define upp/c (->* (url? #:data input-port?) (#:size (or/c integer? #f) #:headers headers/c) any))

(provide/contract
 [download (->* (url? path-string?) (headers/c) (values string? date?))]
 [get (->* (url?) (headers/c) (values integer? headers? input-port?))]
 [get-string (->* (url?) (headers/c) (values integer? headers? bytes?))]
 [post upp/c]
 [put upp/c]
 [head (->* (url?) (headers/c) (values integer? headers?))])
(provide (rename-out (pool:proxy proxy)))