You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

274 lines
12 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2017 Caleb Ristvedt <caleb.ristvedt@cune.org>
  3. ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (guix store database)
  20. #:use-module (sqlite3)
  21. #:use-module (guix config)
  22. #:use-module (guix serialization)
  23. #:use-module (guix store deduplication)
  24. #:use-module (guix base16)
  25. #:use-module (guix build syscalls)
  26. #:use-module (srfi srfi-1)
  27. #:use-module (srfi srfi-11)
  28. #:use-module (srfi srfi-19)
  29. #:use-module (rnrs io ports)
  30. #:use-module (ice-9 match)
  31. #:use-module (system foreign)
  32. #:export (sql-schema
  33. with-database
  34. sqlite-register
  35. register-path
  36. reset-timestamps))
  37. ;;; Code for working with the store database directly.
  38. (define sql-schema
  39. ;; Name of the file containing the SQL scheme or #f.
  40. (make-parameter #f))
  41. (define sqlite-exec
  42. ;; XXX: This is was missing from guile-sqlite3 until
  43. ;; <https://notabug.org/civodul/guile-sqlite3/commit/b87302f9bcd18a286fed57b2ea521845eb1131d7>.
  44. (let ((exec (pointer->procedure
  45. int
  46. (dynamic-func "sqlite3_exec" (@@ (sqlite3) libsqlite3))
  47. '(* * * * *))))
  48. (lambda (db text)
  49. (let ((ret (exec ((@@ (sqlite3) db-pointer) db)
  50. (string->pointer text)
  51. %null-pointer %null-pointer %null-pointer)))
  52. (unless (zero? ret)
  53. ((@@ (sqlite3) sqlite-error) db "sqlite-exec" ret))))))
  54. (define (initialize-database db)
  55. "Initializing DB, an empty database, by creating all the tables and indexes
  56. as specified by SQL-SCHEMA."
  57. (define schema
  58. (or (sql-schema)
  59. (search-path %load-path "guix/store/schema.sql")))
  60. (sqlite-exec db (call-with-input-file schema get-string-all)))
  61. (define (call-with-database file proc)
  62. "Pass PROC a database record corresponding to FILE. If FILE doesn't exist,
  63. create it and initialize it as a new database."
  64. (let ((new? (not (file-exists? file)))
  65. (db (sqlite-open file)))
  66. (dynamic-wind noop
  67. (lambda ()
  68. (when new?
  69. (initialize-database db))
  70. (proc db))
  71. (lambda ()
  72. (sqlite-close db)))))
  73. (define-syntax-rule (with-database file db exp ...)
  74. "Open DB from FILE and close it when the dynamic extent of EXP... is left.
  75. If FILE doesn't exist, create it and initialize it as a new database."
  76. (call-with-database file (lambda (db) exp ...)))
  77. (define (last-insert-row-id db)
  78. ;; XXX: (sqlite3) currently lacks bindings for 'sqlite3_last_insert_rowid'.
  79. ;; Work around that.
  80. (let* ((stmt (sqlite-prepare db "SELECT last_insert_rowid();"
  81. #:cache? #t))
  82. (result (sqlite-fold cons '() stmt)))
  83. (sqlite-finalize stmt)
  84. (match result
  85. ((#(id)) id)
  86. (_ #f))))
  87. (define path-id-sql
  88. "SELECT id FROM ValidPaths WHERE path = :path")
  89. (define* (path-id db path)
  90. "If PATH exists in the 'ValidPaths' table, return its numerical
  91. identifier. Otherwise, return #f."
  92. (let ((stmt (sqlite-prepare db path-id-sql #:cache? #t)))
  93. (sqlite-bind-arguments stmt #:path path)
  94. (let ((result (sqlite-fold cons '() stmt)))
  95. (sqlite-finalize stmt)
  96. (match result
  97. ((#(id) . _) id)
  98. (_ #f)))))
  99. (define update-sql
  100. "UPDATE ValidPaths SET hash = :hash, registrationTime = :time, deriver =
  101. :deriver, narSize = :size WHERE id = :id")
  102. (define insert-sql
  103. "INSERT INTO ValidPaths (path, hash, registrationTime, deriver, narSize)
  104. VALUES (:path, :hash, :time, :deriver, :size)")
  105. (define* (update-or-insert db #:key path deriver hash nar-size time)
  106. "The classic update-if-exists and insert-if-doesn't feature that sqlite
  107. doesn't exactly have... they've got something close, but it involves deleting
  108. and re-inserting instead of updating, which causes problems with foreign keys,
  109. of course. Returns the row id of the row that was modified or inserted."
  110. (let ((id (path-id db path)))
  111. (if id
  112. (let ((stmt (sqlite-prepare db update-sql #:cache? #t)))
  113. (sqlite-bind-arguments stmt #:id id
  114. #:path path #:deriver deriver
  115. #:hash hash #:size nar-size #:time time)
  116. (sqlite-fold cons '() stmt)
  117. (sqlite-finalize stmt)
  118. (last-insert-row-id db))
  119. (let ((stmt (sqlite-prepare db insert-sql #:cache? #t)))
  120. (sqlite-bind-arguments stmt
  121. #:path path #:deriver deriver
  122. #:hash hash #:size nar-size #:time time)
  123. (sqlite-fold cons '() stmt) ;execute it
  124. (sqlite-finalize stmt)
  125. (last-insert-row-id db)))))
  126. (define add-reference-sql
  127. "INSERT OR IGNORE INTO Refs (referrer, reference) SELECT :referrer, id
  128. FROM ValidPaths WHERE path = :reference")
  129. (define (add-references db referrer references)
  130. "REFERRER is the id of the referring store item, REFERENCES is a list
  131. containing store items being referred to. Note that all of the store items in
  132. REFERENCES must already be registered."
  133. (let ((stmt (sqlite-prepare db add-reference-sql #:cache? #t)))
  134. (for-each (lambda (reference)
  135. (sqlite-reset stmt)
  136. (sqlite-bind-arguments stmt #:referrer referrer
  137. #:reference reference)
  138. (sqlite-fold cons '() stmt) ;execute it
  139. (sqlite-finalize stmt)
  140. (last-insert-row-id db))
  141. references)))
  142. ;; XXX figure out caching of statement and database objects... later
  143. (define* (sqlite-register #:key db-file path (references '())
  144. deriver hash nar-size)
  145. "Registers this stuff in a database specified by DB-FILE. PATH is the string
  146. path of some store item, REFERENCES is a list of string paths which the store
  147. item PATH refers to (they need to be already registered!), DERIVER is a string
  148. path of the derivation that created the store item PATH, HASH is the
  149. base16-encoded sha256 hash of the store item denoted by PATH (prefixed with
  150. \"sha256:\") after being converted to nar form, and nar-size is the size in
  151. bytes of the store item denoted by PATH after being converted to nar form."
  152. (with-database db-file db
  153. (let ((id (update-or-insert db #:path path
  154. #:deriver deriver
  155. #:hash hash
  156. #:nar-size nar-size
  157. #:time (time-second (current-time time-utc)))))
  158. (add-references db id references))))
  159. ;;;
  160. ;;; High-level interface.
  161. ;;;
  162. ;; TODO: Factorize with that in (gnu build install).
  163. (define (reset-timestamps file)
  164. "Reset the modification time on FILE and on all the files it contains, if
  165. it's a directory."
  166. (let loop ((file file)
  167. (type (stat:type (lstat file))))
  168. (case type
  169. ((directory)
  170. (utime file 0 0 0 0)
  171. (let ((parent file))
  172. (for-each (match-lambda
  173. (("." . _) #f)
  174. ((".." . _) #f)
  175. ((file . properties)
  176. (let ((file (string-append parent "/" file)))
  177. (loop file
  178. (match (assoc-ref properties 'type)
  179. ((or 'unknown #f)
  180. (stat:type (lstat file)))
  181. (type type))))))
  182. (scandir* parent))))
  183. ((symlink)
  184. ;; FIXME: Implement bindings for 'futime' to reset the timestamps on
  185. ;; symlinks.
  186. #f)
  187. (else
  188. (utime file 0 0 0 0)))))
  189. ;; TODO: make this canonicalize store items that are registered. This involves
  190. ;; setting permissions and timestamps, I think. Also, run a "deduplication
  191. ;; pass", whatever that involves. Also, handle databases not existing yet
  192. ;; (what should the default behavior be? Figuring out how the C++ stuff
  193. ;; currently does it sounds like a lot of grepping for global
  194. ;; variables...). Also, return #t on success like the documentation says we
  195. ;; should.
  196. (define* (register-path path
  197. #:key (references '()) deriver prefix
  198. state-directory (deduplicate? #t))
  199. ;; Priority for options: first what is given, then environment variables,
  200. ;; then defaults. %state-directory, %store-directory, and
  201. ;; %store-database-directory already handle the "environment variables /
  202. ;; defaults" question, so we only need to choose between what is given and
  203. ;; those.
  204. "Register PATH as a valid store file, with REFERENCES as its list of
  205. references, and DERIVER as its deriver (.drv that led to it.) If PREFIX is
  206. given, it must be the name of the directory containing the new store to
  207. initialize; if STATE-DIRECTORY is given, it must be a string containing the
  208. absolute file name to the state directory of the store being initialized.
  209. Return #t on success.
  210. Use with care as it directly modifies the store! This is primarily meant to
  211. be used internally by the daemon's build hook."
  212. (let* ((db-dir (cond
  213. (state-directory
  214. (string-append state-directory "/db"))
  215. (prefix
  216. ;; If prefix is specified, the value of NIX_STATE_DIR
  217. ;; (which affects %state-directory) isn't supposed to
  218. ;; affect db-dir, only the compile-time-customized
  219. ;; default should.
  220. (string-append prefix %localstatedir "/guix/db"))
  221. (else
  222. %store-database-directory)))
  223. (store-dir (if prefix
  224. ;; same situation as above
  225. (string-append prefix %storedir)
  226. %store-directory))
  227. (to-register (if prefix
  228. (string-append %storedir "/" (basename path))
  229. ;; note: we assume here that if path is, for
  230. ;; example, /foo/bar/gnu/store/thing.txt and prefix
  231. ;; isn't given, then an environment variable has
  232. ;; been used to change the store directory to
  233. ;; /foo/bar/gnu/store, since otherwise real-path
  234. ;; would end up being /gnu/store/thing.txt, which is
  235. ;; probably not the right file in this case.
  236. path))
  237. (real-path (string-append store-dir "/" (basename path))))
  238. (let-values (((hash nar-size)
  239. (nar-sha256 real-path)))
  240. (reset-timestamps real-path)
  241. (sqlite-register
  242. #:db-file (string-append db-dir "/db.sqlite")
  243. #:path to-register
  244. #:references references
  245. #:deriver deriver
  246. #:hash (string-append "sha256:"
  247. (bytevector->base16-string hash))
  248. #:nar-size nar-size)
  249. (when deduplicate?
  250. (deduplicate real-path hash #:store store-dir)))))