;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 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 (guix extensions index)
  #:use-module ((guix i18n) #:select (G_))
  #:use-module ((guix ui) #:select (show-version-and-exit
                                    show-bug-report-information))
  #:use-module (guix scripts)
  #:use-module (sqlite3)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (guix describe)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:autoload   (guix combinators) (fold2)
  #:autoload   (guix grafts) (%graft?)
  #:autoload   (guix store roots) (gc-roots)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix sets)
  #:use-module ((guix utils) #:select (cache-directory))
  #:autoload   (guix build utils) (find-files)
  #:autoload   (gnu packages) (fold-packages)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-71)
  #:export     (guix-index))

(define debug #f)

(define application-version 1)

(define schema
  "
create table if not exists SchemaVersion (
  version integer primary key not null,
  unique (version)
);

create table if not exists Packages (
  id        integer primary key autoincrement not null,
  name      text not null,
  version   text not null,
  unique    (name, version) -- add uniqueness constraint
);

create table if not exists Directories (
  id        integer primary key autoincrement not null,
  name      text not null,
  package   integer not null,
  foreign key (package) references Packages(id) on delete cascade,
  unique (name, package) -- add uniqueness constraint
);

create table if not exists Files (
  name      text not null,
  basename  text not null,
  directory integer not null,
  foreign key (directory) references Directories(id) on delete cascade
  unique (name, basename, directory) -- add uniqueness constraint
);

create index if not exists IndexFiles on Files(basename);")

(define (call-with-database file proc)
  (let ((db (sqlite-open file)))
    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (sqlite-exec db schema)
        (proc db))
      (lambda ()
        (sqlite-close db)))))

