New home-page checker for ‘guix lint’

New home-page checker for ‘guix lint’

[Ludovic Courtès]

The ‘guix lint’ command now has a new ‘home-page’ checker that does what
you would expect:

--8<---------------cut here---------------start------------->8---
$ ./pre-inst-env guix lint -c home-page 
gnu/packages/admin.scm:449:15: isc-dhcp-4.3.0: home page http://www.isc.org/products/DHCP/ not reachable: 404 ("Not Found")
gnu/packages/gtk.scm:391:14: gtk+-3.10.1: home page unreachable: No route to host
gnu/packages/image.scm:335:15: giblib-1.2.4: home page http://linuxbrit.co.uk/software/ not reachable: 500 ("Internal Server Error")
gnu/packages/make-bootstrap.scm:596:43: static-binaries-tarball-0: invalid value for home page
gnu/packages/stalonetray.scm:41:15: stalonetray-0.8.1: invalid home page URL: "stalonetray"
gnu/packages/xdisorg.scm:330:15: scrot-0.8: home page http://linuxbrit.co.uk/software/ not reachable: 500 ("Internal Server Error")
--8<---------------cut here---------------end--------------->8---

This has already allowed me to fix and update a bunch of URLs.

The impetus was a message by the gnu.org webmasters pointing to a list
of broken links on gnu.org, and
<https://www.gnu.org/software/guix/package-list.html> happened to have
many of them.

Comments and bug reports welcome!

Ludo’.

Re: New home-page checker for ‘guix lint’

[Cyril Roelandt]

On 12/28/2014 06:02 PM, Ludovic Courtès wrote:
> 
> Comments and bug reports welcome!
> 

That's cool, though I find your lack of tests disturbing.

I'll do the same for URIs, so that it is easier to detect un-buildable
software. I'll send a patch soon enough.

Maybe we could have a cron job that runs those checkers every day and
mails the list with a summary of the broken links ?

Cyril.

[PATCH] lint: add 'source' checker.

[Cyril Roelandt]

* guix/scripts/lint.scm (uri-available?): New procedure.
  (%checkers): Add 'home-page' checker
