code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix channels)
  #:use-module (git)
  #:use-module (guix git)
  #:use-module (guix git-authenticate)
  #:use-module ((guix openpgp)
                #:select (openpgp-public-key-fingerprint
                          openpgp-format-fingerprint))
  #:use-module (guix base16)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix discovery)
  #:use-module (guix monads)
  #:use-module (guix profiles)
  #:use-module (guix packages)
  #:use-module (guix progress)
  #:use-module (guix derivations)
  #:use-module (guix combinators)
  #:use-module (guix diagnostics)
  #:use-module (guix sets)
  #:use-module (guix store)
  #:use-module (guix i18n)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:autoload   (guix describe) (current-channels) ;XXX: circular dep
  #:autoload   (guix self) (whole-package make-config.scm)
  #:autoload   (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep
  #:autoload   (guix quirks) (%quirks %patches applicable-patch? apply-patch)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module ((ice-9 rdelim) #:select (read-string))
  #:use-module ((rnrs bytevectors) #:select (bytevector=?))
  #:export (channel
            channel?
            channel-name
            channel-url
            channel-branch
            channel-commit
            channel-introduction
            channel-location

            channel-introduction?
            make-channel-introduction
            channel-introduction-first-signed-commit
            channel-introduction-first-commit-signer

            openpgp-fingerprint->bytevector
            openpgp-fingerprint

            %default-guix-channel
            %default-channels
            guix-channel?

            channel-instance?
            channel-instance-channel
            channel-instance-commit
            channel-instance-checkout

            authenticate-channel
            latest-channel-instances
            checkout->channel-instance
            latest-channel-derivation
            channel-instance->sexp
            channel-instances->manifest
            %channel-profile-hooks
            channel-instances->derivation
            ensure-forward-channel-update

            profile-channels
            manifest-entry-channel
            sexp->channel
            channel->code

            channel-news-entry?
            channel-news-entry-commit
            channel-news-entry-tag
            channel-news-entry-title
            channel-news-entry-body

            channel-news-for-commit))

;;; Commentary:
;;;
;;; This module implements "channels."  A channel is usually a source of
;;; package definitions.  There's a special channel, the 'guix' channel, that
;;; provides all of Guix, including its commands and its documentation.
;;; User-defined channels are expected to typically provide a bunch of .scm
;;; files meant to be added to the '%package-search-path'.
;;;
;;; This module provides tools to fetch and update channels from a Git
;;; repository and to build them.
;;;
;;; Code:

