From 42cee916b5d0f59d81b808de0117d33245baf533 Mon Sep 17 00:00:00 2001 From: Timo Wilken Date: Mon, 5 Aug 2024 16:30:31 +0100 Subject: Allow serving git repos from untrusted paths I'm setting the base path anyway, and no untrusted user controls anything in there. --- tw/packages/git.scm | 263 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tw/system/lud.scm | 5 +- 2 files changed, 267 insertions(+), 1 deletion(-) create mode 100644 tw/packages/git.scm 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: + ;; . + (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 "~ (/.*)")) -- cgit v1.2.3