(require openssl/sha1)
(require racket/date)
(require
- net/http-client
+ net/head
net/uri-codec
- net/url-string
- net/url-structs)
+ net/url)
(require (prefix-in info: "info.rkt"))
(: cache-dir Path-String)
(define cache-dir (build-path tt-home-dir "cache"))
+(define cache-object-dir (build-path cache-dir "objects"))
+
(: url->cache-file-path-v1 (-> Url Path-String))
(define (url->cache-file-path-v1 uri)
(define (hash-sha1 str) : (-> String String)
(define digest (sha1 in))
(close-input-port in)
digest)
- (build-path cache-dir (hash-sha1 (url->string uri))))
+ (build-path cache-object-dir (hash-sha1 (url->string uri))))
(: url->cache-file-path-v2 (-> Url Path-String))
(define (url->cache-file-path-v2 uri)
- (build-path cache-dir (uri-encode (url->string uri))))
+ (build-path cache-object-dir (uri-encode (url->string uri))))
+
+(define url->cache-object-path url->cache-file-path-v2)
+
+(define (url->cache-etag-path uri)
+ (build-path cache-dir "etags" (uri-encode (url->string uri))))
-(define url->cache-file-path url->cache-file-path-v2)
+(define (url->cache-lmod-path uri)
+ (build-path cache-dir "lmods" (uri-encode (url->string uri))))
; TODO Return Option
(: uri-read-cached (-> Url String))
(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*
(format "+~a" prog-uri))])
(format "~a/~a (~a)" prog-name prog-version user)))
+(: header-get (-> (Listof Bytes) Bytes (Option Bytes)))
+(define (header-get headers name)
+ (match (filter-map (curry extract-field name) headers)
+ [(list val) val]
+ [_ #f]))
+
(: uri-download (-> Url Void))
(define (uri-download u)
- (define cache-file-path (url->cache-file-path u))
- (log-debug "uri-download ~v into ~v" u cache-file-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
- (if (= 200 status)
- (begin
- (make-parent-directory* cache-file-path)
- (call-with-output-file cache-file-path
- (curry copy-port body-input)
- #:exists 'replace))
- (raise status))]
- [(_ _ _)
- (log-error "Invalid URI: ~v" u)]))
+ (define cached-object-path (url->cache-object-path u))
+ (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)
+ (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)
#:help-labels
""
"and <command> is one of"
- "r, read i : Read the timeline."
+ "r, read : Read the timeline."
"d, download : Download the timeline."
; TODO Add path dynamically
"u, upload : Upload your twtxt file (alias to execute ~/.tt/upload)."
"Long output format"
(set! out-format 'multi-line)]
#:args file-paths
- (timeline-print out-format (timeline-read order (paths->peers file-paths)))))])
+ (timeline-print out-format (timeline-read order (paths->peers file-paths)))))]
+ [command
+ (eprintf "Error: invalid command: ~v\n" command)
+ (eprintf "Please use the \"--help\" option to see a list of available commands.\n")
+ (exit 1)])
(log-writer-stop log-writer))))