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

[Arun Isaac]

Many GitHub hosted packages (for example, youtube-dl) present source
tarballs for download on their website
(https://yt-dl.org/downloads/latest/youtube-dl-2018.12.17.tar.gz). But
these URIs just redirect to GitHub. Currently, our GitHub refresher
does not cover these packages. This patch addresses that.

>From 90f756fd6f7df50236023e120cb040f6e5d1718c 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 | 34 ++++++++++++++++++++++++++++++----
 1 file changed, 30 insertions(+), 4 deletions(-)

diff --git a/guix/import/github.scm b/guix/import/github.scm
index af9f56e1d..d4d582b6a 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,27 @@ 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-get uri #:streaming? #t)
+      (case (response-code response)
+        ((301 302)
+         (uri->string (assoc-ref (response-headers response) 'location)))
+        (else #f))))
+
+  (if (string-prefix? "https://github.com/"; uri)
+      uri
+      (and=> (follow-redirect uri)
+             follow-redirects-to-github)))
+
 (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 +103,13 @@ 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. 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))
@@ -212,9 +238,9 @@ https://github.com/settings/tokens";))
   (define (origin-github-uri origin)
     (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