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