;;; Guix Data Service -- Information about Guix over time
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero 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
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (guix-data-service data-deletion)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (squee)
  #:use-module (fibers)
  #:use-module (fibers channels)
  #:use-module (guix-data-service utils)
  #:use-module (guix-data-service database)
  #:use-module (guix-data-service model git-branch)
  #:use-module (guix-data-service model package-derivation-by-guix-revision-range)
  #:export (delete-guix-revisions
            delete-data-for-branch
            delete-revisions-from-branch-except-most-recent-n
            delete-revisions-for-all-branches-except-most-recent-n
            delete-data-for-all-deleted-branches
            delete-unreferenced-derivations
            delete-nars-for-unknown-store-paths))

(define (delete-guix-revisions conn git-repository-id commits)
  (define (delete-unreferenced-package-derivations)
    (exec-query
     conn
     "
DELETE FROM package_derivations
WHERE NOT EXISTS (
  SELECT 1
  FROM guix_revision_package_derivations
  WHERE guix_revision_package_derivations.package_derivation_id =
        package_derivations.id
)"))

  (define (delete-unreferenced-lint-warnings)
    (exec-query
     conn
     "
DELETE FROM lint_warnings
WHERE NOT EXISTS (
  SELECT 1
  FROM guix_revision_lint_warnings
  WHERE guix_revision_lint_warnings.lint_warning_id =
        lint_warnings.id
)"))

  (define (delete-unreferenced-lint-checkers)
    (exec-query
     conn
     "
DELETE FROM lint_checkers
WHERE NOT EXISTS (
  SELECT 1
  FROM guix_revision_lint_checkers
  WHERE guix_revision_lint_checkers.lint_checker_id =
        lint_checkers.id
)"))

  (let ((guix-revision-ids
         (map
          car
          (exec-query
           conn
           (string-append
            "
SELECT guix_revisions.id
FROM (VALUES "
            (string-join
             (map (lambda (commit)
                    (string-append "('" commit "')"))
                  commits)
             ", ")
            ") AS commits
INNER JOIN guix_revisions
  ON guix_revisions.commit = commits.column1
WHERE guix_revisions.git_repository_id = "
            (number->string git-repository-id) " AND
  commits.column1 NOT IN (
    SELECT commit
    FROM git_commits
)")))))

    (unless (null? guix-revision-ids)
      (for-each
       (lambda (table)
         (exec-query
          conn
          (simple-format
           #f
           "
DELETE FROM ~A WHERE ~A IN (VALUES ~A)"
           table
           (if (string=? table
                         "guix_revision_package_derivations")
               "revision_id"
               "guix_revision_id")
           (string-join
            (map (lambda (guix-revision-id)
                   (string-append "(" guix-revision-id ")"))
                 guix-revision-ids)
            ", "))))
       '("channel_instances"
         "guix_revision_channel_news_entries"
         "guix_revision_lint_checkers"
         "guix_revision_lint_warnings"
         "guix_revision_package_derivations"
         "guix_revision_system_test_derivations"
         "guix_revision_package_derivation_distribution_counts"))

      (exec-query
       conn
       (string-append
        "
DELETE FROM guix_revisions
WHERE id IN ("
        (string-join guix-revision-ids ", ")
        ")
AND id NOT IN (
  SELECT guix_revisions.id
  FROM guix_revisions
  INNER JOIN git_branches ON
    git_branches.git_repository_id = guix_revisions.git_repository_id
  INNER JOIN git_commits ON
    git_commits.git_branch_id = git_branches.id AND
    git_commits.commit = guix_revisions.commit
)"))

      (delete-unreferenced-package-derivations)
      (delete-unreferenced-lint-warnings)
      (delete-unreferenced-lint-checkers))))

(define (delete-revisions-from-branch conn git-repository-id branch-name commits)
  (define (delete-jobs conn commits)
    (for-each
     (lambda (table)
       (exec-query
        conn
        (string-append
         "
DELETE FROM " table "
WHERE job_id IN (
  SELECT id
  FROM load_new_guix_revision_jobs
  WHERE git_repository_id = " (number->string git-repository-id) " AND
    commit IN ("
  (string-join
   (map (lambda (commit)
          (string-append "'" commit "'"))
        commits)
   ", ")
  ")
)")))
     '("load_new_guix_revision_job_events"
       "load_new_guix_revision_job_logs"))

    (exec-query
     conn
     (string-append
      "
DELETE FROM load_new_guix_revision_jobs
WHERE git_repository_id = " (number->string git-repository-id) " AND
  commit IN ("
(string-join
 (map (lambda (commit)
        (string-append "'" commit "'"))
      commits)
 ", ")
")")))

  (define (delete-from-git-commits conn)
    (exec-query
     conn
     (simple-format
      #f
      "
DELETE FROM git_commits
WHERE id IN (
  SELECT git_commits.id
  FROM git_commits
  INNER JOIN git_branches
    ON git_branches.id = git_commits.git_branch_id
  WHERE git_branches.git_repository_id = ~A
    AND git_branches.name = '~A'
    AND git_commits.commit IN (~A)
)"
      git-repository-id
      branch-name
      (string-join
       (map (lambda (commit)
              (string-append "'" commit "'"))
            commits)
       ", "))))

  (catch 'psql-query-error
    (lambda ()
      (with-postgresql-transaction
       conn
       (lambda (conn)
         (obtain-advisory-transaction-lock
          conn
          'delete-revisions-from-branch)

         (exec-query conn "SET LOCAL lock_timeout = '5s';")
         (delete-from-git-commits conn)

         (let ((git-branch-id
                (git-branch-for-repository-and-name conn
                                                    git-repository-id
                                                    branch-name)))
           (exec-query
            conn
            (string-append
             "
DROP TABLE IF EXISTS package_derivations_by_guix_revision_range_git_branch_"
             (number->string git-branch-id) ";")))

         (let ((now-unreferenced-commits
                (filter
                 (lambda (commit)
                   (let ((result
                          (or
                           (string-null? commit)
                           (null?
                            (exec-query
                             conn
                             "SELECT 1 FROM git_commits WHERE commit = $1"
                             (list commit))))))
                     (unless result
                       (simple-format (current-error-port)
                                      "skipping ~A because it's still referenced\n"
                                      commit))
                     result))
                 commits)))
           (unless (null? now-unreferenced-commits)
             (delete-jobs conn now-unreferenced-commits)
             (delete-guix-revisions conn
                                    git-repository-id
                                    now-unreferenced-commits))))))
    (lambda (key . args)
      (simple-format
       (current-error-port)
       "error when attempting to delete revisions from branch: ~A ~A\n"
       key args)

      (apply throw key args))))

(define (delete-data-for-branch conn git-repository-id branch-name)
  (define commits
    (map car
         (exec-query conn
                     "
SELECT git_commits.commit
FROM git_branches
INNER JOIN git_commits
  ON git_branches.id = git_commits.git_branch_id
WHERE git_repository_id = $1
  AND git_branches.name = $2"
                     (list (number->string git-repository-id)
                           branch-name))))

  (unless (null? commits)
    (delete-revisions-from-branch conn
                                  git-repository-id
                                  branch-name
                                  commits))

  (exec-query
   conn
   "
DELETE FROM git_branches WHERE name = $1 AND git_repository_id = $2"
   (list branch-name
         (number->string git-repository-id))))

(define (delete-revisions-from-branch-except-most-recent-n conn
                                                           git-repository-id
                                                           branch-name
                                                           n)
  (define commits
    (map car
         (exec-query conn
                     "
SELECT commit
FROM git_commits
INNER JOIN git_branches
  ON git_branches.id = git_commits.git_branch_id
WHERE git_repository_id = $1 AND name = $2
ORDER BY datetime DESC
OFFSET $3"
                     (list (number->string git-repository-id)
                           branch-name
                           (number->string n)))))

  (unless (null? commits)
    (simple-format #t "deleting ~A commits from ~A\n" (length commits) branch-name)
    (delete-revisions-from-branch conn
                                  git-repository-id
                                  branch-name
                                  commits)

    (simple-format #t "repopulating package_derivations_by_guix_revision_range\n")
    (insert-guix-revision-package-derivation-entries conn
                                                     (number->string
                                                      git-repository-id)
                                                     branch-name)))

(define (delete-revisions-for-all-branches-except-most-recent-n n)
  (with-postgresql-connection
   "data-deletion"
   (lambda (conn)
     (for-each
      (match-lambda
        ((git-repository-id branch-name)
         (delete-revisions-from-branch-except-most-recent-n
          conn
          (string->number git-repository-id)
          branch-name
          n)))
      (exec-query
       conn
       "
SELECT DISTINCT git_repository_id, name
FROM git_branches")))))

(define (delete-data-for-all-branches-but-master)
  (with-postgresql-connection
   "data-deletion"
   (lambda (conn)
     (for-each
      (lambda (branch-name)
        (delete-data-for-branch conn 1 branch-name))
      (map
       car
       (exec-query
        conn
        "
SELECT DISTINCT name
FROM git_branches
WHERE git_repository_id = 1 AND name != 'master'"))))))

(define (delete-data-for-all-deleted-branches)
  (with-postgresql-connection
   "data-deletion"
   (lambda (conn)
     (for-each
      (match-lambda
        ((name git-repository-id)
         (simple-format #t "deleting data for ~A (~A)\n"
                        name git-repository-id)
         (delete-data-for-branch conn
                                 (string->number git-repository-id)
                                 name)))
      (exec-query
       conn
       "
SELECT name, git_repository_id
FROM (
  SELECT DISTINCT ON (name, git_repository_id)
    name, git_repository_id, commit
  FROM git_branches
  INNER JOIN git_commits
    ON git_commits.git_branch_id = git_branches.id
  ORDER BY git_repository_id, name, datetime DESC
) AS git_branches_latest_revision
WHERE commit = ''")))))

(define* (delete-unreferenced-derivations #:key
                                          (batch-size 100000))
  (define (delete-builds-for-derivation-output-details-set
           conn
           derivation-output-details-set-id)
    (let ((build-ids
           (map car
                (exec-query
                 conn
                 "
SELECT id
FROM builds
WHERE derivation_output_details_set_id = $1"
                 (list derivation-output-details-set-id)))))

      (unless (null? build-ids)
        (exec-query
         conn
         (string-append
          "
DELETE FROM build_status WHERE build_id IN ("
          (string-join build-ids ",")
          ")"))

        (exec-query
         conn
         (string-append
          "
DELETE FROM latest_build_status WHERE build_id IN ("
          (string-join build-ids ",")
          ")"))

        (exec-query
         conn
         (string-append
          "
DELETE FROM builds WHERE id IN ("
          (string-join build-ids ",")
          ")")))))

  (define (delete-blocked-builds-for-derivation-output-details-set
           conn
           derivation-output-details-set-id)
    ;; Do this for each build server individually, as that helps PostgreSQL
    ;; efficiently check the partitions
    (let ((build-server-ids
           (map
            car
            (exec-query
             conn
             "SELECT id FROM build_servers"))))
      (for-each
       (lambda (build-server-id)
         (exec-query
          conn
          "
DELETE FROM blocked_builds
WHERE build_server_id = $1
  AND (
    blocked_derivation_output_details_set_id = $2 OR blocking_derivation_output_details_set_id = $3
  )"
          (list build-server-id
                derivation-output-details-set-id
                derivation-output-details-set-id)))
       build-server-ids)))

  (define (delete-unreferenced-derivations-source-files conn)
    (define (delete-batch)
      (exec-query
       conn
       "
DELETE FROM derivation_source_files
WHERE id IN (
  SELECT id
  FROM derivation_source_files
  WHERE id NOT IN (
    SELECT derivation_source_file_id
    FROM derivation_sources
  )
  LIMIT 100
)
RETURNING id"))

    (while (not (null? (delete-batch)))
      #t))

  (define (maybe-delete-derivation conn id)
    (match (map
            car
            (exec-query
             conn
             "
DELETE FROM derivation_outputs WHERE derivation_id = $1
AND NOT EXISTS (
  SELECT 1
  FROM derivation_inputs
  WHERE derivation_output_id IN (
    SELECT derivation_outputs.id
    FROM derivation_outputs
    WHERE derivation_id = $1
  )
)
RETURNING derivation_outputs.derivation_output_details_id"
             (list id)))
      (() 0)
      ((derivation-output-details-ids ...)

       (for-each
        (lambda (derivation-output-details-id)
          (unless (string->number derivation-output-details-id)
            (error
             (simple-format #f "derivation-output-details-id: ~A is not a number"
                            derivation-output-details-id)))

          (match (exec-query
                  conn
                  "
SELECT COUNT(*) FROM derivation_outputs
WHERE derivation_output_details_id = $1"
                  (list derivation-output-details-id))
            (((count))
             (when (eq? (string->number count)
                        0)
               (exec-query
                conn
                "
DELETE FROM derivation_output_details
WHERE id = $1"
                (list derivation-output-details-id))))))
        derivation-output-details-ids)

       (exec-query
        conn
        "
DELETE FROM derivation_sources WHERE derivation_id = $1"
        (list id))

       (match (exec-query
               conn
               "
SELECT derivation_output_details_set_id
FROM derivations_by_output_details_set
WHERE derivation_id = $1"
               (list id))
         (((derivation-output-details-set-id))
          (match (exec-query
                  conn
                  "
SELECT COUNT(*) FROM derivations_by_output_details_set
WHERE derivation_output_details_set_id = $1"
                  (list derivation-output-details-set-id))
            (((count))
             (exec-query
              conn
              "
DELETE FROM derivations_by_output_details_set
WHERE derivation_id = $1"
              (list id))

             (when (<= (string->number count)
                       1)
               (delete-builds-for-derivation-output-details-set
                conn
                derivation-output-details-set-id)

               (delete-blocked-builds-for-derivation-output-details-set
                conn
                derivation-output-details-set-id)

               (exec-query
                conn
                "
DELETE FROM derivation_output_details_sets
WHERE id = $1"
                (list derivation-output-details-set-id)))))))

       (exec-query
        conn
        "
DELETE FROM derivation_inputs WHERE derivation_id = $1"
        (list id))

       (exec-query
        conn
        "
DELETE FROM derivations WHERE id = $1"
        (list id))

       1)))

  (define deleted-count 0)
  (define ignored-derivation-ids (make-hash-table))
  (define channel (make-channel))

  (define (delete-batch conn)
    (let* ((derivations
            (with-time-logging "fetching batch of derivations"
              (map car
                   (exec-query
                    conn
                    "
SELECT DISTINCT derivation_id
FROM derivation_outputs
WHERE NOT EXISTS (
  -- This isn't a perfect check, as this will select some derivations that are
  -- used, but maybe-delete-derivation includes the proper check
  SELECT 1
  FROM derivation_inputs
  WHERE derivation_output_id = derivation_outputs.id
) AND NOT EXISTS (
  SELECT 1
  FROM package_derivations
  WHERE package_derivations.derivation_id = derivation_outputs.derivation_id
) AND NOT EXISTS (
  SELECT 1 FROM channel_instances
  WHERE derivation_id = derivation_outputs.derivation_id
) AND NOT EXISTS (
  SELECT 1 FROM guix_revision_system_test_derivations
  WHERE derivation_id = derivation_outputs.derivation_id
) LIMIT $1"
                    (list (number->string batch-size))))))
           (derivations-count (length derivations)))

      (with-time-logging
          (simple-format #f "Looking at ~A derivations" derivations-count)

        (set! deleted-count 0)
        (for-each
         (lambda (derivation-id)
           (unless (hash-ref ignored-derivation-ids derivation-id)
             (put-message channel derivation-id)))
         derivations))

      (simple-format (current-error-port)
                     "Deleted ~A derivations\n"
                     deleted-count)
      deleted-count))

  (run-fibers
   (lambda ()
     ;; First spawn some fibers to delete the derivations
     (for-each
      (lambda _
        (spawn-fiber
         (lambda ()
           (with-postgresql-connection
            "data-deletion"
            (lambda (conn)
              (let loop ((derivation-id (get-message channel)))
                (unless (string->number derivation-id)
                  (error
                   (simple-format #f "derivation-id: ~A is not a number"
                                  derivation-id)))

                (let ((val
                       (catch 'psql-query-error
                         (lambda ()
                           (with-postgresql-transaction
                            conn
                            (lambda (conn)
                              (exec-query
                               conn
                               "
SET CONSTRAINTS derivations_by_output_details_set_derivation_id_fkey DEFERRED")

                              (exec-query conn "SET LOCAL lock_timeout = '5s';")

                              (maybe-delete-derivation conn
                                                       derivation-id))))
                         (lambda (key . args)
                           (simple-format
                            (current-error-port)
                            "error when attempting to delete derivation: ~A ~A\n"
                            key args)

                           0))))

                  (when (= 0 val)
                    (hash-set! ignored-derivation-ids
                               derivation-id
                               #t))

                  ;; This is safe as all fibers are in the same
                  ;; thread and cooperative.
                  (set! deleted-count
                        (+ val deleted-count)))
                (loop (get-message channel))))))))
      (iota 12))

     (with-postgresql-connection
      "data-deletion"
      (lambda (conn)
        (obtain-advisory-transaction-lock
         conn
         'delete-unreferenced-derivations)

        (let loop ((total-deleted 0))
          (let ((batch-deleted-count (delete-batch conn)))
            (if (eq? 0 batch-deleted-count)
                (begin
                  (hash-clear! ignored-derivation-ids)
                  (let ((batch-deleted-count (delete-batch conn)))
                    (if (= 0 batch-deleted-count)
                        (begin
                          (with-time-logging
                              "Deleting unused derivation_source_files entries"
                            (delete-unreferenced-derivations-source-files conn))
                          (simple-format
                           (current-output-port)
                           "Finished deleting derivations, deleted ~A in total\n"
                           total-deleted))
                        (loop (+ total-deleted batch-deleted-count)))))
                (loop (+ total-deleted batch-deleted-count))))))))
   #:hz 0
   #:parallelism 1))

(define (delete-nars-for-unknown-store-paths)
  (define (get-nar-ids-batch conn)
    (map
     car
     (exec-query
      conn
      "
SELECT id
FROM nars
WHERE NOT EXISTS
  (
    SELECT 1 FROM derivation_output_details
    WHERE derivation_output_details.path = nars.store_path
  )
LIMIT 50")))

  (define (delete-narinfo-signature-data conn nar-ids)
    (exec-query
     conn
     (string-append
      "
DELETE FROM narinfo_signature_data
  WHERE id IN (
    SELECT narinfo_signature_data_id
    FROM narinfo_signatures
    WHERE nar_id IN ("
      (string-join nar-ids ",")
      ")
)")))

  (define (delete-nars conn nar-ids)
    (exec-query
     conn
     (string-append
      "
DELETE FROM nars WHERE id IN ("
      (string-join nar-ids ",")
      "
)")))

  (with-postgresql-connection
   "data-deletion"
   (lambda (conn)
     (with-advisory-session-lock
      conn
      'delete-nars-for-unknown-store-paths
      (lambda ()
        (newline)
        (let loop ((nar-ids (get-nar-ids-batch conn)))
          (unless (null? nar-ids)
            (delete-narinfo-signature-data conn nar-ids)
            (delete-nars conn nar-ids)

            (display ".")
            (force-output)

            (loop (get-nar-ids-batch conn)))))))))