;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix git-download)
  #:use-module (guix build utils)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix records)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix modules)
  #:use-module (guix ui)
  #:use-module ((guix build git)
                #:select ((git-fetch . build:git-fetch)))
  #:autoload   (guix build-system gnu) (standard-packages)
  #:use-module (ice-9 match)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (git-reference
            git-reference?
            git-reference-url
            git-reference-commit
            git-reference-recursive?

            git-fetch
            git-fetch/impure
            git-version
            git-file-name
            git-predicate))

;;; Commentary:
;;;
;;; An <origin> method that fetches a specific commit from a Git repository.
;;; The repository URL and commit hash are specified with a <git-reference>
;;; object.
;;;
;;; Code:

(define-record-type* <git-reference>
  git-reference make-git-reference
  git-reference?
  (url        git-reference-url)
  (commit     git-reference-commit)
  (recursive? git-reference-recursive?   ; whether to recurse into sub-modules
              (default #f)))

(define (git-package)
  "Return the default Git package."
  (let ((distro (resolve-interface '(gnu packages version-control))))
    (module-ref distro 'git)))

(define* (git-fetch ref hash-algo hash
                    #:optional name
                    #:key (system (%current-system)) (guile (default-guile))
                    (git (git-package)))
  "Return a fixed-output derivation that fetches REF, a <git-reference>
object.  The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
  (define inputs
    ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
    ;; available so that 'git submodule' works.
    (if (git-reference-recursive? ref)
        (standard-packages)
        '()))

  (define zlib
    (module-ref (resolve-interface '(gnu packages compression)) 'zlib))

  (define config.scm
    (scheme-file "config.scm"
                 #~(begin
                     (define-module (guix config)
                       #:export (%libz))

                     (define %libz
                       #+(file-append zlib "/lib/libz")))))

  (define modules
    (cons `((guix config) => ,config.scm)
          (delete '(guix config)
                  (source-module-closure '((guix build git)
                                           (guix build utils)
                                           (guix build download-nar))))))

  (define build
    (with-imported-modules modules
      #~(begin
          (use-modules (guix build git)
                       (guix build utils)
                       (guix build download-nar)
                       (ice-9 match))

          ;; The 'git submodule' commands expects Coreutils, sed,
          ;; grep, etc. to be in $PATH.
          (set-path-environment-variable "PATH" '("bin")
                                         (match '#+inputs
                                           (((names dirs outputs ...) ...)
                                            dirs)))

          (or (git-fetch (getenv "git url") (getenv "git commit")
                         #$output
                         #:recursive? (call-with-input-string
                                          (getenv "git recursive?")
                                        read)
                         #:git-command (string-append #+git "/bin/git"))
              (download-nar #$output)))))

  (mlet %store-monad ((guile (package->derivation guile system)))
    (gexp->derivation (or name "git-checkout") build

                      ;; Use environment variables and a fixed script name so
                      ;; there's only one script in store for all the
                      ;; downloads.
                      #:script-name "git-download"
                      #:env-vars
                      `(("git url" . ,(git-reference-url ref))
                        ("git commit" . ,(git-reference-commit ref))
                        ("git recursive?" . ,(object->string
                                              (git-reference-recursive? ref))))

                      #:system system
                      #:local-build? #t           ;don't offload repo cloning
                      #:hash-algo hash-algo
                      #:hash hash
                      #:recursive? #t
                      #:guile-for-build guile)))

(define (clone-to-store store name git-reference hash runtime-dependencies)
  "Clone a Git repository, add it to the store, and return its store path.
STORE is an open connection to the store.  NAME will be used as the file name.
GIT-REFERENCE is a <git-reference> describing the Git repository to clone.
HASH is the recursive SHA256 hash value of the Git repository, as produced by
\"guix hash --recursive\" after the .git directories have been removed; if a
fixed output derivation has already added content to the store with this HASH,
then this procedure returns immediately.  RUNTIME-DEPENDENCIES is a list of
store paths; the \"bin\" directory of the RUNTIME-DEPENDENCIES will be added
to the PATH environment variable before running the \"git\" program."
  (define (is-source? name stat)
    ;; It's source if and only if it isn't a .git directory.
    (not (and (eq? (stat:type stat) 'directory)
              (equal? name ".git"))))

  (define (clean staging-directory)
    (when (file-exists? staging-directory)
      (info (G_ "Removing staging directory `~a'~%") staging-directory)
      (delete-file-recursively staging-directory)))

  (define (fetch staging-directory)
    (info
     (G_ "Downloading Git repository `~a' to staging directory `~a'~%")
     (git-reference-url git-reference)
     staging-directory)
    (mkdir-p staging-directory)
    ;; Git prints some messages to stdout, which is a minor blemish because it
    ;; interferes with convenient shell idioms like "ls $(guix build
    ;; my-package)".  However, if we try to redirect stdout to stderr using
    ;; with-output-to-port, and if Git fails because SSH is not available,
    ;; then mysteriously Git's helpful error messages do not get printed.  It
    ;; seems better to surface useful error messages here than to hide them.
    (build:git-fetch
     (git-reference-url git-reference)
     (git-reference-commit git-reference)
     staging-directory
     #:recursive? (git-reference-recursive? git-reference))
    (info (G_ "Adding `~a' to the store~%") staging-directory)
    ;; Even when the git fetch was not done recursively, we want to
    ;; recursively add to the store the results of the git fetch.
    (add-to-store store name #t "sha256" staging-directory
                  #:select? is-source?))

  ;; To ensure the derivation produced by git-fetch/impure does not need to be
  ;; run, the name passed to fixed-output-path must be the same as the name
  ;; used when calling gexp->derivation in git-fetch/impure.
  (let* ((output (fixed-output-path name hash))
         (already-fetched? (false-if-exception (valid-path? store output)))
         (tmpdir (or (getenv "TMPDIR") "/tmp"))
         (checkouts-directory (string-append
                               tmpdir "/guix-git-ssh-checkouts"))
         (staging-directory (string-append checkouts-directory "/" name))
         (original-path (getenv "PATH")))
    ;; We might need to clean up before starting.  For example, we would need
    ;; to do that if Guile crashed during a previous fetch.
    (clean staging-directory)
    (if already-fetched?
        output
        (begin
          ;; Put our Guix-managed runtime dependencies at the front of the
          ;; PATH so they will be used in favor of whatever happens to be in
          ;; the user's environment (except for SSH, of course).  Redirect
          ;; stdout to stderr to keep set-path-environment-variable from
          ;; printing a misleading message about PATH's value, since we
          ;; immediately change it.
          (with-output-to-port (%make-void-port "w")
            (lambda ()
              (set-path-environment-variable
               "PATH" '("bin") runtime-dependencies)))
          (let ((new-path (if original-path
                              (string-append
                               (getenv "PATH") ":" original-path)
                              (getenv "PATH"))))
            (setenv "PATH" new-path)
            (info (G_ "Set environment variable PATH to `~a'~%") new-path)
            (let ((result (fetch staging-directory)))
              (clean staging-directory)
              result))))))

(define clone-to-store* (store-lift clone-to-store))

(define (git-reference->name git-reference)
  (let ((repository-name (basename (git-reference-url git-reference) ".git"))
        (short-commit (string-take (git-reference-commit git-reference) 9)))
    (string-append repository-name "-" short-commit "-checkout")))

(define* (git-fetch/impure ref hash-algo hash
                           #:optional name
                           #:key
                           (system (%current-system))
                           (guile (default-guile)))
  "Return a fixed-output derivation that fetches REF, a <git-reference>
object.  The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f.

This procedure yields the same result as git-fetch; however, it explicitly
allows impurities from the environment in which it is invoked: the \"ssh\"
client program currently available via the PATH environment variable, its SSH
configuration file (usually found at ~/.ssh/config), and any SSH agent that is
currently running (usually made available via environment variables such as
SSH_AUTH_SOCK).

This procedure should not be used in package origins in the official Guix
distribution.  Due to its impurity, if two people have configured SSH
differently, it is possible that the origin will work for one person but not
for the other.  This fetch method is intended as a convenience for cases
where, due to the circumstances of your situation, the Git repository is only
available over an authenticated SSH connection."
  (mlet* %store-monad
      ((name -> (or name (git-reference->name ref)))
       (guile (package->derivation guile system))
       (git -> `("git" ,(git-package)))
       ;; When doing 'git clone --recursive', we need sed, grep, etc. to be
       ;; available so that 'git submodule' works.  We do not add an SSH
       ;; client to the inputs here, since we explicitly want to use the SSH
       ;; client, SSH agent, and SSH config from the current environment.
       (inputs -> `(,git ,@(if (git-reference-recursive? ref)
                               (standard-packages)
                               '())))
       (input-packages -> (match inputs (((names packages outputs ...) ...)
                                         packages)))
       (input-derivations (sequence %store-monad
                                    (map (cut package->derivation <> system)
                                         input-packages)))
       ;; The tools that clone-to-store requires (e.g., Git) must be built
       ;; before we invoke clone-to-store.
       (ignored (built-derivations input-derivations))
       (input-paths -> (map derivation->output-path input-derivations))
       (checkout (clone-to-store* name ref hash input-paths)))
    ;; To ensure that commands like "guix build --source my-package" don't
    ;; fail, return (as a monadic value) a derivation here.  We could just
    ;; tail-call clone-to-store* instead of going through the effort of
    ;; returning a derivation here, but then the aforementioned command would
    ;; fail for the same reason that it fails when the origin is defined with
    ;; "local-file".  This is the ONLY reason why we call gexp->derivation
    ;; here.  In fact, this derivation will never actually be run, since we
    ;; always fetch its contents via clone-to-store* first.
    (gexp->derivation
     ;; To ensure this derivation does not need to be run, the name used here
     ;; must be the same as the name used when calling fixed-output-path in
     ;; clone-to-store.
     name
     ;; This builder never runs, so the actual builder code doesn't matter.
     ;; However, we must ungexp the output variable, or the derivation will
     ;; produce no output path.
     #~(ungexp output)
     ;; Slashes are not allowed in file names.
     #:script-name "git-download-impure"
     #:system system
     ;; Fetching a Git repository is usually a network-bound operation, so
     ;; offloading is unlikely to speed things up.
     #:local-build? #t
     #:hash-algo hash-algo
     #:hash hash
     ;; Even when the git fetch will not be done recursively, we want to
     ;; recursively add to the store the results of the git fetch.
     #:recursive? #t
     #:guile-for-build guile)))

(define (git-version version revision commit)
  "Return the version string for packages using git-download."
  (string-append version "-" revision "." (string-take commit 7)))

(define (git-file-name name version)
  "Return the file-name for packages using git-download."
  (string-append name "-" version "-checkout"))


;;;
;;; 'git-predicate'.
;;;

(define (files->directory-tree files)
  "Return a tree of vhashes representing the directory listed in FILES, a list
like '(\"a/b\" \"b/c/d\")."
  (fold (lambda (file result)
          (let loop ((file (string-split file #\/))
                     (result result))
            (match file
              ((_)
               result)
              ((directory children ...)
               (match (vhash-assoc directory result)
                 (#f
                  (vhash-cons directory (loop children vlist-null)
                              result))
                 ((_ . previous)
                  ;; XXX: 'vhash-delete' is O(n).
                  (vhash-cons directory (loop children previous)
                              (vhash-delete directory result)))))
              (()
               result))))
        vlist-null
        files))

(define (directory-in-tree? tree directory)
  "Return true if DIRECTORY, a string like \"a/b\", denotes a directory listed
in TREE."
  (let loop ((directory (string-split directory #\/))
             (tree       tree))
    (match directory
      (()
       #t)
      ((head . tail)
       (match (vhash-assoc head tree)
         ((_ . sub-tree) (loop tail sub-tree))
         (#f #f))))))

(define (git-predicate directory)
  "Return a predicate that returns true if a file is part of the Git checkout
living at DIRECTORY.  Upon Git failure, return #f instead of a predicate.

The returned predicate takes two arguments FILE and STAT where FILE is an
absolute file name and STAT is the result of 'lstat'."
  (let* ((pipe           (with-directory-excursion directory
                           (open-pipe* OPEN_READ "git" "ls-files")))
         (files          (let loop ((lines '()))
                           (match (read-line pipe)
                             ((? eof-object?)
                              (reverse lines))
                             (line
                              (loop (cons line lines))))))
         (directory-tree (files->directory-tree files))
         (inodes         (fold (lambda (file result)
                                 (let ((stat
                                        (lstat (string-append directory "/"
                                                              file))))
                                   (vhash-consv (stat:ino stat) (stat:dev stat)
                                                result)))
                               vlist-null
                               files))

         ;; Note: For this to work we must *not* call 'canonicalize-path' on
         ;; DIRECTORY or we would get discrepancies of the returned lambda is
         ;; called with a non-canonical file name.
         (prefix-length  (+ 1 (string-length directory)))

         (status         (close-pipe pipe)))
    (and (zero? status)
         (lambda (file stat)
           (match (stat:type stat)
             ('directory
              (directory-in-tree? directory-tree
                                  (string-drop file prefix-length)))
             ((or 'regular 'symlink)
              ;; Comparing file names is always tricky business so we rely on
              ;; inode numbers instead
              (match (vhash-assv (stat:ino stat) inodes)
                ((_ . dev) (= dev (stat:dev stat)))
                (#f        #f)))
             (_
              #f))))))

;;; git-download.scm ends here