Get most of the functionality sort of working

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

1 files changed, 250 insertions, 0 deletions

diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm
new file mode 100644
index 0000000..96c84ed
--- /dev/null
+++ b/nar-herder/storage.scm
@@ -0,0 +1,250 @@
+;;; 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 storage)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 threads)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (logging logger)
+  #:use-module (logging port-log)
+  #:use-module (json)
+  #:use-module ((guix build utils) #:select (dump-port mkdir-p))
+  #:use-module (nar-herder database)
+  #:export (store-item-in-local-storage?
+
+            start-nar-removal-thread
+            start-mirroring-thread))
+
+(define (store-item-in-local-storage? database storage-root hash)
+  (let ((narinfo-files (database-select-narinfo-files database hash)))
+    (every (lambda (file)
+             (file-exists?
+              (string-append storage-root "/" file)))
+           narinfo-files)))
+
+(define (get-storage-size storage-root)
+  (define enter? (const #t))
+  (define (leaf name stat result)
+    (+ result
+       (or (and=> (stat:blocks stat)
+                  (lambda (blocks)
+                    (* blocks 512)))
+           (stat:size stat))))
+
+  (define (down name stat result) result)
+  (define (up name stat result) result)
+  (define (skip name stat result) result)
+
+  (define (error name stat errno result)
+    (format (current-error-port) "warning: ~a: ~a~%"
+            name (strerror errno))
+    result)
+
+  (file-system-fold enter? leaf down up skip error
+                           0 ; Start counting at 0
+                           storage-root))
+
+(define (remove-nar-from-storage storage-root nar-file-url)
+  (delete-file
+   (string-append storage-root "/" nar-file-url)))
+
+(define (index-storage database storage-root)
+  (define (get-files-hash)
+    (define (get-file-strings prefix children)
+      (append-map
+       (match-lambda
+         ((name stat)
+          (list (string-append prefix "/" name)))
+         ((name stat children ...)
+          (get-file-strings (string-append prefix "/" name)
+                            children)))
+       children))
+
+    (let* ((lst
+            (match (third (file-system-tree storage-root))
+              ((name stat children ...)
+               (get-file-strings (string-append "/" name)
+                                 children))))
+           (hash-table
+            (make-hash-table (length lst))))
+
+      (for-each (lambda (s)
+                  (hash-set! hash-table s #t))
+                lst)
+
+      hash-table))
+
+  (let* ((files-hash
+          (get-files-hash))
+         (narinfo-files
+          (database-map-all-narinfo-files
+           database
+           (lambda (file)
+             (let* ((url (assq-ref file 'url))
+                    (stored? (hash-ref files-hash url)))
+               (when stored?
+                 ;; Delete the hash entry, so
+                 ;; that the hash at the end will
+                 ;; just contain the unrecognised
+                 ;; files
+                 (hash-remove! files-hash url))
+
+               `(,@file
+                 (stored? . ,stored?)))))))
+    `((narinfo-files      . ,narinfo-files)
+      (unrecognised-files . ,(hash-map->list (lambda (key _) key)
+                                             files-hash)))))
+
+(define (start-nar-removal-thread database
+                                  storage-root storage-limit
+                                  nar-removal-criteria)
+
+  (define (check-removal-criteria nar criteria)
+    (match criteria
+      (('and and-criteria ...)
+       (every check-removal-criteria criteria))
+      (('stored-on url)
+       (let ((uri (string->uri
+                   (string-append url (assq-ref nar 'url)))))
+         (call-with-values (http-get uri)
+           (lambda (response body)
+             (and (= (response-code response)
+                     200)
+
+                  (let ((json-body (json-string->scm body)))
+                    (eq? (assoc-ref json-body "stored")
+                         #t)))))))))
+
+  (define (nar-can-be-removed? nar)
+    (any (lambda (criteria)
+           (check-removal-criteria nar criteria))
+         nar-removal-criteria))
+
+  (define (get-stored-nar-files)
+    (let ((index (index-storage database storage-root)))
+      (filter
+       (lambda (file)
+         (assq-ref file 'stored?))
+       (assq-ref index 'narinfo-files))))
+
+  (define (run-removal-pass)
+    (let loop ((storage-size (get-storage-size storage-root))
+               (stored-nar-files (get-stored-nar-files)))
+      ;; Look through items in local storage, check if the removal
+      ;; criteria have been met, and if so, delete it
+
+      (unless (null? stored-nar-files)
+        (let ((nar-to-consider (car stored-nar-files)))
+          (if (nar-can-be-removed? nar-to-consider)
+              (let ((removed-bytes
+                     (remove-nar-from-storage storage-root nar-to-consider)))
+
+                (let ((storage-size-estimate
+                       (- storage-size
+                          removed-bytes)))
+                  (when (> storage-size-estimate storage-limit)
+                    (loop storage-size-estimate
+                          (cdr stored-nar-files)))))
+              (loop storage-size
+                    (cdr stored-nar-files)))))))
+
+  (call-with-new-thread
+   (lambda ()
+     (while #t
+       (run-removal-pass)
+
+       (sleep 300)))))
+
+(define (start-mirroring-thread database mirror storage-limit storage-root)
+  (define (get-missing-nar-files)
+    (let ((index (index-storage database storage-root)))
+      (filter
+       (lambda (file)
+         (not (assq-ref file 'stored?)))
+       (assq-ref index 'narinfo-files))))
+
+  (define (fetch-file file)
+    (let* ((string-url
+            (string-append mirror file))
+           (uri
+            (string->uri (string-append mirror file)))
+           (destination-file-name
+            (string-append storage-root file))
+           (tmp-file-name
+            (string-append destination-file-name "-tmp")))
+      (log-msg 'INFO "fetching " string-url)
+
+      (mkdir-p (dirname destination-file-name))
+
+      (when (file-exists? tmp-file-name)
+        (delete-file tmp-file-name))
+
+      (call-with-values
+          (lambda ()
+            (http-get uri
+                      #:decode-body? #f
+                      #:streaming? #t))
+        (lambda (response body)
+          (unless (= (response-code response)
+                     200)
+            (error "unknown response code"))
+
+          (call-with-output-file tmp-file-name
+            (lambda (output-port)
+              (dump-port body output-port)))
+          (rename-file tmp-file-name
+                       destination-file-name)))))
+
+  (define (run-mirror-pass)
+    (define no-storage-limit?
+      (not (integer? storage-limit)))
+
+    (log-msg 'DEBUG "running mirror pass")
+    (let ((initial-storage-size (get-storage-size storage-root)))
+      ;; If there's free space, then consider downloading missing nars
+      (when (or no-storage-limit?
+                (< initial-storage-size storage-limit))
+        (let loop ((storage-size initial-storage-size)
+                   (missing-nar-files (get-missing-nar-files)))
+          (unless (null? missing-nar-files)
+            (let ((file (car missing-nar-files)))
+              (log-msg 'DEBUG "considering "
+                       (assq-ref file 'url))
+              (let ((file-bytes (assq-ref file 'size)))
+                (if (or no-storage-limit?
+                        (< (+ storage-size file-bytes)
+                           storage-limit))
+                    (begin
+                      (fetch-file (assq-ref file 'url))
+                      (loop (+ storage-size file-bytes)
+                            (cdr missing-nar-files)))
+                    ;; This file won't fit, so try the next one
+                    (loop storage-size
+                          (cdr missing-nar-files))))))))))
+
+  (call-with-new-thread
+   (lambda ()
+     (while #t
+       (run-mirror-pass)
+       (log-msg 'DEBUG "finished mirror pass")
+
+       (sleep 300)))))