(define-record-type* <channel> channel make-channel
  channel?
  (name      channel-name)
  (url       channel-url)
  (branch    channel-branch (default "master"))
  (commit    channel-commit (default #f))
  (introduction channel-introduction (default #f))
  (location  channel-location
             (default (current-source-location)) (innate)))

;; Channel introductions.  A "channel introduction" provides a commit/signer
;; pair that specifies the first commit of the authentication process as well
;; as its signer's fingerprint.  Introductions are used to bootstrap trust in
;; a channel.
(define-record-type <channel-introduction>
  (%make-channel-introduction first-signed-commit first-commit-signer)
  channel-introduction?
  (first-signed-commit  channel-introduction-first-signed-commit)  ;hex string
  (first-commit-signer  channel-introduction-first-commit-signer)) ;bytevector

(define (make-channel-introduction commit signer)
  "Return a new channel introduction: COMMIT is the introductory where
authentication starts, and SIGNER is the OpenPGP fingerprint (a bytevector) of
the signer of that commit."
  (%make-channel-introduction commit signer))

(define (openpgp-fingerprint->bytevector str)
  "Convert STR, an OpenPGP fingerprint (hexadecimal string with whitespace),
to the corresponding bytevector."
  (base16-string->bytevector
   (string-downcase (string-filter char-set:hex-digit str))))

(define-syntax openpgp-fingerprint
  (lambda (s)
    "Convert STR, an OpenPGP fingerprint (hexadecimal string with whitespace),
to the corresponding bytevector."
    (syntax-case s ()
      ((_ str)
       (string? (syntax->datum #'str))
       (openpgp-fingerprint->bytevector (syntax->datum #'str)))
      ((_ str)
       #'(openpgp-fingerprint->bytevector str)))))

(define %guix-channel-introduction
  ;; Introduction of the official 'guix channel.  The chosen commit is the
  ;; first one that introduces '.guix-authorizations' on the 'staging'
  ;; branch that was eventually merged in 'master'.  Any branch starting
  ;; before that commit cannot be merged or it will be rejected by 'guix pull'
  ;; & co.
  (make-channel-introduction
   "9edb3f66fd807b096b48283debdcddccfea34bad"     ;2020-05-26
   (openpgp-fingerprint                           ;mbakke
    "BBB0 2DDF 2CEA F6A8 0D1D  E643 A2A0 6DF2 A33A 54FA")))

(define %default-channel-url
  ;; URL of the default 'guix' channel.
  "https://git.savannah.gnu.org/git/guix.git")

(define %default-guix-channel
  (channel
   (name 'guix)
   (branch "master")
   (url %default-channel-url)
   (introduction %guix-channel-introduction)))

(define %default-channels
  ;; Default list of channels.
  (list %default-guix-channel))

(define (guix-channel? channel)
  "Return true if CHANNEL is the 'guix' channel."
  (eq? 'guix (channel-name channel)))

(define (ensure-default-introduction chan)
  "If CHAN represents the \"official\" 'guix' channel and lacks an
introduction, add it."
  (if (and (guix-channel? chan)
           (not (channel-introduction chan))
           (string=? (channel-url chan) %default-channel-url))
      (channel (inherit chan)
               (introduction %guix-channel-introduction))
      chan))

(define-record-type <channel-instance>
  (channel-instance channel commit checkout)
  channel-instance?
  (channel   channel-instance-channel)
  (commit    channel-instance-commit)
  (checkout  channel-instance-checkout))

(define-record-type <channel-metadata>
  (channel-metadata directory dependencies news-file keyring-reference url)
  channel-metadata?
  (directory     channel-metadata-directory)      ;string with leading slash
  (dependencies  channel-metadata-dependencies)   ;list of <channel>
  (news-file     channel-metadata-news-file)      ;string | #f
  (keyring-reference channel-metadata-keyring-reference) ;string
  (url           channel-metadata-url))           ;string | #f

(define %default-keyring-reference
  ;; Default value of the 'keyring-reference' field.
  "keyring")

(define (channel-reference channel)
  "Return the \"reference\" for CHANNEL, an sexp suitable for
'latest-repository-commit'."
  (match (channel-commit channel)
    (#f      `(branch . ,(channel-branch channel)))
    (commit  `(commit . ,(channel-commit channel)))))

(define sexp->channel-introduction
  (match-lambda
    (('channel-introduction ('version 0)
                            ('commit commit) ('signer signer)
                            _ ...)
     (make-channel-introduction commit (openpgp-fingerprint signer)))
    (x #f)))

(define (read-channel-metadata port)
  "Read from PORT channel metadata in the format expected for the
'.guix-channel' file.  Return a <channel-metadata> record, or raise an error
if valid metadata could not be read from PORT."
  (match (read port)
    (('channel ('version 0) properties ...)
     (let ((directory    (and=> (assoc-ref properties 'directory) first))
           (dependencies (or (assoc-ref properties 'dependencies) '()))
           (news-file    (and=> (assoc-ref properties 'news-file) first))
           (url          (and=> (assoc-ref properties 'url) first))
           (keyring-reference
            (or (and=> (assoc-ref properties 'keyring-reference) first)
                %default-keyring-reference)))
       (channel-metadata
        (cond ((not directory) "/")               ;directory
              ((string-prefix? "/" directory) directory)
              (else (string-append "/" directory)))
        (map (lambda (item)                       ;dependencies
               (let ((get (lambda* (key #:optional default)
                            (or (and=> (assoc-ref item key) first) default))))
                 (and-let* ((name (get 'name))
                            (url (get 'url))
                            (branch (get 'branch "master")))
                   (channel
                    (name name)
                    (branch branch)
                    (url url)
                    (commit (get 'commit))
                    (introduction (and=> (get 'introduction)
                                         sexp->channel-introduction))))))
             dependencies)
        news-file
        keyring-reference
        url)))
    ((and ('channel ('version version) _ ...) sexp)
     (raise (condition
             (&message (message "unsupported '.guix-channel' version"))
             (&error-location
              (location (source-properties->location
                         (source-properties sexp)))))))
    (sexp
     (raise (condition
             (&message (message "invalid '.guix-channel' file"))
             (&error-location
              (location (source-properties->location
                         (source-properties sexp)))))))))

(define (read-channel-metadata-from-source source)
  "Return a channel-metadata record read from channel's SOURCE/.guix-channel
description file, or return the default channel-metadata record if that file
doesn't exist."
  (catch 'system-error
    (lambda ()
      (call-with-input-file (string-append source "/.guix-channel")
        read-channel-metadata))
    (lambda args
      (if (= ENOENT (system-error-errno args))
          (channel-metadata "/" '() #f %default-keyring-reference #f)
          (apply throw args)))))

(define (channel-instance-metadata instance)
  "Return a channel-metadata record read from the channel INSTANCE's
description file or its default value."
  (read-channel-metadata-from-source (channel-instance-checkout instance)))

(define (channel-instance-dependencies instance)
  "Return the list of channels that are declared as dependencies for the given
channel INSTANCE."
  (channel-metadata-dependencies (channel-instance-metadata instance)))

(define (apply-patches checkout commit patches)
  "Apply the matching PATCHES to CHECKOUT, modifying files in place.  The
result is unspecified."
  (let loop ((patches patches))
    (match patches
      (() #t)
      ((patch rest ...)
       (when (applicable-patch? patch checkout commit)
         (apply-patch patch checkout))
       (loop rest)))))

(define commit-short-id
  (compose (cut string-take <> 7) oid->string commit-id))

(define* (authenticate-channel channel checkout commit
                               #:key (keyring-reference-prefix "origin/"))
  "Authenticate the given COMMIT of CHANNEL, available at CHECKOUT, a
directory containing a CHANNEL checkout.  Raise an error if authentication
fails."
  (define intro
    (channel-introduction channel))

  (define cache-key
    (string-append "channels/" (symbol->string (channel-name channel))))

  (define keyring-reference
    (channel-metadata-keyring-reference
     (read-channel-metadata-from-source checkout)))

  (define (make-reporter start-commit end-commit commits)
    (format (current-error-port)
            (G_ "Authenticating channel '~a', commits ~a to ~a (~h new \
commits)...~%")
            (channel-name channel)
            (commit-short-id start-commit)
            (commit-short-id end-commit)
            (length commits))

    (progress-reporter/bar (length commits)))

  (define authentic-commits
    ;; Consider the currently-used commit of CHANNEL as authentic so
    ;; authentication can skip it and all its closure.
    (match (find (lambda (candidate)
                   (eq? (channel-name candidate) (channel-name channel)))
                 (current-channels))
      (#f '())
      (channel
       (if (channel-commit channel)
           (list (channel-commit channel))
           '()))))

  ;; XXX: Too bad we need to re-open CHECKOUT.
  (with-repository checkout repository
    (authenticate-repository repository
                             (string->oid
                              (channel-introduction-first-signed-commit intro))
                             (channel-introduction-first-commit-signer intro)
                             #:end (string->oid commit)
                             #:keyring-reference
                             (string-append keyring-reference-prefix
                                            keyring-reference)
                             #:authentic-commits authentic-commits
                             #:make-reporter make-reporter
                             #:cache-key cache-key)))

(define* (latest-channel-instance store channel
                                  #:key (patches %patches)
                                  starting-commit
                                  (authenticate? #f)
                                  (validate-pull
                                   ensure-forward-channel-update))
  "Return the latest channel instance for CHANNEL.  When STARTING-COMMIT is
true, call VALIDATE-PULL with CHANNEL, STARTING-COMMIT, the target commit, and
their relation.  When AUTHENTICATE? is false, CHANNEL is not authenticated."
  (define (dot-git? file stat)
    (and (string=? (basename file) ".git")
         (eq? 'directory (stat:type stat))))

  (let-values (((channel)
                (ensure-default-introduction channel))
               ((checkout commit relation)
                (update-cached-checkout (channel-url channel)
                                        #:ref (channel-reference channel)
                                        #:starting-commit starting-commit)))
    (when relation
      (validate-pull channel starting-commit commit relation))

    (if authenticate?
        (if (channel-introduction channel)
            (authenticate-channel channel checkout commit)
            ;; TODO: Warn for all the channels once the authentication interface
            ;; is public.
            (when (guix-channel? channel)
              (raise (make-compound-condition
                      (formatted-message (G_ "channel '~a' lacks an \
introduction and cannot be authenticated~%")
                                         (channel-name channel))
                      (condition
                       (&fix-hint
                        (hint (G_ "Add the missing introduction to your
channels file to address the issue.  Alternatively, you can pass
@option{--disable-authentication}, at the risk of running unauthenticated and
thus potentially malicious code."))))))))
        (warning (G_ "channel authentication disabled~%")))

    (when (guix-channel? channel)
      ;; Apply the relevant subset of PATCHES directly in CHECKOUT.  This is
      ;; safe to do because 'switch-to-ref' eventually does a hard reset.
      (apply-patches checkout commit patches))

    (let* ((name     (url+commit->name (channel-url channel) commit))
           (checkout (add-to-store store name #t "sha256" checkout
                                   #:select? (negate dot-git?))))
      (channel-instance channel commit checkout))))

(define (ensure-forward-channel-update channel start commit relation)
  "Raise an error if RELATION is not 'ancestor, meaning that START is not an
ancestor of COMMIT, unless CHANNEL specifies a commit.

This procedure implements a channel update policy meant to be used as a
#:validate-pull argument."
  (match relation
    ('ancestor #t)
    ('self #t)
    (_
     (raise (make-compound-condition
             (condition
              (&message (message
                         (format #f (G_ "\
aborting update of channel '~a' to commit ~a, which is not a descendant of ~a")
                                 (channel-name channel)
                                 commit start))))

             ;; If the user asked for a specific commit, they might want
             ;; that to happen nevertheless, so tell them about the
             ;; relevant 'guix pull' option.
             (if (channel-commit channel)
                 (condition
                  (&fix-hint
                   (hint (G_ "Use @option{--allow-downgrades} to force
this downgrade."))))
                 (condition
                  (&fix-hint
                   (hint (G_ "This could indicate that the channel has
been tampered with and is trying to force a roll-back, preventing you from
getting the latest updates.  If you think this is not the case, explicitly
allow non-forward updates."))))))))))

(define (channel-instance-primary-url instance)
  "Return the primary URL advertised for INSTANCE, or #f if there is no such
information."
  (channel-metadata-url (channel-instance-metadata instance)))

(define* (latest-channel-instances store channels
                                   #:key
                                   (current-channels '())
                                   (authenticate? #t)
                                   (validate-pull
                                    ensure-forward-channel-update))
  "Return a list of channel instances corresponding to the latest checkouts of
CHANNELS and the channels on which they depend.

When AUTHENTICATE? is true, authenticate the subset of CHANNELS that has a
\"channel introduction\".

CURRENT-CHANNELS is the list of currently used channels.  It is compared
against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called
for each channel update and can choose to emit warnings or raise an error,
depending on the policy it implements."
  ;; Only process channels that are unique, or that are more specific than a
  ;; previous channel specification.
  (define (ignore? channel others)
    (member channel others
            (lambda (a b)
              (and (eq? (channel-name a) (channel-name b))
                   (or (channel-commit b)
                       (not (or (channel-commit a)
                                (channel-commit b))))))))

  (define (current-commit name)
    ;; Return the current commit for channel NAME.
    (any (lambda (channel)
           (and (eq? (channel-name channel) name)
                (channel-commit channel)))
         current-channels))

  (let loop ((channels channels)
             (previous-channels '()))
    ;; Accumulate a list of instances.  A list of processed channels is also
    ;; accumulated to decide on duplicate channel specifications.
    (define-values (resulting-channels instances)
      (fold2 (lambda (channel previous-channels instances)
               (if (ignore? channel previous-channels)
                   (values previous-channels instances)
                   (begin
                     (format (current-error-port)
                             (G_ "Updating channel '~a' from Git repository at '~a'...~%")
                             (channel-name channel)
                             (channel-url channel))
                     (let* ((current (current-commit (channel-name channel)))
                            (instance
                             (latest-channel-instance store channel
                                                      #:authenticate?
                                                      authenticate?
                                                      #:validate-pull
                                                      validate-pull
                                                      #:starting-commit
                                                      current)))
                       (when authenticate?
                         ;; CHANNEL is authenticated so we can trust the
                         ;; primary URL advertised in its metadata and warn
                         ;; about possibly stale mirrors.
                         (let ((primary-url (channel-instance-primary-url
                                             instance)))
                           (unless (or (not primary-url)
                                       (channel-commit channel)
                                       (string=? primary-url (channel-url channel)))
                             (warning (G_ "pulled channel '~a' from a mirror \
of ~a, which might be stale~%")
                                      (channel-name channel)
                                      primary-url))))

                       (let-values (((new-instances new-channels)
                                     (loop (channel-instance-dependencies instance)
                                           previous-channels)))
                         (values (append (cons channel new-channels)
                                         previous-channels)
                                 (append (cons instance new-instances)
                                         instances)))))))
             previous-channels
             '()                                  ;instances
             channels))

    (let ((instance-name (compose channel-name channel-instance-channel)))
      ;; Remove all earlier channel specifications if they are followed by a
      ;; more specific one.
      (values (delete-duplicates instances
                                 (lambda (a b)
                                   (eq? (instance-name a) (instance-name b))))
              resulting-channels))))

(define* (checkout->channel-instance checkout
                                     #:key commit
                                     (url checkout) (name 'guix))
  "Return a channel instance for CHECKOUT, which is assumed to be a checkout
of COMMIT at URL.  Use NAME as the channel name."
  (let* ((commit  (or commit (make-string 40 #\0)))
         (channel (channel (name name)
                           (commit commit)
                           (url url))))
    (channel-instance channel commit checkout)))

(define %self-build-file
  ;; The file containing code to build Guix.  This serves the same purpose as
  ;; a makefile, and, similarly, is intended to always keep this name.
  "build-aux/build-self.scm")

(define %pull-version
  ;; This is the version of the 'guix pull' protocol.  It specifies what's
  ;; expected from %SELF-BUILD-FILE.  The initial version ("0") was when we'd
  ;; place a set of compiled Guile modules in ~/.config/guix/latest.
  1)

(define (standard-module-derivation name source core dependencies)
  "Return a derivation that builds with CORE, a Guix instance, the Scheme
modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable
objects.  The assumption is that SOURCE contains package modules to be added
to '%package-module-path'."

  (let* ((metadata (read-channel-metadata-from-source source))
         (directory (channel-metadata-directory metadata)))

    (define build
      ;; This is code that we'll run in CORE, a Guix instance, with its own
      ;; modules and so on.  That way, we make sure these modules are built for
      ;; the right Guile version, with the right dependencies, and that they get
      ;; to see the right (gnu packages …) modules.
      (with-extensions dependencies
        #~(begin
            (use-modules (guix build compile)
                         (guix build utils)
                         (srfi srfi-26))

            (define go
              (string-append #$output "/lib/guile/" (effective-version)
                             "/site-ccache"))
            (define scm
              (string-append #$output "/share/guile/site/"
                             (effective-version)))

            (define optimizations-for-level
              ;; Guile 3.0 provides this procedure but Guile 2.2 didn't.
              ;; Since this code may be executed by either version, we can't
              ;; rely on its availability.
              (or (and=> (false-if-exception
                          (resolve-interface '(system base optimize)))
                         (lambda (iface)
                           (module-ref iface 'optimizations-for-level)))
                  (const '())))

            (define -O1
              ;; Optimize for package module compilation speed.
              (optimizations-for-level 1))

            (let* ((subdir #$directory)
                   (source (string-append #$source subdir)))
              (compile-files source go (find-files source "\\.scm$")
                             #:optimization-options (const -O1))
              (mkdir-p (dirname scm))
              (symlink (string-append #$source subdir) scm))

            scm)))

    (gexp->derivation-in-inferior name build core)))

(define* (guile-for-source source #:optional (quirks %quirks))
  "Return the Guile package to use when building SOURCE or #f if the default
'%guile-for-build' should be good enough."
  (let loop ((quirks quirks))
    (match quirks
      (()
       #f)
      (((predicate . guile) rest ...)
       (if (predicate source) (guile) (loop rest))))))

(define (call-with-guile guile thunk)
  (lambda (store)
    (values (parameterize ((%guile-for-build
                            (if guile
                                (package-derivation store guile)
                                (%guile-for-build))))
              (run-with-store store (thunk)))
            store)))

(define-syntax-rule (with-guile guile exp ...)
  "Set GUILE as the '%guile-for-build' parameter for the dynamic extent of
EXP, a series of monadic expressions."
  (call-with-guile guile (lambda ()
                           (mbegin %store-monad exp ...))))

(define (with-trivial-build-handler mvalue)
  "Run MVALUE, a monadic value, with a \"trivial\" build handler installed
that unconditionally resumes the continuation."
  (lambda (store)
    (with-build-handler (lambda (continue . _)
                          (continue #t))
      (values (run-with-store store mvalue)
              store))))

(define* (build-from-source instance
                            #:key core verbose? (dependencies '()) system)
  "Return a derivation to build Guix from INSTANCE, using the self-build
script contained therein.  When CORE is true, build package modules under
SOURCE using CORE, an instance of Guix.  By default, build for the current
system, or SYSTEM if specified."
  (define name
    (symbol->string
     (channel-name (channel-instance-channel instance))))
  (define source
    (channel-instance-checkout instance))
  (define commit
    (channel-instance-commit instance))

  ;; Running the self-build script makes it easier to update the build
  ;; procedure: the self-build script of the Guix-to-be-installed contains the
  ;; right dependencies, build procedure, etc., which the Guix-in-use may not
  ;; know.
  (define script
    (string-append source "/" %self-build-file))

  (if (file-exists? script)
      (let ((build (save-module-excursion
                    (lambda ()
                      ;; Disable deprecation warnings; it's OK for SCRIPT to
                      ;; use deprecated APIs and the user doesn't have to know
                      ;; about it.
                      (parameterize ((guix-warning-port
                                      (%make-void-port "w")))
                        (primitive-load script)))))
            (guile (guile-for-source source)))
        ;; BUILD must be a monadic procedure of at least one argument: the
        ;; source tree.
        ;;
        ;; Note: BUILD can return #f if it does not support %PULL-VERSION.  In
        ;; the future we'll fall back to a previous version of the protocol
        ;; when that happens.
        (with-guile guile
          ;; BUILD is usually quite costly.  Install a "trivial" build handler
          ;; so we don't bounce an outer build-accumulator handler that could
          ;; cause us to redo half of the BUILD computation several times just
          ;; to realize it gives the same result.
          (with-trivial-build-handler
           (build source
                  #:verbose? verbose? #:version commit
                  #:system system
                  #:channel-metadata (channel-instance->sexp instance)
                  #:pull-version %pull-version))))

      ;; Build a set of modules that extend Guix using the standard method.
      (standard-module-derivation name source core dependencies)))

(define* (build-channel-instance instance system
                                 #:optional core (dependencies '()))
  "Return, as a monadic value, the derivation for INSTANCE, a channel
instance, for SYSTEM.  DEPENDENCIES is a list of extensions providing Guile
modules that INSTANCE depends on."
  (build-from-source instance
                     #:core core
                     #:dependencies dependencies
                     #:system system))

(define (resolve-dependencies instances)
  "Return a procedure that, given one of the elements of INSTANCES, returns
list of instances it depends on."
  (define channel-instance-name
    (compose channel-name channel-instance-channel))

  (define table                                   ;map a name to an instance
    (fold (lambda (instance table)
            (vhash-consq (channel-instance-name instance)
                         instance table))
          vlist-null
          instances))

  (define edges
    (fold (lambda (instance edges)
            (fold (lambda (channel edges)
                    (let ((name (channel-name channel)))
                      (match (vhash-assq name table)
                        ((_ . target)
                         (vhash-consq instance target edges)))))
                  edges
                  (channel-instance-dependencies instance)))
          vlist-null
          instances))

  (lambda (instance)
    (vhash-foldq* cons '() instance edges)))

(define* (channel-instance-derivations instances #:key system)
  "Return the list of derivations to build INSTANCES, in the same order as
INSTANCES.  Build for the current system by default, or SYSTEM if specified."
  (define core-instance
    ;; The 'guix' channel is treated specially: it's an implicit dependency of
    ;; all the other channels.
    (find (lambda (instance)
            (guix-channel? (channel-instance-channel instance)))
          instances))

  (define edges
    (resolve-dependencies instances))

  (define (instance->derivation instance)
    (mlet %store-monad ((system (if system (return system) (current-system))))
      (mcached (if (eq? instance core-instance)
                   (build-channel-instance instance system)
                   (mlet %store-monad ((core (instance->derivation core-instance))
                                       (deps (mapm %store-monad instance->derivation
                                                   (edges instance))))
                     (build-channel-instance instance system core deps)))
               instance
               system)))

  (unless core-instance
    (let ((loc (and=> (any (compose channel-location channel-instance-channel)
                           instances)
                      source-properties->location)))
      (raise (apply make-compound-condition
                    (condition
                     (&message (message "'guix' channel is lacking")))
                    (condition
                     (&fix-hint (hint (G_ "Make sure your list of channels
contains one channel named @code{guix} providing the core of Guix."))))
                    (if loc
                        (list (condition (&error-location (location loc))))
                        '())))))

  (mapm %store-monad instance->derivation instances))

(define (whole-package-for-legacy name modules)
  "Return a full-blown Guix package for MODULES, a derivation that builds Guix
modules in the old ~/.config/guix/latest style."
  (define packages
    (resolve-interface '(gnu packages guile)))

  (define modules+compiled
    ;; Since MODULES contains both .scm and .go files at its root, re-bundle
    ;; it so that it has share/guile/site and lib/guile, which is what
    ;; 'whole-package' expects.
    (computed-file (derivation-name modules)
                   (with-imported-modules '((guix build utils))
                     #~(begin
                         (use-modules (guix build utils))

                         (define version
                           (effective-version))
                         (define share
                           (string-append #$output "/share/guile/site"))
                         (define lib
                           (string-append #$output "/lib/guile/" version))

                         (mkdir-p share) (mkdir-p lib)
                         (symlink #$modules (string-append share "/" version))
                         (symlink #$modules (string-append lib "/site-ccache"))))))

  (letrec-syntax ((list (syntax-rules (->)
                          ((_)
                           '())
                          ((_ (module -> variable) rest ...)
                           (cons (module-ref (resolve-interface
                                              '(gnu packages module))
                                             'variable)
                                 (list rest ...)))
                          ((_ variable rest ...)
                           (cons (module-ref packages 'variable)
                                 (list rest ...))))))
    (whole-package name modules+compiled

                   ;; In the "old style", %SELF-BUILD-FILE would simply return a
                   ;; derivation that builds modules.  We have to infer what the
                   ;; dependencies of these modules were.
                   (list guile-json-3 guile-git guile-bytestructures
                         (ssh -> guile-ssh) (tls -> gnutls))
                   #:guile (default-guile))))

(define (old-style-guix? drv)
  "Return true if DRV corresponds to a ~/.config/guix/latest style of
derivation."
  ;; Here we rely on a gross historical fact: that derivations produced by the
  ;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8,
  ;; dated May 30, 2018) did not depend on "guix-command.drv".
  (not (find (lambda (input)
               (string=? "guix-command"
                         (derivation-name
                          (derivation-input-derivation input))))
             (derivation-inputs drv))))

(define (channel-instance->sexp instance)
  "Return an sexp representation of INSTANCE, a channel instance."
  (let* ((commit  (channel-instance-commit instance))
         (channel (channel-instance-channel instance))
         (intro   (channel-introduction channel)))
    `(repository
      (version 0)
      (url ,(channel-url channel))
      (branch ,(channel-branch channel))
      (commit ,commit)
      (name ,(channel-name channel))
      ,@(if intro
            `((introduction
               (channel-introduction
                (version 0)
                (commit
                 ,(channel-introduction-first-signed-commit
                   intro))
                (signer
                 ,(openpgp-format-fingerprint
                   (channel-introduction-first-commit-signer
                    intro))))))
            '()))))

(define* (channel-instances->manifest instances #:key system)
  "Return a profile manifest with entries for all of INSTANCES, a list of
channel instances.  By default, build for the current system, or SYSTEM if
specified."
  (define (instance->entry instance drv)
    (let ((commit  (channel-instance-commit instance))
          (channel (channel-instance-channel instance)))
      (manifest-entry
        (name (symbol->string (channel-name channel)))
        (version (string-take commit 7))
        (item (if (guix-channel? channel)
                  (if (old-style-guix? drv)
                      (whole-package-for-legacy (string-append name "-" version)
                                                drv)
                      drv)
                  drv))
        (properties
         `((source ,(channel-instance->sexp instance)))))))

  (mlet* %store-monad ((derivations (channel-instance-derivations instances
                                                                  #:system system))
                       (entries ->  (map instance->entry instances derivations)))
    (return (manifest entries))))

(define (package-cache-file manifest)
  "Build a package cache file for the instance in MANIFEST.  This is meant to
be used as a profile hook."
  (let ((profile (profile (content manifest) (hooks '()))))
    (define build
      #~(begin
          (use-modules (gnu packages))

          (if (defined? 'generate-package-cache)
              (begin
                ;; Delegate package cache generation to the inferior.
                (format (current-error-port)
                        "Generating package cache for '~a'...~%"
                        #$profile)
                (generate-package-cache #$output))
              (mkdir #$output))))

    (gexp->derivation-in-inferior "guix-package-cache" build
                                  profile

                                  ;; If the Guix in PROFILE is too old and
                                  ;; lacks 'guix repl', don't build the cache
                                  ;; instead of failing.
                                  #:silent-failure? #t

                                  #:properties '((type . profile-hook)
                                                 (hook . package-cache))
                                  #:local-build? #t)))

(define %channel-profile-hooks
  ;; The default channel profile hooks.
  (cons package-cache-file %default-profile-hooks))

(define (channel-instances->derivation instances)
  "Return the derivation of the profile containing INSTANCES, a list of
channel instances."
  (mlet %store-monad ((manifest (channel-instances->manifest instances)))
    (profile-derivation manifest
                        #:hooks %channel-profile-hooks)))

(define latest-channel-instances*
  (store-lift latest-channel-instances))

(define* (latest-channel-derivation #:optional (channels %default-channels)
                                    #:key
                                    (current-channels '())
                                    (validate-pull
                                     ensure-forward-channel-update))
  "Return as a monadic value the derivation that builds the profile for the
latest instances of CHANNELS.  CURRENT-CHANNELS and VALIDATE-PULL are passed
to 'latest-channel-instances'."
  (mlet %store-monad ((instances
                       (latest-channel-instances* channels
                                                  #:current-channels
                                                  current-channels
                                                  #:validate-pull
                                                  validate-pull)))
    (channel-instances->derivation instances)))

(define* (sexp->channel sexp #:optional (name 'channel))
  "Read SEXP, a provenance sexp as created by 'channel-instance->sexp'; use
NAME as the channel name if SEXP does not specify it.  Return #f if the sexp
does not have the expected structure."
  (match sexp
    (('repository ('version 0)
                  ('url url)
                  ('branch branch)
                  ('commit commit)
                  rest ...)
     ;; Historically channel sexps did not include the channel name.  It's OK
     ;; for channels created by 'channel-instances->manifest' because the
     ;; entry name is the channel name, but it was missing for entries created
     ;; by 'manifest-entry-with-provenance'.
     (channel (name (match (assq 'name rest)
                      (#f name)
                      (('name name) name)))
              (url url)
              (branch branch)
              (commit commit)
              (introduction
               (match (assq 'introduction rest)
                 (#f #f)
                 (('introduction intro)
                  (sexp->channel-introduction intro))))))

    (_ #f)))

(define (manifest-entry-channel entry)
  "Return the channel ENTRY corresponds to, or #f if that information is
missing or unreadable.  ENTRY must be an entry created by
'channel-instances->manifest', with the 'source' property."
  (let ((name (string->symbol (manifest-entry-name entry))))
    (match (assq-ref (manifest-entry-properties entry) 'source)
      ((sexp)
       (sexp->channel sexp name))
      (_
       ;; No channel information for this manifest entry.
       ;; XXX: Pre-0.15.0 Guix did not provide that information,
       ;; but there's not much we can do in that case.
       #f))))

(define (profile-channels profile)
  "Return the list of channels corresponding to entries in PROFILE.  If
PROFILE is not a profile created by 'guix pull', return the empty list."
  (filter-map manifest-entry-channel
              ;; Show most recently installed packages last.
              (reverse
               (manifest-entries (profile-manifest profile)))))

(define* (channel->code channel #:key (include-introduction? #t))
  "Return code (an sexp) to build CHANNEL.  When INCLUDE-INTRODUCTION? is
true, include its introduction, if any."
  (let ((intro (and include-introduction?
                    (channel-introduction channel))))
    `(channel
      (name ',(channel-name channel))
      (url ,(channel-url channel))
      (commit ,(channel-commit channel))
      ,@(if intro
            `((introduction (make-channel-introduction
                             ,(channel-introduction-first-signed-commit intro)
                             (openpgp-fingerprint
                              ,(openpgp-format-fingerprint
                                (channel-introduction-first-commit-signer
                                 intro))))))
            '()))))

;;;
;;; News.
;;;

;; Channel news.
(define-record-type <channel-news>
  (channel-news entries)
  channel-news?
  (entries channel-news-entries))                 ;list of <channel-news-entry>

;; News entry, associated with a specific commit of the channel.
(define-record-type <channel-news-entry>
  (channel-news-entry commit tag title body)
  channel-news-entry?
  (commit  channel-news-entry-commit)             ;hex string | #f
  (tag     channel-news-entry-tag)                ;#f | string
  (title   channel-news-entry-title)              ;list of language tag/string pairs
  (body    channel-news-entry-body))              ;list of language tag/string pairs

(define (sexp->channel-news-entry entry)
  "Return the <channel-news-entry> record corresponding to ENTRY, an sexp."
  (define (pair language message)
    (cons (symbol->string language) message))

  (match entry
    (('entry ((and (or 'commit 'tag) type) commit-or-tag)
             ('title ((? symbol? title-tags) (? string? titles)) ...)
             ('body ((? symbol? body-tags) (? string? bodies)) ...)
             _ ...)
     (channel-news-entry (and (eq? type 'commit) commit-or-tag)
                         (and (eq? type 'tag) commit-or-tag)
                         (map pair title-tags titles)
                         (map pair body-tags bodies)))
    (_
     (raise (condition
             (&message (message "invalid channel news entry"))
             (&error-location
              (location (source-properties->location
                         (source-properties entry)))))))))

(define (read-channel-news port)
  "Read a channel news feed from PORT and return it as a <channel-news>
record."
  (match (false-if-exception (read port))
    (('channel-news ('version 0) entries ...)
     (channel-news (map sexp->channel-news-entry entries)))
    (('channel-news ('version version) _ ...)
     ;; This is an unsupported version from the future.  There's nothing wrong
     ;; with that (the user may simply need to upgrade the 'guix' channel to
     ;; be able to read it), so silently ignore it.
     (channel-news '()))
    (#f
     (raise (condition
             (&message (message "syntactically invalid channel news file")))))
    (sexp
     (raise (condition
             (&message (message "invalid channel news file"))
             (&error-location
              (location (source-properties->location
                         (source-properties sexp)))))))))

(define (resolve-channel-news-entry-tag repository entry)
  "If ENTRY has its 'commit' field set, return ENTRY.  Otherwise, lookup
ENTRY's 'tag' in REPOSITORY and return ENTRY with its 'commit' field set to
the field its 'tag' refers to.  A 'git-error' exception is raised if the tag
cannot be found."
  (if (channel-news-entry-commit entry)
      entry
      (let* ((tag       (channel-news-entry-tag entry))
             (reference (string-append "refs/tags/" tag))
             (oid       (reference-name->oid repository reference)))
        (channel-news-entry (oid->string oid) tag
                            (channel-news-entry-title entry)
                            (channel-news-entry-body entry)))))

(define* (channel-news-for-commit channel new #:optional old)
  "Return a list of <channel-news-entry> for CHANNEL between commits OLD and
NEW.  When OLD is omitted or is #f, return all the news entries of CHANNEL."
  (catch 'git-error
    (lambda ()
      (let* ((checkout  (update-cached-checkout (channel-url channel)
                                                #:ref `(commit . ,new)))
             (metadata  (read-channel-metadata-from-source checkout))
             (news-file (channel-metadata-news-file metadata))
             (news-file (and news-file
                             (string-append checkout "/" news-file))))
        (if (and news-file (file-exists? news-file))
            (with-repository checkout repository
              (let* ((news    (call-with-input-file news-file
                                read-channel-news))
                     (entries (map (lambda (entry)
                                     (resolve-channel-news-entry-tag repository
                                                                     entry))
                                   (channel-news-entries news))))
                (if old
                    (let* ((new     (commit-lookup repository (string->oid new)))
                           (old     (commit-lookup repository (string->oid old)))
                           (commits (list->set
                                     (map (compose oid->string commit-id)
                                          (commit-difference new old)))))
                      (filter (lambda (entry)
                                (set-contains? commits
                                               (channel-news-entry-commit entry)))
                              entries))
                    entries)))
            '())))
    (lambda (key error . rest)
      ;; If commit NEW or commit OLD cannot be found, then something must be
      ;; wrong (for example, the history of CHANNEL was rewritten and these
      ;; commits no longer exist upstream), so quietly return the empty list.
      (if (= GIT_ENOTFOUND (git-error-code error))
          '()
          (apply throw key error rest)))))

;;; Local Variables:
;;; eval: (put 'with-guile 'scheme-indent-function 1)
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix ci)
  #:use-module (guix http-client)
  #:use-module (guix utils)
  #:use-module ((guix build download)
                #:select (resolve-uri-reference))
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (web uri)
  #:use-module (guix i18n)
  #:use-module (guix diagnostics)
  #:autoload   (guix channels) (channel)
  #:export (build-product?
            build-product-id
            build-product-type
            build-product-file-size
            build-product-path

            build?
            build-id
            build-derivation
            build-evaluation
            build-system
            build-status
            build-timestamp
            build-products

            checkout?
            checkout-commit
            checkout-channel

            evaluation?
            evaluation-id
            evaluation-spec
            evaluation-complete?
            evaluation-checkouts

            job?
            job-build-id
            job-status
            job-name

            %query-limit
            queued-builds
            latest-builds
            evaluation
            evaluation-jobs
            build
            job-build
            latest-evaluations
            evaluations-for-commit

            channel-with-substitutes-available))

;;; Commentary:
;;;
;;; This module provides a client to the HTTP interface of the Hydra and
;;; Cuirass continuous integration (CI) tools.
;;;
;;; Code:

(define-json-mapping <build-product> make-build-product
  build-product?
  json->build-product
  (id          build-product-id)                  ;integer
  (type        build-product-type)                ;string
  (file-size   build-product-file-size)           ;integer
  (path        build-product-path))               ;string

(define-syntax-rule (define-enumeration-mapping proc
                      (names integers) ...)
  (define (proc value)
    (match value
      (integers 'names) ...)))

(define-enumeration-mapping integer->build-status
  ;; Copied from 'build-status' in Cuirass.
  (submitted        -3)
  (scheduled        -2)
  (started          -1)
  (succeeded         0)
  (failed            1)
  (failed-dependency 2)
  (failed-other      3)
  (canceled          4))

(define-json-mapping <build> make-build build?
  json->build
  (id          build-id "id")                     ;integer
  (derivation  build-derivation)                  ;string | #f
  (evaluation  build-evaluation)                  ;integer
  (system      build-system)                      ;string
  (status      build-status "buildstatus"         ;symbol
               integer->build-status)
  (timestamp   build-timestamp)                   ;integer
  (products    build-products "buildproducts"     ;<build-product>*
               (lambda (products)
                 (map json->build-product
                      ;; Before Cuirass 3db603c1, #f is always returned.
                      (if (vector? products)
                          (vector->list products)
                          '())))))

(define-json-mapping <job> make-job job?
  json->job
  (build-id    job-build-id "build")              ;integer
  (status      job-status "status"                ;symbol
               integer->build-status)
  (name        job-name))                         ;string

(define-json-mapping <checkout> make-checkout checkout?
  json->checkout
  (commit      checkout-commit)                   ;string (SHA1)
  (channel     checkout-channel))                 ;string (name)

(define-json-mapping <evaluation> make-evaluation evaluation?
  json->evaluation
  (id          evaluation-id)                     ;integer
  (spec        evaluation-spec "specification")   ;string
  (complete?   evaluation-complete? "status"
               (match-lambda
                 (0 #t)
                 (_ #f)))                         ;Boolean
  (checkouts   evaluation-checkouts "checkouts"   ;<checkout>*
               (lambda (checkouts)
                 (map json->checkout
                      (vector->list checkouts)))))

(define %query-limit
  ;; Max number of builds requested in queries.
  1000)

(define* (api-url base-url path #:rest query)
  "Build a proper API url, taking into account BASE-URL's trailing slashes.
QUERY takes any number of '(\"name\" value) 2-element lists, with VALUE being
either a string or a number (which will be converted to a string).  If VALUE
is #f, the respective element will not be added to the query parameters.
Other types of VALUE will raise an error since this low-level function is
api-agnostic."

  (define (build-query-string query)
    (let lp ((query (or (reverse query) '())) (acc '()))
      (match query
        (() (string-concatenate acc))
        (((_ #f) . rest) (lp rest acc))
        (((name val) . rest)
         (lp rest (cons*
                   name "="
                   (if (string? val) (uri-encode val) (number->string val))
                   (if (null? acc) "" "&")
                   acc))))))

  (let* ((query-string (build-query-string query))
         (base (string->uri base-url))
         (ref (build-relative-ref #:path path #:query query-string)))
    (resolve-uri-reference ref base)))

(define (json-fetch url)
  (let* ((port (http-fetch url))
         (json (json->scm port)))
    (close-port port)
    json))

(define* (json-api-fetch base-url path #:rest query)
  (json-fetch (apply api-url base-url path query)))

(define* (queued-builds url #:optional (limit %query-limit))
  "Return the list of queued derivations on URL."
  (let ((queue
         (json-api-fetch url "/api/queue" `("nr" ,limit))))
    (map json->build (vector->list queue))))

(define* (latest-builds url #:optional (limit %query-limit)
                        #:key evaluation system job status)
  "Return the latest builds performed by the CI server at URL.  If EVALUATION
is an integer, restrict to builds of EVALUATION.  If SYSTEM is true (a system
string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
  (let ((latest (json-api-fetch
                 url "/api/latestbuilds"
                 `("nr" ,limit)
                 `("evaluation" ,evaluation)
                 `("system" ,system)
                 `("job" ,job)
                 `("status" ,status))))
    ;; Note: Hydra does not provide a "derivation" field for entries in
    ;; 'latestbuilds', but Cuirass does.
    (map json->build (vector->list latest))))

(define (evaluation url evaluation)
  "Return the given EVALUATION performed by the CI server at URL."
  (let ((evaluation
         (json-api-fetch url "/api/evaluation" `("id" ,evaluation))))
    (json->evaluation evaluation)))

(define* (latest-evaluations url
                             #:optional (limit %query-limit)
                             #:key spec)
  "Return the latest evaluations performed by the CI server at URL.  If SPEC
is passed, only consider the evaluations for the given SPEC specification."
  (map json->evaluation
       (vector->list
        (json-api-fetch
         url "/api/evaluations" `("nr" ,limit) `("spec" ,spec)))))

(define* (evaluations-for-commit url commit #:optional (limit %query-limit))
  "Return the evaluations among the latest LIMIT evaluations that have COMMIT
as one of their inputs."
  (filter (lambda (evaluation)
            (find (lambda (checkout)
                    (string=? (checkout-commit checkout) commit))
                  (evaluation-checkouts evaluation)))
          (latest-evaluations url limit)))

(define (evaluation-jobs url evaluation-id)
  "Return the list of jobs of evaluation EVALUATION-ID."
  (map json->job
       (vector->list
        (json-api-fetch url "/api/jobs" `("evaluation" ,evaluation-id)))))

(define (build url id)
  "Look up build ID at URL and return it.  Raise &http-get-error if it is not
found (404)."
  (json->build
   (http-fetch (api-url url (string-append "/build/"    ;note: no "/api" here
                                           (number->string id))))))

(define (job-build url job)
  "Return the build associated with JOB."
  (build url (job-build-id job)))

;; TODO: job history:
;; https://ci.guix.gnu.org/api/jobs/history?spec=master&names=coreutils.x86_64-linux&nr=10

(define (find-latest-commit-with-substitutes url)
  "Return the latest commit with available substitutes for the Guix package
definitions at URL.  Return false if no commit were found."
  (let* ((job-name (string-append "guix." (%current-system)))
         (build (match (latest-builds url 1
                                      #:job job-name
                                      #:status 0) ;success
                  ((build) build)
                  (_ #f)))
         (evaluation (and build
                          (evaluation url (build-evaluation build))))
         (commit (and evaluation
                      (match (evaluation-checkouts evaluation)
                        ((checkout)
                         (checkout-commit checkout))))))
    commit))

(define (channel-with-substitutes-available chan url)
  "Return a channel inheriting from CHAN but which commit field is set to the
latest commit with available substitutes for the Guix package definitions at
URL.  The current system is taken into account.

If no commit with available substitutes were found, the commit field is set to
false and a warning message is printed."
  (let ((commit (find-latest-commit-with-substitutes url)))
    (unless commit
      (warning (G_ "could not find available substitutes at ~a~%")
               url))
    (channel
     (inherit chan)
     (commit commit))))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Free Software Foundation, Inc.
;;; Copyright © 2018 Sahithi Yarlagadda <sahi@swecha.net>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix colors)
  #:use-module (guix memoization)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:export (color
            color?

            colorize-string
            highlight
            dim

            color-rules
            color-output?
            isatty?*))

;;; Commentary:
;;;
;;; This module provides tools to produce colored output using ANSI escapes.
;;;
;;; Code:

;; Record type for "colors", which are actually lists of color attributes.
(define-record-type <color>
  (make-color symbols ansi)
  color?
  (symbols  color-symbols)
  (ansi     color-ansi))

(define (print-color color port)
  (format port "#<color ~a>"
          (string-join (map symbol->string
                            (color-symbols color)))))

(set-record-type-printer! <color> print-color)

(define-syntax define-color-table
  (syntax-rules ()
    "Define NAME as a macro that builds a list of color attributes."
    ((_ name (color escape) ...)
     (begin
       (define-syntax color-codes
         (syntax-rules (color ...)
           ((_)
            '())
           ((_ color rest (... ...))
            `(escape ,@(color-codes rest (... ...))))
           ...))

       (define-syntax-rule (name colors (... ...))
         "Return a list of color attributes that can be passed to
'colorize-string'."
         (make-color '(colors (... ...))
                     (color-codes->ansi (color-codes colors (... ...)))))))))

(define-color-table color
  (CLEAR        "0")
  (RESET        "0")
  (BOLD         "1")
  (DARK         "2")
  (UNDERLINE    "4")
  (UNDERSCORE   "4")
  (BLINK        "5")
  (REVERSE      "6")
  (CONCEALED    "8")
  (BLACK       "30")
  (RED         "31")
  (GREEN       "32")
  (YELLOW      "33")
  (BLUE        "34")
  (MAGENTA     "35")
  (CYAN        "36")
  (WHITE       "37")
  (ON-BLACK    "40")
  (ON-RED      "41")
  (ON-GREEN    "42")
  (ON-YELLOW   "43")
  (ON-BLUE     "44")
  (ON-MAGENTA  "45")
  (ON-CYAN     "46")
  (ON-WHITE    "47"))

(define (color-codes->ansi codes)
  "Convert CODES, a list of color attribute codes, to a ANSI escape string."
  (match codes
    (()
     "")
    (_
     (string-append (string #\esc #\[)
                    (string-join codes ";" 'infix)
                    "m"))))

(define %reset
  (color RESET))

(define (colorize-string str color)
  "Return a copy of STR colorized using ANSI escape sequences according to
COLOR.  At the end of the returned string, the color attributes are reset such
that subsequent output will not have any colors in effect."
  (string-append (color-ansi color)
                 str
                 (color-ansi %reset)))

(define isatty?*
  (mlambdaq (port)
    "Return true if PORT is a tty.  Memoize the result."
    (isatty? port)))

(define (color-output? port)
  "Return true if we should write colored output to PORT."
  (and (not (getenv "NO_COLOR"))
       (isatty?* port)))

(define (coloring-procedure color)
  "Return a procedure that applies COLOR to the given string."
  (lambda* (str #:optional (port (current-output-port)))
    "Return STR with extra ANSI color attributes if PORT supports it."
    (if (color-output? port)
        (colorize-string str color)
        str)))

(define highlight (coloring-procedure (color BOLD)))
(define dim (coloring-procedure (color DARK)))

(define (colorize-matches rules)
  "Return a procedure that, when passed a string, returns that string
colorized according to RULES.  RULES must be a list of tuples like:

  (REGEXP COLOR1 COLOR2 ...)

where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
on."
  (lambda (str)
    (if (string-index str #\nul)
        str
        (let loop ((rules rules))
          (match rules
            (()
             str)
            (((regexp . colors) . rest)
             (match (regexp-exec regexp str)
               (#f (loop rest))
               (m  (let loop ((n 1)
                              (colors colors)
                              (result (list (match:prefix m))))
                     (match colors
                       (()
                        (string-concatenate-reverse
                         (cons (match:suffix m) result)))
                       ((first . tail)
                        (loop (+ n 1)
                              tail
                              (cons (colorize-string (match:substring m n)
                                                     first)
                                    result)))))))))))))

(define-syntax color-rules
  (syntax-rules ()
    "Return a procedure that colorizes the string it is passed according to
the given rules.  Each rule has the form:

  (REGEXP COLOR1 COLOR2 ...)

where COLOR1 specifies how to colorize the first submatch of REGEXP, and so
on."
    ((_ (regexp colors ...) ...)
     (colorize-matches `((,(make-regexp regexp) ,(color colors) ...)
                         ...)))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix combinators)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:export (fold2
            fold-tree
            fold-tree-leaves
            compile-time-value))

;;; Commentary:
;;;
;;; This module provides useful combinators that complement SRFI-1 and
;;; friends.
;;;
;;; Code:

(define fold2
  (case-lambda
    ((proc seed1 seed2 lst)
     "Like `fold', but with a single list and two seeds."
     (let loop ((result1 seed1)
                (result2 seed2)
                (lst     lst))
       (if (null? lst)
           (values result1 result2)
           (call-with-values
               (lambda () (proc (car lst) result1 result2))
             (lambda (result1 result2)
               (loop result1 result2 (cdr lst)))))))
    ((proc seed1 seed2 lst1 lst2)
     "Like `fold', but with two lists and two seeds."
     (let loop ((result1 seed1)
                (result2 seed2)
                (lst1    lst1)
                (lst2    lst2))
       (if (or (null? lst1) (null? lst2))
           (values result1 result2)
           (call-with-values
               (lambda () (proc (car lst1) (car lst2) result1 result2))
             (lambda (result1 result2)
               (loop result1 result2 (cdr lst1) (cdr lst2)))))))))

(define (fold-tree proc init children roots)
  "Call (PROC NODE RESULT) for each node in the tree that is reachable from
ROOTS, using INIT as the initial value of RESULT.  The order in which nodes
are traversed is not specified, however, each node is visited only once, based
on an eq? check.  Children of a node to be visited are generated by
calling (CHILDREN NODE), the result of which should be a list of nodes that
are connected to NODE in the tree, or '() or #f if NODE is a leaf node."
  (let loop ((result init)
             (seen vlist-null)
             (lst roots))
    (match lst
      (() result)
      ((head . tail)
       (if (not (vhash-assq head seen))
           (loop (proc head result)
                 (vhash-consq head #t seen)
                 (match (children head)
                   ((or () #f) tail)
                   (children (append tail children))))
           (loop result seen tail))))))

(define (fold-tree-leaves proc init children roots)
  "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes."
  (fold-tree
   (lambda (node result)
     (match (children node)
       ((or () #f) (proc node result))
       (else result)))
   init children roots))

(define-syntax compile-time-value                 ;not quite at home
  (syntax-rules ()
    "Evaluate the given expression at compile time.  The expression must
evaluate to a simple datum."
    ((_ exp)
     (let-syntax ((v (lambda (s)
                       (let ((val exp))
                         (syntax-case s ()
                           (_ #`'#,(datum->syntax s val)))))))
       v))))

;;; combinators.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix config)
  #:export (%guix-package-name
            %guix-version
            %guix-bug-report-address
            %guix-home-page-url

            %channel-metadata

            %storedir
            %localstatedir
            %sysconfdir

            %store-directory
            %state-directory
            %store-database-directory
            %config-directory

            %system
            %gzip
            %bzip2
            %xz))

;;; Commentary:
;;;
;;; Compile-time configuration of Guix.  When adding a substitution variable
;;; here, make sure to equip (guix scripts pull) to substitute it.
;;;
;;; Code:

(define %guix-package-name
  "@PACKAGE_NAME@")

(define %guix-version
  "@PACKAGE_VERSION@")

(define %guix-bug-report-address
  "@PACKAGE_BUGREPORT@")

(define %guix-home-page-url
  "@PACKAGE_URL@")

(define %channel-metadata
  ;; When true, this is an sexp containing metadata for the 'guix' channel
  ;; this file was built from.  This is used by (guix describe).
  (let ((url    @GUIX_CHANNEL_URL@)
        (commit @GUIX_CHANNEL_COMMIT@)
        (intro  @GUIX_CHANNEL_INTRODUCTION@))
    (and url commit
         `(repository
           (version 0)
           (url ,url)
           (branch "master")                      ;XXX: doesn't really matter
           (commit ,commit)
           (name guix)
           ,@(if intro
                 `((introduction
                    (channel-introduction
                     (version 0)
                     (commit ,(car intro))
                     (signer ,(cdr intro)))))
                 '())))))

(define %storedir
  "@storedir@")

(define %localstatedir
  "@guix_localstatedir@")

(define %sysconfdir
  "@guix_sysconfdir@")

(define %store-directory
  (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path)
      %storedir))

(define %state-directory
  ;; This must match `NIX_STATE_DIR' as defined in `nix/local.mk'.
  (or (getenv "GUIX_STATE_DIRECTORY")
      (string-append %localstatedir "/guix")))

(define %store-database-directory
  (or (getenv "GUIX_DATABASE_DIRECTORY")
      (string-append %state-directory "/db")))

(define %config-directory
  ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as defined in `nix/local.mk'.
  (or (getenv "GUIX_CONFIGURATION_DIRECTORY")
      (string-append %sysconfdir "/guix")))

(define %system
  "@guix_system@")

(define %gzip
  "@GZIP@")

(define %bzip2
  "@BZIP2@")

(define %xz
  "@XZ@")

;;; config.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix cpio)
  #:use-module ((guix build utils) #:select (dump-port))
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 match)
  #:export (cpio-header?
            make-cpio-header
            file->cpio-header
            file->cpio-header*
            special-file->cpio-header*
            write-cpio-header
            read-cpio-header

            write-cpio-archive))

;;; Commentary:
;;;
;;; This module implements the cpio "new ASCII" format, bit-for-bit identical
;;; to GNU cpio with the '-H newc' option.
;;;
;;; Code:

;; Values for 'mode', OR'd together.

(define C_IRUSR #o000400)
(define C_IWUSR #o000200)
(define C_IXUSR #o000100)
(define C_IRGRP #o000040)
(define C_IWGRP #o000020)
(define C_IXGRP #o000010)
(define C_IROTH #o000004)
(define C_IWOTH #o000002)
(define C_IXOTH #o000001)

(define C_ISUID #o004000)
(define C_ISGID #o002000)
(define C_ISVTX #o001000)

(define C_FMT   #o170000)                         ;bit mask
(define C_ISBLK #o060000)
(define C_ISCHR #o020000)
(define C_ISDIR #o040000)
(define C_ISFIFO #o010000)
(define C_ISSOCK #o0140000)
(define C_ISLNK #o0120000)
(define C_ISCTG #o0110000)
(define C_ISREG #o0100000)

(define MAGIC
  ;; The "new" portable format with ASCII header, as produced by GNU cpio with
  ;; '-H newc'.
  (string->number "070701" 16))

(define (read-header-field size port)
  (string->number (get-string-n port size) 16))

(define (write-header-field value size port)
  (put-bytevector port
                  (string->utf8
                   (string-pad (string-upcase (number->string value 16))
                               size #\0))))

(define-syntax define-pack
  (syntax-rules ()
    ((_ type ctor pred write read (field-names field-sizes field-getters) ...)
     (begin
       (define-record-type type
         (ctor field-names ...)
         pred
         (field-names field-getters) ...)

       (define (read port)
         (set-port-encoding! port "ISO-8859-1")
         (ctor (read-header-field field-sizes port)
               ...))

       (define (write obj port)
         (let* ((size (+ field-sizes ...)))
           (match obj
             (($ type field-names ...)
              (write-header-field field-names field-sizes port)
              ...))))))))

;; cpio header in "new ASCII" format, without checksum.
(define-pack <cpio-header>
  %make-cpio-header cpio-header?
  write-cpio-header read-cpio-header
  (magic     6  cpio-header-magic)
  (ino       8  cpio-header-inode)
  (mode      8  cpio-header-mode)
  (uid       8  cpio-header-uid)
  (gid       8  cpio-header-gid)
  (nlink     8  cpio-header-nlink)
  (mtime     8  cpio-header-mtime)
  (file-size 8  cpio-header-file-size)
  (dev-maj   8  cpio-header-device-major)
  (dev-min   8  cpio-header-device-minor)
  (rdev-maj  8  cpio-header-rdevice-major)
  (rdev-min  8  cpio-header-rdevice-minor)
  (name-size 8  cpio-header-name-size)
  (checksum  8  cpio-header-checksum))            ;0 for "newc" format

(define* (make-cpio-header #:key
                           (inode 0)
                           (mode (logior C_ISREG C_IRUSR))
                           (uid 0) (gid 0)
                           (nlink 1) (mtime 0) (size 0)
                           (dev 0) (rdev 0) (name-size 0))
  "Return a new cpio file header."
  (let-values (((major minor)   (device->major+minor dev))
               ((rmajor rminor) (device->major+minor rdev)))
    (%make-cpio-header MAGIC
                       inode mode uid gid
                       nlink mtime
                       (if (or (= C_ISLNK (logand mode C_FMT))
                               (= C_ISREG (logand mode C_FMT)))
                           size
                           0)
                       major minor rmajor rminor
                       (+ name-size 1)              ;include trailing zero
                       0)))                          ;checksum

(define (mode->type mode)
  "Given the number MODE, return a symbol representing the kind of file MODE
denotes, similar to 'stat:type'."
  (let ((fmt (logand mode C_FMT)))
    (cond ((= C_ISREG fmt) 'regular)
          ((= C_ISDIR fmt) 'directory)
          ((= C_ISLNK fmt) 'symlink)
          ((= C_ISBLK fmt) 'block-special)
          ((= C_ISCHR fmt) 'char-special)
          (else
           (error "unsupported file type" mode)))))

(define (device-number major minor)     ; see glibc's <sys/sysmacros.h>
  "Return the device number for the device with MAJOR and MINOR, for use as
the last argument of `mknod'."
  (logior (ash (logand #x00000fff major) 8)
          (ash (logand #xfffff000 major) 32)
               (logand #x000000ff minor)
          (ash (logand #xffffff00 minor) 12)))

(define (device->major+minor device)     ; see glibc's <sys/sysmacros.h>
  "Return two values: the major and minor device numbers that make up DEVICE."
  (values (logior (ash (logand #x00000000000fff00 device) -8)
                  (ash (logand #xfffff00000000000 device) -32))
          (logior      (logand #x00000000000000ff device)
                  (ash (logand #x00000ffffff00000 device) -12))))

(define* (file->cpio-header file #:optional (file-name file)
                            #:key (stat lstat))
  "Return a cpio header corresponding to the info returned by STAT for FILE,
using FILE-NAME as its file name."
  (let ((st (stat file)))
    (make-cpio-header #:inode (stat:ino st)
                      #:mode (stat:mode st)
                      #:uid (stat:uid st)
                      #:gid (stat:gid st)
                      #:nlink (stat:nlink st)
                      #:mtime (stat:mtime st)
                      #:size (stat:size st)
                      #:dev (stat:dev st)
                      #:rdev (stat:rdev st)
                      #:name-size (string-length file-name))))

(define* (file->cpio-header* file
                             #:optional (file-name file)
                             #:key (stat lstat))
  "Similar to 'file->cpio-header', but return a header with a zeroed
modification time, inode number, UID/GID, etc.  This allows archives to be
produced in a deterministic fashion."
  (let ((st (stat file)))
    (make-cpio-header #:mode (stat:mode st)
                      #:nlink (stat:nlink st)
                      #:size (stat:size st)
                      #:name-size (string-length file-name))))

(define* (special-file->cpio-header* file
                                     device-type
                                     device-major
                                     device-minor
                                     permission-bits
                                     #:optional (file-name file))
  "Create a character or block device header.

DEVICE-TYPE is either 'char-special or 'block-special.

The number of hard links is assumed to be 1."
  (make-cpio-header #:mode (logior (match device-type
                                    ('block-special C_ISBLK)
                                    ('char-special C_ISCHR))
                                    permission-bits)
                    #:nlink 1
                    #:rdev (device-number device-major device-minor)
                    #:name-size (string-length file-name)))

(define %trailer
  "TRAILER!!!")

(define %last-header
  ;; The header that marks the end of the archive.
  (make-cpio-header #:mode 0
                    #:name-size (string-length %trailer)))

(define* (write-cpio-archive files port
                             #:key (file->header file->cpio-header))
  "Write to PORT a cpio archive in \"new ASCII\" format containing all of FILES.

The archive written to PORT is intended to be bit-identical to what GNU cpio
produces with the '-H newc' option."
  (define (write-padding offset port)
    (let ((padding (modulo (- 4 (modulo offset 4)) 4)))
      (put-bytevector port (make-bytevector padding))))

  (define (pad-block port)
    ;; Write padding to PORT such that we finish with a 512-byte block.
    ;; XXX: We rely on PORT's internal state, assuming it's a file port.
    (let* ((offset  (seek port 0 SEEK_CUR))
           (padding (modulo (- 512 (modulo offset 512)) 512)))
      (put-bytevector port (make-bytevector padding))))

  (define (dump-file file)
    (let* ((header (file->header file))
           (size   (cpio-header-file-size header)))
      (write-cpio-header header port)
      (put-bytevector port (string->utf8 file))
      (put-u8 port 0)

      ;; We're padding the header + following file name + trailing zero, and
      ;; the header is 110 byte long.
      (write-padding (+ 110 1 (string-length file)) port)

      (case (mode->type (cpio-header-mode header))
        ((regular)
         (call-with-input-file file
           (lambda (input)
             (dump-port input port))))
        ((symlink)
         (let ((target (readlink file)))
           (put-string port target)))
        ((directory)
         #t)
        ((block-special)
         #t)
        ((char-special)
         #t)
        (else
         (error "file type not supported")))

      ;; Pad the file content.
      (write-padding size port)))

  (set-port-encoding! port "ISO-8859-1")

  (for-each dump-file files)

  (write-cpio-header %last-header port)
  (put-bytevector port (string->utf8 %trailer))
  (write-padding (string-length %trailer) port)

  ;; Pad so the last block is 512-byte long.
  (pad-block port))

;;; cpio.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix cve)
  #:use-module (guix utils)
  #:use-module (guix http-client)
  #:use-module (guix i18n)
  #:use-module ((guix diagnostics) #:select (formatted-message))
  #:use-module (json)
  #:use-module (web uri)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 vlist)
  #:export (json->cve-items

            cve-item?
            cve-item-cve
            cve-item-configurations
            cve-item-published-date
            cve-item-last-modified-date

            cve?
            cve-id
            cve-data-type
            cve-data-format
            cve-references

            cve-reference?
            cve-reference-url
            cve-reference-tags

            vulnerability?
            vulnerability-id
            vulnerability-packages

            json->vulnerabilities
            current-vulnerabilities
            vulnerabilities->lookup-proc))

;;; Commentary:
;;;
;;; This modules provides the tools to fetch, parse, and digest part of the
;;; Common Vulnerabilities and Exposures (CVE) feeds provided by the US NIST
;;; at <https://nvd.nist.gov/vuln/data-feeds>.
;;;
;;; Code:

(define (string->date* str)
  (string->date str "~Y-~m-~dT~H:~M~z"))

(define-json-mapping <cve-item> cve-item cve-item?
  json->cve-item
  (cve            cve-item-cve "cve" json->cve)   ;<cve>
  (configurations cve-item-configurations         ;list of sexps
                  "configurations" configuration-data->cve-configurations)
  (published-date cve-item-published-date
                  "publishedDate" string->date*)
  (last-modified-date cve-item-last-modified-date
                      "lastModifiedDate" string->date*))

(define-json-mapping <cve> cve cve?
  json->cve
  (id             cve-id "CVE_data_meta"          ;string
                  (cut assoc-ref <> "ID"))
  (data-type      cve-data-type                   ;'CVE
                  "data_type" string->symbol)
  (data-format    cve-data-format                 ;'MITRE
                  "data_format" string->symbol)
  (references     cve-references                  ;list of <cve-reference>
                  "references" reference-data->cve-references))

(define-json-mapping <cve-reference> cve-reference cve-reference?
  json->cve-reference
  (url            cve-reference-url)              ;string
  (tags           cve-reference-tags              ;list of strings
                  "tags" vector->list))

(define (reference-data->cve-references alist)
  (map json->cve-reference
       ;; Normally "reference_data" is always present but rejected CVEs such
       ;; as CVE-2020-10020 can lack it.
       (vector->list (or (assoc-ref alist "reference_data") '#()))))

(define %cpe-package-rx
  ;; For applications: "cpe:2.3:a:VENDOR:PACKAGE:VERSION", or sometimes
  ;; "cpe:2.3:a:VENDOR:PACKAGE:VERSION:PATCH-LEVEL".
  (make-regexp "^cpe:2\\.3:a:([^:]+):([^:]+):([^:]+):([^:]+):"))

(define (cpe->package-name cpe)
  "Converts the Common Platform Enumeration (CPE) string CPE to a package
name, in a very naive way.  Return two values: the package name, and its
version string.  Return #f and #f if CPE does not look like an application CPE
string."
  (cond ((regexp-exec %cpe-package-rx cpe)
         =>
         (lambda (matches)
           (values (match:substring matches 2)
                   (match (match:substring matches 3)
                     ("*" '_)
                     (version
                      (string-append version
                                     (match (match:substring matches 4)
                                       ("" "")
                                       (patch-level
                                        ;; Drop the colon from things like
                                        ;; "cpe:2.3:a:openbsd:openssh:6.8:p1".
                                        (string-drop patch-level 1)))))))))
        (else
         (values #f #f))))

(define (cpe-match->cve-configuration alist)
  "Convert ALIST, a \"cpe_match\" alist, into an sexp representing the package
and versions matched.  Return #f if ALIST doesn't correspond to an application
package."
  (let ((cpe    (assoc-ref alist "cpe23Uri"))
        (starti (assoc-ref alist "versionStartIncluding"))
        (starte (assoc-ref alist "versionStartExcluding"))
        (endi   (assoc-ref alist "versionEndIncluding"))
        (ende   (assoc-ref alist "versionEndExcluding")))
    ;; Normally "cpe23Uri" is here in each "cpe_match" item, but CVE-2020-0534
    ;; has a configuration that lacks it.
    (and cpe
         (let-values (((package version) (cpe->package-name cpe)))
           (and package
                `(,package
                   ,(cond ((and (or starti starte) (or endi ende))
                           `(and ,(if starti `(>= ,starti) `(> ,starte))
                                 ,(if endi `(<= ,endi) `(< ,ende))))
                          (starti `(>= ,starti))
                          (starte `(> ,starte))
                          (endi   `(<= ,endi))
                          (ende   `(< ,ende))
                          (else   version))))))))

(define (configuration-data->cve-configurations alist)
  "Given ALIST, a JSON dictionary for the baroque \"configurations\"
element found in CVEs, return an sexp such as (\"binutils\" (<
\"2.31\")) that represents matching configurations."
  (define string->operator
    (match-lambda
      ("OR" 'or)
      ("AND" 'and)))

  (define (node->configuration node)
    (let ((operator (string->operator (assoc-ref node "operator"))))
      (cond
       ((assoc-ref node "cpe_match")
        =>
        (lambda (matches)
          (let ((matches (vector->list matches)))
            (match (filter-map cpe-match->cve-configuration
                               matches)
              (()    #f)
              ((one) one)
              (lst   (cons operator lst))))))
       ((assoc-ref node "children")               ;typically for 'and'
        =>
        (lambda (children)
          (match (filter-map node->configuration (vector->list children))
            (()    #f)
            ((one) one)
            (lst   (cons operator lst)))))
       (else
        #f))))

  (let ((nodes (vector->list (assoc-ref alist "nodes"))))
    (filter-map node->configuration nodes)))

(define (json->cve-items json)
  "Parse JSON, an input port or a string, and return a list of <cve-item>
records."
  (let* ((alist   (json->scm json))
         (type    (assoc-ref alist "CVE_data_type"))
         (format  (assoc-ref alist "CVE_data_format"))
         (version (assoc-ref alist "CVE_data_version")))
    (unless (equal? type "CVE")
      (raise (condition (&message
                         (message "invalid CVE feed")))))
    (unless (equal? format "MITRE")
      (raise (formatted-message (G_ "unsupported CVE format: '~a'")
                                format)))
    (unless (equal? version "4.0")
      (raise (formatted-message (G_ "unsupported CVE data version: '~a'")
                                version)))

    (map json->cve-item
         (vector->list (assoc-ref alist "CVE_Items")))))

(define (version-matches? version sexp)
  "Return true if VERSION, a string, matches SEXP."
  (match sexp
    ('_
     #t)
    ((? string? expected)
     (version-prefix? expected version))
    (('or sexps ...)
     (any (cut version-matches? version <>) sexps))
    (('and sexps ...)
     (every (cut version-matches? version <>) sexps))
    (('< max)
     (version>? max version))
    (('<= max)
     (version>=? max version))
    (('> min)
     (version>? version min))
    (('>= min)
     (version>=? version min))))

;;;
;;; High-level interface.
;;;

(define %now
  (current-date))
(define %current-year
  (date-year %now))
(define %past-year
  (- %current-year 1))

(define (yearly-feed-uri year)
  "Return the URI for the CVE feed for YEAR."
  (string->uri
   (string-append "https://nvd.nist.gov/feeds/json/cve/1.1/nvdcve-1.1-"
                  (number->string year) ".json.gz")))

(define %current-year-ttl
  ;; According to <https://nvd.nist.gov/download.cfm#CVE_FEED>, feeds are
  ;; updated "approximately every two hours."
  (* 60 30))

(define %past-year-ttl
  ;; Update the previous year's database more and more infrequently.
  (* 3600 24 (date-month %now)))

(define-record-type <vulnerability>
  (vulnerability id packages)
  vulnerability?
  (id         vulnerability-id)             ;string
  (packages   vulnerability-packages))      ;((p1 sexp1) (p2 sexp2) ...)

(define vulnerability->sexp
  (match-lambda
    (($ <vulnerability> id packages)
     `(v ,id ,packages))))

(define sexp->vulnerability
  (match-lambda
    (('v id (packages ...))
     (vulnerability id packages))))

(define (cve-configuration->package-list config)
  "Parse CONFIG, a config sexp, and return a list of the form (P SEXP)
where P is a package name and SEXP expresses constraints on the matching
versions."
  (let loop ((config config)
             (packages '()))
    (match config
      (('or configs ...)
       (fold loop packages configs))
      (('and config _ ...)                        ;XXX
       (loop config packages))
      (((? string? package) '_)                   ;any version
       (cons `(,package _)
             (alist-delete package packages)))
      (((? string? package) sexp)
       (let ((previous (assoc-ref packages package)))
         (if previous
             (cons `(,package (or ,sexp ,@previous))
                   (alist-delete package packages))
             (cons `(,package ,sexp) packages)))))))

(define (merge-package-lists lst)
  "Merge the list in LST, each of which has the form (p sexp), where P
is the name of a package and SEXP is an sexp that constrains matching
versions."
  (fold (lambda (plist result)                    ;XXX: quadratic
          (fold (match-lambda*
                  (((package version) result)
                   (match (assoc-ref result package)
                     (#f
                      (cons `(,package ,version) result))
                     ((previous)
                      (cons `(,package (or ,version ,previous))
                            (alist-delete package result))))))
                result
                plist))
        '()
        lst))

(define (cve-item->vulnerability item)
  "Return a <vulnerability> corresponding to ITEM, a <cve-item> record;
return #f if ITEM does not list any configuration or if it does not list
any \"a\" (application) configuration."
  (let ((id (cve-id (cve-item-cve item))))
    (match (cve-item-configurations item)
      (()                                         ;no configurations
       #f)
      ((configs ...)
       (vulnerability id
                      (merge-package-lists
                       (map cve-configuration->package-list configs)))))))

(define (json->vulnerabilities json)
  "Parse JSON, an input port or a string, and return the list of
vulnerabilities found therein."
  (filter-map cve-item->vulnerability (json->cve-items json)))

(define (write-cache input cache)
  "Read vulnerabilities as gzipped JSON from INPUT, and write it as a compact
sexp to CACHE."
  (call-with-decompressed-port 'gzip input
    (lambda (input)
      (define vulns
        (json->vulnerabilities input))

      (write `(vulnerabilities
               1                                  ;format version
               ,(map vulnerability->sexp vulns))
             cache))))

(define* (fetch-vulnerabilities year ttl #:key (timeout 10))
  "Return the list of <vulnerability> for YEAR, assuming the on-disk cache has
the given TTL (fetch from the NIST web site when TTL has expired)."
  (define (cache-miss uri)
    (format (current-error-port) "fetching CVE database for ~a...~%" year))

  (define (read* port)
    ;; Disable read options to avoid populating the source property weak
    ;; table, which speeds things up, saves memory, and works around
    ;; <https://lists.gnu.org/archive/html/guile-devel/2017-09/msg00031.html>.
    (let ((options (read-options)))
      (dynamic-wind
        (lambda ()
          (read-disable 'positions))
        (lambda ()
          (read port))
        (lambda ()
          (read-options options)))))

  ;; Note: We used to keep the original JSON files in cache but parsing it
  ;; would take typically ~15s for a year of data.  Thus, we instead store a
  ;; summarized version thereof as an sexp, which can be parsed in 1s or so.
  (let* ((port (http-fetch/cached (yearly-feed-uri year)
                                  #:ttl ttl
                                  #:write-cache write-cache
                                  #:cache-miss cache-miss
                                  #:timeout timeout))
         (sexp (read* port)))
    (close-port port)
    (match sexp
      (('vulnerabilities 1 vulns)
       (map sexp->vulnerability vulns)))))

(define* (current-vulnerabilities #:key (timeout 10))
  "Return the current list of Common Vulnerabilities and Exposures (CVE) as
published by the US NIST.  TIMEOUT specifies the timeout in seconds for
connection establishment."
  (let ((past-years (unfold (cut > <> 3)
                            (lambda (n)
                              (- %current-year n))
                            1+
                            1))
        (past-ttls  (unfold (cut > <> 3)
                            (lambda (n)
                              (* n %past-year-ttl))
                            1+
                            1)))
    (append-map (cut fetch-vulnerabilities <> <> #:timeout timeout)
                (cons %current-year past-years)
                (cons %current-year-ttl past-ttls))))

(define (vulnerabilities->lookup-proc vulnerabilities)
  "Return a lookup procedure built from VULNERABILITIES that takes a package
name and optionally a version number.  When the version is omitted, the lookup
procedure returns a list of vulnerabilities; otherwise, it returns a list of
vulnerabilities affecting the given package version."
  (define table
    ;; Map package names to lists of version/vulnerability pairs.
    (fold (lambda (vuln table)
            (match vuln
              (($ <vulnerability> id packages)
               (fold (lambda (package table)
                       (match package
                         ((name . versions)
                          (vhash-cons name (cons vuln versions)
                                      table))))
                     table
                     packages))))
          vlist-null
          vulnerabilities))

  (lambda* (package #:optional version)
    (vhash-fold* (if version
                     (lambda (pair result)
                       (match pair
                         ((vuln sexp)
                          (if (version-matches? version sexp)
                              (cons vuln result)
                              result))))
                     (lambda (pair result)
                       (match pair
                         ((vuln . _)
                          (cons vuln result)))))
                 '()
                 package table)))

;;; cve.scm ends here