Guix Data Service client module

[Ludovic Courtès]

Hello Guix!

Here’s a client module for the Guix Data Service, allowing you to access
a subset of the Guix Data Service interfaces from the comfort of your
REPL.

I had it sitting in my source tree for a while and Chris sent me an
impressive shell one-liner that made me want to try from Scheme:

  wget 
"https://data.guix-patches.cbaines.net/revision/47f85c53d954f857b45cebefee27ec512d917484/lint-warnings.json?locale=en_US.UTF-8&linter=input-labels&field=linter&field=message&field=location";
 -O - | jq -r '.lint_warnings | .[] | .package.name' | sort | uniq | wc -l

Turns out we can do the same in two long lines of Scheme!

--8<---------------cut here---------------start------------->8---
scheme@(guix data-service)> (define s (open-data-service 
"https://data.guix-patches.cbaines.net";))
scheme@(guix data-service)> (length (delete-duplicates (map 
lint-warning-package (revision-lint-warnings s 
"47f85c53d954f857b45cebefee27ec512d917484" "input-labels"))))
$6 = 3560
--8<---------------cut here---------------end--------------->8---

(That counts the number of packages at that revision that have one or
more warnings from the new ‘input-labels’ lint checker.)

We can do other things, such as browsing package versions:

--8<---------------cut here---------------start------------->8---
scheme@(guix data-service)> (define s (open-data-service 
"https://data.guix.gnu.org";))
scheme@(guix data-service)> (package-version-branches (car (package-versions 
(lookup-package s "emacs"))))
$9 = (#<<branch> name: "master" repository-id: 1>)
scheme@(guix data-service)> (package-version-history s (car $9) "emacs")
$10 = (#<<package-version-range> version: "27.2" first-revision: #<<revision> 
commit: "cc33f50d0e2a7835e99913226cb4c4b0e9e961ae" date: #<date nanosecond: 0 
second: 54 minute: 30 hour: 20 day: 25 month: 3 year: 2021 zone-offset: 0>> 
last-revision: #<<revision> commit: "364b56124b88398c199aacbfd4fdfc9a1583e634" 
date: #<date nanosecond: 0 second: 31 minute: 16 hour: 13 day: 27 month: 6 
year: 2021 zone-offset: 0>>> #<<package-version-range> version: "27.1" 
first-revision: #<<revision> commit: "36a09d185343375a5cba370431870f9c4435d623" 
date: #<date nanosecond: 0 second: 52 minute: 16 hour: 4 day: 28 month: 8 year: 
2020 zone-offset: 0>> last-revision: #<<revision> commit: 
"ac29d37e2ffd7a85adfcac9be4d5bce018289bec" date: #<date nanosecond: 0 second: 2 
minute: 36 hour: 17 day: 25 month: 3 year: 2021 zone-offset: 0>>> 
#<<package-version-range> version: "26.3" first-revision: #<<revision> commit: 
"43412ab967ee00789fe933f916d804aed9961c57" date: #<date nanosecond: 0 second: 
29 minute: 36 hour: 3 day: 30 month: 8 year: 2019 zone-offset: 0>> 
last-revision: #<<revision> commit: "bf19d5e4b26a2e38fe93a45f9341e14476ea5f82" 
date: #<date nanosecond: 0 second: 19 minute: 50 hour: 21 day: 27 month: 8 
year: 2020 zone-offset: 0>>> #<<package-version-range> version: "26.2" 
first-revision: #<<revision> commit: "5069baedb8a902c3b1ea9656c11471658a1de56b" 
date: #<date nanosecond: 0 second: 8 minute: 46 hour: 22 day: 12 month: 4 year: 
2019 zone-offset: 0>> last-revision: #<<revision> commit: 
"02c61278f1327d403f072f42e6b92a1dc62fc93a" date: #<date nanosecond: 0 second: 
35 minute: 44 hour: 0 day: 30 month: 8 year: 2019 zone-offset: 0>>> 
#<<package-version-range> version: "26.1" first-revision: #<<revision> commit: 
"897f303d2fa61497a931cf5fcb43349eb5f44c14" date: #<date nanosecond: 0 second: 
47 minute: 31 hour: 7 day: 1 month: 1 year: 2019 zone-offset: 0>> 
last-revision: #<<revision> commit: "ee6c4b62b88640f3828cf73a30377124e16cb95f" 
date: #<date nanosecond: 0 second: 51 minute: 8 hour: 20 day: 12 month: 4 year: 
2019 zone-offset: 0>>>)
--8<---------------cut here---------------end--------------->8---

Now all we need to do is plug it into the right tools and enjoy!

Ludo’.

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.

(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 <repository> 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 <branch> make-branch branch?
  json->branch
  (name           branch-name)
  (repository-id  branch-repository-id "git_repository_id"))

(define-json-mapping <package-version> 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 <package> 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 <revision> make-revision revision?
  json->revision
  (commit   revision-commit)
  (date     revision-date "datetime" string->date*))

(define-json-mapping <package-version-range>
  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 <build>
  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 <channel-instance>
  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 <lint-warning> 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>
  (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
<branch> 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")))))