aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--nar-herder/database.scm52
-rw-r--r--nar-herder/mirror.scm23
-rw-r--r--nar-herder/recent-changes.scm59
-rw-r--r--nar-herder/server.scm133
-rw-r--r--nar-herder/storage.scm105
-rw-r--r--nar-herder/utils.scm25
-rw-r--r--scripts/nar-herder.in111
7 files changed, 329 insertions, 179 deletions
diff --git a/nar-herder/database.scm b/nar-herder/database.scm
index ded7c2c..e170d64 100644
--- a/nar-herder/database.scm
+++ b/nar-herder/database.scm
@@ -111,8 +111,6 @@ CREATE TABLE narinfos (
added_at TEXT
);
-CREATE UNIQUE INDEX narinfos_store_hash ON narinfos (substr(store_path, 12, 32));
-
CREATE TABLE narinfo_files (
narinfo_id INTEGER NOT NULL REFERENCES narinfos (id),
size INTEGER NOT NULL,
@@ -120,8 +118,6 @@ CREATE TABLE narinfo_files (
url TEXT NOT NULL
);
-CREATE INDEX narinfo_files_narinfo_id ON narinfo_files (narinfo_id);
-
CREATE TABLE narinfo_references (
narinfo_id INTEGER NOT NULL REFERENCES narinfos (id),
store_path TEXT NOT NULL
@@ -133,8 +129,6 @@ CREATE TABLE tags (
value TEXT NOT NULL
);
-CREATE UNIQUE INDEX tags_index ON tags (key, value);
-
CREATE TABLE narinfo_tags (
narinfo_id INTEGER NOT NULL REFERENCES narinfos (id),
tag_id INTEGER NOT NULL REFERENCES tags (id)
@@ -154,9 +148,6 @@ CREATE TABLE cached_narinfo_files (
compression TEXT
);
-CREATE INDEX cached_narinfo_files_narinfo_id
- ON cached_narinfo_files (narinfo_id);
-
CREATE TABLE scheduled_narinfo_removal (
narinfo_id INTEGER PRIMARY KEY ASC REFERENCES narinfos (id),
removal_datetime TEXT NOT NULL
@@ -216,10 +207,7 @@ CREATE TABLE cached_narinfo_files (
narinfo_id INTEGER NOT NULL REFERENCES narinfos (id),
size INTEGER NOT NULL,
compression TEXT NOT NULL
-);
-
-CREATE INDEX cached_narinfo_files_narinfo_id
- ON cached_narinfo_files (narinfo_id);"))
+);"))
(unless (column-exists? db "narinfos" "added_at")
(sqlite-exec
@@ -246,6 +234,22 @@ CREATE TABLE scheduled_cached_narinfo_removal (
(sqlite-exec
db
+ "
+CREATE UNIQUE INDEX IF NOT EXISTS
+ narinfos_store_hash ON narinfos (substr(store_path, 12, 32));")
+
+ (sqlite-exec
+ db
+ "CREATE UNIQUE INDEX IF NOT EXISTS
+ tags_index ON tags (key, value);")
+
+ (sqlite-exec
+ db
+ "CREATE INDEX IF NOT EXISTS cached_narinfo_files_narinfo_id
+ ON cached_narinfo_files (narinfo_id);")
+
+ (sqlite-exec
+ db
"CREATE INDEX IF NOT EXISTS narinfo_tags_narinfo_id
ON narinfo_tags (narinfo_id);")
@@ -257,7 +261,12 @@ CREATE TABLE scheduled_cached_narinfo_removal (
(sqlite-exec
db
"CREATE INDEX IF NOT EXISTS narinfo_files_narinfo_id
- ON narinfo_files (narinfo_id);"))
+ ON narinfo_files (narinfo_id);")
+
+ (sqlite-exec
+ db
+ "CREATE INDEX IF NOT EXISTS narinfo_files_url
+ ON narinfo_files (url);"))
(define* (setup-database database-file metrics-registry
#:key (reader-threads 1))
@@ -577,12 +586,25 @@ PRAGMA optimize;")))
(apply values vals))))
(define (dump-database database name)
+ (define (strip-db name)
+ (let ((db (db-open name)))
+ (let ((tables-to-clear
+ '("cached_narinfo_files")))
+ (for-each
+ (lambda (table)
+ (sqlite-exec db (simple-format #f "DELETE FROM ~A;" table)))
+ tables-to-clear))
+
+ (sqlite-close db)))
+
(call-with-worker-thread
(database-reader-thread-channel database)
(lambda (db)
(sqlite-exec
db
- (string-append "VACUUM INTO '" name "';")))))
+ (string-append "VACUUM INTO '" name "';"))
+
+ (strip-db name))))
(define (last-insert-rowid db)
(let ((statement
diff --git a/nar-herder/mirror.scm b/nar-herder/mirror.scm
index 8aae845..14e23a9 100644
--- a/nar-herder/mirror.scm
+++ b/nar-herder/mirror.scm
@@ -41,7 +41,11 @@
(define (start-fetch-changes-fiber database metrics-registry
storage-root mirror
+ addition-channel
cached-compression-management-channel)
+ (define recent-changes-count-metric
+ (metrics-registry-fetch-metric metrics-registry "recent_changes_count"))
+
(define (request-recent-changes)
(define latest-recent-change
(database-select-latest-recent-change-datetime database))
@@ -105,6 +109,8 @@
(unless (member (strip-change-datetime change-details)
processed-recent-changes)
(let ((change (assq-ref change-details 'change)))
+ (metric-increment recent-changes-count-metric)
+
(cond
((string=? change "addition")
(let ((narinfo
@@ -120,10 +126,20 @@
narinfo
#:change-datetime
(assq-ref change-details
- 'datetime))))
+ 'datetime))
+
+ (when addition-channel
+ (for-each
+ (lambda (uri)
+ (spawn-fiber
+ (lambda ()
+ (put-message addition-channel
+ `(addition ,(uri-path uri))))))
+ (narinfo-uris narinfo)))))
((string=? change "removal")
(let ((store-path (assq-ref change-details 'data)))
+ ;; TODO Use the nar removal fiber
(log-msg 'INFO "processing removal change for "
store-path
" (" (assq-ref change-details 'datetime) ")")
@@ -176,6 +192,11 @@
(spawn-fiber
(lambda ()
+ (let ((recent-changes-count
+ (database-count-recent-changes database)))
+ (metric-set recent-changes-count-metric recent-changes-count)
+ (log-msg 'DEBUG recent-changes-count " recent changes in the database"))
+
(while #t
(with-exception-handler
(lambda (exn)
diff --git a/nar-herder/recent-changes.scm b/nar-herder/recent-changes.scm
index ccfff93..62bd604 100644
--- a/nar-herder/recent-changes.scm
+++ b/nar-herder/recent-changes.scm
@@ -137,35 +137,38 @@
(log-msg 'ERROR "exception in recent change listener " exn)
#f)
(lambda ()
- (let* ((recent-changes
- (database-select-recent-changes database after))
- (unprocessed-recent-changes
- (remove
+ (with-throw-handler #t
+ (lambda ()
+ (let* ((recent-changes
+ (database-select-recent-changes database after))
+ (unprocessed-recent-changes
+ (remove
+ (lambda (change-details)
+ (member change-details last-processed-recent-changes))
+ recent-changes)))
+
+ (unless (null? unprocessed-recent-changes)
+ (log-msg 'INFO "processing " (length unprocessed-recent-changes)
+ " recent changes")
+
+ (for-each
(lambda (change-details)
- (member change-details last-processed-recent-changes))
- recent-changes)))
-
- (unless (null? unprocessed-recent-changes)
- (log-msg 'INFO "processing " (length unprocessed-recent-changes)
- " recent changes")
-
- (metric-increment recent-changes-count-metric
- #:by (length unprocessed-recent-changes))
-
- (for-each
- (lambda (change-details)
- (let ((change (assq-ref change-details 'change)))
- (cond
- ((string=? change "addition")
- (process-addition-change change-details))
- ((string=? change "removal")
- (process-removal-change change-details))
- (else #f))))
- unprocessed-recent-changes))
-
- ;; Use the unprocessed recent changes here to carry
- ;; forward all processed changes to the next pass
- unprocessed-recent-changes))
+ (let ((change (assq-ref change-details 'change)))
+ (cond
+ ((string=? change "addition")
+ (process-addition-change change-details))
+ ((string=? change "removal")
+ (process-removal-change change-details))
+ (else #f))))
+ unprocessed-recent-changes)
+
+ (metric-increment recent-changes-count-metric
+ #:by (length unprocessed-recent-changes)))
+ ;; Use the unprocessed recent changes here to carry
+ ;; forward all processed changes to the next pass
+ unprocessed-recent-changes))
+ (lambda _
+ (backtrace))))
#:unwind? #t)
(#f (loop after '()))
(recent-changes
diff --git a/nar-herder/server.scm b/nar-herder/server.scm
index 2e2c1e7..97f0567 100644
--- a/nar-herder/server.scm
+++ b/nar-herder/server.scm
@@ -217,6 +217,10 @@
(response_code . ,response-code)
,@labels)))
+ (define loop-detections-metric
+ (make-counter-metric metrics-registry
+ "loop_detections_total"))
+
(define %compression-strings
(map symbol->string
%compression-options))
@@ -226,7 +230,12 @@
'DEBUG
(request-method request)
" "
- (uri-path (request-uri request)))
+ (uri-path (request-uri request))
+ (let ((via (request-via request)))
+ (if (null? via)
+ ""
+ (string-append
+ " (Via: " (string-join via ", ") ")"))))
(match (cons (request-method request)
(split-and-decode-uri-path
@@ -324,8 +333,16 @@
(string-take narinfo 32)))))
(values (build-response #:code 404)
"404"))))
- (((or 'HEAD 'GET) "nar" compression filename)
- (let* ((hash (and (>= (string-length filename) 32)
+ ;; TODO The uris in narinfo files can be anything I believe,
+ ;; which doesn't match up with this code
+ (((or 'HEAD 'GET) "nar" rest ...)
+ (let* ((compression
+ (if (= (length rest) 1)
+ "none"
+ (first rest)))
+ (filename
+ (last rest))
+ (hash (and (>= (string-length filename) 32)
(string-take filename 32)))
(narinfo
(and hash
@@ -369,6 +386,7 @@
(assq-ref narinfo 'id)))
(when loop?
+ (metric-increment loop-detections-metric)
(log-msg logger 'WARN
(request-method request)
" "
@@ -395,11 +413,11 @@
(request-via request)))
(values (build-response
#:code 200
- #:headers `((X-Accel-Redirect
- . ,(string-append
- "/internal/nar/"
- compression "/"
- (uri-encode filename)))))
+ #:headers
+ `((X-Accel-Redirect
+ . ,(string-append
+ "/internal"
+ (assq-ref narinfo-file-for-compression 'url)))))
#f)))
(let ((cached-narinfo-file
(and narinfo ; must be a known hash
@@ -437,11 +455,14 @@
(if cached-narinfo-file
(values (build-response
#:code 200
- #:headers `((X-Accel-Redirect
- . ,(string-append
- "/internal/cached-nar/"
- compression "/"
- (uri-encode filename)))))
+ #:headers
+ `((X-Accel-Redirect
+ . ,(string-append
+ "/internal/cached-nar/"
+ ;; This must match up with
+ ;; add-cached-compressions-to-narinfo
+ compression "/"
+ (uri-encode filename)))))
#f)
(values (build-response #:code 404)
"404"))))))
@@ -735,7 +756,16 @@
compression)
'directory)))
(utime (string-append directory "/" filename))))
- maintenance-scheduler)))))
+ maintenance-scheduler))))
+
+ (nar-removal-criteria
+ (filter-map
+ (match-lambda
+ ((key . val)
+ (if (eq? key 'storage-nar-removal-criteria)
+ val
+ #f)))
+ opts)))
(if (string=? (assq-ref opts 'database-dump)
"disabled")
@@ -770,43 +800,32 @@
(assq-ref opts 'recent-changes-limit))
(let ((mirror-channel
- (and=>
- (assq-ref opts 'mirror)
- (lambda (mirror)
- (start-fetch-changes-fiber
- database
- metrics-registry
- canonical-storage ; might be #f, but that's fine here
- mirror
- cached-compression-management-channel)
-
- (if (assq-ref opts 'storage)
- (start-mirroring-fiber database
- mirror
- (assq-ref opts 'storage-limit)
- canonical-storage
- metrics-registry)
- #f))))
+ (and (assq-ref opts 'mirror)
+ (assq-ref opts 'storage)
+ (start-mirroring-fiber database
+ (assq-ref opts 'mirror)
+ (assq-ref opts 'storage-limit)
+ (assq-ref opts 'minimum-free-space)
+ canonical-storage
+ metrics-registry)))
(removal-channel
- (let ((nar-removal-criteria
- (filter-map
- (match-lambda
- ((key . val)
- (if (eq? key 'storage-nar-removal-criteria)
- val
- #f)))
- opts)))
- (if (and (assq-ref opts 'storage)
- (number? (assq-ref opts 'storage-limit))
- (not (null? nar-removal-criteria)))
- (start-nar-removal-fiber database
- canonical-storage
- (assq-ref opts 'storage-limit)
- metrics-registry
- nar-removal-criteria)
- #f)))
+ (start-nar-removal-fiber
+ database
+ canonical-storage
+ (assq-ref opts 'storage-limit)
+ metrics-registry
+ nar-removal-criteria))
(addition-channel (make-channel)))
+ (when (assq-ref opts 'mirror)
+ (start-fetch-changes-fiber
+ database
+ metrics-registry
+ canonical-storage ; might be #f, but that's fine here
+ (assq-ref opts 'mirror)
+ addition-channel
+ cached-compression-management-channel))
+
(spawn-fiber
(lambda ()
(while #t
@@ -832,7 +851,10 @@
(lambda ()
(put-message mirror-channel
`(fetch ,file)))))
- (when removal-channel
+
+ (when (and (assq-ref opts 'storage)
+ (number? (assq-ref opts 'storage-limit))
+ (not (null? nar-removal-criteria)))
(spawn-fiber
(lambda ()
(sleep 60)
@@ -849,11 +871,12 @@
file)))))))
#:unwind? #t))))
- (start-recent-change-listener-fiber
- database
- metrics-registry
- addition-channel
- removal-channel))
+ (unless (assq-ref opts 'mirror)
+ (start-recent-change-listener-fiber
+ database
+ metrics-registry
+ addition-channel
+ removal-channel)))
(unless (null? enabled-cached-compressions)
(let ((cached-compression-removal-fiber-wakeup-channel
@@ -897,7 +920,7 @@
(iota (length schedulers))
schedulers))
- (log-msg 'INFO "starting server, listening on "
+ (log-msg 'INFO "starting server (" (getpid) "), listening on "
(assq-ref opts 'host) ":" (assq-ref opts 'port))
(run-server/patched
diff --git a/nar-herder/storage.scm b/nar-herder/storage.scm
index e85d745..b57ccd8 100644
--- a/nar-herder/storage.scm
+++ b/nar-herder/storage.scm
@@ -33,6 +33,7 @@
#:use-module (prometheus)
#:use-module (json)
#:use-module ((guix build utils) #:select (dump-port mkdir-p))
+ #:use-module ((guix build syscalls) #:select (free-disk-space))
#:use-module ((guix store) #:select (store-path-hash-part))
#:use-module (guix progress)
#:use-module (nar-herder utils)
@@ -77,7 +78,8 @@
(file-exists? filename)))
(when exists?
(remove-nar-from-storage storage-root
- (assq-ref file 'url)))
+ (uri-decode
+ (assq-ref file 'url))))
(and=> (metrics-registry-fetch-metric metrics-registry
"nar_files_total")
@@ -392,8 +394,10 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
metrics-registry
nar-removal-criteria)
(define storage-size-metric
- (make-gauge-metric metrics-registry
- "storage_size_bytes"))
+ (or (metrics-registry-fetch-metric metrics-registry
+ "storage_size_bytes")
+ (make-gauge-metric metrics-registry
+ "storage_size_bytes")))
(define removal-channel
(make-channel))
@@ -441,8 +445,11 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
#:timeout 30)))))
(define (nar-can-be-removed? nar)
+ (log-msg 'INFO "checking if " (assq-ref nar 'url) " can be removed")
(any (lambda (criteria)
- (check-removal-criteria nar criteria))
+ (let ((result (check-removal-criteria nar criteria)))
+ (log-msg 'INFO "removal criteria (" criteria "): " result)
+ result))
nar-removal-criteria))
(define (run-removal-pass)
@@ -490,9 +497,6 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
(log-msg 'INFO "finished looking for nars to remove, removed "
removed-count " files"))))))
- (when (null? nar-removal-criteria)
- (error "must be some removal criteria"))
-
(spawn-fiber
(lambda ()
(while #t
@@ -507,6 +511,9 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
(lambda ()
(with-throw-handler #t
(lambda ()
+ (when (null? nar-removal-criteria)
+ (error "must be some removal criteria"))
+
(cond
((not (file-exists?
(string-append storage-root
@@ -536,35 +543,49 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
(log-msg 'ERROR "failed to remove " file ": " exn))
(lambda ()
;; TODO: Do more checking at this point
- (remove-nar-from-storage
- storage-root
- (uri-decode file))
+ (when storage-root
+ (remove-nar-from-storage
+ storage-root
+ (uri-decode file)))
(update-nar-files-metric metrics-registry
'()
#:removed-count 1))
#:unwind? #t))))))
- (spawn-fiber
- (lambda ()
- (while #t
- (with-exception-handler
- (lambda (exn)
- (log-msg 'ERROR "nar removal pass failed " exn))
- run-removal-pass
- #:unwind? #t)
- (sleep (* 60 60 24)))))
+ (when (and storage-root
+ (not (null? nar-removal-criteria)))
+ (spawn-fiber
+ (lambda ()
+ (while #t
+ (with-exception-handler
+ (lambda (exn)
+ (log-msg 'ERROR "nar removal pass failed " exn))
+ run-removal-pass
+ #:unwind? #t)
+ (sleep (* 60 60 24))))))
removal-channel)
-(define (start-mirroring-fiber database mirror storage-limit storage-root
- metrics-registry)
+(define (start-mirroring-fiber database mirror storage-limit minimum-free-space
+ storage-root metrics-registry)
- (define no-storage-limit?
- (not (integer? storage-limit)))
+ (define storage-limit?
+ (integer? storage-limit))
+
+ (define minimum-free-space?
+ (integer? minimum-free-space))
(define storage-size-metric
- (make-gauge-metric metrics-registry
- "storage_size_bytes"))
+ (or (metrics-registry-fetch-metric metrics-registry
+ "storage_size_bytes")
+ (make-gauge-metric metrics-registry
+ "storage_size_bytes")))
+
+ (define storage-free-space-metric
+ (or (metrics-registry-fetch-metric metrics-registry
+ "storage_free_space_bytes")
+ (make-gauge-metric metrics-registry
+ "storage_free_space_bytes")))
(define (fetch-file file)
(let* ((string-url
@@ -621,9 +642,19 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
'()
#:fetched-count 1)))
- (define (download-nars initial-storage-size)
- ;; If there's free space, then consider downloading missing nars
- (if (< initial-storage-size storage-limit)
+ (define (download-nars initial-storage-size initial-free-space)
+ (define effective-storage-limit
+ (cond
+ ((and storage-limit? minimum-free-space?)
+ (min storage-limit
+ (+ initial-storage-size
+ (- initial-free-space minimum-free-space))))
+ (storage-limit? storage-limit)
+ (minimum-free-space?
+ (+ initial-storage-size
+ (- initial-free-space minimum-free-space)))))
+
+ (if (< initial-storage-size effective-storage-limit)
(let ((result
nar-file-counts
(fold-nar-files
@@ -635,9 +666,8 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
(match result
((storage-size . fetched-count)
(let ((file-bytes (assq-ref file 'size)))
- (if (or no-storage-limit?
- (< (+ storage-size file-bytes)
- storage-limit))
+ (if (< (+ storage-size file-bytes)
+ effective-storage-limit)
(let ((success?
(with-exception-handler
(lambda (exn)
@@ -728,13 +758,18 @@ When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
(define (run-mirror-pass)
(log-msg 'DEBUG "running mirror pass")
(let ((initial-storage-size (with-time-logging "getting storage size"
- (get-storage-size storage-root))))
+ (get-storage-size storage-root)))
+ (free-space
+ (free-disk-space storage-root)))
(metric-set storage-size-metric
initial-storage-size)
+ (metric-set storage-free-space-metric
+ free-space)
(let ((fetched-count
- (if no-storage-limit?
- (fast-download-nars)
- (download-nars initial-storage-size))))
+ (if (or storage-limit? minimum-free-space?)
+ (download-nars initial-storage-size
+ free-space)
+ (fast-download-nars))))
(log-msg 'DEBUG "finished mirror pass (fetched " fetched-count " nars)"))))
(let ((channel (make-channel)))
diff --git a/nar-herder/utils.scm b/nar-herder/utils.scm
index 4755d33..5bac2da 100644
--- a/nar-herder/utils.scm
+++ b/nar-herder/utils.scm
@@ -657,20 +657,16 @@ If already in the worker thread, call PROC immediately."
(define (readable? port)
"Test if PORT is writable."
- (match (select (vector port) #() #() 0)
- ((#() #() #()) #f)
- ((#(_) #() #()) #t)))
+ (= 1 (port-poll port "r" 0)))
(define (writable? port)
"Test if PORT is writable."
- (match (select #() (vector port) #() 0)
- ((#() #() #()) #f)
- ((#() #(_) #()) #t)))
+ (= 1 (port-poll port "w" 0)))
(define (make-wait-operation ready? schedule-when-ready port port-ready-fd this-procedure)
(make-base-operation #f
(lambda _
- (and (ready? (port-ready-fd port)) values))
+ (and (ready? port) values))
(lambda (flag sched resume)
(define (commit)
(match (atomic-box-compare-and-swap! flag 'W 'S)
@@ -701,7 +697,7 @@ If already in the worker thread, call PROC immediately."
(define &port-timeout
(make-exception-type '&port-timeout
&external-error
- '(port)))
+ '(thunk port)))
(define make-port-timeout-error
(record-constructor &port-timeout))
@@ -735,7 +731,7 @@ If already in the worker thread, call PROC immediately."
#:key timeout
(read-timeout timeout)
(write-timeout timeout))
- (define (no-fibers-wait port mode timeout)
+ (define (no-fibers-wait thunk port mode timeout)
(define poll-timeout-ms 200)
;; When the GC runs, it restarts the poll syscall, but the timeout
@@ -746,8 +742,7 @@ If already in the worker thread, call PROC immediately."
;; timed out overall.
(let ((timeout-internal
(+ (get-internal-real-time)
- (* internal-time-units-per-second
- (/ timeout 1000)))))
+ (* timeout internal-time-units-per-second))))
(let loop ((poll-value
(port-poll port mode poll-timeout-ms)))
(if (= poll-value 0)
@@ -755,8 +750,8 @@ If already in the worker thread, call PROC immediately."
timeout-internal)
(raise-exception
(if (string=? mode "r")
- (make-port-read-timeout-error port)
- (make-port-write-timeout-error port)))
+ (make-port-read-timeout-error thunk port)
+ (make-port-write-timeout-error thunk port)))
(loop (port-poll port mode poll-timeout-ms)))
poll-value))))
@@ -772,7 +767,7 @@ If already in the worker thread, call PROC immediately."
(lambda ()
(raise-exception
(make-port-read-timeout-error thunk port))))))
- (no-fibers-wait port "r" read-timeout))))
+ (no-fibers-wait thunk port "r" read-timeout))))
(current-write-waiter
(lambda (port)
(if (current-scheduler)
@@ -784,5 +779,5 @@ If already in the worker thread, call PROC immediately."
(lambda ()
(raise-exception
(make-port-write-timeout-error thunk port))))))
- (no-fibers-wait port "w" write-timeout)))))
+ (no-fibers-wait thunk port "w" write-timeout)))))
(thunk)))
diff --git a/scripts/nar-herder.in b/scripts/nar-herder.in
index 515b98a..a611018 100644
--- a/scripts/nar-herder.in
+++ b/scripts/nar-herder.in
@@ -148,9 +148,16 @@
"none"
(string->number arg))
(alist-delete 'storage-limit result))))
+ (option '("storage-minimum-free-space") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'storage-minimum-free-space
+ (if (string=? arg "none")
+ "none"
+ (string->number arg))
+ (alist-delete 'storage-minimum-free-space result))))
- ;; stored-on=https://other-nar-herder-server
- ;; stored-on=https://other-nar-herder-server&stored-on=https://different-server
+ ;; (stored-on https://other-nar-herder-server)
+ ;; and=((stored-on https://other-nar-herder-server) (stored-on https://different-server))
(option '("storage-nar-removal-criteria") #t #f
(lambda (opt name arg result)
(alist-cons 'storage-nar-removal-criteria
@@ -391,37 +398,78 @@
(assq-ref opts 'arguments)))
(len (length narinfos))
(progress
- (progress-reporter/bar len
- (format #f "importing ~a narinfos"
- len)
- (current-error-port))))
+ (if (= 1 len)
+ progress-reporter/silent
+ (progress-reporter/bar len
+ (format #f "importing ~a narinfos"
+ len)
+ (current-error-port)))))
(call-with-progress-reporter progress
(lambda (report)
(database-call-with-transaction
database
(lambda (db)
- (let ((read-narinfos
- (map
- (lambda (narinfo-file)
- (let ((narinfo
- (call-with-input-file narinfo-file
- (lambda (port)
- ;; Set url to a dummy value as this doesn't
- ;; matter
- (read-narinfo port
- "https://narherderdummyvalue")))))
-
- (database-insert-narinfo
- database
- narinfo
- #:tags (or (assq-ref opts 'tags)
- '()))
-
- (report)
-
- narinfo))
- narinfos)))
+ (let* ((canonical-storage
+ (and=> (assq-ref opts 'storage)
+ canonicalize-path))
+ (read-narinfos
+ (map
+ (lambda (narinfo-file)
+ (let ((narinfo
+ (call-with-input-file narinfo-file
+ (lambda (port)
+ ;; Set url to a dummy value as this doesn't
+ ;; matter
+ (read-narinfo port
+ "https://narherderdummyvalue")))))
+
+ (define (check-size! file size)
+ (let ((actual-size (stat:size (stat file))))
+ (unless (= size actual-size)
+ (error
+ (simple-format
+ #f
+ "error importing ~A, ~A should be ~A bytes but is ~A"
+ narinfo-file
+ file
+ size
+ actual-size)))))
+
+ (database-insert-narinfo
+ database
+ narinfo
+ #:tags (or (assq-ref opts 'tags)
+ '()))
+
+ (when canonical-storage
+ (for-each
+ (lambda (uri size)
+ (let* ((nar-path
+ (uri-decode (uri-path uri)))
+ (source
+ (string-append
+ (dirname narinfo-file) "/" nar-path)))
+ (if (string=? canonical-storage
+ (dirname narinfo-file))
+ (check-size! source size)
+ (let ((dest
+ (string-append
+ canonical-storage "/" nar-path)))
+ (check-size! source size)
+ (simple-format (current-error-port)
+ "moving ~A to ~A\n"
+ source dest)
+ (rename-file source dest)
+ ;; Re-check file size
+ (check-size! dest size)))))
+ (narinfo-uris narinfo)
+ (narinfo-file-sizes narinfo)))
+
+ (report)
+
+ narinfo))
+ narinfos)))
(when (assq-ref opts 'ensure-references-exist)
(for-each
@@ -443,7 +491,9 @@
"missing reference to ~A\n"
reference))))
(narinfo-references narinfo))))
- read-narinfos))))))))))
+ read-narinfos)))))))
+ (when (= 1 len)
+ (simple-format (current-error-port) "imported narinfo\n")))))
(("remove" rest ...)
(let* ((opts (parse-options %base-options
%base-option-defaults
@@ -510,8 +560,9 @@
;; that'll stop these files appearing in narinfos
(database-remove-cached-narinfo-file
database
- narinfo-id
- (symbol->string compression)))
+ (assq-ref narinfo-details 'id)
+ (symbol->string
+ (assq-ref cached-narinfo-details 'compression))))
cached-narinfo-files)
(database-remove-narinfo database store-path))
generated by cgit v1.2.3 (git 2.25.4) at 2024-09-21 08:59:53 +0000