objective categorical abstract machine language personal data server
Blob storage
+83
+80
pegasus/lib/blob_store.ml
+80
pegasus/lib/blob_store.ml
···
1
+
open Util.Rapper
2
+
open Util.Syntax
3
+
module Lex = Mist.Lex
4
+
module Tid = Mist.Tid
5
+
6
+
type t = Caqti_lwt.connection
7
+
8
+
type blob = {id: int; cid: Cid.t; mimetype: string; data: Blob.t}
9
+
10
+
module Queries = struct
11
+
let create_tables t =
12
+
let$! () =
13
+
[%rapper
14
+
execute
15
+
{sql| CREATE TABLE IF NOT EXISTS blobs (
16
+
id INTEGER PRIMARY KEY,
17
+
cid TEXT NOT NULL,
18
+
mimetype TEXT NOT NULL,
19
+
data BLOB NOT NULL
20
+
);
21
+
|sql}]
22
+
() t
23
+
in
24
+
let$! () =
25
+
[%rapper
26
+
execute
27
+
{sql| CREATE TABLE IF NOT EXISTS blobs_records (
28
+
blob_id INTEGER NOT NULL REFERENCES blobs(id) ON DELETE CASCADE,
29
+
record_path TEXT NOT NULL REFERENCES records(path) ON DELETE CASCADE,
30
+
PRIMARY KEY (blob_id, record_path)
31
+
);
32
+
|sql}]
33
+
() t
34
+
in
35
+
[%rapper
36
+
execute
37
+
{sql| CREATE TRIGGER IF NOT EXISTS cleanup_orphaned_blobs
38
+
AFTER DELETE ON blobs_records
39
+
BEGIN
40
+
DELETE FROM blobs
41
+
WHERE id NOT IN (
42
+
SELECT DISTINCT blob_id FROM blobs_records
43
+
);
44
+
END;
45
+
|sql}
46
+
syntax_off]
47
+
() t
48
+
49
+
let get_blob =
50
+
[%rapper
51
+
get_opt
52
+
{sql| SELECT @int{id}, @CID{cid}, @string{mimetype}, @Blob{data} FROM blobs WHERE cid = %CID{cid} |sql}
53
+
record_out]
54
+
55
+
let list_blobs ~limit ~cursor =
56
+
[%rapper
57
+
get_many
58
+
{sql| SELECT @CID{cid} FROM blobs WHERE id > %int{cursor} ORDER BY id LIMIT %int{limit} |sql}]
59
+
~limit ~cursor
60
+
61
+
let write_blob cid mimetype data =
62
+
[%rapper
63
+
get_one
64
+
{sql| INSERT INTO blobs (cid, mimetype, data) VALUES (%CID{cid}, %string{mimetype}, %Blob{data}) RETURNING @int{id} |sql}]
65
+
~cid ~mimetype ~data
66
+
end
67
+
68
+
let init connection = Queries.create_tables connection
69
+
70
+
let get_blob t cid : blob option Lwt.t =
71
+
let$! blob = Queries.get_blob t ~cid in
72
+
Lwt.return blob
73
+
74
+
let list_blobs t ~limit ~cursor : Cid.t list Lwt.t =
75
+
let$! blobs = Queries.list_blobs t ~limit ~cursor in
76
+
Lwt.return blobs
77
+
78
+
let write_blob t cid mimetype data : int Lwt.t =
79
+
let$! blob_id = Queries.write_blob t cid mimetype data in
80
+
Lwt.return blob_id
+3
pegasus/lib/util.ml
+3
pegasus/lib/util.ml