Allow serving git repos from untrusted paths

I'm setting the base path anyway, and no untrusted user controls anything in
there.

2 files changed, 267 insertions, 1 deletions

diff --git a/tw/packages/git.scm b/tw/packages/git.scm
new file mode 100644
index 00000000..62f690fe
--- /dev/null
+++ b/tw/packages/git.scm
@@ -0,0 +1,263 @@
+(define-module (tw packages git)
+  #:use-module (guix packages)
+  #:use-module ((guix utils) #:select (system-hurd?))
+  #:use-module ((gnu packages docbook) #:select (docbook-xsl))
+  #:use-module ((gnu packages version-control) #:select (git)))
+
+(define-public git/unsafe-directories
+  (hidden-package   ; Users shouldn't normally want to use this, e.g. for `guix shell'.
+   (package
+     (inherit git)
+     (arguments
+      `(,@(package-arguments git)
+        #:phases   ; after the original arguments, to override original phases
+        (modify-phases %standard-phases
+          (add-after 'install 'override-gitconfig
+            (lambda* (#:key outputs #:allow-other-keys)
+              (with-output-to-file
+                  (string-append (assoc-ref outputs "out")
+                                 "/etc/gitconfig")
+                (lambda ()
+                  (display "[safe]\n\tdirectory = *\n")))))
+
+          ;; The below phases are copied from the main git package because it
+          ;; does not seem to be possible to selectively override them.
+          ,@(if (%current-target-system)
+                ;; The git build system assumes build == host
+                `((add-after 'unpack  'use-host-uname_S
+                    (lambda _
+                      (substitute* "config.mak.uname"
+                        (("uname_S := .*" all)
+                         (if (equal? ,(%current-target-system) "i586-pc-gnu")
+                             "uname_S := GNU\n"
+                             all))))))
+                ;; We do not have bash-for-tests when cross-compiling.
+                `((add-after 'unpack 'modify-PATH
+                    (lambda* (#:key inputs #:allow-other-keys)
+                      (let ((path (string-split (getenv "PATH") #\:))
+                            (bash-full (assoc-ref inputs "bash-for-tests")))
+                        ;; Drop the test bash from PATH so that (which "sh") and
+                        ;; similar does the right thing.
+                        (setenv "PATH" (string-join
+                                        (remove (cut string-prefix? bash-full <>) path)
+                                        ":")))))))
+          ;; Add cross curl-config script to PATH when cross-compiling.
+          ,@(if (%current-target-system)
+                '((add-before 'configure 'add-cross-curl-config
+                    (lambda* (#:key inputs #:allow-other-keys)
+                      (setenv "PATH"
+                              (string-append (assoc-ref inputs "curl") "/bin:"
+                                             (getenv "PATH"))))))
+                '())
+          (add-after 'configure 'patch-makefiles
+            (lambda _
+              (substitute* "Makefile"
+                (("/usr/bin/perl") (which "perl"))
+                (("/usr/bin/python") (which "python3")))))
+          (add-after 'configure 'add-PM.stamp
+            (lambda _
+              ;; Add the "PM.stamp" to avoid "no rule to make target".
+              (call-with-output-file "perl/PM.stamp" (const #t))))
+          (add-after 'build 'build-subtree
+            (lambda* (#:key inputs #:allow-other-keys)
+              (with-directory-excursion "contrib/subtree"
+                (substitute* "Makefile"
+                  ;; Apparently `xmlto' does not bother to looks up the stylesheets
+                  ;; specified in the XML, unlike the above substitution.  Instead it
+                  ;; uses a hard-coded URL.  Work around it here, but if this is
+                  ;; common perhaps we should hardcode this path in xmlto itself.
+                  (("\\$\\(XMLTO\\) -m \\$\\(MANPAGE_XSL\\)")
+                   (string-append "$(XMLTO) -x "
+                                  (string-append (assoc-ref inputs "docbook-xsl")
+                                                 "/xml/xsl/docbook-xsl-"
+                                                 ,(package-version docbook-xsl))
+                                  "/manpages/docbook.xsl -m $(MANPAGE_XSL)")))
+                (invoke "make")
+                (invoke "make" "install")
+                (invoke "make" "install-doc")
+                (substitute* "git-subtree"
+                  (("/bin/sh") (which "sh"))))))
+          (add-before 'check 'patch-tests
+            (lambda _
+              (let ((store-directory (%store-directory)))
+                ;; These files contain some funny bytes that Guile is unable
+                ;; to decode for shebang patching. Just delete them.
+                (for-each delete-file '("t/t4201-shortlog.sh"
+                                        "t/t7813-grep-icase-iso.sh"))
+                ;; Many tests contain inline shell scripts (hooks etc).
+                (substitute* (find-files "t" "\\.sh$")
+                  (("#!/bin/sh") (string-append "#!" (which "sh"))))
+                ;; Un-do shebang patching here to prevent checksum mismatch.
+                (substitute* '("t/t4034/perl/pre" "t/t4034/perl/post")
+                  (("^#!.*/bin/perl") "#!/usr/bin/perl"))
+                (substitute* "t/t5003-archive-zip.sh"
+                  (("cp /bin/sh") (string-append "cp " (which "sh"))))
+                (substitute* "t/t6030-bisect-porcelain.sh"
+                  (("\"/bin/sh\"") (string-append "\"" (which "sh") "\"")))
+                ;; FIXME: This test runs `git commit` with a bogus EDITOR
+                ;; and empty commit message, but does not fail the way it's
+                ;; expected to. The test passes when invoked interactively.
+                (substitute* "t/t7508-status.sh"
+                  (("\tcommit_template_commented") "\ttrue"))
+                ;; More checksum mismatches due to odd shebangs.
+                (substitute* "t/t9100-git-svn-basic.sh"
+                  (((string-append "\"#!" store-directory ".*/bin/sh")) "\"#!/bin/sh") )
+                (substitute* "t/t9300-fast-import.sh"
+                  (((string-append "\t#!" store-directory ".*/bin/sh")) "\t#!/bin/sh")
+                  (((string-append "'#!" store-directory ".*/bin/sh")) "'#!/bin/sh"))
+                ;; FIXME: Some hooks fail with "basename: command not found".
+                ;; See 't/trash directory.t9164.../svn-hook.log'.
+                (delete-file "t/t9164-git-svn-dcommit-concurrent.sh")
+
+                ;; XXX: These tests fail intermittently for unknown reasons:
+                ;; <https://bugs.gnu.org/29546>.
+                (for-each delete-file
+                          '("t/t9128-git-svn-cmd-branch.sh"
+                            "t/t9167-git-svn-cmd-branch-subproject.sh"
+                            "t/t9141-git-svn-multiple-branches.sh")))))
+          (add-after 'install 'install-info-manual
+            (lambda* (#:key parallel-build? #:allow-other-keys)
+              (define job-count (if parallel-build?
+                                    (number->string (parallel-job-count))
+                                    "1"))
+              (invoke "make" "-C" "Documentation" "install-info"
+                      "-j" job-count
+                      ;; The Makefile refer to 'docbook2x-texi', but our binary
+                      ;; is named 'docbook2texi'.
+                      "DOCBOOK2X_TEXI=docbook2texi" "PERL_PATH=perl")))
+          (add-after 'install 'install-shell-completion
+            (lambda* (#:key outputs #:allow-other-keys)
+              (let* ((out         (assoc-ref outputs "out"))
+                     (completions (string-append out "/etc/bash_completion.d")))
+                ;; TODO: Install the tcsh and zsh completions in the right place.
+                (mkdir-p completions)
+                (copy-file "contrib/completion/git-completion.bash"
+                           (string-append completions "/git")))))
+          (add-after 'install 'install-credential-netrc
+            (lambda* (#:key outputs #:allow-other-keys)
+              (let* ((netrc (assoc-ref outputs "credential-netrc")))
+                (install-file "contrib/credential/netrc/git-credential-netrc.perl"
+                              (string-append netrc "/bin"))
+                (rename-file (string-append netrc "/bin/git-credential-netrc.perl")
+                             (string-append netrc "/bin/git-credential-netrc"))
+                ;; Previously, Git.pm was automatically found by netrc.
+                ;; Perl 5.26 changed how it locates modules so that @INC no
+                ;; longer includes the current working directory (the Perl
+                ;; community calls this "dotless @INC").
+                (wrap-program (string-append netrc "/bin/git-credential-netrc")
+                  `("PERL5LIB" ":" prefix
+                    (,(string-append (assoc-ref outputs "out") "/share/perl5")))))))
+          (add-after 'install 'install-credential-libsecret
+            (lambda* (#:key outputs #:allow-other-keys)
+              (let* ((libsecret (assoc-ref outputs "credential-libsecret")))
+                (with-directory-excursion "contrib/credential/libsecret"
+                  ((assoc-ref gnu:%standard-phases 'build))
+                  (install-file "git-credential-libsecret"
+                                (string-append libsecret "/bin"))))))
+          (add-after 'install 'install-subtree
+            (lambda* (#:key outputs #:allow-other-keys)
+              (let ((subtree (assoc-ref outputs "subtree")))
+                (install-file "contrib/subtree/git-subtree"
+                              (string-append subtree "/bin"))
+                (install-file "contrib/subtree/git-subtree.1"
+                              (string-append subtree "/share/man/man1")))))
+          (add-after 'install 'restore-sample-hooks-shebang
+            (lambda* (#:key outputs #:allow-other-keys)
+              (let* ((out (assoc-ref outputs "out"))
+                     (dir (string-append out "/share/git-core/templates/hooks")))
+                (for-each (lambda (file)
+                            (format #t "restoring shebang on `~a'~%" file)
+                            (substitute* file
+                              (("^#!.*/bin/sh") "#!/bin/sh")))
+                          (find-files dir ".*")))))
+          (add-after 'install 'split
+            (lambda* (#:key inputs outputs #:allow-other-keys)
+              ;; Split the binaries to the various outputs.
+              (let* ((out      (assoc-ref outputs "out"))
+                     (se       (assoc-ref outputs "send-email"))
+                     (svn      (assoc-ref outputs "svn"))
+                     (gui      (assoc-ref outputs "gui"))
+                     (gitk     (string-append out "/bin/gitk"))
+                     (gitk*    (string-append gui "/bin/gitk"))
+                     (git-gui  (string-append out "/libexec/git-core/git-gui"))
+                     (git-gui* (string-append gui "/libexec/git-core/git-gui"))
+                     (git-cit  (string-append out "/libexec/git-core/git-citool"))
+                     (git-cit* (string-append gui "/libexec/git-core/git-citool"))
+                     (git-se   (string-append out "/libexec/git-core/git-send-email"))
+                     (git-se*  (string-append se  "/libexec/git-core/git-send-email"))
+                     (git-svn  (string-append out "/libexec/git-core/git-svn"))
+                     (git-svn* (string-append svn "/libexec/git-core/git-svn"))
+                     (git-sm   (string-append out
+                                              "/libexec/git-core/git-submodule")))
+                (mkdir-p (string-append gui "/bin"))
+                (mkdir-p (string-append gui "/libexec/git-core"))
+                (mkdir-p (string-append se  "/libexec/git-core"))
+                (mkdir-p (string-append svn "/libexec/git-core"))
+
+                (for-each (lambda (old new)
+                            (copy-file old new)
+                            (delete-file old)
+                            (chmod new #o555))
+                          (list gitk git-gui git-cit git-se git-svn)
+                          (list gitk* git-gui* git-cit* git-se* git-svn*))
+
+                ;; Tell 'git-svn' where Subversion and perl-term-readkey are.
+                (wrap-program git-svn*
+                  `("PATH" ":" prefix
+                    (,(string-append (assoc-ref inputs "subversion")
+                                     "/bin")))
+                  `("PERL5LIB" ":" prefix
+                    ,(map (lambda (i) (string-append (assoc-ref inputs i)
+                                                     "/lib/perl5/site_perl"))
+                          '("subversion" "perl-term-readkey")))
+
+                  ;; XXX: The .so for SVN/Core.pm lacks a RUNPATH, so
+                  ;; help it find 'libsvn_client-1.so'.
+                  `("LD_LIBRARY_PATH" ":" prefix
+                    (,(string-append (assoc-ref inputs "subversion")
+                                     "/lib"))))
+
+                ;; Tell 'git-send-email' where perl modules are.
+                (wrap-program git-se*
+                  `("PERL5LIB" ":" prefix
+                    ,(map (lambda (o) (string-append o "/lib/perl5/site_perl"))
+                          (list
+                           ,@(transitive-input-references
+                              'inputs
+                              (map (lambda (l)
+                                     (assoc l (package-inputs this-package)))
+                                   '("perl-authen-sasl"
+                                     "perl-net-smtp-ssl"
+                                     "perl-io-socket-ssl")))))))
+
+                ;; Tell 'gitweb.cgi' where perl modules are.
+                (wrap-program (string-append out "/share/gitweb/gitweb.cgi")
+                  `("PERL5LIB" ":" prefix
+                    ,(map (lambda (o) (string-append o "/lib/perl5/site_perl"))
+                          (list
+                           ,@(transitive-input-references
+                              'inputs
+                              (map (lambda (l)
+                                     (assoc l (package-inputs this-package)))
+                                   '("perl-cgi")))))))
+
+                ;; Tell 'git-submodule' where Perl is.
+                (wrap-program git-sm
+                  `("PATH" ":" prefix
+                    (,(string-append (assoc-ref inputs "perl")
+                                     "/bin")))))))
+          (add-after 'split 'install-man-pages
+            (lambda* (#:key inputs outputs #:allow-other-keys)
+              (let* ((out (assoc-ref outputs "out"))
+                     (man (string-append out "/share/man"))
+                     (manpages (assoc-ref inputs "git-manpages")))
+                (mkdir-p man)
+                (with-directory-excursion man
+                  (invoke "tar" "xvf" manpages)))))
+          ,@(if (system-hurd?)
+                '((add-after 'unpack 'delete-tests/hurd
+                    (lambda _
+                      (delete-file "t/t0052-simple-ipc.sh")
+                      (delete-file "t/t5562-http-backend-content-length.sh")
+                      (delete-file "t/t9902-completion.sh"))))
+                '())))))))
diff --git a/tw/system/lud.scm b/tw/system/lud.scm
index a5b9d58e..2e0ea190 100644
--- a/tw/system/lud.scm
+++ b/tw/system/lud.scm
@@ -5,6 +5,7 @@
   #:use-module (gnu system locale)
   #:use-module (gnu system nss)
   #:use-module (guix gexp)
+  #:use-module (tw packages git)
   #:use-module (tw services dns)
   #:use-module (tw services games)
   #:use-module (tw services nextcloud)
@@ -172,7 +173,9 @@ that I just want to host somewhere.")
                        (locations
                         (list (nginx-location-configuration
                                (inherit (git-http-nginx-location-configuration
-                                         (git-http-configuration (uri-path "/"))))
+                                         (git-http-configuration
+                                          (package git/unsafe-directories)
+                                          (uri-path "/"))))
                                ;; Fix location URI -- `git-http-nginx-location-configuration'
                                ;; adds a double slash in the beginning if `uri-path' is "/".
                                (uri "~ (/.*)"))