X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=tt.rkt;h=1cb90cf18bac9c964fdcb3a95dcc75b34c397778;hb=9a346534e567f5496e2608b5946f1d21320bde94;hp=01dbc6b3545a1f6996f58838583bc514609a1198;hpb=26d57c074a565aa4d4623ca5714ecde51a705ec0;p=tt.git diff --git a/tt.rkt b/tt.rkt index 01dbc6b..1cb90cf 100644 --- a/tt.rkt +++ b/tt.rkt @@ -24,23 +24,22 @@ (U 'old->new 'new->old)) -(struct msg +(struct Msg ([ts-epoch : Integer] [ts-orig : String] - [nick : String] + [nick : (Option String)] [uri : Url] - [text : String]) - #:type-name Msg) + [text : String] + [mentions : (Listof Peer)])) -(struct feed - ([nick : String] - [uri : Url]) - #:type-name Feed) +(struct Peer + ([nick : (Option String)] + [uri : Url])) (: tt-home-dir Path-String) (define tt-home-dir (build-path (expand-user-path "~") ".tt")) -(: concurrent-filter-map (∀ (α β) (-> Natural (-> α β) (Listof α)))) +(: concurrent-filter-map (∀ (α β) (-> Natural (-> α β) (Listof α) (Listof β)))) (define (concurrent-filter-map num-workers f xs) ; TODO preserve order of elements OR communicate that reorder is expected ; TODO switch from mailboxes to channels @@ -91,21 +90,26 @@ [n (vector-length colors)]) (λ (out-format color-i msg) (let ([color (vector-ref colors (modulo color-i n))] - [nick (msg-nick msg)] - [uri (url->string (msg-uri msg))] - [text (msg-text msg)]) + [nick (Msg-nick msg)] + [uri (url->string (Msg-uri msg))] + [text (Msg-text msg)] + [mentions (Msg-mentions msg)]) (match out-format ['single-line - (printf "~a \033[1;37m<~a>\033[0m \033[0;~am~a\033[0m~n" - (parameterize ([date-display-format 'iso-8601]) - (date->string (seconds->date [msg-ts-epoch msg]) #t)) - nick color text)] + (let ([nick (if nick nick uri)]) + (printf "~a \033[1;37m<~a>\033[0m \033[0;~am~a\033[0m~n" + (parameterize + ([date-display-format 'iso-8601]) + (date->string (seconds->date (Msg-ts-epoch msg)) #t)) + nick color text))] ['multi-line - (printf "~a (~a)~n\033[1;37m<~a ~a>\033[0m~n\033[0;~am~a\033[0m~n~n" - (parameterize ([date-display-format 'rfc2822]) - (date->string (seconds->date [msg-ts-epoch msg]) #t)) - (msg-ts-orig msg) - nick uri color text)]))))) + (let ([nick (if nick (string-append nick " ") "")]) + (printf "~a (~a)~n\033[1;37m<~a~a>\033[0m~n\033[0;~am~a\033[0m~n~n" + (parameterize + ([date-display-format 'rfc2822]) + (date->string (seconds->date (Msg-ts-epoch msg)) #t)) + (Msg-ts-orig msg) + nick uri color text))]))))) (: rfc3339->epoch (-> String (Option Nonnegative-Integer))) (define rfc3339->epoch @@ -141,7 +145,7 @@ (log-error "Invalid timestamp: ~v" ts) #f])))) -(: str->msg (-> String Url String (Option Msg))) +(: str->msg (-> (Option String) Url String (Option Msg))) (define str->msg (let ([re (pregexp "^([^\\s\t]+)[\\s\t]+(.*)$")]) (λ (nick uri str) @@ -156,17 +160,24 @@ [(list _wholething ts-orig text) (let ([ts-epoch (rfc3339->epoch ts-orig)]) (if ts-epoch - (msg ts-epoch ts-orig nick uri text) + (let ([mentions + (filter-map + (λ (m) (match (regexp-match #px"@<([^>]+)>" m) + [(list _wholething nick-uri) + (str->peer nick-uri)])) + (regexp-match* #px"@<[^\\s]+([\\s]+)?[^>]+>" text))]) + (Msg ts-epoch ts-orig nick uri text mentions)) (begin (log-error "Msg rejected due to invalid timestamp: ~v, nick:~v, uri:~v" str nick (url->string uri)) #f)))] [_ - (log-debug "Non-msg line from nick:~a, line:~a" nick str) + (log-debug "Non-msg line from nick:~v, line:~a" nick str) #f]))))) (module+ test + ; TODO Test for when missing-nick case (let* ([tzs (for*/list ([d '("-" "+")] [h '("5" "05")] [m '("00" ":00" "57" ":57")]) @@ -184,10 +195,10 @@ z)] [m (str->msg n u (string-append ts sep txt))]) (check-not-false m) - (check-equal? (msg-nick m) n) - (check-equal? (msg-uri m) u) - (check-equal? (msg-text m) txt) - (check-equal? (msg-ts-orig m) ts (format "Given: ~v" ts)) + (check-equal? (Msg-nick m) n) + (check-equal? (Msg-uri m) u) + (check-equal? (Msg-text m) txt) + (check-equal? (Msg-ts-orig m) ts (format "Given: ~v" ts)) ))) (let* ([ts "2020-11-18T22:22:09-0500"] @@ -196,26 +207,26 @@ [nick "foo"] [uri "bar"] [actual (str->msg nick uri (string-append ts tab text))] - [expected (msg 1605756129 ts nick uri text)]) + [expected (Msg 1605756129 ts nick uri text)]) (check-equal? - (msg-ts-epoch actual) - (msg-ts-epoch expected) + (Msg-ts-epoch actual) + (Msg-ts-epoch expected) "str->msg ts-epoch") (check-equal? - (msg-ts-orig actual) - (msg-ts-orig expected) + (Msg-ts-orig actual) + (Msg-ts-orig expected) "str->msg ts-orig") (check-equal? - (msg-nick actual) - (msg-nick expected) + (Msg-nick actual) + (Msg-nick expected) "str->msg nick") (check-equal? - (msg-uri actual) - (msg-uri expected) + (Msg-uri actual) + (Msg-uri expected) "str->msg uri") (check-equal? - (msg-text actual) - (msg-text expected) + (Msg-text actual) + (Msg-text expected) "str->msg text"))) (: str->lines (-> String (Listof String))) @@ -225,7 +236,7 @@ (module+ test (check-equal? (str->lines "abc\ndef\n\nghi") '("abc" "def" "ghi"))) -(: str->msgs (-> String Url String (Listof Msg))) +(: str->msgs (-> (Option String) Url String (Listof Msg))) (define (str->msgs nick uri str) (filter-map (λ (line) (str->msg nick uri line)) (filter-comments (str->lines str)))) @@ -260,32 +271,33 @@ (log-warning "Cache file not found for URI: ~a" (url->string uri)) ""))) -(: str->feed (String (Option Feed))) -(define (str->feed str) - (log-debug "Parsing feed string: ~v" str) - (match (string-split str) - [(list nick u) - (with-handlers* - ([exn:fail? - (λ (e) - (log-error "Invalid URI: ~v, exn: ~v" u e) - #f)]) - (feed nick (string->url u)))] - [_ - (log-error "Invalid feed string: ~v" str) - #f])) +(: 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) (Peer #f (string->url u))] + [(list n u) (Peer n (string->url u))] + [_ + (log-error "Invalid peer string: ~v" str) + #f]))) + (: filter-comments (-> (Listof String) (Listof String))) (define (filter-comments lines) (filter-not (λ (line) (string-prefix? line "#")) lines)) -(: str->feeds (-> String (Listof Feed))) -(define (str->feeds str) - (filter-map str->feed (filter-comments (str->lines str)))) +(: str->peers (-> String (Listof Peer))) +(define (str->peers str) + (filter-map str->peer (filter-comments (str->lines str)))) -(: file->feeds (-> Path-String (Listof Feed))) -(define (file->feeds filename) - (str->feeds (file->string filename))) +(: file->peers (-> Path-String (Listof Peer))) +(define (file->peers filename) + (str->peers (file->string filename))) (: user-agent String) (define user-agent @@ -293,11 +305,12 @@ ([prog-name "tt"] [prog-version (info:#%info-lookup 'version)] [prog-uri "https://github.com/xandkar/tt"] - [user-feed-file (build-path tt-home-dir "me")] + [user-peer-file (build-path tt-home-dir "me")] [user - (if (file-exists? user-feed-file) - (let ([user (first (file->feeds user-feed-file))]) - (format "+~a; @~a" (url->string (feed-uri user)) (feed-nick 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)]) (format "+~a" prog-uri))]) (format "~a/~a (~a)" prog-name prog-version user))) @@ -337,50 +350,50 @@ (: 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 (string=? prev-nick nick) i (+ 1 i))]) + [((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))) -(: feed->msgs (-> Feed (Listof Msg))) -(define (feed->msgs f) - (match-define (feed nick uri) f) - (log-info "Reading feed nick:~a uri:~v" nick (url->string uri)) +(: peer->msgs (-> Peer (Listof Msg))) +(define (peer->msgs f) + (match-define (Peer nick uri) f) + (log-info "Reading peer nick:~v uri:~v" nick (url->string uri)) (str->msgs nick uri (uri-read-cached uri))) -(: feed-download (-> Feed Void)) -(define (feed-download f) - (match-define (feed nick uri) f) +(: peer-download (-> Peer Void)) +(define (peer-download f) + (match-define (Peer nick uri) f) (define u (url->string uri)) - (log-info "Downloading feed uri:~a" u) + (log-info "Downloading peer uri:~a" u) (with-handlers ([exn:fail? (λ (e) - (log-error "Network error nick:~a uri:~v exn:~v" nick u e) + (log-error "Network error nick:~v uri:~v exn:~v" nick u e) #f)] [integer? (λ (status) - (log-error "HTTP error nick:~a uri:~a status:~a" nick u status) + (log-error "HTTP error nick:~v uri:~a status:~a" nick u status) #f)]) (define-values (_result _tm-cpu-ms tm-real-ms _tm-gc-ms) (time-apply uri-download (list uri))) - (log-info "Feed downloaded in ~a seconds, uri: ~a" (/ tm-real-ms 1000.0) u))) + (log-info "Peer downloaded in ~a seconds, uri: ~a" (/ tm-real-ms 1000.0) u))) -(: timeline-download (-> Integer (Listof Feed) Void)) -(define (timeline-download num-workers feeds) +(: timeline-download (-> Integer (Listof Peer) Void)) +(define (timeline-download num-workers peers) ; TODO No need for map - can just iter - (void (concurrent-filter-map num-workers feed-download feeds))) + (void (concurrent-filter-map num-workers peer-download peers))) ; TODO timeline contract : time-sorted list of messages -(: timeline-read (-> Timeline-Order (Listof Feed) (Listof Msg))) -(define (timeline-read order feeds) +(: timeline-read (-> Timeline-Order (Listof Peer) (Listof Msg))) +(define (timeline-read order peers) (define cmp (match order ['old->new <] ['new->old >])) - (sort (append* (filter-map feed->msgs feeds)) - (λ (a b) (cmp (msg-ts-epoch a) (msg-ts-epoch b))))) + (sort (append* (filter-map peer->msgs peers)) + (λ (a b) (cmp (Msg-ts-epoch a) (Msg-ts-epoch b))))) (: log-writer-stop (-> Thread Void)) (define (log-writer-stop log-writer) @@ -440,7 +453,7 @@ (set! num-workers (string->number njobs))] #:args (filename) (define-values (_res _cpu real-ms _gc) - (time-apply timeline-download (list num-workers (file->feeds filename)))) + (time-apply timeline-download (list num-workers (file->peers filename)))) (log-info "Timeline downloaded in ~a seconds." (/ real-ms 1000.0)) (log-writer-stop log-writer)))] [(or "u" "upload") @@ -469,5 +482,5 @@ "Long output format" (set! out-format 'multi-line)] #:args (filename) - (timeline-print out-format (timeline-read order (file->feeds filename)))))] + (timeline-print out-format (timeline-read order (file->peers filename)))))] ))))