guix/swh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019, 2020 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                    (lst (json->checksums lst))))
 352   (id            directory-entry-id "dir_id")
 353   (length        directory-entry-length)
 354   (permissions   directory-entry-permissions "perms")
 355   (target-url    directory-entry-target-url "target_url"))
 356
 357 ;; <https://archive.softwareheritage.org/api/1/origin/save/>
 358 (define-json-mapping <save-reply> make-save-reply save-reply?
 359   json->save-reply
 360   (origin-url     save-reply-origin-url "origin_url")
 361   (origin-type    save-reply-origin-type "origin_type")
 362   (request-date   save-reply-request-date "save_request_date"
 363                   string->date*)
 364   (request-status save-reply-request-status "save_request_status"
 365                   string->symbol)
 366   (task-status    save-reply-task-status "save_task_status"
 367                   (match-lambda
 368                     ("not created" 'not-created)
 369                     ((? string? str) (string->symbol str)))))
 370
 371 ;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref>
 372 (define-json-mapping <vault-reply> make-vault-reply vault-reply?
 373   json->vault-reply
 374   (id             vault-reply-id)
 375   (fetch-url      vault-reply-fetch-url "fetch_url")
 376   (object-id      vault-reply-object-id "obj_id")
 377   (object-type    vault-reply-object-type "obj_type" string->symbol)
 378   (progress-message vault-reply-progress-message "progress_message")
 379   (status         vault-reply-status "status" string->symbol))
 380
 381 \f
 382 ;;;
 383 ;;; RPCs.
 384 ;;;
 385
 386 (define-query (lookup-origin url)
 387   "Return an origin for URL."
 388   (path "/api/1/origin" url "get")
 389   json->origin)
 390
 391 (define-query (lookup-content hash type)
 392   "Return a content for HASH, of the given TYPE--e.g., \"sha256\"."
 393   (path "/api/1/content"
 394         (string-append type ":"
 395                        (bytevector->base16-string hash)))
 396   json->content)
 397
 398 (define-query (lookup-revision id)
 399   "Return the revision with the given ID, typically a Git commit SHA1."
 400   (path "/api/1/revision" id)
 401   json->revision)
 402
 403 (define-query (lookup-directory id)
 404   "Return the directory with the given ID."
 405   (path "/api/1/directory" id)
 406   json->directory-entries)
 407
 408 (define (json->directory-entries port)
 409   (map json->directory-entry
 410        (vector->list (json->scm port))))
 411
 412 (define (origin-visits origin)
 413   "Return the list of visits of ORIGIN, a record as returned by
 414 'lookup-origin'."
 415   (call (swh-url (origin-visits-url origin))
 416         (lambda (port)
 417           (map json->visit (vector->list (json->scm port))))))
 418
 419 (define (visit-snapshot visit)
 420   "Return the snapshot corresponding to VISIT or #f if no snapshot is
 421 available."
 422   (and (visit-snapshot-url visit)
 423        (call (swh-url (visit-snapshot-url visit))
 424              json->snapshot)))
 425
 426 (define (branch-target branch)
 427   "Return the target of BRANCH, either a <revision> or a <release>."
 428   (match (branch-target-type branch)
 429     ('release
 430      (call (swh-url (branch-target-url branch))
 431            json->release))
 432     ('revision
 433      (call (swh-url (branch-target-url branch))
 434            json->revision))))
 435
 436 (define (lookup-origin-revision url tag)
 437   "Return a <revision> corresponding to the given TAG for the repository
 438 coming from URL.  Example:
 439
 440   (lookup-origin-revision \"https://github.com/guix-mirror/guix/\" \"v0.8\")
 441   => #<<revision> id: \"44941…\" …>
 442
 443 The information is based on the latest visit of URL available.  Return #f if
 444 URL could not be found."
 445   (match (lookup-origin url)
 446     (#f #f)
 447     (origin
 448       (match (filter visit-snapshot-url (origin-visits origin))
 449         ((visit . _)
 450          (let ((snapshot (visit-snapshot visit)))
 451            (match (and=> (find (lambda (branch)
 452                                  (string=? (string-append "refs/tags/" tag)
 453                                            (branch-name branch)))
 454                                (snapshot-branches snapshot))
 455                          branch-target)
 456              ((? release? release)
 457               (release-target release))
 458              ((? revision? revision)
 459               revision)
 460              (#f                                  ;tag not found
 461               #f))))
 462         (()
 463          #f)))))
 464
 465 (define (release-target release)
 466   "Return the revision that is the target of RELEASE."
 467   (match (release-target-type release)
 468     ('revision
 469      (call (swh-url (release-target-url release))
 470            json->revision))))
 471
 472 (define (directory-entry-target entry)
 473   "If ENTRY, a directory entry, has type 'directory, return its list of
 474 directory entries; if it has type 'file, return its <content> object."
 475   (call (swh-url (directory-entry-target-url entry))
 476         (match (directory-entry-type entry)
 477           ('file json->content)
 478           ('directory json->directory-entries))))
 479
 480 (define* (save-origin url #:optional (type "git"))
 481   "Request URL to be saved."
 482   (call (swh-url "/api/1/origin/save" type "url" url) json->save-reply
 483         http-post*))
 484
 485 (define-query (save-origin-status url type)
 486   "Return the status of a /save request for URL and TYPE (e.g., \"git\")."
 487   (path "/api/1/origin/save" type "url" url)
 488   json->save-reply)
 489
 490 (define-query (query-vault id kind)
 491   "Ask the availability of object ID and KIND to the vault, where KIND is
 492 'directory or 'revision.  Return #f if it could not be found, or a
 493 <vault-reply> on success."
 494   ;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref>
 495   ;; There's a single format supported for directories and revisions and for
 496   ;; now, the "/format" bit of the URL *must* be omitted.
 497   (path "/api/1/vault" (symbol->string kind) id)
 498   json->vault-reply)
 499
 500 (define (request-cooking id kind)
 501   "Request the cooking of object ID and KIND (one of 'directory or 'revision)
 502 to the vault.  Return a <vault-reply>."
 503   (call (swh-url "/api/1/vault" (symbol->string kind) id)
 504         json->vault-reply
 505         http-post*))
 506
 507 (define* (vault-fetch id kind
 508                       #:key (log-port (current-error-port)))
 509   "Return an input port from which a bundle of the object with the given ID
 510 and KIND (one of 'directory or 'revision) can be retrieved, or #f if the
 511 object could not be found.
 512
 513 For a directory, the returned stream is a gzip-compressed tarball.  For a
 514 revision, it is a gzip-compressed stream for 'git fast-import'."
 515   (let loop ((reply (query-vault id kind)))
 516     (match reply
 517       (#f
 518        (and=> (request-cooking id kind) loop))
 519       (_
 520        (match (vault-reply-status reply)
 521          ('done
 522           ;; Fetch the bundle.
 523           (let-values (((response port)
 524                         (http-get* (swh-url (vault-reply-fetch-url reply))
 525                                    #:streaming? #t
 526                                    #:verify-certificate?
 527                                    (%verify-swh-certificate?))))
 528             (if (= (response-code response) 200)
 529                 port
 530                 (begin                            ;shouldn't happen
 531                   (close-port port)
 532                   #f))))
 533          ('failed
 534           ;; Upon failure, we're supposed to try again.
 535           (format log-port "SWH vault: failure: ~a~%"
 536                   (vault-reply-progress-message reply))
 537           (format log-port "SWH vault: retrying...~%")
 538           (loop (request-cooking id kind)))
 539          ((and (or 'new 'pending) status)
 540           ;; Wait until the bundle shows up.
 541           (let ((message (vault-reply-progress-message reply)))
 542             (when (eq? 'new status)
 543               (format log-port "SWH vault: \
 544 requested bundle cooking, waiting for completion...~%"))
 545             (when (string? message)
 546               (format log-port "SWH vault: ~a~%" message))
 547
 548             ;; Wait long enough so we don't exhaust our maximum number of
 549             ;; requests per hour too fast (as of this writing, the limit is 60
 550             ;; requests per hour per IP address.)
 551             (sleep (if (eq? status 'new) 60 30))
 552
 553             (loop (query-vault id kind)))))))))
 554
 555 \f
 556 ;;;
 557 ;;; High-level interface.
 558 ;;;
 559
 560 (define (commit-id? reference)
 561   "Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
 562 it is a tag name.  This is based on a simple heuristic so use with care!"
 563   (and (= (string-length reference) 40)
 564        (string-every char-set:hex-digit reference)))
 565
 566 (define (call-with-temporary-directory proc)      ;FIXME: factorize
 567   "Call PROC with a name of a temporary directory; close the directory and
 568 delete it when leaving the dynamic extent of this call."
 569   (let* ((directory (or (getenv "TMPDIR") "/tmp"))
 570          (template  (string-append directory "/guix-directory.XXXXXX"))
 571          (tmp-dir   (mkdtemp! template)))
 572     (dynamic-wind
 573       (const #t)
 574       (lambda ()
 575         (proc tmp-dir))
 576       (lambda ()
 577         (false-if-exception (delete-file-recursively tmp-dir))))))
 578
 579 (define* (swh-download url reference output
 580                        #:key (log-port (current-error-port)))
 581   "Download from Software Heritage a checkout of the Git tag or commit
 582 REFERENCE originating from URL, and unpack it in OUTPUT.  Return #t on success
 583 and #f on failure.
 584
 585 This procedure uses the \"vault\", which contains \"cooked\" directories in
 586 the form of tarballs.  If the requested directory is not cooked yet, it will
 587 wait until it becomes available, which could take several minutes."
 588   (match (if (commit-id? reference)
 589              (lookup-revision reference)
 590              (lookup-origin-revision url reference))
 591     ((? revision? revision)
 592      (format log-port "SWH: found revision ~a with directory at '~a'~%"
 593              (revision-id revision)
 594              (swh-url (revision-directory-url revision)))
 595      (call-with-temporary-directory
 596       (lambda (directory)
 597         (match (vault-fetch (revision-directory revision) 'directory
 598                             #:log-port log-port)
 599           (#f
 600            (format log-port
 601                    "SWH: directory ~a could not be fetched from the vault~%"
 602                    (revision-directory revision))
 603            #f)
 604           ((? port? input)
 605            (let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
 606              (dump-port input tar)
 607              (close-port input)
 608              (let ((status (close-pipe tar)))
 609                (unless (zero? status)
 610                  (error "tar extraction failure" status)))
 611
 612              (match (scandir directory)
 613                (("." ".." sub-directory)
 614                 (copy-recursively (string-append directory "/" sub-directory)
 615                                   output
 616                                   #:log (%make-void-port "w"))
 617                 #t))))))))
 618     (#f
 619      #f)))