summaryrefslogtreecommitdiff
path: root/guix/scripts/lint.scm
diff options
context:
space:
mode:
authorArun Isaac <arunisaac@systemreboot.net>2018-12-21 17:48:55 +0530
committerArun Isaac <arunisaac@systemreboot.net>2018-12-24 08:15:17 +0530
commit0865d8a8f6c229fef5bcba647cc7b37c2f3d3dae (patch)
tree25d8096d41012cb8395a10eb72ead08cdc455f2f /guix/scripts/lint.scm
parent450226ebc1b2611ff62469d314e7ca2973bbf131 (diff)
guix: lint: Check for source URIs redirecting to GitHub.
* guix/scripts/lint.scm (check-github-uri): New procedure. (%checkers): Add it. * doc/guix.texi (Invoking guix lint): Document it. * tests/lint.scm ("github-url", "github-url: one suggestion"): New tests.
Diffstat (limited to 'guix/scripts/lint.scm')
-rw-r--r--guix/scripts/lint.scm39
1 files changed, 39 insertions, 0 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 2314f3b28c..354f6f7031 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -44,8 +45,10 @@
#:use-module (guix cve)
#:use-module (gnu packages)
#:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
+ #:use-module (web client)
#:use-module (web uri)
#:use-module ((guix build download)
#:select (maybe-expand-mirrors
@@ -74,6 +77,7 @@
check-source
check-source-file-name
check-mirror-url
+ check-github-url
check-license
check-vulnerabilities
check-for-updates
@@ -773,6 +777,37 @@ descriptions maintained upstream."
(let ((uris (origin-uris origin)))
(for-each check-mirror-uri uris)))))
+(define (check-github-url package)
+ "Check whether PACKAGE uses source URLs that redirect to GitHub."
+ (define (follow-redirect uri)
+ (receive (response body) (http-head uri)
+ (case (response-code response)
+ ((301 302)
+ (uri->string (assoc-ref (response-headers response) 'location)))
+ (else #f))))
+
+ (define (follow-redirects-to-github uri)
+ (cond
+ ((string-prefix? "https://github.com/" uri) uri)
+ ((string-prefix? "http" uri)
+ (and=> (follow-redirect uri) follow-redirects-to-github))
+ ;; Do not attempt to follow redirects on URIs other than http and https
+ ;; (such as mirror, file)
+ (else #f)))
+
+ (let ((origin (package-source package)))
+ (when (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (for-each
+ (lambda (uri)
+ (and=> (follow-redirects-to-github uri)
+ (lambda (github-uri)
+ (emit-warning
+ package
+ (format #f (G_ "URL should be '~a'") github-uri)
+ 'source))))
+ (origin-uris origin)))))
+
(define (check-derivation package)
"Emit a warning if we fail to compile PACKAGE to a derivation."
(define (try system)
@@ -1056,6 +1091,10 @@ or a list thereof")
(description "Suggest 'mirror://' URLs")
(check check-mirror-url))
(lint-checker
+ (name 'github-uri)
+ (description "Suggest GitHub URIs")
+ (check check-github-url))
+ (lint-checker
(name 'source-file-name)
(description "Validate file names of sources")
(check check-source-file-name))