;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015-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-graph)
  #:use-module (guix tests)
  #:use-module (guix graph)
  #:use-module (guix scripts graph)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system trivial)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bootstrap)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages libunistring)
  #:use-module (gnu packages bootstrap)
  #:use-module (ice-9 match)
  #:use-module (ice-9 sandbox)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-64))

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

;; Globally disable grafts because they can trigger early builds.
(%graft? #f)

(define (make-recording-backend)
  "Return a <graph-backend> and a thunk that returns the recorded nodes and
edges."
  (let ((nodes '())
        (edges '()))
    (define (record-node id label port)
      (set! nodes (cons (list id label) nodes)))
    (define (record-edge source target port)
      (set! edges (cons (list source target) edges)))
    (define (return)
      (values (reverse nodes) (reverse edges)))

    (values (graph-backend "test" "This is the test backend."
                           (const #t) (const #t)
                           record-node record-edge)
            return)))

(define (package->tuple package)
  "Return a tuple representing PACKAGE as produced by %PACKAGE-NODE-TYPE."
  (list (object-address package)
        (package-full-name package)))

(define (edge->tuple source target)
  "Likewise for an edge from SOURCE to TARGET."
  (list (object-address source)
        (object-address target)))


(test-begin "graph")

(test-assert "package DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let* ((p1 (dummy-package "p1"))
           (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
           (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
      (run-with-store %store
        (export-graph (list p3) 'port
                      #:node-type %package-node-type
                      #:backend backend))
      ;; We should see nothing more than these 3 packages.
      (let-values (((nodes edges) (nodes+edges)))
        (and (equal? nodes (map package->tuple (list p3 p2 p1)))
             (equal? edges
                     (map edge->tuple
                          (list p3 p3 p2)
                          (list p2 p1 p1))))))))

(test-assert "package DAG, limited depth"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let* ((p1 (dummy-package "p1"))
           (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
           (p3 (dummy-package "p3" (inputs `(("p1" ,p1)))))
           (p4 (dummy-package "p4" (inputs `(("p2" ,p2) ("p3" ,p3))))))
      (run-with-store %store
        (export-graph (list p4) 'port
                      #:max-depth 1
                      #:node-type %package-node-type
                      #:backend backend))
      ;; We should see nothing more than these 3 packages.
      (let-values (((nodes edges) (nodes+edges)))
        (and (equal? nodes (map package->tuple (list p4 p2 p3)))
             (equal? edges
                     (map edge->tuple
                          (list p4 p4)
                          (list p2 p3))))))))

(test-assert "package DAG, oops it was a cycle"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (letrec ((p1 (dummy-package "p1" (inputs `(("p3" ,p3)))))
             (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
             (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
      (call-with-time-limit
       600 ;; If ever this test should fail, we still want it to terminate
       (lambda ()
         (run-with-store %store
           (export-graph (list p3) 'port
                         #:node-type %package-node-type
                         #:backend backend)))
       (lambda ()
         (run-with-store %store
           (export-graph
            (list (dummy-package "timeout-reached"))
            'port
            #:node-type %package-node-type
            #:backend backend))))
      ;; We should see nothing more than these 3 packages.
      (let-values (((nodes edges) (nodes+edges)))
        (and (equal? nodes (map package->tuple (list p3 p2 p1)))
             (equal? edges
                     (map edge->tuple
                          (list p3 p3 p2 p1)
                          (list p2 p1 p1 p3))))))))

(test-assert "reverse package DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (export-graph (list libunistring) 'port
                    #:node-type %reverse-package-node-type
                    #:backend backend))
    ;; We should see nothing more than these 3 packages.
    (let-values (((nodes edges) (nodes+edges)))
      (and (member (package->tuple guile-2.0) nodes)
           (->bool (member (edge->tuple libunistring guile-2.0) edges))))))

(test-assert "bag-emerged DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let* ((o        (dummy-origin (method (lambda _
                                             (text-file "foo" "bar")))))
           (p        (dummy-package "p" (source o)))
           (implicit (map (match-lambda
                            ((label package) package)
                            ((label package output) package))
                          (standard-packages))))
      (run-with-store %store
        (export-graph (list p) 'port
                      #:node-type %bag-emerged-node-type
                      #:backend backend))
      ;; We should see exactly P and IMPLICIT, with one edge from P to each
      ;; element of IMPLICIT.  O must not appear among NODES.  Note: IMPLICIT
      ;; contains "glibc" twice, once for "out" and a second time for
      ;; "static", hence the 'delete-duplicates' call below.
      (let-values (((nodes edges) (nodes+edges)))
        (and (equal? (match nodes
                       (((labels names) ...)
                        names))
                     (map package-full-name
                          (cons p (delete-duplicates implicit))))
             (equal? (match edges
                       (((sources destinations) ...)
                        (zip (map store-path-package-name sources)
                             (map store-path-package-name destinations))))
                     (map (lambda (destination)
                            (list "p-0.drv"
                                  (string-append
                                   (package-full-name destination "-")
                                   ".drv")))
                          implicit)))))))

(test-assert "bag DAG"                            ;a big town in Iraq
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let ((p (dummy-package "p")))
      (run-with-store %store
        (export-graph (list p) 'port
                      #:node-type %bag-node-type
                      #:backend backend))
      ;; We should see P, its implicit inputs as well as the whole DAG, which
      ;; should include bootstrap binaries.
      (let-values (((nodes edges) (nodes+edges)))
        (every (lambda (name)
                 (find (cut string=? name <>)
                       (match nodes
                         (((labels names) ...)
                          names))))
               (match (%bootstrap-inputs)
                 (((labels packages) ...)
                  (map package-full-name (filter package? packages)))))))))

(test-assert "bag DAG, including origins"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (let* ((m (lambda* (uri hash-type hash name #:key system)
                (text-file "foo-1.2.3.tar.gz" "This is a fake!")))
           (o (origin
                (method m) (uri "the-uri")
                (sha256
                 (base32
                  "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))))
           (p (dummy-package "p" (source o))))
      (run-with-store %store
        (export-graph (list p) 'port
                      #:node-type %bag-with-origins-node-type
                      #:backend backend))
      ;; We should see O among the nodes, with an edge coming from P.
      (let-values (((nodes edges) (nodes+edges)))
        (run-with-store %store
          (mlet %store-monad ((o* (lower-object o))
                              (p* (lower-object p))
                              (g  (lower-object (default-guile))))
            (return
             (and (find (match-lambda
                          ((file "the-uri") #t)
                          (_                #f))
                        nodes)
                  (find (match-lambda
                          ((source target)
                           (and (string=? source (derivation-file-name p*))
                                (string=? target o*))))
                        edges)

                  ;; There must also be an edge from O to G.
                  (find (match-lambda
                          ((source target)
                           (and (string=? source o*)
                                (string=? target (derivation-file-name g)))))
                        edges)))))))))

(test-assert "reverse bag DAG"
  (let-values (((dune camomile utop)
                (values (specification->package "dune")
                        (specification->package "ocaml-camomile")
                        (specification->package "ocaml-utop")))
               ((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (export-graph (list dune) 'port
                    #:node-type %reverse-bag-node-type
                    #:backend backend))

    (run-with-store %store
      (mlet %store-monad ((dune-drv       (package->derivation dune))
                          (camomile-drv   (package->derivation camomile))
                          (utop-drv       (package->derivation utop)))
        ;; CAMOMILE uses 'dune-build-system' so DUNE is a direct dependency.
        ;; UTOP is much higher in the stack but it should be there.
        (let-values (((nodes edges) (nodes+edges)))
          (return
           (and (member `(,(derivation-file-name camomile-drv)
                          ,(package-full-name camomile))
                        nodes)
                (->bool (member (map derivation-file-name
                                     (list dune-drv utop-drv))
                                edges)))))))))

(test-assert "derivation DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
                           (guile (package->derivation %bootstrap-guile))
                           (drv   (gexp->derivation "output"
                                                    #~(symlink #$txt #$output)
                                                    #:guile-for-build
                                                    guile)))
        ;; We should get at least these 3 nodes and corresponding edges.
        (mbegin %store-monad
          (export-graph (list drv) 'port
                        #:node-type %derivation-node-type
                        #:backend backend)
          (let-values (((nodes edges) (nodes+edges)))
            ;; XXX: For some reason we need to throw in so99cff4d661a979cd03a417d1df23cd77d798dc60'>gnu: rust-native-tls: Move to (gnu packages crates-tls).</a><span class='msg-avail'>...</span></td><td>Efraim Flashner</td></tr>
                   (every (lambda (item)
                                       (member (basename item) ids))
                                     (list txt
                                           (derivation-file-name drv)
                                           (derivation-file-name guile))))))
                         (every (cut member <>
                                     (map (lambda (edge)
                                            (map basename edge))
                                          edges))
                                (list (map (compose basename derivation-file-name)
                                           (list drv guile))
                                      (list (basename (derivation-file-name drv))
                                            (basename txt))))))))))))

