diff options
| -rw-r--r-- | guix-data-service/branch-updated-emails.scm | 4 | ||||
| -rw-r--r-- | guix-data-service/data-deletion.scm | 9 | ||||
| -rw-r--r-- | guix-data-service/jobs/load-new-guix-revision.scm | 2 | ||||
| -rw-r--r-- | guix-data-service/model/git-repository.scm | 28 | ||||
| -rw-r--r-- | guix-data-service/poll-git-repository.scm | 16 | ||||
| -rw-r--r-- | guix-data-service/utils.scm | 16 |
6 files changed, 57 insertions, 18 deletions
diff --git a/guix-data-service/branch-updated-emails.scm b/guix-data-service/branch-updated-emails.scm index 8b5290b..aeb1570 100644 --- a/guix-data-service/branch-updated-emails.scm +++ b/guix-data-service/branch-updated-emails.scm @@ -59,9 +59,9 @@ conn git-repository-id))) (let ((excluded-branch? - (member branch-name excluded-branches string=?)) + (branch-in-list? excluded-branches branch-name)) (included-branch? - (member branch-name included-branches string=?))) + (branch-in-list? included-branches branch-name))) (when (and (not excluded-branch?) (or (null? included-branches) included-branch?)) diff --git a/guix-data-service/data-deletion.scm b/guix-data-service/data-deletion.scm index c9dc631..e75fe42 100644 --- a/guix-data-service/data-deletion.scm +++ b/guix-data-service/data-deletion.scm @@ -255,10 +255,11 @@ WHERE git_repository_id = $1 (list (number->string git-repository-id) branch-name)))) - (delete-revisions-from-branch conn - git-repository-id - branch-name - commits) + (unless (null? commits) + (delete-revisions-from-branch conn + git-repository-id + branch-name + commits)) (exec-query conn diff --git a/guix-data-service/jobs/load-new-guix-revision.scm b/guix-data-service/jobs/load-new-guix-revision.scm index 5c2744c..d821157 100644 --- a/guix-data-service/jobs/load-new-guix-revision.scm +++ b/guix-data-service/jobs/load-new-guix-revision.scm @@ -1485,7 +1485,7 @@ (match-lambda ((system . target) (let loop ((wal-bytes (stat:size (stat "/var/guix/db/db.sqlite-wal")))) - (when (> wal-bytes 200000000) + (when (> wal-bytes (* 2048 (expt 2 20))) (simple-format #t "debug: guix-daemon WAL is large (~A), waiting\n" wal-bytes) diff --git a/guix-data-service/model/git-repository.scm b/guix-data-service/model/git-repository.scm index feae290..5c605f8 100644 --- a/guix-data-service/model/git-repository.scm +++ b/guix-data-service/model/git-repository.scm @@ -16,6 +16,7 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (guix-data-service model git-repository) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (json) #:use-module (squee) @@ -25,6 +26,7 @@ git-repository-query-substitutes? git-repository-id->url select-includes-and-excluded-branches-for-git-repository + branch-in-list? count-git-repositories-with-x-git-repo-header-values git-repository-x-git-repo-header->git-repository-id git-repository-url->git-repository-id @@ -84,6 +86,17 @@ WHERE id = $1" (((url)) url))) (define (select-includes-and-excluded-branches-for-git-repository conn id) + (define (make-regexes lst) + (map + (lambda (item) + (if (string-prefix? "/" item) + (make-regexp + (string-drop + (string-drop-right item 1) + 1)) + item)) + lst)) + (match (exec-query conn " @@ -95,11 +108,22 @@ FROM git_repositories WHERE id = $1" (if (or (eq? #f included_branches) (string-null? included_branches)) '() - (parse-postgresql-array-string included_branches)) + (make-regexes + (parse-postgresql-array-string included_branches))) (if (or (eq? excluded_branches #f) (string-null? excluded_branches)) '() - (parse-postgresql-array-string excluded_branches)))))) + (make-regexes + (parse-postgresql-array-string excluded_branches))))))) + +(define (branch-in-list? lst branch) + (any + (lambda (item) + (->bool + (if (string? item) + (string=? item branch) + (regexp-exec item branch)))) + lst)) (define (count-git-repositories-with-x-git-repo-header-values conn) (match (exec-query diff --git a/guix-data-service/poll-git-repository.scm b/guix-data-service/poll-git-repository.scm index 124c559..8dfd13d 100644 --- a/guix-data-service/poll-git-repository.scm +++ b/guix-data-service/poll-git-repository.scm @@ -99,6 +99,9 @@ conn 'latest-channel-instances (lambda () + (simple-format (current-error-port) + "polling git repository ~A\n" + git-repository-id) ;; This was using update-cached-checkout, but it wants to checkout ;; refs/remotes/origin/HEAD by default, and that can fail for some reason ;; on some repositories: @@ -158,6 +161,15 @@ oid->string))))) (branch-list repository BRANCH-REMOTE))))) + (simple-format (current-error-port) + "git repository ~A: excluded branches: ~A\n" + git-repository-id + excluded-branches) + (simple-format (current-error-port) + "git repository ~A: included branches: ~A\n" + git-repository-id + included-branches) + (with-postgresql-transaction conn (lambda (conn) @@ -170,9 +182,9 @@ (filter (lambda (branch-name) (let ((excluded-branch? - (member branch-name excluded-branches string=?)) + (branch-in-list? excluded-branches branch-name)) (included-branch? - (member branch-name included-branches string=?))) + (branch-in-list? included-branches branch-name))) (and (not excluded-branch?) (or (null? included-branches) included-branch?)))) diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm index d01fb5c..a9e8f39 100644 --- a/guix-data-service/utils.scm +++ b/guix-data-service/utils.scm @@ -244,13 +244,15 @@ (waiters . ,(length waiters)) (checkout-failure-count . ,checkout-failure-count)))) - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply stats) - (const #t)) - (wrap-operation (sleep-operation 0.2) - (const #f))))) + (spawn-fiber + (lambda () + (perform-operation + (choice-operation + (wrap-operation + (put-operation reply stats) + (const #t)) + (wrap-operation (sleep-operation 1) + (const #f))))))) (loop resources available |