leibowitz
Experimental Common Lisp object storage abstraction for Unix file systems
leibowitz/core/backends/sqlite.lisp
Download raw file: core/backends/sqlite.lisp
;; A library backend to store the ontology in an SQLite database.
(in-package :leibowitz.core)
;; Helper macros; these need to be declared before they're called.
(defmacro with-sqlite-tx ((sqlite-library) &body body)
"Run BODY as an atomic SQLite transaction."
`(sqlite:with-transaction (slot-value ,sqlite-library 'handle)
,@body))
(defmacro ccat (&rest strings)
"Concatenate some strings at compile-time. Used internally to shorten
lines with really long SQL queries."
(format NIL "~{~A~}" strings))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass sqlite-library (library)
((db-path
:type (or string pathname)
:initarg :db-path
:initform (error "db-path required.")
:documentation "The path to the SQLite database.")
(handle
:type sqlite:sqlite-handle
:documentation "The handle through which database queries are made."))
(:documentation "A library backend to store the ontology in a SQLite database."))
(defmethod print-object ((sqlite-library sqlite-library) stream)
(print-unreadable-object (sqlite-library stream :type T)
(format stream "~A" (slot-value sqlite-library 'db-path))))
(defmethod initialize-instance :after
((l sqlite-library) &rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(ensure-directories-exist (directory-namestring (slot-value l 'db-path)))
(setf (slot-value l 'handle) (sqlite:connect (slot-value l 'db-path)))
(mapcar (lambda (tbl) (sqlite:execute-non-query (slot-value l 'handle) tbl))
'("
create table if not exists 'data' (
'id' text not null unique,
'accesses' integer not null,
'type' text not null,
'birth' datetime not null,
'modified' datetime not null,
'terms' text
)" "
create table if not exists 'tags' (
'name' text not null unique,
'label' text,
'count' integer
)" "
create table if not exists 'tag_datum_junctions' (
'tag_name' text not null,
'datum_id' text not null,
unique(tag_name, datum_id) on conflict ignore
)" "
create table if not exists 'tag_predicates' (
'iftag' text not null,
'thentag' text not null,
unique(iftag, thentag) on conflict ignore
)" "
create virtual table if not exists 'search' using fts5 (
'terms',
'id',
content='data'
)" "
create trigger if not exists inc_tag_count after insert on tag_datum_junctions begin
update tags set count = count + 1 where name = new.tag_name;
end" "
create trigger if not exists dec_tag_count after delete on tag_datum_junctions begin
update tags set count = count - 1 where name = old.tag_name;
delete from tags where name = old.tag_name and count = 0 and label is null;
end" "
create trigger if not exists data_into_fts after insert on data begin
insert into search (id, terms) values (new.id, new.terms);
end" "
create trigger if not exists data_from_fts after delete on data begin
insert into search (search, id, terms) values ('delete', old.id, old.terms);
end
" "
create trigger if not exists data_update_fts after update on data begin
insert into search (search, id, terms) values ('delete', old.id, old.terms);
insert into search (id, terms) values (new.id, new.terms);
end" "
create trigger if not exists update_junction_on_datum_rename after update on data begin
update tag_datum_junctions set datum_id = new.id where datum_id = old.id;
end")))
;;; Library metadata
(defmethod library-print-info ((l sqlite-library))
(format (if *out* *out* T)
"SQLite Library on ~A with ~A tags and ~A files.~%"
(namestring (slot-value l 'db-path))
(library-tag-quantity l)
(library-data-quantity l)))
(defmethod library-data-quantity ((l sqlite-library))
(sqlite-row l "select count(*) from data"))
(defmethod library-tag-quantity ((l sqlite-library))
(sqlite-row l "select count(*) from tags"))
;;; FIXME: get this into one statement so that we can sort by count
;;; and group by the major part. This is apparently Very Hard in SQL.
;;; FIXME: is it worth writing tests for this?
(defmethod library-all-file-types ((l sqlite-library))
(loop for type in (sqlite-rows l "select distinct type from data")
collect (cons (car type)
(sqlite-row
l "select count(*) from data where type = ?"
(car type)))))
(defmethod datum-num-tags ((l sqlite-library) (datum string))
(sqlite-row l "select count(*) from tag_datum_junctions where datum_id = ? "
datum))
;;; Reading and writing data
;; FIXME: Make indexing jobs run in parallel!
(defmethod index ((l sqlite-library) (path-or-paths pathname)
&key (promote-error NIL))
(let ((thumbnailer:*thumbnail-cache-dir* (library-thumbnail-cache-dir l))
(indexed NIL))
(labels ((index-worker (path)
(when (library-path-indexable-p l path)
(format *out* "Indexing ~S..." (uiop:native-namestring path))
(finish-output *out*)
(handler-case
(let ((d (collection-index l (library-get-datum-collection l path) path)))
(push d indexed)
(thumbnailer:get-thumbnail (datum-id d) (datum-kind d))
;; For some reason known only to God and the
;; spirit that dwells within the Steele Bank
;; Common Lisp, we _need_ to `finish-output'
;; here in order to avoid an "invalid number of
;; arguments: 2" error
(finish-output))
;; FIXME: `no-such-file', `file-not-readable', etc.
;; The fact that `no-such-file' errors end up as
;; `no-applicable-collection' is really annoying,
;; where would be the proper place to correct this?
;; Perhaps in `datum's `initialize-instance'?
;; Really I should rip out collections altogether,
;; they're feeling more and more like an
;; overly-complex and inconvenient way of having
;; custom indexing rules for given directories.
;; (file-not-regular (c)
;; (if promote-error
;; (error c)
;; (when log (format T "failed!~%Error: ~A~%" c) (finish-output))))
(thumbnailer:unsupported-file-type (c)
(if promote-error
(error c)
(progn (format *out* "done~%")
(format *error-output* "~A~%" c))))
(thumbnailer:thumbnail-creation-failed (c)
(if promote-error
(error c)
(progn (format *out* "done~%")
(format *error-output* "~A~%" c))))
(:no-error (c)
(declare (ignore c))
(format *out* "done~%"))))))
(if (uiop:directory-exists-p path-or-paths)
(cl-fad:walk-directory path-or-paths #'index-worker)
(index-worker path-or-paths)))
indexed))
(defmethod add-datum ((l sqlite-library) (d datum))
(sqlite-nq l (ccat "insert or replace into data "
"(id, accesses, type, birth, modified, terms) "
"values (?, ?, ?, ?, ?, ?)")
(datum-id d) (datum-accesses d) (datum-kind d) (datum-birth d)
(datum-modified d) (datum-terms d))
d)
(defmethod get-datum ((l sqlite-library) (path string) &key (error NIL))
(multiple-value-bind
(id accesses kind birth modified terms)
(sqlite-row l "select * from data where id = ?"
(%need-datum-id path))
(if id
(make-instance 'datum :id id :accesses accesses :kind kind :birth birth
:modified modified :terms terms
:collection (library-get-datum-collection l id))
(if error
(error 'datum-not-indexed :lib l :id path)
NIL))))
(defun %del-datum-inner-transaction (lib id)
(loop for tag in (get-datum-tags lib id)
do (sqlite-nq lib (ccat "delete from tags where name = ? and "
"count = 0 and label is null")
(tag-name tag)))
(sqlite-nq lib "delete from data where id = ?" id)
(sqlite-nq lib "delete from tag_datum_junctions where datum_id = ?" id))
(defmethod del-datum ((l sqlite-library) (datum-or-id string) &key (error NIL) (disk T))
(let ((id (%need-datum-id datum-or-id)))
(format *out* "Removing ~A~%" id)
(when error (get-datum l id :error T))
(with-sqlite-tx (l)
(%del-datum-inner-transaction l id))
;; FIXME: this should be mediated by this datum's collection.
;; Placing this last means that if this datum is in db but not in
;; disk, the orphaned entries will be removed before an error is
;; signaled.
(when disk (if (probe-file (uiop:parse-native-namestring id))
(delete-file (uiop:parse-native-namestring id))
(when error
(error 'datum-is-orphaned :id id))))))
(defmethod move-datum ((l sqlite-library) old-datum-or-id new-datum-or-id
&key (overwrite NIL))
(check-type old-datum-or-id (or string pathname datum))
(check-type new-datum-or-id (or string pathname datum))
(let* ((old (%need-datum-id old-datum-or-id))
(new (%need-datum-id new-datum-or-id))
(oldpath (uiop:parse-unix-namestring old))
(newpath (uiop:parse-unix-namestring new))
;; FIXME: aren't we appending an image file extension? I
;; think there'll be a bug here!
(oldth (merge-pathnames oldpath (library-thumbnail-cache-dir l)))
(newth (merge-pathnames newpath (library-thumbnail-cache-dir l))))
(format *out* "Moving ~A -> ~A~%" old new)
(when (equal old new) (error 'cannot-mv-or-cp-to-itself :d new))
(unless (get-datum l old) (error 'datum-not-indexed :lib l :id old))
(when (and (or (get-datum l new) (probe-file newpath))
(not overwrite))
(error 'datum-already-exists :d new))
(when (and (not (probe-file oldpath))
(not (probe-file newpath)))
(error 'datum-is-orphaned :id old))
;; It's okay if old doesn't exist on disk as long as the entry is
;; still in the DB; the user might have moved it and want to
;; update the ID.
(when (probe-file oldpath)
(rename-file oldpath newpath)
;; The user probably passed a relative path for new, and we want
;; the absolute for all ids.
(setf new (uiop:native-namestring (truename newpath))))
(when (probe-file oldth)
(rename-file oldth newth))
;; Triggers do the hard lifting of keeping everything up to date.
(with-sqlite-tx (l)
(%del-datum-inner-transaction l new)
(sqlite-nq l "update data set id = ? where id = ?" new old))
(uiop:native-namestring new)))
(defmethod copy-datum ((l sqlite-library) old-datum-or-id new-datum-or-id
&key (overwrite NIL))
(check-type old-datum-or-id (or string pathname datum))
(check-type new-datum-or-id (or string pathname datum))
(let* ((old (%need-datum-id old-datum-or-id))
(new (%need-datum-id new-datum-or-id))
(oldth (merge-pathnames old (library-thumbnail-cache-dir l)))
(newth (merge-pathnames new (library-thumbnail-cache-dir l))))
(format *out* "Copying ~A -> ~A~%" old new)
(when (equal old new) (error 'cannot-mv-or-cp-to-itself :d new))
(unless (get-datum l old) (error 'datum-not-indexed :lib l :id old))
(unless (probe-file old) (error 'datum-is-orphaned :lib l :id old))
(when (and (or (get-datum l new) (probe-file new))
(not overwrite))
(error 'datum-already-exists :d new))
(uiop:copy-file old new)
(uiop:copy-file oldth newth)
(with-sqlite-tx (l)
(let* ((new (namestring (truename new)))
(datum (get-datum l old))
(tags (get-datum-tags l datum)))
(setf (datum-id datum) new)
(add-datum l datum)
(if overwrite
(%add-datum-tags-inner-transaction l datum tags :replace T)
(%add-datum-tags-inner-transaction l datum tags)))
(get-datum l new))))
;;; Reading and writing tags
(defun %add-tag-inner-transaction (l tag)
(let* ((tag (if (stringp tag) (make-instance 'tag :name tag) tag))
(prev-label (sqlite-row l "select label from tags where name = ?" (tag-name tag)))
(curr-label (if (slot-boundp tag 'label) (tag-label tag) NIL)))
;; We insert-or-ignore here in order to not clobber count.
(sqlite-nq l "insert or ignore into tags (name, label, count) values (?, ?, ?)"
(tag-name tag) curr-label (tag-count tag))
(when curr-label
(unless (equal prev-label curr-label)
(sqlite-nq l "update tags set label = ? where name = ?"
curr-label (tag-name tag))))
tag))
(defmethod add-tag ((l sqlite-library) tag-or-name)
(check-type tag-or-name (or tag string))
(with-sqlite-tx (l)
(%add-tag-inner-transaction l tag-or-name)
(get-tag l (%need-tag-name tag-or-name))))
(defmethod get-tag ((l sqlite-library) tag-name &key (error NIL))
(check-type tag-name string)
(multiple-value-bind
(name label count)
(sqlite-row l "select * from tags where name = ?" tag-name)
(if name
(make-instance 'tag :name name :label label :count count)
(if error
(error 'no-such-tag :name tag-name :lib l)
NIL))))
(defun %del-tag-inner-transaction (l name)
(check-type l sqlite-library)
(check-type name string)
(sqlite-nq l "delete from tags where name = ?" name)
(sqlite-nq l "delete from tag_datum_junctions where tag_name = ?" name)
(sqlite-nq l "delete from tag_predicates where iftag = ? or thentag = ?"
name name))
(defmethod del-tag ((l sqlite-library) tag-or-name)
(check-type tag-or-name (or datum string))
(format *out* "Removing tag ~S~%" tag-or-name)
(with-sqlite-tx (l)
(%del-tag-inner-transaction l (%need-tag-name tag-or-name))))
(defmethod move-tag ((l sqlite-library) old-tag-or-name new-tag-or-name
&key (overwrite NIL) (merge NIL))
(check-type old-tag-or-name (or string tag))
(check-type new-tag-or-name (or string tag))
(check-type overwrite boolean)
(check-type merge boolean)
(assert (not (and merge overwrite)))
(let ((old (%need-tag-name old-tag-or-name))
(new (%need-tag-name new-tag-or-name)))
(format *out* "Moving tag ~A -> ~A~%" old new)
(when (equal old new) (error 'cannot-mv-or-cp-to-itself :d new))
(unless (get-tag l old) (error 'no-such-tag :name old :lib l))
(when (and (get-tag l new)
(not (or overwrite merge)))
(error 'tag-already-exists :name new))
(with-sqlite-tx (l)
(when overwrite
(%del-tag-inner-transaction l new))
(if merge
(let ((old-tag (get-tag l old)))
(sqlite-nq l "update tags set label = ? where name = ?" (tag-label old-tag) new)
(sqlite-nq l "update tags set count = count + ? where name = ?" (tag-count old-tag) new)
(sqlite-nq l "delete from tags where name = ?" old)
;; Since we're merging, the data of old all need to be
;; updated to the existing new's predicate tags. Worst
;; case runtime of O(fuck-my-life-I-hate-graphs).
(let* ((predicates (%cascade-down-predicate-tree l new))
(tags (loop for tag being each hash-key of predicates
collect tag)))
(loop for datum in (list-data l :tags (list old))
do (%add-datum-tags-inner-transaction l datum tags))))
(sqlite-nq l "update tags set name = ? where name = ?" new old))
(sqlite-nq l "update tag_datum_junctions set tag_name = ? where tag_name = ?" new old)
(sqlite-nq l "update tag_predicates set iftag = ? where iftag = ?" new old)
(sqlite-nq l "update tag_predicates set thentag = ? where thentag = ?" new old)
(get-tag l new))))
(defmethod copy-tag ((l sqlite-library) old-tag-or-name new-tag-or-name
&key (overwrite NIL) (merge NIL))
(check-type old-tag-or-name (or string tag))
(check-type new-tag-or-name (or string tag))
(check-type overwrite boolean)
(check-type merge boolean)
(assert (not (and merge overwrite)))
(let ((old (%need-tag-name old-tag-or-name))
(new (%need-tag-name new-tag-or-name)))
(format *out* "Copying tag ~A -> ~A~%" old new)
(when (equal old new) (error 'cannot-mv-or-cp-to-itself :d new))
(unless (get-tag l old) (error 'no-such-tag :name old :lib l))
(when (and (get-tag l new)
(not (or overwrite merge)))
(error 'tag-already-exists :name new))
(with-sqlite-tx (l)
(when overwrite (%del-tag-inner-transaction l new))
(let ((new-tag (make-instance 'tag :name new
:label (tag-label (get-tag l old)))))
(%add-tag-inner-transaction l new-tag))
(loop for predicate in (get-tag-predicates l old)
do (%add-tag-predicate-inner-transaction l new (list predicate)))
(loop for datum in (list-data l :tags (list old))
do (%add-datum-tags-inner-transaction l datum (list new)))
(get-tag l new))))
;;; Reading and writing datum-tag relationships
;; FIXME: if tags is a list of tag instances, their labels are
;; discarded!
(defun %add-datum-tags-inner-transaction (lib datum-or-id tags &key replace)
"Same deal as `%del-datum-tags-inner-transaction'."
(check-type datum-or-id (or datum pathname string))
(check-type tags list)
(labels ((add-assoc (l name id)
(%add-tag-inner-transaction l name)
(sqlite-nq l (ccat "insert into tag_datum_junctions "
"(tag_name, datum_id) values (?, ?)")
name id)))
(when replace
(%del-datum-tags-inner-transaction
lib datum-or-id (get-datum-tags lib datum-or-id)))
(loop for tag in tags
for id = (%need-datum-id datum-or-id)
for name = (%need-tag-name tag)
for required-tags = (%cascade-down-predicate-tree lib name)
do (loop for required-tag being each hash-key of required-tags
do (add-assoc lib required-tag id)))))
(defmethod add-datum-tags ((l sqlite-library) datum-or-id tags &key (replace NIL))
(format *out* "Adding tag ~S to file ~S~%" tags (%need-datum-id datum-or-id))
(unless (get-datum l (%need-datum-id datum-or-id))
(error 'datum-not-indexed :lib l :id (%need-datum-id datum-or-id)))
(with-sqlite-tx (l)
(%add-datum-tags-inner-transaction l datum-or-id tags :replace replace)))
(defmethod get-datum-tags ((l sqlite-library) datum-or-id)
(check-type datum-or-id (or datum pathname string))
(loop for row in (sqlite-rows l (ccat "select tags.* from tags "
"inner join tag_datum_junctions "
"on tag_name = name where datum_id = ?")
(%need-datum-id datum-or-id))
collect (destructuring-bind (name label count) row
(make-instance 'tag :name name :count count :label label))))
(defun %del-datum-tags-inner-transaction (lib datum-or-id tags &key cascade)
"All the tag operations require multiple update/insert/delete queries,
which we want to run atomically in a single transaction in order to
avoid corrupting the db. Unfortunately, transactions cannot be nested
and `add-datum-tags' needs to call `del-datum-tags' within its own
transaction, hence this little helper function."
(labels ((del-assoc (l name id)
(sqlite-nq l (ccat "delete from tag_datum_junctions "
"where tag_name = ? and datum_id = ?")
name id)
(sqlite-nq l (ccat "delete from tags where name = ? and "
"count = 0 and label is null")
name)))
(loop for tag in tags
for name = (%need-tag-name tag)
for id = (%need-datum-id datum-or-id)
do (del-assoc lib name id)
(when cascade
(loop for req being each hash-key of (%cascade-down-predicate-tree lib name)
do (del-assoc lib req id))))))
(defmethod del-datum-tags ((l sqlite-library) (datum-or-id string) (tags list)
&key (cascade NIL))
(format *out* "Removing tags from file ~S: ~S~%" datum-or-id tags)
(get-datum l datum-or-id :error T)
(with-sqlite-tx (l)
(%del-datum-tags-inner-transaction l datum-or-id tags :cascade cascade)))
;;; Reading and writing tag hierarchies
(defun %add-tag-predicate-inner-transaction (l iftag-or-name thentags-or-names
&key (retroactive T) (replace NIL))
(labels ((add-assoc (ifname thenname)
(let ((ifname (%need-tag-name ifname))
(thenname (%need-tag-name thenname)))
;; FIXME: if this methods arguments are tags we'll
;; lose information like labels! In general the core
;; library's handling of different argument types is
;; abysmally convoluted.
(unless (get-tag l ifname)
(%add-tag-inner-transaction l ifname))
(unless (get-tag l thenname)
(%add-tag-inner-transaction l thenname))
;; FIXME: give del-tag-predicate a retroactive option
;; and pass it whatever value we were passed here
(sqlite-nq l (ccat "insert or ignore into tag_predicates "
"(iftag, thentag) values (?, ?)")
ifname thenname)
(when retroactive
;; Big O of deez nuts
(let ((predicates (%cascade-down-predicate-tree l iftag-or-name)))
(loop for tag being each hash-key of predicates
do (loop for datum in (list-data l :tags (list tag))
do (%add-datum-tags-inner-transaction
l datum (list thenname)))))))))
;; FIXME: refactor del-tag-predicate to optionally take a list
(when replace
(loop for tag in (get-tag-predicates l iftag-or-name)
do (del-tag-predicate l iftag-or-name tag)))
(etypecase thentags-or-names
((or string tag) (add-assoc iftag-or-name thentags-or-names))
(list (loop for thentag-or-name in thentags-or-names
do (add-assoc iftag-or-name thentag-or-name))))))
(defmethod add-tag-predicate ((l sqlite-library) iftag-or-name thentags-or-names
&key (retroactive T) (replace NIL))
(check-type iftag-or-name (or tag string))
(format *out* "If a file has tag ~S, it now also has ~S~%" iftag-or-name thentags-or-names)
(with-sqlite-tx (l)
(%add-tag-predicate-inner-transaction
l iftag-or-name thentags-or-names :replace replace :retroactive retroactive)))
(defmethod get-tag-predicates ((l sqlite-library) tag-or-name)
(check-type tag-or-name (or tag string))
(loop for row in (sqlite-rows l (ccat "select tags.* from tags "
"inner join tag_predicates "
"on thentag = name where iftag = ?")
(%need-tag-name tag-or-name))
collect (destructuring-bind (name label count) row
(make-instance 'tag :name name :count count :label label))))
(defmethod get-tag-predicands ((l sqlite-library) tag-or-name)
(check-type tag-or-name (or tag string))
(loop for row in (sqlite-rows l (ccat "select tags.* from tags "
"inner join tag_predicates "
"on iftag = name where thentag = ?")
(%need-tag-name tag-or-name))
collect (destructuring-bind (name label count) row
(make-instance 'tag :name name :count count :label label))))
(defmethod del-tag-predicate ((l sqlite-library) iftag-or-name thentag-or-name)
(check-type iftag-or-name (or tag string))
(check-type thentag-or-name (or tag string))
(format *out* "Files tagged with ~S, will no longer have ~S~%"
iftag-or-name thentag-or-name)
(let ((ifname (%need-tag-name iftag-or-name))
(thenname (%need-tag-name thentag-or-name)))
(sqlite-nq l "delete from tag_predicates where iftag = ? and thentag = ?"
ifname thenname)))
(defmethod tag-num-parents ((l sqlite-library) (tag-or-name string))
(sqlite-row l "select count(*) from tag_predicates where iftag = ?" tag-or-name))
(defmethod tag-num-children ((l sqlite-library) (tag-or-name string))
(sqlite-row l "select count(*) from tag_predicates where thentag = ?" tag-or-name))
;;; Searching and Listing
;; FIXME: Improve search! We should be able to search in different or
;; all fields (id, body, tags) and filter for tags at the same time as
;; searching for text.
;; FIXME: add support for tag filtering
;; FIXME: the search terms must follow FTS's search syntax and we will
;; receive an error if they contain certain stray characters. This
;; may be fixed by double-quoting the entire string, but then we lose
;; the search syntax. Figure out a policy here!
(defmethod query ((l sqlite-library) terms &key (sort-by :rank) (direction :ascending)
(limit NIL) (offset NIL))
(assert (member sort-by '(:rank :modified :birth :accesses)))
(assert (member direction '(:descending :ascending)))
(check-type terms string)
(check-type offset (or null integer))
(check-type limit (or null integer))
(when (or offset limit) (assert (and offset limit)))
(loop for row in (sqlite-rows
l (format NIL (ccat "select data.* from search "
"left join data on data.id = search.id "
"where search match ? order by ~A ~A ~A")
(cond ((eql sort-by :rank) "rank")
((eql sort-by :modified) "modified")
((eql sort-by :birth) "birth")
((eql sort-by :accesses) "accesses"))
(cond ((eql direction :descending) "desc")
((eql direction :ascending) "asc"))
(if (and limit offset)
(format NIL "limit ~A offset ~A" limit offset)
""))
terms)
collect (destructuring-bind (id accesses kind birth modified terms) row
(make-instance 'datum :id id :accesses accesses :kind kind
:birth birth :modified modified
:terms terms
:collection (library-get-datum-collection l id)))))
(defmethod list-tags ((l sqlite-library) &key (limit NIL))
(check-type limit (or null integer))
(loop for row in (sqlite-rows
l (format NIL "select * from tags order by count desc ~A"
(if limit (format NIL "limit ~A" limit) "")))
collect (destructuring-bind (name label count) row
(make-instance 'tag :name name :count count :label label))))
;; FIXME: Track datum tag-count so we can sort by them
(defmethod list-data ((l sqlite-library) &key (sort-by :modified)
(direction :descending)
(limit NIL) (offset NIL)
(tags NIL) (type NIL) (dir NIL))
(assert (member sort-by '(:modified :birth :accesses)))
(assert (member direction '(:descending :ascending)))
(check-type limit (or null integer))
(check-type offset (or null integer))
(check-type tags list)
(check-type type (or null string))
(check-type dir (or null string pathname))
(setf dir (etypecase dir
(string (uiop:parse-unix-namestring dir))
((or pathname null) dir)))
(when (or limit offset) (assert (and limit offset)))
(let ((query (format NIL "~A select * from ~A ~A order by ~A ~A ~A"
(if tags
(format NIL "with tagged as ~
(select data.* from data ~
inner join tag_datum_junctions ~
on datum_id = data.id where ~
~v{tag_name = ?~*~^ or ~})"
(length tags) tags)
"")
(if tags "tagged" "data")
(if type "where type = ?" "")
(case sort-by
(:modified "modified")
(:birth "birth")
(:accesses "accesses"))
(case direction
(:descending "desc")
(:ascending "asc"))
(if (and limit offset)
(format NIL "limit ~A offset ~A" limit offset)
""))))
(loop for row in (apply #'sqlite-rows (nconc (list l query)
(mapcar #'%need-tag-name tags)
(when type (list type))))
;; FIXME: will this filtering approach break if the database
;; and filesystem are out of sync? I'd rather do it in SQL
when (let* ((id (uiop:parse-unix-namestring (car row)))
(base (make-pathname :name (pathname-name id)
:type (pathname-type id))))
(if dir (equal id (merge-pathnames base dir)) T))
collect (destructuring-bind (id accesses kind birth modified terms) row
(make-instance 'datum :id id :accesses accesses :kind kind
:birth birth :modified modified
:terms terms
:collection (library-get-datum-collection l id))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Additional Methods
(defmethod sqlite-nq ((l sqlite-library) &rest args)
"Run a non-query on this database."
(apply #'sqlite:execute-non-query (nconc (list (slot-value l 'handle)) args)))
(defmethod sqlite-row ((l sqlite-library) &rest args)
"Run a query on this database that returns a single row."
(apply #'sqlite:execute-one-row-m-v (nconc (list (slot-value l 'handle)) args)))
(defmethod sqlite-rows ((l sqlite-library) &rest args)
"Run a query on this database that returns multiple rows."
(apply #'sqlite:execute-to-list (nconc (list (slot-value l 'handle)) args)))
(defun %cascade-down-predicate-tree (lib root &optional (tbl NIL))
"Given ROOT as the root tag of a tag hierarchy, traverse down it and
return a hash table of all tags that should be added. If we encounter
a tag that is already in the table of tags to add, simply skip it; ie,
cycles in the tag hierarchy are just ignored."
;; Create the hash table the first time this function is called
(unless tbl (setf tbl (make-hash-table :test #'equal)))
;; Do a recursive breadth-first search of the graph, skipping
;; whenever we find a tag that was previously encountered in order
;; to avoid recursing infinitely.
(setf (gethash root tbl) root)
(loop for tag in (get-tag-predicates lib root)
for name = (tag-name tag)
unless (gethash (tag-name tag) tbl)
do (setf (gethash (tag-name tag) tbl) (tag-name tag))
(%cascade-down-predicate-tree lib (tag-name tag) tbl))
tbl)