From 9ada791f1eecb68a850d5526ca511b1ad0c20e87 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Sun, 31 Jan 2021 10:57:23 +0100 Subject: [PATCH 1/2] DRAFT: Support hooks for adding extra entries to the narinfo TODO: documentation, perhaps a news channel entry, a service extension for guix-publish and tests. * guix/scripts/publish.scm (show-help, %options): Add '--hooks' option. (narinfo-string, render-narinfo, make-request-handler) (render-narinfo/cached, bake-narinfo+nar) (run-publish-server): Add '#:hooks' argument. (render-narinfo): Ask 'hooks-info' for extra narinfo key-value pairs. (guix-publish): Loading narinfo hooks with 'load-hooks'. (): New record type for narinfo hooks. (load-hooks): New procedure loading hooks from source, or from compiled .go. (hooks-info): New procedure, asking each hook for extra key-vaue pairs. --- guix/scripts/publish.scm | 106 ++++++++++++++++++++++++++++++++++----- 1 file changed, 94 insertions(+), 12 deletions(-) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index fa85088ed0..a9018d3fde 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2020 by Amar M. Singh ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -47,6 +48,7 @@ #:use-module (guix base64) #:use-module (guix config) #:use-module (guix derivations) + #:use-module (guix records) #:use-module (gcrypt hash) #:use-module (guix pki) #:use-module (gcrypt pk-crypto) @@ -75,7 +77,11 @@ open-server-socket publish-service-type run-publish-server - guix-publish)) + guix-publish + + narinfo-hook + narinfo-hook? + narinfo-hook-extra-info)) (define (show-help) (format #t (G_ "Usage: guix publish [OPTION]... @@ -108,6 +114,8 @@ Publish ~a over HTTP.\n") %store-directory) --private-key=FILE use FILE as the private key for signatures")) (display (G_ " -r, --repl[=PORT] spawn REPL server on PORT")) + (display (G_" + --hooks=FILE.go load hooks from FILE.go")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -236,7 +244,10 @@ usage." (lambda (opt name arg result) ;; If port unspecified, use default Guile REPL port. (let ((port (and arg (string->number* arg)))) - (alist-cons 'repl (or port 37146) result)))))) + (alist-cons 'repl (or port 37146) result)))) + (option '("hooks") #f #t + (lambda (opt name arg result) + (alist-cons 'hook arg result))))) (define %default-options `((port . 8080) @@ -309,7 +320,9 @@ with COMPRESSION, starting at NAR-PATH." url (compression-type compression) file-size))) (define* (narinfo-string store store-path key - #:key (compressions (list %no-compression)) + #:key + (hooks '()) + (compressions (list %no-compression)) (nar-path "nar") (file-sizes '())) "Generate a narinfo key/value string for STORE-PATH; an exception is raised if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The @@ -317,7 +330,10 @@ narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs. Optionally, FILE-SIZES is a list of compression/integer pairs, where the integer is size in bytes of the compressed NAR; it informs the client of how -much needs to be downloaded." +much needs to be downloaded. + +If present, each narinfo hooks in HOOKS is called and the resulting +key/value pairs are added to the narinfo." (let* ((path-info (query-path-info store store-path)) (compressions (actual-compressions store-path compressions)) (hash (bytevector->nix-base32-string @@ -346,22 +362,24 @@ References: ~a~%" compression))) compressions) hash size references)) + (extra-info (hooks-info hooks path-info)) ;; Do not render a "Deriver" or "System" line if we are rendering ;; info for a derivation. (info (if (not deriver) - base-info + (format #f "~a~a" base-info extra-info) (catch 'system-error (lambda () (let ((drv (read-derivation-from-file deriver))) - (format #f "~aSystem: ~a~%Deriver: ~a~%" - base-info (derivation-system drv) + (format #f "~a~aSystem: ~a~%Deriver: ~a~%" + base-info extra-info + (derivation-system drv) (basename deriver)))) (lambda args ;; DERIVER might be missing, but that's fine: ;; it's only used for where it's ;; optional. 'System' is currently unused. (if (= ENOENT (system-error-errno args)) - base-info + (format #f "~a~a" base-info extra-info) (apply throw args)))))) (signature (base64-encode-string (canonical-sexp->string (signed-string info))))) @@ -388,7 +406,9 @@ References: ~a~%" %nix-cache-info)))) (define* (render-narinfo store request hash - #:key ttl (compressions (list %no-compression)) + #:key + (hooks '()) + ttl (compressions (list %no-compression)) (nar-path "nar")) "Render metadata for the store path corresponding to HASH. If TTL is true, advertise it as the maximum validity period (in seconds) via the @@ -403,6 +423,7 @@ appropriate duration. NAR-PATH specifies the prefix for nar URLs." '())) (cut display (narinfo-string store store-path (%private-key) + #:hooks hooks #:nar-path nar-path #:compressions compressions) <>))))) @@ -510,7 +531,9 @@ interpreted as the basename of a store item." (cache-bypass-threshold)))) (define* (render-narinfo/cached store request hash - #:key ttl (compressions (list %no-compression)) + #:key + (hooks '()) + ttl (compressions (list %no-compression)) (nar-path "nar") cache pool) "Respond to the narinfo request for REQUEST. If the narinfo is available in @@ -556,6 +579,7 @@ requested using POOL." (unless (file-exists? cached) ;; (format #t "baking ~s~%" item) (bake-narinfo+nar cache item + #:hooks hooks #:ttl ttl #:compressions compressions #:nar-path nar-path))) @@ -576,6 +600,7 @@ requested using POOL." ;; client asks for it. (if (bypass-cache? store item) (render-narinfo store request hash + #:hooks hooks #:ttl 300 ;temporary #:nar-path nar-path #:compressions compressions) @@ -617,7 +642,9 @@ requested using POOL." (chmod port (logand #o644 (lognot (umask))))))))) (define* (bake-narinfo+nar cache item - #:key ttl (compressions (list %no-compression)) + #:key + (hooks '()) + ttl (compressions (list %no-compression)) (nar-path "/nar")) "Write the narinfo and nar for ITEM to CACHE." (define (compressed-nar-size compression) @@ -643,6 +670,7 @@ requested using POOL." (let ((sizes (filter-map compressed-nar-size compression))) (display (narinfo-string store item (%private-key) + #:hooks hooks #:nar-path nar-path #:compressions compressions #:file-sizes sizes) @@ -972,6 +1000,7 @@ methods, return the applicable compression." (define* (make-request-handler store #:key + (hooks '()) cache pool narinfo-ttl (nar-path "nar") @@ -1002,12 +1031,14 @@ methods, return the applicable compression." (((= extract-narinfo-hash (? string? hash))) (if cache (render-narinfo/cached store request hash + #:hooks hooks #:cache cache #:pool pool #:ttl narinfo-ttl #:nar-path nar-path #:compressions compressions) (render-narinfo store request hash + #:hooks hooks #:ttl narinfo-ttl #:nar-path nar-path #:compressions compressions))) @@ -1065,6 +1096,7 @@ methods, return the applicable compression." (define* (run-publish-server socket store #:key + (hooks '()) advertise? port (compressions (list %no-compression)) (nar-path "nar") narinfo-ttl @@ -1079,6 +1111,7 @@ methods, return the applicable compression." #:port port))) (run-server (make-request-handler store + #:hooks hooks #:cache cache #:pool pool #:nar-path nar-path @@ -1106,6 +1139,49 @@ methods, return the applicable compression." (lambda (key proc message args . rest) (leave (G_ "user '~a' not found: ~a~%") user (apply format #f message args))))) + +;;; +;;; Hooks. +;;; + +;; Hook for adding extra key-value pairs to +;; the generated narinfo. +(define-record-type + (narinfo-hook extra-info) + narinfo-hook? + ;; pathinfo -> alist. Should accept + ;; rest arguments for future extensibility. + (extra-info narinfo-hook-extra-info)) + +(define (load-hooks hook-file) + "Load hooks from HOOK-FILE. The code in HOOK-FILE +must evaluate to a list of hooks." + (let ((hooks + (cond ((string-suffix? ".go" hook-file) ; compiled + (load-compiled hook-file)) + ((string-suffix? ".scm" hook-file) ; source code + (load hook-file)) + (#t (leave (G_ "file '~a' is not a Scheme file~%") + hook-file))))) + ;; Validate whether @var{hooks} are, in fact, hooks. + (for-each (lambda (hook) + (unless (narinfo-hook? hook) + (leave (G_ "'~a' is not a hook~%") + hook))) + hooks) + hooks)) + +(define (hooks-info hooks pathinfo) + "Ask HOOKS for extra narinfo key/value pairs." + (let ((alist + (append-map (lambda (hook) ((narinfo-hook-extra-info hook) pathinfo)) + hooks))) + (call-with-output-string + (lambda (port) + (for-each (lambda (key+value) + (format port "~a: ~a~%" + (car key+value) (cdr key+value))) + alist))))) ;;; @@ -1149,8 +1225,13 @@ methods, return the applicable compression." ;; Read the key right away so that (1) we fail early on if we can't ;; access them, and (2) we can then drop privileges. (public-key (read-file-sexp (assoc-ref opts 'public-key-file))) - (private-key (read-file-sexp (assoc-ref opts 'private-key-file)))) + (private-key (read-file-sexp (assoc-ref opts 'private-key-file))) + (hooks (concatenate (filter-map (match-lambda + (('hook . hook-file) + (load-hooks hook-file)) + (_ #f)) + opts)))) (when user ;; Now that we've read the key material and opened the socket, we can ;; drop privileges. @@ -1185,6 +1266,7 @@ consider using the '--user' option!~%"))) (with-store store (run-publish-server socket store #:advertise? advertise? + #:hooks hooks #:port port #:cache cache #:pool (and cache (make-pool workers -- 2.30.0