;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012-2021, 2023 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 (test-store)
  #:use-module (guix tests)
  #:use-module (guix config)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix monads)
  #:use-module ((gcrypt hash) #:prefix gcrypt:)
  #:use-module ((gcrypt pk-crypto) #:prefix gcrypt:)
  #:use-module (guix pki)
  #:use-module (guix base32)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix serialization)
  #:use-module (guix build utils)
  #:use-module (guix gexp)
  #:use-module (gnu packages)
  #:use-module (gnu packages bootstrap)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (web uri)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64))

;; Test the (guix store) module.

(define %store
  (open-connection-for-tests))

(define %shell
  (or (getenv "SHELL") (getenv "CONFIG_SHELL") "/bin/sh"))


(test-begin "store")

(test-assert "open-connection with file:// URI"
  (let ((store (open-connection (string-append "file://"
                                               (%daemon-socket-uri)))))
    (and (add-text-to-store store "foo" "bar")
         (begin
           (close-connection store)
           #t))))

(test-equal "connection handshake error"
  EPROTO
  (let ((port (%make-void-port "rw")))
    (guard (c ((store-connection-error? c)
               (and (eq? port (store-connection-error-file c))
                    (store-connection-error-code c))))
      (open-connection #f #:port port)
      'broken)))

(test-equal "store-path-hash-part"
  "283gqy39v3g9dxjy26rynl0zls82fmcg"
  (store-path-hash-part
   (string-append (%store-prefix)
                  "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))

(test-equal "store-path-hash-part #f"
  #f
  (store-path-hash-part
   (string-append (%store-prefix)
                  "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))

(test-equal "store-path-package-name"
  "guile-2.0.7"
  (store-path-package-name
   (string-append (%store-prefix)
                  "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))

(test-equal "store-path-package-name #f"
  #f
  (store-path-package-name
   "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))

(test-assert "direct-store-path?"
  (and (direct-store-path?
        (string-append (%store-prefix)
                       "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
       (not (direct-store-path?
             (string-append
              (%store-prefix)
              "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))
       (not (direct-store-path? (%store-prefix)))))

(test-skip (if %store 0 18))

(test-equal "substitute-urls, default"
  (list (getenv "GUIX_BINARY_SUBSTITUTE_URL"))
  (with-store store
    (set-build-options store #:use-substitutes? #t)
    (substitute-urls store)))

(test-equal "substitute-urls, client-specified URLs"
  '("http://substitutes.example.org"
    "http://other.example.org")
  (with-store store
    (set-build-options store #:use-substitutes? #t
                       #:substitute-urls '("http://substitutes.example.org"
                                           "http://other.example.org"))
    (substitute-urls store)))

(test-equal "substitute-urls, disabled"
  '()
  (with-store store
    (set-build-options store #:use-substitutes? #f)
    (substitute-urls store)))

(test-equal "profiles/per-user exists and is not writable"
  #o755
  (stat:perms (stat (string-append %state-directory "/profiles/per-user"))))

(test-equal "profiles/per-user/$USER exists"
  (list (getuid) #o755)
  (let ((s (stat (string-append %state-directory "/profiles/per-user/"
                                (passwd:name (getpwuid (getuid)))))))
    (list (stat:uid s) (stat:perms s))))

(test-equal "add-to-store"
  '("sha1" "sha256" "sha512" "sha3-256" "sha3-512" "blake2s-256")
  (let* ((file    (search-path %load-path "guix.scm"))
         (content (call-with-input-file file get-bytevector-all)))
    (map (lambda (hash-algo)
           (let ((file (add-to-store %store "guix.scm" #f hash-algo file)))
             (and (direct-store-path? file)
                  (bytevector=? (call-with-input-file file get-bytevector-all)
                                content)
                  hash-algo)))
         '("sha1" "sha256" "sha512" "sha3-256" "sha3-512" "blake2s-256"))))

(test-equal "add-data-to-store"
  #vu8(1 2 3 4 5)
  (call-with-input-file (add-data-to-store %store "data" #vu8(1 2 3 4 5))
    get-bytevector-all))

(test-assert "valid-path? live"
  (let ((p (add-text-to-store %store "hello" "hello, world")))
    (valid-path? %store p)))

(test-assert "valid-path? false"
  (not (valid-path? %store
                    (string-append (%store-prefix) "/"
                                   (make-string 32 #\e) "-foobar"))))

(test-equal "with-store, multiple values"        ;<https://bugs.gnu.org/42912>
  '(1 2 3)
  (call-with-values
      (lambda ()
        (with-store s
          (add-text-to-store s "foo" "bar")
          (values 1 2 3)))
    list))

(test-assert "valid-path? error"
  (with-store s
    (guard (c ((store-protocol-error? c) #t))
      (valid-path? s "foo")
      #f)))

(test-assert "valid-path? recovery"
  ;; Prior to Nix commit 51800e0 (18 Mar. 2014), the daemon would immediately
  ;; close the connection after receiving a 'valid-path?' RPC with a non-store
  ;; file name.  See
  ;; <http://article.gmane.org/gmane.linux.distributions.nixos/12411> for
  ;; details.
  (with-store s
    (let-syntax ((true-if-error (syntax-rules ()
                                  ((_ exp)
                                   (guard (c ((store-protocol-error? c) #t))
                                     exp #f)))))
      (and (true-if-error (valid-path? s "foo"))
           (true-if-error (valid-path? s "bar"))
           (true-if-error (valid-path? s "baz"))
           (true-if-error (valid-path? s "chbouib"))
           (valid-path? s (add-text-to-store s "valid" "yeah"))))))

(test-assert "hash-part->path"
  (let ((p (add-text-to-store %store "hello" "hello, world")))
    (equal? (hash-part->path %store (store-path-hash-part p))
            p)))

(test-assert "dead-paths"
  (let ((p (add-text-to-store %store "random-text" (random-text))))
    (->bool (member p (dead-paths %store)))))

;; FIXME: Find a test for `live-paths'.
;;
;; (test-assert "temporary root is in live-paths"
;;   (let* ((p1 (add-text-to-store %store "random-text"
;;                                 (random-text) '()))
;;          (b  (add-text-to-store %store "link-builde