X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=tt.rkt;h=1bc398fbe056c3c311b762a5faa9b6496714bc8a;hb=eade817510cd03ba31e90099238f06d6c30872aa;hp=bc8e8bc5c134b92f596b08b59bfc37ce3a8865a8;hpb=a60c484e9105bad3ec0bd90148b27f44dbfeb266;p=tt.git diff --git a/tt.rkt b/tt.rkt index bc8e8bc..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)))) @@ -476,6 +489,7 @@ ; TODO No need for map - can just iter (void (concurrent-filter-map num-workers peer-download peers))) +(: uniq (∀ (α) (-> (Listof α) (Listof α)))) (define (uniq xs) (set->list (list->set xs))) @@ -505,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) @@ -570,18 +668,28 @@ (time-apply timeline-download (list num-workers peers))) (log-info "Downloaded timelines from ~a peers in ~a seconds." (length peers) - (/ real-ms 1000.0)))))] + (/ 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" @@ -589,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" @@ -600,38 +714,79 @@ (let* ([peers (paths->peers file-paths)] [timeline - (timeline-sort (peers->timeline peers) order)]) + (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 file-paths - (let* ([peers-all-file + #:args log-files-directories + (let* ([peers-sort + (λ (peers) (sort peers (match-lambda** + [((Peer n1 _) (Peer n2 _)) + (stringpeers - (match file-paths - ; TODO Refactor such that path->string not needed - ['() (list (path->string peers-all-file))] - [_ file-paths]))] - [timeline - (peers->timeline peers)] + [peers-followers-file + (build-path tt-home-dir "peers-followers")] + [peers-followers-curr + (follower-peers-in-web-logs + (if (empty? log-files-directories) + (list (build-path tt-home-dir "web-logs")) + log-files-directories))] [peers-mentioned-curr - (uniq (append* (map Msg-mentions timeline)))] + (mentioned-peers-in-cache)] [peers-mentioned-prev (file->peers peers-mentioned-file)] + [peers-followers-prev + (file->peers peers-followers-file)] [peers-mentioned - (uniq (append peers-mentioned-prev - peers-mentioned-curr))] + (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 - (uniq (append peers - peers-mentioned - peers-all-prev))]) + (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