(test-assert "reference DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (mlet* %store-monad ((txt   (text-file "text-file" "Hello!"))
                           (guile (package->derivation %bootstrap-guile))
                           (drv   (gexp->derivation "output"
                                                    #~(symlink #$txt #$output)
                                                    #:guile-for-build
                                                    guile))
                           (out -> (derivation->output-path drv)))
        ;; We should see only OUT and TXT, with an edge from the former to the
        ;; latter.
        (mbegin %store-monad
          (built-derivations (list drv))
          (export-graph (list (derivation->output-path drv)) 'port
                        #:node-type %reference-node-type
                        #:backend backend)
          (let-values (((nodes edges) (nodes+edges)))
            (return
             (and (equal? (match nodes
                            (((ids labels) ...)
                             ids))
                          (list out txt))
                  (equal? edges `((,out ,txt)))))))))))

(test-assert "referrer DAG"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (mlet* %store-monad ((txt   (text-file "referrer-node" (random-text)))
                           (drv   (gexp->derivation "referrer"
                                                    #~(symlink #$txt #$output)))
                           (out -> (derivation->output-path drv)))
        ;; We should see only TXT and OUT, with an edge from the former to the
        ;; latter.
        (mbegin %store-monad
          (built-derivations (list drv))
          (export-graph (list txt) 'port
                        #:node-type %referrer-node-type
                        #:backend backend)
          (let-values (((nodes edges) (nodes+edges)))
            (return
             (and (equal? (match nodes
                            (((ids labels) ...)
                             ids))
                          (list txt out))
                  (equal? edges `((,txt ,out)))))))))))

