;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix 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 General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (guix data-service) #:use-module (json) #:use-module (web client) #:use-module (web response) #:use-module (web uri) #:use-module ((guix diagnostics) #:select (location)) #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) #:use-module (srfi srfi-71) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 match)) (define-json-mapping make-repository repository? json->repository (id repository-id) (label repository-label) (url repository-url) (branches repository-branches "branches" (const 'not-implemented))) ;FIXME: another kind of branch! (define-json-mapping make-branch branch? json->branch (name branch-name) (repository-id branch-repository-id "git_repository_id")) (define-json-mapping make-package-version package-version? json->package-version (string package-version-string "version") (branches package-version-branches "branches" (lambda (vector) (map json->branch (vector->list vector))))) (define-json-mapping make-package package? json->package (name package-name) (versions package-versions "versions" (lambda (vector) (map json->package-version (vector->list vector))))) (define (utc-date date) "Return DATE with its timezone offset zeroed." (make-date (date-nanosecond date) (date-second date) (date-minute date) (date-hour date) (date-day date) (date-month date) (date-year date) 0)) (define (string->date* str) (utc-date (string->date str "~Y-~m-~d ~H:~M:~S"))) ;assume dates are UTC (define-json-mapping make-revision revision? json->revision (commit revision-commit) (date revision-date "datetime" string->date*)) (define-json-mapping make-package-version-range package-version-range? json->package-version-range (version package-version-range-version) (first-revision package-version-range-first-revision "first_revision" json->revision) (last-revision package-version-range-last-revision "last_revision" json->revision)) (define-json-mapping make-build build? json->build (server-id build-server-id "build_server_id") (id build-id "build_server_build_id") (time build-time "timestamp" (lambda (str) (utc-date (string->date str "~Y-~m-~dT~H:~M:~S"))))) (define-json-mapping make-channel-instance channel-instance? json->channel-instance (system channel-instance-system) (derivation channel-instance-derivation) (builds channel-instance-builds "builds" (lambda (vector) (map json->build (vector->list vector))))) (define (json->location alist) (location (assoc-ref alist "file") (assoc-ref alist "line-number") (assoc-ref alist "column-number"))) (define-json-mapping make-lint-warning lint-warning? json->lint-warning (package lint-warning-package "package" (lambda (alist) (assoc-ref alist "name"))) (package-version lint-warning-package-version "package" (lambda (alist) (assoc-ref alist "version"))) (message lint-warning-message) (location lint-warning-location "location" json->location)) ;;; ;;; Calling the Guix Data Service. ;;; ;; Connection to an instance of the Data Service. (define-record-type (data-service socket uri) data-service? (socket data-service-socket) (uri data-service-uri)) (define (open-data-service url) "Open a connection to the Guix Data Service instance at URL." (let ((uri (string->uri url))) (data-service (open-socket-for-uri uri) uri))) (define (make-data-service-uri service path) (build-uri (uri-scheme (data-service-uri service)) #:host (uri-host (data-service-uri service)) #:port (uri-port (data-service-uri service)) #:path path)) (define (discard port n) "Read N bytes from PORT and discard them." (define bv (make-bytevector 4096)) (let loop ((n n)) (unless (zero? n) (match (get-bytevector-n! port bv 0 (min n (bytevector-length bv))) ((? eof-object?) #t) (read (loop (- n read))))))) (define (call service path) (let* ((uri (make-data-service-uri service path)) (response port (http-get uri #:port (data-service-socket service) #:keep-alive? #t #:headers '((Accept . "application/json")) #:streaming? #t))) (unless (= 200 (response-code response)) (when (response-content-length response) (discard port (response-content-length response))) (throw 'data-service-client-error uri response)) port)) (define (lookup-package service name) "Lookup package NAME and return a package record." (json->package (call service (string-append "/package/" name)))) (define (lookup-repository service id) "Lookup the repository with the given ID, an integer, and return it." (json->repository (call service (string-append "/repository/" (number->string id))))) (define (package-version-history service branch package) "Return a list of package version ranges for PACKAGE, a string, on BRANCH, a record." ;; http://data.guix.gnu.org/repository/1/branch/master/package/emacs.json (map json->package-version-range (let ((result (json->scm (call service (string-append "/repository/" (number->string (branch-repository-id branch)) "/branch/" (branch-name branch) "/package/" package))))) (vector->list (assoc-ref result "versions"))))) (define (revision-channel-instances service commit) "Return the channel instances for COMMIT." (let ((result (json->scm (call service (string-append "/revision/" commit "/channel-instances"))))) (map json->channel-instance (vector->list (assoc-ref result "channel_instances"))))) (define* (revision-lint-warnings service commit #:optional linter) "Return lint warnings for COMMIT. If LINTER is given, only show warnings for the given linter--e.g., 'description'." (let ((result (json->scm (call service (string-append "/revision/" commit "/lint-warnings" (if linter (string-append "?linter=" linter) "")))))) (map json->lint-warning (vector->list (assoc-ref result "lint_warnings")))))