(define (insert-version db version)
  "Insert application VERSION into the DB."
  (define stmt-insert-version
    (sqlite-prepare db "\
INSERT OR IGNORE INTO SchemaVersion(version)
VALUES (:version);"
                    #:cache? #t))
  (sqlite-exec db "begin immediate;")
  (sqlite-bind-arguments stmt-insert-version #:version version)
  (sqlite-fold (const #t) #t stmt-insert-version)
  (sqlite-exec db "commit;"))

(define (read-version db)
  "Read the current application version from the DB."

  (define stmt-select-version (sqlite-prepare db "\
SELECT version FROM SchemaVersion;"
                                              #:cache? #t))
  (match (sqlite-fold cons '() stmt-select-version)
    ((#(version))
     version)))

(define (insert-files db package version directories)
    "Insert files from DIRECTORIES as belonging to PACKAGE at VERSION."
    (define stmt-select-package
      (sqlite-prepare db "\
SELECT id FROM Packages WHERE name = :name AND version = :version;"
                      #:cache? #t))

    (define stmt-insert-package
      (sqlite-prepare db "\
INSERT OR IGNORE INTO Packages(name, version) -- to avoid spurious writes
VALUES (:name, :version);"
                      #:cache? #t))

    (define stmt-select-directory
      (sqlite-prepare db "\
SELECT id FROM Directories WHERE name = :name AND package = :package;"
                      #:cache? #t))

    (define stmt-insert-directory
      (sqlite-prepare db "\
INSERT OR IGNORE INTO Directories(name, package) -- to avoid spurious writes
VALUES (:name, :package);"
                      #:cache? #t))

    (define stmt-insert-file
      (sqlite-prepare db "\
INSERT OR IGNORE INTO Files(name, basename, directory)
VALUES (:name, :basename, :directory);"
                      #:cache? #t))

    (sqlite-exec db "begin immediate;")
    (sqlite-bind-arguments stmt-insert-package
                           #:name package
                           #:version version)
    (sqlite-fold (const #t) #t stmt-insert-package)

    (sqlite-bind-arguments stmt-select-package
                           #:name package
                           #:version version)
    (match (sqlite-fold cons '() stmt-select-package)
      ((#(package-id))
       (when debug
         (format #t "(pkg, version, pkg-id): (~a, ~a, ~a)"
                 package version package-id))
       (pk 'package package-id package)
       (for-each (lambda (directory)
                   (define (strip file)
                     (string-drop file (+ (string-length directory) 1)))

                   (sqlite-reset stmt-insert-directory)
                   (sqlite-bind-arguments stmt-insert-directory
                                          #:name directory
                                          #:package package-id)
                   (sqlite-fold (const #t) #t stmt-insert-directory)

                   (sqlite-reset stmt-select-directory)
                   (sqlite-bind-arguments stmt-select-directory
                                          #:name directory
                                          #:package package-id)
                   (match (sqlite-fold cons '() stmt-select-directory)
                     ((#(directory-id))
                      (when debug
                        (format #t "(name, package, dir-id): (~a, ~a, ~a)\n"
                                directory package-id directory-id))
                      (for-each (lambda (file)
                                  ;; If DIRECTORY is a symlink, (find-files
                                  ;; DIRECTORY) returns the DIRECTORY singleton.
                                  (unless (string=? file directory)
                                    (sqlite-reset stmt-insert-file)
                                    (sqlite-bind-arguments stmt-insert-file
                                                           #:name (strip file)
                                                           #:basename
                                                           (basename file)
                                                           #:directory
                                                           directory-id)
                                    (sqlite-fold (const #t) #t stmt-insert-file)))
                                (find-files directory)))))
                 directories)))
    (sqlite-exec db "commit;"))

\f
;;;
;;; Indexing from local profiles.
;;;

(define (all-profiles)
  "Return the list of system profiles."
  (delete-duplicates
   (filter-map (lambda (root)
                 (if (file-exists? (string-append root "/manifest"))
                     root
                     (let ((root (string-append root "/profile")))
                       (and (file-exists? (string-append root "/manifest"))
                            root))))
               (gc-roots))))

(define (profiles->manifest-entries profiles)
  "Return deduplicated manifest entries across all PROFILES."
  (let loop ((visited (set))
             (profiles profiles)
             (entries '()))
    (match profiles
      (()
       entries)
      ((profile . rest)
       (let* ((manifest (profile-manifest profile))
              (entries visited
                       (fold2 (lambda (entry lst visited)
                                (let ((item (manifest-entry-item entry)))
                                  (if (set-contains? visited item)
                                      (values lst visited)
                                      (values (cons entry lst)
                                              (set-insert item
                                                          visited)))))
                              entries
                              visited
                              (manifest-transitive-entries manifest))))
         (loop visited rest entries))))))

(define (insert-manifest-entry db entry)
  "Insert a manifest ENTRY into DB."
  (insert-files db (manifest-entry-name entry)
                (manifest-entry-version entry)
                (list (manifest-entry-item entry)))) ;FIXME: outputs?

(define (index-manifests db-file)
  "Insert packages entries into DB-FILE from the system manifests."
  (let ((db-dirpath (dirname db-file)))
    (unless (file-exists? db-dirpath)
      (mkdir db-dirpath)))

  (insert-version-with-db db-file)

  (call-with-database db-file
    (lambda (db)
      (for-each (lambda (entry)
                  (insert-manifest-entry db entry))
                (let ((lst (profiles->manifest-entries (all-profiles))))
                  (pk 'entries (length lst))
                  lst)))))

\f
;;;
;;; Search.
;;;

(define-record-type <package-match>
  (package-match name version file)
  package-match?
  (name      package-match-name)
  (version   package-match-version)
  (file      package-match-file))

(define (matching-packages db file)
  "Return unique <package-match> corresponding to packages containing FILE."
  (define lookup-stmt
    (sqlite-prepare db "\
SELECT Packages.name, Packages.version, Directories.name, Files.name
FROM Packages
INNER JOIN Files, Directories
ON files.basename = :file
  AND directories.id = files.directory
  AND packages.id = directories.package;"))

  (sqlite-bind-arguments lookup-stmt #:file file)
  (sqlite-fold (lambda (result lst)
                 (match result
                   (#(package version directory file)
                    (cons (package-match package version
                                         (string-append directory "/" file))
                          lst))))
               '() lookup-stmt))

\f

;;;
;;; CLI
;;;

(define (insert-version-with-db db-pathname)
  "Insert application version into the database."
  (call-with-database db-pathname
    (lambda (db)
      (insert-version db application-version))))

(define (read-db-version-with-db db-pathname)
  "Insert version into the database."
  (call-with-database db-pathname read-version))

(define (matching-packages-with-db db-pathname file)
  "Compute list of packages referencing FILE using db at DB-PATHNAME."
  (call-with-database db-pathname
    (lambda (db)
      (matching-packages db file))))

(define (print-matching-results matches)
  "Print the MATCHES matching results."
  (for-each (lambda (result)
              (format #t "~20a ~a~%"
                      (string-append (package-match-name result)
                                     "@" (package-match-version result))
                      (package-match-file result)))
            matches))

(define default-db-path
  (string-append (cache-directory #:ensure? #f)
                 "/index/db.sqlite"))

(define (show-help)
  (display (G_ "Usage: guix index [OPTIONS...] [search FILE...]
Without argument, indexes (package, file) relationships in the local store.
With 'search FILE', search for packages installing FILE.\n
Note: The internal cache is located at ~/.cache/guix/index/db.sqlite.
See --db-path for customization.\n"))
  (newline)
  (display (G_ "The valid values for OPTIONS are:"))
  (newline)
  (display (G_ "
  -h, --help      Display this help and exit"))
  (display (G_ "
  -V, --version   Display version information and exit"))
  (display (G_ "
  --db-path=DIR   Change default location of the cache db"))
  (newline)
  (newline)
  (display (G_ "The valid values for ARGS are:"))
  (newline)
  (display (G_ "
  search FILE     Search for packages installing the FILE (from cache db)"))
  (newline)
  (show-bug-report-information))

(define-command (guix-index . args)
  (category extension)
  (synopsis "Index packages to allow searching package for a given filename")

  (define (parse-db-args args)
    "Parsing of string key=value where we are only interested in 'value'"
    (match (string-split args #\=)
      ((unused db-path)
       db-path)
      (_ #f)))

  (define (display-help-and-exit)
    (show-help)
    (exit 0))

  (match args
    ((or ("-h") ("--help"))
     (display-help-and-exit))
    ((or ("-V") ("--version"))
     (with-exception-handler
         (lambda (exn) 'meh)  ;; noop exception
       (simple-format #t "Extension db version: ~a\n" (read-db-version-with-db default-db-path))
       #:unwind? #t)
     (show-version-and-exit "guix index"))
    ((db-path-args)
     (let ((db-path (parse-db-args db-path-args)))
       (if db-path
           (index-manifests db-path)
           (display-help-and-exit))))
    (("search" file)
     (let ((matches (matching-packages-with-db default-db-path file)))
       (print-matching-results matches)
       (exit (pair? matches))))
    ((db-path-args "search" file)
     (let ((db-path (parse-db-args db-path-args)))
       (if db-path
           (let ((matches (matching-packages-with-db db-path file)))
             (print-matching-results matches)
             (exit (pair? matches)))
           (display-help-and-exit))))
    (_  ;; By default, index
     (index-manifests default-db-path))))