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