Git Monitoring process

collects/meta/drdr2/git-monitor/monitor.rkt

@@ -1,15 +1,49 @@
 #lang racket
-(require "../lib/pqueue.rkt")
+(require "../lib/pqueue.rkt"
+         "../lib/db.rkt"
+         "scm.rkt")
 
-(define (main)
-  
+(define-syntax-rule (atomic e ...) 
+  (begin e ...))
+
+(define (main . argv)
+  (define push-queue (make-parameter #f))
+  (define the-db (make-parameter #f))
+  (define repo (make-parameter #f))
+  (define monitoring-interval (make-parameter 60))
+  (command-line 
+   #:program "monitor"
+   #:argv argv
+   #:once-each
+   [("--interval") num "Monitoring interval" (monitoring-interval (string->number num))]
+   [("--repo") dir "Local Git repository" (repo dir)]
+   [("--pushes") dir "Persistent queue of pushes" (push-queue dir)]
+   [("--db") spec "Specification of database" (the-db spec)])
   ; Setup the queue to receive push information
-  ; Read the short term database to find out what push we're at
-  ; While true
-  ;  Check the online push counter
-  ;  Get the information about a push
-  ;  Add it to the queue
-  ;  Add it to the long term database
-  ;  Update the latest push in the short term database
+  (define pushes (pqueue (push-queue)))
+  (pqueue-init! pushes)
   
-  ...)
+  (define db (db-connect (the-db)))
+  ; While true
+  (let loop () 
+    ; Read the short term database to find out what push we're at
+    (define current (db-ref db "monitor" "last-push"))
+    ; Update the git repository
+    (git-update (repo))
+    ; Check the online push counter
+    (for ([new (in-list (git-pushes-after current))])
+      ; Get the information about a push
+      (define push-info (get-git-push (repo) new))
+      (atomic
+       ;  Add it to the queue
+       (pqueue-enqueue! pushes push-info)
+       ; Add it to the long term database
+       (db-set! db "push-info" new push-info)
+       ; Update the latest push in the short term database
+       (db-set! db "monitor" "last-push" new)))
+    ; Wait
+    (sleep (monitoring-interval))
+    (loop))
+  (db-close! db))
+
+(provide main)

collects/meta/drdr2/git-monitor/scm.rkt

@@ -0,0 +1,136 @@
+#lang racket/base
+(require net/url
+         racket/system
+         racket/function
+         racket/list
+         racket/match
+         racket/port
+         racket/contract
+         "../lib/scm.rkt")
+
+(define git-path (find-executable-path "git"))
+(define git-url-base "http://git.racket-lang.org/plt.git") 
+(define (get-newest-push)
+  (string->number (port->string (get-pure-port (string->url (format "~a/push-counter" git-url-base))))))
+
+(define (pad2zeros n)
+  (format "~a~a"
+          (if (n . < . 10)
+              "0" "")
+          (number->string n)))
+
+(struct push-data (who end-commit branches) #:prefab)
+
+(define (get-push-data push-n)
+  (define push-n100s (quotient push-n 100))
+  (define push-nrem (pad2zeros (modulo push-n 100)))
+  (define ls 
+    (port->lines 
+     (get-pure-port 
+      (string->url 
+       (format "~a/pushes/~a/~a" git-url-base push-n100s push-nrem)))))
+  (match ls
+    [(list (regexp #rx"^([^ ]+) +([0-9abcdef]+)$" (list _ who end-commit))
+           (regexp #rx"^([0-9abcdef]+) +([0-9abcdef]+) +(.+)$" (list _ bstart bend branch))
+           ...)
+     (push-data who end-commit 
+                (make-immutable-hash
+                 (map (lambda (b bs be) (cons b (vector bs be)))
+                      branch bstart bend)))]
+    [_
+     #f]))
+
+(define (close-input-port* p)
+  (when p (close-input-port p)))
+(define (close-output-port* p)
+  (when p (close-output-port p)))
+
+(define (system/output-port #:k k #:stdout [init-stdout #f] . as)
+  (define-values (sp stdout stdin stderr)
+    (apply subprocess init-stdout #f #f as))
+  (begin0 (k stdout)
+          (subprocess-wait sp)
+          (subprocess-kill sp #t)
+          (close-input-port* stdout)
+          (close-output-port* stdin)
+          (close-input-port* stderr)))
+
+(define (read-until-empty-line in-p)
+  (let loop ()
+    (let ([l (read-line in-p)])
+      (cond
+        [(eof-object? l)
+         (close-input-port in-p)
+         empty]
+        [(string=? l "")
+         empty]
+        [else
+         (list* (regexp-replace #rx"^ +" l "") (loop))]))))
+
+(define (read-commit in-p)
+  (match (read-line in-p)
+    [(? eof-object?)
+     #f]
+    [(regexp #rx"^commit +(.+)$" (list _ hash))
+     (match (read-line in-p)
+       [(regexp #rx"^Merge: +(.+) +(.+)$" (list _ from to))
+        (match-define (regexp #rx"^Author: +(.+)$" (list _ author)) (read-line in-p))
+        (match-define (regexp #rx"^Date: +(.+)$" (list _ date)) (read-line in-p))
+        (define _1 (read-line in-p))
+        (define msg (read-until-empty-line in-p))
+        (git-merge hash author date msg from to)]
+       [(regexp #rx"^Author: +(.+)$" (list _ author))
+        (match-define (regexp #rx"^Date: +(.+)$" (list _ date)) (read-line in-p))
+        (define _1 (read-line in-p))
+        (define msg (read-until-empty-line in-p))
+        (define mfiles (read-until-empty-line in-p))
+        (git-diff hash author date msg mfiles)])]))
+
+(define master-branch "refs/heads/master")
+(define (git-pushes-after cur-rev)
+  (define newest-rev (get-newest-push))
+  (for/list ([rev (in-range (add1 cur-rev) (add1 newest-rev))]
+             #:when
+             (let ([info (get-push-data rev)])
+               (and info (hash-has-key? (push-data-branches info) master-branch))))
+    rev))
+
+(define (git-update repo)
+  (parameterize ([current-directory repo])
+    (system* git-path "fetch" git-url-base))
+  (void))
+
+(define (read-commits in-p)
+  (cond
+    [(port-closed? in-p)
+     empty]
+    [(read-commit in-p)
+     => (lambda (c) 
+          (printf "~S\n" c)
+          (list* c (read-commits in-p)))]
+    [else
+     empty]))
+(define (parse-push repo num author in-p)
+  (define commits (read-commits in-p))
+  (define start (git-commit-hash (last commits)))
+  (define previous-commit 
+    (parameterize ([current-directory repo])
+      (system/output-port 
+       #:k (λ (port) (read-line port))
+       git-path "--no-pager" "log" "--format=format:%P" start "-1")))
+  (git-push num author previous-commit commits))
+
+(define (get-git-push repo rev)
+  (match-define (push-data who _ branches) (get-push-data rev))
+  (match-define (vector start-commit end-commit) (hash-ref branches master-branch))  
+  (parameterize ([current-directory repo])
+    (system/output-port 
+     #:k (curry parse-push repo rev who)
+     git-path
+     "--no-pager" "log" "--date=iso" "--name-only" "--no-merges"
+     (format "~a..~a" start-commit end-commit))))
+
+(provide/contract
+ [git-pushes-after (exact-nonnegative-integer? . -> . (listof exact-nonnegative-integer?))]
+ [git-update (path? . -> . void?)]
+ [get-git-push (path? exact-nonnegative-integer? . -> . git-push?)])

collects/meta/drdr2/lib/db.rkt

@@ -0,0 +1,18 @@
+#lang racket/base
+(require racket/match)
+
+(define (db-connect spec)
+  #f)
+
+(define (db-ref db . path)
+  #f)
+
+(define db-set!
+  (match-lambda*
+    [(list db path ... value)
+     #f]))
+
+(define (db-close! db)
+  #f)
+
+(provide (all-defined-out))

collects/meta/drdr2/lib/pqueue.rkt

@@ -1,5 +1,8 @@
-#lang racket
-(require mzlib/os)
+#lang racket/base
+(require mzlib/os
+         racket/contract
+         racket/file
+         racket/match)
 
 (struct pqueue (dir))
 

collects/meta/drdr2/lib/scm.rkt

@@ -0,0 +1,41 @@
+#lang racket/base
+(require racket/list
+         racket/contract)
+
+(struct git-push (num author previous-commit commits) #:prefab)
+(struct git-commit (hash author date msg) #:prefab)
+(struct git-diff git-commit (mfiles) #:prefab)
+(struct git-merge git-commit (from to) #:prefab)
+
+(provide/contract
+ [struct git-push 
+         ([num exact-nonnegative-integer?]
+          [author string?]
+          [previous-commit string?]
+          [commits (listof git-commit?)])]
+ [struct git-commit 
+         ([hash string?]
+          [author string?]
+          [date string?]
+          [msg (listof string?)])]
+ [struct git-diff 
+         ([hash string?]
+          [author string?]
+          [date string?]
+          [msg (listof string?)]
+          [mfiles (listof string?)])]
+ [struct git-merge 
+         ([hash string?]
+          [author string?]
+          [date string?]
+          [msg (listof string?)]
+          [from string?]
+          [to string?])])
+  
+(define (git-push-start-commit gp)
+  (git-commit-hash (last (git-push-commits gp))))
+(define (git-push-end-commit gp)
+  (git-commit-hash (first (git-push-commits gp))))
+(provide/contract
+ [git-push-start-commit (git-push? . -> . string?)]
+ [git-push-end-commit (git-push? . -> . string?)])