X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=tt.rkt;h=a375c69f05aaa1f979741ec96ceb99bed5b72ee6;hb=refs%2Ftags%2F0.26.0;hp=a40003f2006026e5376f196cab8c7fc7025cbb03;hpb=7fd20778168252189c82adcb917af1bc1faeec86;p=tt.git diff --git a/tt.rkt b/tt.rkt index a40003f..a375c69 100644 --- a/tt.rkt +++ b/tt.rkt @@ -36,8 +36,9 @@ [mentions : (Listof Peer)])) (struct Peer - ([nick : (Option String)] - [uri : Url]) + ([nick : (Option String)] + [uri : Url] + [comment : (Option String)]) #:transparent) (struct Resp @@ -281,8 +282,7 @@ (define (url->cache-lmod-path uri) (build-path cache-dir "lmods" (uri-encode (url->string uri)))) -; TODO Return Option -(: uri-read-cached (-> Url String)) +(: uri-read-cached (-> Url (Option String))) (define (uri-read-cached uri) (define path-v1 (url->cache-file-path-v1 uri)) (define path-v2 (url->cache-file-path-v2 uri)) @@ -292,27 +292,64 @@ (file->string path-v2) (begin (log-warning "Cache file not found for URI: ~a" (url->string uri)) - ""))) + #f))) -(: uri? (-> String Boolean)) -(define (uri? str) - (regexp-match? #rx"^[a-z]+://.*" (string-downcase str))) +(: str->url (-> String (Option String))) +(define (str->url s) + (with-handlers* + ([exn:fail? (λ (e) #f)]) + (string->url s))) (: str->peer (String (Option Peer))) (define (str->peer str) (log-debug "Parsing peer string: ~v" str) - (with-handlers* - ([exn:fail? - (λ (e) - (log-error "Invalid URI in string: ~v, exn: ~v" str e) - #f)]) - (match (string-split str) - [(list u) #:when (uri? u) (Peer #f (string->url u))] - [(list n u) #:when (uri? u) (Peer n (string->url u))] - [_ - (log-error "Invalid peer string: ~v" str) - #f]))) + (match + (regexp-match + #px"(([^\\s\t]+)[\\s\t]+)?([a-zA-Z]+://[^\\s\t]*)[\\s\t]*(#\\s*(.*))?" + str) + [(list _wholething + _nick-with-space + nick + url + _comment-with-hash + comment) + (match (str->url url) + [#f + (log-error "Invalid URI in peer string: ~v" str) + #f] + [url (Peer nick url comment)])] + [_ + (log-error "Invalid peer string: ~v" str) + #f])) +(module+ test + (check-equal? + (str->peer "foo http://bar/file.txt # some rando") + (Peer "foo" (str->url "http://bar/file.txt") "some rando")) + (check-equal? + (str->peer "http://bar/file.txt # some rando") + (Peer #f (str->url "http://bar/file.txt") "some rando")) + (check-equal? + (str->peer "http://bar/file.txt #") + (Peer #f (str->url "http://bar/file.txt") "")) + (check-equal? + (str->peer "http://bar/file.txt#") ; XXX URLs can have #s + (Peer #f (str->url "http://bar/file.txt#") #f)) + (check-equal? + (str->peer "http://bar/file.txt") + (Peer #f (str->url "http://bar/file.txt") #f)) + (check-equal? + (str->peer "foo http://bar/file.txt") + (Peer "foo" (str->url "http://bar/file.txt") #f)) + (check-equal? + (str->peer "foo bar # baz") + #f) + (check-equal? + (str->peer "foo bar://baz # quux") + (Peer "foo" (str->url "bar://baz") "quux")) + (check-equal? + (str->peer "foo bar//baz # quux") + #f)) (: filter-comments (-> (Listof String) (Listof String))) (define (filter-comments lines) @@ -326,8 +363,11 @@ (define (peers->file peers path) (display-lines-to-file (map (match-lambda - [(Peer n u) - (format "~a~a" (if n (format "~a " n) "") (url->string u))]) + [(Peer n u c) + (format "~a~a~a" + (if n (format "~a " n) "") + (url->string u) + (if c (format " # ~a" c) ""))]) peers) path #:exists 'replace)) @@ -387,8 +427,8 @@ [user (if (file-exists? user-peer-file) (match (first (file->peers user-peer-file)) - [(Peer #f u) (format "+~a" (url->string u) )] - [(Peer n u) (format "+~a; @~a" (url->string u) n)]) + [(Peer #f u _) (format "+~a" (url->string u) )] + [(Peer n u _) (format "+~a; @~a" (url->string u) n)]) (format "+~a" prog-uri))]) (format "~a/~a (~a)" prog-name prog-version user))) @@ -522,17 +562,20 @@ timeline))) (: peer->msgs (-> Peer (Listof Msg))) -(define (peer->msgs f) - (match-define (Peer nick uri) f) +(define (peer->msgs peer) + (match-define (Peer nick uri _) peer) (log-info "Reading peer nick:~v uri:~v" nick (url->string uri)) - (str->msgs nick uri (uri-read-cached 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) + (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) @@ -550,15 +593,19 @@ (concurrent-filter-map num-workers (λ (p) (cons p (peer-download timeout p))) peers)) - (define ok? (match-lambda - [(cons _ (cons 'ok _)) #t] - [(cons _ (cons 'error _)) #f])) - (define (err? r) (not (ok? r))) - (define peers-ok (map car (filter ok? results))) - (define peers-err (map car (filter err? results))) + (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")) - ; TODO Append error as a comment: # - ; TODO Support inline/trailing comments in peer files (peers->file peers-err (build-path tt-home-dir "peers-last-downloaded-err"))) (: uniq (∀ (α) (-> (Listof α) (Listof α)))) @@ -741,13 +788,15 @@ #:args () (let* ([peers-sort (λ (peers) (sort peers (match-lambda** - [((Peer n1 _) (Peer n2 _)) + [((Peer n1 _ _) (Peer n2 _ _)) (stringset peers-all-prev))] [peers-all - (peers-sort (set->list peers-all))]) + (peers-sort (set->list peers-all))] + [peers-parsed + (filter + (λ (p) (< 0 (length (peer->msgs p)))) + peers-all)]) (log-info "Known peers mentioned: ~a" (length peers-mentioned)) + (log-info "Known peers parsed ~a" (length peers-parsed)) (log-info "Known peers total: ~a" (length peers-all)) (log-info "Discovered ~a new peers:~n~a" (set-count peers-discovered) @@ -774,6 +828,8 @@ (set->list peers-discovered)))) (peers->file peers-mentioned peers-mentioned-file) + (peers->file peers-parsed + peers-parsed-file) (peers->file peers-all peers-all-file)))] [command