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

@@ -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))
+      (let ((valid-status-p
-      (numberp (ignore-errors (search-forward-regexp smart-content-type))))))
+             (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"

test/issues/el-get-issue-1920.el

@@ -1,35 +1,36 @@
-;; Test for testing `el-get-git-shallow-clone-supported-p' function
+;;; Test for testing `el-get-git-shallow-clone-supported-p' function
-;; the function detects whether shallow clone is supported for url
+;;; 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"))
+;; responses to HEAD
-(cl-assert (not (el-get-git-is-host-smart-http-p "http://www.dr-qubit.org/git/undo-tree.git")))
+(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]
+;;; Tests for function [el-get-git-shallow-clone-supported-p]
-;; `git', `ssh' and `file' support shallow clones
+;;; `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
+;;; 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/")))
 (cl-assert (not (el-get-git-shallow-clone-supported-p "http://michael.orlitzky.com/git/nagios-mode.git")))