X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=tt.rkt;h=19b61ec179af87900653f80ad63fb6474f32e29b;hb=9c34c974c9c5d324cd432499ae55b3e2b3f1b059;hp=d6218b8305d4c116014f189dc36e08f5a51ae822;hpb=d718efc4fa25667b6c42c97b8f0998ff3eb9e09c;p=tt.git

diff --git a/tt.rkt b/tt.rkt
index d6218b8..19b61ec 100644
--- a/tt.rkt
+++ b/tt.rkt
@@ -4,10 +4,8 @@
 (require racket/date)
 (require
   net/head
-  net/http-client
   net/uri-codec
-  net/url-string
-  net/url-structs)
+  net/url)
 
 (require (prefix-in info: "info.rkt"))
 
@@ -313,6 +311,43 @@
         (log-error "File does not exist: ~v" (path->string file-path))
         '())))
 
+(define re-rfc2822
+  #px"^(Mon|Tue|Wed|Thu|Fri|Sat|Sun), ([0-9]{2}) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) ([0-9]{4}) ([0-2][0-9]):([0-6][0-9]):([0-6][0-9]) GMT")
+
+(: b->n (-> Bytes (Option Number)))
+(define (b->n b)
+  (string->number (bytes->string/utf-8 b)))
+
+(: mon->num (-> Bytes Natural))
+(define/match (mon->num mon)
+  [(#"Jan")  1]
+  [(#"Feb")  2]
+  [(#"Mar")  3]
+  [(#"Apr")  4]
+  [(#"May")  5]
+  [(#"Jun")  6]
+  [(#"Jul")  7]
+  [(#"Aug")  8]
+  [(#"Sep")  9]
+  [(#"Oct") 10]
+  [(#"Nov") 11]
+  [(#"Dec") 12])
+
+(: rfc2822->epoch (-> Bytes (Option Nonnegative-Integer)))
+(define (rfc2822->epoch timestamp)
+  (match (regexp-match re-rfc2822 timestamp)
+    [(list _ _ dd mo yyyy HH MM SS)
+     #:when (and dd mo yyyy HH MM SS)
+     (find-seconds (b->n SS)
+                   (b->n MM)
+                   (b->n HH)
+                   (b->n dd)
+                   (mon->num mo)
+                   (b->n yyyy)
+                   #f)]
+    [_
+      #f]))
+
 (: user-agent String)
 (define user-agent
   (let*
@@ -340,51 +375,53 @@
   (define cached-etag-path (url->cache-etag-path u))
   (define cached-lmod-path (url->cache-lmod-path u))
   (log-debug "uri-download ~v into ~v" u cached-object-path)
-  (match* ((url-scheme u) (url-host u) (url-port u))
-    [(s h p)
-     #:when (and s h)
-     (define ssl? (string=? s "https"))
-     (define-values (status-line headers body-input)
-       ; TODO Timeout. Currently hangs on slow connections.
-       (http-sendrecv
-         h
-         (url->string (struct-copy url u [scheme #f] [host #f]))
-         #:ssl? ssl?
-         #:port (cond [p p] [ssl? 443] [else 80])
-         #:headers (list (format "User-Agent: ~a" user-agent))))
-     (log-debug "headers: ~v" headers)
-     (log-debug "status-line: ~v" status-line)
-     (define status
-       (string->number (second (string-split (bytes->string/utf-8 status-line)))))
-     (log-debug "status: ~v" status)
-     ; TODO Handle redirects
-     (match status
-       [200
-         (let ([etag (header-get headers #"ETag")]
-               [lmod (header-get headers #"Last-Modified")])
-           (if (and etag
-                    (file-exists? cached-etag-path)
-                    (bytes=? etag (file->bytes cached-etag-path)))
-               (log-info "ETags match, skipping the rest of ~v" (url->string u))
-               (begin
-                 (log-info
-                   "Downloading the rest of ~v. ETag: ~a, Last-Modified: ~v"
-                   (url->string u) etag lmod)
-                 (make-parent-directory* cached-object-path)
-                 (make-parent-directory* cached-etag-path)
-                 (make-parent-directory* cached-lmod-path)
-                 (call-with-output-file cached-object-path
-                                        (curry copy-port body-input)
-                                        #:exists 'replace)
-                 (when etag
-                   (display-to-file etag cached-etag-path #:exists 'replace))
-                 (when lmod
-                   (display-to-file etag cached-lmod-path #:exists 'replace))))
-           (close-input-port body-input))]
-       [_
-         (raise status)])]
-    [(_ _ _)
-     (log-error "Invalid URI: ~v" u)]))
+  (define-values (status-line headers body-input)
+    ; TODO Timeout. Currently hangs on slow connections.
+    (http-sendrecv/url u #:headers (list (format "User-Agent: ~a" user-agent))))
+  (log-debug "headers: ~v" headers)
+  (log-debug "status-line: ~v" status-line)
+  (define status
+    (string->number (second (string-split (bytes->string/utf-8 status-line)))))
+  (log-debug "status: ~v" status)
+  ; TODO Handle redirects
+  (match status
+    [200
+      (let* ([etag      (header-get headers #"ETag")]
+             [lmod      (header-get headers #"Last-Modified")]
+             [lmod-curr (if lmod (rfc2822->epoch lmod) #f)]
+             [lmod-prev (if (file-exists? cached-lmod-path)
+                            (rfc2822->epoch (file->bytes cached-lmod-path))
+                            #f)])
+        (log-debug "lmod-curr:~v lmod-prev:~v" lmod-curr lmod-prev)
+        (unless (or (and etag
+                         (file-exists? cached-etag-path)
+                         (bytes=? etag (file->bytes cached-etag-path))
+                         (begin
+                           (log-info "ETags match, skipping the rest of ~v" (url->string u))
+                           #t))
+                    (and lmod-curr
+                         lmod-prev
+                         (<= lmod-curr lmod-prev)
+                         (begin
+                           (log-info "Last-Modified <= current skipping the rest of ~v" (url->string u))
+                           #t)))
+          (begin
+            (log-info
+              "Downloading the rest of ~v. ETag: ~a, Last-Modified: ~v"
+              (url->string u) etag lmod)
+            (make-parent-directory* cached-object-path)
+            (make-parent-directory* cached-etag-path)
+            (make-parent-directory* cached-lmod-path)
+            (call-with-output-file cached-object-path
+                                   (curry copy-port body-input)
+                                   #:exists 'replace)
+            (when etag
+              (display-to-file etag cached-etag-path #:exists 'replace))
+            (when lmod
+              (display-to-file lmod cached-lmod-path #:exists 'replace))))
+        (close-input-port body-input))]
+    [_
+      (raise status)]))
 
 (: timeline-print (-> Out-Format (Listof Msg) Void))
 (define (timeline-print out-format timeline)