guix/swh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix swh)
  21   #:use-module (guix base16)
  22   #:use-module (guix build utils)
  23   #:use-module ((guix build syscalls) #:select (mkdtemp!))
  24   #:use-module (web uri)
  25   #:use-module (web client)
  26   #:use-module (web response)
  27   #:use-module (json)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-9)
  30   #:use-module (srfi srfi-11)
  31   #:use-module (srfi srfi-19)
  32   #:use-module (ice-9 match)
  33   #:use-module (ice-9 regex)
  34   #:use-module (ice-9 popen)
  35   #:use-module ((ice-9 ftw) #:select (scandir))
  36   #:export (%swh-base-url
  37             %verify-swh-certificate?
  38             %allow-request?
  39
  40             request-rate-limit-reached?
  41
  42             origin?
  43             origin-type
  44             origin-url
  45             origin-visits
  46             lookup-origin
  47
  48             visit?
  49             visit-date
  50             visit-origin
  51             visit-url
  52             visit-snapshot-url
  53             visit-status
  54             visit-number
  55             visit-snapshot
  56
  57             branch?
  58             branch-name
  59             branch-target
  60
  61             release?
  62             release-id
  63             release-name
  64             release-message
  65             release-target
  66
  67             revision?
  68             revision-id
  69             revision-date
  70             revision-directory
  71             lookup-revision
  72             lookup-origin-revision
  73
  74             content?
  75             content-checksums
  76             content-data-url
  77             content-length
  78             lookup-content
  79
  80             directory-entry?
  81             directory-entry-name
  82             directory-entry-type
  83             directory-entry-checksums
  84             directory-entry-length
  85             directory-entry-permissions
  86             lookup-directory
  87             directory-entry-target
  88
  89             save-reply?
  90             save-reply-origin-url
  91             save-reply-origin-type
  92             save-reply-request-date
  93             save-reply-request-status
  94             save-reply-task-status
  95             save-origin
  96             save-origin-status
  97
  98             vault-reply?
  99             vault-reply-id
 100             vault-reply-fetch-url
 101             vault-reply-object-id
 102             vault-reply-object-type
 103             vault-reply-progress-message
 104             vault-reply-status
 105             query-vault
 106             request-cooking
 107             vault-fetch
 108
 109             commit-id?
 110
 111             swh-download))
 112
 113 ;;; Commentary:
 114 ;;;
 115 ;;; This module provides bindings to the HTTP interface of Software Heritage.
 116 ;;; It allows you to browse the archive, look up revisions (such as SHA1
 117 ;;; commit IDs), "origins" (code hosting URLs), content (files), etc.  See
 118 ;;; <https://archive.softwareheritage.org/api/> for more information.
 119 ;;;
 120 ;;; The high-level 'swh-download' procedure allows you to download a Git
 121 ;;; revision from Software Heritage, provided it is available.
 122 ;;;
 123 ;;; Code:
 124
 125 (define %swh-base-url
 126   ;; Presumably we won't need to change it.
 127   (make-parameter "https://archive.softwareheritage.org"))
 128
 129 (define %verify-swh-certificate?
 130   ;; Whether to verify the X.509 HTTPS certificate for %SWH-BASE-URL.
 131   (make-parameter #t))
 132
 133 (define (swh-url path . rest)
 134   ;; URLs returned by the API may be relative or absolute. This has changed
 135   ;; without notice before. Handle both cases by detecting whether the path
 136   ;; starts with a domain.
 137   (define root
 138     (if (string-prefix? "/" path)
 139       (string-append (%swh-base-url) path)
 140       path))
 141
 142   (define url
 143     (string-append root (string-join rest "/" 'prefix)))
 144
 145   ;; Ensure there's a trailing slash or we get a redirect.
 146   (if (string-suffix? "/" url)
 147       url
 148       (string-append url "/")))
 149
 150 ;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would
 151 ;; be ignored (<https://bugs.gnu.org/40486>).
 152 (define* (http-get* uri #:rest rest)
 153   (apply http-request uri #:method 'GET rest))
 154 (define* (http-post* uri #:rest rest)
 155   (apply http-request uri #:method 'POST rest))
 156
 157 (define %date-regexp
 158   ;; Match strings like "2014-11-17T22:09:38+01:00" or
 159   ;; "2018-09-30T23:20:07.815449+00:00"".
 160   (make-regexp "^([0-9]{4})-([0-9]{2})-([0-9]{2})T([0-9]{2}):([0-9]{2}):([0-9]{2})((\\.[0-9]+)?)([+-][0-9]{2}):([0-9]{2})$"))
 161
 162 (define (string->date* str)
 163   "Return a SRFI-19 date parsed from STR, a date string as returned by
 164 Software Heritage."
 165   ;; We can't use 'string->date' because of the timezone format: SWH returns
 166   ;; "+01:00" when the '~z' template expects "+0100".  So we roll our own!
 167   (or (and=> (regexp-exec %date-regexp str)
 168              (lambda (match)
 169                (define (ref n)
 170                  (string->number (match:substring match n)))
 171
 172                (make-date (let ((ns (match:substring match 8)))
 173                             (if ns
 174                                 (string->number (string-drop ns 1))
 175                                 0))
 176                           (ref 6) (ref 5) (ref 4)
 177                           (ref 3) (ref 2) (ref 1)
 178                           (+ (* 3600 (ref 9))     ;time zone
 179                              (if (< (ref 9) 0)
 180                                  (- (ref 10))
 181                                  (ref 10))))))
 182       str))                                       ;oops!
 183
 184 (define string*
 185   ;; Converts "string or #nil" coming from JSON to "string or #f".
 186   (match-lambda
 187     ((? string? str) str)
 188     ((? null?) #f)                                ;Guile-JSON 3.x
 189     ('null #f)))                                  ;Guile-JSON 4.x
 190
 191 (define %allow-request?
 192   ;; Takes a URL and method (e.g., the 'http-get' procedure) and returns true
 193   ;; to keep going.  This can be used to disallow requests when
 194   ;; 'request-rate-limit-reached?' returns true, for instance.
 195   (make-parameter (const #t)))
 196
 197 ;; The time when the rate limit for "/origin/save" POST requests and that of
 198 ;; other requests will be reset.
 199 ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
 200 (define %save-rate-limit-reset-time 0)
 201 (define %general-rate-limit-reset-time 0)
 202
 203 (define (request-rate-limit-reached? url method)
 204   "Return true if the rate limit has been reached for URI."
 205   (define uri
 206     (string->uri url))
 207
 208   (define reset-time
 209     (if (and (eq? method http-post*)
 210              (string-prefix? "/api/1/origin/save/" (uri-path uri)))
 211         %save-rate-limit-reset-time
 212         %general-rate-limit-reset-time))
 213
 214   (< (car (gettimeofday)) reset-time))
 215
 216 (define (update-rate-limit-reset-time! url method response)
 217   "Update the rate limit reset time for URL and METHOD based on the headers in
 218 RESPONSE."
 219   (let ((uri (string->uri url)))
 220     (match (assq-ref (response-headers response) 'x-ratelimit-reset)
 221       ((= string->number (? number? reset))
 222        (if (and (eq? method http-post*)
 223                 (string-prefix? "/api/1/origin/save/" (uri-path uri)))
 224            (set! %save-rate-limit-reset-time reset)
 225            (set! %general-rate-limit-reset-time reset)))
 226       (_
 227        #f))))
 228
 229 (define* (call url decode #:optional (method http-get*)
 230                #:key (false-if-404? #t))
 231   "Invoke the endpoint at URL using METHOD.  Decode the resulting JSON body
 232 using DECODE, a one-argument procedure that takes an input port.  When
 233 FALSE-IF-404? is true, return #f upon 404 responses."
 234   (and ((%allow-request?) url method)
 235        (let*-values (((response port)
 236                       (method url #:streaming? #t
 237                               #:verify-certificate?
 238                               (%verify-swh-certificate?))))
 239          ;; See <https://archive.softwareheritage.org/api/#rate-limiting>.
 240          (match (assq-ref (response-headers response) 'x-ratelimit-remaining)
 241            (#f #t)
 242            ((? (compose zero? string->number))
 243             (update-rate-limit-reset-time! url method response)
 244             (throw 'swh-error url method response))
 245            (_ #t))
 246
 247          (cond ((= 200 (response-code response))
 248                 (let ((result (decode port)))
 249                   (close-port port)
 250                   result))
 251                ((and false-if-404?
 252                      (= 404 (response-code response)))
 253                 (close-port port)
 254                 #f)
 255                (else
 256                 (close-port port)
 257                 (throw 'swh-error url method response))))))
 258
 259 (define-syntax define-query
 260   (syntax-rules (path)
 261     "Define a procedure that performs a Software Heritage query."
 262     ((_ (name args ...) docstring (path components ...)
 263         json->value)
 264      (define (name args ...)
 265        docstring
 266        (call (swh-url components ...) json->value)))))
 267
 268 ;; <https://archive.softwareheritage.org/api/1/origin/https://github.com/guix-mirror/guix/get>
 269 (define-json-mapping <origin> make-origin origin?
 270   json->origin
 271   (visits-url origin-visits-url "origin_visits_url")
 272   (type origin-type)
 273   (url origin-url))
 274
 275 ;; <https://archive.softwareheritage.org/api/1/origin/52181937/visits/>
 276 (define-json-mapping <visit> make-visit visit?
 277   json->visit
 278   (date visit-date "date" string->date*)
 279   (origin visit-origin)
 280   (url visit-url "origin_visit_url")
 281   (snapshot-url visit-snapshot-url "snapshot_url" string*) ;string | #f
 282   (status visit-status "status" string->symbol)   ;'full | 'partial | 'ongoing
 283   (number visit-number "visit"))
 284
 285 ;; <https://archive.softwareheritage.org/api/1/snapshot/4334c3ed4bb208604ed780d8687fe523837f1bd1/>
 286 (define-json-mapping <snapshot> make-snapshot snapshot?
 287   json->snapshot
 288   (branches snapshot-branches "branches" json->branches))
 289
 290 ;; This is used for the "branches" field of snapshots.
 291 (define-record-type <branch>
 292   (make-branch name target-type target-url)
 293   branch?
 294   (name         branch-name)
 295   (target-type  branch-target-type)               ;release | revision
 296   (target-url   branch-target-url))
 297
 298 (define (json->branches branches)
 299   (map (match-lambda
 300          ((key . value)
 301           (make-branch key
 302                        (string->symbol
 303                         (assoc-ref value "target_type"))
 304                        (assoc-ref value "target_url"))))
 305        branches))
 306
 307 ;; <https://archive.softwareheritage.org/api/1/release/1f44934fb6e2cefccbecd4fa347025349fa9ff76/>
 308 (define-json-mapping <release> make-release release?
 309   json->release
 310   (id          release-id)
 311   (name        release-name)
 312   (message     release-message)
 313   (target-type release-target-type "target_type" string->symbol)
 314   (target-url  release-target-url "target_url"))
 315
 316 ;; <https://archive.softwareheritage.org/api/1/revision/359fdda40f754bbf1b5dc261e7427b75463b59be/>
 317 (define-json-mapping <revision> make-revision revision?
 318   json->revision
 319   (id            revision-id)
 320   (date          revision-date "date" string->date*)
 321   (directory     revision-directory)
 322   (directory-url revision-directory-url "directory_url"))
 323
 324 ;; <https://archive.softwareheritage.org/api/1/content/>
 325 (define-json-mapping <content> make-content content?
 326   json->content
 327   (checksums     content-checksums "checksums" json->checksums)
 328   (data-url      content-data-url "data_url")
 329   (file-type-url content-file-type-url "filetype_url")
 330   (language-url  content-language-url "language_url")
 331   (length        content-length)
 332   (license-url   content-license-url "license_url"))
 333
 334 (define (json->checksums checksums)
 335   (map (match-lambda
 336          ((key . value)
 337           (cons key (base16-string->bytevector value))))
 338        checksums))
 339
 340 ;; <https://archive.softwareheritage.org/api/1/directory/27c69c5d298a43096a53affbf881e7b13f17bdcd/>
 341 (define-json-mapping <directory-entry> make-directory-entry directory-entry?
 342   json->directory-entry
 343   (name          directory-entry-name)
 344   (type          directory-entry-type "type"
 345                  (match-lambda
 346                    ("dir" 'directory)
 347                    (str   (string->symbol str))))
 348   (checksums     directory-entry-checksums "checksums"
 349                  (match-lambda
 350                    (#f  #f)
 351                    ((? unspecified?) #f)
 352                    (lst (json->checksums lst))))
 353   (id            directory-entry-id "dir_id")
 354   (length        directory-entry-length)
 355   (permissions   directory-entry-permissions "perms")
 356   (target-url    directory-entry-target-url "target_url"))
 357
 358 ;; <https://archive.softwareheritage.org/api/1/origin/save/>
 359 (define-json-mapping <save-reply> make-save-reply save-reply?
 360   json->save-reply
 361   (origin-url     save-reply-origin-url "origin_url")
 362   (origin-type    save-reply-origin-type "origin_type")
 363   (request-date   save-reply-request-date "save_request_date"
 364                   string->date*)
 365   (request-status save-reply-request-status "save_request_status"
 366                   string->symbol)
 367   (task-status    save-reply-task-status "save_task_status"
 368                   (match-lambda
 369                     ("not created" 'not-created)
 370                     ((? string? str) (string->symbol str)))))
 371
 372 ;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref>
 373 (define-json-mapping <vault-reply> make-vault-reply vault-reply?
 374   json->vault-reply
 375   (id             vault-reply-id)
 376   (fetch-url      vault-reply-fetch-url "fetch_url")
 377   (object-id      vault-reply-object-id "obj_id")
 378   (object-type    vault-reply-object-type "obj_type" string->symbol)
 379   (progress-message vault-reply-progress-message "progress_message")
 380   (status         vault-reply-status "status" string->symbol))
 381
 382 \f
 383 ;;;
 384 ;;; RPCs.
 385 ;;;
 386
 387 (define-query (lookup-origin url)
 388   "Return an origin for URL."
 389   (path "/api/1/origin" url "get")
 390   json->origin)
 391
 392 (define-query (lookup-content hash type)
 393   "Return a content for HASH, of the given TYPE--e.g., \"sha256\"."
 394   (path "/api/1/content"
 395         (string-append type ":"
 396                        (bytevector->base16-string hash)))
 397   json->content)
 398
 399 (define-query (lookup-revision id)
 400   "Return the revision with the given ID, typically a Git commit SHA1."
 401   (path "/api/1/revision" id)
 402   json->revision)
 403
 404 (define-query (lookup-directory id)
 405   "Return the directory with the given ID."
 406   (path "/api/1/directory" id)
 407   json->directory-entries)
 408
 409 (define (json->directory-entries port)
 410   (map json->directory-entry
 411        (vector->list (json->scm port))))
 412
 413 (define (origin-visits origin)
 414   "Return the list of visits of ORIGIN, a record as returned by
 415 'lookup-origin'."
 416   (call (swh-url (origin-visits-url origin))
 417         (lambda (port)
 418           (map json->visit (vector->list (json->scm port))))))
 419
 420 (define (visit-snapshot visit)
 421   "Return the snapshot corresponding to VISIT or #f if no snapshot is
 422 available."
 423   (and (visit-snapshot-url visit)
 424        (call (swh-url (visit-snapshot-url visit))
 425              json->snapshot)))
 426
 427 (define (branch-target branch)
 428   "Return the target of BRANCH, either a <revision> or a <release>."
 429   (match (branch-target-type branch)
 430     ('release
 431      (call (swh-url (branch-target-url branch))
 432            json->release))
 433     ('revision
 434      (call (swh-url (branch-target-url branch))
 435            json->revision))))
 436
 437 (define (lookup-origin-revision url tag)
 438   "Return a <revision> corresponding to the given TAG for the repository
 439 coming from URL.  Example:
 440
 441   (lookup-origin-revision \"https://github.com/guix-mirror/guix/\" \"v0.8\")
 442   => #<<revision> id: \"44941…\" …>
 443
 444 The information is based on the latest visit of URL available.  Return #f if
 445 URL could not be found."
 446   (match (lookup-origin url)
 447     (#f #f)
 448     (origin
 449       (match (filter visit-snapshot-url (origin-visits origin))
 450         ((visit . _)
 451          (let ((snapshot (visit-snapshot visit)))
 452            (match (and=> (find (lambda (branch)
 453                                  (string=? (string-append "refs/tags/" tag)
 454                                            (branch-name branch)))
 455                                (snapshot-branches snapshot))
 456                          branch-target)
 457              ((? release? release)
 458               (release-target release))
 459              ((? revision? revision)
 460               revision)
 461              (#f                                  ;tag not found
 462               #f))))
 463         (()
 464          #f)))))
 465
 466 (define (release-target release)
 467   "Return the revision that is the target of RELEASE."
 468   (match (release-target-type release)
 469     ('revision
 470      (call (swh-url (release-target-url release))
 471            json->revision))))
 472
 473 (define (directory-entry-target entry)
 474   "If ENTRY, a directory entry, has type 'directory, return its list of
 475 directory entries; if it has type 'file, return its <content> object."
 476   (call (swh-url (directory-entry-target-url entry))
 477         (match (directory-entry-type entry)
 478           ('file json->content)
 479           ('directory json->directory-entries))))
 480
 481 (define* (save-origin url #:optional (type "git"))
 482   "Request URL to be saved."
 483   (call (swh-url "/api/1/origin/save" type "url" url) json->save-reply
 484         http-post*))
 485
 486 (define-query (save-origin-status url type)
 487   "Return the status of a /save request for URL and TYPE (e.g., \"git\")."
 488   (path "/api/1/origin/save" type "url" url)
 489   json->save-reply)
 490
 491 (define-query (query-vault id kind)
 492   "Ask the availability of object ID and KIND to the vault, where KIND is
 493 'directory or 'revision.  Return #f if it could not be found, or a
 494 <vault-reply> on success."
 495   ;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref>
 496   ;; There's a single format supported for directories and revisions and for
 497   ;; now, the "/format" bit of the URL *must* be omitted.
 498   (path "/api/1/vault" (symbol->string kind) id)
 499   json->vault-reply)
 500
 501 (define (request-cooking id kind)
 502   "Request the cooking of object ID and KIND (one of 'directory or 'revision)
 503 to the vault.  Return a <vault-reply>."
 504   (call (swh-url "/api/1/vault" (symbol->string kind) id)
 505         json->vault-reply
 506         http-post*))
 507
 508 (define* (vault-fetch id kind
 509                       #:key (log-port (current-error-port)))
 510   "Return an input port from which a bundle of the object with the given ID
 511 and KIND (one of 'directory or 'revision) can be retrieved, or #f if the
 512 object could not be found.
 513
 514 For a directory, the returned stream is a gzip-compressed tarball.  For a
 515 revision, it is a gzip-compressed stream for 'git fast-import'."
 516   (let loop ((reply (query-vault id kind)))
 517     (match reply
 518       (#f
 519        (and=> (request-cooking id kind) loop))
 520       (_
 521        (match (vault-reply-status reply)
 522          ('done
 523           ;; Fetch the bundle.
 524           (let-values (((response port)
 525                         (http-get* (swh-url (vault-reply-fetch-url reply))
 526                                    #:streaming? #t
 527                                    #:verify-certificate?
 528                                    (%verify-swh-certificate?))))
 529             (if (= (response-code response) 200)
 530                 port
 531                 (begin                            ;shouldn't happen
 532                   (close-port port)
 533                   #f))))
 534          ('failed
 535           ;; Upon failure, we're supposed to try again.
 536           (format log-port "SWH vault: failure: ~a~%"
 537                   (vault-reply-progress-message reply))
 538           (format log-port "SWH vault: retrying...~%")
 539           (loop (request-cooking id kind)))
 540          ((and (or 'new 'pending) status)
 541           ;; Wait until the bundle shows up.
 542           (let ((message (vault-reply-progress-message reply)))
 543             (when (eq? 'new status)
 544               (format log-port "SWH vault: \
 545 requested bundle cooking, waiting for completion...~%"))
 546             (when (string? message)
 547               (format log-port "SWH vault: ~a~%" message))
 548
 549             ;; Wait long enough so we don't exhaust our maximum number of
 550             ;; requests per hour too fast (as of this writing, the limit is 60
 551             ;; requests per hour per IP address.)
 552             (sleep (if (eq? status 'new) 60 30))
 553
 554             (loop (query-vault id kind)))))))))
 555
 556 \f
 557 ;;;
 558 ;;; High-level interface.
 559 ;;;
 560
 561 (define (commit-id? reference)
 562   "Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
 563 it is a tag name.  This is based on a simple heuristic so use with care!"
 564   (and (= (string-length reference) 40)
 565        (string-every char-set:hex-digit reference)))
 566
 567 (define (call-with-temporary-directory proc)      ;FIXME: factorize
 568   "Call PROC with a name of a temporary directory; close the directory and
 569 delete it when leaving the dynamic extent of this call."
 570   (let* ((directory (or (getenv "TMPDIR") "/tmp"))
 571          (template  (string-append directory "/guix-directory.XXXXXX"))
 572          (tmp-dir   (mkdtemp! template)))
 573     (dynamic-wind
 574       (const #t)
 575       (lambda ()
 576         (proc tmp-dir))
 577       (lambda ()
 578         (false-if-exception (delete-file-recursively tmp-dir))))))
 579
 580 (define* (swh-download url reference output
 581                        #:key (log-port (current-error-port)))
 582   "Download from Software Heritage a checkout of the Git tag or commit
 583 REFERENCE originating from URL, and unpack it in OUTPUT.  Return #t on success
 584 and #f on failure.
 585
 586 This procedure uses the \"vault\", which contains \"cooked\" directories in
 587 the form of tarballs.  If the requested directory is not cooked yet, it will
 588 wait until it becomes available, which could take several minutes."
 589   (match (if (commit-id? reference)
 590              (lookup-revision reference)
 591              (lookup-origin-revision url reference))
 592     ((? revision? revision)
 593      (format log-port "SWH: found revision ~a with directory at '~a'~%"
 594              (revision-id revision)
 595              (swh-url (revision-directory-url revision)))
 596      (call-with-temporary-directory
 597       (lambda (directory)
 598         (match (vault-fetch (revision-directory revision) 'directory
 599                             #:log-port log-port)
 600           (#f
 601            (format log-port
 602                    "SWH: directory ~a could not be fetched from the vault~%"
 603                    (revision-directory revision))
 604            #f)
 605           ((? port? input)
 606            (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
 607              (dump-port input tar)
 608              (close-port input)
 609              (let ((status (close-pipe tar)))
 610                (unless (zero? status)
 611                  (error "tar extraction failure" status)))
 612
 613              (match (scandir directory)
 614                (("." ".." sub-directory)
 615                 (copy-recursively (string-append directory "/" sub-directory)
 616                                   output
 617                                   #:log (%make-void-port "w"))
 618                 #t))))))))
 619     (#f
 620      #f)))