X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=tt.rkt;h=1bc398fbe056c3c311b762a5faa9b6496714bc8a;hb=eade817510cd03ba31e90099238f06d6c30872aa;hp=2292a9abfcea79a4eb58f65dd3c4683d2e2ddfb6;hpb=ef07b6edb836559d5c734ab08a3521759cef5565;p=tt.git diff --git a/tt.rkt b/tt.rkt index 2292a9a..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)))) @@ -508,6 +521,90 @@ (log-info "Read-in ~a peers." (length 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) (log-message (current-logger) 'fatal 'stop "Exiting." #f) @@ -571,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" @@ -590,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" @@ -601,43 +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 + #: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 (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 (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