#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)))
(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)]) (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)))