diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/scripts/authenticate.scm | 138 |
1 files changed, 108 insertions, 30 deletions
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index 37e6cef53c..dc73981092 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -22,6 +22,10 @@ #:use-module (gcrypt pk-crypto) #:use-module (guix pki) #:use-module (guix ui) + #:use-module (guix diagnostics) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) @@ -40,41 +44,90 @@ (compose string->canonical-sexp read-string)) (define (sign-with-key key-file sha256) - "Sign the hash SHA256 (a bytevector) with KEY-FILE, and write an sexp that -includes both the hash and the actual signature." + "Sign the hash SHA256 (a bytevector) with KEY-FILE, and return the signature +as a canonical sexp that includes both the hash and the actual signature." (let* ((secret-key (call-with-input-file key-file read-canonical-sexp)) (public-key (if (string-suffix? ".sec" key-file) (call-with-input-file (string-append (string-drop-right key-file 4) ".pub") read-canonical-sexp) - (leave - (G_ "cannot find public key for secret key '~a'~%") - key-file))) + (raise + (formatted-message + (G_ "cannot find public key for secret key '~a'~%") + key-file)))) (data (bytevector->hash-data sha256 #:key-type (key-type public-key))) (signature (signature-sexp data secret-key public-key))) - (display (canonical-sexp->string signature)) - #t)) + signature)) (define (validate-signature signature) "Validate SIGNATURE, a canonical sexp. Check whether its public key is -authorized, verify the signature, and print the signed data to stdout upon -success." +authorized, verify the signature, and return the signed data (a bytevector) +upon success." (let* ((subject (signature-subject signature)) (data (signature-signed-data signature))) (if (and data subject) (if (authorized-key? subject) (if (valid-signature? signature) - (let ((hash (hash-data->bytevector data))) - (display (bytevector->base16-string hash)) - #t) ; success - (leave (G_ "error: invalid signature: ~a~%") - (canonical-sexp->string signature))) - (leave (G_ "error: unauthorized public key: ~a~%") - (canonical-sexp->string subject))) - (leave (G_ "error: corrupt signature data: ~a~%") - (canonical-sexp->string signature))))) + (hash-data->bytevector data) ; success + (raise + (formatted-message (G_ "invalid signature: ~a") + (canonical-sexp->string signature)))) + (raise + (formatted-message (G_ "unauthorized public key: ~a") + (canonical-sexp->string subject)))) + (raise + (formatted-message (G_ "corrupt signature data: ~a") + (canonical-sexp->string signature)))))) + +(define (read-command port) + "Read a command from PORT and return the command and arguments as a list of +strings. Return the empty list when the end-of-file is reached. + +Commands are newline-terminated and must look something like this: + + COMMAND 3:abc 5:abcde 1:x + +where COMMAND is an alphanumeric sequence and the remainder is the command +arguments. Each argument is written as its length (in characters), followed +by colon, followed by the given number of characters." + (define (consume-whitespace port) + (let ((chr (lookahead-u8 port))) + (when (eqv? chr (char->integer #\space)) + (get-u8 port) + (consume-whitespace port)))) + + (match (read-delimited " \t\n\r" port) + ((? eof-object?) + '()) + (command + (let loop ((result (list command))) + (consume-whitespace port) + (let ((next (lookahead-u8 port))) + (cond ((eqv? next (char->integer #\newline)) + (get-u8 port) + (reverse result)) + ((eof-object? next) + (reverse result)) + (else + (let* ((len (string->number (read-delimited ":" port))) + (str (utf8->string + (get-bytevector-n port len)))) + (loop (cons str result)))))))))) + +(define-syntax define-enumerate-type ;TODO: factorize + (syntax-rules () + ((_ name->int (name id) ...) + (define-syntax name->int + (syntax-rules (name ...) + ((_ name) id) ...))))) + +;; Codes used when reply to requests. +(define-enumerate-type reply-code + (success 0) + (command-not-found 404) + (command-failed 500)) ;;; @@ -85,6 +138,13 @@ success." (category internal) (synopsis "sign or verify signatures on normalized archives (nars)") + (define (send-reply code str) + ;; Send CODE and STR as a reply to our client. + (let ((bv (string->utf8 str))) + (format #t "~a ~a:" code (bytevector-length bv)) + (put-bytevector (current-output-port) bv) + (force-output (current-output-port)))) + ;; Signature sexps written to stdout may contain binary data, so force ;; ISO-8859-1 encoding so that things are not mangled. See ;; <http://bugs.gnu.org/17312> for details. @@ -95,21 +155,39 @@ success." (with-fluids ((%default-port-encoding "ISO-8859-1") (%default-port-conversion-strategy 'error)) (match args - (("sign" key-file hash) - (sign-with-key key-file (base16-string->bytevector hash))) - (("verify" signature-file) - (call-with-input-file signature-file - (lambda (port) - (validate-signature (string->canonical-sexp - (read-string port)))))) - (("--help") (display (G_ "Usage: guix authenticate OPTION... -Sign or verify the signature on the given file. This tool is meant to -be used internally by 'guix-daemon'.\n"))) +Sign data or verify signatures. This tool is meant to be used internally by +'guix-daemon'.\n"))) (("--version") (show-version-and-exit "guix authenticate")) - (else - (leave (G_ "wrong arguments")))))) + (() + (let loop () + (guard (c ((formatted-message? c) + (send-reply (reply-code command-failed) + (apply format #f + (G_ (formatted-message-string c)) + (formatted-message-arguments c))))) + ;; Read a request on standard input and reply. + (match (read-command (current-input-port)) + (("sign" signing-key (= base16-string->bytevector hash)) + (let ((signature (sign-with-key signing-key hash))) + (send-reply (reply-code success) + (canonical-sexp->string signature)))) + (("verify" signature) + (send-reply (reply-code success) + (bytevector->base16-string + (validate-signature + (string->canonical-sexp signature))))) + (() + (exit 0)) + (commands + (warning (G_ "~s: invalid command; ignoring~%") commands) + (send-reply (reply-code command-not-found) + "invalid command")))) + + (loop))) + (_ + (leave (G_ "wrong arguments~%")))))) ;;; authenticate.scm ends here |