;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2016, 2017 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 grafts)
  #: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 guile)
  #:use-module (gnu packages libunistring)
  #:use-module (gnu packages bootstrap)
  #:use-module (ice-9 match)
  #: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 "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))
                          (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.
      (let-values (((nodes edges) (nodes+edges)))
        (and (equal? (match nodes
                       (((labels names) ...)
                        names))
                     (map package-full-name (cons p 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 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 #vu8(0 1 2))))
           (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 s<tr><td class='mode'>-rw-r--r--</td><td class='upd'><a href='/guix/diff/gnu/packages/web.scm?id=4b0e63670119971864289d67fc1e11a438f58ea6'>gnu/packages/web.scm</a></td><td class='right'>12</td><td class='graph'><table summary='file diffstat' width='12%'><tr><td class='add' style='width: 16.7%;'/><td class='rem' style='width: 83.3%;'/><td class='none' style='width: 0.0%;'/></tr></table></td></tr>
</table><div class='diffstat-summary'>1 files changed, 2 insertions, 10 deletions</div><table summary='diff' class='diff'><tr><td><div class='head'>diff --git a/gnu/packages/web.scm b/gnu/packages/web.scm<br/>index a0e76d52c4..7fb94005e8 100644<br/>--- a/<a href='/guix/tree/gnu/packages/web.scm?id=ed428a58ec347a9fb48aa75d805fab665f0eb6f4'>gnu/packages/web.scm</a><br/>+++ b/<a href='/guix/tree/gnu/packages/web.scm?id=4b0e63670119971864289d67fc1e11a438f58ea6'>gnu/packages/web.scm</a></div><div class='hunk'>@@ -626,11 +626,7 @@ used to validate and fix HTML data.")</div><div class='ctx'>         %standard-phases)))</div><div class='ctx'>     ;; All of the below are used to generate the documentation</div><div class='ctx'>     ;; (Should they be propagated inputs of asciidoc ??)</div><div class='del'>-    (native-inputs `(("asciidoc" ,asciidoc)</div><div class='del'>-                     ("libxml2" ,libxml2)</div><div class='del'>-                     ("docbook-xml" ,docbook-xml)</div><div class='del'>-                     ("docbook-xsl" ,docbook-xsl)</div><div class='del'>-                     ("libxslt" ,libxslt)))</div><div class='add'>+    (native-inputs `(("asciidoc" ,asciidoc)))</div><div class='ctx'>     (home-page "https://tinyproxy.github.io/")</div><div class='ctx'>     (synopsis "Light-weight HTTP/HTTPS proxy daemon")</div><div class='ctx'>     (description "Tinyproxy is a light-weight HTTP/HTTPS proxy</div><div class='hunk'>@@ -4479,11 +4475,7 @@ exploit attempts.")</div><div class='ctx'>          "0pf91nc0xcykahc3x7ww525c9czm8zpg80nxl8n2mrzc4ilgvass"))))</div><div class='ctx'>     (build-system python-build-system)</div><div class='ctx'>     (native-inputs</div><div class='del'>-     `(("asciidoc" ,asciidoc)</div><div class='del'>-       ("docbook-xsl" ,docbook-xsl)</div><div class='del'>-       ("docbook-xml" ,docbook-xml)</div><div class='del'>-       ("libxml2" ,libxml2)             ;for xmllint</div><div class='del'>-       ("libxslt" ,libxslt)))           ;for xsltproc</div><div class='add'>+     `(("asciidoc" ,asciidoc)))</div><div class='ctx'>     (inputs</div><div class='ctx'>      `(("python-colorama" ,python-colorama)</div><div class='ctx'>        ("python-cssutils" ,python-cssutils)</div></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
des+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 "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 sed))
                     (lset= eq?
                            (edges guile-2.0)
                            (match (package-direct-inputs guile-2.0)
                              (((labels packages _ ...) ...)
                               packages)))))))))

(test-assert "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))))
      (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 and
          ;; some that use TRIVIAL-BUILD-SYSTEM.
          (return (null? (remove (lambda (package)
                                   (or (trivial? package)
                                       (bootstrap? 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-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-end "graph")