;;; specification-to-swhids.scm
;;; Copyright © 2023 Timothy Sample <samplet@ngyro.com>
;;;
;;; This program 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.
;;;
;;; This program 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 this program. If not, see <https://www.gnu.org/licenses/>.

(use-modules (gnu packages)
             (guix base32)
             (guix derivations)
             (guix gexp)
             (guix monads)
             (guix store)
             (ice-9 format)
             (ice-9 getopt-long)
             (ice-9 match)
             (sqlite3)
             (srfi srfi-9 gnu))


;;; Database stuff

(define (call-with-sqlite-db filename proc)
  "Open the SQLite database at FILENAME and pass the resulting
connection to PROC.  The connection will only be open during the dynamic
extent of PROC.  If that dynamic extent is re-entered (using a
continuation, say), the database connection will be re-established."
  (let ((db #f))
    (dynamic-wind
      (lambda ()
        (set! db (sqlite-open filename)))
      (lambda ()
        (proc db))
      (lambda ()
        (sqlite-close db)
        (set! db #f)))))

(define (database-lookup db query params converter)
  "Using the SQLite database connection DB, run QUERY with PARAMS, and
map CONVERTER over the resulting rows."
  (let* ((stmt (sqlite-prepare db query))
         (_ (unless (null? params)
              (apply sqlite-bind-arguments stmt params)))
         (result (sqlite-fold (lambda (x acc)
                                (cons (converter x) acc))
                              '()
                              stmt)))
    (sqlite-finalize stmt)
    result))

(define (lookup-swh-status db algorithm hash)
  "Using the SQLite database connection DB, lookup the SWHID of the
fixed-output derivation with the ALGORITHM-computed checksum HASH.
Here, both ALGORITHM and HASH are strings, the latter being the Nix
base-32 representation of the hash value."
  (define query "\
SELECT swhid, is_in_swh
FROM fods
WHERE algorithm = ?
    AND hash = ?")
  (define (converter row) row)
  (and=> (database-lookup db query (list algorithm hash) converter) car))


;;; Guix stuff

(define (derivation-transitive-fixed-output-inputs drv)
  "Compute the list of all fixed-output derivations in the transitive
inputs of the derivation DRV."
  (define seen (make-hash-table))
  (define fod-hashes (make-hash-table))

  (define (seen? drv)
    (hashq-ref seen drv))

  (let loop ((queue (list drv)))
    (match queue
      (() (hash-map->list cons fod-hashes))
      ((drv . rest)
       (hashq-set! seen drv #t)
       (when (fixed-output-derivation? drv)
         (let* ((out (assoc-ref (derivation-outputs drv) "out"))
                (algo (derivation-output-hash-algo out))
                (hash (derivation-output-hash out))
                (filename (derivation-output-path out)))
           (hash-set! fod-hashes (cons algo hash) filename)))
       (loop (append (filter (negate seen?)
                             (map derivation-input-derivation
                                  (derivation-inputs drv)))
                     rest))))))

(define (lookup-object-hashes obj)
  "Get the list of Guix hashes needed for the lowerable object OBJ."
  (let ((drv (run-with-store (open-connection)
               (lower-object obj))))
    (derivation-transitive-fixed-output-inputs drv)))


;;; Glue

(define-immutable-record-type <source>
  (make-source algorithm hash filename swhid in-swh?)
  source?
  (algorithm source-algorithm)
  (hash source-hash)
  (filename source-filename)
  (swhid source-swhid)
  (in-swh? source-in-swh?))

(define (guix-hash->source db hash-obj)
  "Using the SQLite database connection DB, convert HASH-OBJ to a source
record.  HASH-OBJ should be a result from 'lookup-object-hashes'."
  (match-let* ((((algorithm . hash) . filename) hash-obj)
               (algorithm (symbol->string algorithm))
               (hash (bytevector->nix-base32-string hash))
               (#(swhid in-swh?) (lookup-swh-status db algorithm hash)))
    (make-source algorithm hash filename swhid in-swh?)))

(define (object-sources db obj)
  "Using the SQLite database connection DB, get the list of source
records for the lowerable object OBJ."
  (let ((hashes (lookup-object-hashes obj)))
    (map (lambda (hash) (guix-hash->source db hash)) hashes)))


;; Shell interface

(define (print-source src)
  (format #t "~a\t~a\t~50a\t~a\t~a~%"
          (source-algorithm src)
          (source-hash src)
          (or (source-swhid src) "unknown")
          (cond
           ((source-in-swh? src) "stored")
           ((source-swhid src) "missing")
           (else "unknown"))
          (source-filename src)))

(define version "2023-03-13-0")

(define version-message (string-append "\
specification-to-swhids.scm " version "
"))

(define help-message "\
Usage: guix repl specification-to-swhids.scm DB-FILENAME SPECIFICATION

Print a table of Guix hashes, SWHIDs, and store filenames for the Guix
package SPECIFICATION using the Preservation of Guix database at
DB-FILENAME.  See <https://ngyro.com/pog-reports/latest>.
")

(define options-grammar
  `((help (single-char #\h))
    (version (single-char #\V))))

(define (main args)
  (let ((options (getopt-long args options-grammar)))
    (when (option-ref options 'help #f)
      (display help-message)
      (exit EXIT_SUCCESS))
    (when (option-ref options 'version #f)
      (display version-message)
      (exit EXIT_SUCCESS))
    (match (option-ref options '() #f)
      ((db-filename specification)
       (for-each print-source
                 (let ((obj (specification->package specification)))
                   (call-with-sqlite-db db-filename
                     (lambda (db)
                       (object-sources db obj)))))
       (exit EXIT_SUCCESS))
      (_
       (display help-message)
       (exit EXIT_FAILURE)))))

(main (command-line))