code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2017 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 monads)
  #:use-module ((system syntax)
                #:select (syntax-local-binding))
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:export (;; Monads.
            define-monad
            monad?
            monad-bind
            monad-return

            template-directory

            ;; Syntax.
            >>=
            return
            with-monad
            mlet
            mlet*
            mbegin
            mwhen
            munless
            lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
            listm
            foldm
            mapm
            sequence
            anym

            ;; Concrete monads.
            %identity-monad

            %state-monad
            state-return
            state-bind
            current-state
            set-current-state
            state-push
            state-pop
            run-with-state))

;;; Commentary:
;;;
;;; This module implements the general mechanism of monads, and provides in
;;; particular an instance of the "state" monad.  The API was inspired by that
;;; of Racket's "better-monads" module (see
;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>).
;;; The implementation and use case were influenced by Oleg Kysielov's
;;; "Monadic Programming in Scheme" (see
;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>).
;;;
;;; Code:

;; Record type for monads manipulated at run time.
(define-record-type <monad>
  (make-monad bind return)
  monad?
  (bind   monad-bind)
  (return monad-return))                         ; TODO: Add 'plus' and 'zero'

(define-syntax define-monad
  (lambda (s)
    "Define the monad under NAME, with the given bind and return methods."
    (define prefix (string->symbol "% "))
    (define (make-rtd-name name)
      (datum->syntax name
                     (symbol-append prefix (syntax->datum name) '-rtd)))

    (syntax-case s (bind return)
      ((_ name (bind b) (return r))
       (with-syntax ((rtd (make-rtd-name #'name)))
         #`(begin
             (define rtd
               ;; The record type, for use at run time.
               (make-monad b r))

             ;; Instantiate all the templates, specialized for this monad.
             (template-directory instantiations name)

             (define-syntax name
               ;; An "inlined record", for use at expansion time.  The goal is
               ;; to allow 'bind' and 'return' to be resolved at expansion
               ;; time, in the common case where the monad is accessed
               ;; directly as NAME.
               (lambda (s)
                 (syntax-case s (%bind %return)
                   ((_ %bind)   #'b)
                   ((_ %return) #'r)
                   (_           #'rtd))))))))))

;; Expansion- and run-time state of the template directory.  This needs to be
;; available at run time (and not just at expansion time) so we can
;; instantiate templates defined in other modules, or use instances defined
;; elsewhere.
(eval-when (load expand eval)
  ;; Mapping of syntax objects denoting the template to a pair containing (1)
  ;; the syntax object of the parameter over which it is templated, and (2)
  ;; the syntax of its body.
  (define-once %templates (make-hash-table))

  (define (register-template! name param body)
    (hash-set! %templates name (cons param body)))

  ;; List of template instances, where each entry is a triplet containing the
  ;; syntax of the name, the actual parameter for which the template is
  ;; specialized, and the syntax object referring to this specialization (the
  ;; procedure's identifier.)
  (define-once %template-instances '())

  (define (register-template-instance! name actual instance)
    (set! %template-instances
      (cons (list name actual instance) %template-instances))))

(define-syntax template-directory
  (lambda (s)
    "This is a \"stateful macro\" to register and lookup templates and
template instances."
    (define location
      (syntax-source s))

    (define current-info-port
      ;; Port for debugging info.
      (const (%make-void-port "w")))

    (define location-string
      (format #f "~a:~a:~a"
              (assq-ref location 'filename)
              (and=> (assq-ref location 'line) 1+)
              (assq-ref location 'column)))

    (define (matching-instance? name actual)
      (match-lambda
        ((name* instance-param proc)
         (and (free-identifier=? name name*)
              (or (equal? actual instance-param)
                  (and (identifier? actual)
                       (identifier? instance-param)
                       (free-identifier=? instance-param
                                          actual)))
              proc))))

    (define (instance-identifier name actual)
      (define stem
        (string-append
         " "
         (symbol->string (syntax->datum name))
         (if (identifier? actual)
             (string-append " " (symbol->string (syntax->datum actual)))
             "")
         " instance"))
      (datum->syntax actual (string->symbol stem)))

    (define (instance-definition name template actual)
      (match template
        ((formal . body)
         (let ((instance (instance-identifier name actual)))
           (format (current-info-port)
                   "~a: info: specializing '~a' for '~a' as '~a'~%"
                   location-string
                   (syntax->datum name) (syntax->datum actual)
                   (syntax->datum instance))

           (register-template-instance! name actual instance)

           #`(begin
               (define #,instance
                 (let-syntax ((#,formal (identifier-syntax #,actual)))
                   #,body))

               ;; Generate code to register the thing at run time.
               (register-template-instance! #'#,name #'#,actual
                                            #'#,instance))))))

    (syntax-case s (register! lookup exists? instantiations)
      ((_ register! name param body)
       ;; Register NAME as a template on PARAM with the given BODY.
       (begin
         (register-template! #'name #'param #'body)

         ;; Generate code to register the template at run time.  XXX: Because
         ;; of this, BODY must not contain ellipses.
         #'(register-template! #'name #'param #'body)))
      ((_ lookup name actual)
       ;; Search for an instance of template NAME for this ACTUAL parameter.
       ;; On success, expand to the identifier of the instance; otherwise
       ;; expand to #f.
       (any (matching-instance? #'name #'actual) %template-instances))
      ((_ exists? name actual)
       ;; Likewise, but return a Boolean.
       (let ((result (->bool
                      (any (matching-instance? #'name #'actual)
                           %template-instances))))
         (unless result
           (format (current-warning-port)
                   "~a: warning: no specialization of template '~a' for '~a'~%"
                   location-string
                   (syntax->datum #'name) (syntax->datum #'actual)))
         result))
      ((_ instantiations actual)
       ;; Expand to the definitions of all the existing templates
       ;; specialized for ACTUAL.
       #`(begin
           #,@(hash-map->list (cut instance-definition <> <> #'actual)
                              %templates))))))

(define-syntax define-template
  (lambda (s)
    "Define a template, which is a procedure that can be specialized over its
first argument.  In our case, the first argument is typically the identifier
of a monad.

Defining templates for procedures like 'mapm' allows us to make have a
specialized version of those procedures for each monad that we define, such
that calls to:

  (mapm %state-monad proc lst)

automatically expand to:

  (#{ mapm %state-monad instance}# proc lst)

Here, #{ mapm %state-monad instance}# is specialized for %state-monad, and
thus it contains inline calls to %state-bind and %state-return.  This avoids
repeated calls to 'struct-ref' to get the 'bind' and 'return' procedure of the
monad, and allows 'bind' and 'return' to be inlined, which in turn allows for
more optimizations."
    (syntax-case s ()
      ((_ (name arg0 args ...) body ...)
       (with-syntax ((generic-name (datum->syntax
                                    #'name
                                    (symbol-append '#{ %}#
                                                   (syntax->datum #'name)
                                                   '-generic)))
                     (original-name #'name))
         #`(begin
             (template-directory register! name arg0
                                 (lambda (args ...)
                                   body ...))
             (define (generic-name arg0 args ...)
               ;; The generic instance of NAME, for when no specialization was
               ;; found.
               body ...)

             (define-syntax name
               (lambda (s)
                 (syntax-case s ()
                   ((_ arg0* args ...)
                    ;; Expand to either the specialized instance or the
                    ;; generic instance of template ORIGINAL-NAME.
                    #'(if (template-directory exists? original-name arg0*)
                          ((template-directory lookup original-name arg0*)
                           args ...)
                          (generic-name arg0* args ...)))
                   (_
                    #'generic-name))))))))))

(define-syntax-rule (define-syntax-parameter-once name proc)
  ;; Like 'define-syntax-parameter' but ensure the top-level binding for NAME
  ;; does not get redefined.  This works around a race condition in a
  ;; multi-threaded context with Guile <= 2.2.4: <https://bugs.gnu.org/27476>.
  (eval-when (load eval expand compile)
    (define name
      (if (module-locally-bound? (current-module) 'name)
          (module-ref (current-module) 'name)
          (make-syntax-transformer 'name 'syntax-parameter
                                   (list proc))))))

(define-syntax-parameter-once >>=
  ;; The name 'bind' is already taken, so we choose this (obscure) symbol.
  (lambda (s)
    (syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s)))

(define-syntax-parameter-once return
  (lambda (s)
    (syntax-violation 'return "return used outside of 'with-monad'" s)))

(define-syntax-rule (bind-syntax bind)
  "Return a macro transformer that handles the expansion of '>>=' expressions
using BIND as the binary bind operator.

This macro exists to allow the expansion of n-ary '>>=' expressions, even
though BIND is simply binary, as in:

  (with-monad %state-monad
    (>>= (return 1)
         (lift 1+ %state-monad)
         (lift 1+ %state-monad)))
"
  (lambda (stx)
    (define (expand body)
      (syntax-case body ()
        ((_ mval mproc)
         #'(bind mval mproc))
        ((x mval mproc0 mprocs (... ...))
         (expand #'(>>= (>>= mval mproc0)
                        mprocs (... ...))))))

    (expand stx)))

(define-syntax with-monad
  (lambda (s)
    "Evaluate BODY in the context of MONAD, and return its result."
    (syntax-case s ()
      ((_ monad body ...)
       (eq? 'macro (syntax-local-binding #'monad))
       ;; MONAD is a syntax transformer, so we can obtain the bind and return
       ;; methods by directly querying it.
       #'(syntax-parameterize ((>>=    (bind-syntax (monad %bind)))
                               (return (identifier-syntax (monad %return))))
           body ...))
      ((_ monad body ...)
       ;; MONAD refers to the <monad> record that represents the monad at run
       ;; time, so use the slow method.
       #'(syntax-parameterize ((>>=    (bind-syntax
                                        (monad-bind monad)))
                               (return (identifier-syntax
                                        (monad-return monad))))
           body ...)))))

(define-syntax mlet*
  (syntax-rules (->)
    "Bind the given monadic values MVAL to the given variables VAR.  When the
form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as
'let'."
    ;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'.
    ((_ monad () body ...)
     (with-monad monad body ...))
    ((_ monad ((var mval) rest ...) body ...)
     (with-monad monad
       (>>= mval
            (lambda (var)
              (mlet* monad (rest ...)
                body ...)))))
    ((_ monad ((var -> val) rest ...) body ...)
     (let ((var val))
       (mlet* monad (rest ...)
         body ...)))))

(define-syntax mlet
  (lambda (s)
    (syntax-case s ()
      ((_ monad ((var mval ...) ...) body ...)
       (with-syntax (((temp ...) (generate-temporaries #'(var ...))))
         #'(mlet* monad ((temp mval ...) ...)
             (let ((var temp) ...)
               body ...)))))))

(define-syntax mbegin
  (syntax-rules (%current-monad)
    "Bind MEXP and the following monadic expressions in sequence, returning
the result of the last expression.  Every expression in the sequence must be a
monadic expression."
    ((_ %current-monad mexp)
     mexp)
    ((_ %current-monad mexp rest ...)
     (>>= mexp
          (lambda (unused-value)
            (mbegin %current-monad rest ...))))
    ((_ monad mexp)
     (with-monad monad
       mexp))
    ((_ monad mexp rest ...)
     (with-monad monad
       (>>= mexp
            (lambda (unused-value)
              (mbegin monad rest ...)))))))

(define-syntax mwhen
  (syntax-rules ()
    "When CONDITION is true, evaluate the sequence of monadic expressions
MEXP0..MEXP* as in an 'mbegin'.  When CONDITION is false, return *unspecified*
in the current monad.  Every expression in the sequence must be a monadic
expression."
    ((_ condition mexp0 mexp* ...)
     (if condition
         (mbegin %current-monad
           mexp0 mexp* ...)
         (return *unspecified*)))))

(define-syntax munless
  (syntax-rules ()
    "When CONDITION is false, evaluate the sequence of monadic expressions
MEXP0..MEXP* as in an 'mbegin'.  When CONDITION is true, return *unspecified*
in the current monad.  Every expression in the sequence must be a monadic
expression."
    ((_ condition mexp0 mexp* ...)
     (if condition
         (return *unspecified*)
         (mbegin %current-monad
           mexp0 mexp* ...)))))

(define-syntax define-lift
  (syntax-rules ()
    ((_ liftn (args ...))
     (define-syntax liftn
       (lambda (s)
         "Lift PROC to MONAD---i.e., return a monadic function in MONAD."
         (syntax-case s ()
           ((liftn proc monad)
            ;; Inline the result of lifting PROC, such that 'return' can in
            ;; turn be open-coded.
            #'(lambda (args ...)
                (with-monad monad
                  (return (proc args ...)))))
           (id
            (identifier? #'id)
            ;; Slow path: Return a closure-returning procedure (we don't
            ;; guarantee (eq? LIFTN LIFTN), but that's fine.)
            #'(lambda (proc monad)
                (lambda (args ...)
                  (with-monad monad
                    (return (proc args ...))))))))))))

(define-lift lift0 ())
(define-lift lift1 (a))
(define-lift lift2 (a b))
(define-lift lift3 (a b c))
(define-lift lift4 (a b c d))
(define-lift lift5 (a b c d e))
(define-lift lift6 (a b c d e f))
(define-lift lift7 (a b c d e f g))

(define (lift proc monad)
  "Lift PROC, a procedure that accepts an arbitrary number of arguments, to
MONAD---i.e., return a monadic function in MONAD."
  (lambda args
    (with-monad monad
      (return (apply proc args)))))

(define-template (foldm monad mproc init lst)
  "Fold MPROC over LST and return a monadic value seeded by INIT.

  (foldm %state-monad (lift2 cons %state-monad) '() '(a b c))
  => '(c b a)  ;monadic
"
  (with-monad monad
    (let loop ((lst    lst)
               (result init))
      (match lst
        (()
         (return result))
        ((head . tail)
         (>>= (mproc head result)
              (lambda (result)
                (loop tail result))))))))

(define-template (mapm monad mproc lst)
  "Map MPROC over LST and return a monadic list.

  (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2))
  => (1 2 3)  ;monadic
"
  ;; XXX: We don't use 'foldm' because template specialization wouldn't work
  ;; in this context.
  (with-monad monad
    (let mapm ((lst    lst)
               (result '()))
      (match lst
        (()
         (return (reverse result)))
        ((head . tail)
         (>>= (mproc head)
              (lambda (head)
                (mapm tail (cons head result)))))))))

(define-template (sequence monad lst)
  "Turn the list of monadic values LST into a monadic list of values, by
evaluating each item of LST in sequence."
  (with-monad monad
    (let seq ((lstx   lst)
              (result '()))
      (match lstx
        (()
         (return (reverse result)))
        ((head . tail)
         (>>= head
              (lambda (item)
                (seq tail (cons item result)))))))))

(define-template (anym monad mproc lst)
  "Apply MPROC to the list of values LST; return as a monadic value the first
value for which MPROC returns a true monadic value or #f.  For example:

  (anym %state-monad (lift1 odd? %state-monad) '(0 1 2))
  => #t   ;monadic
"
  (with-monad monad
    (let loop ((lst lst))
      (match lst
        (()
         (return #f))
        ((head . tail)
         (>>= (mproc head)
              (lambda (result)
                (if result
                    (return result)
                    (loop tail)))))))))

(define-syntax listm
  (lambda (s)
    "Return a monadic list in MONAD from the monadic values MVAL."
    (syntax-case s ()
      ((_ monad mval ...)
       (with-syntax (((val ...) (generate-temporaries #'(mval ...))))
         #'(mlet monad ((val mval) ...)
             (return (list val ...))))))))

;;;
;;; Identity monad.
;;;

(define-inlinable (identity-return value)
  value)

(define-inlinable (identity-bind mvalue mproc)
  (mproc mvalue))

(define-monad %identity-monad
  (bind   identity-bind)
  (return identity-return))

;;;
;;; State monad.
;;;

(define-inlinable (state-return value)
  (lambda (state)
    (values value state)))

(define-inlinable (state-bind mvalue mproc)
  "Bind MVALUE, a value in the state monad, and pass it to MPROC."
  (lambda (state)
    (call-with-values
        (lambda ()
          (mvalue state))
      (lambda (value state)
        ;; Note: as of Guile 2.0.11, declaring a variable to hold the result
        ;; of (mproc value) prevents a bit of unfolding/inlining.
        ((mproc value) state)))))

(define-monad %state-monad
  (bind state-bind)
  (return state-return))

(define* (run-with-state mval #:optional (state '()))
  "Run monadic value MVAL starting with STATE as the initial state.  Return
two values: the resulting value, and the resulting state."
  (mval state))

(define-inlinable (current-state)
  "Return the current state as a monadic value."
  (lambda (state)
    (values state state)))

(define-inlinable (set-current-state value)
  "Set the current state to VALUE and return the previous state as a monadic
value."
  (lambda (state)
    (values state value)))

(define (state-pop)
  "Pop a value from the current state and return it as a monadic value.  The
state is assumed to be a list."
  (lambda (state)
    (match state
      ((head . tail)
       (values head tail)))))

(define (state-push value)
  "Push VALUE to the current state, which is assumed to be a list, and return
the previous state as a monadic value."
  (lambda (state)
    (values state (cons value state))))

;;; monads.scm end here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.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 nar)
  #:use-module (guix serialization)
  #:use-module (guix build syscalls)
  #:use-module ((guix build utils)
                #:select (delete-file-recursively with-directory-excursion))

  ;; XXX: Eventually we should use (guix store database) exclusively, and not
  ;; (guix store) since this is "daemon-side" code.
  #:use-module (guix store)
  #:use-module (guix store database)
  #:use-module ((guix build store-copy) #:select (store-info))

  #:use-module (guix i18n)
  #:use-module (gcrypt hash)
  #:use-module (guix pki)
  #:use-module (gcrypt pk-crypto)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (nar-invalid-hash-error?
            nar-invalid-hash-error-expected
            nar-invalid-hash-error-actual

            nar-signature-error?
            nar-signature-error-signature

            restore-file-set))

;;; Comment:
;;;
;;; Read and write Nix archives, aka. ‘nar’.
;;;
;;; Code:

(define-condition-type &nar-signature-error &nar-error
  nar-signature-error?
  (signature nar-signature-error-signature))      ; faulty signature or #f

(define-condition-type &nar-invalid-hash-error &nar-signature-error
  nar-invalid-hash-error?
  (expected  nar-invalid-hash-error-expected)     ; expected hash (a bytevector)
  (actual    nar-invalid-hash-error-actual))      ; actual hash

;;;
;;; Restoring a file set into the store.
;;;

;; The code below accesses the store directly and is meant to be run from
;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since
;; (1) the locks on the files to be restored as already held, and (2) the
;; $NIX_HELD_LOCKS hackish environment variable cannot be set.
;;
;; So we're really duplicating that functionality of the daemon (well, until
;; most of the daemon is in Scheme :-)).  But note that we do use a couple of
;; RPCs for functionality not available otherwise, like 'valid-path?'.

(define* (finalize-store-file source target
                              #:key (references '()) deriver (lock? #t))
  "Rename SOURCE to TARGET and register TARGET as a valid store item, with
REFERENCES and DERIVER.  When LOCK? is true, acquire exclusive locks on TARGET
before attempting to register it; otherwise, assume TARGET's locks are already
held."
  ;; TODO: make this reusable
  (define (acquire-lock file)
    (let ((port (lock-file file)))
      ;; There is an inherent race condition between opening the lock file and
      ;; attempting to acquire the lock on it, and because we like deleting
      ;; these lock files when we release them, only the first successful
      ;; acquisition on a given lock file matters.  To make it easier to tell
      ;; when an acquisition is and isn't the first, the first to acquire it
      ;; writes a deletion token (arbitrary character) prior to releasing the
      ;; lock.
      (if (zero? (stat:size (stat port)))
          port
          ;; if FILE is non-empty, that's because it contains the deletion
          ;; token, so we aren't the first to acquire it.  So try again!
          (begin
            (close port)
            (acquire-lock file)))))

  (with-database %default-database-file db
    (unless (path-id db target)
      (let ((lock (and lock?
                       (acquire-lock (string-append target ".lock")))))

        (unless (path-id db target)
          ;; If FILE already exists, delete it (it's invalid anyway.)
          (when (file-exists? target)
            (delete-file-recursively target))

          ;; Install the new TARGET.
          (rename-file source target)

          ;; Register TARGET.  As a side effect, it resets the timestamps of all
          ;; its files, recursively, and runs a deduplication pass.
          (register-items db
                          (list (store-info target deriver references))))

        (when lock?
          (delete-file (string-append target ".lock"))
          ;; Write the deletion token to inform anyone who acquires the lock
          ;; on this particular file next that they aren't the first to
          ;; acquire it, so they should retry.
          (display "d" lock)
          (force-output lock)
          (unlock-file lock))))))

(define (temporary-store-file)
  "Return the file name of a temporary file created in the store."
  (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
         (port     (mkstemp! template)))
    (close-port port)
    template))

(define-syntax-rule (with-temporary-store-file name body ...)
  "Evaluate BODY with NAME bound to the file name of a temporary store item
protected from GC."
  (with-store store
    (let loop ((name (temporary-store-file)))
      ;; Add NAME to the current process' roots.  (Opening this connection to
      ;; the daemon allows us to reuse its code that deals with the
      ;; per-process roots file.)
      (add-temp-root store name)

      ;; There's a window during which GC could delete NAME.  Try again when
      ;; that happens.
      (if (file-exists? name)
          (begin
            (delete-file name)
            body ...)
          (loop (temporary-store-file))))))

(define* (restore-one-item port
                           #:key acl (verify-signature? #t) (lock? #t)
                           (log-port (current-error-port)))
  "Restore one store item of a nar bundle read from PORT; return its file name
on success."

  (define (assert-valid-signature signature hash file)
    ;; Bail out if SIGNATURE, which must be a string as produced by
    ;; 'canonical-sexp->string', doesn't match HASH, a bytevector containing
    ;; the expected hash for FILE.
    (let ((signature (catch 'gcry-error
                       (lambda ()
                         (string->canonical-sexp signature))
                       (lambda (key proc err)
                         (raise (condition
                                 (&message
                                  (message "signature is not a valid \
s-expression"))
                                 (&nar-signature-error
                                  (file file)
                                  (signature signature) (port port))))))))
      (signature-case (signature hash (current-acl))
        (valid-signature #t)
        (invalid-signature
         (raise (condition
                 (&message (message "invalid signature"))
                 (&nar-signature-error
                  (file file) (signature signature) (port port)))))
        (hash-mismatch
         (raise (condition (&message (message "invalid hash"))
                           (&nar-invalid-hash-error
                            (port port) (file file)
                            (signature signature)
                            (expected (hash-data->bytevector
                                       (signature-signed-data signature)))
                            (actual hash)))))
        (unauthorized-key
         (raise (condition (&message (message "unauthorized public key"))
                           (&nar-signature-error
                            (signature signature) (file file) (port port)))))
        (corrupt-signature
         (raise (condition
                 (&message (message "corrupt signature data"))
                 (&nar-signature-error
                  (signature signature) (file file) (port port))))))))

  (define %export-magic
    ;; Number used to identify genuine file set archives.
    #x4558494e)

  (define port*
    ;; Keep that one around, for error conditions.
    port)

  (let-values (((port get-hash)
                (open-sha256-input-port port)))
    (with-temporary-store-file temp
      (restore-file port temp)

      (let ((magic (read-int port)))
        (unless (= magic %export-magic)
          (raise (condition
                  (&message (message "corrupt file set archive"))
                  (&nar-read-error
                   (port port*) (file #f) (token #f))))))

      (let ((file     (read-store-path port))
            (refs     (read-store-path-list port))
            (deriver  (read-string port))
            (hash     (get-hash))
            (has-sig? (= 1 (read-int port))))
        (format log-port
                (G_ "importing file or directory '~a'...~%")
                file)

        ;; The signature may contain characters that are meant to be
        ;; interpreted as bytes in a 'char *', so read them as a ISO-8859-1.
        (let ((sig (and has-sig? (read-latin1-string port))))
          (when verify-signature?
            (if sig
                (begin
                  (assert-valid-signature sig hash file)
                  (format log-port
                          (G_ "found valid signature for '~a'~%")
                          file)
                  (finalize-store-file temp file
                                       #:references refs
                                       #:deriver deriver
                                       #:lock? lock?))
                (raise (condition
                        (&message (message "imported file lacks \
a signature"))
                        (&nar-signature-error
                         (port port*) (file file) (signature #f))))))
          file)))))

(define* (restore-file-set port
                           #:key (verify-signature? #t) (lock? #t)
                           (log-port (current-error-port)))
  "Restore the file set (\"nar bundle\") read from PORT to the store.  The
format of the data on PORT must be as created by 'export-paths'---i.e., a
series of Nar-formatted archives with interspersed meta-data joining them
together, possibly with a digital signature at the end.  Log progress to
LOG-PORT.  Return the list of files restored.

When LOCK? is #f, assume locks for the files to be restored are already held.
This is the case when the daemon calls a build hook.

Note that this procedure accesses the store directly, so it's only meant to be
used by the daemon's build hooks since they cannot call back to the daemon
while the locks are held."
  (define acl
    (current-acl))

  (let loop ((n     (read-long-long port))
             (files '()))
    (case n
      ((0)
       (reverse files))
      ((1)
       (let ((file
              (restore-one-item port
                                #:acl acl #:verify-signature? verify-signature?
                                #:lock? lock? #:log-port log-port)))
         (loop (read-long-long port)
               (cons file files))))
      (else
       ;; Neither 0 nor 1.
       (raise (condition
               (&message (message "invalid inter-file archive mark"))
               (&nar-read-error
                (port port) (file #f) (token #f))))))))

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

;;; nar.scm ends here

license: mit


code:
;; -*- mode: scheme; coding: utf-8 -*-
;; Copyright © 2010, 2012 Göran Weinholt <goran@weinholt.se>
;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>

;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.

;;; This code was originally written by Göran Weinholt for Industria and
;;; released under the Expat license shown above.  It was then modified by
;;; Ludovic Courtès for use in GNU Guix: turned into a native Guile module,
;;; ported to Guile-Gcrypt, and extended and simplified in other ways.

(define-module (guix openpgp)
  #:export (get-openpgp-detached-signature/ascii
            (get-packet . get-openpgp-packet)
            verify-openpgp-signature
            port-ascii-armored?

            openpgp-error?
            openpgp-unrecognized-packet-error?
            openpgp-unrecognized-packet-error-port
            openpgp-invalid-signature-error?
            openpgp-invalid-signature-error-port

            openpgp-signature?
            openpgp-signature-issuer-key-id
            openpgp-signature-issuer-fingerprint
            openpgp-signature-public-key-algorithm
            openpgp-signature-hash-algorithm
            openpgp-signature-creation-time
            openpgp-signature-expiration-time

            openpgp-user-id?
            openpgp-user-id-value
            openpgp-user-attribute?

            openpgp-public-key?
            openpgp-public-key-subkey?
            openpgp-public-key-value
            openpgp-public-key-fingerprint openpgp-format-fingerprint
            openpgp-public-key-id

            openpgp-keyring?
            %empty-keyring
            lookup-key-by-id
            lookup-key-by-fingerprint
            get-openpgp-keyring

            read-radix-64
            string->openpgp-packet)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #: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 (srfi srfi-60)
  #:use-module (ice-9 match)
  #:use-module ((ice-9 rdelim) #:select (read-line))
  #:use-module (ice-9 vlist)
  #:use-module (gcrypt hash)
  #:use-module (gcrypt pk-crypto)
  #:use-module (gcrypt base64)
  #:use-module (gcrypt base16)
  #:use-module ((guix build utils) #:select (dump-port)))

;;; Commentary:
;;;
;;; This module contains code to read OpenPGP messages as described in
;;; <https://tools.ietf.org/html/rfc4880>, with extensions from
;;; <https://tools.ietf.org/html/draft-ietf-openpgp-rfc4880bis-06> (notably
;;; EdDSA support and extra signature sub-packets).
;;;
;;; Currently this module does enough to verify detached signatures of binary
;;; data.  It does _not_ perform sanity checks on self-signatures, subkey
;;; binding signatures, etc., among others.  Use only in a context where this
;;; limitations are acceptable!
;;;
;;; Code:

(define-syntax print
  (syntax-rules ()
    ;; ((_ args ...) (pk 'openpgp args))
    ((_ args ...) (values))))

(define-syntax-rule (define-alias new old)
  (define-syntax new (identifier-syntax old)))

(define-alias fx+ +)
(define-alias fx- -)
(define-alias fx* *)
(define-alias fx/ /)
(define-alias fxdiv quotient)
(define-alias fxand logand)
(define-alias fxbit-set? bit-set?)
(define-alias fxbit-field bit-field)
(define-alias bitwise-bit-field bit-field)
(define-alias fxarithmetic-shift-left ash)
(define-inlinable (fxarithmetic-shift-right i n) (ash i (- n)))
(define-inlinable (port-eof? port) (eof-object? (lookahead-u8 port)))

(define (string-hex-pad str)
  (if (odd? (string-length str))
      (string-append "0" str)
      str))

(define (unixtime n)
  (time-monotonic->date (make-time 'time-monotonic 0 n)))

;; Root of the error hierarchy.
(define-condition-type &openpgp-error &error
  openpgp-error?)

;; Error raised when reading an unsupported or unrecognized packet tag.
(define-condition-type &openpgp-unrecognized-packet-error &openpgp-error
  openpgp-unrecognized-packet-error?
  (port openpgp-unrecognized-packet-error-port))

;; Error raised when reading an invalid signature packet.
(define-condition-type &openpgp-invalid-signature-error &openpgp-error
  openpgp-invalid-signature-error?
  (port openpgp-invalid-signature-error-port))

;;;
;;; Bitwise I/O.
;;;
;;; TODO: Use Bytestructures instead.
;;;

(define-syntax-rule (integer-read size)
  (lambda (port)
    "Read from PORT a big-endian integer of SIZE bytes.  Return the EOF object
on end-of-file."
    (let ((buf (make-bytevector size)))
      (match (get-bytevector-n! port buf 0 size)
        (size (bytevector-uint-ref buf 0 (endianness big) size))
        (_    (eof-object))))))

(define get-u16 (integer-read 2))
(define get-u32 (integer-read 4))
(define get-u64 (integer-read 8))

(define-syntax get-integers
  (syntax-rules ()
    "Read from PORT integers of the given TYPE, in big endian encoding.  Each
TYPE must be one of u8, u16, u32, u64, or _, as in this example:

  (get-integers port u8 _ _ _ u32 u16)

In the case of _ (wildcard), one byte is read and discarded.  Return as many
values as there are TYPEs."
    ((_ port type ...)
     (letrec-syntax ((get-integer (syntax-rules (u8 u16 u32 u64)
                                    ((x u8) (get-u8 port))
                                    ((x u16) (get-u16 port))
                                    ((x u32) (get-u32 port))
                                    ((x u64) (get-u64 port))))
                     (values*     (syntax-rules (_)
                                    ((x (result (... ...)))
                                     (values result (... ...)))
                                    ((x (result (... ...)) _ rest (... ...))
                                     (let ((x (get-u8 port)))
                                       (values* (result (... ...))
                                                rest (... ...))))
                                    ((x (result (... ...)) t rest (... ...))
                                     (let ((x (get-integer t)))
                                       (values* (result (... ...) x)
                                                rest (... ...)))))))
       (values* () type ...)))))

(define (bytevector->uint bv)
  (bytevector-uint-ref bv 0 (endianness big)
                       (bytevector-length bv)))

(define-syntax-rule (integer-write size)
  (lambda (port integer)
    "Write INTEGER to PORT as a SIZE-byte integer and as big endian."
    (let ((bv (make-bytevector size)))
      (bytevector-uint-set! bv 0 integer (endianness big) size)
      (put-bytevector port bv))))

(define put-u16 (integer-write 2))
(define put-u32 (integer-write 4))
(define put-u64 (integer-write 8))

(define-syntax put-integers
  (syntax-rules ()
    "Write the given integers as big endian to PORT.  For example:

  (put-integers port u8 42 u32 #x7777)

writes to PORT the value 42 as an 8-bit integer and the value #x7777 as a
32-bit integer."
    ((_ port)
     #t)
    ((_ port type value rest ...)
     (let-syntax ((put (syntax-rules (u8 u16 u32 u64)
                         ((_ u8 port integer)
                          (put-u8 port integer))
                         ((_ u16 port integer)
                          (put-u16 port integer))
                         ((_ u32 port integer)
                          (put-u32 port integer))
                         ((_ u64 port integer)
                          (put-u64 port integer)))))
       (begin
         (put type port value)
         (put-integers port rest ...))))))

(define-syntax-rule (integers->bytevector type value rest ...)
  "Return the the TYPE/VALUE integers representation as a bytevector."
  (let-values (((port get) (open-bytevector-output-port)))
    (put-integers port type value rest ...)
    (force-output port)
    (get)))

(define (bytevector->bitnames bv names)
  (define (bit-set? bv i)
    (let ((idx (fxarithmetic-shift-right i 3))
          (bit (fxand i #b111)))
      (and (< idx (bytevector-length bv))
           (fxbit-set? (bytevector-u8-ref bv idx) bit))))
  (do ((names names (cdr names))
       (i 0 (fx+ i 1))
       (bits '()
             (if (bit-set? bv i)
                 (cons (car names) bits)
                 bits)))
      ((null? names) (reverse bits))))

(define (openpgp-format-fingerprint bv)
  "Return a string representing BV, a bytevector, in the conventional OpenPGP
hexadecimal format for fingerprints."
  (define (h i)
    (string-pad (string-upcase
                 (number->string
                  (bytevector-u16-ref bv (* i 2) (endianness big))
                  16))
                4 #\0))
  (string-append (h 0) " " (h 1) " " (h 2) " " (h 3) " " (h 4)
                 "  "
                 (h 5) " " (h 6) " " (h 7) " " (h 8) " " (h 9)))

;;; Constants

(define PACKET-SESSION-KEY 1)
(define PACKET-SIGNATURE 2)
(define PACKET-SYMMETRIC-SESSION-KEY 3)
(define PACKET-ONE-PASS-SIGNATURE 4)
(define PACKET-SECRET-KEY 5)
(define PACKET-PUBLIC-KEY 6)
(define PACKET-SECRET-SUBKEY 7)
(define PACKET-COMPRESSED-DATA 8)
(define PACKET-SYMMETRIC-ENCRYPTED-DATA 9)
(define PACKET-MARKER 10)
(define PACKET-LITERAL-DATA 11)
(define PACKET-TRUST 12)
(define PACKET-USER-ID 13)
(define PACKET-PUBLIC-SUBKEY 14)
(define PACKET-USER-ATTRIBUTE 17)
(define PACKET-SYMMETRIC-ENCRYPTED/PROTECTED-DATA 18)
(define PACKET-MDC 19)

(define PUBLIC-KEY-RSA 1)
(define PUBLIC-KEY-RSA-ENCRYPT-ONLY 2)
(define PUBLIC-KEY-RSA-SIGN-ONLY 3)
(define PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY 16)
(define PUBLIC-KEY-DSA 17)
(define PUBLIC-KEY-ECDH 18)                       ;RFC-6637
(define PUBLIC-KEY-ECDSA 19)                      ;RFC-6639
(define PUBLIC-KEY-ELGAMAL 20)                    ;encrypt + sign (legacy)
(define PUBLIC-KEY-EDDSA 22)                      ;"not yet assigned" says GPG

(define (public-key-algorithm id)
  (cond ((= id PUBLIC-KEY-RSA) 'rsa)
        ((= id PUBLIC-KEY-DSA) 'dsa)
        ((= id PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY) 'elgamal)
        ((= id PUBLIC-KEY-EDDSA) 'eddsa)
        (else id)))

(define SYMMETRIC-KEY-PLAINTEXT 0)
(define SYMMETRIC-KEY-IDEA 1)
(define SYMMETRIC-KEY-TRIPLE-DES 2)
(define SYMMETRIC-KEY-CAST5-128 3)
(define SYMMETRIC-KEY-BLOWFISH-128 4)
(define SYMMETRIC-KEY-AES-128 7)
(define SYMMETRIC-KEY-AES-192 8)
(define SYMMETRIC-KEY-AES-256 9)
(define SYMMETRIC-KEY-TWOFISH-256 10)
(define SYMMETRIC-KEY-CAMELLIA-128 11)            ;RFC-5581
(define SYMMETRIC-KEY-CAMELLIA-192 12)
(define SYMMETRIC-KEY-CAMELLIA-256 13)

(define (symmetric-key-algorithm id)
  (cond ((= id SYMMETRIC-KEY-PLAINTEXT) 'plaintext)
        ((= id SYMMETRIC-KEY-IDEA) 'idea)
        ((= id SYMMETRIC-KEY-TRIPLE-DES) 'tdea)
        ((= id SYMMETRIC-KEY-CAST5-128) 'cast5-128)
        ((= id SYMMETRIC-KEY-BLOWFISH-128) 'blowfish-128)
        ((= id SYMMETRIC-KEY-AES-128) 'aes-128)
        ((= id SYMMETRIC-KEY-AES-192) 'aes-192)
        ((= id SYMMETRIC-KEY-AES-256) 'aes-256)
        ((= id SYMMETRIC-KEY-TWOFISH-256) 'twofish-256)
        (else id)))

(define HASH-MD5 1)
(define HASH-SHA-1 2)
(define HASH-RIPE-MD160 3)
(define HASH-SHA-256 8)
(define HASH-SHA-384 9)
(define HASH-SHA-512 10)
(define HASH-SHA-224 11)

(define (openpgp-hash-algorithm id signature-port)
  (cond ((= id HASH-MD5) 'md5)
        ((= id HASH-SHA-1) 'sha1)
        ((= id HASH-RIPE-MD160) 'rmd160)
        ((= id HASH-SHA-256) 'sha256)
        ((= id HASH-SHA-384) 'sha384)
        ((= id HASH-SHA-512) 'sha512)
        ((= id HASH-SHA-224) 'sha224)
        (else
         (raise (condition
                 (&openpgp-invalid-signature-error (port signature-port)))))))

(define COMPRESSION-UNCOMPRESSED 0)
(define COMPRESSION-ZIP 1)                      ;deflate

(define COMPRESSION-ZLIB 2)
(define COMPRESSION-BZIP2 3)

(define (compression-algorithm id)
  (cond ((= id COMPRESSION-UNCOMPRESSED) 'uncompressed)
        ((= id COMPRESSION-ZIP) 'deflate)
        ((= id COMPRESSION-ZLIB) 'zlib)
        ((= id COMPRESSION-BZIP2) 'bzip2)
        (else id)))

(define SUBPACKET-SIGNATURE-CTIME 2)
(define SUBPACKET-SIGNATURE-ETIME 3)
  ;;  4 = Exportable Certification

(define SUBPACKET-TRUST-SIGNATURE 5)
  ;;  6 = Regular Expression

(define SUBPACKET-REVOCABLE 7)
(define SUBPACKET-KEY-ETIME 9)
(define SUBPACKET-PREFERRED-SYMMETRIC-ALGORITHMS 11)
  ;; 12 = Revocation Key

(define SUBPACKET-ISSUER 16)
(define SUBPACKET-NOTATION-DATA 20)
(define SUBPACKET-PREFERRED-HASH-ALGORITHMS 21)
(define SUBPACKET-PREFERRED-COMPRESSION-ALGORITHMS 22)
(define SUBPACKET-KEY-SERVER-PREFERENCES 23)
(define SUBPACKET-PREFERRED-KEY-SERVER 24)
(define SUBPACKET-PRIMARY-USER-ID 25)
(define SUBPACKET-POLICY-URI 26)
(define SUBPACKET-KEY-FLAGS 27)
(define SUBPACKET-SIGNER-USER-ID 28)
(define SUBPACKET-REASON-FOR-REVOCATION 29)
(define SUBPACKET-FEATURES 30)
  ;; 31 = Signature Target
(define SUBPACKET-EMBEDDED-SIGNATURE 32)
(define SUBPACKET-ISSUER-FINGERPRINT 33)          ;defined in RFC4880bis

(define SIGNATURE-BINARY #x00)
(define SIGNATURE-TEXT #x01)
(define SIGNATURE-STANDALONE #x02)
(define SIGNATURE-GENERIC-CERT #x10)
(define SIGNATURE-PERSONA-CERT #x11)
(define SIGNATURE-CASUAL-CERT #x12)
(define SIGNATURE-POSITIVE-CERT #x13)
(define SIGNATURE-SUBKEY-BINDING #x18)
(define SIGNATURE-PRIMARY-KEY-BINDING #x19)
(define SIGNATURE-DIRECT #x1f)
(define SIGNATURE-KEY-REVOCATION #x20)
(define SIGNATURE-SUBKEY-REVOCATION #x28)
(define SIGNATURE-CERT-REVOCATION #x30)
(define SIGNATURE-TIMESTAMP #x40)
(define SIGNATURE-THIRD-PARTY #x50)

;;; Parsing

  ;; Look at the tag byte and see if it looks reasonable, if it does
  ;; then the file is likely not armored. Does not move the port
  ;; position.

(define (port-ascii-armored? p)
  (let ((tag (lookahead-u8 p)))
    (cond ((eof-object? tag) #f)
          ((not (fxbit-set? tag 7)) #t)
          (else
           (let ((type (if (fxbit-set? tag 6)
                           (fxbit-field tag 0 6)
                           (fxbit-field tag 2 6))))
             (not (<= PACKET-SESSION-KEY type PACKET-MDC)))))))

(define (get-mpi/bytevector p)
  (let* ((bitlen  (get-u16 p))
         (bytelen (fxdiv (fx+ bitlen 7) 8)))
    (get-bytevector-n p bytelen)))

(define (get-mpi p)
  (bytevector->uint (get-mpi/bytevector p)))

(define (get-v4-length p)
  ;; TODO: indeterminate length (only for data packets)
  (let ((o1 (get-u8 p)))
    (cond ((< o1 192) o1)
          ((< o1 255)
           (+ (fxarithmetic-shift-left (fx- o1 192) 8)
              (get-u8 p)
              192))
          ((= o1 255)
           (get-u32 p)))))

(define (get-packet p)
  (if (port-eof? p)
      (eof-object)
      (get-packet* p get-data)))

(define (get-packet* p get-data)
  (let ((tag (get-u8 p)))
    ;; (unless (fxbit-set? tag 7) (error 'get-packet "Invalid tag" tag))
    (cond ((fxbit-set? tag 6)                     ;New packet format
           (let ((tag (fxbit-field tag 0 6))
                 (len (get-v4-length p)))
             (get-data p tag len)))
          (else                                   ;Old packet format
           (let ((tag (fxbit-field tag 2 6))
                 (len (case (fxbit-field tag 0 2)
                        ((0) (get-u8 p))
                        ((1) (get-u16 p))
                        ((2) (get-u32 p))
                        ((3) #f))))
             (get-data p tag len))))))

(define (get-data p tag len)
  (let ((pp (if len
                (open-bytevector-input-port (get-bytevector-n p len))
                p)))                              ;indeterminate length
    (cond
     ((= tag PACKET-SIGNATURE)
      (get-signature pp))
     ((= tag PACKET-PUBLIC-KEY)
      (get-public-key pp #f))
     ((= tag PACKET-TRUST)
      'openpgp-trust)                             ;XXX: non-standard format?
     ((= tag PACKET-USER-ID)
      (get-user-id pp len))
     ((= tag PACKET-PUBLIC-SUBKEY)
      (get-public-key pp #t))
     ((= tag PACKET-USER-ATTRIBUTE)
      (get-user-attribute pp len))
     ((= tag PACKET-ONE-PASS-SIGNATURE)
      'one-pass-signature)                        ;TODO: implement
     (else
      (raise (condition (&openpgp-unrecognized-packet-error (port p))))))))

(define-record-type <openpgp-public-key>
  (make-openpgp-public-key version subkey? time value fingerprint)
  openpgp-public-key?
  (version      openpgp-public-key-version)
  (subkey?      openpgp-public-key-subkey?)
  (time         openpgp-public-key-time)
  (value        openpgp-public-key-value)
  (fingerprint  openpgp-public-key-fingerprint))

;;; Signatures

(define-record-type <openpgp-signature>
  (make-openpgp-signature version type pk-algorithm hash-algorithm hashl16
                          append-data hashed-subpackets unhashed-subpackets
                          value issuer issuer-fingerprint)
  openpgp-signature?
  (version               openpgp-signature-version)
  (type                  openpgp-signature-type)
  (pk-algorithm          openpgp-signature-public-key-algorithm)
  (hash-algorithm        openpgp-signature-hash-algorithm)
  (hashl16               openpgp-signature-hashl16) ;left 16 bits of signed hash
  (append-data           openpgp-signature-append-data) ;append to data when hashing
  (hashed-subpackets     openpgp-signature-hashed-subpackets)
  (unhashed-subpackets   openpgp-signature-unhashed-subpackets)
  (value                 openpgp-signature-value)
  (issuer                openpgp-signature-issuer-key-id)       ;integer | #f
  (issuer-fingerprint    openpgp-signature-issuer-fingerprint)) ;bytevector | #f

(define (openpgp-signature-creation-time sig)
  (cond ((assq 'signature-ctime (openpgp-signature-hashed-subpackets sig))
         => (lambda (x) (unixtime (cdr x))))
        ;; XXX: should be an error?
        (else #f)))

(define (openpgp-signature-expiration-time sig)
  (cond ((assq 'signature-etime (openpgp-signature-hashed-subpackets sig))
         => (lambda (x)
              (unixtime (+ (cdr x)
                           (openpgp-signature-creation-time sig)))))
        (else #f)))

(define (get-openpgp-detached-signature/ascii port)
  "Read from PORT an ASCII-armored detached signature.  Return an
<openpgp-signature> record or the end-of-file object.  Raise an error if the
data read from PORT does is invalid or does not correspond to a detached
signature."
  (let-values (((data type) (read-radix-64 port)))
    (cond ((eof-object? data) data)
          ((string=? type "PGP SIGNATURE")
           (get-packet (open-bytevector-input-port data)))
          (else
           (print "expected PGP SIGNATURE" type)
           (raise (condition
                   (&openpgp-invalid-signature-error (port port))))))))

(define (hash-algorithm-name algorithm)        ;XXX: should be in Guile-Gcrypt
  "Return the name of ALGORITHM, a 'hash-algorithm' integer, as a symbol."
  (letrec-syntax ((->name (syntax-rules ()
                            ((_) #f)
                            ((_ name rest ...)
                             (if (= algorithm (hash-algorithm name))
                                 'name
                                 (->name rest ...))))))
    (->name sha1 sha256 sha384 sha512 sha224
            sha3-224 sha3-256 sha3-384 sha3-512)))

(define (verify-openpgp-signature sig keyring dataport)
  "Verify that the data read from DATAPORT matches SIG, an
<openpgp-signature>.  Fetch the public key of the issuer of SIG from KEYRING,
a keyring as returned by 'get-openpgp-keyring'.  Return two values: a status
symbol, such as 'bad-signature or 'missing-key, and additional info, such as
the issuer's OpenPGP public key extracted from KEYRING."
  (define (check key sig)
    (let*-values (((hash-algorithm) (lookup-hash-algorithm
                                     (openpgp-signature-hash-algorithm sig)))
                  ((port get-hash) (open-hash-port hash-algorithm)))
      (dump-port dataport port)

      ;; As per RFC4880 Section 5.2.4 ("Computing Signatures"), hash some of
      ;; the fields from the signature packet.
      (for-each (cut put-bytevector port <>)
                (openpgp-signature-append-data sig))
      (close-port port)

      (let* ((signature  (openpgp-signature-value sig))
             (public-key (openpgp-public-key-value key))
             (hash       (get-hash))
             (key-type   (key-type public-key))
             (data
              ;; See "(gcrypt) Cryptographic Functions".
              (sexp->canonical-sexp
               (if (eq? key-type 'ecc)
                   `(data
                     (flags eddsa)
                     (hash-algo sha512)
                     (value ,hash))
                   `(data
                     (flags ,(match key-type
                               ('rsa 'pkcs1)
                               ('dsa 'rfc6979)))
                     (hash ,(hash-algorithm-name hash-algorithm)
                           ,hash))))))
        (values (if (verify signature data public-key)
                    'good-signature
                    'bad-signature)
                key))))

  ;; TODO: Support SIGNATURE-TEXT.
  (if (= (openpgp-signature-type sig) SIGNATURE-BINARY)
      (let* ((id          (openpgp-signature-issuer-key-id sig))
             (fingerprint (openpgp-signature-issuer-fingerprint sig))
             (key         (if fingerprint
                              (lookup-key-by-fingerprint keyring fingerprint)
                              (lookup-key-by-id keyring id))))
        (if key
            (check key sig)
            (values 'missing-key (or fingerprint id))))
      (values 'unsupported-signature sig)))

(define (key-id-matches-fingerprint? key-id fingerprint)
  "Return true if KEY-ID, a number, corresponds to the low 8 bytes of
FINGERPRINT, a bytevector."
  (let* ((len (bytevector-length fingerprint))
         (low (make-bytevector 8)))
    (bytevector-copy! fingerprint (- len 8) low 0 8)
    (= (bytevector->uint low) key-id)))

(define (get-signature p)
  (define (->hex n)
    (string-hex-pad (number->string n 16)))

  (define (get-sig p pkalg)
    (cond ((= pkalg PUBLIC-KEY-RSA)
           (print "RSA signature")
           (string->canonical-sexp
            (format #f "(sig-val (rsa (s #~a#)))"
                    (->hex (get-mpi p)))))
          ((= pkalg PUBLIC-KEY-DSA)
           (print "DSA signature")
           (let ((r (get-mpi p)) (s (get-mpi p)))
             (string->canonical-sexp
              (format #f "(sig-val (dsa (r #~a#) (s #~a#)))"
                      (->hex r) (->hex s)))))
          ((= pkalg PUBLIC-KEY-EDDSA)
           (print "EdDSA signature")
           (let ((r (get-mpi/bytevector p))
                 (s (get-mpi/bytevector p)))
             ;; XXX: 'verify' fails down the road with GPG_ERR_INV_LENGTH if
             ;; we provide a 31-byte R or S below, hence the second argument
             ;; to '->hex' ensuring the MPIs are represented as two-byte
             ;; multiples, with leading zeros.
             (define (bytevector->hex bv)
               (let ((str (bytevector->base16-string bv)))
                 (if (odd? (bytevector-length bv))
                     (string-append "00" str)
                     str)))

             (string->canonical-sexp
              (format #f "(sig-val (eddsa (r #~a#) (s #~a#)))"
                      (bytevector->hex r) (bytevector->hex s)))))
          (else
           (list 'unsupported-algorithm
                 (public-key-algorithm pkalg)
                 (get-bytevector-all p)))))
  (let ((version (get-u8 p)))
    (case version
      ((3)
       (let-values (((hmlen type ctime keyid pkalg halg hashl16)
                     (get-integers p u8 u8 u32 u64 u8 u8 u16)))
         (unless (= hmlen 5)
           (raise (condition
                   (&openpgp-invalid-signature-error (port p)))))

         (print "Signature type: " type " creation time: " (unixtime ctime))
         (print "Hash algorithm: " (openpgp-hash-algorithm halg p))
         (let ((value (get-sig p pkalg)))
           (unless (port-eof? p)
             (print "Trailing data in signature: " (get-bytevector-all p)))
           (make-openpgp-signature version type
                                   (public-key-algorithm pkalg)
                                   (openpgp-hash-algorithm halg p) hashl16
                                   (list (integers->bytevector u8 type
                                                               u32 ctime))
                                   ;; Emulate hashed subpackets
                                   (list (cons 'signature-ctime ctime))
                                   ;; Unhashed subpackets
                                   (list (cons 'issuer keyid))
                                   value
                                   keyid #f))))
      ((4)
       (let*-values (((type pkalg halg) (get-integers p u8 u8 u8))
                     ((hashed-subpackets)
                      (get-bytevector-n p (get-u16 p)))
                     ((unhashed-subpackets)
                      (get-bytevector-n p (get-u16 p)))
                     ((hashl16) (get-u16 p)))
         (print "Signature type: " type)
         (print "Hash algorithm: " (openpgp-hash-algorithm halg p))
         (let ((value (get-sig p pkalg)))
           (unless (port-eof? p)
             (print "Trailing data in signature: " (get-bytevector-all p)))
           (let* ((subpacket-len (bytevector-length hashed-subpackets))
                  (append-data
                   (list
                    (integers->bytevector u8 version
                                          u8 type
                                          u8 pkalg
                                          u8 halg
                                          u16 subpacket-len)
                    hashed-subpackets
                    ;; http://www.rfc-editor.org/errata_search.php?rfc=4880
                    ;; Errata ID: 2214.
                    (integers->bytevector u8 #x04
                                          u8 #xff
                                          u32 (+ 6 subpacket-len))))
                  (unhashed-subpackets
                   (parse-subpackets unhashed-subpackets p))
                  (hashed-subpackets (parse-subpackets hashed-subpackets p))
                  (subpackets        (append hashed-subpackets
                                             unhashed-subpackets))
                  (issuer-key-id     (assoc-ref subpackets 'issuer))
                  (issuer            (assoc-ref subpackets
                                                'issuer-fingerprint)))
             (unless (or (not issuer) (not issuer-key-id)
                         (key-id-matches-fingerprint? issuer-key-id issuer))
               (print "issuer key id does not match fingerprint"
                      issuer-key-id issuer)
               (raise (condition
                       (&openpgp-invalid-signature-error (port p)))))

             (make-openpgp-signature version type
                                     (public-key-algorithm pkalg)
                                     (openpgp-hash-algorithm halg p)
                                     hashl16
                                     append-data
                                     hashed-subpackets
                                     unhashed-subpackets
                                     value
                                     issuer-key-id issuer)))))
      (else
       (print "Unsupported signature version: " version)
       'unsupported-signature-version))))

(define (parse-subpackets bv signature-port)
  (define (parse tag data)
    (let ((type (fxbit-field tag 0 7))
          (critical? (fxbit-set? tag 7)))
      (cond
       ((= type SUBPACKET-SIGNATURE-CTIME)
        (cons 'signature-ctime
              (bytevector-u32-ref data 0 (endianness big))))
       ((= type SUBPACKET-SIGNATURE-ETIME)
        (cons 'signature-etime
              (bytevector-u32-ref data 0 (endianness big))))
       ((= type SUBPACKET-TRUST-SIGNATURE)
        (cons 'trust-signature
              (bytevector-u8-ref data 0)))
       ((= type SUBPACKET-REVOCABLE)
        (cons 'revocable
              (= (bytevector-u8-ref data 0) 1)))
       ((= type SUBPACKET-KEY-ETIME)
        (cons 'key-etime
              (bytevector-u32-ref data 0 (endianness big))))
       ((= type SUBPACKET-PREFERRED-SYMMETRIC-ALGORITHMS)
        (cons 'preferred-symmetric-algorithms
              (map symmetric-key-algorithm (bytevector->u8-list data))))
       ((= type SUBPACKET-ISSUER)
        (cons 'issuer
              (bytevector-u64-ref data 0 (endianness big))))
       ((= type SUBPACKET-ISSUER-FINGERPRINT)     ;v4+ only, RFC4880bis
        (cons 'issuer-fingerprint
              (let* ((version     (bytevector-u8-ref data 0))
                     (len         (match version (4 20) (5 32)) )
                     (fingerprint (make-bytevector len)))
                (bytevector-copy! data 1 fingerprint 0 len)
                fingerprint)))
       ((= type SUBPACKET-NOTATION-DATA)
        (let ((p (open-bytevector-input-port data)))
          (let-values (((f1 nlen vlen)
                        (get-integers p u8 _ _ _ u16 u16)))
            (let* ((name (get-bytevector-n p nlen))
                   (value (get-bytevector-n p vlen)))
              (cons 'notation-data
                    (list (utf8->string name)
                          (if (fxbit-set? f1 7)
                              (utf8->string value)
                              value)))))))
       ((= type SUBPACKET-PREFERRED-HASH-ALGORITHMS)
        (cons 'preferred-hash-algorithms
              (map (cut openpgp-hash-algorithm <> signature-port)
                   (bytevector->u8-list data))))
       ((= type SUBPACKET-PREFERRED-COMPRESSION-ALGORITHMS)
        (cons 'preferred-compression-algorithms
              (map compression-algorithm (bytevector->u8-list data))))
       ((= type SUBPACKET-KEY-SERVER-PREFERENCES)
        (cons 'key-server-preferences
              (if (and (>= (bytevector-length data) 1)
                       (fxbit-set? (bytevector-u8-ref data 0) 7))
                  (list 'no-modify)
                  (list))))
       ((= type SUBPACKET-PREFERRED-KEY-SERVER)
        (cons 'preferred-key-server (utf8->string data)))
       ((= type SUBPACKET-PRIMARY-USER-ID)
        (cons 'primary-user-id (not (zero? (bytevector-u8-ref data 0)))))
       ((= type SUBPACKET-POLICY-URI)
        (cons 'policy-uri (utf8->string data)))
       ((= type SUBPACKET-KEY-FLAGS)
        (cons 'key-flags (bytevector->bitnames
                          data
                          '(certification sign-data
                                          communications-encryption
                                          storage-encryption
                                          split-key authentication
                                          group-key))))
       ((= type SUBPACKET-SIGNER-USER-ID)
        (cons 'signer-user-id (utf8->string data)))
       ((= type SUBPACKET-REASON-FOR-REVOCATION)
        (let* ((p (open-bytevector-input-port data))
               (revocation-code (get-u8 p)))
          (cons 'reason-for-revocation
                (list revocation-code
                      (if (port-eof? p)
                          ""
                          (utf8->string (get-bytevector-all p)))))))
       ((= type SUBPACKET-FEATURES)
        (cons 'features (bytevector->bitnames
                         data '(modification-detection))))
       ((= type SUBPACKET-EMBEDDED-SIGNATURE)
        (cons 'embedded-signature
              (get-signature (open-bytevector-input-port data))))
       (else
        ;; Unknown subpacket type.  If it is critical, then the signature
        ;; should be considered invalid.
        (print "Unknown subpacket type: " type)
        (if critical?
            (raise (condition
                    (&openpgp-unrecognized-packet-error
                     (port signature-port))))
            (list 'unsupported-subpacket type data))))))

  (let ((p (open-bytevector-input-port bv)))
    (let lp ((subpackets '()))
      ;; In case of multiple subpackets of the same type, the last
      ;; one should be used. Therefore the list is not reversed
      ;; here.
      (if (port-eof? p)
          (reverse subpackets)
          (let* ((len (- (get-v4-length p) 1))
                 (tag (get-u8 p))
                 (sp (parse tag (get-bytevector-n p len))))
            (print "#;Subpacket " sp)
            (lp (cons sp subpackets)))))))

;;; Public keys

(define (openpgp-public-key-id k)
  (let ((bv (openpgp-public-key-fingerprint k)))
    (bytevector-u64-ref bv
                        (- (bytevector-length bv) 8)
                        (endianness big))))

(define (get-public-key p subkey?)
  (define (fingerprint p)
    (let ((len (port-position p)))
      (set-port-position! p 0)
      (let-values (((sha1-port get)
                    (open-hash-port (hash-algorithm sha1))))
        (put-u8 sha1-port #x99)
        (put-u16 sha1-port len)
        (dump-port p sha1-port)
        (close-port sha1-port)
        (get))))
  (define (get-key p alg)
    (define (->hex n)
      (string-hex-pad (number->string n 16)))

    (cond ((= alg PUBLIC-KEY-RSA)
           (print "Public RSA key")
           (let* ((n (get-mpi p)) (e (get-mpi p)))
             (string->canonical-sexp
              (format #f "(public-key (rsa (n #~a#) (e #~a#)))"
                      (->hex n) (->hex e)))))
          ((= alg PUBLIC-KEY-DSA)
           (print "Public DSA key")
           (let* ((p* (get-mpi p)) (q (get-mpi p))
                  (g (get-mpi p)) (y (get-mpi p)))
             (string->canonical-sexp
              (format #f "(public-key (dsa (p #~a#)(q #~a#)(g #~a#)(y #~a#)))"
                      (->hex p*) (->hex q) (->hex g) (->hex y)))))
          #;
          ((= alg PUBLIC-KEY-ELGAMAL-ENCRYPT-ONLY) ; ; ; ;
          (print "Public El-Gamal Key")         ; ; ; ;
          (let* ((p* (get-mpi p)) (g (get-mpi p)) (y (get-mpi p))) ; ; ; ;
          (make-public-elgamal-key p* g y)))
          ((= alg PUBLIC-KEY-EDDSA)
           ;; See
           ;; <https://tools.ietf.org/html/draft-koch-eddsa-for-openpgp-04>
           ;; and openpgp-oid.c in GnuPG.
           (print "Public EdDSA key")
           (let* ((len     (get-u8 p))
                  (oid     (bytevector->uint (get-bytevector-n p len)))
                  (q (get-mpi p)))
             (define curve
               (match oid
                 (#x2b06010401da470f01   'Ed25519)
                 (#x2b060104019755010501 'Curve25519)))

             (string->canonical-sexp
              (format #f "(public-key (ecc (curve ~a)(flags ~a)(q #~a#)))"
                      curve
                      (if (eq? curve 'Curve25519) 'djb-tweak 'eddsa)
                      (->hex q)))))
          (else
           (list 'unsupported-algorithm           ;FIXME: throw
                 (public-key-algorithm alg)
                 (get-bytevector-all p)))))
  (let ((version (get-u8 p)))
    (case version
      ((4)
       (let-values (((ctime alg) (get-integers p u32 u8)))
         (print "Key creation time: " (unixtime ctime))
         (let ((key (get-key p alg)))
           (unless (port-eof? p)
             ;; Probably an error? Gonna cause trouble anyway.
             (print "Trailing data in public key: " (get-bytevector-all p)))
           (let ((digest (fingerprint p)))
             (make-openpgp-public-key version subkey? ctime key
                                      digest)))))
      (else
       (print "Unsupported public key version: " version)
       'unsupported-public-key-version))))

(define (openpgp-public-key-primary? key)
  (and (openpgp-public-key? key)
       (not (openpgp-public-key-subkey? key))))

;;; User IDs and User attributes

(define-record-type <openpgp-user-id>
  (make-openpgp-user-id value unparsed)
  openpgp-user-id?
  (value     openpgp-user-id-value)
  (unparsed  openpgp-user-id-unparsed))

(define (get-user-id p len)
  (let ((unparsed (get-bytevector-n p len)))
    (make-openpgp-user-id (utf8->string unparsed) unparsed)))

(define-record-type <openpgp-user-attribute>
  (make-openpgp-user-attribute unparsed)
  openpgp-user-attribute?
  (unparsed   openpgp-user-attribute-unparsed))

(define (get-user-attribute p len)
  (let ((bv (get-bytevector-n p len)))
    ;; TODO: bv contains subpackets. Type 1 is JFIF.
    (make-openpgp-user-attribute bv)))

;;; Keyring management

(define-record-type <openpgp-keyring>
  (openpgp-keyring ids fingerprints)
  openpgp-keyring?
  (ids            openpgp-keyring-ids)        ;vhash mapping key id to packets
  (fingerprints   openpgp-keyring-fingerprints)) ;mapping fingerprint to packets

(define* (keyring-insert key keyring #:optional (packets '()))
  "Insert the KEY/PACKETS association into KEYRING and return the resulting
keyring.  PACKETS typically contains KEY, an <openpgp-public-key>, alongside
with additional <openpgp-public-key> records for sub-keys, <openpgp-user-id>
records, and so on."
  (openpgp-keyring (vhash-consv (openpgp-public-key-id key)
                                (cons key packets)
                                (openpgp-keyring-ids keyring))
                   (vhash-cons (openpgp-public-key-fingerprint key)
                               (cons key packets)
                               (openpgp-keyring-fingerprints keyring))))

(define (lookup-key-by-id keyring id)
  "Return two values: the first key with ID in KEYRING, and a list of
associated packets (user IDs, signatures, etc.).  Return #f and the empty list
of ID was not found.  ID must be the 64-bit key ID of the key, an integer."
  (match (vhash-assv id (openpgp-keyring-ids keyring))
    ((_ key packets ...) (values key packets))
    (#f (values #f '()))))

(define (lookup-key-by-fingerprint keyring fingerprint)
  "Return two values: the key with FINGERPRINT in KEYRING, and a list of
associated packets (user IDs, signatures, etc.).  Return #f and the empty list
of FINGERPRINT was not found.  FINGERPRINT must be a bytevector."
  (match (vhash-assoc fingerprint (openpgp-keyring-fingerprints keyring))
    ((_ key packets ...) (values key packets))
    (#f (values #f '()))))

;; Reads a keyring from the binary input port p. It must not be
;; ASCII armored.

(define %empty-keyring
  ;; The empty keyring.
  (openpgp-keyring vlist-null vlist-null))

(define* (get-openpgp-keyring port
                              #:optional (keyring %empty-keyring)
                              #:key (limit -1))
  "Read from PORT an OpenPGP keyring in binary format; return a keyring based
on all the OpenPGP primary keys that were read.  The returned keyring
complements KEYRING.  LIMIT is the maximum number of keys to read, or -1 if
there is no limit."
  (let lp ((pkt (get-packet port))
           (limit limit)
           (keyring keyring))
    (print "#;key " pkt)
    (cond ((or (zero? limit) (eof-object? pkt))
           keyring)
          ((openpgp-public-key-primary? pkt)
           ;; Read signatures, user id's, subkeys
           (let lp* ((pkt  (get-packet port))
                     (pkts (list pkt))
                     (keys (list pkt)))
             (print "#;keydata " pkt)
             (cond ((or (eof-object? pkt)
                        (eq? pkt 'unsupported-public-key-version)
                        (openpgp-public-key-primary? pkt))
                    ;; KEYRING is indexed by key-id.  Key ids for both the
                    ;; primary key and subkeys all point to the list of
                    ;; packets.
                    (lp pkt
                        (- limit 1)
                        (fold (cute keyring-insert <> <> (reverse pkts))
                              keyring keys)))
                   ((openpgp-public-key? pkt)     ;subkey
                    (lp* (get-packet port) (cons pkt pkts)
                         (cons pkt keys)))
                   (else
                    (lp* (get-packet port) (cons pkt pkts) keys)))))
          (else
           ;; Skip until there's a primary key. Ignore errors...
           (lp (get-packet port) limit keyring)))))

;;;
;;; Radix-64 (RFC4880).
;;;

(define (crc24 bv)
  "Compute a CRC24 as described in RFC4880, Section 6.1."
  ;; We used to have it implemented in Scheme but the C version here makes
  ;; 'load-keyring-from-reference' 18% faster when loading the 72
  ;; ASCII-armored files of today's Guix keyring.
  (bytevector->uint (bytevector-hash bv (hash-algorithm crc24-rfc2440))))

(define %begin-block-prefix "-----BEGIN ")
(define %begin-block-suffix "-----")

(define %end-block-prefix "-----END ")
(define %end-block-suffix "-----")

(define (read-radix-64 port)
  "Read from PORT an ASCII-armored Radix-64 stream, decode it, and return the
result as a bytevector as well as the type, a string such as \"PGP MESSAGE\".
Return #f if PORT does not contain a valid Radix-64 stream, and the
end-of-file object if the Radix-64 sequence was truncated."
  ;; This is the same as 'get-delimited-base64', except that it implements the
  ;; CRC24 check.
  (define (skip-headers port)
    ;; Skip the Radix-64 "armor headers".
    (match (read-line port)
      ((? eof-object? eof) eof)
      ((= string-trim-both "") "")
      (_  (skip-headers port))))

  (let ((line (string-trim-right (read-line port))))
    (if (and (string-prefix? %begin-block-prefix line)
             (string-suffix? %begin-block-suffix line))
        (let* ((kind (string-drop-right
                      (string-drop line (string-length %begin-block-prefix))
                      (string-length %begin-block-suffix)))
               (end  (string-append %end-block-prefix kind
                                    %end-block-suffix)))
          (skip-headers port)
          (let loop ((lines '()))
            (let ((line (read-line port)))
              (match line
                ((? eof-object? eof)
                 (values eof kind))
                ((= string-trim-both "")
                 (loop lines))
                ((= string-trim-both str)
                 (if (string=? str end)
                     (match lines
                       ((crc lines ...)
                        ;; The last line should be the CRC, starting with an
                        ;; "=" sign.
                        (let ((crc  (and (string-prefix? "=" crc)
                                         (base64-decode (string-drop crc 1))))
                              (data (base64-decode
                                     (string-concatenate-reverse lines))))
                          (if (and crc (= (bytevector->uint crc) (crc24 data)))
                              (values data kind)
                              (values #f kind))))
                       (_
                        (values #f kind)))
                     (loop (cons str lines))))))))
        (values #f #f))))

(define (string->openpgp-packet str)
  "Read STR, an ASCII-armored OpenPGP packet, and return the corresponding
OpenPGP record."
  (get-packet
   (open-bytevector-input-port (call-with-input-string str read-radix-64))))