;;; 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 locate)
  #:use-module (guix scripts)
  #:use-module (sqlite3)
  #:use-module (ice-9 match)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:autoload   (guix grafts) (%graft?)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:autoload   (guix build utils) (find-files)
  #:autoload   (gnu packages) (fold-packages)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:export     (guix-locate))

(define schema
  "
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-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))
     (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))
                    (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;"))

(define (insert-package db package)
  "Insert all the files of PACKAGE into DB."
  (mlet %store-monad ((drv (package->derivation package #:graft? #f)))
    (match (derivation->output-paths drv)
      (((labels . directories) ...)
       (when (every file-exists? directories)
         (insert-files db (package-name package) (package-version package)
                       directories))
       (return #t)))))

(define (insert-packages db)
  "Insert all the current packages into DB."
  (with-store store
    (parameterize ((%graft? #f))
      (fold-packages (lambda (package _)
                       (run-with-store store
                         (insert-package db package)))
                     #t
                     #:select? (lambda (package)
                                 (and (not (hidden-package? package))
                                      (not (package-superseded package))
                                      (supported-package? package)))))))

(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

(define (index-packages-with-db db-pathname)
  "Index packages using db at location DB-PATHNAME."
  (call-with-database db-pathname
    (lambda (db)
      (insert-packages db))))

(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))

;; TODO: Determine the current guile/guix mechanism to provide configuration
;; for this
(define default-location-db-path "/tmp/db")

(define-command (guix-locate . args)
  (category extension)
  (synopsis "Index packages then search what package declares a given file")
  (match args
    (("index")
     (index-packages-with-db default-location-db-path))
    (("search" file)
     (let ((matches (matching-packages-with-db default-location-db-path file)))
       (print-matching-results matches)
       (exit (pair? matches))))
    (_
     (format (current-error-port)
             "usage: guix locate [index|search] args ...~% ~a"
             args)
     (exit 1))))