WIP
[tt.git] / tt.rkt
diff --git a/tt.rkt b/tt.rkt
index 5718783..1bc398f 100644 (file)
--- a/tt.rkt
+++ b/tt.rkt
          [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
+           #: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
                     (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
-                                       peers-mentioned
+                    (list->set (append peers-mentioned
+                                       (set->list peers-followers)
                                        peers-all-prev))]
-                  [n-peers-discovered
-                    (set-count (set-subtract peers-all
-                                             (list->set 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 "Discovered ~a new peers." n-peers-discovered)
+             (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
This page took 0.040026 seconds and 4 git commands to generate.