---
 guix/scripts/lint.scm | 98 ++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 65 insertions(+), 33 deletions(-)

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 9a0d997..482b3e4 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -20,6 +20,7 @@
 
 (define-module (guix scripts lint)
   #:use-module (guix base32)
+  #:use-module (guix download)
   #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module (guix ui)
@@ -253,45 +254,51 @@ response from URI, and additional details, such as the actual HTTP response."
       (_
        (values 'not-http #f)))))
 
+(define (uri-available? uri)
+  "Return #t if the given URI can be reached, otherwise throw a
+'not-available exception along with an appropriate error message."
+  (let-values (((status argument)
+                (probe-uri uri)))
+    (case status
+      ((http-response)
+       (unless (= 200 (response-code argument))
+         (throw 'not-available
+                (format #f
+                        (_ "~a unreachable: ~a (~s)")
+                        (uri->string uri)
+                        (response-code argument)
+                        (response-reason-phrase argument)))))
+      ((getaddrinfo-error)
+       (throw 'not-available
+              (format #f
+                      (_ "domain not found: ~a")
+                      (gai-strerror (car argument)))))
+      ((system-error)
+       (throw 'not-available
+              (format #f
+                      (_ "unreachable: ~a")
+                      (strerror
+                       (system-error-errno
+                        (cons status argument))))))
+      ((invalid-http-response gnutls-error)
+       ;; Probably a misbehaving server; ignore.
+       #f)
+      ((not-http)                             ;nothing we can do
+       #f)
+      (else
+       (error "internal home-page linter error" status)))
+    #t))
+
 (define (check-home-page package)
   "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
 'home-page' is not reachable."
   (let ((uri (and=> (package-home-page package) string->uri)))
     (cond
      ((uri? uri)
-      (let-values (((status argument)
-                    (probe-uri uri)))
-        (case status
-          ((http-response)
-           (unless (= 200 (response-code argument))
-             (emit-warning package
-                           (format #f
-                                   (_ "home page ~a not reachable: ~a (~s)")
-                                   (uri->string uri)
-                                   (response-code argument)
-                                   (response-reason-phrase argument))
-                           'home-page)))
-          ((getaddrinfo-error)
-           (emit-warning package
-                         (format #f
-                                 (_ "home page domain not found: ~a")
-                                 (gai-strerror (car argument)))
-                         'package))
-          ((system-error)
-           (emit-warning package
-                         (format #f
-                                 (_ "home page unreachable: ~a")
-                                 (strerror
-                                  (system-error-errno
-                                   (cons status argument))))
-                         'home-page))
-          ((invalid-http-response gnutls-error)
-           ;; Probably a misbehaving server; ignore.
-           #f)
-          ((not-http)                             ;nothing we can do
-           #f)
-          (else
-           (error "internal home-page linter error" status)))))
+      (catch 'not-available
+             (lambda () (uri-available? uri))
+             (lambda (key . args)
+               (emit-warning package (car args) 'home-page))))
      ((not (package-home-page package))
       (unless (or (string-contains (package-name package) "bootstrap")
                   (string=? (package-name package) "ld-wrapper"))
@@ -374,6 +381,27 @@ descriptions maintained upstream."
                  (location->string loc) (package-full-name package)
                  (fill-paragraph (escape-quotes upstream) 77 7)))))))
 
+(define (check-source package)
+  ""
+  (let ((origin (package-source package)))
+    (when (and origin
+               (eqv? (origin-method origin) url-fetch))
+      (let* ((strings (origin-uri origin))
+             (uris (if (list? strings)
+                       (map string->uri strings)
+                       (list (string->uri strings)))))
+       (for-each
+         (lambda (uri)
+           (cond
+            ((uri? uri)
+             (catch 'not-available
+                    (lambda () (uri-available? uri))
+                    (lambda (key . args)
+                      (emit-warning package (car args) 'home-page))))
+            (else
+              (error "internal source linter errorl"))))
+         uris)))))
+
 \f
 ;;;
 ;;; List of checkers.
@@ -402,6 +430,10 @@ descriptions maintained upstream."
      (description "Validate home-page URLs")
      (check       check-home-page))
    (lint-checker
+     (name        'source)
+     (description "Valide source URLs")
+     (check       check-source))
+   (lint-checker
      (name        'synopsis)
      (description "Validate package synopses")
      (check       check-synopsis-style))))
-- 
1.8.4.rc3

Re: [PATCH] lint: add 'source' checker.

[David Thompson]

Cyril Roelandt <tipecaml@gmail.com> writes:

> * guix/scripts/lint.scm (uri-available?): New procedure.
>   (%checkers): Add 'home-page' checker
> ---
>  guix/scripts/lint.scm | 98 ++++++++++++++++++++++++++++++++++-----------------
>  1 file changed, 65 insertions(+), 33 deletions(-)
>
> diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
> index 9a0d997..482b3e4 100644
> --- a/guix/scripts/lint.scm
> +++ b/guix/scripts/lint.scm
> @@ -20,6 +20,7 @@
>  
>  (define-module (guix scripts lint)
>    #:use-module (guix base32)
> +  #:use-module (guix download)
>    #:use-module (guix packages)
>    #:use-module (guix records)
>    #:use-module (guix ui)
> @@ -253,45 +254,51 @@ response from URI, and additional details, such as the actual HTTP response."
>        (_
>         (values 'not-http #f)))))
>  
> +(define (uri-available? uri)
> +  "Return #t if the given URI can be reached, otherwise throw a
> +'not-available exception along with an appropriate error message."
> +  (let-values (((status argument)
> +                (probe-uri uri)))
> +    (case status

How about using match instead of case?

> +      ((http-response)
> +       (unless (= 200 (response-code argument))
> +         (throw 'not-available
> +                (format #f
> +                        (_ "~a unreachable: ~a (~s)")
> +                        (uri->string uri)
> +                        (response-code argument)
> +                        (response-reason-phrase argument)))))
> +      ((getaddrinfo-error)
> +       (throw 'not-available
> +              (format #f
> +                      (_ "domain not found: ~a")
> +                      (gai-strerror (car argument)))))
> +      ((system-error)
> +       (throw 'not-available
> +              (format #f
> +                      (_ "unreachable: ~a")
> +                      (strerror
> +                       (system-error-errno
> +                        (cons status argument))))))
> +      ((invalid-http-response gnutls-error)
> +       ;; Probably a misbehaving server; ignore.
> +       #f)
> +      ((not-http)                             ;nothing we can do
> +       #f)
> +      (else
> +       (error "internal home-page linter error" status)))
> +    #t))
> +
>  (define (check-home-page package)
>    "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
>  'home-page' is not reachable."
>    (let ((uri (and=> (package-home-page package) string->uri)))
>      (cond
>       ((uri? uri)
> -      (let-values (((status argument)
> -                    (probe-uri uri)))
> -        (case status
> -          ((http-response)
> -           (unless (= 200 (response-code argument))
> -             (emit-warning package
> -                           (format #f
> -                                   (_ "home page ~a not reachable: ~a (~s)")
> -                                   (uri->string uri)
> -                                   (response-code argument)
> -                                   (response-reason-phrase argument))
> -                           'home-page)))
> -          ((getaddrinfo-error)
> -           (emit-warning package
> -                         (format #f
> -                                 (_ "home page domain not found: ~a")
> -                                 (gai-strerror (car argument)))
> -                         'package))
> -          ((system-error)
> -           (emit-warning package
> -                         (format #f
> -                                 (_ "home page unreachable: ~a")
> -                                 (strerror
> -                                  (system-error-errno
> -                                   (cons status argument))))
> -                         'home-page))
> -          ((invalid-http-response gnutls-error)
> -           ;; Probably a misbehaving server; ignore.
> -           #f)
> -          ((not-http)                             ;nothing we can do
> -           #f)
> -          (else
> -           (error "internal home-page linter error" status)))))
> +      (catch 'not-available
> +             (lambda () (uri-available? uri))
> +             (lambda (key . args)
> +               (emit-warning package (car args) 'home-page))))
>       ((not (package-home-page package))
>        (unless (or (string-contains (package-name package) "bootstrap")
>                    (string=? (package-name package) "ld-wrapper"))
> @@ -374,6 +381,27 @@ descriptions maintained upstream."
>                   (location->string loc) (package-full-name package)
>                   (fill-paragraph (escape-quotes upstream) 77 7)))))))
>  
> +(define (check-source package)
> +  ""
> +  (let ((origin (package-source package)))
> +    (when (and origin
> +               (eqv? (origin-method origin) url-fetch))
> +      (let* ((strings (origin-uri origin))
> +             (uris (if (list? strings)
> +                       (map string->uri strings)
> +                       (list (string->uri strings)))))
> +       (for-each
> +         (lambda (uri)
> +           (cond
> +            ((uri? uri)

I think this would be more succint if match-lambda were used instead.

> +             (catch 'not-available
> +                    (lambda () (uri-available? uri))
> +                    (lambda (key . args)
> +                      (emit-warning package (car args) 'home-page))))
> +            (else
> +              (error "internal source linter errorl"))))

s/errorl/error/

> +         uris)))))
> +
>  \f
>  ;;;
>  ;;; List of checkers.
> @@ -402,6 +430,10 @@ descriptions maintained upstream."
>       (description "Validate home-page URLs")
>       (check       check-home-page))
>     (lint-checker
> +     (name        'source)
> +     (description "Valide source URLs")

s/Valide/Validate/

> +     (check       check-source))
> +   (lint-checker
>       (name        'synopsis)
>       (description "Validate package synopses")
>       (check       check-synopsis-style))))
> -- 
> 1.8.4.rc3
>
>

Thanks!

-- 
David Thompson
Web Developer - Free Software Foundation - http://fsf.org
GPG Key: 0FF1D807
Support the FSF: https://fsf.org/donate

Re: New home-page checker for ‘guix lint’

[Ludovic Courtès]

Cyril Roelandt <tipecaml@gmail.com> skribis:

> That's cool, though I find your lack of tests disturbing.

:-) I admit I took the usual approach of “oh but all this is untestable,
it requires the web and all that.”  I realize we can certainly do
better, using Guile’s web server for instance.  I’ll see what I can do.

> I'll do the same for URIs, so that it is easier to detect un-buildable
> software. I'll send a patch soon enough.

Glad you propose; I thought about it too.

> Maybe we could have a cron job that runs those checkers every day and
> mails the list with a summary of the broken links ?

Definitely.  Either that or create an HTML page listing all the defects.
That would mean adding HTML output to ‘guix lint’, which is a bit of
work, but not too hard, I think.

Thanks,
Ludo’.

Re: [PATCH] lint: add 'source' checker.

[Ludovic Courtès]

Cyril Roelandt <tipecaml@gmail.com> skribis:

> * guix/scripts/lint.scm (uri-available?): New procedure.
>   (%checkers): Add 'home-page' checker

Some comments in addition to what David already wrote.

> +(define (uri-available? uri)
> +  "Return #t if the given URI can be reached, otherwise throw a
> +'not-available exception along with an appropriate error message."

By convention, one would expect ‘uri-available?’ to return #t or #f, not
to throw.

How about calling it ‘validate-uri’ and directly call ‘emit-warning’
from there?  It would need the field name as an additional argument.

> +  (let-values (((status argument)
> +                (probe-uri uri)))
> +    (case status
> +      ((http-response)

IMO ‘case’ is fine here.

> +(define (check-source package)
> +  ""

Missing docstring.

Thanks!

Ludo’.

Re: New home-page checker for ‘guix lint’

[Ludovic Courtès]

Cyril Roelandt <tipecaml@gmail.com> skribis:

> That's cool, though I find your lack of tests disturbing.

Commit 907c98a adds tests, using Guile’s HTTP server.

Thanks for pointing fingers!  ;-)

Ludo’.

Re: [PATCH] lint: add 'source' checker.

[Ludovic Courtès]

Cyril Roelandt <tipecaml@gmail.com> skribis:

> +(define (check-source package)
> +  ""
> +  (let ((origin (package-source package)))
> +    (when (and origin
> +               (eqv? (origin-method origin) url-fetch))
> +      (let* ((strings (origin-uri origin))
> +             (uris (if (list? strings)
> +                       (map string->uri strings)
> +                       (list (string->uri strings)))))

I realized while fixing it in list-packages.scm that mirror:// URIs
actually need to be expanded here.  See commit 1c69e4c for an example.

Ludo’.

Re: [PATCH] lint: add 'source' checker.

[Cyril Roelandt]

On 12/29/2014 03:23 PM, Ludovic Courtès wrote:
> Cyril Roelandt <tipecaml@gmail.com> skribis:
> 
>> * guix/scripts/lint.scm (uri-available?): New procedure.
>>   (%checkers): Add 'home-page' checker
> 
> Some comments in addition to what David already wrote.
> 
>> +(define (uri-available? uri)
>> +  "Return #t if the given URI can be reached, otherwise throw a
>> +'not-available exception along with an appropriate error message."
> 
> By convention, one would expect ‘uri-available?’ to return #t or #f, not
> to throw.
> 
> How about calling it ‘validate-uri’ and directly call ‘emit-warning’
> from there?  It would need the field name as an additional argument.
> 

This would also require passing the "package" to validate-uri. How about
we make uri-available? return #t/#f, and just don't really care about
the exact reason why it failed ? Anyway a human being is going to
manually check what happened to know whether this is a real issue or
just a server that went down for a couple hours, or a file that wrongly
got removed...


Cyril.

Re: [PATCH] lint: add 'source' checker.

[Ludovic Courtès]

Cyril Roelandt <tipecaml@gmail.com> skribis:

> On 12/29/2014 03:23 PM, Ludovic Courtès wrote:
>> Cyril Roelandt <tipecaml@gmail.com> skribis:
>> 
>>> * guix/scripts/lint.scm (uri-available?): New procedure.
>>>   (%checkers): Add 'home-page' checker
>> 
>> Some comments in addition to what David already wrote.
>> 
>>> +(define (uri-available? uri)
>>> +  "Return #t if the given URI can be reached, otherwise throw a
>>> +'not-available exception along with an appropriate error message."
>> 
>> By convention, one would expect ‘uri-available?’ to return #t or #f, not
>> to throw.
>> 
>> How about calling it ‘validate-uri’ and directly call ‘emit-warning’
>> from there?  It would need the field name as an additional argument.
>> 
>
> This would also require passing the "package" to validate-uri.

Right, and I think it’s fine.

> How about we make uri-available? return #t/#f, and just don't really
> care about the exact reason why it failed ? Anyway a human being is
> going to manually check what happened to know whether this is a real
> issue or just a server that went down for a couple hours, or a file
> that wrongly got removed...

Possibly but still, I prefer to have detailed reports since we already
have all the details anyway.

Thanks,
Ludo’.

[PATCHv2] lint: add 'source' checker.

[Cyril Roelandt]

* guix/scripts/lint.scm (validate-uri?): New procedure.
  (%checkers): Add 'home-page' checker
---
 guix/scripts/lint.scm | 102 +++++++++++++++++++++++++++++++++-----------------
 1 file changed, 68 insertions(+), 34 deletions(-)

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 15ae213..7a0b246 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -20,6 +20,7 @@
 
 (define-module (guix scripts lint)
   #:use-module (guix base32)
+  #:use-module (guix download)
   #:use-module (guix packages)
   #:use-module (guix records)
   #:use-module (guix ui)
@@ -31,7 +32,8 @@
   #:use-module (ice-9 format)
   #:use-module (web uri)
   #:use-module ((guix build download)
-                #:select (open-connection-for-uri))
+                #:select (maybe-expand-mirrors
+                          open-connection-for-uri))
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (srfi srfi-1)
@@ -254,45 +256,53 @@ response from URI, and additional details, such as the actual HTTP response."
       (_
        (values 'not-http #f)))))
 
+(define (validate-uri uri package field)
+  "Return #t if the given URI can be reached, otherwise emit a
+warning for PACKAGE mentionning the FIELD."
+  (let-values (((status argument)
+                (probe-uri uri)))
+    (case status
+      ((http-response)
+       (unless (= 200 (response-code argument))
+         (emit-warning package
+                       (format #f
+                               (_ "URI ~a not reachable: ~a (~s)")
+                               (uri->string uri)
+                               (response-code argument)
+                               (response-reason-phrase argument))
+                       field)))
+      ((getaddrinfo-error)
+       (emit-warning package
+                     (format #f
+                             (_ "URI ~a domain not found: ~a")
+                             (uri->string uri)
+                             (gai-strerror (car argument)))
+                     field))
+      ((system-error)
+       (emit-warning package
+                     (format #f
+                             (_ "URI ~a unreachable: ~a")
+                             (uri->string uri)
+                             (strerror
+                              (system-error-errno
+                               (cons status argument))))
+                     field))
+      ((invalid-http-response gnutls-error)
+       ;; Probably a misbehaving server; ignore.
+       #f)
+      ((not-http)                             ;nothing we can do
+       #f)
+      (else
+       (error "internal linter error" status)))
+    #t))
+
 (define (check-home-page package)
   "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
 'home-page' is not reachable."
   (let ((uri (and=> (package-home-page package) string->uri)))
     (cond
      ((uri? uri)
-      (let-values (((status argument)
-                    (probe-uri uri)))
-        (case status
-          ((http-response)
-           (unless (= 200 (response-code argument))
-             (emit-warning package
-                           (format #f
-                                   (_ "home page ~a not reachable: ~a (~s)")
-                                   (uri->string uri)
-                                   (response-code argument)
-                                   (response-reason-phrase argument))
-                           'home-page)))
-          ((getaddrinfo-error)
-           (emit-warning package
-                         (format #f
-                                 (_ "home page domain not found: ~a")
-                                 (gai-strerror (car argument)))
-                         'package))
-          ((system-error)
-           (emit-warning package
-                         (format #f
-                                 (_ "home page unreachable: ~a")
-                                 (strerror
-                                  (system-error-errno
-                                   (cons status argument))))
-                         'home-page))
-          ((invalid-http-response gnutls-error)
-           ;; Probably a misbehaving server; ignore.
-           #f)
-          ((not-http)                             ;nothing we can do
-           #f)
-          (else
-           (error "internal home-page linter error" status)))))
+      (validate-uri uri package 'home-page))
      ((not (package-home-page package))
       (unless (or (string-contains (package-name package) "bootstrap")
                   (string=? (package-name package) "ld-wrapper"))
@@ -375,6 +385,26 @@ descriptions maintained upstream."
                  (location->string loc) (package-full-name package)
                  (fill-paragraph (escape-quotes upstream) 77 7)))))))
 
+(define (check-source package)
+  "Emit a warning if PACKAGE has an invalid 'source' field, or if that
+'source' is not reachable."
+  (let ((origin (package-source package)))
+    (when (and origin
+               (eqv? (origin-method origin) url-fetch))
+      (let* ((strings (origin-uri origin))
+             (uris (if (list? strings)
+                       (map string->uri strings)
+                       (list (string->uri strings)))))
+       (for-each
+         (match-lambda
+          ((? uri? uri)
+           (validate-uri uri package 'source))
+          (_ (error "internal linter error")))
+         (concatenate (map (lambda (uri)
+                             (maybe-expand-mirrors uri %mirrors))
+                           uris)))))))
+
+
 \f
 ;;;
 ;;; List of checkers.
@@ -403,6 +433,10 @@ descriptions maintained upstream."
      (description "Validate home-page URLs")
      (check       check-home-page))
    (lint-checker
+     (name        'source)
+     (description "Validate source URLs")
+     (check       check-source))
+   (lint-checker
      (name        'synopsis)
      (description "Validate package synopses")
      (check       check-synopsis-style))))
-- 
1.8.4.rc3

Re: [PATCHv2] lint: add 'source' checker.

[Ludovic Courtès]

Cyril Roelandt <tipecaml@gmail.com> skribis:

> * guix/scripts/lint.scm (validate-uri?): New procedure.
>   (%checkers): Add 'home-page' checker
                      ^^^^^
Typo.

> +(define (check-source package)
> +  "Emit a warning if PACKAGE has an invalid 'source' field, or if that
> +'source' is not reachable."
> +  (let ((origin (package-source package)))
> +    (when (and origin
> +               (eqv? (origin-method origin) url-fetch))
> +      (let* ((strings (origin-uri origin))
> +             (uris (if (list? strings)
> +                       (map string->uri strings)
> +                       (list (string->uri strings)))))
> +       (for-each
> +         (match-lambda
> +          ((? uri? uri)
> +           (validate-uri uri package 'source))
> +          (_ (error "internal linter error")))

Just:

  (for-each (cut validate-uri <> package 'source) ...)

> +         (concatenate (map (lambda (uri)
> +                             (maybe-expand-mirrors uri %mirrors))
> +                           uris)))))))

Here:

  (append-map (cut maybe-expand-mirrors <> %mirrors) uris)

OK to push with these changes, thank you!

The next step is to improve ‘probe-uri’ to handle FTP.

Ludo’.

Re: [PATCHv2] lint: add 'source' checker.

[Ludovic Courtès]

ludo@gnu.org (Ludovic Courtès) skribis:

> OK to push with these changes, thank you!

Ping!  :-)

Ludo’.

Re: [PATCHv2] lint: add 'source' checker.

[Cyril Roelandt]

On 01/23/2015 10:56 AM, Ludovic Courtès wrote:
> ludo@gnu.org (Ludovic Courtès) skribis:
> 
>> OK to push with these changes, thank you!
> 
> Ping!  :-)
> 

Done in 17a7b75c0f727cd7c32b156d8a9235a2009a248f .


Cyril.