Subject: [bug#46214] [PATCH] DRAFT: narinfo hooks for ‘guix publish’

From: Maxime Devos <[email-masked]>
Date: Sun, 31 Jan 2021 12:11:25 +0100

Hello Guix!

I've a proposal to make ‘guix publish’ somewhat extensible.
The draft patch allows for passing a list of ‘hooks’ to guix
publish, with "guix publish --hooks=FILE-WITH-HOOKS.scm
--hooks=MORE-HOOKS.go".  "guix publish" then will consult
this list of hooks at some points.

I've defined a ‘narinfo-hook’, which allows adding extra
key value pairs to the generated narinfos.  See the last
patch that adds a ‘hook.scm’ file for a silly example
that includes a random number and some arbitrary strings.

A TODO for a future revision of the patch, is modifying
‘guix-publish-service-type’ to allow passing a list of
hooks (as gexps).

The use case I had in mind: this could be used for Guix+IPFS
and Guix+GNUnet integration (at least on the "guix publish"
side), by implementing a hook that inserts the store item
into IPFS and GNUnet respectively, and add an appropriate
IPFS and GNUnet URI.

(I'll look into appropriate "guix substitute" hooks
later.)

Guix+IPFS and Guix+GNUnet integrations could of course
use a forked guix (until the integration is merged
upstream when it is in a good state), but a hook system
seems more practical for experimentation to me.

(Also, if hypothetically, in the future "guix publish" supports,
say, IPFS, GNUnet, BitTorrent and Dat, then using the approach
of wip-ipfs-substitutes, there would be four keyword
arguments that need to be passed everywhere.  This patch
only passes a single #:hooks argument.)

Also a question for guix-devel: the wip-ipfs-substitutes
patch adds the "IPFS: etcetera" line *after* the signed
part, while this patch only allows for addings key-value
pairs that will be signed.  Would it be problematic for
the "IPFS: etcetera" or "GNUnet: etcetera" line to be
signed?

If this proposal seems OK to guix-devel, I'll write up
some documentation, tests and changes to
guix-publish-service-type.

(Patch can also be found as signed tag wip-publish-narinfo-hook0
at https://notabug.org/mdevos/guix-gnunet.)

Greetings,
Maxime
-- 
Maxime Devos <[email-masked]>
PGP Key: C1F3 3EE2 0C52 8FDB 7DD7  011F 49E3 EE22 1917 25EE
Freenode handle: mdevos
From 9ada791f1eecb68a850d5526ca511b1ad0c20e87 Mon Sep 17 00:00:00 2001
From: Maxime Devos <[email-masked]>
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'.
  (<narinfo-hook>): 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 <[email-masked]>
 ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <[email-masked]>
 ;;; Copyright © 2020 Maxim Cournoyer <[email-masked]>
+;;; Copyright © 2021 Maxime Devos <[email-masked]>
 ;;;
 ;;; 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 <substitutable> 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>
+  (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

From 61c681cbe0b29b31587e71a905f34f0f12757a13 Mon Sep 17 00:00:00 2001
From: Maxime Devos <[email-masked]>
Date: Sun, 31 Jan 2021 11:06:46 +0100
Subject: [PATCH 2/2] DRAFT: add hook example

TODO: should be located elsewere.
---
 hook.scm | 27 +++++++++++++++++++++++++++
 1 file changed, 27 insertions(+)
 create mode 100644 hook.scm

diff --git a/hook.scm b/hook.scm
new file mode 100644
index 0000000000..7b81c8d761
--- /dev/null
+++ b/hook.scm
@@ -0,0 +1,27 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Maxime Devos <[email-masked]>
+;;;
+;;; 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/>.
+(use-modules (guix scripts publish))
+
+(list
+ (narinfo-hook
+  (lambda (pathinfo . rest)
+    `(("LuckyNumber" . ,(random 1000))
+      ("Stuff" . ,(object->string pathinfo)))))
+ (narinfo-hook
+  (lambda (pathinfo . rest)
+    `(("Cool" . "Beans")))))
-- 
2.30.0