From 3969e02b2755d11224b80d2db9d2b8fc5ae73711 Mon Sep 17 00:00:00 2001 From: stephan-cr Date: Sun, 1 Jan 2023 13:31:18 +0100 Subject: [PATCH] Fix Git HTTP smart host detection (#2854) * Fix Git HTTP smart host detection regression test test/issues/el-get-issue-1920.el revealed that Git HTTP smart host detection is broken. Not all hosts support the HEAD HTTP request method. For example, github.com for HEAD (let ((url-request-method "HEAD")) (url-retrieve-synchronously "https://github.com/dimitri/el-get.git/info/refs\?service\=git-upload-pack")) responds HTTP/1.1 405 Method Not Allowed Server: GitHub Babel 2.0 Content-Type: text/plain Content-Security-Policy: default-src 'none'; sandbox Content-Length: 0 X-Frame-Options: DENY X-GitHub-Request-Id: C1DA:12E32:2B6C9D7:302B1C2:61C9A4E8 while for GET (let ((url-request-method "GET")) (url-retrieve-synchronously "https://github.com/dimitri/el-get.git/info/refs\?service\=git-upload-pack")) responds HTTP/1.1 200 OK Server: GitHub Babel 2.0 Content-Type: application/x-git-upload-pack-advertisement Content-Security-Policy: default-src 'none'; sandbox Transfer-Encoding: chunked expires: Fri, 01 Jan 1980 00:00:00 GMT pragma: no-cache Cache-Control: no-cache, max-age=0, must-revalidate Vary: Accept-Encoding X-Frame-Options: DENY X-GitHub-Request-Id: C22C:5E15:3923777:3D822AC:61CA332A Other hosts like git.sr.ht do support HEAD, of course. Furthermore, the HTTP status code wasn't checked, that's why hosts like github.com would be classified as "dumb" hosts. This commit checks the HTTP status code, and if the status is not 200 or 304 for the HEAD HTTP request method, it tries GET. HEAD is tried first, because GET might be more expensive for big repositories. The regression test is adapted as well. * Fix byte compiler warnings --- methods/el-get-git.el | 44 +++++++++++++++++++++++++++----- test/issues/el-get-issue-1920.el | 27 ++++++++++---------- 2 files changed, 52 insertions(+), 19 deletions(-) diff --git a/methods/el-get-git.el b/methods/el-get-git.el index 99f63805..3aabc2a2 100644 --- a/methods/el-get-git.el +++ b/methods/el-get-git.el @@ -15,6 +15,7 @@ (require 'cl-lib) (require 'el-get-core) (require 'el-get-recipes) +(require 'url-http) (defcustom el-get-git-clone-hook nil "Hook run after git clone." @@ -26,12 +27,18 @@ :group 'el-get :type 'boolean) -(defcustom el-get-git-known-smart-domains '("www.github.com" "www.bitbucket.org" "repo.or.cz" "code.orgmode.org") +(defcustom el-get-git-known-smart-domains '("www.github.com" "www.bitbucket.org" "repo.or.cz" "git.sr.ht") "List of domains which are known to support shallow clone, el-get will not make explicit checks for these" :group 'el-get :type 'list) +;; The following variables are declared here to silence the byte +;; compiler "reference to variable" warning. The package "url-http" +;; provides these variables. +(defvar url-http-content-type) +(defvar url-http-response-status) + (defun el-get-git-executable () "Return git executable to use, or signal an error when not found." @@ -61,11 +68,15 @@ though they do not indicate this in their response headers see (defun el-get-git-is-host-smart-http-p (giturl) "Detect if the host supports shallow clones using http(s). GITURL is url to the git repository, this function is intended to be used only with http(s) -urls. The function uses the approach described here [http://stackoverflow.com/questions/9270488/] +urls. The function uses the approach described here +[http://stackoverflow.com/questions/9270488/] Basically it makes a HEAD request and checks the Content-Type for 'smart' MIME type. This approach does not work for some domains like `bitbucket', which do -not return 'smart' headers despite supporting shallow clones" +not return 'smart' headers despite supporting shallow clones. + +Other domains like `github' return 405 for HEAD and only respond to GET. In this +case, if HEAD doesn't respond with 200 or 304, GET is tried as well." (let ((url-request-method "HEAD") (req-url (format "%s%s/info/refs\?service\=git-upload-pack" giturl @@ -74,11 +85,32 @@ not return 'smart' headers despite supporting shallow clones" (if (string-match "\\.git\\'" giturl) "" ".git"))) - (smart-content-type "Content-Type: application/x-git-upload-pack-advertisement")) + (smart-content-type "application/x-git-upload-pack-advertisement") + ;; according to https://www.git-scm.com/docs/http-protocol, + ;; 200 and 304 are valid + (valid-response-status-p + (lambda (status) (or (= status 200) (= status 304)))) + (retry-with-get-p nil) + (smart-p nil)) (with-current-buffer (url-retrieve-synchronously req-url) - (goto-char (point-min)) - (numberp (ignore-errors (search-forward-regexp smart-content-type)))))) + (let ((valid-status-p + (funcall valid-response-status-p url-http-response-status))) + (setq retry-with-get-p (not valid-status-p)) + (setq smart-p (string= url-http-content-type smart-content-type)))) + + (when retry-with-get-p + (setq url-request-method "GET") + (with-current-buffer (url-retrieve-synchronously req-url) + (let ((valid-status-p + (funcall valid-response-status-p url-http-response-status))) + (unless valid-status-p + (error "Unable to detect if %s is a smart HTTP host" giturl)) + (setq smart-p + (and valid-status-p + (string= url-http-content-type smart-content-type)))))) + + smart-p)) (defun el-get-git-shallow-clone-supported-p (url) "Check if shallow clone is supported for given URL" diff --git a/test/issues/el-get-issue-1920.el b/test/issues/el-get-issue-1920.el index 293dff3e..d8972288 100644 --- a/test/issues/el-get-issue-1920.el +++ b/test/issues/el-get-issue-1920.el @@ -1,35 +1,36 @@ -;; Test for testing `el-get-git-shallow-clone-supported-p' function -;; the function detects whether shallow clone is supported for url +;;; Test for testing `el-get-git-shallow-clone-supported-p' function +;;; the function detects whether shallow clone is supported for url (require 'cl-lib) -;; Tests for lower level function [el-get-git-url-from-known-smart-domains-p] +;;; Tests for lower level function [el-get-git-url-from-known-smart-domains-p] (cl-assert (el-get-git-shallow-clone-supported-p "https://www.bitbucket.org/alfaromurillo/org-passwords.el.git")) (cl-assert (el-get-git-url-from-known-smart-domains-p "https://www.github.com/dimitri/el-get")) (cl-assert (el-get-git-url-from-known-smart-domains-p "https://bitbucket.org/alfaromurillo/org-passwords.el.git")) (cl-assert (el-get-git-url-from-known-smart-domains-p "https://github.com/dimitri/el-get")) -;; Tests for lower level function [el-get-git-is-host-smart-http-p] +;;; Tests for lower level function [el-get-git-is-host-smart-http-p] +;; responses to GET, but not HEAD (cl-assert (el-get-git-is-host-smart-http-p "https://github.com/dimitri/el-get.git")) -(cl-assert (el-get-git-is-host-smart-http-p "http://repo.or.cz/r/anything-config.git")) -(cl-assert (not (el-get-git-is-host-smart-http-p "http://www.dr-qubit.org/git/undo-tree.git"))) +;; responses to HEAD +(cl-assert (el-get-git-is-host-smart-http-p "https://repo.or.cz/r/anything-config.git")) +(cl-assert (el-get-git-is-host-smart-http-p "https://gitlab.com/tsc25/undo-tree.git")) -;; Function should not fail for urls without '.git' prefix +;;; Function should not fail for urls without '.git' prefix (cl-assert (el-get-git-is-host-smart-http-p "https://github.com/dimitri/el-get")) (cl-assert (el-get-git-is-host-smart-http-p "http://repo.or.cz/r/anything-config")) -(cl-assert (not (el-get-git-is-host-smart-http-p "http://www.dr-qubit.org/git/undo-tree"))) +(cl-assert (el-get-git-is-host-smart-http-p "https://gitlab.com/tsc25/undo-tree")) -;; Tests for function [el-get-git-shallow-clone-supported-p] -;; `git', `ssh' and `file' support shallow clones +;;; Tests for function [el-get-git-shallow-clone-supported-p] +;;; `git', `ssh' and `file' support shallow clones (cl-assert (el-get-git-shallow-clone-supported-p "git://gitorious.org/evil/evil.git")) (cl-assert (el-get-git-shallow-clone-supported-p "file:///opt/git/project.git")) (cl-assert (el-get-git-shallow-clone-supported-p "ssh://some_user@some_server/some_project.git")) -;; The following repos support shallow clones +;;; The following repos support shallow clones (cl-assert (el-get-git-shallow-clone-supported-p "http://repo.or.cz/r/anything-config.git")) (cl-assert (el-get-git-shallow-clone-supported-p "https://github.com/dimitri/el-get")) (cl-assert (el-get-git-shallow-clone-supported-p "https://bitbucket.org/alfaromurillo/org-passwords.el.git")) -;; The following do not support shallow clones -(cl-assert (not (el-get-git-shallow-clone-supported-p "http://www.dr-qubit.org/git/undo-tree.git/"))) +;;; The following do not support shallow clones (cl-assert (not (el-get-git-shallow-clone-supported-p "http://michael.orlitzky.com/git/nagios-mode.git")))