[bug#33801] import: github: Support source URIs that redirect to GitHub

[Arun Isaac]

> Do you know how many packages fall into that category?

With this patch, we have a problem estimating the coverage using `guix
refresh -L'. Now, to estimate coverage, we need to make HTTP requests
for every single source tarball in Guix to determine if it redirects to
GitHub. This is an enormous number of HTTP requests! When I ran `guix
refresh -L', it took a very long time to finish coverage estimation. So,
I cancelled the command. Any better way to handle this?

>> +(define (follow-redirects-to-github uri)
>> +  "Follow redirects of URI until a GitHub URI is found. Return that GitHub
>> +URI. If no GitHub URI is found, return #f."
>
> Perhaps add the yt-dl.org example as a comment here.

I added a reference to the youtube-dl package in the comments. I also
added a few more comments in other places.

>> +  (define (follow-redirect uri)
>> +    (receive (response body) (http-get uri #:streaming? #t)
>
> Add: (close-port body).

I switched to using (http-head uri) instead of (http-get uri
#:streaming? #t). So, (close-port body) should no longer be required.

I also modified follow-redirects-to-github to avoid following redirects
on mirror and file URIs.

Please find attached a new patch.

>From 7fa1daaf44720fa31813e4f07a2c49a2540a0526 Mon Sep 17 00:00:00 2001
From: Arun Isaac <address@hidden>
Date: Wed, 19 Dec 2018 15:59:52 +0530
Subject: [PATCH] import: github: Support source URIs that redirect to GitHub.

* guix/import/github.scm (follow-redirects-to-github): New function.
(updated-github-url)[updated-url]: For source URIs on other domains, replace
all instances of the old version with the new version.
(latest-release)[origin-github-uri]: If necessary, follow redirects to find
the GitHub URI.
---
 guix/import/github.scm | 41 +++++++++++++++++++++++++++++++++++++----
 1 file changed, 37 insertions(+), 4 deletions(-)

diff --git a/guix/import/github.scm b/guix/import/github.scm
index af9f56e1d..8db7db305 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Ben Woodcroft <address@hidden>
 ;;; Copyright © 2017, 2018 Ludovic Courtès <address@hidden>
+;;; Copyright © 2018 Arun Isaac <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +20,8 @@
 
 (define-module (guix import github)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
@@ -29,6 +32,8 @@
   #:use-module (guix packages)
   #:use-module (guix upstream)
   #:use-module (guix http-client)
+  #:use-module (web client)
+  #:use-module (web response)
   #:use-module (web uri)
   #:export (%github-updater))
 
@@ -39,12 +44,30 @@ false if none is recognized"
         (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar"
               ".tgz" ".tbz" ".love")))
 
+(define (follow-redirects-to-github uri)
+  "Follow redirects of URI until a GitHub URI is found. Return that GitHub
+URI. If no GitHub URI is found, return #f."
+  (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))))
+
+  (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)))
+
 (define (updated-github-url old-package new-version)
   ;; Return a url for the OLD-PACKAGE with NEW-VERSION.  If no source url in
   ;; the OLD-PACKAGE is a GitHub url, then return false.
 
   (define (updated-url url)
-    (if (string-prefix? "https://github.com/"; url)
+    (if (follow-redirects-to-github url)
         (let ((ext     (or (find-extension url) ""))
               (name    (package-name old-package))
               (version (package-version old-package))
@@ -83,7 +106,14 @@ false if none is recognized"
                             url)
             (string-append "/releases/download/" repo "-" version "/" repo "-"
                            version ext))
-           (#t #f))) ; Some URLs are not recognised.
+           ;; As a last resort, attempt to replace all instances of the old
+           ;; version with the new version. This is necessary to handle URIs
+           ;; hosted on other domains that redirect to GitHub (for an example,
+           ;; see the youtube-dl package). We do not know the internal
+           ;; structure of these URIs and cannot handle them more
+           ;; intelligently.
+           (else (regexp-substitute/global
+                  #f version url 'pre new-version 'post))))
         #f))
 
   (let ((source-url (and=> (package-source old-package) origin-uri))
@@ -210,11 +240,14 @@ https://github.com/settings/tokens";))
 (define (latest-release pkg)
   "Return an <upstream-source> for the latest release of PKG."
   (define (origin-github-uri origin)
+    ;; We follow redirects to GitHub because the origin URI might appear to be
+    ;; hosted on some other domain but just redirects to GitHub. For example,
+    ;; see the youtube-dl package.
     (match (origin-uri origin)
       ((? string? url)
-       url)                                       ;surely a github.com URL
+       (follow-redirects-to-github url))
       ((urls ...)
-       (find (cut string-contains <> "github.com") urls))))
+       (find follow-redirects-to-github urls))))
 
   (let* ((source-uri (origin-github-uri (package-source pkg)))
          (name (package-name pkg))
-- 
2.19.2