Source file repo.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
module type Sig = sig
val register_migration : unit -> unit
val register_cleaner : unit -> unit
val insert_file : file:Sihl.Contract.Storage.stored -> unit Lwt.t
val insert_blob : id:string -> blob:string -> unit Lwt.t
val get_file : id:string -> Sihl.Contract.Storage.stored option Lwt.t
val get_blob : id:string -> string option Lwt.t
val update_file : file:Sihl.Contract.Storage.stored -> unit Lwt.t
val update_blob : id:string -> blob:string -> unit Lwt.t
val delete_file : id:string -> unit Lwt.t
val delete_blob : id:string -> unit Lwt.t
end
module MakeMariaDb (MigrationService : Sihl.Contract.Migration.Sig) : Sig =
struct
let stored_file =
let encode m =
let open Sihl.Contract.Storage in
let { file; blob } = m in
let { id; filename; filesize; mime } = file in
Ok (id, (filename, (filesize, (mime, blob))))
in
let decode (id, (filename, (filesize, (mime, blob)))) =
let open Sihl.Contract.Storage in
let file = { id; filename; filesize; mime } in
Ok { file; blob }
in
Caqti_type.(
custom
~encode
~decode
Caqti_type.(tup2 string (tup2 string (tup2 int (tup2 string string)))))
;;
let insert_request =
Caqti_request.exec
stored_file
{sql|
INSERT INTO storage_handles (
uuid,
filename,
filesize,
mime,
asset_blob
) VALUES (
UNHEX(REPLACE(?, '-', '')),
?,
?,
?,
UNHEX(REPLACE(?, '-', ''))
)
|sql}
;;
let insert_file ~file = Sihl.Database.exec insert_request file
let update_file_request =
Caqti_request.exec
stored_file
{sql|
UPDATE storage_handles SET
filename = $2,
filesize = $3,
mime = $4,
asset_blob = UNHEX(REPLACE($5, '-', ''))
WHERE
storage_handles.uuid = UNHEX(REPLACE($1, '-', ''))
|sql}
;;
let update_file ~file = Sihl.Database.exec update_file_request file
let get_file_request =
Caqti_request.find_opt
Caqti_type.string
stored_file
{sql|
SELECT
LOWER(CONCAT(
SUBSTR(HEX(uuid), 1, 8), '-',
SUBSTR(HEX(uuid), 9, 4), '-',
SUBSTR(HEX(uuid), 13, 4), '-',
SUBSTR(HEX(uuid), 17, 4), '-',
SUBSTR(HEX(uuid), 21)
)),
filename,
filesize,
mime,
LOWER(CONCAT(
SUBSTR(HEX(asset_blob), 1, 8), '-',
SUBSTR(HEX(asset_blob), 9, 4), '-',
SUBSTR(HEX(asset_blob), 13, 4), '-',
SUBSTR(HEX(asset_blob), 17, 4), '-',
SUBSTR(HEX(asset_blob), 21)
))
FROM storage_handles
WHERE storage_handles.uuid = UNHEX(REPLACE(?, '-', ''))
|sql}
;;
let get_file ~id = Sihl.Database.find_opt get_file_request id
let delete_file_request =
Caqti_request.exec
Caqti_type.string
{sql|
DELETE FROM storage_handles
WHERE storage_handles.uuid = UNHEX(REPLACE(?, '-', ''))
|sql}
;;
let delete_file ~id = Sihl.Database.exec delete_file_request id
let get_blob_request =
Caqti_request.find_opt
Caqti_type.string
Caqti_type.string
{sql|
SELECT
asset_data
FROM storage_blobs
WHERE storage_blobs.uuid = UNHEX(REPLACE(?, '-', ''))
|sql}
;;
let get_blob ~id = Sihl.Database.find_opt get_blob_request id
let insert_blob_request =
Caqti_request.exec
Caqti_type.(tup2 string string)
{sql|
INSERT INTO storage_blobs (
uuid,
asset_data
) VALUES (
UNHEX(REPLACE(?, '-', '')),
?
)
|sql}
;;
let insert_blob ~id ~blob = Sihl.Database.exec insert_blob_request (id, blob)
let update_blob_request =
Caqti_request.exec
Caqti_type.(tup2 string string)
{sql|
UPDATE storage_blobs SET
asset_data = $2
WHERE
storage_blobs.uuid = UNHEX(REPLACE($1, '-', ''))
|sql}
;;
let update_blob ~id ~blob = Sihl.Database.exec update_blob_request (id, blob)
let delete_blob_request =
Caqti_request.exec
Caqti_type.string
{sql|
DELETE FROM storage_blobs
WHERE
storage_blobs.uuid = UNHEX(REPLACE(?, '-', ''))
|sql}
;;
let delete_blob ~id = Sihl.Database.exec delete_blob_request id
let clean_handles_request =
Caqti_request.exec Caqti_type.unit "TRUNCATE storage_handles;"
;;
let clean_handles () = Sihl.Database.exec clean_handles_request ()
let clean_blobs_request =
Caqti_request.exec Caqti_type.unit "TRUNCATE storage_blobs;"
;;
let clean_blobs () = Sihl.Database.exec clean_blobs_request ()
let fix_collation =
Sihl.Database.Migration.create_step
~label:"fix collation"
{sql|
SET collation_server = 'utf8mb4_unicode_ci';
|sql}
;;
let create_blobs_table =
Sihl.Database.Migration.create_step
~label:"create blobs table"
{sql|
CREATE TABLE IF NOT EXISTS storage_blobs (
id BIGINT UNSIGNED AUTO_INCREMENT,
uuid BINARY(16) NOT NULL,
asset_data MEDIUMBLOB NOT NULL,
created TIMESTAMP DEFAULT CURRENT_TIMESTAMP,
updated TIMESTAMP DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP,
PRIMARY KEY (id),
CONSTRAINT unique_uuid UNIQUE KEY (uuid)
) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci;
|sql}
;;
let create_handles_table =
Sihl.Database.Migration.create_step
~label:"create handles table"
{sql|
CREATE TABLE IF NOT EXISTS storage_handles (
id BIGINT UNSIGNED AUTO_INCREMENT,
uuid BINARY(16) NOT NULL,
filename VARCHAR(255) NOT NULL,
filesize BIGINT UNSIGNED,
mime VARCHAR(128) NOT NULL,
asset_blob BINARY(16) NOT NULL,
created TIMESTAMP DEFAULT CURRENT_TIMESTAMP,
updated TIMESTAMP DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP,
PRIMARY KEY (id),
CONSTRAINT unique_uuid UNIQUE KEY (uuid)
) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci;
|sql}
;;
let migration () =
Sihl.Database.Migration.(
empty "storage"
|> add_step fix_collation
|> add_step create_blobs_table
|> add_step create_handles_table)
;;
let register_migration () = MigrationService.register_migration (migration ())
let register_cleaner () =
let cleaner () =
let%lwt () = clean_handles () in
clean_blobs ()
in
Sihl.Cleaner.register_cleaner cleaner
;;
end