X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=tt.rkt;h=1bc398fbe056c3c311b762a5faa9b6496714bc8a;hb=refs%2Fheads%2Ftmp;hp=f470538faef56e2a9631fd8028e7fc5377a9d10f;hpb=8da029e4d172f6a2b440c3e56d9575ea369c0001;p=tt.git diff --git a/tt.rkt b/tt.rkt index f470538..1bc398f 100644 --- a/tt.rkt +++ b/tt.rkt @@ -36,6 +36,14 @@ [uri : Url]) #:transparent) +(struct Follower + ([nick : (Option String)] + [uri : Url] + [client : String] + [version : String]) + #:transparent) + +; TODO Normalize dir var naming (: tt-home-dir Path-String) (define tt-home-dir (build-path (expand-user-path "~") ".tt")) @@ -149,12 +157,13 @@ (define str->msg (let ([re (pregexp "^([^\\s\t]+)[\\s\t]+(.*)$")]) (λ (nick uri str) + (define str-head (substring str 0 (min 100 (string-length str)))) (with-handlers* ([exn:fail? (λ (e) (log-error "Failed to parse msg: ~v, from: ~v, at: ~v, because: ~v" - str nick (url->string uri) e) + str-head nick (url->string uri) e) #f)]) (match (regexp-match re str) [(list _wholething ts-orig text) @@ -170,10 +179,10 @@ (begin (log-error "Msg rejected due to invalid timestamp: ~v, nick:~v, uri:~v" - str nick (url->string uri)) + str-head nick (url->string uri)) #f)))] [_ - (log-debug "Non-msg line from nick:~v, line:~a" nick str) + (log-debug "Non-msg line from nick:~v, line:~a" nick str-head) #f]))))) (module+ test @@ -207,7 +216,7 @@ [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) @@ -260,6 +269,10 @@ (define url->cache-object-path url->cache-file-path-v2) +(: cache-object-filename->url (-> Path-String Url)) +(define (cache-object-filename->url name) + (string->url (uri-decode (path->string name)))) + (define (url->cache-etag-path uri) (build-path cache-dir "etags" (uri-encode (url->string uri)))) @@ -279,6 +292,10 @@ (log-warning "Cache file not found for URI: ~a" (url->string uri)) ""))) +(: uri? (-> String Boolean)) +(define (uri? str) + (regexp-match? #rx"^[a-z]+://.*" (string-downcase str))) + (: str->peer (String (Option Peer))) (define (str->peer str) (log-debug "Parsing peer string: ~v" str) @@ -288,8 +305,8 @@ (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))] + [(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]))) @@ -303,14 +320,61 @@ (define (str->peers str) (filter-map str->peer (filter-comments (str->lines str)))) +(: peers->file (-> (Listof Peers) Path-String Void)) +(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))]) + peers) + path + #:exists 'replace)) + (: file->peers (-> Path-String (Listof Peer))) (define (file->peers file-path) (if (file-exists? file-path) (str->peers (file->string file-path)) (begin - (log-error "File does not exist: ~v" (path->string file-path)) + (log-warning "File does not exist: ~v" (path->string file-path)) '()))) +(define re-rfc2822 + #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") + +(: b->n (-> Bytes (Option Number))) +(define (b->n b) + (string->number (bytes->string/utf-8 b))) + +(: mon->num (-> Bytes Natural)) +(define/match (mon->num mon) + [(#"Jan") 1] + [(#"Feb") 2] + [(#"Mar") 3] + [(#"Apr") 4] + [(#"May") 5] + [(#"Jun") 6] + [(#"Jul") 7] + [(#"Aug") 8] + [(#"Sep") 9] + [(#"Oct") 10] + [(#"Nov") 11] + [(#"Dec") 12]) + +(: rfc2822->epoch (-> Bytes (Option Nonnegative-Integer))) +(define (rfc2822->epoch timestamp) + (match (regexp-match re-rfc2822 timestamp) + [(list _ _ dd mo yyyy HH MM SS) + #:when (and dd mo yyyy HH MM SS) + (find-seconds (b->n SS) + (b->n MM) + (b->n HH) + (b->n dd) + (mon->num mo) + (b->n yyyy) + #f)] + [_ + #f])) + (: user-agent String) (define user-agent (let* @@ -349,26 +413,39 @@ ; TODO Handle redirects (match status [200 - (let ([etag (header-get headers #"ETag")] - [lmod (header-get headers #"Last-Modified")]) - (if (and etag - (file-exists? cached-etag-path) - (bytes=? etag (file->bytes cached-etag-path))) - (log-info "ETags match, skipping the rest of ~v" (url->string u)) - (begin - (log-info - "Downloading the rest of ~v. ETag: ~a, Last-Modified: ~v" - (url->string u) etag lmod) - (make-parent-directory* cached-object-path) - (make-parent-directory* cached-etag-path) - (make-parent-directory* cached-lmod-path) - (call-with-output-file cached-object-path - (curry copy-port body-input) - #:exists 'replace) - (when etag - (display-to-file etag cached-etag-path #:exists 'replace)) - (when lmod - (display-to-file etag cached-lmod-path #:exists 'replace)))) + (let* ([etag (header-get headers #"ETag")] + [lmod (header-get headers #"Last-Modified")] + [lmod-curr (if lmod (rfc2822->epoch lmod) #f)] + [lmod-prev (if (file-exists? cached-lmod-path) + (rfc2822->epoch (file->bytes cached-lmod-path)) + #f)]) + (log-debug "lmod-curr:~v lmod-prev:~v" lmod-curr lmod-prev) + (unless (or (and etag + (file-exists? cached-etag-path) + (bytes=? etag (file->bytes cached-etag-path)) + (begin + (log-info "ETags match, skipping the rest of ~v" (url->string u)) + #t)) + (and lmod-curr + lmod-prev + (<= lmod-curr lmod-prev) + (begin + (log-info "Last-Modified <= current skipping the rest of ~v" (url->string u)) + #t))) + (begin + (log-info + "Downloading the rest of ~v. ETag: ~a, Last-Modified: ~v" + (url->string u) etag lmod) + (make-parent-directory* cached-object-path) + (make-parent-directory* cached-etag-path) + (make-parent-directory* cached-lmod-path) + (call-with-output-file cached-object-path + (curry copy-port body-input) + #:exists 'replace) + (when etag + (display-to-file etag cached-etag-path #:exists 'replace)) + (when lmod + (display-to-file lmod cached-lmod-path #:exists 'replace)))) (close-input-port body-input))] [_ (raise status)])) @@ -412,14 +489,21 @@ ; TODO No need for map - can just iter (void (concurrent-filter-map num-workers peer-download peers))) -; TODO timeline contract : time-sorted list of messages -(: timeline-read (-> Timeline-Order (Listof Peer) (Listof Msg))) -(define (timeline-read order peers) +(: uniq (∀ (α) (-> (Listof α) (Listof α)))) +(define (uniq xs) + (set->list (list->set xs))) + +(: peers->timeline (-> (listof Peer) (listof Msg))) +(define (peers->timeline peers) + (append* (filter-map peer->msgs peers))) + +(: timeline-sort (-> (listof Msg) timeline-order (Listof Msgs))) +(define (timeline-sort msgs order) (define cmp (match order ['old->new <] ['new->old >])) - (sort (append* (filter-map peer->msgs peers)) - (λ (a b) (cmp (Msg-ts-epoch a) (Msg-ts-epoch b))))) + (sort msgs (λ (a b) (cmp (Msg-ts-epoch a) + (Msg-ts-epoch b))))) (: paths->peers (-> (Listof String) (Listof Peer))) (define (paths->peers paths) @@ -435,7 +519,91 @@ (map string->path paths)])] [peers (append* (map file->peers paths))]) (log-info "Read-in ~a peers." (length peers)) - peers)) + (uniq peers))) + +(: mentioned-peers-in-cache (-> (Listof Peer))) +(define (mentioned-peers-in-cache) + (define msgs + (append* (map (λ (filename) + (define path (build-path cache-object-dir filename)) + (define size (/ (file-size path) 1000000.0)) + (log-info "BEGIN parsing ~a MB from file: ~v" + size + (path->string path)) + (define t0 (current-inexact-milliseconds)) + (define m (filter-map + (λ (line) + (str->msg #f (cache-object-filename->url filename) line)) + (filter-comments + (file->lines path)))) + (define t1 (current-inexact-milliseconds)) + (log-info "END parsing ~a MB in ~a seconds from file: ~v." + size + (* 0.001 (- t1 t0)) + (path->string path)) + (when (empty? m) + (log-warning "No messages found in ~a" (path->string path))) + m) + (directory-list cache-object-dir)))) + (uniq (append* (map Msg-mentions msgs)))) + +(: follower->peer (-> Follower Peer)) +(define/match (follower->peer f) + [((Follower n u _ _)) (Peer n u)]) + +(: weblog-line->follower (-> String (Option Peer))) +(define weblog-line->follower + (let ([re #px"([^/]+)/([^ ]+) +\\(\\+([a-z]+://[^;]+); *@([^\\)]+)\\)"]) + (λ (log-line) + (match (regexp-match re log-line) + [(list _ client version uri nick) + (let ([f (Follower nick (string->url uri) client version)]) + (log-debug "Found follower: ~v" f) + f) ] + [_ #f])))) + +(define (weblog-file->peers file-path) + (define size (/ (file-size file-path) 1000000.0)) + (log-info "BEGIN parsing ~a MB from file: ~v" size (path->string file-path)) + (define t0 (current-inexact-milliseconds)) + (define peers + (let* ([prefilter-cmd-path + (build-path tt-home-dir "hooks" "web-log-prefilter")] + [lines + (match (process* prefilter-cmd-path file-path) + [(list in _out pid err ctrl) + (ctrl 'wait) + (match (ctrl 'exit-code) + [(or 0 1) ; Assuming grep's: 0: found, 1: not found, 2: error + (port->lines in)] + [_ + (log-warning "Prefilter hook failed: ~a" (port->string err)) + (file->lines file-path)])])]) + (map follower->peer (filter-map weblog-line->follower lines)))) + (define t1 (current-inexact-milliseconds)) + (log-info "END parsing ~a MB in ~a seconds from file: ~v." + size + (* 0.001 (- t1 t0)) + (path->string file-path)) + (when (empty? peers) + (log-warning "No peers found in ~a" (path->string file-path))) + (uniq peers)) + +(define (weblog-dir->peers dir-path) + (uniq (append* + (map weblog-file->peers + (filter-map + (λ (filename) + (define file-path (build-path dir-path filename)) + (if (equal? 'file (file-or-directory-type file-path)) + file-path + #f)) + (if (directory-exists? dir-path) + (directory-list dir-path) + '())))))) + +(define (follower-peers-in-web-logs log-dirs) + (uniq (append* (map weblog-dir->peers log-dirs)))) (: log-writer-stop (-> Thread Void)) (define (log-writer-stop log-writer) @@ -473,10 +641,11 @@ #:help-labels "" "and is one of" - "r, read i : Read the timeline." + "r, read : Read the timeline (offline operation)." "d, download : Download the timeline." ; TODO Add path dynamically "u, upload : Upload your twtxt file (alias to execute ~/.tt/upload)." + "c, crawl : Discover new peers mentioned by known peers (offline operation)." "" #:args (command . args) (define log-writer (log-writer-start log-level)) @@ -494,20 +663,33 @@ njobs "Number of concurrent jobs." (set! num-workers (string->number njobs))] #:args file-paths - (define-values (_res _cpu real-ms _gc) - (time-apply timeline-download (list num-workers (paths->peers file-paths)))) - (log-info "Timeline downloaded in ~a seconds." (/ real-ms 1000.0))))] + (let ([peers (paths->peers file-paths)]) + (define-values (_res _cpu real-ms _gc) + (time-apply timeline-download (list num-workers peers))) + (log-info "Downloaded timelines from ~a peers in ~a seconds." + (length peers) + (/ real-ms 1000.0))) + (let ([hook-path (build-path tt-home-dir "hooks" "download")]) + (if (file-exists? hook-path) + (if (member 'execute (file-or-directory-permissions hook-path)) + (if (system (path->string hook-path)) + (exit 0) + (exit 1)) + (log-warning "Download hook found, but not executable.")) + (log-warning "Download hook not found.")))))] [(or "u" "upload") (command-line #:program "tt upload" #:args () - (if (system (path->string (build-path tt-home-dir "upload"))) + (if (system (path->string (build-path tt-home-dir "hooks" "upload"))) (exit 0) (exit 1)))] [(or "r" "read") (let ([out-format 'multi-line] - [order 'old->new]) + [order 'old->new] + [ts-min #f] + [ts-max #f]) (command-line #:program "tt read" @@ -515,6 +697,12 @@ [("-r" "--rev") "Reverse displayed timeline order." (set! order 'new->old)] + [("-m" "--min") + m "Earliest time to display (ignore anything before it)." + (set! ts-min (rfc3339->epoch m))] + [("-x" "--max") + x "Latest time to display (ignore anything after it)." + (set! ts-max (rfc3339->epoch x))] #:once-any [("-s" "--short") "Short output format" @@ -523,5 +711,88 @@ "Long output format" (set! out-format 'multi-line)] #:args file-paths - (timeline-print out-format (timeline-read order (paths->peers file-paths)))))]) + (let* ([peers + (paths->peers file-paths)] + [timeline + (timeline-sort (peers->timeline peers) order)] + [timeline + (filter (λ (m) (and (if ts-min (>= (Msg-ts-epoch m) + ts-min) + #t) + (if ts-max (<= (Msg-ts-epoch m) + ts-max) + #t))) + timeline)]) + (timeline-print out-format timeline))))] + [(or "c" "crawl") + (command-line + #:program + "tt crawl" + #:args log-files-directories + (let* ([peers-sort + (λ (peers) (sort peers (match-lambda** + [((Peer n1 _) (Peer n2 _)) + (stringpeers peers-mentioned-file)] + [peers-followers-prev + (file->peers peers-followers-file)] + [peers-mentioned + (peers-sort (uniq (append peers-mentioned-prev + peers-mentioned-curr)))] + [peers-all-prev + (file->peers peers-all-file)] + [peers-followers + (list->set (append peers-followers-prev + peers-followers-curr))] + [peers-all + (list->set (append peers-mentioned + (set->list peers-followers) + peers-all-prev))] + [peers-discovered-followers + (set-subtract (list->set peers-followers) + (list->set peers-followers-prev))] + [peers-discovered + (set-subtract peers-all (list->set peers-all-prev))] + [peers-all + (peers-sort (set->list peers-all))]) + (log-info "Known peers mentioned: ~a" (length peers-mentioned)) + (log-info "Known peers total: ~a" (length peers-all)) + (log-info "Discovered ~a new followers:~n~a" + (set-count peers-discovered-followers) + (pretty-format (map + (λ (p) (cons (Peer-nick p) + (url->string (Peer-uri p)))) + (set->list peers-discovered-followers)))) + (log-info "Discovered ~a new peers:~n~a" + (set-count peers-discovered) + (pretty-format (map + (λ (p) (cons (Peer-nick p) + (url->string (Peer-uri p)))) + (set->list peers-discovered)))) + (peers->file (peers-sort (set->list peers-followers)) + peers-followers-file) + (peers->file peers-mentioned + peers-mentioned-file) + (peers->file peers-all + peers-all-file)))] + [command + (eprintf "Error: invalid command: ~v\n" command) + (eprintf "Please use the \"--help\" option to see a list of available commands.\n") + (exit 1)]) (log-writer-stop log-writer))))