tt.rkt

   1 #lang typed/racket/no-check
   2
   3 (require openssl/sha1)
   4 (require racket/date)
   5 (require
   6   net/head
   7   net/uri-codec
   8   net/url)
   9
  10 (require (prefix-in info: "info.rkt"))
  11
  12 (module+ test
  13   (require rackunit))
  14
  15 (define-type Url
  16   net/url-structs:url)
  17
  18 (define-type Out-Format
  19   (U 'single-line
  20      'multi-line))
  21
  22 (define-type Timeline-Order
  23   (U 'old->new
  24      'new->old))
  25
  26 (define-type Result
  27   (∀ (α β) (U (cons 'ok α)
  28               (cons 'error β))))
  29
  30 (struct Msg
  31         ([ts-epoch   : Integer]
  32          [ts-orig    : String]
  33          [nick       : (Option String)]
  34          [uri        : Url]
  35          [text       : String]
  36          [mentions   : (Listof Peer)]))
  37
  38 (struct Peer
  39         ([nick    : (Option String)]
  40          [uri     : Url]
  41          [comment : (Option String)])
  42         #:transparent)
  43
  44 (struct Resp
  45         ([status-line : String]
  46          [headers     : (Listof Bytes)]
  47          [body-input  : Input-Port])
  48         #:transparent)
  49
  50 (: tt-home-dir Path-String)
  51 (define tt-home-dir (build-path (expand-user-path "~") ".tt"))
  52
  53 (: concurrent-filter-map (∀ (α β) (-> Natural (-> α β) (Listof α) (Listof β))))
  54 (define (concurrent-filter-map num-workers f xs)
  55   ; TODO preserve order of elements OR communicate that reorder is expected
  56   ; TODO switch from mailboxes to channels
  57   (define (make-worker id f)
  58     (define parent (current-thread))
  59     (λ ()
  60        (define self : Thread (current-thread))
  61        (: work (∀ (α) (-> α)))
  62        (define (work)
  63          (thread-send parent (cons 'next self))
  64          (match (thread-receive)
  65            ['done          (thread-send parent (cons 'exit id))]
  66            [(cons 'unit x) (begin
  67                              (define y (f x))
  68                              (when y (thread-send parent (cons 'result y)))
  69                              (work))]))
  70        (work)))
  71   (: dispatch (∀ (α β) (-> (Listof Nonnegative-Integer) (Listof α) (Listof β))))
  72   (define (dispatch ws xs ys)
  73     (if (empty? ws)
  74         ys
  75         (match (thread-receive)
  76           [(cons 'exit w)   (dispatch (remove w ws =) xs ys)]
  77           [(cons 'result y) (dispatch ws xs (cons y ys))]
  78           [(cons 'next thd) (match xs
  79                               ['()         (begin
  80                                              (thread-send thd 'done)
  81                                              (dispatch ws xs ys))]
  82                               [(cons x xs) (begin
  83                                              (thread-send thd (cons 'unit x))
  84                                              (dispatch ws xs ys))])])))
  85   (define workers (range num-workers))
  86   (define threads (map (λ (id) (thread (make-worker id f))) workers))
  87   (define results (dispatch workers xs '()))
  88   (for-each thread-wait threads)
  89   results)
  90
  91 (module+ test
  92   (let* ([f        (λ (x) (if (even? x) x #f))]
  93          [xs       (range 11)]
  94          [actual   (sort (concurrent-filter-map 10 f xs) <)]
  95          [expected (sort (           filter-map    f xs) <)])
  96     (check-equal? actual expected "concurrent-filter-map")))
  97
  98 (: msg-print (-> Out-Format Integer Msg Void))
  99 (define msg-print
 100   (let* ([colors (vector 36 33)]
 101          [n      (vector-length colors)])
 102     (λ (out-format color-i msg)
 103        (let ([color (vector-ref colors (modulo color-i n))]
 104              [nick  (Msg-nick msg)]
 105              [uri   (url->string (Msg-uri msg))]
 106              [text  (Msg-text msg)]
 107              [mentions (Msg-mentions msg)])
 108          (match out-format
 109            ['single-line
 110             (let ([nick (if nick nick uri)])
 111               (printf "~a  \033[1;37m<~a>\033[0m  \033[0;~am~a\033[0m~n"
 112                       (parameterize
 113                         ([date-display-format 'iso-8601])
 114                         (date->string (seconds->date (Msg-ts-epoch msg)) #t))
 115                       nick color text))]
 116            ['multi-line
 117             (let ([nick (if nick (string-append nick " ") "")])
 118               (printf "~a (~a)~n\033[1;37m<~a~a>\033[0m~n\033[0;~am~a\033[0m~n~n"
 119                       (parameterize
 120                         ([date-display-format 'rfc2822])
 121                         (date->string (seconds->date (Msg-ts-epoch msg)) #t))
 122                       (Msg-ts-orig msg)
 123                       nick uri color text))])))))
 124
 125 (: rfc3339->epoch (-> String (Option Nonnegative-Integer)))
 126 (define rfc3339->epoch
 127   (let ([re (pregexp "^([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2})(:([0-9]{2}))?(\\.[0-9]+)?(Z|([+-])([0-9]{1,2}):?([0-9]{2}))?$")])
 128     (λ (ts)
 129        (match (regexp-match re ts)
 130          [(list _wholething yyyy mm dd HH MM _:SS SS _fractional tz-whole tz-sign tz-HH tz-MM)
 131           (let*
 132             ([tz-offset
 133                (match* (tz-whole tz-sign tz-HH tz-MM)
 134                  [("Z" #f #f #f)
 135                   0]
 136                  [(_  (or "-" "+") (? identity h)  (? identity m))
 137                   (let ([h (string->number h)]
 138                         [m (string->number m)]
 139                         ; Reverse to get back to UTC:
 140                         [op (match tz-sign ["+" -] ["-" +])])
 141                     (op 0 (+ (* 60 m) (* 60 (* 60 h)))))]
 142                  [(a b c d)
 143                   (log-warning "Impossible TZ string: ~v, components: ~v ~v ~v ~v" tz-whole a b c d)
 144                   0])]
 145              [ts-orig ts]
 146              [local-time? #f]
 147              [ts-epoch (find-seconds (if SS (string->number SS) 0)
 148                                      (string->number MM)
 149                                      (string->number HH)
 150                                      (string->number dd)
 151                                      (string->number mm)
 152                                      (string->number yyyy)
 153                                      local-time?)])
 154             (+ ts-epoch tz-offset))]
 155          [_
 156            (log-error "Invalid timestamp: ~v" ts)
 157            #f]))))
 158
 159 (: str->msg (-> (Option String) Url String (Option Msg)))
 160 (define str->msg
 161   (let ([re (pregexp "^([^\\s\t]+)[\\s\t]+(.*)$")])
 162     (λ (nick uri str)
 163        (define str-head (substring str 0 (min 100 (string-length str))))
 164        (with-handlers*
 165          ([exn:fail?
 166             (λ (e)
 167                (log-error
 168                  "Failed to parse msg: ~v, from: ~v, at: ~v, because: ~v"
 169                  str-head nick (url->string uri) e)
 170                #f)])
 171          (match (regexp-match re str)
 172            [(list _wholething ts-orig text)
 173             (let ([ts-epoch (rfc3339->epoch ts-orig)])
 174               (if ts-epoch
 175                   (let ([mentions
 176                           (filter-map
 177                             (λ (m) (match (regexp-match #px"@<([^>]+)>" m)
 178                                      [(list _wholething nick-uri)
 179                                       (str->peer nick-uri)]))
 180                             (regexp-match* #px"@<[^\\s]+([\\s]+)?[^>]+>" text))])
 181                     (Msg ts-epoch ts-orig nick uri text mentions))
 182                   (begin
 183                     (log-error
 184                       "Msg rejected due to invalid timestamp: ~v, nick:~v, uri:~v"
 185                       str-head nick (url->string uri))
 186                     #f)))]
 187            [_
 188              (log-debug "Non-msg line from nick:~v, line:~a" nick str-head)
 189              #f])))))
 190
 191 (module+ test
 192   ; TODO Test for when missing-nick case
 193   (let* ([tzs (for*/list ([d '("-" "+")]
 194                           [h '("5" "05")]
 195                           [m '("00" ":00" "57" ":57")])
 196                          (string-append d h m))]
 197          [tzs (list* "" "Z" tzs)])
 198     (for* ([n   '("fake-nick")]
 199            [u   '("fake-uri")]
 200            [s   '("" ":10")]
 201            [f   '("" ".1337")]
 202            [z   tzs]
 203            [sep (list "\t" " ")]
 204            [txt '("foo bar baz" "'jaz poop bear giraffe / tea" "@*\"``")])
 205           (let* ([ts (string-append "2020-11-18T22:22"
 206                                     (if (non-empty-string? s) s ":00")
 207                                     z)]
 208                  [m  (str->msg n u (string-append ts sep txt))])
 209             (check-not-false m)
 210             (check-equal? (Msg-nick m) n)
 211             (check-equal? (Msg-uri m) u)
 212             (check-equal? (Msg-text m) txt)
 213             (check-equal? (Msg-ts-orig m) ts (format "Given: ~v" ts))
 214             )))
 215
 216   (let* ([ts       "2020-11-18T22:22:09-0500"]
 217          [tab      "    "]
 218          [text     "Lorem ipsum"]
 219          [nick     "foo"]
 220          [uri      "bar"]
 221          [actual   (str->msg nick uri (string-append ts tab text))]
 222          [expected (Msg 1605756129 ts nick uri text '())])
 223     (check-equal?
 224       (Msg-ts-epoch actual)
 225       (Msg-ts-epoch expected)
 226       "str->msg ts-epoch")
 227     (check-equal?
 228       (Msg-ts-orig actual)
 229       (Msg-ts-orig expected)
 230       "str->msg ts-orig")
 231     (check-equal?
 232       (Msg-nick actual)
 233       (Msg-nick expected)
 234       "str->msg nick")
 235     (check-equal?
 236       (Msg-uri actual)
 237       (Msg-uri expected)
 238       "str->msg uri")
 239     (check-equal?
 240       (Msg-text actual)
 241       (Msg-text expected)
 242       "str->msg text")))
 243
 244 (: str->lines (-> String (Listof String)))
 245 (define (str->lines str)
 246   (string-split str (regexp "[\r\n]+")))
 247
 248 (module+ test
 249   (check-equal? (str->lines "abc\ndef\n\nghi") '("abc" "def" "ghi")))
 250
 251 (: str->msgs (-> (Option String) Url String (Listof Msg)))
 252 (define (str->msgs nick uri str)
 253   (filter-map (λ (line) (str->msg nick uri line)) (filter-comments (str->lines str))))
 254
 255 (: cache-dir Path-String)
 256 (define cache-dir (build-path tt-home-dir "cache"))
 257
 258 (define cache-object-dir (build-path cache-dir "objects"))
 259
 260 (: url->cache-file-path-v1 (-> Url Path-String))
 261 (define (url->cache-file-path-v1 uri)
 262   (define (hash-sha1 str) : (-> String String)
 263     (define in (open-input-string str))
 264     (define digest (sha1 in))
 265     (close-input-port in)
 266     digest)
 267   (build-path cache-object-dir (hash-sha1 (url->string uri))))
 268
 269 (: url->cache-file-path-v2 (-> Url Path-String))
 270 (define (url->cache-file-path-v2 uri)
 271   (build-path cache-object-dir (uri-encode (url->string uri))))
 272
 273 (define url->cache-object-path url->cache-file-path-v2)
 274
 275 (: cache-object-filename->url (-> Path-String Url))
 276 (define (cache-object-filename->url name)
 277   (string->url (uri-decode (path->string name))))
 278
 279 (define (url->cache-etag-path uri)
 280   (build-path cache-dir "etags" (uri-encode (url->string uri))))
 281
 282 (define (url->cache-lmod-path uri)
 283   (build-path cache-dir "lmods" (uri-encode (url->string uri))))
 284
 285 ; TODO Return Option
 286 (: uri-read-cached (-> Url String))
 287 (define (uri-read-cached uri)
 288   (define path-v1 (url->cache-file-path-v1 uri))
 289   (define path-v2 (url->cache-file-path-v2 uri))
 290   (when (file-exists? path-v1)
 291     (rename-file-or-directory path-v1 path-v2 #t))
 292   (if (file-exists? path-v2)
 293       (file->string path-v2)
 294       (begin
 295         (log-warning "Cache file not found for URI: ~a" (url->string uri))
 296         "")))
 297
 298 (: str->url (-> String (Option String)))
 299 (define (str->url s)
 300   (with-handlers*
 301     ([exn:fail? (λ (e) #f)])
 302     (string->url s)))
 303
 304 (: str->peer (String (Option Peer)))
 305 (define (str->peer str)
 306   (log-debug "Parsing peer string: ~v" str)
 307   (match
 308     (regexp-match
 309       #px"(([^\\s\t]+)[\\s\t]+)?([a-zA-Z]+://[^\\s\t]*)[\\s\t]*(#\\s*(.*))?"
 310       str)
 311     [(list _wholething
 312            _nick-with-space
 313            nick
 314            url
 315            _comment-with-hash
 316            comment)
 317      (match (str->url url)
 318        [#f
 319          (log-error "Invalid URI in peer string: ~v" str)
 320          #f]
 321        [url (Peer nick url comment)])]
 322     [_
 323       (log-error "Invalid peer string: ~v" str)
 324       #f]))
 325
 326 (module+ test
 327   (check-equal?
 328     (str->peer "foo http://bar/file.txt # some rando")
 329     (Peer "foo" (str->url "http://bar/file.txt") "some rando"))
 330   (check-equal?
 331     (str->peer "http://bar/file.txt # some rando")
 332     (Peer #f (str->url "http://bar/file.txt") "some rando"))
 333   (check-equal?
 334     (str->peer "http://bar/file.txt #")
 335     (Peer #f (str->url "http://bar/file.txt") ""))
 336   (check-equal?
 337     (str->peer "http://bar/file.txt#") ; XXX URLs can have #s
 338     (Peer #f (str->url "http://bar/file.txt#") #f))
 339   (check-equal?
 340     (str->peer "http://bar/file.txt")
 341     (Peer #f (str->url "http://bar/file.txt") #f))
 342   (check-equal?
 343     (str->peer "foo http://bar/file.txt")
 344     (Peer "foo" (str->url "http://bar/file.txt") #f))
 345   (check-equal?
 346     (str->peer "foo bar # baz")
 347     #f)
 348   (check-equal?
 349     (str->peer "foo bar://baz # quux")
 350     (Peer "foo" (str->url "bar://baz") "quux"))
 351   (check-equal?
 352     (str->peer "foo bar//baz # quux")
 353     #f))
 354
 355 (: filter-comments (-> (Listof String) (Listof String)))
 356 (define (filter-comments lines)
 357   (filter-not (λ (line) (string-prefix? line "#")) lines))
 358
 359 (: str->peers (-> String (Listof Peer)))
 360 (define (str->peers str)
 361   (filter-map str->peer (filter-comments (str->lines str))))
 362
 363 (: peers->file (-> (Listof Peers) Path-String Void))
 364 (define (peers->file peers path)
 365   (display-lines-to-file
 366     (map (match-lambda
 367            [(Peer n u c)
 368             (format "~a~a~a"
 369                     (if n (format "~a " n) "")
 370                     (url->string u)
 371                     (if c (format " # ~a" c) ""))])
 372          peers)
 373     path
 374     #:exists 'replace))
 375
 376 (: file->peers (-> Path-String (Listof Peer)))
 377 (define (file->peers file-path)
 378   (if (file-exists? file-path)
 379       (str->peers (file->string file-path))
 380       (begin
 381         (log-warning "File does not exist: ~v" (path->string file-path))
 382         '())))
 383
 384 (define re-rfc2822
 385   #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")
 386
 387 (: b->n (-> Bytes (Option Number)))
 388 (define (b->n b)
 389   (string->number (bytes->string/utf-8 b)))
 390
 391 (: mon->num (-> Bytes Natural))
 392 (define/match (mon->num mon)
 393   [(#"Jan")  1]
 394   [(#"Feb")  2]
 395   [(#"Mar")  3]
 396   [(#"Apr")  4]
 397   [(#"May")  5]
 398   [(#"Jun")  6]
 399   [(#"Jul")  7]
 400   [(#"Aug")  8]
 401   [(#"Sep")  9]
 402   [(#"Oct") 10]
 403   [(#"Nov") 11]
 404   [(#"Dec") 12])
 405
 406 (: rfc2822->epoch (-> Bytes (Option Nonnegative-Integer)))
 407 (define (rfc2822->epoch timestamp)
 408   (match (regexp-match re-rfc2822 timestamp)
 409     [(list _ _ dd mo yyyy HH MM SS)
 410      #:when (and dd mo yyyy HH MM SS)
 411      (find-seconds (b->n SS)
 412                    (b->n MM)
 413                    (b->n HH)
 414                    (b->n dd)
 415                    (mon->num mo)
 416                    (b->n yyyy)
 417                    #f)]
 418     [_
 419       #f]))
 420
 421 (: user-agent String)
 422 (define user-agent
 423   (let*
 424     ([prog-name      "tt"]
 425      [prog-version   (info:#%info-lookup 'version)]
 426      [prog-uri       "https://github.com/xandkar/tt"]
 427      [user-peer-file (build-path tt-home-dir "me")]
 428      [user
 429        (if (file-exists? user-peer-file)
 430            (match (first (file->peers user-peer-file))
 431              [(Peer #f u _) (format "+~a"      (url->string u)  )]
 432              [(Peer  n u _) (format "+~a; @~a" (url->string u) n)])
 433            (format "+~a" prog-uri))])
 434     (format "~a/~a (~a)" prog-name prog-version user)))
 435
 436 (: header-get (-> (Listof Bytes) Bytes (Option Bytes)))
 437 (define (header-get headers name)
 438   (match (filter-map (curry extract-field name) headers)
 439     [(list val) val]
 440     [_           #f]))
 441
 442 (: uri-download-from-port
 443    (-> Url (Listof (U Bytes String)) Input-Port
 444        (U 'skipped-cached 'downloaded-new))) ; TODO 'ok|'error ?
 445 (define (uri-download-from-port u headers body-input)
 446   (define u-str (url->string u))
 447   (log-debug "uri-download-from-port ~v into ~v" u-str cached-object-path)
 448   (define cached-object-path (url->cache-object-path u))
 449   (define cached-etag-path (url->cache-etag-path u))
 450   (define cached-lmod-path (url->cache-lmod-path u))
 451   (define etag      (header-get headers #"ETag"))
 452   (define lmod      (header-get headers #"Last-Modified"))
 453   (define lmod-curr (if lmod (rfc2822->epoch lmod) #f))
 454   (define lmod-prev (if (file-exists? cached-lmod-path)
 455                         (rfc2822->epoch (file->bytes cached-lmod-path))
 456                         #f))
 457   (log-debug "lmod-curr:~v lmod-prev:~v" lmod-curr lmod-prev)
 458   (define cached?
 459     (or (and etag
 460              (file-exists? cached-etag-path)
 461              (bytes=? etag (file->bytes cached-etag-path))
 462              (begin
 463                (log-debug "ETags match, skipping the rest of ~v" u-str)
 464                #t))
 465         (and lmod-curr
 466              lmod-prev
 467              (<= lmod-curr lmod-prev)
 468              (begin
 469                (log-debug "Last-Modified <= current skipping the rest of ~v" u-str)
 470                #t))))
 471   (if (not cached?)
 472     (begin
 473       (log-debug
 474         "Downloading the rest of ~v. ETag: ~a, Last-Modified: ~v"
 475         u-str etag lmod)
 476       (make-parent-directory* cached-object-path)
 477       (make-parent-directory* cached-etag-path)
 478       (make-parent-directory* cached-lmod-path)
 479       (call-with-output-file cached-object-path
 480                              (curry copy-port body-input)
 481                              #:exists 'replace)
 482       (when etag
 483         (display-to-file etag cached-etag-path #:exists 'replace))
 484       (when lmod
 485         (display-to-file lmod cached-lmod-path #:exists 'replace))
 486       'downloaded-new)
 487     'skipped-cached))
 488
 489 (: uri-download
 490    (-> Positive-Float Url
 491        (Result (U 'skipped-cached 'downloaded-new)
 492                Any))) ; TODO Maybe more-precise error type?
 493 (define (uri-download timeout u)
 494   (define u-str (url->string u))
 495   (define timeout-chan (make-channel))
 496   (define result-chan (make-channel))
 497   (define timeout-thread
 498     (thread (λ ()
 499                ; Doing this instead of sync/timeout to distinguish error values,
 500                ; rather than just have #f to work with.
 501                (sleep timeout)
 502                (channel-put timeout-chan '(error . timeout)))))
 503   (define result-thread
 504     (thread (λ ()
 505                ; XXX We timeout getting a response, but body download could
 506                ; also take a long time and we might want to time that out as
 507                ; well, but then we may end-up with partially downloaded
 508                ; objects. But that could happen anyway if the server drops the
 509                ; connection for whatever reason.
 510                ;
 511                ; Maybe that is OK once we start treating the
 512                ; downloaded object as an addition to the stored set of
 513                ; messages, rather than the final set of messages.
 514
 515                ; TODO message db
 516                ; - 1st try can just be an in-memory set that gets written-to
 517                ;   and read-from disk as a whole.
 518                (define result
 519                  (with-handlers
 520                    ; TODO Maybe name each known errno? (exn:fail:network:errno-errno e)
 521                    ([exn:fail:network?
 522                       (λ (e) `(error . (net-error . ,e)))]
 523                     [exn?
 524                       (λ (e) `(error . (other . ,e)))])
 525                    (define-values (status-line headers body-input)
 526                      (http-sendrecv/url
 527                        u
 528                        #:headers (list (format "User-Agent: ~a" user-agent))))
 529                    `(ok . ,(Resp status-line headers body-input))))
 530                (channel-put result-chan result))))
 531   (define result
 532     (sync timeout-chan
 533           result-chan))
 534   (kill-thread result-thread)
 535   (kill-thread timeout-thread)
 536   (match result
 537     [(cons 'error _)
 538      result]
 539     [(cons 'ok (Resp status-line headers body-input))
 540      (log-debug "headers: ~v" headers)
 541      (log-debug "status-line: ~v" status-line)
 542      (define status
 543        (string->number (second (string-split (bytes->string/utf-8 status-line)))))
 544      (log-debug "status: ~v" status)
 545      ; TODO Handle redirects. Should be within same timeout as req and body.
 546      (let ([result
 547              (match status
 548                [200
 549                  `(ok . ,(uri-download-from-port u headers body-input))]
 550                [_
 551                  `(error . (http . ,status))])])
 552        (close-input-port body-input)
 553        result)]))
 554
 555 (: timeline-print (-> Out-Format (Listof Msg) Void))
 556 (define (timeline-print out-format timeline)
 557   (void (foldl (match-lambda**
 558                  [((and m (Msg _ _ nick _ _ _)) (cons prev-nick i))
 559                   (let ([i (if (equal? prev-nick nick) i (+ 1 i))])
 560                     (msg-print out-format i m)
 561                     (cons nick i))])
 562                (cons "" 0)
 563                timeline)))
 564
 565 (: peer->msgs (-> Peer (Listof Msg)))
 566 (define (peer->msgs peer)
 567   (match-define (Peer nick uri _) peer)
 568   (log-info "Reading peer nick:~v uri:~v" nick (url->string uri))
 569   (str->msgs nick uri (uri-read-cached uri)))
 570
 571 (: peer-download
 572    (-> Positive-Float Peer
 573        (Result (U 'skipped-cached 'downloaded-new)
 574                Any)))
 575 (define (peer-download timeout peer)
 576   (match-define (Peer nick uri _) peer)
 577   (define u (url->string uri))
 578   (log-info "Download BEGIN URL:~a" u)
 579   (define-values (results _tm-cpu-ms tm-real-ms _tm-gc-ms)
 580     (time-apply uri-download (list timeout uri)))
 581   (define result (car results))
 582   (log-info "Download END in ~a seconds, URL:~a, result:~s"
 583             (/ tm-real-ms 1000.0)
 584             u
 585             result)
 586   result)
 587
 588 (: timeline-download (-> Integer Positive-Float (Listof Peer) Void))
 589 (define (timeline-download num-workers timeout peers)
 590   (define results
 591     (concurrent-filter-map num-workers
 592                            (λ (p) (cons p (peer-download timeout p)))
 593                            peers))
 594   (define ok? (match-lambda
 595                 [(cons _ (cons 'ok _)) #t]
 596                 [(cons _ (cons 'error _)) #f]))
 597   (define (err? r) (not (ok? r)))
 598   (define peers-ok (map car (filter ok? results)))
 599   (define peers-err (map car (filter err? results)))
 600   (peers->file peers-ok (build-path tt-home-dir "peers-last-downloaded-ok"))
 601   ; TODO Append error as a comment: <nick> <uri> # <error>
 602   ; TODO Support inline/trailing comments in peer files
 603   (peers->file peers-err (build-path tt-home-dir "peers-last-downloaded-err")))
 604
 605 (: uniq (∀ (α) (-> (Listof α) (Listof α))))
 606 (define (uniq xs)
 607   (set->list (list->set xs)))
 608
 609 (: peers->timeline (-> (listof Peer) (listof Msg)))
 610 (define (peers->timeline peers)
 611   (append* (filter-map peer->msgs peers)))
 612
 613 (: timeline-sort (-> (listof Msg) timeline-order (Listof Msgs)))
 614 (define (timeline-sort msgs order)
 615   (define cmp (match order
 616                 ['old->new <]
 617                 ['new->old >]))
 618   (sort msgs (λ (a b) (cmp (Msg-ts-epoch a)
 619                            (Msg-ts-epoch b)))))
 620
 621 (: paths->peers (-> (Listof String) (Listof Peer)))
 622 (define (paths->peers paths)
 623   (let* ([paths (match paths
 624                   ['()
 625                    (let ([peer-refs-file (build-path tt-home-dir "peers")])
 626                      (log-debug
 627                        "No peer ref file paths provided, defaulting to ~v"
 628                        (path->string peer-refs-file))
 629                      (list peer-refs-file))]
 630                   [paths
 631                     (log-debug "Peer ref file paths provided: ~v" paths)
 632                     (map string->path paths)])]
 633          [peers (append* (map file->peers paths))])
 634     (log-info "Read-in ~a peers." (length peers))
 635     (uniq peers)))
 636
 637 (: mentioned-peers-in-cache (-> (Listof Peer)))
 638 (define (mentioned-peers-in-cache)
 639   (define msgs
 640     (append* (map (λ (filename)
 641                      (define path (build-path cache-object-dir filename))
 642                      (define size (/ (file-size path) 1000000.0))
 643                      (log-info "BEGIN parsing ~a MB from file: ~v"
 644                                size
 645                                (path->string path))
 646                      (define t0 (current-inexact-milliseconds))
 647                      (define m (filter-map
 648                                  (λ (line)
 649                                     (str->msg #f (cache-object-filename->url filename) line))
 650                                  (filter-comments
 651                                    (file->lines path))))
 652                      (define t1 (current-inexact-milliseconds))
 653                      (log-info "END parsing ~a MB in ~a seconds from file: ~v."
 654                                size
 655                                (* 0.001 (- t1 t0))
 656                                (path->string path))
 657                      (when (empty? m)
 658                        (log-warning "No messages found in ~a" (path->string path)))
 659                      m)
 660                   (directory-list cache-object-dir))))
 661   (uniq (append* (map Msg-mentions msgs))))
 662
 663 (: log-writer-stop (-> Thread Void))
 664 (define (log-writer-stop log-writer)
 665   (log-message (current-logger) 'fatal 'stop "Exiting." #f)
 666   (thread-wait log-writer))
 667
 668 (: log-writer-start (-> Log-Level Thread))
 669 (define (log-writer-start level)
 670   (let* ([logger
 671            (make-logger #f #f level #f)]
 672          [log-receiver
 673            (make-log-receiver logger level)]
 674          [log-writer
 675            (thread
 676              (λ ()
 677                 (parameterize
 678                   ([date-display-format 'iso-8601])
 679                   (let loop ()
 680                     (match-define (vector level msg _ topic) (sync log-receiver))
 681                     (unless (equal? topic 'stop)
 682                       (eprintf "~a [~a] ~a~n" (date->string (current-date) #t) level msg)
 683                       (loop))))))])
 684     (current-logger logger)
 685     log-writer))
 686
 687 (module+ main
 688   (let ([log-level 'info])
 689     (command-line
 690       #:program
 691       "tt"
 692       #:once-each
 693       [("-d" "--debug")
 694        "Enable debug log level."
 695        (set! log-level 'debug)]
 696       #:help-labels
 697       ""
 698       "and <command> is one of"
 699       "r, read     : Read the timeline (offline operation)."
 700       "d, download : Download the timeline."
 701       ; TODO Add path dynamically
 702       "u, upload   : Upload your twtxt file (alias to execute ~/.tt/upload)."
 703       "c, crawl    : Discover new peers mentioned by known peers (offline operation)."
 704       ""
 705       #:args (command . args)
 706       (define log-writer (log-writer-start log-level))
 707       (current-command-line-arguments (list->vector args))
 708       (match command
 709         [(or "d" "download")
 710          ; Initially, 15 was fastest out of the tried: 1, 5, 10, 20.  Then I
 711          ; started noticing significant slowdowns. Reducing to 5 seems to help.
 712          (let ([num-workers 5]
 713                [timeout     10.0])
 714            (command-line
 715              #:program
 716              "tt download"
 717              #:once-each
 718              [("-j" "--jobs")
 719               njobs "Number of concurrent jobs."
 720               (set! num-workers (string->number njobs))]
 721              [("-t" "--timeout")
 722               seconds "Timeout seconds per request."
 723               (set! timeout (string->number seconds))]
 724              #:args file-paths
 725              (let ([peers (paths->peers file-paths)])
 726                (define-values (_res _cpu real-ms _gc)
 727                  (time-apply timeline-download (list num-workers timeout peers)))
 728                (log-info "Downloaded timelines from ~a peers in ~a seconds."
 729                          (length peers)
 730                          (/ real-ms 1000.0)))))]
 731         [(or "u" "upload")
 732          (command-line
 733            #:program
 734            "tt upload"
 735            #:args ()
 736            (if (system (path->string (build-path tt-home-dir "upload")))
 737                (exit 0)
 738                (exit 1)))]
 739         [(or "r" "read")
 740          (let ([out-format 'multi-line]
 741                [order      'old->new]
 742                [ts-min     #f]
 743                [ts-max     #f])
 744            (command-line
 745              #:program
 746              "tt read"
 747              #:once-each
 748              [("-r" "--rev")
 749               "Reverse displayed timeline order."
 750               (set! order 'new->old)]
 751              [("-m" "--min")
 752               m "Earliest time to display (ignore anything before it)."
 753               (set! ts-min (rfc3339->epoch m))]
 754              [("-x" "--max")
 755               x "Latest time to display (ignore anything after it)."
 756               (set! ts-max (rfc3339->epoch x))]
 757              #:once-any
 758              [("-s" "--short")
 759               "Short output format"
 760               (set! out-format 'single-line)]
 761              [("-l" "--long")
 762               "Long output format"
 763               (set! out-format 'multi-line)]
 764              #:args file-paths
 765              (let* ([peers
 766                       (paths->peers file-paths)]
 767                     [timeline
 768                       (timeline-sort (peers->timeline peers) order)]
 769                     [timeline
 770                       (filter (λ (m) (and (if ts-min (>= (Msg-ts-epoch m)
 771                                                          ts-min)
 772                                               #t)
 773                                           (if ts-max (<= (Msg-ts-epoch m)
 774                                                          ts-max)
 775                                               #t)))
 776                               timeline)])
 777                (timeline-print out-format timeline))))]
 778         [(or "c" "crawl")
 779          (command-line
 780            #:program
 781            "tt crawl"
 782            #:args ()
 783            (let* ([peers-sort
 784                     (λ (peers) (sort peers (match-lambda**
 785                                              [((Peer n1 _ _) (Peer n2 _ _))
 786                                               (string<? (if n1 n1 "")
 787                                                         (if n2 n2 ""))])))]
 788                   [peers-all-file
 789                     (build-path tt-home-dir "peers-all")]
 790                   [peers-mentioned-file
 791                     (build-path tt-home-dir "peers-mentioned")]
 792                   [peers-mentioned-curr
 793                     (mentioned-peers-in-cache)]
 794                   [peers-mentioned-prev
 795                     (file->peers peers-mentioned-file)]
 796                   [peers-mentioned
 797                     (peers-sort (uniq (append peers-mentioned-prev
 798                                               peers-mentioned-curr)))]
 799                   [peers-all-prev
 800                     (file->peers peers-all-file)]
 801                   [peers-all
 802                     (list->set (append peers-mentioned
 803                                        peers-all-prev))]
 804                   [peers-discovered
 805                     (set-subtract peers-all (list->set peers-all-prev))]
 806                   [peers-all
 807                     (peers-sort (set->list peers-all))])
 808              (log-info "Known peers mentioned: ~a" (length peers-mentioned))
 809              (log-info "Known peers total: ~a" (length peers-all))
 810              (log-info "Discovered ~a new peers:~n~a"
 811                        (set-count peers-discovered)
 812                        (pretty-format (map
 813                                         (λ (p) (cons (Peer-nick p)
 814                                                      (url->string (Peer-uri p))))
 815                                         (set->list peers-discovered))))
 816              (peers->file peers-mentioned
 817                           peers-mentioned-file)
 818              (peers->file peers-all
 819                           peers-all-file)))]
 820         [command
 821           (eprintf "Error: invalid command: ~v\n" command)
 822           (eprintf "Please use the \"--help\" option to see a list of available commands.\n")
 823           (exit 1)])
 824       (log-writer-stop log-writer))))