(test-assert "module graph"
  (let-values (((backend nodes+edges) (make-recording-backend)))
    (run-with-store %store
      (export-graph '((gnu packages guile)) 'port
                    #:node-type %module-node-type
                    #:backend backend))

    (let-values (((nodes edges) (nodes+edges)))
      (and (member '(gnu packages guile)
                   (match nodes
                     (((ids labels) ...) ids)))
           (->bool (and (member (list '(gnu packages guile)
                                      '(gnu packages libunistring))
                                edges)
                        (member (list '(gnu packages guile)
                                      '(gnu packages bdw-gc))
                                edges)))))))

(test-assert "node-edges"
  (run-with-store %store
    (let ((packages (fold-packages cons '())))
      (mlet %store-monad ((edges (node-edges %package-node-type packages)))
        (return (and (null? (edges hello))
                     (lset= eq?
                            (edges guile-2.0)
                            (match (package-direct-inputs guile-2.0)
                              (((labels packages _ ...) ...)
                               packages)))))))))

(test-equal "node-transitive-edges + node-back-edges"
  '()
  (run-with-store %store
    (let ((packages   (fold-packages cons '()))
          (bootstrap? (lambda (package)
                        (string-contains
                         (location-file (package-location package))
                         "bootstrap.scm")))
          (trivial?   (lambda (package)
                        (eq? (package-build-system package)
                             trivial-build-system)))
          (system-specific? (lambda (package)
                              (memq #:system (package-arguments package)))))
      (mlet %store-monad ((edges (node-back-edges %bag-node-type packages)))
        (let* ((glibc      (canonical-package glibc))
               (dependents (node-transitive-edges (list glibc) edges))
               (diff       (lset-difference eq? packages dependents)))
          ;; All the packages depend on libc, except bootstrap packages, some
          ;; packages that use TRIVIAL-BUILD-SYSTEM, and some that target a
          ;; specific system and thus may depend on a different libc package
          ;; object.
          (return (remove (lambda (package)
                            (or (trivial? package)
                                (bootstrap? package)
                                (system-specific? package)))
                          diff)))))))

(test-assert "node-transitive-edges, no duplicates"
  (run-with-store %store
    (let* ((p0  (dummy-package "p0"))
           (p1a (dummy-package "p1a" (inputs `(("p0" ,p0)))))
           (p1b (dummy-package "p1b" (inputs `(("p0" ,p0)))))
           (p2  (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b))))))
      (mlet %store-monad ((edges (node-edges %package-node-type
                                             (list p2 p1a p1b p0))))
        (return (lset= eq? (node-transitive-edges (list p2) edges)
                       (list p1a p1b p0)))))))

(test-assert "node-transitive-edges, references"
  (run-with-store %store
    (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile))
                         (d1 (gexp->derivation "d1"
                                               #~(begin
                                                   (mkdir #$output)
                                                   (symlink #$%bootstrap-guile
                                                            (string-append
                                                             #$output "/l")))))
                         (d2 (gexp->derivation "d2"
                                               #~(begin
                                                   (mkdir #$output)
                                                   (symlink #$d1
                                                            (string-append
                                                             #$output "/l")))))
                         (_  (built-derivations (list d2)))
                         (->node -> (node-type-convert %reference-node-type))
                         (o2      (->node (derivation->output-path d2)))
                         (o1      (->node (derivation->output-path d1)))
                         (o0      (->node (derivation->output-path d0)))
                         (edges   (node-edges %reference-node-type
                                              (append o0 o1 o2)))
                         (reqs    ((store-lift requisites) o2)))
      (return (lset= string=?
                     (append o2 (node-transitive-edges o2 edges)) reqs)))))

(test-equal "node-reachable-count"
  '(3 3)
  (run-with-store %store
    (let* ((p0  (dummy-package "p0"))
           (p1a (dummy-package "p1a" (inputs `(("p0" ,p0)))))
           (p1b (dummy-package "p1b" (inputs `(("p0" ,p0)))))
           (p2  (dummy-package "p2" (inputs `(("p1a" ,p1a) ("p1b" ,p1b))))))
      (mlet* %store-monad ((all -> (list p2 p1a p1b p0))
                           (edges  (node-edges %package-node-type all))
                           (back   (node-back-edges %package-node-type all)))
        (return (list (node-reachable-count (list p2) edges)
                      (node-reachable-count (list p0) back)))))))

(test-equal "shortest-path, packages + derivations"
  '(("p5" "p4" "p1" "p0")
    ("p3" "p2" "p1" "p0")
    #f
    ("p5-0.drv" "p4-0.drv" "p1-0.drv" "p0-0.drv"))
  (run-with-store %store
    (let* ((p0 (dummy-package "p0"))
           (p1 (dummy-package "p1" (inputs `(("p0" ,p0)))))
           (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
           (p3 (dummy-package "p3" (inputs `(("p2" ,p2)))))
           (p4 (dummy-package "p4" (inputs `(("p1" ,p1)))))
           (p5 (dummy-package "p5" (inputs `(("p4" ,p4) ("p3" ,p3))))))
      (mlet* %store-monad ((path1 (shortest-path p5 p0 %package-node-type))
                           (path2 (shortest-path p3 p0 %package-node-type))
                           (nope  (shortest-path p3 p4 %package-node-type))
                           (drv5  (package->derivation p5))
                           (drv0  (package->derivation p0))
                           (path3 (shortest-path drv5 drv0
                                                 %derivation-node-type)))
        (return (append (map (lambda (path)
                               (and path (map package-name path)))
                             (list path1 path2 nope))
                        (list (map (node-type-label %derivation-node-type)
                                   path3))))))))

(test-equal "shortest-path, reverse packages"
  '("libffi" "guile" "guile-json")
  (run-with-store %store
    (mlet %store-monad ((path (shortest-path (specification->package "libffi")
                                             guile-json-1
                                             %reverse-package-node-type)))
      (return (map package-name path)))))

(test-equal "shortest-path, references"
  `(("d2" "d1" ,(package-full-name %bootstrap-guile "-"))
    (,(package-full-name %bootstrap-guile "-") "d1" "d2"))
  (run-with-store %store
    (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile))
                         (d1 (gexp->derivation "d1"
                                               #~(begin
                                                   (mkdir #$output)
                                                   (symlink #$%bootstrap-guile
                                                            (string-append
                                                             #$output "/l")))))
                         (d2 (gexp->derivation "d2"
                                               #~(begin
                                                   (mkdir #$output)
                                                   (symlink #$d1
                                                            (string-append
                                                             #$output "/l")))))
                         (_  (built-derivations (list d2)))
                         (->node -> (node-type-convert %reference-node-type))
                         (o2   (->node (derivation->output-path d2)))
                         (o0   (->node (derivation->output-path d0)))
                         (path (shortest-path (first o2) (first o0)
                                              %reference-node-type))
                         (rpath (shortest-path (first o0) (first o2)
                                               %referrer-node-type)))
      (return (list (map (node-type-label %reference-node-type) path)
                    (map (node-type-label %referrer-node-type) rpath))))))

(test-end "graph")