guix/scripts/authenticate.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix scripts authenticate)
  20   #:use-module (guix scripts)
  21   #:use-module (guix base16)
  22   #:use-module (gcrypt pk-crypto)
  23   #:use-module (guix pki)
  24   #:use-module (guix ui)
  25   #:use-module (guix diagnostics)
  26   #:use-module (srfi srfi-34)
  27   #:use-module (srfi srfi-35)
  28   #:use-module (srfi srfi-71)
  29   #:use-module (rnrs bytevectors)
  30   #:use-module (ice-9 binary-ports)
  31   #:use-module (ice-9 rdelim)
  32   #:use-module (ice-9 match)
  33   #:use-module (ice-9 vlist)
  34   #:use-module (ice-9 iconv)
  35   #:export (guix-authenticate))
  36
  37 ;;; Commentary:
  38 ;;;
  39 ;;; This program is used internally by the daemon to sign exported archive
  40 ;;; (the 'export-paths' RPC), and to authenticate imported archives (the
  41 ;;; 'import-paths' RPC.)
  42 ;;;
  43 ;;; Code:
  44
  45 (define read-canonical-sexp
  46   ;; Read a gcrypt sexp from a port and return it.
  47   (compose string->canonical-sexp read-string))
  48
  49 (define (load-key-pair key-file)
  50   "Load the key pair whose secret key lives at KEY-FILE.  Return a pair of
  51 canonical sexps representing those keys."
  52   (catch 'system-error
  53     (lambda ()
  54       (let* ((secret-key (call-with-input-file key-file read-canonical-sexp))
  55              (public-key (call-with-input-file
  56                              (string-append (string-drop-right key-file 4)
  57                                             ".pub")
  58                            read-canonical-sexp)))
  59         (cons public-key secret-key)))
  60     (lambda args
  61       (let ((errno (system-error-errno args)))
  62         (raise
  63          (formatted-message
  64           (G_ "failed to load key pair at '~a': ~a~%")
  65           key-file (strerror errno)))))))
  66
  67 (define (sign-with-key public-key secret-key sha256)
  68   "Sign the hash SHA256 (a bytevector) with SECRET-KEY (a canonical sexp), and
  69 return the signature as a canonical sexp that includes SHA256, PUBLIC-KEY, and
  70 the actual signature."
  71   (let ((data (bytevector->hash-data sha256
  72                                      #:key-type (key-type public-key))))
  73     (signature-sexp data secret-key public-key)))
  74
  75 (define (validate-signature signature acl)
  76   "Validate SIGNATURE, a canonical sexp.  Check whether its public key is
  77 authorized in ACL, verify the signature, and return the signed data (a
  78 bytevector) upon success."
  79   (let* ((subject (signature-subject signature))
  80          (data    (signature-signed-data signature)))
  81     (if (and data subject)
  82         (if (authorized-key? subject acl)
  83             (if (valid-signature? signature)
  84                 (hash-data->bytevector data)      ; success
  85                 (raise
  86                  (formatted-message (G_ "invalid signature: ~a")
  87                                     (canonical-sexp->string signature))))
  88             (raise
  89              (formatted-message (G_ "unauthorized public key: ~a")
  90                                 (canonical-sexp->string subject))))
  91         (raise
  92          (formatted-message (G_ "corrupt signature data: ~a")
  93                             (canonical-sexp->string signature))))))
  94
  95 (define (read-command port)
  96   "Read a command from PORT and return the command and arguments as a list of
  97 strings.  Return the empty list when the end-of-file is reached.
  98
  99 Commands are newline-terminated and must look something like this:
 100
 101   COMMAND 3:abc 5:abcde 1:x
 102
 103 where COMMAND is an alphanumeric sequence and the remainder is the command
 104 arguments.  Each argument is written as its length (in characters), followed
 105 by colon, followed by the given number of characters."
 106   (define (consume-whitespace port)
 107     (let ((chr (lookahead-u8 port)))
 108       (when (eqv? chr (char->integer #\space))
 109         (get-u8 port)
 110         (consume-whitespace port))))
 111
 112   (match (read-delimited " \t\n\r" port)
 113     ((? eof-object?)
 114      '())
 115     (command
 116      (let loop ((result (list command)))
 117        (consume-whitespace port)
 118        (let ((next (lookahead-u8 port)))
 119          (cond ((eqv? next (char->integer #\newline))
 120                 (get-u8 port)
 121                 (reverse result))
 122                ((eof-object? next)
 123                 (reverse result))
 124                (else
 125                 (let* ((len (string->number (read-delimited ":" port)))
 126                        (str (bytevector->string
 127                              (get-bytevector-n port len)
 128                              "ISO-8859-1" 'error)))
 129                   (loop (cons str result))))))))))
 130
 131 (define-syntax define-enumerate-type              ;TODO: factorize
 132   (syntax-rules ()
 133     ((_ name->int (name id) ...)
 134      (define-syntax name->int
 135        (syntax-rules (name ...)
 136          ((_ name) id) ...)))))
 137
 138 ;; Codes used when reply to requests.
 139 (define-enumerate-type reply-code
 140   (success 0)
 141   (command-not-found 404)
 142   (command-failed 500))
 143
 144 \f
 145 ;;;
 146 ;;; Entry point.
 147 ;;;
 148
 149 (define-command (guix-authenticate . args)
 150   (category internal)
 151   (synopsis "sign or verify signatures on normalized archives (nars)")
 152
 153   (define (send-reply code str)
 154     ;; Send CODE and STR as a reply to our client.
 155     (let ((bv (string->bytevector str "ISO-8859-1" 'error)))
 156       (format #t "~a ~a:" code (bytevector-length bv))
 157       (put-bytevector (current-output-port) bv)
 158       (force-output (current-output-port))))
 159
 160   (define (call-with-reply thunk)
 161     ;; Send a reply for the result of THUNK or for any exception raised during
 162     ;; its execution.
 163     (guard (c ((formatted-message? c)
 164                (send-reply (reply-code command-failed)
 165                            (apply format #f
 166                                   (G_ (formatted-message-string c))
 167                                   (formatted-message-arguments c)))))
 168       (send-reply (reply-code success) (thunk))))
 169
 170   (define-syntax-rule (with-reply exp ...)
 171     (call-with-reply (lambda () exp ...)))
 172
 173   ;; Signature sexps written to stdout may contain binary data, so force
 174   ;; ISO-8859-1 encoding so that things are not mangled.  See
 175   ;; <http://bugs.gnu.org/17312> for details.
 176   (set-port-encoding! (current-output-port) "ISO-8859-1")
 177   (set-port-conversion-strategy! (current-output-port) 'error)
 178
 179   ;; Same goes for input ports.
 180   (with-fluids ((%default-port-encoding "ISO-8859-1")
 181                 (%default-port-conversion-strategy 'error))
 182     (match args
 183       (("--help")
 184        (display (G_ "Usage: guix authenticate OPTION...
 185 Sign data or verify signatures.  This tool is meant to be used internally by
 186 'guix-daemon'.\n")))
 187       (("--version")
 188        (show-version-and-exit "guix authenticate"))
 189       (()
 190        (let ((acl (current-acl)))
 191          (let loop ((key-pairs vlist-null))
 192            ;; Read a request on standard input and reply.
 193            (match (read-command (current-input-port))
 194              (("sign" signing-key (= base16-string->bytevector hash))
 195               (let* ((key-pairs keys
 196                                 (match (vhash-assoc signing-key key-pairs)
 197                                   ((_ . keys)
 198                                    (values key-pairs keys))
 199                                   (#f
 200                                    (let ((keys (load-key-pair signing-key)))
 201                                      (values (vhash-cons signing-key keys
 202                                                          key-pairs)
 203                                              keys))))))
 204                 (with-reply (canonical-sexp->string
 205                              (match keys
 206                                ((public . secret)
 207                                 (sign-with-key public secret hash)))))
 208                 (loop key-pairs)))
 209              (("verify" signature)
 210               (with-reply (bytevector->base16-string
 211                            (validate-signature
 212                             (string->canonical-sexp signature)
 213                             acl)))
 214               (loop key-pairs))
 215              (()
 216               (exit 0))
 217              (commands
 218               (warning (G_ "~s: invalid command; ignoring~%") commands)
 219               (send-reply (reply-code command-not-found)
 220                           "invalid command")
 221               (loop key-pairs))))))
 222       (_
 223        (leave (G_ "wrong arguments~%"))))))
 224
 225 ;;; authenticate.scm ends here