+(: 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-from-port
+ (-> Url (Listof (U Bytes String)) Input-Port
+ (U 'skipped-cached 'downloaded-new))) ; TODO 'ok|'error ?
+(define (uri-download-from-port u headers body-input)
+ (define u-str (url->string u))
+ (log-debug "uri-download-from-port ~v into ~v" u-str cached-object-path)
+ (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))
+ (define etag (header-get headers #"ETag"))
+ (define lmod (header-get headers #"Last-Modified"))
+ (define lmod-curr (if lmod (rfc2822->epoch lmod) #f))
+ (define 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)
+ (define cached?
+ (or (and etag
+ (file-exists? cached-etag-path)
+ (bytes=? etag (file->bytes cached-etag-path))
+ (begin
+ (log-debug "ETags match, skipping the rest of ~v" u-str)
+ #t))
+ (and lmod-curr
+ lmod-prev
+ (<= lmod-curr lmod-prev)
+ (begin
+ (log-debug "Last-Modified <= current skipping the rest of ~v" u-str)
+ #t))))
+ (if (not cached?)
+ (begin
+ (log-debug
+ "Downloading the rest of ~v. ETag: ~a, Last-Modified: ~v"
+ u-str 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))
+ 'downloaded-new)
+ 'skipped-cached))
+
+(: uri-download
+ (-> Positive-Float Url
+ (Result (U 'skipped-cached 'downloaded-new)
+ Any))) ; TODO Maybe more-precise error type?
+(define (uri-download timeout u)
+ (define u-str (url->string u))
+ (define timeout-chan (make-channel))
+ (define result-chan (make-channel))
+ (define timeout-thread
+ (thread (λ ()
+ ; Doing this instead of sync/timeout to distinguish error values,
+ ; rather than just have #f to work with.
+ (sleep timeout)
+ (channel-put timeout-chan '(error . timeout)))))
+ (define result-thread
+ (thread (λ ()
+ ; XXX We timeout getting a response, but body download could
+ ; also take a long time and we might want to time that out as
+ ; well, but then we may end-up with partially downloaded
+ ; objects. But that could happen anyway if the server drops the
+ ; connection for whatever reason.
+ ;
+ ; Maybe that is OK once we start treating the
+ ; downloaded object as an addition to the stored set of
+ ; messages, rather than the final set of messages.
+
+ ; TODO message db
+ ; - 1st try can just be an in-memory set that gets written-to
+ ; and read-from disk as a whole.
+ (define result
+ (with-handlers
+ ; TODO Maybe name each known errno? (exn:fail:network:errno-errno e)
+ ([exn:fail:network?
+ (λ (e) `(error . (net-error . ,e)))]
+ [exn?
+ (λ (e) `(error . (other . ,e)))])
+ (define-values (status-line headers body-input)
+ (http-sendrecv/url
+ u
+ #:headers (list (format "User-Agent: ~a" user-agent))))
+ `(ok . ,(Resp status-line headers body-input))))
+ (channel-put result-chan result))))
+ (define result
+ (sync timeout-chan
+ result-chan))
+ (kill-thread result-thread)
+ (kill-thread timeout-thread)
+ (match result
+ [(cons 'error _)
+ result]
+ [(cons 'ok (Resp status-line headers body-input))
+ (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. Should be within same timeout as req and body.
+ (let ([result
+ (match status
+ [200
+ `(ok . ,(uri-download-from-port u headers body-input))]
+ [_
+ `(error . (http . ,status))])])
+ (close-input-port body-input)
+ result)]))
+
+(: timeline-print (-> Out-Format (Listof Msg) Void))
+(define (timeline-print out-format timeline)
+ (void (foldl (match-lambda**
+ [((and m (Msg _ _ nick _ _ _)) (cons prev-nick i))
+ (let ([i (if (equal? prev-nick nick) i (+ 1 i))])
+ (msg-print out-format i m)
+ (cons nick i))])
+ (cons "" 0)
+ timeline)))
+
+(: peer->msgs (-> Peer (Listof Msg)))
+(define (peer->msgs peer)
+ (match-define (Peer nick uri _) peer)
+ (log-debug "Reading peer nick:~v uri:~v" nick (url->string uri))
+ (define msgs-data (uri-read-cached uri))
+ (if msgs-data
+ (str->msgs nick uri msgs-data)
+ '()))
+
+(: peer-download
+ (-> Positive-Float Peer
+ (Result (U 'skipped-cached 'downloaded-new)
+ Any)))
+(define (peer-download timeout peer)
+ (match-define (Peer nick uri _) peer)
+ (define u (url->string uri))
+ (log-info "Download BEGIN URL:~a" u)
+ (define-values (results _tm-cpu-ms tm-real-ms _tm-gc-ms)
+ (time-apply uri-download (list timeout uri)))
+ (define result (car results))
+ (log-info "Download END in ~a seconds, URL:~a, result:~s"
+ (/ tm-real-ms 1000.0)
+ u
+ result)
+ result)
+
+(: timeline-download (-> Integer Positive-Float (Listof Peer) Void))
+(define (timeline-download num-workers timeout peers)
+ (define results
+ (concurrent-filter-map num-workers
+ (λ (p) (cons p (peer-download timeout p)))
+ peers))
+ (define peers-ok
+ (filter-map (match-lambda
+ [(cons p (cons 'ok _)) p]
+ [(cons _ (cons 'error e)) #f])
+ results))
+ (define peers-err
+ (filter-map (match-lambda
+ [(cons _ (cons 'ok _))
+ #f]
+ [(cons p (cons 'error e))
+ (struct-copy Peer p [comment (format "~s" e)])])
+ results))
+ (peers->file peers-ok (build-path tt-home-dir "peers-last-downloaded-ok"))
+ (peers->file peers-err (build-path tt-home-dir "peers-last-downloaded-err")))
+
+(: uniq (∀ (α) (-> (Listof α) (Listof α))))
+(define (uniq xs)
+ (set->list (list->set xs)))
+
+(: peers->timeline (-> (listof Peer) (listof Msg)))
+(define (peers->timeline peers)
+ (append* (filter-map peer->msgs peers)))
+
+(: timeline-sort (-> (listof Msg) timeline-order (Listof Msgs)))
+(define (timeline-sort msgs order)
+ (define cmp (match order
+ ['old->new <]
+ ['new->old >]))
+ (sort msgs (λ (a b) (cmp (Msg-ts-epoch a)
+ (Msg-ts-epoch b)))))
+
+(: paths->peers (-> (Listof String) (Listof Peer)))
+(define (paths->peers paths)
+ (let* ([paths (match paths
+ ['()
+ (let ([peer-refs-file (build-path tt-home-dir "peers")])
+ (log-debug
+ "No peer ref file paths provided, defaulting to ~v"
+ (path->string peer-refs-file))
+ (list peer-refs-file))]
+ [paths
+ (log-debug "Peer ref file paths provided: ~v" paths)
+ (map string->path paths)])]
+ [peers (append* (map file->peers paths))])
+ (log-info "Read-in ~a peers." (length peers))
+ (uniq peers)))
+
+(: mentioned-peers-in-cache (-> (Listof Peer)))
+(define (mentioned-peers-in-cache)
+ (define msgs
+ (append* (map (λ (filename)
+ (define path (build-path cache-object-dir filename))
+ (define size (/ (file-size path) 1000000.0))
+ (log-debug "BEGIN parsing ~a MB from file: ~v"
+ size
+ (path->string path))
+ (define t0 (current-inexact-milliseconds))
+ (define m (filter-map
+ (λ (line)
+ (str->msg #f (cache-object-filename->url filename) line))
+ (filter-comments
+ (file->lines path))))
+ (define t1 (current-inexact-milliseconds))
+ (log-debug "END parsing ~a MB in ~a seconds from file: ~v."
+ size
+ (* 0.001 (- t1 t0))
+ (path->string path))
+ (when (empty? m)
+ (log-debug "No messages found in ~a" (path->string path)))
+ m)
+ (directory-list cache-object-dir))))
+ (uniq (append* (map Msg-mentions msgs))))
+
+(: log-writer-stop (-> Thread Void))
+(define (log-writer-stop log-writer)
+ (log-message (current-logger) 'fatal 'stop "Exiting." #f)
+ (thread-wait log-writer))
+
+(: log-writer-start (-> Log-Level Thread))
+(define (log-writer-start level)
+ (let* ([logger
+ (make-logger #f #f level #f)]
+ [log-receiver
+ (make-log-receiver logger level)]
+ [log-writer
+ (thread
+ (λ ()
+ (parameterize
+ ([date-display-format 'iso-8601])
+ (let loop ()
+ (match-define (vector level msg _ topic) (sync log-receiver))
+ (unless (equal? topic 'stop)
+ (eprintf "~a [~a] ~a~n" (date->string (current-date) #t) level msg)
+ (loop))))))])
+ (current-logger logger)
+ log-writer))
+