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

[David Thompson <dthompson2@worcester.edu>]

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