(∀ (α β) (U (cons 'ok α)
(cons 'error β))))
+(struct User
+ ([uri : String]
+ [nick : (Option String)]))
+
+(struct User-Agent
+ ([user : User]
+ [prog : Prog]))
+
+(struct Prog
+ ([name : String]
+ [version : String]))
+
(struct Msg
([ts-epoch : Integer]
[ts-orig : String]
[body-input : Input-Port])
#:transparent)
+(: prog Prog)
+(define prog
+ (Prog "tt" (info:#%info-lookup 'version)))
+
+(: user-default User)
+(define user-default
+ (User "https://github.com/xandkar/tt" #f))
+
+(: user->str (-> User String))
+(define (user->str user)
+ (match-define (User u n) user)
+ (if n
+ (format "+~a; @~a" u n)
+ (format "+~a" u )))
+
+(: user-agent->str (-> User-Agent String))
+(define (user-agent->str ua)
+ (match-define (User-Agent u p) ua)
+ (format "~a/~a (~a)" (Prog-name p) (Prog-version p) (user->str u)))
+
+(: user->user-agent User)
+(define (user->user-agent user)
+ (User-Agent user prog))
+
+(: user-agent-str String)
+(define user-agent-str
+ (user-agent->str (user->user-agent user-default)))
+
+(: set-user-agent-str (-> Path-String Void))
+(define (set-user-agent-str filename)
+ (set! user-agent-str (user-agent->str (user->user-agent (file->user filename))))
+ (log-info "User-Agent string is now set to: ~v" user-agent-str))
+
+(: file->user (-> Path-String User))
+(define (file->user filename)
+ (if (file-exists? filename)
+ (match (set->list (file->peers filename))
+ [(list p)
+ (log-info
+ "User-Agent. Found one peer in file: ~v. Using the found peer: ~a"
+ filename
+ (peer->str p))
+ (peer->user p)]
+ [(list* p _)
+ (log-warning
+ "User-Agent. Multiple peers in file: ~v. Picking arbitrary: ~a"
+ filename
+ (peer->str p))
+ (peer->user p)]
+ ['()
+ (log-warning
+ "User-Agent. No peers found in file: ~v. Using the default user: ~a"
+ filename
+ user-default)
+ user-default])
+ (begin
+ (log-warning
+ "User-Agent. File doesn't exist: ~v. Using the default user: ~a"
+ filename
+ user-default)
+ user-default)))
+
+(define (peer->user p)
+ (match-define (Peer n _ u _) p)
+ (User u n))
+
(: peers-equal? (-> Peer Peer Boolean))
(define (peers-equal? p1 p2)
(equal? (Peer-uri-str p1)
;
; TODO Investigate why and make a minimal reproducible test case.
+(define (peers-union . peer-sets)
+ (define groups
+ (foldl
+ (λ (p groups)
+ (hash-update groups (Peer-uri-str p) (λ (group) (cons p group)) '()))
+ (hash)
+ (append* (map set->list peer-sets))))
+ (define (merge peers)
+ (match peers
+ ['() (raise 'impossible)]
+ [(list p) p]
+ [(list* p1 p2 ps)
+ (let* ([n1 (Peer-nick p1)]
+ [n2 (Peer-nick p2)]
+ [p (cond
+ [(and (not n1) (not n2)) p1]
+ [(and n1 n2 ) p1]
+ [(and n1 (not n2)) p1]
+ [(and (not n1) n2) p2]
+ [else
+ (raise 'impossible)])])
+ (merge (cons p ps)))]))
+ (make-immutable-peers (map merge (hash-values groups))))
+
+(module+ test
+ (let* ([u1 "http://foo/bar"]
+ [u2 "http://baz/quux"]
+ [p1 (Peer #f (string->url u1) u1 #f)]
+ [p2 (Peer "a" (string->url u1) u1 #f)]
+ [p3 (Peer "b" (string->url u2) u2 #f)]
+ [s1 (make-immutable-peers (list p1))]
+ [s2 (make-immutable-peers (list p2 p3))])
+ (check-true (peers? (peers-union s1 s2)))
+ (check-true (peers? (peers-union s2 s1)))
+ (check-equal? (list p3 p2) (set->list (peers-union s1 s2)))
+ (check-equal? (list p3 p2) (set->list (peers-union s2 s1)))))
+
(: tt-home-dir Path-String)
(define tt-home-dir (build-path (expand-user-path "~") ".tt"))
[tzs (list* "" "Z" tzs)])
(for* ([n '("fake-nick")]
[u '("http://fake-uri")]
- [p (list (Peer n (string->url u) u ""))]
+ [p (list (Peer n (string->url u) u #f))]
[s '("" ":10")]
[f '("" ".1337")]
[z tzs]
[text "Lorem ipsum"]
[nick "foo"]
[uri "http://bar/"]
- [peer (Peer nick (string->url uri) uri "")]
+ [peer (Peer nick (string->url uri) uri #f)]
[actual (str->msg peer (string-append ts tab text))]
[expected (Msg 1605756129 ts peer text '())])
(check-equal?
[_
#f]))
-(: user-agent String)
-(define user-agent
- (let*
- ([prog-name "tt"]
- [prog-version (info:#%info-lookup 'version)]
- [prog-uri "https://github.com/xandkar/tt"]
- [user-peer-file (build-path tt-home-dir "me")]
- [user
- (if (file-exists? user-peer-file)
- (match (set-first (file->peers user-peer-file))
- [(Peer #f _ u _) (format "+~a" u )]
- [(Peer n _ u _) (format "+~a; @~a" u n)])
- (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)
(define-values (status-line headers body-input)
(http-sendrecv/url
u
- #:headers (list (format "User-Agent: ~a" user-agent))))
+ #:headers (list (format "User-Agent: ~a" user-agent-str))))
`(ok . ,(Resp status-line headers body-input))))
(channel-put result-chan result))))
(define result
(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")))
-(: peers->timeline (-> (Listof Peer) (Listof Msg)))
+(: peers->timeline (-> (Setof Peer) (Listof Msg)))
(define (peers->timeline peers)
(append* (filter-map peer->msgs (set->list peers))))
[paths
(log-debug "Peer ref file paths provided: ~v" paths)
(map string->path paths)])]
- [peers (apply set-union (map file->peers paths))])
+ [peers (apply peers-union (map file->peers paths))])
(log-info "Read-in ~a peers." (set-count peers))
peers))
-(: mentioned-peers-in-cache (-> (Setof Peer)))
-(define (mentioned-peers-in-cache)
- ; TODO Expire 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)
- (define url-str (uri-decode (path->string filename)))
- (define url (string->url url-str))
- (define from (Peer #f url url-str ""))
- (str->msg from 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))))
+(: cache-filename->peer (-> Path-String (Option Peer)))
+(define (cache-filename->peer filename)
+ (define nick #f) ; TODO Look it up in the nick-db when it exists.
+ (define url-str (uri-decode (path->string filename))) ; TODO Can these crash?
+ (match (str->url url-str)
+ [#f #f]
+ [url (Peer nick url url-str #f)]))
+
+(: peers-cached (-> (Setof Peer)))
+(define (peers-cached)
+ ; TODO Expire cache?
+ (make-immutable-peers
+ (filter-map cache-filename->peer
+ (directory-list cache-object-dir))))
+
+(: peers-mentioned (-> (Listof Msg) (Setof Peer)))
+(define (peers-mentioned msgs)
(make-immutable-peers (append* (map Msg-mentions msgs))))
(: log-writer-stop (-> Thread Void))
(build-path tt-home-dir "peers-mentioned")]
[peers-parsed-file
(build-path tt-home-dir "peers-parsed")]
+ [peers-cached-file
+ (build-path tt-home-dir "peers-cached")]
+ [peers-cached
+ (peers-cached)]
+ [cached-timeline
+ (peers->timeline peers-cached)]
[peers-mentioned-curr
- (mentioned-peers-in-cache)]
+ (peers-mentioned cached-timeline)]
[peers-mentioned-prev
(file->peers peers-mentioned-file)]
[peers-mentioned
- (set-union peers-mentioned-prev
- peers-mentioned-curr)]
+ (peers-union peers-mentioned-prev
+ peers-mentioned-curr)]
[peers-all-prev
(file->peers peers-all-file)]
[peers-all
- (set-union peers-mentioned
- peers-all-prev)]
+ (peers-union peers-mentioned
+ peers-all-prev
+ peers-cached)]
[peers-discovered
(set-subtract peers-all
peers-all-prev)]
[peers-parsed
(for/set ([p peers-all] #:when (> (length (peer->msgs p)) 0)) p)])
; TODO Deeper de-duping
+ (log-info "Known peers cached ~a" (set-count peers-cached))
(log-info "Known peers mentioned: ~a" (set-count peers-mentioned))
(log-info "Known peers parsed ~a" (set-count peers-parsed))
(log-info "Known peers total: ~a" (set-count peers-all))
(match-lambda
[(Peer n _ u c) (list n u c)])
(set->list peers-discovered))))
+ (peers->file peers-cached
+ peers-cached-file)
(peers->file peers-mentioned
peers-mentioned-file)
(peers->file peers-parsed
#:args (command . args)
(define log-writer (log-writer-start log-level))
(current-command-line-arguments (list->vector args))
+ (set-user-agent-str (build-path tt-home-dir "me"))
; TODO dispatch should return status with which we should exit after cleanups
(dispatch command)
(log-writer-stop log-writer))))
home / code / tt.git / blobdiff