guix/swh.scm

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