;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;;
;;; 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 narinfo)
  #:use-module (guix pki)
  #:use-module (guix i18n)
  #:use-module (guix base32)
  #:use-module (guix base64)
  #:use-module (guix records)
  #:use-module (guix diagnostics)
  #:use-module (gcrypt hash)
  #:use-module (gcrypt pk-crypto)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 binary-ports)
  #:use-module (web uri)
  #:export (narinfo-signature->canonical-sexp

            narinfo?
            narinfo-path
            narinfo-uris
            narinfo-uri-base
            narinfo-compressions
            narinfo-file-hashes
            narinfo-file-sizes
            narinfo-hash
            narinfo-size
            narinfo-references
            narinfo-deriver
            narinfo-system
            narinfo-signature
            narinfo-contents

            narinfo-hash-algorithm+value

            narinfo-hash->sha256
            narinfo-best-uri

            valid-narinfo?

            read-narinfo
            write-narinfo

            string->narinfo
            narinfo->string

            equivalent-narinfo?))

(define-record-type <narinfo>
  (%make-narinfo path uri-base uris compressions file-sizes file-hashes
                 nar-hash nar-size references deriver system
                 signature contents)
  narinfo?
  (path         narinfo-path)
  (uri-base     narinfo-uri-base)        ;URI of the cache it originates from
  (uris         narinfo-uris)            ;list of strings
  (compressions narinfo-compressions)    ;list of strings
  (file-sizes   narinfo-file-sizes)      ;list of (integers | #f)
  (file-hashes  narinfo-file-hashes)
  (nar-hash     narinfo-hash)
  (nar-size     narinfo-size)
  (references   narinfo-references)
  (deriver      narinfo-deriver)
  (system       narinfo-system)
  (signature    narinfo-signature)      ; canonical sexp
  ;; The original contents of a narinfo file.  This field is needed because we
  ;; want to preserve the exact textual representation for verification purposes.
  ;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
  ;; for more information.
  (contents     narinfo-contents))

(define (narinfo-hash-algorithm+value narinfo)
  "Return two values: the hash algorithm used by NARINFO and its value as a
bytevector."
  (match (string-tokenize (narinfo-hash narinfo)
                          (char-set-complement (char-set #\:)))
    ((algorithm base32)
     (values (lookup-hash-algorithm (string->symbol algorithm))
             (nix-base32-string->bytevector base32)))
    (_
     (raise (formatted-message
             (G_ "invalid narinfo hash: ~s") (narinfo-hash narinfo))))))

(define (narinfo-hash->sha256 hash)
  "If the string HASH denotes a sha256 hash, return it as a bytevector.
Otherwise return #f."
  (and (string-prefix? "sha256:" hash)
       (nix-base32-string->bytevector (string-drop hash 7))))

(define (narinfo-signature->canonical-sexp str)
  "Return the value of a narinfo's 'Signature' field as a canonical sexp."
  (match (string-split str #\;)
    ((version host-name sig)
     (let ((maybe-number (string->number version)))
       (cond ((not (number? maybe-number))
              (leave (G_ "signature version must be a number: ~s~%")
                     version))
             ;; Currently, there are no other versions.
             ((not (= 1 maybe-number))
              (leave (G_ "unsupported signature version: ~a~%")
                     maybe-number))
             (else
              (let ((signature (utf8->string (base64-decode sig))))
                (catch 'gcry-error
                  (lambda ()
                    (string->canonical-sexp signature))
                  (lambda (key proc err)
                    (leave (G_ "signature is not a valid \
s-expression: ~s~%")
                           signature))))))))
    (x
     (leave (G_ "invalid format of the signature field: ~a~%") x))))

(define (narinfo-maker str cache-url)
  "Return a narinfo constructor for narinfos originating from CACHE-URL.  STR
must contain the original contents of a narinfo file."
  (lambda (path urls compressions file-hashes file-sizes
                nar-hash nar-size references deriver system
                signature)
    "Return a new <narinfo> object."
    (define len (length urls))
    (%make-narinfo path cache-url
                   ;; Handle the case where URL is a relative URL.
                   (map (lambda (url)
                          (or (string->uri url)
                              (string->uri
                               (if (string-suffix? "/" cache-url)
                                   (string-append cache-url url)
                                   (string-append cache-url "/" url)))))
                        urls)
                   compressions
                   (match file-sizes
                     (()        (make-list len #f))
                     ((lst ...) (map string->number lst)))
                   (match file-hashes
                     (()        (make-list len #f))
                     ((lst ...) (map string->number lst)))
                   nar-hash
                   (and=> nar-size string->number)
                   (string-tokenize references)
                   (match deriver
                     ((or #f "") #f)
                     (_ deriver))
                   system
                   (false-if-exception
                    (and=> signature narinfo-signature->canonical-sexp))
                   str)))

(define fields->alist
  ;; The narinfo format is really just like recutils.
  recutils->alist)

(define* (read-narinfo port #:optional url
                       #:key size)
  "Read a narinfo from PORT.  If URL is true, it must be a string used to
build full URIs from relative URIs found while reading PORT.  When SIZE is
true, read at most SIZE bytes from PORT; otherwise, read as much as possible.

No authentication and authorization checks are performed here!"
  (let ((str (utf8->string (if size
                               (get-bytevector-n port size)
                               (get-bytevector-all port)))))
    (alist->record (call-with-input-string str fields->alist)
                   (narinfo-maker str url)
                   '("StorePath" "URL" "Compression"
                     "FileHash" "FileSize" "NarHash" "NarSize"
                     "References" "Deriver" "System"
                     "Signature")
                   '("URL" "Compression" "FileSize" "FileHash"))))

(define (narinfo-sha256 narinfo)
  "Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
'Signature' field."
  (define %mandatory-fields
    ;; List of fields that must be signed.  If they are not signed, the
    ;; narinfo is considered unsigned.
    '("StorePath" "NarHash" "References"))

  (let ((contents (narinfo-contents narinfo)))
    (match (string-contains contents "Signature:")
      (#f #f)
      (index
       (let* ((above-signature (string-take contents index))
              (signed-fields (match (call-with-input-string above-signature
                                      fields->alist)
                               (((fields . values) ...) fields))))
         (and (every (cut member <> signed-fields) %mandatory-fields)
              (sha256 (string->utf8 above-signature))))))))

(define* (valid-narinfo? narinfo #:optional (acl (current-acl))
                         #:key verbose?)
  "Return #t if NARINFO's signature is valid and made by one of the keys in
ACL."
  (let ((hash      (narinfo-sha256 narinfo))
        (signature (narinfo-signature narinfo))
        (uri       (uri->string (first (narinfo-uris narinfo)))))
    (and hash signature
         (signature-case (signature hash acl)
           (valid-signature #t)
           (invalid-signature
            (when verbose?
              (format (current-error-port)
                      "invalid signature for substitute at '~a'~%"
                      uri))
            #f)
           (hash-mismatch
            (when verbose?
              (format (current-error-port)
                      "hash mismatch for substitute at '~a'~%"
                      uri))
            #f)
           (unauthorized-key
            (when verbose?
              (format (current-error-port)
                      "substitute at '~a' is signed by an \
unauthorized party~%"
                      uri))
            #f)
           (corrupt-signature
            (when verbose?
              (format (current-error-port)
                      "corrupt signature for substitute at '~a'~%"
                      uri))
            #f)))))

(define (write-narinfo narinfo port)
  "Write NARINFO to PORT."
  (put-bytevector port (string->utf8 (narinfo-contents narinfo))))

(define (narinfo->string narinfo)
  "Return the external representation of NARINFO."
  (call-with-output-string (cut write-narinfo narinfo <>)))

(define (string->narinfo str cache-uri)
  "Return the narinfo represented by STR.  Assume CACHE-URI as the base URI of
the cache STR originates form."
  (call-with-input-string str (cut read-narinfo <> cache-uri)))

(define (equivalent-narinfo? narinfo1 narinfo2)
  "Return true if NARINFO1 and NARINFO2 are equivalent--i.e., if they describe
the same store item.  This ignores unnecessary metadata such as the Nar URL."
  (and (string=? (narinfo-hash narinfo1)
                 (narinfo-hash narinfo2))

       ;; The following is not needed if all we want is to download a valid
       ;; nar, but it's necessary if we want valid narinfo.
       (string=? (narinfo-path narinfo1)
                 (narinfo-path narinfo2))
       (equal? (narinfo-references narinfo1)
               (narinfo-references narinfo2))

       (= (narinfo-size narinfo1)
          (narinfo-size narinfo2))))

(define %compression-methods
  ;; Known compression methods and a thunk to determine whether they're
  ;; supported.  See 'decompressed-port' in (guix utils).
  `(("gzip"  . ,(const #t))
    ("lzip"  . ,(const #t))
    ("zstd"  . ,(lambda ()
                  (resolve-module '(zstd) #t #f #:ensure #f)))
    ("xz"    . ,(const #t))
    ("bzip2" . ,(const #t))
    ("none"  . ,(const #t))))

(define (supported-compression? compression)
  "Return true if COMPRESSION, a string, denotes a supported compression
method."
  (match (assoc-ref %compression-methods compression)
    (#f         #f)
    (supported? (supported?))))

(define (compresses-better? compression1 compression2)
  "Return true if COMPRESSION1 generally compresses better than COMPRESSION2;
this is a rough approximation."
  (match compression1
    ("none" #f)
    ("gzip" (string=? compression2 "none"))
    ("lzip" #t)
    (_      (or (string=? compression2 "none")
                (string=? compression2 "gzip")))))

(define (decompresses-faster? compression1 compression2)
  "Return true if COMPRESSION1 generally has a higher decompression throughput
than COMPRESSION2."
  (match compression1
    ("none" #t)
    ("zstd" #t)
    ("gzip" (string=? compression2 "lzip"))
    (_      #f)))

(define* (narinfo-best-uri narinfo #:key fast-decompression?)
  "Select the \"best\" URI to download NARINFO's nar, and return three values:
the URI, its compression method (a string), and the compressed file size.
When FAST-DECOMPRESSION? is true, prefer substitutes with faster
decompression (typically zstd) rather than substitutes with a higher
compression ratio (typically lzip)."
  (define choices
    (filter (match-lambda
              ((uri compression file-size)
               (supported-compression? compression)))
            (zip (narinfo-uris narinfo)
                 (narinfo-compressions narinfo)
                 (narinfo-file-sizes narinfo))))

  (define (file-size<? c1 c2)
    (match c1
      ((uri1 compression1 (? integer? file-size1))
       (match c2
         ((uri2 compression2 (? integer? file-size2))
          (< file-size1 file-size2))
         (_ #t)))
      ((uri compression1 #f)
       (match c2
         ((uri2 compression2 _)
          (compresses-better? compression1 compression2))))
      (_ #f)))                                    ;we can't tell

  (define (speed<? c1 c2)
    (match c1
      ((uri1 compression1 . _)
       (match c2
         ((uri2 compression2 . _)
          (decompresses-faster? compression2 compression1))))))

  (match (sort choices (if fast-decompression? (negate speed<?) file-size<?))
    (((uri compression file-size) _ ...)
     (values uri compression file-size))))