diff options
| -rw-r--r-- | guix-data-service/model/package-metadata.scm | 137 | ||||
| -rw-r--r-- | tests/model-package-metadata.scm | 6 | ||||
| -rw-r--r-- | tests/model-package.scm | 6 |
3 files changed, 83 insertions, 66 deletions
diff --git a/guix-data-service/model/package-metadata.scm b/guix-data-service/model/package-metadata.scm index e450620..f1ffdbf 100644 --- a/guix-data-service/model/package-metadata.scm +++ b/guix-data-service/model/package-metadata.scm @@ -18,6 +18,7 @@ (define-module (guix-data-service model package-metadata) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-43) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (squee) @@ -275,8 +276,13 @@ WHERE packages.id IN ( (define (inferior-packages->package-metadata-ids conn package-metadata license-set-ids) - (define package-metadata-list - (vector->list package-metadata)) + (define (vector-zip . vecs) + (let ((result (make-vector (vector-length (first vecs))))) + (apply vector-map! + (lambda (i . vals) + (cdr vals)) + (cons result vecs)) + result)) (insert-missing-data-and-return-all-ids conn @@ -287,68 +293,71 @@ WHERE packages.id IN ( package_description_set_id package_synopsis_set_id) - (list->vector - (zip - (map (match-lambda - ((home-page rest ...) - (if (string? home-page) - home-page - NULL))) - package-metadata-list) - (with-time-logging "preparing location ids" - (map (match-lambda - ((_ location rest ...) - (if location - (location->location-id - conn - location) - NULL))) - package-metadata-list)) - (vector->list license-set-ids) - (with-time-logging "preparing package description set ids" - (map (lambda (package-description-ids) - (insert-and-return-id - conn - "package_description_sets" - '(description_ids) - (list (sort package-description-ids <)))) - (with-time-logging "preparing package description ids" - (map (match-lambda - ((_ _ package-description-data _) - (insert-missing-data-and-return-all-ids - conn - "package_descriptions" - '(locale description) - (list->vector - (map (match-lambda - ((locale . description) - (list locale - ;; \u0000 has appeared in package - ;; descriptions (#71968), so strip it - ;; out here to avoid PostgreSQL throwing - ;; an error - (string-delete-null description)))) - package-description-data))))) - package-metadata-list)))) - (with-time-logging "preparing package synopsis set ids" - (map (lambda (package-synopsis-ids) - (insert-and-return-id - conn - "package_synopsis_sets" - '(synopsis_ids) - (list (sort package-synopsis-ids <)))) - (map (match-lambda - ((_ _ _ package-synopsis-data) - (insert-missing-data-and-return-all-ids - conn - "package_synopsis" - '(locale synopsis) - (list->vector - (map (match-lambda - ((locale . synopsis) - (list locale synopsis))) - package-synopsis-data))))) - package-metadata-list))))))) + (vector-zip + (vector-map (match-lambda* + ((_ (home-page rest ...)) + (if (string? home-page) + home-page + NULL))) + package-metadata) + (with-time-logging "preparing location ids" + (vector-map (match-lambda* + ((_ (_ location rest ...)) + (if location + (location->location-id + conn + location) + NULL))) + package-metadata)) + license-set-ids + (with-time-logging "preparing package description set ids" + (vector-map (match-lambda* + ((_ (_ _ package-description-data _)) + (let ((package-description-ids + (insert-missing-data-and-return-all-ids + conn + "package_descriptions" + '(locale description) + (let ((vec (list->vector package-description-data))) + (vector-map! + (match-lambda* + ((_ (locale . description)) + (list locale + ;; \u0000 has appeared in package + ;; descriptions (#71968), so strip it + ;; out here to avoid PostgreSQL throwing + ;; an error + (string-delete-null description)))) + vec) + vec)))) + (insert-and-return-id + conn + "package_description_sets" + '(description_ids) + (list (sort! package-description-ids <)))))) + package-metadata)) + (with-time-logging "preparing package synopsis set ids" + (vector-map (match-lambda* + ((_ (_ _ _ package-synopsis-data)) + (let ((package-synopsis-ids + (insert-missing-data-and-return-all-ids + conn + "package_synopsis" + '(locale synopsis) + (let ((vec + (list->vector package-synopsis-data))) + (vector-map! + (match-lambda* + ((_ (locale . synopsis)) + (list locale synopsis))) + vec) + vec)))) + (insert-and-return-id + conn + "package_synopsis_sets" + '(synopsis_ids) + (list (sort! package-synopsis-ids <)))))) + package-metadata))))) (define (package-description-and-synopsis-locale-options-guix-revision conn revision-id) diff --git a/tests/model-package-metadata.scm b/tests/model-package-metadata.scm index c262f57..5e9c897 100644 --- a/tests/model-package-metadata.scm +++ b/tests/model-package-metadata.scm @@ -49,6 +49,9 @@ conn '#((("License 1" "https://gnu.org/licenses/test-1.html" + "https://example.com/why-license-1")) + (("License 1" + "https://gnu.org/licenses/test-1.html" "https://example.com/why-license-1")))))) (inferior-packages->license-set-ids conn license-id-lists))) @@ -74,7 +77,8 @@ conn mock-package-metadata (test-license-set-ids conn)) - (#(x) (number? x)))) + (#(x y) (and (number? x) + (number? y))))) #:always-rollback? #t)) (with-postgresql-transaction diff --git a/tests/model-package.scm b/tests/model-package.scm index 70882bd..f58b887 100644 --- a/tests/model-package.scm +++ b/tests/model-package.scm @@ -38,6 +38,9 @@ conn '#((("License 1" "https://gnu.org/licenses/test-1.html" + "https://example.com/why-license-1")) + (("License 1" + "https://gnu.org/licenses/test-1.html" "https://example.com/why-license-1")))))) (inferior-packages->license-set-ids conn license-id-lists))) @@ -87,7 +90,8 @@ (map mock-inferior-package-version mock-inferior-packages) (vector->list package-metadata-ids) package-replacement-package-ids))) - (#(x) (number? x)))))) + (#(x y) (and (number? x) + (number? y))))))) #:always-rollback? #t) (with-postgresql-transaction |