diff options
| -rw-r--r-- | guix-build-coordinator/datastore.scm | 1 | ||||
| -rw-r--r-- | guix-build-coordinator/datastore/sqlite.scm | 136 |
2 files changed, 137 insertions, 0 deletions
diff --git a/guix-build-coordinator/datastore.scm b/guix-build-coordinator/datastore.scm index 68cbebb..f33f5ce 100644 --- a/guix-build-coordinator/datastore.scm +++ b/guix-build-coordinator/datastore.scm @@ -38,6 +38,7 @@ (re-export datastore-count-builds) (re-export datastore-for-each-build) (re-export datastore-find-build) +(re-export datastore-list-builds) (re-export datastore-insert-build-tags) (re-export datastore-fetch-build-tags) (re-export datastore-find-build-result) diff --git a/guix-build-coordinator/datastore/sqlite.scm b/guix-build-coordinator/datastore/sqlite.scm index e5705f8..7c9b4d0 100644 --- a/guix-build-coordinator/datastore/sqlite.scm +++ b/guix-build-coordinator/datastore/sqlite.scm @@ -28,6 +28,7 @@ datastore-count-builds datastore-for-each-build datastore-find-build + datastore-list-builds datastore-insert-build-tags datastore-fetch-build-tags datastore-find-build-result @@ -1177,6 +1178,141 @@ WHERE uuid = :uuid" result))))) +(define-method (datastore-list-builds + (datastore <sqlite-datastore>) + . + rest) + (define* (list-builds #:key + (tags '()) + (not-tags '()) + (processed 'unset) + (canceled 'unset) + (limit 1000)) + (call-with-worker-thread + (slot-ref datastore 'worker-reader-thread-channel) + (lambda (db) + (define tag->expression + (let ((statement + (sqlite-prepare + db + " +SELECT id FROM tags WHERE key = :key AND value = :value" + #:cache? #t))) + (lambda (tag not?) + (match tag + ((key . value) + (sqlite-bind-arguments statement + #:key key + #:value value) + + (let ((result (match (sqlite-step statement) + (#(id) + (simple-format + #f "tag_string ~A '%,~A,%'" + (if not? + "NOT LIKE" + "LIKE") + id)) + (#f #f)))) + (sqlite-reset statement) + + result)))))) + + (let ((tag-expressions + (map (lambda (tag) + (tag->expression tag #f)) + tags)) + (not-tag-expressions + (map (lambda (tag) + (tag->expression tag #t)) + not-tags))) + + ;; If one of the requested tags doesn't exist, nothing can be tagged to + ;; it, so just return nothing + (if (memq #f tag-expressions) + '() + (let* ((where-needed? + (or (not (null? tag-expressions)) + (not (null? not-tag-expressions)) + (not (eq? processed 'unset)) + (not (eq? canceled 'unset)))) + (statement + (sqlite-prepare + db + (string-append + " +SELECT uuid, derivation_name, priority, processed, canceled, created_at, end_time +FROM builds +INNER JOIN ( + SELECT build_id, (',' || group_concat(tag_id) || ',') AS tag_string + FROM build_tags + GROUP BY build_id +) AS all_build_tags + ON builds.uuid = all_build_tags.build_id +" + (if where-needed? + (string-append + "WHERE\n" + (string-join + (append + (let ((all-tag-expressions + (append tag-expressions + not-tag-expressions))) + (if (null? all-tag-expressions) + '() + all-tag-expressions)) + (cond + ((eq? processed #t) '("processed = 1")) + ((eq? processed #f) '("processed = 0")) + (else '())) + (cond + ((eq? canceled #t) '("canceled = 1")) + ((eq? canceled #f) '("canceled = 0")) + (else '()))) + " AND ") + "\n") + "") + (if limit + (string-append "LIMIT " (number->string limit) "\n") + "")) + #:cache? #f))) + + (let ((result + (sqlite-map + (match-lambda + (#(uuid derivation_name priority processed canceled + created_at end_time) + `((uuid . ,uuid) + (derivation-name . ,derivation_name) + (priority . ,priority) + (processed . ,(cond + ((= 0 processed) #f) + ((= 1 processed) #t) + (else + (error + "unknown processed value")))) + (canceled . ,(cond + ((= 0 canceled) #f) + ((= 1 canceled) #t) + (else + (error "unknown canceled value")))) + (created-at . ,(if (string? created_at) + (match (strptime "%F %T" + created_at) + ((parts . _) parts)) + #f)) + (end-time . ,(if (string? end_time) + (match (strptime "%F %T" + end_time) + ((parts . _) parts)) + #f))))) + statement))) + (sqlite-finalize statement) + + result))))))) + + (apply list-builds rest)) + (define-method (datastore-fetch-build-tags (datastore <sqlite-datastore>) build-id) |