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")))