From 7fa1daaf44720fa31813e4f07a2c49a2540a0526 Mon Sep 17 00:00:00 2001 From: Arun Isaac 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 ;;; Copyright © 2017, 2018 Ludovic Courtès +;;; Copyright © 2018 Arun Isaac ;;; ;;; 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 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