· 6 years ago · Sep 07, 2019, 12:08 PM
1#lang racket
2
3(require db
4 memo
5 "util.rkt"
6 racket/serialize)
7
8(provide #%app
9 #%datum
10 #%top
11
12 ;; SQL stuff
13 reader-jobs-queue
14 writer-jobs-queue
15
16 (struct-out sql-request)
17 (struct-out sql-response)
18
19 send-request/get-response
20 send-request/async
21
22 sql-read
23 sql-write
24
25 ;; other stuff
26 add-file
27 get-file-id
28 get-file-name
29
30 remove-files
31 rename-file
32
33 number-of-files
34 ;;number-of-tags ;; TODO
35
36 create-tag
37 get-tag-id
38 list-all-tags
39 create-tag
40 get-tag-size
41 get-tags-for-files
42 tag-files
43 untag-files
44
45
46
47 #%app
48 #%datum
49 #%top)
50
51(define reader-jobs-queue (make-parameter null))
52(define writer-jobs-queue (make-parameter null))
53
54(struct sql-request (kind sql-stmt args return-channel) #:prefab)
55(struct sql-response (status result) #:prefab)
56
57;; Send a request to a SQLite worker and return the response.
58;; Handles all serialization and deserialization of arguments.
59(define (send-request/get-response target kind sql-stmt args)
60 (let*-values ([(send receive) (place-channel)]
61 [(request) (sql-request kind sql-stmt (serialize args) send)])
62 (place-channel-put target request)
63
64 (match (place-channel-get receive)
65 [(sql-response 'ok result) (deserialize result)]
66 [(sql-response 'error result) (deserialize result)])))
67
68;; Send a request to a SQLite worker and return a sync event immediately.
69;; The return place-channel is a sync event, but send-request/async wraps it
70;; to preform deserialization.
71(define (send-request/async target kind sql-stmt args)
72 (let*-values ([(send receive) (place-channel)]
73 [(request) (sql-request kind sql-stmt (serialize args) send)])
74 (place-channel-put target request)
75 (wrap-evt receive (lambda (e)
76 (match e
77 [(sql-response 'ok result) (deserialize result)]
78 ;; TODO: raise an exception
79 [(sql-response 'error result) (deserialize result)])))))
80
81(define (sql-read kind sql-stmt . args) (send-request/get-response (reader-jobs-queue) kind sql-stmt args))
82(define (sql-write kind sql-stmt . args) (send-request/get-response (writer-jobs-queue) kind sql-stmt args))
83
84
85;; File operations
86;; ================================================================================================================
87
88
89;; Add a file to the system, return the file_id
90;;
91;; last-modify and size are added opportunistically, but silently left null if
92;; something goes wrong (e.g. the files are not accessible on this host for
93;; whatever reason.)
94;;
95;; If the file already exists, the existing file-id is returned without hassling
96;; the user.
97(define (add-file filename)
98 (or (get-file-id filename)
99 (begin0 (sql-write 'exec-with-last-rowid "INSERT INTO Files (filename, last_modified, size) VALUES (?,?,?)"
100 filename
101 (file-or-directory-modify-seconds filename #f (thunk sql-null))
102 (with-handlers ([(thunk* #t) (thunk* sql-null)])
103 (file-size filename)))
104
105 (invalidate-memo/single number-of-files)
106 ;; TODO: fire plugins with filename and file-id
107 )))
108
109;; Get the file-id for a given filename
110;; returns #f if the filename isn't in the db.
111(define/memoize (get-file-id filename)
112 (sql-read 'query-maybe-value "SELECT file_id FROM Files WHERE filename=?" filename))
113
114;; Get the filename for a given file-id
115;; returns #f if file-id isn't in the db.
116(define/memoize (get-file-name file-id)
117 (sql-read 'query-maybe-value "SELECT filename FROM Files where file_id=?" file-id))
118
119;; For each file-id provided, untag it completely. Optionally, delete the
120;; file as well.
121;;
122;; If this user requests file deletion but the file doesn't exist from the
123;; server's perspective, the system silently proceeds. This is designed
124;; to not hassle the user, but might change in the future because I'm not sure
125;; this is actually good behavior; a file might simply be inaccessible to the
126;; server but live elsewhere, and the user might want to know the file isn't
127;; actually gone.
128;;
129;; TODO: give the above some more consideration.
130(define (remove-files #:delete? [delete? #f] . file-ids)
131 ;; TODO: make this not suck
132 (let ([files-with-tags (map cons file-ids (apply get-tags-for-files file-ids))])
133 (for ([f files-with-tags])
134 ;; untag the file (this sucks)
135 (for ([t (cdr f)])
136 (untag-files t (car f)))
137
138 ;; optionally delete the file, if present
139 (when delete?
140 (let ([filename (get-file-name (car f))])
141 (when (file-exists? filename) (delete-file filename))))
142
143 ;; finally, remove it from the Files table.
144 (sql-write 'exec "DELETE FROM Files WHERE file_id=?" (car f)))
145
146 (invalidate-memo/single number-of-files)
147 ;; TODO: fire plugins with list of removed file ids.
148 ))
149
150
151;; Rename a file in the db, optionally moving the file on disk as well.
152;; The main reason somebody might want to rename a file in the DB but not
153;; their filesystem is probably due to samba nonsense with mangled unicode.
154;; Otherwise, this procedure will likely be invoked with #move-file? #t
155(define (rename-file file-id new-filename #:move-file? [move-file? #t])
156 (define old-filename (get-file-name file-id))
157 (when move-file? (rename-file-or-directory old-filename new-filename #f))
158 (sql-write 'exec "UPDATE Files SET filename=? WHERE file_id=?" new-filename file-id)
159
160 ;; invalidate caches concerning old file-id / filename association
161 (invalidate-memo/partial get-file-id old-filename)
162 (invalidate-memo/partial get-file-name file-id)
163
164 ;; TODO: fire plugins with old and new filename
165 )
166
167
168;; Total number of files registered in the system.
169(define/memoize-zero number-of-files
170 (sql-read 'query-value "SELECT count(*) FROM Files"))
171
172;; Tag operations
173;; =============================================================================================================================
174
175;; Get the id of a tag (passed as a symbol)
176;; If the tag does not exist, return #f
177;;
178;; TODO: this behavior is inconsistent with get-file-id.
179(define/memoize (get-tag-id tag)
180 (sql-read 'query-maybe-value "SELECT tag_id FROM Tags where tag_name=?" (symbol->string tag)))
181
182;; Returns a list of all tags, from the largest to the smallest.
183;;
184;; Perhaps we should invalidate this cache every time the size of a tag changes
185;; since the true ordering of the tags might have changed, but naive invalidation
186;; like that would have really awful performance and the consequence of this
187;; cache being slightly out of order should be relatively minor. In any
188;; event, it gets invalidated each time a tag is created or deleted, which
189;; in practice is probably often enough.
190(define/memoize-zero list-all-tags
191 (map string->symbol (sql-read 'query-list "SELECT tag_name FROM Tags ORDER BY num_files DESC")))
192
193;; Create a new tag, returning the tag-id.
194;;
195;; If the tag already exists, don't hassle the user; just return the tag-id.
196;; If we are creating a new tag for real, take the opportunity to invalidate the
197;; list-all-tags cache.
198(define (create-tag tag)
199 (or (get-tag-id tag)
200 (begin0
201 (sql-write 'exec-with-last-rowid "INSERT INTO Tags (tag_name) VALUES (?)" (symbol->string tag))
202
203 (invalidate-memo/single list-all-tags)
204 (invalidate-memo/partial get-tag-id tag)
205 ;; TODO: fire plugins with new tag
206 )))
207
208;; Return the number of files associated with a given tag.
209(define/memoize (get-tag-size tag)
210 (let ([tag-id (get-tag-id tag)])
211 (sql-read 'query-value "SELECT count(*) FROM FileTags WHERE tag_id=?" tag-id)))
212
213;; Given a file-ids, return a list of the tags those file-ids are associated with.
214;;
215;; If multiple reader places exist, use all of them. This has NOT (yet) been
216;; benchmarked. A more clever query running in a single reader place may very
217;; well outperform this solution.
218;;
219;; TODO: benchmark it
220(define (get-tags-for-files . file-ids)
221 (vector->list (sync/vector
222 (for/vector #:length (length file-ids)
223 ([file-id file-ids])
224 (send-request/async (reader-jobs-queue) 'query-list
225 (string-append "SELECT tag_name FROM Tags"
226 " INNER JOIN"
227 "(SELECT tag_id FROM FileTags WHERE file_id=?) AS sub"
228 " ON Tags.tag_id = sub.tag_id"
229 )
230 `(,file-id) )))))
231
232;; Apply a given tag to a set of file ids.
233;; If the tag doesn't already exist, it is silently created without hassling the user.
234;; If any of the file ids already have the given tag, they are silently skipped without
235;; hassling the user.
236(define (tag-files tag . file-ids)
237 (let* ([tag-id (create-tag tag)]
238 [files-with-tags (map cons file-ids (apply get-tags-for-files file-ids))]
239 [files-without-our-tag (filter (lambda (f) (not (member? tag (cdr f))))
240 files-with-tags)])
241 (for ([f files-without-our-tag])
242 (sql-write 'exec "INSERT INTO FileTags (file_id, tag_id, probability) VALUES (?,?,1.0)" (car f) tag-id)
243 (sql-write 'exec "UPDATE Files SET num_tags = num_tags + 1 WHERE file_id=?" (car f)))
244
245 (invalidate-memo/partial get-tag-size tag)
246 ;; TODO: fire plugins with tag and `files-without-our-tag` (which now have it.)
247 ))
248
249;; Remove a given tag from a set of file ids.
250;; If any of the file ids is not tagged with the given tag, they are silently skipped
251;; without hassling the user. If a tag is empty after this operation, it is deleted.
252;;
253;; TODO: This procedure performs up to three database writes. If those writes
254;; happened to be interleaved with other writes which are associated with
255;; the same tag, screwy things might happen. Therefore these two/three
256;; writes should be performed in a single transaction.
257(define (untag-files tag . file-ids)
258 (let* ([tag-id (get-tag-id tag)]
259 [files-with-tags (map cons file-ids (apply get-tags-for-files file-ids))]
260 [files-with-our-tag (filter (lambda (f) (member? tag (cdr f))) files-with-tags)])
261 (for ([f files-with-our-tag])
262 (sql-write 'exec "DELETE FROM FileTags WHERE file_id=? AND tag_id=? AND probability=1" (car f) tag-id)
263 (sql-write 'exec "UPDATE Files SET num_tags = num_tags - 1 WHERE file_id=?" (car f)))
264
265 (invalidate-memo/partial get-tag-size tag)
266 (when (zero? (get-tag-size tag))
267 (sql-write 'exec "DELETE FROM Tags WHERE tag_id=?" tag-id))
268
269 ;; TODO: fire plugins with tag and `files-with-our-tag` (which now do not have it.)
270 ))