[bug#58231] [PATCH 0/2] Checking the 'license' field of packages

[bug#58231] [PATCH 0/2] Checking the 'license' field of packages

[Ludovic Courtès]

Hello Guix!

We already have ‘guix lint -c license’ but that hasn’t prevented
us from occasionally having invalid licenses committed.  This patch
adds add a ‘sanitize’ option to the ‘license’ field of <package> to
detect invalid licenses early on, as zimoun suggested at:

  https://lists.gnu.org/archive/html/guix-devel/2022-09/msg00067.html

The funny part of this patch is that the license validation expands
to #t in the majority of cases, meaning that it comes without
run-time overhead (there is macro-expansion overhead, but I didn’t
measure it).  Kinda like static type checking, except that we can
only tell when a value is definitely a valid license and cannot
conclude in other cases.

Feedback welcome!

Thanks,
Ludo’.

Ludovic Courtès (2):
  licenses: Let 'license?' expand to #t in trivial cases.
  packages: Raise an exception for invalid 'license' values.

 guix/licenses.scm  | 58 +++++++++++++++++++++++++++++++++++++++-------
 guix/packages.scm  | 40 +++++++++++++++++++++++++++++++-
 tests/packages.scm |  7 ++++++
 3 files changed, 95 insertions(+), 10 deletions(-)


base-commit: d9b7982ba58fdea0934b60a81f507440a56c82ee
-- 
2.37.3

[bug#58231] [PATCH 1/2] licenses: Let 'license?' expand to #t in trivial cases.

[Ludovic Courtès]

With this change, we have:

  > ,expand (license? gpl3+)
  $2 = #t
  > ,expand (license? something-else)
  $3 = (let ((obj something-else))
    (and ((@@ (srfi srfi-9) struct?) obj)
	 ((@@ (srfi srfi-9) eq?)
	  ((@@ (srfi srfi-9) struct-vtable) obj)
	  (@@ (guix licenses) <license>))))

* guix/licenses.scm (define-license-predicate)
(begin-license-definitions): New macros
<top level>: Wrap definitions in 'begin-license-definitions'.
---
 guix/licenses.scm | 58 +++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 49 insertions(+), 9 deletions(-)

diff --git a/guix/licenses.scm b/guix/licenses.scm
index 3b820ae07e..80cf0f1114 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2014, 2015, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2014, 2015, 2017, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@@ -109,13 +109,6 @@ (define-module (guix licenses)
             hpnd
             fsdg-compatible))
 
-(define-record-type <license>
-  (license name uri comment)
-  license?
-  (name    license-name)
-  (uri     license-uri)
-  (comment license-comment))
-
 ;;; Commentary:
 ;;;
 ;;; Available licenses.
@@ -129,6 +122,53 @@ (define-record-type <license>
 ;;;
 ;;; Code:
 
+(define-record-type <license>
+  (license name uri comment)
+  actual-license?
+  (name    license-name)
+  (uri     license-uri)
+  (comment license-comment))
+
+(define-syntax define-license-predicate
+  (syntax-rules (define define*)
+    "Define PREDICATE as a license predicate that, when applied to trivial
+cases, reduces to #t at macro-expansion time."
+    ((_ predicate (variables ...) (procedures ...)
+        (define variable _) rest ...)
+     (define-license-predicate
+       predicate
+       (variable variables ...) (procedures ...)
+       rest ...))
+    ((_ predicate (variables ...) (procedures ...)
+        (define* (procedure _ ...) _ ...)
+        rest ...)
+     (define-license-predicate
+       predicate
+       (variables ...) (procedure procedures ...)
+       rest ...))
+    ((_ predicate (variables ...) (procedures ...))
+     (define-syntax predicate
+       (lambda (s)
+         (syntax-case s (variables ... procedures ...)
+           ((_ variables) #t) ...
+           ((_ (procedures _)) #t) ...
+           ((_ obj) #'(actual-license? obj))
+           (id
+            (identifier? #'id)
+            #'actual-license?)))))))
+
+(define-syntax begin-license-definitions
+  (syntax-rules ()
+    ((_ predicate definitions ...)
+     (begin
+       ;; Define PREDICATE such that it expands to #t when passed one of the
+       ;; identifiers in DEFINITIONS.
+       (define-license-predicate predicate () () definitions ...)
+
+       definitions ...))))
+
+(begin-license-definitions license?
+
 (define agpl1
   (license "AGPL 1"
            "https://gnu.org/licenses/agpl.html"
@@ -717,6 +757,6 @@ (define* (fsdg-compatible uri #:optional (comment ""))
 https://www.gnu.org/distros/free-system-distribution-guidelines.en.html#non-functional-data."
   (license "FSDG-compatible"
            uri
-           comment))
+           comment)))
 
 ;;; licenses.scm ends here
-- 
2.37.3

[bug#58231] [PATCH 2/2] packages: Raise an exception for invalid 'license' values.

[Ludovic Courtès]

This is written in such a way that the type check turns into a no-op at
macro-expansion time for trivial cases:

  > ,optimize (validate-license gpl3+)
  $18 = gpl3+
  > ,optimize (validate-license (list gpl3+ gpl2+))
  $19 = (list gpl3+ gpl2+)

* guix/packages.scm (valid-license-value?, validate-license): New
macros.
(<package>)[license]: Add 'sanitize' option.
(&package-license-error): New error condition type.
* tests/packages.scm ("license type checking"): New test.
---
 guix/packages.scm  | 40 +++++++++++++++++++++++++++++++++++++++-
 tests/packages.scm |  7 +++++++
 2 files changed, 46 insertions(+), 1 deletion(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index 94e464cd01..704b4ee710 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -41,6 +41,9 @@ (define-module (guix packages)
   #:use-module (guix search-paths)
   #:use-module (guix sets)
   #:use-module (guix deprecation)
+  #:use-module ((guix diagnostics)
+                #:select (formatted-message define-with-syntax-properties))
+  #:autoload   (guix licenses) (license?)
   #:use-module (guix i18n)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
@@ -159,6 +162,8 @@ (define-module (guix packages)
             &package-error
             package-error?
             package-error-package
+            package-license-error?
+            package-error-invalid-license
             &package-input-error
             package-input-error?
             package-error-invalid-input
@@ -533,6 +538,34 @@ (define ensure-thread-safe-texinfo-parser!
         ((_ obj)
          #'obj)))))
 
+(define-syntax valid-license-value?
+  (syntax-rules (list package-license)
+    "Return #t if the given value is a valid license field, #f otherwise."
+    ;; Arrange so that the answer can be given at macro-expansion time in the
+    ;; most common cases.
+    ((_ (list x ...))
+     (and (license? x) ...))
+    ((_ (package-license _))
+     #t)
+    ((_ obj)
+     (or (license? obj)
+         ;; Note: Avoid 'not' below due to <https://bugs.gnu.org/58217>.
+         (eq? #f obj)                             ;#f is considered valid
+         (let ((x obj))
+           (and (pair? x) (every license? x)))))))
+
+(define-with-syntax-properties (validate-license (value properties))
+  (unless (valid-license-value? value)
+    (raise
+     (make-compound-condition
+      (condition
+       (&error-location
+        (location (source-properties->location properties))))
+      (condition
+       (&package-license-error (package #f) (license value)))
+      (formatted-message (G_ "~s: invalid package license~%") value))))
+  value)
+
 ;; A package.
 (define-record-type* <package>
   package make-package
@@ -574,7 +607,8 @@ (define-record-type* <package>
             (sanitize validate-texinfo))          ; one-line description
   (description package-description
                (sanitize validate-texinfo))       ; one or two paragraphs
-  (license package-license)                       ; (list of) <license>
+  (license package-license                        ; (list of) <license>
+           (sanitize validate-license))
   (home-page package-home-page)
   (supported-systems package-supported-systems    ; list of strings
                      (default %supported-systems))
@@ -737,6 +771,10 @@ (define-condition-type &package-error &error
   package-error?
   (package package-error-package))
 
+(define-condition-type &package-license-error &package-error
+  package-license-error?
+  (license package-error-invalid-license))
+
 (define-condition-type &package-input-error &package-error
   package-input-error?
   (input package-error-invalid-input))
diff --git a/tests/packages.scm b/tests/packages.scm
index 6cbc34ba0b..dc03b13417 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -94,6 +94,13 @@ (define %store
                     (write
                      (dummy-package "foo" (location #f)))))))
 
+(test-equal "license type checking"
+  'bad-license
+  (guard (c ((package-license-error? c)
+             (package-error-invalid-license c)))
+    (dummy-package "foo"
+      (license 'bad-license))))
+
 (test-assert "hidden-package"
   (and (hidden-package? (hidden-package (dummy-package "foo")))
        (not (hidden-package? (dummy-package "foo")))))
-- 
2.37.3

[bug#58231] [PATCH 0/2] Checking the 'license' field of packages

[pelzflorian (Florian Pelz)]

Thank you!  This is good.  Just to let you know though; when reverting
e61c581805b2338ea8feaac86617c5d7bff41c41 and guix pull’ing, there is
no error location.  Doesn’t matter to me though.

Computing Guix derivation for 'x86_64-linux'... -Backtrace:
In ice-9/boot-9.scm:
   222:29 19 (map1 _)
   222:29 18 (map1 _)
   222:29 17 (map1 _)
   222:29 16 (map1 _)
   222:29 15 (map1 _)
   222:29 14 (map1 _)
   222:29 13 (map1 _)
   222:17 12 (map1 (((gnu packages qt)) ((gnu packages sqlite)) ((gnu packages web)) ((gnu packages xml)) ((gnu ?)) ?))
  3326:17 11 (resolve-interface (gnu packages qt) #:select _ #:hide _ #:prefix _ #:renamer _ #:version _)
In ice-9/threads.scm:
    390:8 10 (_ _)
In ice-9/boot-9.scm:
  3252:13  9 (_)
In ice-9/threads.scm:
    390:8  8 (_ _)
In ice-9/boot-9.scm:
  3536:20  7 (_)
   2835:4  6 (save-module-excursion _)
  3556:26  5 (_)
In unknown file:
           4 (primitive-load-path "gnu/packages/qt" #<procedure 7fded2ddefc0 at ice-9/boot-9.scm:3543:37 ()>)
In ice-9/eval.scm:
    619:8  3 (_ #f)
   626:19  2 (_ #<directory (gnu packages qt) 7fded3df5780>)
   293:34  1 (_ #(#(#(#(#(#(#(#(#(#(#<directory (gnu packages qt) 7fded3df5780> "qtshad?") #) #) #) #) #) #) #) #) #))
    619:8  0 (_ #(#(#(#(#(#(#(#(#(#(#<directory (gnu packages qt) 7fded3df5780> "qtshad?") #) #) #) #) #) #) #) #) #))

ice-9/eval.scm:619:8: ERROR:
  1. &error-location: #f
  2. &package-license-error:
      package: #f
      license: "https://www.qt.io/"
  3. &formatted-message:
      format: "~s: invalid package license~%\n"
      arguments: ("https://www.qt.io/")
guix pull: Fehler: You found a bug: the program '/gnu/store/vbk7jc9w4808cn7697bc3h24g2kl78wx-compute-guix-derivation'
failed to compute the derivation for Guix (version: "4b2ae06e49fc7bd41856b02604b5f277a6df06ce"; system: "x86_64-linux";
host version: "0dec41f329c37a4293a2a8326f1fe7d9318ec455"; pull-version: 1).
Please report the COMPLETE output above by email to <bug-guix@gnu.org>.

[bug#58231] [PATCH 0/2] Checking the 'license' field of packages

[Ludovic Courtès]

Hi,

"pelzflorian (Florian Pelz)" <pelzflorian@pelzflorian.de> skribis:

> Thank you!  This is good.  Just to let you know though; when reverting
> e61c581805b2338ea8feaac86617c5d7bff41c41 and guix pull’ing, there is
> no error location.  Doesn’t matter to me though.
>
> Computing Guix derivation for 'x86_64-linux'... -Backtrace:

[...]

>   1. &error-location: #f
>   2. &package-license-error:
>       package: #f
>       license: "https://www.qt.io/"
>   3. &formatted-message:
>       format: "~s: invalid package license~%\n"
>       arguments: ("https://www.qt.io/")

It may be that there’s no location info because during the “Computing
Guix derivation” step, things are being evaluated.

However, most likely the invalid license wouldn’t have been committed in
the first place because the committer would have been unable to test the
package.  (There is location info when running Guix from one’s
checkout.)

Thanks for checking!

Ludo’.

[bug#58231] [PATCH 0/2] Checking the 'license' field of packages

[Ludovic Courtès]

Ludovic Courtès <ludo@gnu.org> skribis:

> The funny part of this patch is that the license validation expands
> to #t in the majority of cases, meaning that it comes without
> run-time overhead (there is macro-expansion overhead, but I didn’t
> measure it).

A quick measurement of the time taken by the “Computing Guix derivation”
step¹ (most of which is macro expansion) suggests it’s going from ~1m34s
to ~1m44s on my laptop—so roughly a 10% slowdown on this stage.

I guess that’s the price to pay.

That phase has always been very slow though, mostly due to psyntax, and
we need to do something about it anyway.

Ludo’.

¹ I ran ‘time guix time-machine --branch=wip-license-checks --url=$PWD’
  and similar for the commit before those changes.

[bug#58231] [PATCH 2/2] packages: Raise an exception for invalid 'license' values.

[zimoun]

Hi,

Well, I am a bit late. :-)


On sam., 01 oct. 2022 at 18:20, Ludovic Courtès <ludo@gnu.org> wrote:

>  ;; A package.
>  (define-record-type* <package>
>    package make-package
> @@ -574,7 +607,8 @@ (define-record-type* <package>
>              (sanitize validate-texinfo))          ; one-line description
>    (description package-description
>                 (sanitize validate-texinfo))       ; one or two paragraphs
> -  (license package-license)                       ; (list of) <license>
> +  (license package-license                        ; (list of) <license>
> +           (sanitize validate-license))
>    (home-page package-home-page)
>    (supported-systems package-supported-systems    ; list of strings
>                       (default %supported-systems))

This change is the core, IIUC.  The question is: does it make sense to
have something similar for all the fields?

For instance, the fields ’name’ and ’verson’ are expected to be ’string’
and could be similarly checked?

Although, the overhead by «Compute derivation» could too much.


Cheers,
simon

[bug#58231] [PATCH 2/2] packages: Raise an exception for invalid 'license' values.

[Ludovic Courtès]

Hi,

zimoun <zimon.toutoune@gmail.com> skribis:

> On sam., 01 oct. 2022 at 18:20, Ludovic Courtès <ludo@gnu.org> wrote:
>
>>  ;; A package.
>>  (define-record-type* <package>
>>    package make-package
>> @@ -574,7 +607,8 @@ (define-record-type* <package>
>>              (sanitize validate-texinfo))          ; one-line description
>>    (description package-description
>>                 (sanitize validate-texinfo))       ; one or two paragraphs
>> -  (license package-license)                       ; (list of) <license>
>> +  (license package-license                        ; (list of) <license>
>> +           (sanitize validate-license))
>>    (home-page package-home-page)
>>    (supported-systems package-supported-systems    ; list of strings
>>                       (default %supported-systems))
>
> This change is the core, IIUC.  The question is: does it make sense to
> have something similar for all the fields?
>
> For instance, the fields ’name’ and ’verson’ are expected to be ’string’
> and could be similarly checked?

I think eventually we should have contracts rather than home-made type
checks like this (Cc’ing Philip).

However, as you write, we have to pay attention to performance in the
case of packages as it could quickly become too expensive.  While I
think it could make sense to have contracts for all the fields of
service configuration records, I think we’ll have to do much less for
<package> fields.

Ludo’.

[bug#58231] [PATCH 2/2] packages: Raise an exception for invalid 'license' values.

[Philip McGrath]

[-- Attachment #1: Type: text/plain, Size: 6671 bytes --]

Hi,

On Monday, October 10, 2022 10:52:16 AM EDT Ludovic Courtès wrote:
> Hi,
> 
> zimoun <zimon.toutoune@gmail.com> skribis:
> > On sam., 01 oct. 2022 at 18:20, Ludovic Courtès <ludo@gnu.org> wrote:
> >>  ;; A package.
> >>  (define-record-type* <package>
> >>    package make-package
> >> @@ -574,7 +607,8 @@ (define-record-type* <package>
> >>              (sanitize validate-texinfo))          ; one-line description
> >>    (description package-description
> >>                 (sanitize validate-texinfo))       ; one or two
> >>                 paragraphs
> >> -  (license package-license)                       ; (list of) <license>
> >> +  (license package-license                        ; (list of) <license>
> >> +           (sanitize validate-license))
> >>    (home-page package-home-page)
> >>    (supported-systems package-supported-systems    ; list of strings
> >>    
> >>                       (default %supported-systems))
> > 
> > This change is the core, IIUC.  The question is: does it make sense to
> > have something similar for all the fields?
> > 
> > For instance, the fields ’name’ and ’verson’ are expected to be ’string’
> > and could be similarly checked?
> 
> I think eventually we should have contracts rather than home-made type
> checks like this (Cc’ing Philip).
> 

Definitely agreed that contracts are The Right Thing, though `string?` by
itself would in fact be a contract.

I'm planning to get back to trying to write a basic `(guix contracts)` library
once I've finished my current project, a `racket-build-system` (for which I've
finally started writing code, as opposed to planning and shaving many
yaks: https://gitlab.com/philip1/guix-racket-experiment/).

I had started a fairly direct port of Racket's contract system, though with the
intention of starting out with as little as possible. I think I'd more or less
finished the representation of "blame" objects.

However, one thing that gave me pause was some of the advice I got on
<https://racket.discourse.group/t/advice-on-implementing-a-contract-system/832/2>.
Matthias Felleisen wrote:

> I will also say that as much as I like ho  [higher-order] contracts and use them
> extensively,
> making everything a function is bad for any future optimization.
> 
> Michael B[allantyne] Cameron M and I are thinking of designing a hosted contract DSL
> on top, via Michael’s special-purpose expanders, and experimenting with a
> classical optimizer, perhaps even using Leif’s nano-passes (adapted for
> syntax of course).

Robby Findler, the mastermind of Racket's contract system, later added in part:

> If I were to get to redo racket/contract, the one big change I'd make is to
> design a (macro-based) DSL for contracts instead of going with a
> combinator-based approach. Although you won't need to do it for a
> minimum-viable product, the opportunity to, at a later date, look at an
> entire contract at compile time and generate better code for it is probably
> going to be useful.
> 
> [...]
> 
> That said, you definitely want to allow arbitrary predicates to just be
> contracts without having to type a lot of stuff, as that's turned out to be
> super useful.
>
> [...]

This came as a surprise, though the explanations made sense. In Racket, I have a
reasonably good sense of how I would implement the kind of DSL they describe,
either using the framework Ballantyne, King, and Felleisen set out in
https://dl.acm.org/doi/abs/10.1145/3428297 (open-access) or manually along the
lines Alexis King explains in a series of blog posts:

 1. https://lexi-lambda.github.io/blog/2018/04/15/reimplementing-hackett-s-type-language-expanding-to-custom-core-forms-in-racket/
 2. https://lexi-lambda.github.io/blog/2018/09/13/custom-core-forms-in-racket-part-ii-generalizing-to-arbitrary-expressions-and-internal-definitions/
 3. https://lexi-lambda.github.io/blog/2018/10/06/macroexpand-anywhere-with-local-apply-transformer/

However, I have no idea how to implement such a thing in Guile, and I think it
would be arduous, perhaps even impossible, without `local-expand` and some of
the other features from "Macros that Work Together: Compile-Time Bindings,
Partial Expansion, and Definition Contexts"
(<https://www.cs.utah.edu/plt/publications/jfp12-draft-fcdf.pdf>) and related
papers.

I'm also wary of shifting the scope from a minimum viable contract library to
what would amount to a research project trying to improve upon the
state-of-the-art contract system.

So, despite this advice, I still tentatively think I'd start by doing
following the Racket contract library very closely. Still, it reinforces my
view that we should start small and initially keep the library as
`(guix contracts)` or something (though I don't think it should use any Guix
specific in its implementation), rather than trying to make a general-purpose
library, so we could change things fairly freely as we get a more concrete
sense of Guix's needs. (In contrast, Racket tries to maintain an extremely
high level of source compatibility with even twenty-year-old code.)

> However, as you write, we have to pay attention to performance in the
> case of packages as it could quickly become too expensive.  While I
> think it could make sense to have contracts for all the fields of
> service configuration records, I think we’ll have to do much less for
> <package> fields.
> 

I'm a little unsure about the specific performance hack in this patch, though.
In either Racket or Chez Scheme, I would expect the compiler constant-fold an
application of a record-type predicate to a known constant identifier. It
should be able to do this in all of the scenarios where a macro could
interpose, and possibly in additional scenarios made visible through previous
inlining etc. in the compiler. So I would expect handling special cases in a
macro to introduce compile-time cost with no run-time benefit. I would expect
this to be covered by "The Guaranteed Optimization Clause of the Macro Writer's
Bill of Rights": https://www.youtube.com/watch?v=LIEX3tUliHw

From Andy Wingo's message at
https://lists.gnu.org/archive/html/guix-devel/2022-03/msg00230.html
I've been hoping roughly the same intuitions apply to Guile records, but maybe
that's not true? For example, I'm not sure that Guile allows assignment to
imported identifiers for which no assignment appeared in their exporting
modules (but the chaos that would ensue from
`(set! license:gpl3.0+ "not a license")` seems like a great example of why
that's such a useful rule).

-Philip

[-- Attachment #2: This is a digitally signed message part. --]
[-- Type: application/pgp-signature, Size: 833 bytes --]