(use-modules
 (guix ssh)
 (guix packages)
 (guix derivations)
 (guix store)
 (guix inferior)
 (srfi srfi-9)
 (srfi srfi-1)
 (ice-9 match))

;; A very janky script to compare derivation outputs on two machines.
;; The basic idea is to start from a derivation that is known to
;; produce an output that differs on two machines.  We walk the graph
;; of inputs starting from that derivation (an input here is a
;; combination of a derivation and an output, such as "out" or
;; "static").  As we go, we record the derivations that produced a
;; differing output on the two machines.  We stop once there are no
;; more such inputs to walk.
;;
;; It is expected that any derivations under examination have already
;; been built on both machines.  It's probably best to just build the
;; root derivation on both machines before running this script.  Make
;; sure you build without using substitutes, since we're trying to
;; compare reproducibility between machines when built from source.
;;
;; This script was written under the assumption that all machines
;; - the local machine, gs1, and gs2 - are using the same version of
;; Guix.  Run this script with: "guix repl the-script.scm"

(define gs1-eval
  (let* ((session-gs1 (open-ssh-session "gs1"))
         (inferior-gs1 (remote-inferior session-gs1)))
    (lambda (exp)
      (inferior-eval exp inferior-gs1))))

(define gs2-eval
  (let* ((session-gs2 (open-ssh-session "gs2"))
         (inferior-gs2 (remote-inferior session-gs2)))
    (lambda (exp)
      (inferior-eval exp inferior-gs2))))

;; Represent edges in a graph as pairs.

(define (make-edge from to)
  (cons from to))

(define (edge-from edge)
  (car edge))

(define (edge-to edge)
  (cdr edge))

(define (get-inputs drv)
  (pk 'get-inputs drv)
  ;; return the inputs of drv (according to gs1, or gs2, or locally)
  ;; one input is e.g. ("/gnu/store/...foo.drv" ("out")) - a
  ;; two-element list.
  (gs1-eval
   `(map (lambda (input)
           (list (derivation-input-path input)
                 (derivation-input-sub-derivations input)))
         (derivation-inputs (read-derivation-from-file ,drv)))))

;; Evaluate to the recursive SHA-256 hash, as a string, of the output
;; path.
(define (compute-hash-exp file)
  (pk 'compute-hash-exp file)
  `(let-values (((port get-hash)
                 (open-hash-port (lookup-hash-algorithm 'sha256))))
     (write-file ,file port)
     (force-output port)
     (bytevector->nix-base32-string (get-hash))))

(define (get-drv-output-paths drv output-names)
  (pk 'get-drv-output-paths drv output-names)
  ;; from any of gs1 or gs2 or local
  (sort-list
   (gs1-eval
    `(filter-map (match-lambda
                   ((name . output)
                    (if (member name ',output-names)
                        (derivation-output-path output)
                        #f)))
                 (derivation-outputs (read-derivation-from-file ,drv))))
   string<))

(define (get-hashes-gs1 files)
  (pk 'get-hashes-gs1 files)
  (sort-list
   (map (lambda (file)
          ;; There aren't usually many outputs, so connecting once per
          ;; output isn't so bad.
          (gs1-eval (compute-hash-exp file)))
        files)
   string<))

(define (get-hashes-gs2 files)
  (pk 'get-hashes-gs2 files)
  (sort-list
   (map (lambda (file)
          ;; There aren't usually many outputs, so connecting once per
          ;; output isn't so bad.
          (gs2-eval (compute-hash-exp file)))
        files)
   string<))

;; differs for some output.
(define (any-output-differs-on-gs1-and-gs2 drv outputs)
  (pk 'any-output-differs-on-gs1-and-gs2 drv outputs)
  (let* ((drv-output-paths (get-drv-output-paths drv outputs))
         (hashes-gs1 (get-hashes-gs1 drv-output-paths))
         (hashes-gs2 (get-hashes-gs2 drv-output-paths)))
    (any (lambda (hash-gs1 hash-gs2)
           (not (string= hash-gs1 hash-gs2)))         
         hashes-gs1
         hashes-gs2)))

(define (get-bad-drvs inputs)
  (pk 'get-bad-drvs inputs)
  ;; return the drvs that are not identical on gs1 and gs2
  (filter-map (match-lambda
                ((drv outputs)
                 (if (any-output-differs-on-gs1-and-gs2 drv outputs)
                     (begin
                       (display "Differs: ")
                       (display drv)
                       (newline)
                       ;; Without the outputs because the entire drv
                       ;; must be run in order to build any outputs.
                       drv)
                     #f)))
              inputs))

(define visited
  (make-hash-table))

;; from-drv is assumed to be bad.
;; The bad-drvs returned are a list of edges describing the graph of bad derivations.
(define (get-bad-drv-edges from-drv)
  (pk 'get-bad-drv-edges from-drv)
  ;; Don't visit the same node twice, to avoid loops.
  (if (hash-ref visited from-drv)
      '()
      (begin
        (hash-set! visited from-drv #t)
        (let* ((inputs (get-inputs from-drv))
               (bad-drvs (get-bad-drvs inputs))
               (bad-drv-edges (map (lambda (bad-drv)
                                     (make-edge from-drv bad-drv))
                                   bad-drvs)))
          (append bad-drv-edges
                  (append-map (lambda (bad-drv)
                                (get-bad-drv-edges bad-drv))
                              bad-drvs))))))


(pk 'gs1-use-modules
    (gs1-eval
     '(use-modules (guix)
                   (ice-9 match)
                   (srfi srfi-1)
                   (srfi srfi-11)
                   (gcrypt hash)
                   (guix serialization))))

(pk 'gs2-use-modules
    (gs2-eval
     '(use-modules (guix)
                   (ice-9 match)
                   (srfi srfi-1)
                   (srfi srfi-11)
                   (gcrypt hash)
                   (guix serialization))))

;; guix build -d --target=powerpc64-linux-gnu --no-grafts -e '(@@ (gnu packages make-bootstrap) %gcc-static)'
(define root-drv
  "/gnu/store/i5wn3xl6p0zw1vglscgk0bs9dwc6hdh6-gcc-static-5.5.0.drv")

(call-with-output-file "/tmp/myedges"
  (lambda (port)
    (write (get-bad-drv-edges root-drv) port)))

(display "done")
(newline)