[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"))
(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)
(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
[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)
(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))))
(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)
(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"
[("-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"
(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 _))
+ (string<? (if n1 n1 "")
+ (if n2 n2 ""))])))]
+ ; TODO Tidy-up redundant set conversions
+ [peers-all-file
(build-path tt-home-dir "peers-all")]
[peers-mentioned-file
(build-path tt-home-dir "peers-mentioned")]
- [peers
- (paths->peers
- (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