Get most of the functionality sort of working

At least working enough to start trying this out, and finding the
problems.

1 files changed, 82 insertions, 0 deletions

diff --git a/nar-herder/mirror.scm b/nar-herder/mirror.scm
new file mode 100644
index 0000000..01da2ba
--- /dev/null
+++ b/nar-herder/mirror.scm
@@ -0,0 +1,82 @@
+;;; Nar Herder
+;;;
+;;; Copyright © 2021 Christopher Baines <mail@cbaines.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (nar-herder mirror)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-43)
+  #:use-module (ice-9 threads)
+  #:use-module (rnrs bytevectors)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (logging logger)
+  #:use-module (json)
+  #:use-module (guix narinfo)
+  #:use-module (nar-herder database)
+  #:export (start-fetch-changes-thread))
+
+(define (start-fetch-changes-thread database mirror)
+  (define (request-recent-changes)
+    (define latest-recent-change
+      (database-select-latest-recent-change-datetime database))
+
+    (define processed-recent-changes
+      (database-select-recent-changes database latest-recent-change))
+
+    (call-with-values
+        (lambda ()
+          (http-get
+           (string->uri
+            (string-append mirror "/recent-changes"
+                           (if latest-recent-change
+                               (string-append "?since=" latest-recent-change)
+                               "")))
+           #:decode-body? #f))
+      (lambda (response body)
+        (if (= (response-code response) 200)
+            (let ((json-body (json-string->scm
+                              (utf8->string body))))
+              (vector-for-each
+               (lambda (_ change-details)
+                 ;; Guard against processing changes that have already
+                 ;; been processed
+                 (unless (member processed-recent-changes change-details)
+                   (let ((change (assoc-ref change-details "change")))
+                     (cond
+                      ((string=? change "addition")
+                       (let ((narinfo
+                              (call-with-input-string
+                                  (assoc-ref change-details "data")
+                                (lambda (port)
+                                  (read-narinfo port
+                                                "https://narherderdummyvalue")))))
+                         (log-msg 'INFO "processing addition change for "
+                                  (first (narinfo-uris narinfo)))
+                         (database-insert-narinfo database
+                                                  narinfo)))
+                      (else
+                       (error "unimplemented"))))))
+               (assoc-ref json-body "recent_changes")))
+            (error "unknown response code")))))
+
+  (call-with-new-thread
+   (lambda ()
+     (while #t
+       (request-recent-changes)
+
+       (sleep 60)))))