[OCaml] High Intensity Training Online
refactor Split persistence into its own layer
Extract the Repository adapters into a new hito.persistence library so the Dependency Rule at the persistence boundary holds by construction rather than by convention. Move Sqlite_repo, Memory_repo, Codec, Migrations, and Timestamp from lib/app to lib/persistence. hito.app now depends inward on hito.core only and names no database library, so the compiler forbids the Service from reaching Caqti. The adapters sit one layer out and implement the Repository port. One folder per Clean Architecture layer: core, app, persistence, web.
Changed files
- ARCHITECTURE.org
- bin/dune
- bin/main.ml
- dune
- lib/app/codec.ml
- lib/app/codec.mli
- lib/app/dune
- lib/app/memory_repo.ml
- lib/app/memory_repo.mli
- lib/app/migrations.ml
- lib/app/migrations.mli
- lib/app/sqlite_repo.ml
- lib/app/sqlite_repo.mli
- lib/app/timestamp.ml
- lib/app/timestamp.mli
- lib/persistence/codec.ml
- lib/persistence/codec.mli
- lib/persistence/dune
- lib/persistence/memory_repo.ml
- lib/persistence/memory_repo.mli
- lib/persistence/migrations.ml
- lib/persistence/migrations.mli
- lib/persistence/sqlite_repo.ml
- lib/persistence/sqlite_repo.mli
- lib/persistence/timestamp.ml
- lib/persistence/timestamp.mli
- test/dune
- test/test_codec.ml
- test/test_service.ml
- test/test_sqlite_repo.ml
- test/test_web.ml
ARCHITECTURE.org
@@ -139,19 +139,28 @@
139
139
140
140
* Layers
141
141
142
Removed:
Three libraries. Dependencies point inward only.
142
Added:
Four libraries. Dependencies point inward only.
143
143
144
144
#+begin_src
145
Removed:
hito.web Dream · dream-html · js_of_ocaml client
146
Removed:
| HTTP, HTML, sessions, CSRF, wall-clock time
145
Added:
hito.web Dream · dream-html · js_of_ocaml client
146
Added:
| HTTP, HTML, sessions, CSRF, wall-clock time
147
Added:
|
148
Added:
| hito.persistence Sqlite_repo · Memory_repo · Codec · Migrations
149
Added:
| | Caqti, the SQLite driver, stored-fact serialization
150
Added:
v v
151
Added:
hito.app Trainee · Repository (port) · Service · Catalog
152
Added:
| identity, the port, recovery policy, Lwt — no database
147
153
v
148
Removed:
hito.app Trainee · Repository (port) · Service · Catalog · Codec
149
Removed:
| identity, persistence, recovery policy, Lwt
150
Removed:
v
151
Removed:
hito.core Exercise · Recovery · Prescription · Evidence · Progression
152
Removed:
pure domain: no framework, no database, no serialization
154
Added:
hito.core Exercise · Recovery · Prescription · Evidence · Progression
155
Added:
pure domain: no framework, no database, no serialization
153
156
#+end_src
154
157
158
Added:
The use case (=hito.app=) depends inward on =hito.core= only. It names no
159
Added:
database library, so the Dependency Rule at the persistence boundary holds by
160
Added:
construction: the compiler forbids the =Service= from reaching Caqti. The
161
Added:
adapters live one layer out in =hito.persistence=, which depends on =hito.app=
162
Added:
and implements its =Repository= port.
163
Added:
155
164
The core is five modules, unwrapped (=wrapped false=), so they are referred to
156
165
bare: =Prescription.Stimulus=, =Evidence.Workout=, =Evidence.Log=. It has no
157
166
dependency on Lwt, Caqti, Dream, or any serializer, and gaining one would be a
@@ -249,7 +258,7 @@
249
258
| identity | =Repository=, =Trainee= | a plan needs a name only once something remembers |
250
259
| wall-clock time | =hito.web= (=Handlers=) | a pure domain cannot read a clock |
251
260
| untrusted forms | =hito.web= (=Decode=) | the core accepts trusted values |
252
Removed:
| stored text | =hito.app= (=Codec=) | opaque types carry no serializers |
261
Added:
| stored text | =hito.persistence= (=Codec=) | opaque types carry no serializers |
253
262
| recovery policy | =hito.app= (=Service=) | one policy, so no client can loosen it |
254
263
| persistence | =Repository= port + adapters | the domain must not know SQL exists |
255
264
| phrasing | =hito.web= (=Handlers.Present=) | wording is presentation, not domain |
bin/dune
@@ -1,4 +1,4 @@
1
1
(executable
2
2
(public_name hito)
3
3
(name main)
4
Removed:
(libraries hito.web hito.app dream lwt caqti))
4
Added:
(libraries hito.web hito.app hito.persistence dream lwt caqti))
bin/main.ml
@@ -20,8 +20,8 @@
20
20
the password from [HITO_SEED_PASSWORD]. Both are temporary until public
21
21
registration returns. *)
22
22
23
Removed:
module Handlers = Hito_web.Handlers.Make (Hito_app.Sqlite_repo)
24
Removed:
module Service = Hito_app.Service.Make (Hito_app.Sqlite_repo)
23
Added:
module Handlers = Hito_web.Handlers.Make (Hito_persistence.Sqlite_repo)
24
Added:
module Service = Hito_app.Service.Make (Hito_persistence.Sqlite_repo)
25
25
26
26
let getenv name default =
27
27
match Sys.getenv_opt name with Some v when v <> "" -> v | _ -> default
@@ -53,7 +53,7 @@
53
53
not survive a restart.";
54
54
Dream.to_base64url (Dream.random 32)
55
55
in
56
Removed:
match Lwt_main.run (Hito_app.Sqlite_repo.connect db_uri) with
56
Added:
match Lwt_main.run (Hito_persistence.Sqlite_repo.connect db_uri) with
57
57
| Error error ->
58
58
Printf.eprintf "hito: cannot open database %S: %s\n" db_uri
59
59
(Caqti_error.show error);
dune
@@ -1,4 +1,5 @@
1
1
; Keep local dev runtime data out of the build/watch tree. The dev server's
2
2
; SQLite database lives in local_db/; without this exclusion, each write
3
3
; retriggers `dune -w`, restarting the server in a loop.
4
Added:
4
5
(dirs :standard \ local_db local)
lib/app/codec.ml
@@ -1,382 +0,0 @@
1
Removed:
type error =
2
Removed:
| Malformed of string
3
Removed:
| Unknown_exercise of string
4
Removed:
| Unknown_routine of string
5
Removed:
| Unknown_workout_name of { routine : string; workout : string }
6
Removed:
| Replay_rejected of string
7
Removed:
8
Removed:
let pp_error ppf = function
9
Removed:
| Malformed detail -> Format.fprintf ppf "malformed record: %s" detail
10
Removed:
| Unknown_exercise id -> Format.fprintf ppf "unknown exercise %S" id
11
Removed:
| Unknown_routine name -> Format.fprintf ppf "unknown routine %S" name
12
Removed:
| Unknown_workout_name { routine; workout } ->
13
Removed:
Format.fprintf ppf "routine %S has no workout %S" routine workout
14
Removed:
| Replay_rejected detail ->
15
Removed:
Format.fprintf ppf "stored record rejected: %s" detail
16
Removed:
17
Removed:
(* --- extension and outcome codes --- *)
18
Removed:
19
Removed:
let extension_code : Evidence.Stimulus.extension -> string = function
20
Removed:
| Forced_reps -> "forced"
21
Removed:
| Negatives -> "negatives"
22
Removed:
| Rest_pause -> "rest-pause"
23
Removed:
| Static_hold -> "static"
24
Removed:
25
Removed:
let extension_of_code = function
26
Removed:
| "forced" -> Ok Evidence.Stimulus.Forced_reps
27
Removed:
| "negatives" -> Ok Evidence.Stimulus.Negatives
28
Removed:
| "rest-pause" -> Ok Evidence.Stimulus.Rest_pause
29
Removed:
| "static" -> Ok Evidence.Stimulus.Static_hold
30
Removed:
| other -> Error (Malformed (Printf.sprintf "extension %S" other))
31
Removed:
32
Removed:
let encode_outcome (outcome : Evidence.Stimulus.outcome) =
33
Removed:
match outcome with
34
Removed:
| Positive_failure -> "positive"
35
Removed:
| Beyond_failure (first, rest) ->
36
Removed:
"beyond:" ^ String.concat "," (List.map extension_code (first :: rest))
37
Removed:
38
Removed:
let decode_outcome text =
39
Removed:
if String.equal text "positive" then Ok Evidence.Stimulus.Positive_failure
40
Removed:
else
41
Removed:
match String.split_on_char ':' text with
42
Removed:
| [ "beyond"; codes ] -> (
43
Removed:
match String.split_on_char ',' codes with
44
Removed:
| [] | [ "" ] -> Error (Malformed "empty beyond-failure")
45
Removed:
| first :: rest ->
46
Removed:
let ( let* ) = Result.bind in
47
Removed:
let* first = extension_of_code first in
48
Removed:
let rec go acc = function
49
Removed:
| [] -> Ok (List.rev acc)
50
Removed:
| code :: tl -> (
51
Removed:
match extension_of_code code with
52
Removed:
| Ok e -> go (e :: acc) tl
53
Removed:
| Error _ as e -> e)
54
Removed:
in
55
Removed:
let* rest = go [] rest in
56
Removed:
Ok (Evidence.Stimulus.Beyond_failure (first, rest)))
57
Removed:
| _ -> Error (Malformed (Printf.sprintf "outcome %S" text))
58
Removed:
59
Removed:
(* --- efforts and stimuli --- *)
60
Removed:
61
Removed:
let encode_effort effort =
62
Removed:
let exercise = Evidence.Stimulus.Effort.exercise effort in
63
Removed:
Printf.sprintf "%s\t%h\t%d\t%s"
64
Removed:
(Exercise.id exercise :> string)
65
Removed:
(Evidence.Stimulus.Effort.load effort)
66
Removed:
(Evidence.Stimulus.Effort.reps effort)
67
Removed:
(encode_outcome (Evidence.Stimulus.Effort.outcome effort))
68
Removed:
69
Removed:
let encode_stimulus ~slot stimulus =
70
Removed:
match Evidence.Stimulus.delivery stimulus with
71
Removed:
| Evidence.Stimulus.Single effort ->
72
Removed:
Printf.sprintf "stimulus\t%d\tsingle\t%s" slot (encode_effort effort)
73
Removed:
| Evidence.Stimulus.Pair { first; second } ->
74
Removed:
Printf.sprintf "stimulus\t%d\tpair\t%s\t%s" slot (encode_effort first)
75
Removed:
(encode_effort second)
76
Removed:
77
Removed:
let ( let* ) = Result.bind
78
Removed:
79
Removed:
let decode_effort = function
80
Removed:
| [ exid; load; reps; outcome ] -> (
81
Removed:
match Exercise.find_id exid with
82
Removed:
| None -> Error (Unknown_exercise exid)
83
Removed:
| Some exercise -> (
84
Removed:
match (float_of_string_opt load, int_of_string_opt reps) with
85
Removed:
| Some load, Some reps ->
86
Removed:
let* outcome = decode_outcome outcome in
87
Removed:
Ok (Evidence.Stimulus.Effort.make ~exercise ~load ~reps ~outcome)
88
Removed:
| _ -> Error (Malformed "effort load/reps")))
89
Removed:
| _ -> Error (Malformed "effort arity")
90
Removed:
91
Removed:
(* Decode a stimulus and the slot it filled. The current format prefixes the
92
Removed:
slot; a record from before slots were stored omits it, and replays in
93
Removed:
performance order through [add_stimulus] instead. *)
94
Removed:
let decode_stimulus fields =
95
Removed:
let delivery = function
96
Removed:
| "single" :: rest ->
97
Removed:
let* effort = decode_effort rest in
98
Removed:
Ok (Evidence.Stimulus.make (Evidence.Stimulus.Single effort))
99
Removed:
| "pair" :: rest -> (
100
Removed:
match rest with
101
Removed:
| [ a; b; c; d; e; f; g; h ] ->
102
Removed:
let* first = decode_effort [ a; b; c; d ] in
103
Removed:
let* second = decode_effort [ e; f; g; h ] in
104
Removed:
Ok
105
Removed:
(Evidence.Stimulus.make
106
Removed:
(Evidence.Stimulus.Pair { first; second }))
107
Removed:
| _ -> Error (Malformed "pair arity"))
108
Removed:
| _ -> Error (Malformed "stimulus delivery")
109
Removed:
in
110
Removed:
match fields with
111
Removed:
| slot :: rest when Option.is_some (int_of_string_opt slot) ->
112
Removed:
let* stimulus = delivery rest in
113
Removed:
Ok (Some (Option.get (int_of_string_opt slot)), stimulus)
114
Removed:
| rest ->
115
Removed:
let* stimulus = delivery rest in
116
Removed:
Ok (None, stimulus)
117
Removed:
118
Removed:
(* --- clearance --- *)
119
Removed:
120
Removed:
let encode_clearance clearance =
121
Removed:
match Recovery.basis clearance with
122
Removed:
| Recovery.Recovered -> "clearance\trecovered"
123
Removed:
| Recovery.Overridden { rested; recommended } ->
124
Removed:
Printf.sprintf "clearance\toverridden\t%d\t%d"
125
Removed:
(Recovery.duration_to_seconds rested)
126
Removed:
(Recovery.duration_to_seconds recommended)
127
Removed:
128
Removed:
(* Recovery exposes only hours/days constructors, so derive an arbitrary
129
Removed:
second-valued duration through elapsed: since=0, now=secs yields exactly
130
Removed:
[secs] seconds. *)
131
Removed:
let seconds_duration secs =
132
Removed:
Recovery.elapsed
133
Removed:
~since:(Recovery.timestamp_of_unix_seconds 0)
134
Removed:
~now:(Recovery.timestamp_of_unix_seconds secs)
135
Removed:
136
Removed:
(* A clearance cannot be minted directly; it is derived from a readiness.
137
Removed:
[Recovered] comes from a [Ready] reading; an override needs a [Recovering]
138
Removed:
reading carrying the stored durations. *)
139
Removed:
let decode_clearance = function
140
Removed:
| [ "recovered" ] -> Ok (Option.get (Recovery.clear Recovery.Ready))
141
Removed:
| [ "overridden"; rested; recommended ] -> (
142
Removed:
match (int_of_string_opt rested, int_of_string_opt recommended) with
143
Removed:
| Some rested, Some recommended ->
144
Removed:
Ok
145
Removed:
(Recovery.override
146
Removed:
(Recovery.Recovering
147
Removed:
{
148
Removed:
rested = seconds_duration rested;
149
Removed:
recommended = seconds_duration recommended;
150
Removed:
}))
151
Removed:
| _ -> Error (Malformed "clearance durations"))
152
Removed:
| _ -> Error (Malformed "clearance basis")
153
Removed:
154
Removed:
(* --- workout --- *)
155
Removed:
156
Removed:
let encode_workout ~routine_name workout =
157
Removed:
let buf = Buffer.create 256 in
158
Removed:
let line s =
159
Removed:
Buffer.add_string buf s;
160
Removed:
Buffer.add_char buf '\n'
161
Removed:
in
162
Removed:
line (Printf.sprintf "routine\t%s" routine_name);
163
Removed:
line
164
Removed:
(Printf.sprintf "prescription\t%s"
165
Removed:
(Prescription.Workout.name (Evidence.Workout.prescription workout)));
166
Removed:
line (encode_clearance (Evidence.Workout.clearance workout));
167
Removed:
line
168
Removed:
(Printf.sprintf "started\t%s"
169
Removed:
(Timestamp.encode (Evidence.Workout.started_at workout)));
170
Removed:
(match Evidence.Workout.ended_at workout with
171
Removed:
| Some ended -> line (Printf.sprintf "ended\t%s" (Timestamp.encode ended))
172
Removed:
| None -> ());
173
Removed:
List.iter
174
Removed:
(fun (slot, stimulus) -> line (encode_stimulus ~slot stimulus))
175
Removed:
(Evidence.Workout.performed workout);
176
Removed:
Buffer.contents buf
177
Removed:
178
Removed:
(* A fully-parsed header, gathered before any replay. Parsing produces this
179
Removed:
typed record; replay consumes it. Keeping the two phases apart removes the
180
Removed:
mutable accumulators the old single pass needed. *)
181
Removed:
type parsed = {
182
Removed:
routine_name : string;
183
Removed:
prescription_name : string;
184
Removed:
clearance : Recovery.clearance;
185
Removed:
started_at : Recovery.timestamp;
186
Removed:
ended_at : Recovery.timestamp option;
187
Removed:
stimuli : (int option * Evidence.Stimulus.t) list;
188
Removed:
(** Performance order, each with the slot it filled when known. *)
189
Removed:
}
190
Removed:
191
Removed:
(* Fields accumulated while folding over lines; every field is optional until
192
Removed:
its line is seen. [stimuli] is reversed for O(1) prepend and flipped once at
193
Removed:
the end. *)
194
Removed:
type acc = {
195
Removed:
a_routine : string option;
196
Removed:
a_prescription : string option;
197
Removed:
a_clearance : Recovery.clearance option;
198
Removed:
a_started : Recovery.timestamp option;
199
Removed:
a_ended : Recovery.timestamp option;
200
Removed:
a_stimuli_rev : (int option * Evidence.Stimulus.t) list;
201
Removed:
}
202
Removed:
203
Removed:
let empty_acc =
204
Removed:
{
205
Removed:
a_routine = None;
206
Removed:
a_prescription = None;
207
Removed:
a_clearance = None;
208
Removed:
a_started = None;
209
Removed:
a_ended = None;
210
Removed:
a_stimuli_rev = [];
211
Removed:
}
212
Removed:
213
Removed:
let parse_timestamp label text =
214
Removed:
match Timestamp.decode text with
215
Removed:
| Ok timestamp -> Ok timestamp
216
Removed:
| Error _ -> Error (Malformed label)
217
Removed:
218
Removed:
(* Fold one line into the accumulator. A line either sets a header field or
219
Removed:
appends a stimulus; anything else is malformed. *)
220
Removed:
let step acc = function
221
Removed:
| [ "routine"; name ] -> Ok { acc with a_routine = Some name }
222
Removed:
| [ "prescription"; name ] -> Ok { acc with a_prescription = Some name }
223
Removed:
| "clearance" :: rest ->
224
Removed:
let* c = decode_clearance rest in
225
Removed:
Ok { acc with a_clearance = Some c }
226
Removed:
| [ "started"; text ] ->
227
Removed:
let* timestamp = parse_timestamp "started timestamp" text in
228
Removed:
Ok { acc with a_started = Some timestamp }
229
Removed:
| [ "ended"; text ] ->
230
Removed:
let* timestamp = parse_timestamp "ended timestamp" text in
231
Removed:
Ok { acc with a_ended = Some timestamp }
232
Removed:
| "stimulus" :: rest ->
233
Removed:
let* s = decode_stimulus rest in
234
Removed:
Ok { acc with a_stimuli_rev = s :: acc.a_stimuli_rev }
235
Removed:
| fields -> Error (Malformed (String.concat "|" fields))
236
Removed:
237
Removed:
(* Parse the whole text into a typed header, or fail. Mandatory fields are
238
Removed:
checked here so replay never sees a partial record. *)
239
Removed:
let parse text =
240
Removed:
let lines =
241
Removed:
String.split_on_char '\n' text
242
Removed:
|> List.filter (fun l -> String.length l > 0)
243
Removed:
|> List.map (fun l -> String.split_on_char '\t' l)
244
Removed:
in
245
Removed:
let rec fold acc = function
246
Removed:
| [] -> Ok acc
247
Removed:
| line :: tl ->
248
Removed:
let* acc = step acc line in
249
Removed:
fold acc tl
250
Removed:
in
251
Removed:
let* acc = fold empty_acc lines in
252
Removed:
match (acc.a_routine, acc.a_prescription, acc.a_clearance, acc.a_started) with
253
Removed:
| Some routine_name, Some prescription_name, Some clearance, Some started_at
254
Removed:
->
255
Removed:
Ok
256
Removed:
{
257
Removed:
routine_name;
258
Removed:
prescription_name;
259
Removed:
clearance;
260
Removed:
started_at;
261
Removed:
ended_at = acc.a_ended;
262
Removed:
stimuli = List.rev acc.a_stimuli_rev;
263
Removed:
}
264
Removed:
| _ -> Error (Malformed "missing header fields")
265
Removed:
266
Removed:
(* Resolve the prescription named in the header against the catalog. *)
267
Removed:
let resolve_prescription ~find_routine parsed =
268
Removed:
match find_routine parsed.routine_name with
269
Removed:
| None -> Error (Unknown_routine parsed.routine_name)
270
Removed:
| Some routine -> (
271
Removed:
match
272
Removed:
List.find_opt
273
Removed:
(fun w ->
274
Removed:
String.equal (Prescription.Workout.name w) parsed.prescription_name)
275
Removed:
(Prescription.Routine.workouts routine)
276
Removed:
with
277
Removed:
| Some prescription -> Ok prescription
278
Removed:
| None ->
279
Removed:
Error
280
Removed:
(Unknown_workout_name
281
Removed:
{
282
Removed:
routine = parsed.routine_name;
283
Removed:
workout = parsed.prescription_name;
284
Removed:
}))
285
Removed:
286
Removed:
(* Drive the core constructors from a typed header. The core raises on a
287
Removed:
rejected stimulus; catch it once here and report it as data corruption. *)
288
Removed:
let replay ~prescription parsed =
289
Removed:
try
290
Removed:
let workout =
291
Removed:
Evidence.Workout.start prescription ~clearance:parsed.clearance
292
Removed:
~started_at:parsed.started_at
293
Removed:
in
294
Removed:
let workout =
295
Removed:
List.fold_left
296
Removed:
(fun workout (slot, stimulus) ->
297
Removed:
match slot with
298
Removed:
| Some slot -> Evidence.Workout.record_at workout ~slot stimulus
299
Removed:
| None -> Evidence.Workout.add_stimulus workout stimulus)
300
Removed:
workout parsed.stimuli
301
Removed:
in
302
Removed:
let workout =
303
Removed:
match parsed.ended_at with
304
Removed:
| Some ended_at -> Evidence.Workout.finish workout ~ended_at
305
Removed:
| None -> workout
306
Removed:
in
307
Removed:
Ok workout
308
Removed:
with Evidence.Workout.Invalid err ->
309
Removed:
Error (Replay_rejected (Format.asprintf "%a" Evidence.Workout.pp_error err))
310
Removed:
311
Removed:
let decode_workout ~find_routine text =
312
Removed:
let* parsed = parse text in
313
Removed:
let* prescription = resolve_prescription ~find_routine parsed in
314
Removed:
replay ~prescription parsed
315
Removed:
316
Removed:
(* --- subjective feedback --- *)
317
Removed:
318
Removed:
let level_code (l : Evidence.Feedback.level) =
319
Removed:
string_of_int (Evidence.Feedback.level_to_score l)
320
Removed:
321
Removed:
let level_of_code code =
322
Removed:
match int_of_string_opt code with
323
Removed:
| Some n -> (
324
Removed:
match Evidence.Feedback.level_of_score n with
325
Removed:
| Some l -> Ok l
326
Removed:
| None -> Error (Malformed (Printf.sprintf "level %S" code)))
327
Removed:
| None -> Error (Malformed (Printf.sprintf "level %S" code))
328
Removed:
329
Removed:
let signal_code : Evidence.Feedback.signal -> string = function
330
Removed:
| Sleep l -> "sleep:" ^ level_code l
331
Removed:
| Appetite l -> "appetite:" ^ level_code l
332
Removed:
| Readiness l -> "readiness:" ^ level_code l
333
Removed:
| Motivation l -> "motivation:" ^ level_code l
334
Removed:
| Difficulty l -> "difficulty:" ^ level_code l
335
Removed:
| Pain -> "pain"
336
Removed:
| Injury -> "injury"
337
Removed:
| Preparation_insufficient -> "preparation-insufficient"
338
Removed:
339
Removed:
let signal_of_code code =
340
Removed:
let leveled make rest =
341
Removed:
let* l = level_of_code rest in
342
Removed:
Ok (make l)
343
Removed:
in
344
Removed:
match String.split_on_char ':' code with
345
Removed:
| [ "sleep"; l ] -> leveled (fun l -> Evidence.Feedback.Sleep l) l
346
Removed:
| [ "appetite"; l ] -> leveled (fun l -> Evidence.Feedback.Appetite l) l
347
Removed:
| [ "readiness"; l ] -> leveled (fun l -> Evidence.Feedback.Readiness l) l
348
Removed:
| [ "motivation"; l ] -> leveled (fun l -> Evidence.Feedback.Motivation l) l
349
Removed:
| [ "difficulty"; l ] -> leveled (fun l -> Evidence.Feedback.Difficulty l) l
350
Removed:
| [ "pain" ] -> Ok Evidence.Feedback.Pain
351
Removed:
| [ "injury" ] -> Ok Evidence.Feedback.Injury
352
Removed:
| [ "preparation-insufficient" ] ->
353
Removed:
Ok Evidence.Feedback.Preparation_insufficient
354
Removed:
| _ -> Error (Malformed (Printf.sprintf "signal %S" code))
355
Removed:
356
Removed:
let encode_feedback report =
357
Removed:
let reported_at = Timestamp.encode (Evidence.Feedback.reported_at report) in
358
Removed:
let signals =
359
Removed:
String.concat "," (List.map signal_code (Evidence.Feedback.signals report))
360
Removed:
in
361
Removed:
Printf.sprintf "%s\t%s" reported_at signals
362
Removed:
363
Removed:
let decode_feedback text =
364
Removed:
match String.split_on_char '\t' text with
365
Removed:
| [ timestamp; signals ] -> (
366
Removed:
match Timestamp.decode timestamp with
367
Removed:
| Error _ -> Error (Malformed "feedback timestamp")
368
Removed:
| Ok reported_at ->
369
Removed:
let codes =
370
Removed:
String.split_on_char ',' signals
371
Removed:
|> List.filter (fun s -> String.length s > 0)
372
Removed:
in
373
Removed:
let rec go acc = function
374
Removed:
| [] -> Ok (List.rev acc)
375
Removed:
| code :: tl -> (
376
Removed:
match signal_of_code code with
377
Removed:
| Ok s -> go (s :: acc) tl
378
Removed:
| Error _ as e -> e)
379
Removed:
in
380
Removed:
let* signals = go [] codes in
381
Removed:
Ok (Evidence.Feedback.make ~reported_at signals))
382
Removed:
| _ -> Error (Malformed "feedback arity")
lib/app/codec.mli
@@ -1,38 +0,0 @@
1
Removed:
(** Serialization of performed facts, and their replay through the core.
2
Removed:
3
Removed:
The core types are opaque and carry no serializers, by design: the logbook
4
Removed:
records, it never interprets. This module is the trust boundary for stored
5
Removed:
data. It captures only what was performed — exercise, load, reps, outcome,
6
Removed:
timestamps, and the basis on which a workout was begun — and rebuilds a
7
Removed:
{!Evidence.Workout.t} by driving the same constructors a live session does.
8
Removed:
9
Removed:
A workout's prescription is not stored. It is found again by name in the
10
Removed:
routine catalog, so a stored workout stays valid only as long as its routine
11
Removed:
and workout names do. That is the intended coupling: prescriptions are
12
Removed:
authored, not recorded. *)
13
Removed:
14
Removed:
type error =
15
Removed:
| Malformed of string (** The stored text does not parse. *)
16
Removed:
| Unknown_exercise of string
17
Removed:
| Unknown_routine of string
18
Removed:
| Unknown_workout_name of { routine : string; workout : string }
19
Removed:
| Replay_rejected of string
20
Removed:
(** The core refused a stored stimulus; the store is inconsistent. *)
21
Removed:
22
Removed:
val pp_error : Format.formatter -> error -> unit
23
Removed:
24
Removed:
val encode_workout : routine_name:string -> Evidence.Workout.t -> string
25
Removed:
(** A stable, single-string encoding of a performed or in-progress workout.
26
Removed:
[routine_name] identifies the catalog routine the prescription came from. *)
27
Removed:
28
Removed:
val decode_workout :
29
Removed:
find_routine:(string -> Prescription.Routine.t option) ->
30
Removed:
string ->
31
Removed:
(Evidence.Workout.t, error) result
32
Removed:
(** Rebuilds a workout, resolving its prescription through [find_routine]. *)
33
Removed:
34
Removed:
val encode_feedback : Evidence.Feedback.t -> string
35
Removed:
(** A stable, single-string encoding of a subjective feedback report. *)
36
Removed:
37
Removed:
val decode_feedback : string -> (Evidence.Feedback.t, error) result
38
Removed:
(** Rebuilds a feedback report from its encoding. *)
lib/app/dune
@@ -1,12 +1,9 @@
1
Added:
; The use-case layer: entities' identity, the Repository port, the Service, and
2
Added:
; the shared Catalog. It depends inward on hito.core only — no database, no web
3
Added:
; framework — so the compiler forbids the Service from reaching an adapter.
4
Added:
; safepass stays only until password hashing moves behind a port.
5
Added:
1
6
(library
2
7
(name hito_app)
3
8
(public_name hito.app)
4
Removed:
(libraries
5
Removed:
hito.core
6
Removed:
lwt
7
Removed:
caqti
8
Removed:
caqti-lwt
9
Removed:
caqti-lwt.unix
10
Removed:
caqti-driver-sqlite3
11
Removed:
safepass
12
Removed:
uri))
9
Added:
(libraries hito.core lwt unix safepass))
lib/app/memory_repo.ml
@@ -1,399 +0,0 @@
1
Removed:
(* Per-trainee mutable state, held in a hashtable keyed by trainee id. *)
2
Removed:
type trainee_state = {
3
Removed:
mutable active : Repository.routine_id option;
4
Removed:
mutable current : Evidence.Workout.t option;
5
Removed:
mutable stored : Repository.record list; (* most recent first *)
6
Removed:
mutable feedback : Evidence.Feedback.t list; (* most recent first *)
7
Removed:
mutable next_id : int;
8
Removed:
mutable next_app_feedback : int;
9
Removed:
}
10
Removed:
11
Removed:
type t = {
12
Removed:
mutable trainees : Trainee.t list;
13
Removed:
states : (string, trainee_state) Hashtbl.t;
14
Removed:
mutable app_feedback : (Trainee.id * Repository.app_feedback) list;
15
Removed:
mutable app_feedback_votes : (Repository.app_feedback_id * Trainee.id) list;
16
Removed:
mutable next_trainee : int;
17
Removed:
}
18
Removed:
19
Removed:
let create () =
20
Removed:
{
21
Removed:
trainees = [];
22
Removed:
states = Hashtbl.create 16;
23
Removed:
app_feedback = [];
24
Removed:
app_feedback_votes = [];
25
Removed:
next_trainee = 1;
26
Removed:
}
27
Removed:
28
Removed:
let state t id =
29
Removed:
let key = Trainee.id_to_string id in
30
Removed:
match Hashtbl.find_opt t.states key with
31
Removed:
| Some s -> s
32
Removed:
| None ->
33
Removed:
let s =
34
Removed:
{
35
Removed:
active = None;
36
Removed:
current = None;
37
Removed:
stored = [];
38
Removed:
feedback = [];
39
Removed:
next_id = 1;
40
Removed:
next_app_feedback = 1;
41
Removed:
}
42
Removed:
in
43
Removed:
Hashtbl.replace t.states key s;
44
Removed:
s
45
Removed:
46
Removed:
let create_trainee t ~(username : Trainee.username) ~credential =
47
Removed:
match
48
Removed:
List.find_opt
49
Removed:
(fun (tr : Trainee.t) ->
50
Removed:
String.equal
51
Removed:
(Trainee.username_to_string tr.username)
52
Removed:
(Trainee.username_to_string username))
53
Removed:
t.trainees
54
Removed:
with
55
Removed:
| Some _ -> Lwt.return (Error `Username_taken)
56
Removed:
| None ->
57
Removed:
let id = Trainee.id (Printf.sprintf "t%d" t.next_trainee) in
58
Removed:
t.next_trainee <- t.next_trainee + 1;
59
Removed:
let trainee = { Trainee.id; username; credential } in
60
Removed:
t.trainees <- trainee :: t.trainees;
61
Removed:
Lwt.return (Ok trainee)
62
Removed:
63
Removed:
let find_trainee_by_username t (username : Trainee.username) =
64
Removed:
Lwt.return
65
Removed:
(List.find_opt
66
Removed:
(fun (tr : Trainee.t) ->
67
Removed:
String.equal
68
Removed:
(Trainee.username_to_string tr.username)
69
Removed:
(Trainee.username_to_string username))
70
Removed:
t.trainees)
71
Removed:
72
Removed:
let find_trainee t id =
73
Removed:
Lwt.return
74
Removed:
(List.find_opt
75
Removed:
(fun (tr : Trainee.t) ->
76
Removed:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
77
Removed:
t.trainees)
78
Removed:
79
Removed:
let replace_trainee t (updated : Trainee.t) =
80
Removed:
t.trainees <-
81
Removed:
List.map
82
Removed:
(fun (tr : Trainee.t) ->
83
Removed:
if
84
Removed:
String.equal
85
Removed:
(Trainee.id_to_string tr.id)
86
Removed:
(Trainee.id_to_string updated.id)
87
Removed:
then updated
88
Removed:
else tr)
89
Removed:
t.trainees
90
Removed:
91
Removed:
let update_username t id (username : Trainee.username) =
92
Removed:
match
93
Removed:
List.find_opt
94
Removed:
(fun (tr : Trainee.t) ->
95
Removed:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
96
Removed:
t.trainees
97
Removed:
with
98
Removed:
| None -> Lwt.return (Error `Username_taken)
99
Removed:
| Some current ->
100
Removed:
let taken =
101
Removed:
List.exists
102
Removed:
(fun (tr : Trainee.t) ->
103
Removed:
(not
104
Removed:
(String.equal
105
Removed:
(Trainee.id_to_string tr.id)
106
Removed:
(Trainee.id_to_string id)))
107
Removed:
&& String.equal
108
Removed:
(Trainee.username_to_string tr.username)
109
Removed:
(Trainee.username_to_string username))
110
Removed:
t.trainees
111
Removed:
in
112
Removed:
if taken then Lwt.return (Error `Username_taken)
113
Removed:
else begin
114
Removed:
let updated = { current with Trainee.username } in
115
Removed:
replace_trainee t updated;
116
Removed:
Lwt.return (Ok updated)
117
Removed:
end
118
Removed:
119
Removed:
let update_credential t id credential =
120
Removed:
match
121
Removed:
List.find_opt
122
Removed:
(fun (tr : Trainee.t) ->
123
Removed:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
124
Removed:
t.trainees
125
Removed:
with
126
Removed:
| None -> Lwt.return None
127
Removed:
| Some current ->
128
Removed:
let updated = { current with Trainee.credential } in
129
Removed:
replace_trainee t updated;
130
Removed:
Lwt.return (Some updated)
131
Removed:
132
Removed:
let list_routines _ = Catalog.routines
133
Removed:
let find_routine _ id = Catalog.find id
134
Removed:
let active_routine t id = Lwt.return (state t id).active
135
Removed:
136
Removed:
let set_active_routine t id routine =
137
Removed:
(state t id).active <- Some routine;
138
Removed:
Lwt.return_unit
139
Removed:
140
Removed:
let in_progress t id = Lwt.return (state t id).current
141
Removed:
142
Removed:
let set_in_progress t id workout =
143
Removed:
(state t id).current <- workout;
144
Removed:
Lwt.return_unit
145
Removed:
146
Removed:
(* Store the finished workout and clear the in-progress slot together. In
147
Removed:
memory this is a single synchronous update, so it cannot tear. *)
148
Removed:
let finish_workout t id workout =
149
Removed:
let s = state t id in
150
Removed:
let wid = Repository.workout_id (Printf.sprintf "w%d" s.next_id) in
151
Removed:
let record = { Repository.id = wid; workout } in
152
Removed:
s.next_id <- s.next_id + 1;
153
Removed:
s.stored <- record :: s.stored;
154
Removed:
s.current <- None;
155
Removed:
Lwt.return record
156
Removed:
157
Removed:
let equal_id (a : Repository.workout_id) (b : Repository.workout_id) =
158
Removed:
String.equal (a :> string) (b :> string)
159
Removed:
160
Removed:
let find t id wid =
161
Removed:
let s = state t id in
162
Removed:
Lwt.return (List.find_opt (fun r -> equal_id r.Repository.id wid) s.stored)
163
Removed:
164
Removed:
let replace t id record =
165
Removed:
let s = state t id in
166
Removed:
if
167
Removed:
not
168
Removed:
(List.exists
169
Removed:
(fun r -> equal_id r.Repository.id record.Repository.id)
170
Removed:
s.stored)
171
Removed:
then Lwt.return false
172
Removed:
else begin
173
Removed:
s.stored <-
174
Removed:
List.map
175
Removed:
(fun existing ->
176
Removed:
if equal_id existing.Repository.id record.Repository.id then record
177
Removed:
else existing)
178
Removed:
s.stored;
179
Removed:
Lwt.return true
180
Removed:
end
181
Removed:
182
Removed:
let log t id =
183
Removed:
let s = state t id in
184
Removed:
Lwt.return
185
Removed:
(List.fold_left
186
Removed:
(fun log record -> Evidence.Log.add log record.Repository.workout)
187
Removed:
Evidence.Log.empty (List.rev s.stored))
188
Removed:
189
Removed:
let history t id = Lwt.return (state t id).stored
190
Removed:
191
Removed:
let save_feedback t id report =
192
Removed:
let s = state t id in
193
Removed:
s.feedback <- report :: s.feedback;
194
Removed:
Lwt.return_unit
195
Removed:
196
Removed:
let feedback t id = Lwt.return (state t id).feedback
197
Removed:
198
Removed:
let save_app_feedback t id ~submitted_at ~message =
199
Removed:
let author =
200
Removed:
match
201
Removed:
List.find_opt
202
Removed:
(fun (trainee : Trainee.t) ->
203
Removed:
String.equal
204
Removed:
(Trainee.id_to_string trainee.id)
205
Removed:
(Trainee.id_to_string id))
206
Removed:
t.trainees
207
Removed:
with
208
Removed:
| Some trainee -> Trainee.username_to_string trainee.username
209
Removed:
| None -> ""
210
Removed:
in
211
Removed:
let contributions =
212
Removed:
1
213
Removed:
+ List.fold_left
214
Removed:
(fun count (owner, _) ->
215
Removed:
if String.equal (Trainee.id_to_string owner) (Trainee.id_to_string id)
216
Removed:
then count + 1
217
Removed:
else count)
218
Removed:
0 t.app_feedback
219
Removed:
in
220
Removed:
let s = state t id in
221
Removed:
let feedback_id =
222
Removed:
Repository.app_feedback_id
223
Removed:
(Printf.sprintf "%s:%d" (Trainee.id_to_string id) s.next_app_feedback)
224
Removed:
in
225
Removed:
s.next_app_feedback <- s.next_app_feedback + 1;
226
Removed:
let report =
227
Removed:
Repository.
228
Removed:
{
229
Removed:
feedback_id;
230
Removed:
author;
231
Removed:
contributions;
232
Removed:
submitted_at;
233
Removed:
message;
234
Removed:
upvotes = 0;
235
Removed:
viewer_upvoted = false;
236
Removed:
viewer_owns = true;
237
Removed:
}
238
Removed:
in
239
Removed:
t.app_feedback <- (id, report) :: t.app_feedback;
240
Removed:
Lwt.return report
241
Removed:
242
Removed:
let app_feedback_id_parts report =
243
Removed:
let raw =
244
Removed:
Repository.app_feedback_id_to_string report.Repository.feedback_id
245
Removed:
in
246
Removed:
match String.rindex_opt raw ':' with
247
Removed:
| None -> (raw, 0)
248
Removed:
| Some separator ->
249
Removed:
let owner = String.sub raw 0 separator in
250
Removed:
let sequence =
251
Removed:
String.sub raw (separator + 1) (String.length raw - separator - 1)
252
Removed:
|> int_of_string_opt |> Option.value ~default:0
253
Removed:
in
254
Removed:
(owner, sequence)
255
Removed:
256
Removed:
let app_feedback t ~viewer =
257
Removed:
let reports =
258
Removed:
List.map
259
Removed:
(fun (owner, report) ->
260
Removed:
let owner_id = Trainee.id_to_string owner in
261
Removed:
let contributions =
262
Removed:
List.fold_left
263
Removed:
(fun count (candidate, _) ->
264
Removed:
if String.equal owner_id (Trainee.id_to_string candidate) then
265
Removed:
count + 1
266
Removed:
else count)
267
Removed:
0 t.app_feedback
268
Removed:
in
269
Removed:
let author =
270
Removed:
match
271
Removed:
List.find_opt
272
Removed:
(fun (trainee : Trainee.t) ->
273
Removed:
String.equal owner_id (Trainee.id_to_string trainee.id))
274
Removed:
t.trainees
275
Removed:
with
276
Removed:
| Some trainee -> Trainee.username_to_string trainee.username
277
Removed:
| None -> report.Repository.author
278
Removed:
in
279
Removed:
let viewer_upvoted =
280
Removed:
List.exists
281
Removed:
(fun (feedback_id, voter) ->
282
Removed:
String.equal
283
Removed:
(Repository.app_feedback_id_to_string feedback_id)
284
Removed:
(Repository.app_feedback_id_to_string
285
Removed:
report.Repository.feedback_id)
286
Removed:
&& String.equal
287
Removed:
(Trainee.id_to_string voter)
288
Removed:
(Trainee.id_to_string viewer))
289
Removed:
t.app_feedback_votes
290
Removed:
in
291
Removed:
let viewer_owns = String.equal owner_id (Trainee.id_to_string viewer) in
292
Removed:
{ report with author; contributions; viewer_upvoted; viewer_owns })
293
Removed:
t.app_feedback
294
Removed:
in
295
Removed:
let compare left right =
296
Removed:
let by_votes =
297
Removed:
Int.compare right.Repository.upvotes left.Repository.upvotes
298
Removed:
in
299
Removed:
if by_votes <> 0 then by_votes
300
Removed:
else
301
Removed:
let by_time =
302
Removed:
Int.compare
303
Removed:
(Recovery.timestamp_to_unix_seconds right.submitted_at)
304
Removed:
(Recovery.timestamp_to_unix_seconds left.submitted_at)
305
Removed:
in
306
Removed:
if by_time <> 0 then by_time
307
Removed:
else
308
Removed:
let left_owner, left_sequence = app_feedback_id_parts left in
309
Removed:
let right_owner, right_sequence = app_feedback_id_parts right in
310
Removed:
let by_owner = String.compare left_owner right_owner in
311
Removed:
if by_owner <> 0 then by_owner
312
Removed:
else Int.compare right_sequence left_sequence
313
Removed:
in
314
Removed:
Lwt.return (List.sort compare reports)
315
Removed:
316
Removed:
let upvote_app_feedback t ~voter feedback_id =
317
Removed:
match
318
Removed:
List.find_opt
319
Removed:
(fun (_, report) ->
320
Removed:
String.equal
321
Removed:
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
322
Removed:
(Repository.app_feedback_id_to_string feedback_id))
323
Removed:
t.app_feedback
324
Removed:
with
325
Removed:
| None -> Lwt.return false
326
Removed:
| Some (owner, _)
327
Removed:
when String.equal (Trainee.id_to_string owner) (Trainee.id_to_string voter)
328
Removed:
->
329
Removed:
Lwt.return false
330
Removed:
| Some (_, report) ->
331
Removed:
if
332
Removed:
List.exists
333
Removed:
(fun (voted_feedback, existing_voter) ->
334
Removed:
String.equal
335
Removed:
(Repository.app_feedback_id_to_string voted_feedback)
336
Removed:
(Repository.app_feedback_id_to_string feedback_id)
337
Removed:
&& String.equal
338
Removed:
(Trainee.id_to_string existing_voter)
339
Removed:
(Trainee.id_to_string voter))
340
Removed:
t.app_feedback_votes
341
Removed:
then Lwt.return false
342
Removed:
else begin
343
Removed:
t.app_feedback_votes <- (feedback_id, voter) :: t.app_feedback_votes;
344
Removed:
t.app_feedback <-
345
Removed:
List.map
346
Removed:
(fun (owner, current) ->
347
Removed:
if
348
Removed:
String.equal
349
Removed:
(Repository.app_feedback_id_to_string
350
Removed:
current.Repository.feedback_id)
351
Removed:
(Repository.app_feedback_id_to_string
352
Removed:
report.Repository.feedback_id)
353
Removed:
then (owner, { current with upvotes = current.upvotes + 1 })
354
Removed:
else (owner, current))
355
Removed:
t.app_feedback;
356
Removed:
Lwt.return true
357
Removed:
end
358
Removed:
359
Removed:
let update_app_feedback t ~author id ~message =
360
Removed:
let author_id = Trainee.id_to_string author in
361
Removed:
let updated = ref false in
362
Removed:
t.app_feedback <-
363
Removed:
List.map
364
Removed:
(fun (owner, report) ->
365
Removed:
if
366
Removed:
String.equal (Trainee.id_to_string owner) author_id
367
Removed:
&& String.equal
368
Removed:
(Repository.app_feedback_id_to_string
369
Removed:
report.Repository.feedback_id)
370
Removed:
(Repository.app_feedback_id_to_string id)
371
Removed:
then begin
372
Removed:
updated := true;
373
Removed:
(owner, { report with message })
374
Removed:
end
375
Removed:
else (owner, report))
376
Removed:
t.app_feedback;
377
Removed:
Lwt.return !updated
378
Removed:
379
Removed:
let delete_app_feedback t ~author id =
380
Removed:
let author_id = Trainee.id_to_string author in
381
Removed:
let owned (owner, report) =
382
Removed:
String.equal (Trainee.id_to_string owner) author_id
383
Removed:
&& String.equal
384
Removed:
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
385
Removed:
(Repository.app_feedback_id_to_string id)
386
Removed:
in
387
Removed:
let removed = List.exists owned t.app_feedback in
388
Removed:
if removed then begin
389
Removed:
t.app_feedback <- List.filter (fun item -> not (owned item)) t.app_feedback;
390
Removed:
t.app_feedback_votes <-
391
Removed:
List.filter
392
Removed:
(fun (feedback_id, _) ->
393
Removed:
not
394
Removed:
(String.equal
395
Removed:
(Repository.app_feedback_id_to_string feedback_id)
396
Removed:
(Repository.app_feedback_id_to_string id)))
397
Removed:
t.app_feedback_votes
398
Removed:
end;
399
Removed:
Lwt.return removed
lib/app/memory_repo.mli
@@ -1,7 +0,0 @@
1
Removed:
(** In-memory {!Repository.S} for tests. Nothing survives a restart, and it is
2
Removed:
never used in production — durable storage is {!Sqlite_repo}. *)
3
Removed:
4
Removed:
include Repository.S
5
Removed:
6
Removed:
val create : unit -> t
7
Removed:
(** Seeded with the shared routine catalog. *)
lib/app/migrations.ml
@@ -1,231 +0,0 @@
1
Removed:
type migration = { version : int; name : string; statements : string list }
2
Removed:
3
Removed:
let migrations =
4
Removed:
[
5
Removed:
{
6
Removed:
version = 1;
7
Removed:
name = "initial schema";
8
Removed:
statements =
9
Removed:
[
10
Removed:
{|CREATE TABLE IF NOT EXISTS trainee (
11
Removed:
id TEXT PRIMARY KEY,
12
Removed:
username TEXT NOT NULL UNIQUE,
13
Removed:
credential TEXT NOT NULL
14
Removed:
)|};
15
Removed:
{|CREATE TABLE IF NOT EXISTS active_routine (
16
Removed:
trainee_id TEXT PRIMARY KEY,
17
Removed:
routine_id TEXT NOT NULL
18
Removed:
)|};
19
Removed:
{|CREATE TABLE IF NOT EXISTS in_progress (
20
Removed:
trainee_id TEXT PRIMARY KEY,
21
Removed:
encoded TEXT NOT NULL
22
Removed:
)|};
23
Removed:
{|CREATE TABLE IF NOT EXISTS workout (
24
Removed:
id TEXT PRIMARY KEY,
25
Removed:
trainee_id TEXT NOT NULL,
26
Removed:
seq INTEGER NOT NULL,
27
Removed:
encoded TEXT NOT NULL
28
Removed:
)|};
29
Removed:
{|CREATE INDEX IF NOT EXISTS workout_by_trainee
30
Removed:
ON workout (trainee_id, seq DESC)|};
31
Removed:
(* The table Dream's sql_sessions back end expects. *)
32
Removed:
{|CREATE TABLE IF NOT EXISTS dream_session (
33
Removed:
id TEXT PRIMARY KEY,
34
Removed:
label TEXT NOT NULL,
35
Removed:
expires_at REAL NOT NULL,
36
Removed:
payload TEXT NOT NULL
37
Removed:
)|};
38
Removed:
];
39
Removed:
};
40
Removed:
{
41
Removed:
version = 2;
42
Removed:
name = "subjective feedback";
43
Removed:
statements =
44
Removed:
[
45
Removed:
{|CREATE TABLE IF NOT EXISTS feedback (
46
Removed:
trainee_id TEXT NOT NULL,
47
Removed:
seq INTEGER NOT NULL,
48
Removed:
encoded TEXT NOT NULL,
49
Removed:
PRIMARY KEY (trainee_id, seq)
50
Removed:
)|};
51
Removed:
{|CREATE INDEX IF NOT EXISTS feedback_by_trainee
52
Removed:
ON feedback (trainee_id, seq DESC)|};
53
Removed:
];
54
Removed:
};
55
Removed:
{
56
Removed:
version = 3;
57
Removed:
name = "application feedback";
58
Removed:
statements =
59
Removed:
[
60
Removed:
{|CREATE TABLE IF NOT EXISTS app_feedback (
61
Removed:
trainee_id TEXT NOT NULL,
62
Removed:
seq INTEGER NOT NULL,
63
Removed:
submitted_at TEXT NOT NULL,
64
Removed:
message TEXT NOT NULL,
65
Removed:
PRIMARY KEY (trainee_id, seq)
66
Removed:
)|};
67
Removed:
{|CREATE INDEX IF NOT EXISTS app_feedback_by_trainee
68
Removed:
ON app_feedback (trainee_id, seq DESC)|};
69
Removed:
];
70
Removed:
};
71
Removed:
{
72
Removed:
version = 4;
73
Removed:
name = "application feedback votes";
74
Removed:
statements =
75
Removed:
[
76
Removed:
{|CREATE TABLE IF NOT EXISTS app_feedback_vote (
77
Removed:
feedback_trainee_id TEXT NOT NULL,
78
Removed:
feedback_seq INTEGER NOT NULL,
79
Removed:
voter_id TEXT NOT NULL,
80
Removed:
PRIMARY KEY (feedback_trainee_id, feedback_seq, voter_id)
81
Removed:
)|};
82
Removed:
{|CREATE INDEX IF NOT EXISTS app_feedback_vote_by_voter
83
Removed:
ON app_feedback_vote (voter_id)|};
84
Removed:
];
85
Removed:
};
86
Removed:
{
87
Removed:
version = 5;
88
Removed:
name = "ISO 8601 UTC timestamps";
89
Removed:
statements =
90
Removed:
[
91
Removed:
{|DROP TABLE IF EXISTS app_feedback_vote|};
92
Removed:
{|DROP TABLE IF EXISTS app_feedback|};
93
Removed:
{|DROP TABLE IF EXISTS feedback|};
94
Removed:
{|DROP TABLE IF EXISTS workout|};
95
Removed:
{|DROP TABLE IF EXISTS in_progress|};
96
Removed:
{|CREATE TABLE IF NOT EXISTS in_progress (
97
Removed:
trainee_id TEXT PRIMARY KEY,
98
Removed:
encoded TEXT NOT NULL
99
Removed:
)|};
100
Removed:
{|CREATE TABLE IF NOT EXISTS workout (
101
Removed:
id TEXT PRIMARY KEY,
102
Removed:
trainee_id TEXT NOT NULL,
103
Removed:
seq INTEGER NOT NULL,
104
Removed:
encoded TEXT NOT NULL
105
Removed:
)|};
106
Removed:
{|CREATE INDEX IF NOT EXISTS workout_by_trainee
107
Removed:
ON workout (trainee_id, seq DESC)|};
108
Removed:
{|CREATE TABLE IF NOT EXISTS feedback (
109
Removed:
trainee_id TEXT NOT NULL,
110
Removed:
seq INTEGER NOT NULL,
111
Removed:
encoded TEXT NOT NULL,
112
Removed:
PRIMARY KEY (trainee_id, seq)
113
Removed:
)|};
114
Removed:
{|CREATE INDEX IF NOT EXISTS feedback_by_trainee
115
Removed:
ON feedback (trainee_id, seq DESC)|};
116
Removed:
{|CREATE TABLE IF NOT EXISTS app_feedback (
117
Removed:
trainee_id TEXT NOT NULL,
118
Removed:
seq INTEGER NOT NULL,
119
Removed:
submitted_at TEXT NOT NULL,
120
Removed:
message TEXT NOT NULL,
121
Removed:
PRIMARY KEY (trainee_id, seq)
122
Removed:
)|};
123
Removed:
{|CREATE INDEX IF NOT EXISTS app_feedback_by_trainee
124
Removed:
ON app_feedback (trainee_id, seq DESC)|};
125
Removed:
{|CREATE TABLE IF NOT EXISTS app_feedback_vote (
126
Removed:
feedback_trainee_id TEXT NOT NULL,
127
Removed:
feedback_seq INTEGER NOT NULL,
128
Removed:
voter_id TEXT NOT NULL,
129
Removed:
PRIMARY KEY (feedback_trainee_id, feedback_seq, voter_id)
130
Removed:
)|};
131
Removed:
{|CREATE INDEX IF NOT EXISTS app_feedback_vote_by_voter
132
Removed:
ON app_feedback_vote (voter_id)|};
133
Removed:
];
134
Removed:
};
135
Removed:
{
136
Removed:
version = 6;
137
Removed:
name = "five-point feedback scores";
138
Removed:
(* Subjective feedback now encodes levels as scores 1..5, so rows written
139
Removed:
with the old below/usual/above codes no longer decode. Feedback is
140
Removed:
observed, not authored, so the domain permits dropping it rather than
141
Removed:
migrating it. *)
142
Removed:
statements =
143
Removed:
[
144
Removed:
{|DROP TABLE IF EXISTS feedback|};
145
Removed:
{|CREATE TABLE IF NOT EXISTS feedback (
146
Removed:
trainee_id TEXT NOT NULL,
147
Removed:
seq INTEGER NOT NULL,
148
Removed:
encoded TEXT NOT NULL,
149
Removed:
PRIMARY KEY (trainee_id, seq)
150
Removed:
)|};
151
Removed:
{|CREATE INDEX IF NOT EXISTS feedback_by_trainee
152
Removed:
ON feedback (trainee_id, seq DESC)|};
153
Removed:
];
154
Removed:
};
155
Removed:
]
156
Removed:
157
Removed:
(* The ledger of applied migrations. A row per version, so a reconnect knows
158
Removed:
what the file already carries and skips it. *)
159
Removed:
let ledger =
160
Removed:
{|CREATE TABLE IF NOT EXISTS schema_migrations (
161
Removed:
version INTEGER PRIMARY KEY,
162
Removed:
name TEXT NOT NULL,
163
Removed:
applied_at REAL NOT NULL
164
Removed:
)|}
165
Removed:
166
Removed:
let statements =
167
Removed:
List.concat_map (fun migration -> migration.statements) migrations
168
Removed:
169
Removed:
(* --- request helpers --- *)
170
Removed:
171
Removed:
let exec_sql (module Db : Caqti_lwt.CONNECTION) sql =
172
Removed:
let request =
173
Removed:
let open Caqti_request.Infix in
174
Removed:
let open Caqti_type.Std in
175
Removed:
(unit ->. unit) ~oneshot:true sql
176
Removed:
in
177
Removed:
Db.exec request ()
178
Removed:
179
Removed:
let is_applied (module Db : Caqti_lwt.CONNECTION) version =
180
Removed:
let request =
181
Removed:
let open Caqti_request.Infix in
182
Removed:
let open Caqti_type.Std in
183
Removed:
(int ->! int) ~oneshot:true
184
Removed:
"SELECT COUNT(*) FROM schema_migrations WHERE version = ?"
185
Removed:
in
186
Removed:
Db.find request version
187
Removed:
188
Removed:
let record_applied (module Db : Caqti_lwt.CONNECTION) migration =
189
Removed:
let request =
190
Removed:
let open Caqti_request.Infix in
191
Removed:
let open Caqti_type.Std in
192
Removed:
(t2 int string ->. unit)
193
Removed:
~oneshot:true
194
Removed:
"INSERT INTO schema_migrations (version, name, applied_at) VALUES (?, ?, \
195
Removed:
strftime('%s','now'))"
196
Removed:
in
197
Removed:
Db.exec request (migration.version, migration.name)
198
Removed:
199
Removed:
(* Apply one migration inside a transaction, then record it. The ledger check
200
Removed:
makes this idempotent; the [IF NOT EXISTS] clauses keep an already-populated
201
Removed:
file from a pre-ledger build safe. *)
202
Removed:
let apply_migration ((module Db : Caqti_lwt.CONNECTION) as db) migration =
203
Removed:
let open Lwt_result.Syntax in
204
Removed:
let* applied = is_applied db migration.version in
205
Removed:
if applied > 0 then Lwt_result.return ()
206
Removed:
else
207
Removed:
Db.with_transaction (fun () ->
208
Removed:
let rec go = function
209
Removed:
| [] -> record_applied db migration
210
Removed:
| sql :: tl ->
211
Removed:
let* () = exec_sql db sql in
212
Removed:
go tl
213
Removed:
in
214
Removed:
go migration.statements)
215
Removed:
216
Removed:
let apply (module Db : Caqti_lwt.CONNECTION) =
217
Removed:
let db = (module Db : Caqti_lwt.CONNECTION) in
218
Removed:
let open Lwt_result.Syntax in
219
Removed:
let run =
220
Removed:
let* () = exec_sql db ledger in
221
Removed:
let rec go = function
222
Removed:
| [] -> Lwt_result.return ()
223
Removed:
| migration :: tl ->
224
Removed:
let* () = apply_migration db migration in
225
Removed:
go tl
226
Removed:
in
227
Removed:
go migrations
228
Removed:
in
229
Removed:
Lwt.map
230
Removed:
(function Ok () -> Ok () | Error e -> Error (e :> Caqti_error.t))
231
Removed:
run
lib/app/migrations.mli
@@ -1,24 +0,0 @@
1
Removed:
(** Versioned schema migrations for the SQLite store.
2
Removed:
3
Removed:
Each migration is a numbered, named set of statements. A [schema_migrations]
4
Removed:
ledger records which versions a database file already carries, so applying
5
Removed:
on connect runs only the migrations the file is missing and never repeats
6
Removed:
one. Every statement still uses [IF NOT EXISTS], so a database created by an
7
Removed:
earlier, ledger-less build stays safe.
8
Removed:
9
Removed:
Includes the [dream_session] table {!Dream.sql_sessions} expects. *)
10
Removed:
11
Removed:
type migration = { version : int; name : string; statements : string list }
12
Removed:
(** One migration: a version, a human name, and the ordered statements it runs.
13
Removed:
*)
14
Removed:
15
Removed:
val migrations : migration list
16
Removed:
(** Every migration, in ascending version order. *)
17
Removed:
18
Removed:
val apply : (module Caqti_lwt.CONNECTION) -> (unit, Caqti_error.t) result Lwt.t
19
Removed:
(** Create the ledger, then apply every migration not yet recorded, each inside
20
Removed:
a transaction. Idempotent across reconnects. *)
21
Removed:
22
Removed:
val statements : string list
23
Removed:
(** Every migration's statements, in order, exposed for documentation and tests.
24
Removed:
*)
lib/app/sqlite_repo.ml
@@ -1,478 +0,0 @@
1
Removed:
open Lwt.Infix
2
Removed:
3
Removed:
exception Corrupt of Codec.error
4
Removed:
5
Removed:
type t = {
6
Removed:
pool : (Caqti_lwt.connection, Caqti_error.t) Caqti_lwt_unix.Pool.t;
7
Removed:
mutable next_trainee : int;
8
Removed:
}
9
Removed:
10
Removed:
(* --- request definitions --- *)
11
Removed:
12
Removed:
module Q = struct
13
Removed:
open Caqti_request.Infix
14
Removed:
open Caqti_type.Std
15
Removed:
16
Removed:
let insert_trainee =
17
Removed:
(t3 string string string ->. unit)
18
Removed:
"INSERT INTO trainee (id, username, credential) VALUES (?, ?, ?)"
19
Removed:
20
Removed:
let trainee_by_username =
21
Removed:
(string ->? t3 string string string)
22
Removed:
"SELECT id, username, credential FROM trainee WHERE username = ?"
23
Removed:
24
Removed:
let trainee_by_id =
25
Removed:
(string ->? t3 string string string)
26
Removed:
"SELECT id, username, credential FROM trainee WHERE id = ?"
27
Removed:
28
Removed:
let next_trainee =
29
Removed:
(unit ->! int)
30
Removed:
"SELECT COALESCE(MAX(CAST(SUBSTR(id, 2) AS INTEGER)), 0) + 1 FROM \
31
Removed:
trainee WHERE id GLOB 't[0-9]*'"
32
Removed:
33
Removed:
let update_username =
34
Removed:
(t2 string string ->. unit) "UPDATE trainee SET username = ? WHERE id = ?"
35
Removed:
36
Removed:
let update_credential =
37
Removed:
(t2 string string ->. unit) "UPDATE trainee SET credential = ? WHERE id = ?"
38
Removed:
39
Removed:
let get_active =
40
Removed:
(string ->? string)
41
Removed:
"SELECT routine_id FROM active_routine WHERE trainee_id = ?"
42
Removed:
43
Removed:
let set_active =
44
Removed:
(t2 string string ->. unit)
45
Removed:
"INSERT INTO active_routine (trainee_id, routine_id) VALUES (?, ?) ON \
46
Removed:
CONFLICT (trainee_id) DO UPDATE SET routine_id = excluded.routine_id"
47
Removed:
48
Removed:
let get_in_progress =
49
Removed:
(string ->? string) "SELECT encoded FROM in_progress WHERE trainee_id = ?"
50
Removed:
51
Removed:
let set_in_progress =
52
Removed:
(t2 string string ->. unit)
53
Removed:
"INSERT INTO in_progress (trainee_id, encoded) VALUES (?, ?) ON CONFLICT \
54
Removed:
(trainee_id) DO UPDATE SET encoded = excluded.encoded"
55
Removed:
56
Removed:
let clear_in_progress =
57
Removed:
(string ->. unit) "DELETE FROM in_progress WHERE trainee_id = ?"
58
Removed:
59
Removed:
let next_seq =
60
Removed:
(string ->! int)
61
Removed:
"SELECT COALESCE(MAX(seq), 0) + 1 FROM workout WHERE trainee_id = ?"
62
Removed:
63
Removed:
let insert_workout =
64
Removed:
(t4 string string int string ->. unit)
65
Removed:
"INSERT INTO workout (id, trainee_id, seq, encoded) VALUES (?, ?, ?, ?)"
66
Removed:
67
Removed:
let workout_by_id =
68
Removed:
(t2 string string ->? string)
69
Removed:
"SELECT encoded FROM workout WHERE trainee_id = ? AND id = ?"
70
Removed:
71
Removed:
let update_workout =
72
Removed:
(t3 string string string ->. unit)
73
Removed:
"UPDATE workout SET encoded = ? WHERE trainee_id = ? AND id = ?"
74
Removed:
75
Removed:
let history =
76
Removed:
(string ->* t2 string string)
77
Removed:
"SELECT id, encoded FROM workout WHERE trainee_id = ? ORDER BY seq DESC"
78
Removed:
79
Removed:
let next_feedback_seq =
80
Removed:
(string ->! int)
81
Removed:
"SELECT COALESCE(MAX(seq), 0) + 1 FROM feedback WHERE trainee_id = ?"
82
Removed:
83
Removed:
let insert_feedback =
84
Removed:
(t3 string int string ->. unit)
85
Removed:
"INSERT INTO feedback (trainee_id, seq, encoded) VALUES (?, ?, ?)"
86
Removed:
87
Removed:
let feedback =
88
Removed:
(string ->* string)
89
Removed:
"SELECT encoded FROM feedback WHERE trainee_id = ? ORDER BY seq DESC"
90
Removed:
91
Removed:
let next_app_feedback_seq =
92
Removed:
(string ->! int)
93
Removed:
"SELECT COALESCE(MAX(seq), 0) + 1 FROM app_feedback WHERE trainee_id = ?"
94
Removed:
95
Removed:
let insert_app_feedback =
96
Removed:
(t4 string int string string ->. unit)
97
Removed:
"INSERT INTO app_feedback (trainee_id, seq, submitted_at, message) \
98
Removed:
VALUES (?, ?, ?, ?)"
99
Removed:
100
Removed:
let app_feedback =
101
Removed:
(unit ->* t7 string int string string string int int)
102
Removed:
"SELECT f.trainee_id, f.seq, t.username, f.submitted_at, f.message, \
103
Removed:
(SELECT COUNT(*) FROM app_feedback c WHERE c.trainee_id = \
104
Removed:
f.trainee_id), (SELECT COUNT(*) FROM app_feedback_vote v WHERE \
105
Removed:
v.feedback_trainee_id = f.trainee_id AND v.feedback_seq = f.seq) FROM \
106
Removed:
app_feedback f JOIN trainee t ON t.id = f.trainee_id ORDER BY 7 DESC, \
107
Removed:
f.submitted_at DESC, f.trainee_id, f.seq DESC"
108
Removed:
109
Removed:
let viewer_votes =
110
Removed:
(string ->* t2 string int)
111
Removed:
"SELECT feedback_trainee_id, feedback_seq FROM app_feedback_vote WHERE \
112
Removed:
voter_id = ?"
113
Removed:
114
Removed:
let feedback_owner =
115
Removed:
(t2 string int ->? string)
116
Removed:
"SELECT trainee_id FROM app_feedback WHERE trainee_id = ? AND seq = ?"
117
Removed:
118
Removed:
let vote_exists =
119
Removed:
(t3 string int string ->? int)
120
Removed:
"SELECT 1 FROM app_feedback_vote WHERE feedback_trainee_id = ? AND \
121
Removed:
feedback_seq = ? AND voter_id = ?"
122
Removed:
123
Removed:
let insert_vote =
124
Removed:
(t3 string int string ->. unit)
125
Removed:
"INSERT INTO app_feedback_vote (feedback_trainee_id, feedback_seq, \
126
Removed:
voter_id) VALUES (?, ?, ?)"
127
Removed:
128
Removed:
let update_app_feedback =
129
Removed:
(t3 string string int ->. unit)
130
Removed:
"UPDATE app_feedback SET message = ? WHERE trainee_id = ? AND seq = ?"
131
Removed:
132
Removed:
let delete_feedback_votes =
133
Removed:
(t2 string int ->. unit)
134
Removed:
"DELETE FROM app_feedback_vote WHERE feedback_trainee_id = ? AND \
135
Removed:
feedback_seq = ?"
136
Removed:
137
Removed:
let delete_app_feedback =
138
Removed:
(t2 string int ->. unit)
139
Removed:
"DELETE FROM app_feedback WHERE trainee_id = ? AND seq = ?"
140
Removed:
end
141
Removed:
142
Removed:
(* --- pool helper --- *)
143
Removed:
144
Removed:
let run t f = Caqti_lwt_unix.Pool.use f t.pool >>= Caqti_lwt.or_fail
145
Removed:
146
Removed:
let connect uri =
147
Removed:
match Caqti_lwt_unix.connect_pool (Uri.of_string uri) with
148
Removed:
| Error e -> Lwt.return (Error (e :> Caqti_error.t))
149
Removed:
| Ok pool ->
150
Removed:
let open Lwt_result.Syntax in
151
Removed:
let* () = Caqti_lwt_unix.Pool.use Migrations.apply pool in
152
Removed:
let* next_trainee =
153
Removed:
Caqti_lwt_unix.Pool.use
154
Removed:
(fun (module Db : Caqti_lwt.CONNECTION) -> Db.find Q.next_trainee ())
155
Removed:
pool
156
Removed:
in
157
Removed:
Lwt_result.return { pool; next_trainee }
158
Removed:
159
Removed:
(* --- decoding stored workouts --- *)
160
Removed:
161
Removed:
let find_routine_by_name = Catalog.find_by_name
162
Removed:
163
Removed:
let decode encoded =
164
Removed:
match Codec.decode_workout ~find_routine:find_routine_by_name encoded with
165
Removed:
| Ok workout -> workout
166
Removed:
| Error e -> raise (Corrupt e)
167
Removed:
168
Removed:
(* --- accounts --- *)
169
Removed:
170
Removed:
let create_trainee t ~username ~credential =
171
Removed:
let username_s = Trainee.username_to_string username in
172
Removed:
let credential_s = Trainee.credential_to_hash credential in
173
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
174
Removed:
Db.find_opt Q.trainee_by_username username_s)
175
Removed:
>>= function
176
Removed:
| Some _ -> Lwt.return (Error `Username_taken)
177
Removed:
| None ->
178
Removed:
let id = Printf.sprintf "t%d" t.next_trainee in
179
Removed:
t.next_trainee <- t.next_trainee + 1;
180
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
181
Removed:
Db.exec Q.insert_trainee (id, username_s, credential_s))
182
Removed:
>|= fun () -> Ok { Trainee.id = Trainee.id id; username; credential }
183
Removed:
184
Removed:
let trainee_of_row (id, username, credential) =
185
Removed:
match Trainee.username username with
186
Removed:
| Ok username ->
187
Removed:
Some
188
Removed:
{
189
Removed:
Trainee.id = Trainee.id id;
190
Removed:
username;
191
Removed:
credential = Trainee.credential_of_hash credential;
192
Removed:
}
193
Removed:
| Error _ -> None
194
Removed:
195
Removed:
let find_trainee_by_username t username =
196
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
197
Removed:
Db.find_opt Q.trainee_by_username (Trainee.username_to_string username))
198
Removed:
>|= function
199
Removed:
| Some row -> trainee_of_row row
200
Removed:
| None -> None
201
Removed:
202
Removed:
let find_trainee t id =
203
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
204
Removed:
Db.find_opt Q.trainee_by_id (Trainee.id_to_string id))
205
Removed:
>|= function
206
Removed:
| Some row -> trainee_of_row row
207
Removed:
| None -> None
208
Removed:
209
Removed:
(* Rename in one transaction: check the name is free for anyone else, then
210
Removed:
update. Running both on the same connection keeps the check and the write
211
Removed:
from racing another rename. The trainee's own current name is a no-op. *)
212
Removed:
let update_username t id (username : Trainee.username) =
213
Removed:
let trainee = Trainee.id_to_string id in
214
Removed:
let username_s = Trainee.username_to_string username in
215
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
216
Removed:
let open Lwt_result.Syntax in
217
Removed:
Db.with_transaction (fun () ->
218
Removed:
let* holder = Db.find_opt Q.trainee_by_username username_s in
219
Removed:
match holder with
220
Removed:
| Some (holder_id, _, _) when not (String.equal holder_id trainee) ->
221
Removed:
Lwt_result.return (Error `Username_taken)
222
Removed:
| _ ->
223
Removed:
let* () = Db.exec Q.update_username (username_s, trainee) in
224
Removed:
let* row = Db.find_opt Q.trainee_by_id trainee in
225
Removed:
Lwt_result.return
226
Removed:
(match Option.bind row trainee_of_row with
227
Removed:
| Some updated -> Ok updated
228
Removed:
| None -> Error `Username_taken)))
229
Removed:
230
Removed:
let update_credential t id credential =
231
Removed:
let trainee = Trainee.id_to_string id in
232
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
233
Removed:
Db.exec Q.update_credential
234
Removed:
(Trainee.credential_to_hash credential, trainee))
235
Removed:
>>= fun () -> find_trainee t id
236
Removed:
237
Removed:
(* --- catalog --- *)
238
Removed:
239
Removed:
let list_routines _ = Catalog.routines
240
Removed:
let find_routine _ id = Catalog.find id
241
Removed:
242
Removed:
(* The routine name a workout's prescription belongs to, for encoding. Only the
243
Removed:
ideal routine exists, but resolve it honestly rather than hard-code. *)
244
Removed:
let routine_name_of workout =
245
Removed:
let workout_name =
246
Removed:
Prescription.Workout.name (Evidence.Workout.prescription workout)
247
Removed:
in
248
Removed:
List.find_map
249
Removed:
(fun (_, routine) ->
250
Removed:
if
251
Removed:
List.exists
252
Removed:
(fun w -> String.equal (Prescription.Workout.name w) workout_name)
253
Removed:
(Prescription.Routine.workouts routine)
254
Removed:
then Some (Prescription.Routine.name routine)
255
Removed:
else None)
256
Removed:
Catalog.routines
257
Removed:
|> Option.value ~default:""
258
Removed:
259
Removed:
let encode workout =
260
Removed:
Codec.encode_workout ~routine_name:(routine_name_of workout) workout
261
Removed:
262
Removed:
(* --- per-trainee selection and workout in progress --- *)
263
Removed:
264
Removed:
let active_routine t id =
265
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
266
Removed:
Db.find_opt Q.get_active (Trainee.id_to_string id))
267
Removed:
>|= Option.map Repository.routine_id
268
Removed:
269
Removed:
let set_active_routine t id (routine : Repository.routine_id) =
270
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
271
Removed:
Db.exec Q.set_active (Trainee.id_to_string id, (routine :> string)))
272
Removed:
273
Removed:
let in_progress t id =
274
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
275
Removed:
Db.find_opt Q.get_in_progress (Trainee.id_to_string id))
276
Removed:
>|= function
277
Removed:
| None -> None
278
Removed:
| Some encoded -> Some (decode encoded)
279
Removed:
280
Removed:
let set_in_progress t id workout =
281
Removed:
let trainee = Trainee.id_to_string id in
282
Removed:
match workout with
283
Removed:
| None ->
284
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
285
Removed:
Db.exec Q.clear_in_progress trainee)
286
Removed:
| Some workout ->
287
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
288
Removed:
Db.exec Q.set_in_progress (trainee, encode workout))
289
Removed:
290
Removed:
(* --- history --- *)
291
Removed:
292
Removed:
(* Save a finished workout and clear the in-progress slot in one transaction,
293
Removed:
so the two rows never disagree after a crash. Both statements run on the same
294
Removed:
connection, checked out once, inside [with_transaction]. *)
295
Removed:
let finish_workout t id workout =
296
Removed:
let trainee = Trainee.id_to_string id in
297
Removed:
let encoded = encode workout in
298
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
299
Removed:
let open Lwt_result.Syntax in
300
Removed:
Db.with_transaction (fun () ->
301
Removed:
let* seq = Db.find Q.next_seq trainee in
302
Removed:
let wid = Printf.sprintf "%s:w%d" trainee seq in
303
Removed:
let* () = Db.exec Q.insert_workout (wid, trainee, seq, encoded) in
304
Removed:
let* () = Db.exec Q.clear_in_progress trainee in
305
Removed:
Lwt_result.return
306
Removed:
{ Repository.id = Repository.workout_id wid; workout }))
307
Removed:
308
Removed:
let find t id (wid : Repository.workout_id) =
309
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
310
Removed:
Db.find_opt Q.workout_by_id (Trainee.id_to_string id, (wid :> string)))
311
Removed:
>|= function
312
Removed:
| None -> None
313
Removed:
| Some encoded -> Some { Repository.id = wid; workout = decode encoded }
314
Removed:
315
Removed:
let replace t id record =
316
Removed:
let trainee = Trainee.id_to_string id in
317
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
318
Removed:
Db.find_opt Q.workout_by_id (trainee, (record.Repository.id :> string)))
319
Removed:
>>= function
320
Removed:
| None -> Lwt.return false
321
Removed:
| Some _ ->
322
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
323
Removed:
Db.exec Q.update_workout
324
Removed:
( encode record.Repository.workout,
325
Removed:
trainee,
326
Removed:
(record.Repository.id :> string) ))
327
Removed:
>|= fun () -> true
328
Removed:
329
Removed:
let history t id =
330
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
331
Removed:
Db.collect_list Q.history (Trainee.id_to_string id))
332
Removed:
>|= fun rows ->
333
Removed:
List.map
334
Removed:
(fun (wid, encoded) ->
335
Removed:
{ Repository.id = Repository.workout_id wid; workout = decode encoded })
336
Removed:
rows
337
Removed:
338
Removed:
let log t id =
339
Removed:
history t id >|= fun records ->
340
Removed:
List.fold_left
341
Removed:
(fun log record -> Evidence.Log.add log record.Repository.workout)
342
Removed:
Evidence.Log.empty (List.rev records)
343
Removed:
344
Removed:
(* --- subjective feedback --- *)
345
Removed:
346
Removed:
let save_feedback t id report =
347
Removed:
let trainee = Trainee.id_to_string id in
348
Removed:
let encoded = Codec.encode_feedback report in
349
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
350
Removed:
Db.find Q.next_feedback_seq trainee)
351
Removed:
>>= fun seq ->
352
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
353
Removed:
Db.exec Q.insert_feedback (trainee, seq, encoded))
354
Removed:
355
Removed:
let decode_feedback encoded =
356
Removed:
match Codec.decode_feedback encoded with
357
Removed:
| Ok report -> report
358
Removed:
| Error e -> raise (Corrupt e)
359
Removed:
360
Removed:
let feedback t id =
361
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
362
Removed:
Db.collect_list Q.feedback (Trainee.id_to_string id))
363
Removed:
>|= List.map decode_feedback
364
Removed:
365
Removed:
let save_app_feedback t id ~submitted_at ~message =
366
Removed:
let trainee = Trainee.id_to_string id in
367
Removed:
find_trainee t id >>= function
368
Removed:
| None ->
369
Removed:
Lwt.fail_with "cannot save application feedback for an unknown trainee"
370
Removed:
| Some author ->
371
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
372
Removed:
Db.find Q.next_app_feedback_seq trainee)
373
Removed:
>>= fun seq ->
374
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
375
Removed:
Db.exec Q.insert_app_feedback
376
Removed:
(trainee, seq, Timestamp.encode submitted_at, message))
377
Removed:
>|= fun () ->
378
Removed:
Repository.
379
Removed:
{
380
Removed:
feedback_id = app_feedback_id (Printf.sprintf "%s:%d" trainee seq);
381
Removed:
author = Trainee.username_to_string author.Trainee.username;
382
Removed:
contributions = seq;
383
Removed:
submitted_at;
384
Removed:
message;
385
Removed:
upvotes = 0;
386
Removed:
viewer_upvoted = false;
387
Removed:
viewer_owns = true;
388
Removed:
}
389
Removed:
390
Removed:
let app_feedback t ~viewer =
391
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
392
Removed:
Db.collect_list Q.app_feedback ())
393
Removed:
>>= fun rows ->
394
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
395
Removed:
Db.collect_list Q.viewer_votes (Trainee.id_to_string viewer))
396
Removed:
>|= fun voted ->
397
Removed:
List.map
398
Removed:
(fun (trainee, seq, author, submitted_at, message, contributions, upvotes)
399
Removed:
->
400
Removed:
let submitted_at =
401
Removed:
match Timestamp.decode submitted_at with
402
Removed:
| Ok timestamp -> timestamp
403
Removed:
| Error _ ->
404
Removed:
raise (Corrupt (Codec.Malformed "application feedback timestamp"))
405
Removed:
in
406
Removed:
Repository.
407
Removed:
{
408
Removed:
feedback_id = app_feedback_id (Printf.sprintf "%s:%d" trainee seq);
409
Removed:
author;
410
Removed:
contributions;
411
Removed:
submitted_at;
412
Removed:
message;
413
Removed:
upvotes;
414
Removed:
viewer_upvoted = List.mem (trainee, seq) voted;
415
Removed:
viewer_owns = String.equal trainee (Trainee.id_to_string viewer);
416
Removed:
})
417
Removed:
rows
418
Removed:
419
Removed:
let split_app_feedback_id id =
420
Removed:
let raw = Repository.app_feedback_id_to_string id in
421
Removed:
match String.rindex_opt raw ':' with
422
Removed:
| None -> None
423
Removed:
| Some separator ->
424
Removed:
let trainee = String.sub raw 0 separator in
425
Removed:
let seq_start = separator + 1 in
426
Removed:
let seq_length = String.length raw - seq_start in
427
Removed:
Option.map
428
Removed:
(fun seq -> (trainee, seq))
429
Removed:
(int_of_string_opt (String.sub raw seq_start seq_length))
430
Removed:
431
Removed:
let upvote_app_feedback t ~voter id =
432
Removed:
match split_app_feedback_id id with
433
Removed:
| None -> Lwt.return false
434
Removed:
| Some (trainee, seq) -> (
435
Removed:
let voter = Trainee.id_to_string voter in
436
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
437
Removed:
Db.find_opt Q.feedback_owner (trainee, seq))
438
Removed:
>>= function
439
Removed:
| None -> Lwt.return false
440
Removed:
| Some owner when String.equal owner voter -> Lwt.return false
441
Removed:
| Some _ -> (
442
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
443
Removed:
Db.find_opt Q.vote_exists (trainee, seq, voter))
444
Removed:
>>= function
445
Removed:
| Some _ -> Lwt.return false
446
Removed:
| None ->
447
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
448
Removed:
Db.exec Q.insert_vote (trainee, seq, voter))
449
Removed:
>|= fun () -> true))
450
Removed:
451
Removed:
let update_app_feedback t ~author id ~message =
452
Removed:
match split_app_feedback_id id with
453
Removed:
| None -> Lwt.return false
454
Removed:
| Some (trainee, seq) -> (
455
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
456
Removed:
Db.find_opt Q.feedback_owner (trainee, seq))
457
Removed:
>>= function
458
Removed:
| Some owner when String.equal owner (Trainee.id_to_string author) ->
459
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
460
Removed:
Db.exec Q.update_app_feedback (message, trainee, seq))
461
Removed:
>|= fun () -> true
462
Removed:
| _ -> Lwt.return false)
463
Removed:
464
Removed:
let delete_app_feedback t ~author id =
465
Removed:
match split_app_feedback_id id with
466
Removed:
| None -> Lwt.return false
467
Removed:
| Some (trainee, seq) -> (
468
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
469
Removed:
Db.find_opt Q.feedback_owner (trainee, seq))
470
Removed:
>>= function
471
Removed:
| Some owner when String.equal owner (Trainee.id_to_string author) ->
472
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
473
Removed:
Db.exec Q.delete_feedback_votes (trainee, seq))
474
Removed:
>>= fun () ->
475
Removed:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
476
Removed:
Db.exec Q.delete_app_feedback (trainee, seq))
477
Removed:
>|= fun () -> true
478
Removed:
| _ -> Lwt.return false)
lib/app/sqlite_repo.mli
@@ -1,21 +0,0 @@
1
Removed:
(** Durable {!Repository.S} backed by SQLite through Caqti. The production
2
Removed:
store.
3
Removed:
4
Removed:
All performed facts are stored through {!Codec}: the adapter never inspects
5
Removed:
domain shape, it stores and returns opaque encoded strings. Prescriptions
6
Removed:
are not stored — a workout resolves its prescription against the shared
7
Removed:
{!Catalog} on read.
8
Removed:
9
Removed:
Identity is assigned here: trainees and workouts get string ids the adapter
10
Removed:
mints. *)
11
Removed:
12
Removed:
include Repository.S
13
Removed:
14
Removed:
exception Corrupt of Codec.error
15
Removed:
(** Raised when a stored workout cannot be decoded — a corrupted database or a
16
Removed:
catalog that no longer names a stored routine or workout. This is a fault,
17
Removed:
not a normal outcome. *)
18
Removed:
19
Removed:
val connect : string -> (t, Caqti_error.t) result Lwt.t
20
Removed:
(** [connect uri] opens a connection pool and applies {!Migrations}. [uri] is a
21
Removed:
Caqti URI such as ["sqlite3:hito.sqlite"]. *)
lib/app/timestamp.ml
@@ -1,73 +0,0 @@
1
Removed:
type error = Malformed of string
2
Removed:
3
Removed:
let pp_error ppf = function
4
Removed:
| Malformed detail -> Format.fprintf ppf "malformed timestamp: %s" detail
5
Removed:
6
Removed:
let encode timestamp =
7
Removed:
let time =
8
Removed:
Unix.gmtime (float_of_int (Recovery.timestamp_to_unix_seconds timestamp))
9
Removed:
in
10
Removed:
Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" (time.Unix.tm_year + 1900)
11
Removed:
(time.Unix.tm_mon + 1) time.Unix.tm_mday time.Unix.tm_hour time.Unix.tm_min
12
Removed:
time.Unix.tm_sec
13
Removed:
14
Removed:
let digit text index =
15
Removed:
let value = Char.code text.[index] - Char.code '0' in
16
Removed:
if value >= 0 && value <= 9 then Some value else None
17
Removed:
18
Removed:
let number text start length =
19
Removed:
let rec loop index value =
20
Removed:
if index = start + length then Some value
21
Removed:
else
22
Removed:
match digit text index with
23
Removed:
| None -> None
24
Removed:
| Some value' -> loop (index + 1) ((value * 10) + value')
25
Removed:
in
26
Removed:
loop start 0
27
Removed:
28
Removed:
(* Return the number of days from 1970-01-01 for a Gregorian date. *)
29
Removed:
let days_from_civil year month day =
30
Removed:
let year = year - if month <= 2 then 1 else 0 in
31
Removed:
let era = if year >= 0 then year / 400 else (year - 399) / 400 in
32
Removed:
let year_of_era = year - (era * 400) in
33
Removed:
let month = month + if month > 2 then -3 else 9 in
34
Removed:
let day_of_year = (((153 * month) + 2) / 5) + day - 1 in
35
Removed:
let day_of_era =
36
Removed:
(year_of_era * 365) + (year_of_era / 4) - (year_of_era / 100) + day_of_year
37
Removed:
in
38
Removed:
(era * 146097) + day_of_era - 719468
39
Removed:
40
Removed:
let decode text =
41
Removed:
let malformed detail = Error (Malformed detail) in
42
Removed:
if String.length text <> 20 then malformed "expected YYYY-MM-DDTHH:MM:SSZ"
43
Removed:
else if
44
Removed:
text.[4] <> '-'
45
Removed:
|| text.[7] <> '-'
46
Removed:
|| text.[10] <> 'T'
47
Removed:
|| text.[13] <> ':'
48
Removed:
|| text.[16] <> ':'
49
Removed:
|| text.[19] <> 'Z'
50
Removed:
then malformed "expected YYYY-MM-DDTHH:MM:SSZ"
51
Removed:
else
52
Removed:
match
53
Removed:
( number text 0 4,
54
Removed:
number text 5 2,
55
Removed:
number text 8 2,
56
Removed:
number text 11 2,
57
Removed:
number text 14 2,
58
Removed:
number text 17 2 )
59
Removed:
with
60
Removed:
| Some year, Some month, Some day, Some hour, Some minute, Some second ->
61
Removed:
if
62
Removed:
month < 1 || month > 12 || day < 1 || day > 31 || hour > 23
63
Removed:
|| minute > 59 || second > 59
64
Removed:
then malformed "timestamp component out of range"
65
Removed:
else
66
Removed:
let seconds =
67
Removed:
(days_from_civil year month day * 86_400)
68
Removed:
+ (hour * 3_600) + (minute * 60) + second
69
Removed:
in
70
Removed:
let timestamp = Recovery.timestamp_of_unix_seconds seconds in
71
Removed:
if String.equal (encode timestamp) text then Ok timestamp
72
Removed:
else malformed "invalid calendar date"
73
Removed:
| _ -> malformed "timestamp contains a non-digit"
lib/app/timestamp.mli
@@ -1,10 +0,0 @@
1
Removed:
(** Strict UTC Zulu timestamps used at persistence boundaries. *)
2
Removed:
type error = Malformed of string
3
Removed:
4
Removed:
val encode : Recovery.timestamp -> string
5
Removed:
(** Encode seconds as [YYYY-MM-DDTHH:MM:SSZ]. *)
6
Removed:
7
Removed:
val decode : string -> (Recovery.timestamp, error) result
8
Removed:
(** Decode a strict UTC Zulu timestamp. *)
9
Removed:
10
Removed:
val pp_error : Format.formatter -> error -> unit
lib/persistence/codec.ml
@@ -0,0 +1,382 @@
1
Added:
type error =
2
Added:
| Malformed of string
3
Added:
| Unknown_exercise of string
4
Added:
| Unknown_routine of string
5
Added:
| Unknown_workout_name of { routine : string; workout : string }
6
Added:
| Replay_rejected of string
7
Added:
8
Added:
let pp_error ppf = function
9
Added:
| Malformed detail -> Format.fprintf ppf "malformed record: %s" detail
10
Added:
| Unknown_exercise id -> Format.fprintf ppf "unknown exercise %S" id
11
Added:
| Unknown_routine name -> Format.fprintf ppf "unknown routine %S" name
12
Added:
| Unknown_workout_name { routine; workout } ->
13
Added:
Format.fprintf ppf "routine %S has no workout %S" routine workout
14
Added:
| Replay_rejected detail ->
15
Added:
Format.fprintf ppf "stored record rejected: %s" detail
16
Added:
17
Added:
(* --- extension and outcome codes --- *)
18
Added:
19
Added:
let extension_code : Evidence.Stimulus.extension -> string = function
20
Added:
| Forced_reps -> "forced"
21
Added:
| Negatives -> "negatives"
22
Added:
| Rest_pause -> "rest-pause"
23
Added:
| Static_hold -> "static"
24
Added:
25
Added:
let extension_of_code = function
26
Added:
| "forced" -> Ok Evidence.Stimulus.Forced_reps
27
Added:
| "negatives" -> Ok Evidence.Stimulus.Negatives
28
Added:
| "rest-pause" -> Ok Evidence.Stimulus.Rest_pause
29
Added:
| "static" -> Ok Evidence.Stimulus.Static_hold
30
Added:
| other -> Error (Malformed (Printf.sprintf "extension %S" other))
31
Added:
32
Added:
let encode_outcome (outcome : Evidence.Stimulus.outcome) =
33
Added:
match outcome with
34
Added:
| Positive_failure -> "positive"
35
Added:
| Beyond_failure (first, rest) ->
36
Added:
"beyond:" ^ String.concat "," (List.map extension_code (first :: rest))
37
Added:
38
Added:
let decode_outcome text =
39
Added:
if String.equal text "positive" then Ok Evidence.Stimulus.Positive_failure
40
Added:
else
41
Added:
match String.split_on_char ':' text with
42
Added:
| [ "beyond"; codes ] -> (
43
Added:
match String.split_on_char ',' codes with
44
Added:
| [] | [ "" ] -> Error (Malformed "empty beyond-failure")
45
Added:
| first :: rest ->
46
Added:
let ( let* ) = Result.bind in
47
Added:
let* first = extension_of_code first in
48
Added:
let rec go acc = function
49
Added:
| [] -> Ok (List.rev acc)
50
Added:
| code :: tl -> (
51
Added:
match extension_of_code code with
52
Added:
| Ok e -> go (e :: acc) tl
53
Added:
| Error _ as e -> e)
54
Added:
in
55
Added:
let* rest = go [] rest in
56
Added:
Ok (Evidence.Stimulus.Beyond_failure (first, rest)))
57
Added:
| _ -> Error (Malformed (Printf.sprintf "outcome %S" text))
58
Added:
59
Added:
(* --- efforts and stimuli --- *)
60
Added:
61
Added:
let encode_effort effort =
62
Added:
let exercise = Evidence.Stimulus.Effort.exercise effort in
63
Added:
Printf.sprintf "%s\t%h\t%d\t%s"
64
Added:
(Exercise.id exercise :> string)
65
Added:
(Evidence.Stimulus.Effort.load effort)
66
Added:
(Evidence.Stimulus.Effort.reps effort)
67
Added:
(encode_outcome (Evidence.Stimulus.Effort.outcome effort))
68
Added:
69
Added:
let encode_stimulus ~slot stimulus =
70
Added:
match Evidence.Stimulus.delivery stimulus with
71
Added:
| Evidence.Stimulus.Single effort ->
72
Added:
Printf.sprintf "stimulus\t%d\tsingle\t%s" slot (encode_effort effort)
73
Added:
| Evidence.Stimulus.Pair { first; second } ->
74
Added:
Printf.sprintf "stimulus\t%d\tpair\t%s\t%s" slot (encode_effort first)
75
Added:
(encode_effort second)
76
Added:
77
Added:
let ( let* ) = Result.bind
78
Added:
79
Added:
let decode_effort = function
80
Added:
| [ exid; load; reps; outcome ] -> (
81
Added:
match Exercise.find_id exid with
82
Added:
| None -> Error (Unknown_exercise exid)
83
Added:
| Some exercise -> (
84
Added:
match (float_of_string_opt load, int_of_string_opt reps) with
85
Added:
| Some load, Some reps ->
86
Added:
let* outcome = decode_outcome outcome in
87
Added:
Ok (Evidence.Stimulus.Effort.make ~exercise ~load ~reps ~outcome)
88
Added:
| _ -> Error (Malformed "effort load/reps")))
89
Added:
| _ -> Error (Malformed "effort arity")
90
Added:
91
Added:
(* Decode a stimulus and the slot it filled. The current format prefixes the
92
Added:
slot; a record from before slots were stored omits it, and replays in
93
Added:
performance order through [add_stimulus] instead. *)
94
Added:
let decode_stimulus fields =
95
Added:
let delivery = function
96
Added:
| "single" :: rest ->
97
Added:
let* effort = decode_effort rest in
98
Added:
Ok (Evidence.Stimulus.make (Evidence.Stimulus.Single effort))
99
Added:
| "pair" :: rest -> (
100
Added:
match rest with
101
Added:
| [ a; b; c; d; e; f; g; h ] ->
102
Added:
let* first = decode_effort [ a; b; c; d ] in
103
Added:
let* second = decode_effort [ e; f; g; h ] in
104
Added:
Ok
105
Added:
(Evidence.Stimulus.make
106
Added:
(Evidence.Stimulus.Pair { first; second }))
107
Added:
| _ -> Error (Malformed "pair arity"))
108
Added:
| _ -> Error (Malformed "stimulus delivery")
109
Added:
in
110
Added:
match fields with
111
Added:
| slot :: rest when Option.is_some (int_of_string_opt slot) ->
112
Added:
let* stimulus = delivery rest in
113
Added:
Ok (Some (Option.get (int_of_string_opt slot)), stimulus)
114
Added:
| rest ->
115
Added:
let* stimulus = delivery rest in
116
Added:
Ok (None, stimulus)
117
Added:
118
Added:
(* --- clearance --- *)
119
Added:
120
Added:
let encode_clearance clearance =
121
Added:
match Recovery.basis clearance with
122
Added:
| Recovery.Recovered -> "clearance\trecovered"
123
Added:
| Recovery.Overridden { rested; recommended } ->
124
Added:
Printf.sprintf "clearance\toverridden\t%d\t%d"
125
Added:
(Recovery.duration_to_seconds rested)
126
Added:
(Recovery.duration_to_seconds recommended)
127
Added:
128
Added:
(* Recovery exposes only hours/days constructors, so derive an arbitrary
129
Added:
second-valued duration through elapsed: since=0, now=secs yields exactly
130
Added:
[secs] seconds. *)
131
Added:
let seconds_duration secs =
132
Added:
Recovery.elapsed
133
Added:
~since:(Recovery.timestamp_of_unix_seconds 0)
134
Added:
~now:(Recovery.timestamp_of_unix_seconds secs)
135
Added:
136
Added:
(* A clearance cannot be minted directly; it is derived from a readiness.
137
Added:
[Recovered] comes from a [Ready] reading; an override needs a [Recovering]
138
Added:
reading carrying the stored durations. *)
139
Added:
let decode_clearance = function
140
Added:
| [ "recovered" ] -> Ok (Option.get (Recovery.clear Recovery.Ready))
141
Added:
| [ "overridden"; rested; recommended ] -> (
142
Added:
match (int_of_string_opt rested, int_of_string_opt recommended) with
143
Added:
| Some rested, Some recommended ->
144
Added:
Ok
145
Added:
(Recovery.override
146
Added:
(Recovery.Recovering
147
Added:
{
148
Added:
rested = seconds_duration rested;
149
Added:
recommended = seconds_duration recommended;
150
Added:
}))
151
Added:
| _ -> Error (Malformed "clearance durations"))
152
Added:
| _ -> Error (Malformed "clearance basis")
153
Added:
154
Added:
(* --- workout --- *)
155
Added:
156
Added:
let encode_workout ~routine_name workout =
157
Added:
let buf = Buffer.create 256 in
158
Added:
let line s =
159
Added:
Buffer.add_string buf s;
160
Added:
Buffer.add_char buf '\n'
161
Added:
in
162
Added:
line (Printf.sprintf "routine\t%s" routine_name);
163
Added:
line
164
Added:
(Printf.sprintf "prescription\t%s"
165
Added:
(Prescription.Workout.name (Evidence.Workout.prescription workout)));
166
Added:
line (encode_clearance (Evidence.Workout.clearance workout));
167
Added:
line
168
Added:
(Printf.sprintf "started\t%s"
169
Added:
(Timestamp.encode (Evidence.Workout.started_at workout)));
170
Added:
(match Evidence.Workout.ended_at workout with
171
Added:
| Some ended -> line (Printf.sprintf "ended\t%s" (Timestamp.encode ended))
172
Added:
| None -> ());
173
Added:
List.iter
174
Added:
(fun (slot, stimulus) -> line (encode_stimulus ~slot stimulus))
175
Added:
(Evidence.Workout.performed workout);
176
Added:
Buffer.contents buf
177
Added:
178
Added:
(* A fully-parsed header, gathered before any replay. Parsing produces this
179
Added:
typed record; replay consumes it. Keeping the two phases apart removes the
180
Added:
mutable accumulators the old single pass needed. *)
181
Added:
type parsed = {
182
Added:
routine_name : string;
183
Added:
prescription_name : string;
184
Added:
clearance : Recovery.clearance;
185
Added:
started_at : Recovery.timestamp;
186
Added:
ended_at : Recovery.timestamp option;
187
Added:
stimuli : (int option * Evidence.Stimulus.t) list;
188
Added:
(** Performance order, each with the slot it filled when known. *)
189
Added:
}
190
Added:
191
Added:
(* Fields accumulated while folding over lines; every field is optional until
192
Added:
its line is seen. [stimuli] is reversed for O(1) prepend and flipped once at
193
Added:
the end. *)
194
Added:
type acc = {
195
Added:
a_routine : string option;
196
Added:
a_prescription : string option;
197
Added:
a_clearance : Recovery.clearance option;
198
Added:
a_started : Recovery.timestamp option;
199
Added:
a_ended : Recovery.timestamp option;
200
Added:
a_stimuli_rev : (int option * Evidence.Stimulus.t) list;
201
Added:
}
202
Added:
203
Added:
let empty_acc =
204
Added:
{
205
Added:
a_routine = None;
206
Added:
a_prescription = None;
207
Added:
a_clearance = None;
208
Added:
a_started = None;
209
Added:
a_ended = None;
210
Added:
a_stimuli_rev = [];
211
Added:
}
212
Added:
213
Added:
let parse_timestamp label text =
214
Added:
match Timestamp.decode text with
215
Added:
| Ok timestamp -> Ok timestamp
216
Added:
| Error _ -> Error (Malformed label)
217
Added:
218
Added:
(* Fold one line into the accumulator. A line either sets a header field or
219
Added:
appends a stimulus; anything else is malformed. *)
220
Added:
let step acc = function
221
Added:
| [ "routine"; name ] -> Ok { acc with a_routine = Some name }
222
Added:
| [ "prescription"; name ] -> Ok { acc with a_prescription = Some name }
223
Added:
| "clearance" :: rest ->
224
Added:
let* c = decode_clearance rest in
225
Added:
Ok { acc with a_clearance = Some c }
226
Added:
| [ "started"; text ] ->
227
Added:
let* timestamp = parse_timestamp "started timestamp" text in
228
Added:
Ok { acc with a_started = Some timestamp }
229
Added:
| [ "ended"; text ] ->
230
Added:
let* timestamp = parse_timestamp "ended timestamp" text in
231
Added:
Ok { acc with a_ended = Some timestamp }
232
Added:
| "stimulus" :: rest ->
233
Added:
let* s = decode_stimulus rest in
234
Added:
Ok { acc with a_stimuli_rev = s :: acc.a_stimuli_rev }
235
Added:
| fields -> Error (Malformed (String.concat "|" fields))
236
Added:
237
Added:
(* Parse the whole text into a typed header, or fail. Mandatory fields are
238
Added:
checked here so replay never sees a partial record. *)
239
Added:
let parse text =
240
Added:
let lines =
241
Added:
String.split_on_char '\n' text
242
Added:
|> List.filter (fun l -> String.length l > 0)
243
Added:
|> List.map (fun l -> String.split_on_char '\t' l)
244
Added:
in
245
Added:
let rec fold acc = function
246
Added:
| [] -> Ok acc
247
Added:
| line :: tl ->
248
Added:
let* acc = step acc line in
249
Added:
fold acc tl
250
Added:
in
251
Added:
let* acc = fold empty_acc lines in
252
Added:
match (acc.a_routine, acc.a_prescription, acc.a_clearance, acc.a_started) with
253
Added:
| Some routine_name, Some prescription_name, Some clearance, Some started_at
254
Added:
->
255
Added:
Ok
256
Added:
{
257
Added:
routine_name;
258
Added:
prescription_name;
259
Added:
clearance;
260
Added:
started_at;
261
Added:
ended_at = acc.a_ended;
262
Added:
stimuli = List.rev acc.a_stimuli_rev;
263
Added:
}
264
Added:
| _ -> Error (Malformed "missing header fields")
265
Added:
266
Added:
(* Resolve the prescription named in the header against the catalog. *)
267
Added:
let resolve_prescription ~find_routine parsed =
268
Added:
match find_routine parsed.routine_name with
269
Added:
| None -> Error (Unknown_routine parsed.routine_name)
270
Added:
| Some routine -> (
271
Added:
match
272
Added:
List.find_opt
273
Added:
(fun w ->
274
Added:
String.equal (Prescription.Workout.name w) parsed.prescription_name)
275
Added:
(Prescription.Routine.workouts routine)
276
Added:
with
277
Added:
| Some prescription -> Ok prescription
278
Added:
| None ->
279
Added:
Error
280
Added:
(Unknown_workout_name
281
Added:
{
282
Added:
routine = parsed.routine_name;
283
Added:
workout = parsed.prescription_name;
284
Added:
}))
285
Added:
286
Added:
(* Drive the core constructors from a typed header. The core raises on a
287
Added:
rejected stimulus; catch it once here and report it as data corruption. *)
288
Added:
let replay ~prescription parsed =
289
Added:
try
290
Added:
let workout =
291
Added:
Evidence.Workout.start prescription ~clearance:parsed.clearance
292
Added:
~started_at:parsed.started_at
293
Added:
in
294
Added:
let workout =
295
Added:
List.fold_left
296
Added:
(fun workout (slot, stimulus) ->
297
Added:
match slot with
298
Added:
| Some slot -> Evidence.Workout.record_at workout ~slot stimulus
299
Added:
| None -> Evidence.Workout.add_stimulus workout stimulus)
300
Added:
workout parsed.stimuli
301
Added:
in
302
Added:
let workout =
303
Added:
match parsed.ended_at with
304
Added:
| Some ended_at -> Evidence.Workout.finish workout ~ended_at
305
Added:
| None -> workout
306
Added:
in
307
Added:
Ok workout
308
Added:
with Evidence.Workout.Invalid err ->
309
Added:
Error (Replay_rejected (Format.asprintf "%a" Evidence.Workout.pp_error err))
310
Added:
311
Added:
let decode_workout ~find_routine text =
312
Added:
let* parsed = parse text in
313
Added:
let* prescription = resolve_prescription ~find_routine parsed in
314
Added:
replay ~prescription parsed
315
Added:
316
Added:
(* --- subjective feedback --- *)
317
Added:
318
Added:
let level_code (l : Evidence.Feedback.level) =
319
Added:
string_of_int (Evidence.Feedback.level_to_score l)
320
Added:
321
Added:
let level_of_code code =
322
Added:
match int_of_string_opt code with
323
Added:
| Some n -> (
324
Added:
match Evidence.Feedback.level_of_score n with
325
Added:
| Some l -> Ok l
326
Added:
| None -> Error (Malformed (Printf.sprintf "level %S" code)))
327
Added:
| None -> Error (Malformed (Printf.sprintf "level %S" code))
328
Added:
329
Added:
let signal_code : Evidence.Feedback.signal -> string = function
330
Added:
| Sleep l -> "sleep:" ^ level_code l
331
Added:
| Appetite l -> "appetite:" ^ level_code l
332
Added:
| Readiness l -> "readiness:" ^ level_code l
333
Added:
| Motivation l -> "motivation:" ^ level_code l
334
Added:
| Difficulty l -> "difficulty:" ^ level_code l
335
Added:
| Pain -> "pain"
336
Added:
| Injury -> "injury"
337
Added:
| Preparation_insufficient -> "preparation-insufficient"
338
Added:
339
Added:
let signal_of_code code =
340
Added:
let leveled make rest =
341
Added:
let* l = level_of_code rest in
342
Added:
Ok (make l)
343
Added:
in
344
Added:
match String.split_on_char ':' code with
345
Added:
| [ "sleep"; l ] -> leveled (fun l -> Evidence.Feedback.Sleep l) l
346
Added:
| [ "appetite"; l ] -> leveled (fun l -> Evidence.Feedback.Appetite l) l
347
Added:
| [ "readiness"; l ] -> leveled (fun l -> Evidence.Feedback.Readiness l) l
348
Added:
| [ "motivation"; l ] -> leveled (fun l -> Evidence.Feedback.Motivation l) l
349
Added:
| [ "difficulty"; l ] -> leveled (fun l -> Evidence.Feedback.Difficulty l) l
350
Added:
| [ "pain" ] -> Ok Evidence.Feedback.Pain
351
Added:
| [ "injury" ] -> Ok Evidence.Feedback.Injury
352
Added:
| [ "preparation-insufficient" ] ->
353
Added:
Ok Evidence.Feedback.Preparation_insufficient
354
Added:
| _ -> Error (Malformed (Printf.sprintf "signal %S" code))
355
Added:
356
Added:
let encode_feedback report =
357
Added:
let reported_at = Timestamp.encode (Evidence.Feedback.reported_at report) in
358
Added:
let signals =
359
Added:
String.concat "," (List.map signal_code (Evidence.Feedback.signals report))
360
Added:
in
361
Added:
Printf.sprintf "%s\t%s" reported_at signals
362
Added:
363
Added:
let decode_feedback text =
364
Added:
match String.split_on_char '\t' text with
365
Added:
| [ timestamp; signals ] -> (
366
Added:
match Timestamp.decode timestamp with
367
Added:
| Error _ -> Error (Malformed "feedback timestamp")
368
Added:
| Ok reported_at ->
369
Added:
let codes =
370
Added:
String.split_on_char ',' signals
371
Added:
|> List.filter (fun s -> String.length s > 0)
372
Added:
in
373
Added:
let rec go acc = function
374
Added:
| [] -> Ok (List.rev acc)
375
Added:
| code :: tl -> (
376
Added:
match signal_of_code code with
377
Added:
| Ok s -> go (s :: acc) tl
378
Added:
| Error _ as e -> e)
379
Added:
in
380
Added:
let* signals = go [] codes in
381
Added:
Ok (Evidence.Feedback.make ~reported_at signals))
382
Added:
| _ -> Error (Malformed "feedback arity")
lib/persistence/codec.mli
@@ -0,0 +1,38 @@
1
Added:
(** Serialization of performed facts, and their replay through the core.
2
Added:
3
Added:
The core types are opaque and carry no serializers, by design: the logbook
4
Added:
records, it never interprets. This module is the trust boundary for stored
5
Added:
data. It captures only what was performed — exercise, load, reps, outcome,
6
Added:
timestamps, and the basis on which a workout was begun — and rebuilds a
7
Added:
{!Evidence.Workout.t} by driving the same constructors a live session does.
8
Added:
9
Added:
A workout's prescription is not stored. It is found again by name in the
10
Added:
routine catalog, so a stored workout stays valid only as long as its routine
11
Added:
and workout names do. That is the intended coupling: prescriptions are
12
Added:
authored, not recorded. *)
13
Added:
14
Added:
type error =
15
Added:
| Malformed of string (** The stored text does not parse. *)
16
Added:
| Unknown_exercise of string
17
Added:
| Unknown_routine of string
18
Added:
| Unknown_workout_name of { routine : string; workout : string }
19
Added:
| Replay_rejected of string
20
Added:
(** The core refused a stored stimulus; the store is inconsistent. *)
21
Added:
22
Added:
val pp_error : Format.formatter -> error -> unit
23
Added:
24
Added:
val encode_workout : routine_name:string -> Evidence.Workout.t -> string
25
Added:
(** A stable, single-string encoding of a performed or in-progress workout.
26
Added:
[routine_name] identifies the catalog routine the prescription came from. *)
27
Added:
28
Added:
val decode_workout :
29
Added:
find_routine:(string -> Prescription.Routine.t option) ->
30
Added:
string ->
31
Added:
(Evidence.Workout.t, error) result
32
Added:
(** Rebuilds a workout, resolving its prescription through [find_routine]. *)
33
Added:
34
Added:
val encode_feedback : Evidence.Feedback.t -> string
35
Added:
(** A stable, single-string encoding of a subjective feedback report. *)
36
Added:
37
Added:
val decode_feedback : string -> (Evidence.Feedback.t, error) result
38
Added:
(** Rebuilds a feedback report from its encoding. *)
lib/persistence/dune
@@ -0,0 +1,16 @@
1
Added:
; The persistence layer: adapters that implement the Repository port. It sits
2
Added:
; outside the use case and depends on it, never the reverse. This is where Caqti,
3
Added:
; the SQLite driver, and the stored-fact codec live, so the domain never sees SQL.
4
Added:
5
Added:
(library
6
Added:
(name hito_persistence)
7
Added:
(public_name hito.persistence)
8
Added:
(libraries
9
Added:
hito.core
10
Added:
hito.app
11
Added:
lwt
12
Added:
caqti
13
Added:
caqti-lwt
14
Added:
caqti-lwt.unix
15
Added:
caqti-driver-sqlite3
16
Added:
uri))
lib/persistence/memory_repo.ml
@@ -0,0 +1,401 @@
1
Added:
open Hito_app
2
Added:
3
Added:
(* Per-trainee mutable state, held in a hashtable keyed by trainee id. *)
4
Added:
type trainee_state = {
5
Added:
mutable active : Repository.routine_id option;
6
Added:
mutable current : Evidence.Workout.t option;
7
Added:
mutable stored : Repository.record list; (* most recent first *)
8
Added:
mutable feedback : Evidence.Feedback.t list; (* most recent first *)
9
Added:
mutable next_id : int;
10
Added:
mutable next_app_feedback : int;
11
Added:
}
12
Added:
13
Added:
type t = {
14
Added:
mutable trainees : Trainee.t list;
15
Added:
states : (string, trainee_state) Hashtbl.t;
16
Added:
mutable app_feedback : (Trainee.id * Repository.app_feedback) list;
17
Added:
mutable app_feedback_votes : (Repository.app_feedback_id * Trainee.id) list;
18
Added:
mutable next_trainee : int;
19
Added:
}
20
Added:
21
Added:
let create () =
22
Added:
{
23
Added:
trainees = [];
24
Added:
states = Hashtbl.create 16;
25
Added:
app_feedback = [];
26
Added:
app_feedback_votes = [];
27
Added:
next_trainee = 1;
28
Added:
}
29
Added:
30
Added:
let state t id =
31
Added:
let key = Trainee.id_to_string id in
32
Added:
match Hashtbl.find_opt t.states key with
33
Added:
| Some s -> s
34
Added:
| None ->
35
Added:
let s =
36
Added:
{
37
Added:
active = None;
38
Added:
current = None;
39
Added:
stored = [];
40
Added:
feedback = [];
41
Added:
next_id = 1;
42
Added:
next_app_feedback = 1;
43
Added:
}
44
Added:
in
45
Added:
Hashtbl.replace t.states key s;
46
Added:
s
47
Added:
48
Added:
let create_trainee t ~(username : Trainee.username) ~credential =
49
Added:
match
50
Added:
List.find_opt
51
Added:
(fun (tr : Trainee.t) ->
52
Added:
String.equal
53
Added:
(Trainee.username_to_string tr.username)
54
Added:
(Trainee.username_to_string username))
55
Added:
t.trainees
56
Added:
with
57
Added:
| Some _ -> Lwt.return (Error `Username_taken)
58
Added:
| None ->
59
Added:
let id = Trainee.id (Printf.sprintf "t%d" t.next_trainee) in
60
Added:
t.next_trainee <- t.next_trainee + 1;
61
Added:
let trainee = { Trainee.id; username; credential } in
62
Added:
t.trainees <- trainee :: t.trainees;
63
Added:
Lwt.return (Ok trainee)
64
Added:
65
Added:
let find_trainee_by_username t (username : Trainee.username) =
66
Added:
Lwt.return
67
Added:
(List.find_opt
68
Added:
(fun (tr : Trainee.t) ->
69
Added:
String.equal
70
Added:
(Trainee.username_to_string tr.username)
71
Added:
(Trainee.username_to_string username))
72
Added:
t.trainees)
73
Added:
74
Added:
let find_trainee t id =
75
Added:
Lwt.return
76
Added:
(List.find_opt
77
Added:
(fun (tr : Trainee.t) ->
78
Added:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
79
Added:
t.trainees)
80
Added:
81
Added:
let replace_trainee t (updated : Trainee.t) =
82
Added:
t.trainees <-
83
Added:
List.map
84
Added:
(fun (tr : Trainee.t) ->
85
Added:
if
86
Added:
String.equal
87
Added:
(Trainee.id_to_string tr.id)
88
Added:
(Trainee.id_to_string updated.id)
89
Added:
then updated
90
Added:
else tr)
91
Added:
t.trainees
92
Added:
93
Added:
let update_username t id (username : Trainee.username) =
94
Added:
match
95
Added:
List.find_opt
96
Added:
(fun (tr : Trainee.t) ->
97
Added:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
98
Added:
t.trainees
99
Added:
with
100
Added:
| None -> Lwt.return (Error `Username_taken)
101
Added:
| Some current ->
102
Added:
let taken =
103
Added:
List.exists
104
Added:
(fun (tr : Trainee.t) ->
105
Added:
(not
106
Added:
(String.equal
107
Added:
(Trainee.id_to_string tr.id)
108
Added:
(Trainee.id_to_string id)))
109
Added:
&& String.equal
110
Added:
(Trainee.username_to_string tr.username)
111
Added:
(Trainee.username_to_string username))
112
Added:
t.trainees
113
Added:
in
114
Added:
if taken then Lwt.return (Error `Username_taken)
115
Added:
else begin
116
Added:
let updated = { current with Trainee.username } in
117
Added:
replace_trainee t updated;
118
Added:
Lwt.return (Ok updated)
119
Added:
end
120
Added:
121
Added:
let update_credential t id credential =
122
Added:
match
123
Added:
List.find_opt
124
Added:
(fun (tr : Trainee.t) ->
125
Added:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
126
Added:
t.trainees
127
Added:
with
128
Added:
| None -> Lwt.return None
129
Added:
| Some current ->
130
Added:
let updated = { current with Trainee.credential } in
131
Added:
replace_trainee t updated;
132
Added:
Lwt.return (Some updated)
133
Added:
134
Added:
let list_routines _ = Catalog.routines
135
Added:
let find_routine _ id = Catalog.find id
136
Added:
let active_routine t id = Lwt.return (state t id).active
137
Added:
138
Added:
let set_active_routine t id routine =
139
Added:
(state t id).active <- Some routine;
140
Added:
Lwt.return_unit
141
Added:
142
Added:
let in_progress t id = Lwt.return (state t id).current
143
Added:
144
Added:
let set_in_progress t id workout =
145
Added:
(state t id).current <- workout;
146
Added:
Lwt.return_unit
147
Added:
148
Added:
(* Store the finished workout and clear the in-progress slot together. In
149
Added:
memory this is a single synchronous update, so it cannot tear. *)
150
Added:
let finish_workout t id workout =
151
Added:
let s = state t id in
152
Added:
let wid = Repository.workout_id (Printf.sprintf "w%d" s.next_id) in
153
Added:
let record = { Repository.id = wid; workout } in
154
Added:
s.next_id <- s.next_id + 1;
155
Added:
s.stored <- record :: s.stored;
156
Added:
s.current <- None;
157
Added:
Lwt.return record
158
Added:
159
Added:
let equal_id (a : Repository.workout_id) (b : Repository.workout_id) =
160
Added:
String.equal (a :> string) (b :> string)
161
Added:
162
Added:
let find t id wid =
163
Added:
let s = state t id in
164
Added:
Lwt.return (List.find_opt (fun r -> equal_id r.Repository.id wid) s.stored)
165
Added:
166
Added:
let replace t id record =
167
Added:
let s = state t id in
168
Added:
if
169
Added:
not
170
Added:
(List.exists
171
Added:
(fun r -> equal_id r.Repository.id record.Repository.id)
172
Added:
s.stored)
173
Added:
then Lwt.return false
174
Added:
else begin
175
Added:
s.stored <-
176
Added:
List.map
177
Added:
(fun existing ->
178
Added:
if equal_id existing.Repository.id record.Repository.id then record
179
Added:
else existing)
180
Added:
s.stored;
181
Added:
Lwt.return true
182
Added:
end
183
Added:
184
Added:
let log t id =
185
Added:
let s = state t id in
186
Added:
Lwt.return
187
Added:
(List.fold_left
188
Added:
(fun log record -> Evidence.Log.add log record.Repository.workout)
189
Added:
Evidence.Log.empty (List.rev s.stored))
190
Added:
191
Added:
let history t id = Lwt.return (state t id).stored
192
Added:
193
Added:
let save_feedback t id report =
194
Added:
let s = state t id in
195
Added:
s.feedback <- report :: s.feedback;
196
Added:
Lwt.return_unit
197
Added:
198
Added:
let feedback t id = Lwt.return (state t id).feedback
199
Added:
200
Added:
let save_app_feedback t id ~submitted_at ~message =
201
Added:
let author =
202
Added:
match
203
Added:
List.find_opt
204
Added:
(fun (trainee : Trainee.t) ->
205
Added:
String.equal
206
Added:
(Trainee.id_to_string trainee.id)
207
Added:
(Trainee.id_to_string id))
208
Added:
t.trainees
209
Added:
with
210
Added:
| Some trainee -> Trainee.username_to_string trainee.username
211
Added:
| None -> ""
212
Added:
in
213
Added:
let contributions =
214
Added:
1
215
Added:
+ List.fold_left
216
Added:
(fun count (owner, _) ->
217
Added:
if String.equal (Trainee.id_to_string owner) (Trainee.id_to_string id)
218
Added:
then count + 1
219
Added:
else count)
220
Added:
0 t.app_feedback
221
Added:
in
222
Added:
let s = state t id in
223
Added:
let feedback_id =
224
Added:
Repository.app_feedback_id
225
Added:
(Printf.sprintf "%s:%d" (Trainee.id_to_string id) s.next_app_feedback)
226
Added:
in
227
Added:
s.next_app_feedback <- s.next_app_feedback + 1;
228
Added:
let report =
229
Added:
Repository.
230
Added:
{
231
Added:
feedback_id;
232
Added:
author;
233
Added:
contributions;
234
Added:
submitted_at;
235
Added:
message;
236
Added:
upvotes = 0;
237
Added:
viewer_upvoted = false;
238
Added:
viewer_owns = true;
239
Added:
}
240
Added:
in
241
Added:
t.app_feedback <- (id, report) :: t.app_feedback;
242
Added:
Lwt.return report
243
Added:
244
Added:
let app_feedback_id_parts report =
245
Added:
let raw =
246
Added:
Repository.app_feedback_id_to_string report.Repository.feedback_id
247
Added:
in
248
Added:
match String.rindex_opt raw ':' with
249
Added:
| None -> (raw, 0)
250
Added:
| Some separator ->
251
Added:
let owner = String.sub raw 0 separator in
252
Added:
let sequence =
253
Added:
String.sub raw (separator + 1) (String.length raw - separator - 1)
254
Added:
|> int_of_string_opt |> Option.value ~default:0
255
Added:
in
256
Added:
(owner, sequence)
257
Added:
258
Added:
let app_feedback t ~viewer =
259
Added:
let reports =
260
Added:
List.map
261
Added:
(fun (owner, report) ->
262
Added:
let owner_id = Trainee.id_to_string owner in
263
Added:
let contributions =
264
Added:
List.fold_left
265
Added:
(fun count (candidate, _) ->
266
Added:
if String.equal owner_id (Trainee.id_to_string candidate) then
267
Added:
count + 1
268
Added:
else count)
269
Added:
0 t.app_feedback
270
Added:
in
271
Added:
let author =
272
Added:
match
273
Added:
List.find_opt
274
Added:
(fun (trainee : Trainee.t) ->
275
Added:
String.equal owner_id (Trainee.id_to_string trainee.id))
276
Added:
t.trainees
277
Added:
with
278
Added:
| Some trainee -> Trainee.username_to_string trainee.username
279
Added:
| None -> report.Repository.author
280
Added:
in
281
Added:
let viewer_upvoted =
282
Added:
List.exists
283
Added:
(fun (feedback_id, voter) ->
284
Added:
String.equal
285
Added:
(Repository.app_feedback_id_to_string feedback_id)
286
Added:
(Repository.app_feedback_id_to_string
287
Added:
report.Repository.feedback_id)
288
Added:
&& String.equal
289
Added:
(Trainee.id_to_string voter)
290
Added:
(Trainee.id_to_string viewer))
291
Added:
t.app_feedback_votes
292
Added:
in
293
Added:
let viewer_owns = String.equal owner_id (Trainee.id_to_string viewer) in
294
Added:
{ report with author; contributions; viewer_upvoted; viewer_owns })
295
Added:
t.app_feedback
296
Added:
in
297
Added:
let compare left right =
298
Added:
let by_votes =
299
Added:
Int.compare right.Repository.upvotes left.Repository.upvotes
300
Added:
in
301
Added:
if by_votes <> 0 then by_votes
302
Added:
else
303
Added:
let by_time =
304
Added:
Int.compare
305
Added:
(Recovery.timestamp_to_unix_seconds right.submitted_at)
306
Added:
(Recovery.timestamp_to_unix_seconds left.submitted_at)
307
Added:
in
308
Added:
if by_time <> 0 then by_time
309
Added:
else
310
Added:
let left_owner, left_sequence = app_feedback_id_parts left in
311
Added:
let right_owner, right_sequence = app_feedback_id_parts right in
312
Added:
let by_owner = String.compare left_owner right_owner in
313
Added:
if by_owner <> 0 then by_owner
314
Added:
else Int.compare right_sequence left_sequence
315
Added:
in
316
Added:
Lwt.return (List.sort compare reports)
317
Added:
318
Added:
let upvote_app_feedback t ~voter feedback_id =
319
Added:
match
320
Added:
List.find_opt
321
Added:
(fun (_, report) ->
322
Added:
String.equal
323
Added:
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
324
Added:
(Repository.app_feedback_id_to_string feedback_id))
325
Added:
t.app_feedback
326
Added:
with
327
Added:
| None -> Lwt.return false
328
Added:
| Some (owner, _)
329
Added:
when String.equal (Trainee.id_to_string owner) (Trainee.id_to_string voter)
330
Added:
->
331
Added:
Lwt.return false
332
Added:
| Some (_, report) ->
333
Added:
if
334
Added:
List.exists
335
Added:
(fun (voted_feedback, existing_voter) ->
336
Added:
String.equal
337
Added:
(Repository.app_feedback_id_to_string voted_feedback)
338
Added:
(Repository.app_feedback_id_to_string feedback_id)
339
Added:
&& String.equal
340
Added:
(Trainee.id_to_string existing_voter)
341
Added:
(Trainee.id_to_string voter))
342
Added:
t.app_feedback_votes
343
Added:
then Lwt.return false
344
Added:
else begin
345
Added:
t.app_feedback_votes <- (feedback_id, voter) :: t.app_feedback_votes;
346
Added:
t.app_feedback <-
347
Added:
List.map
348
Added:
(fun (owner, current) ->
349
Added:
if
350
Added:
String.equal
351
Added:
(Repository.app_feedback_id_to_string
352
Added:
current.Repository.feedback_id)
353
Added:
(Repository.app_feedback_id_to_string
354
Added:
report.Repository.feedback_id)
355
Added:
then (owner, { current with upvotes = current.upvotes + 1 })
356
Added:
else (owner, current))
357
Added:
t.app_feedback;
358
Added:
Lwt.return true
359
Added:
end
360
Added:
361
Added:
let update_app_feedback t ~author id ~message =
362
Added:
let author_id = Trainee.id_to_string author in
363
Added:
let updated = ref false in
364
Added:
t.app_feedback <-
365
Added:
List.map
366
Added:
(fun (owner, report) ->
367
Added:
if
368
Added:
String.equal (Trainee.id_to_string owner) author_id
369
Added:
&& String.equal
370
Added:
(Repository.app_feedback_id_to_string
371
Added:
report.Repository.feedback_id)
372
Added:
(Repository.app_feedback_id_to_string id)
373
Added:
then begin
374
Added:
updated := true;
375
Added:
(owner, { report with message })
376
Added:
end
377
Added:
else (owner, report))
378
Added:
t.app_feedback;
379
Added:
Lwt.return !updated
380
Added:
381
Added:
let delete_app_feedback t ~author id =
382
Added:
let author_id = Trainee.id_to_string author in
383
Added:
let owned (owner, report) =
384
Added:
String.equal (Trainee.id_to_string owner) author_id
385
Added:
&& String.equal
386
Added:
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
387
Added:
(Repository.app_feedback_id_to_string id)
388
Added:
in
389
Added:
let removed = List.exists owned t.app_feedback in
390
Added:
if removed then begin
391
Added:
t.app_feedback <- List.filter (fun item -> not (owned item)) t.app_feedback;
392
Added:
t.app_feedback_votes <-
393
Added:
List.filter
394
Added:
(fun (feedback_id, _) ->
395
Added:
not
396
Added:
(String.equal
397
Added:
(Repository.app_feedback_id_to_string feedback_id)
398
Added:
(Repository.app_feedback_id_to_string id)))
399
Added:
t.app_feedback_votes
400
Added:
end;
401
Added:
Lwt.return removed
lib/persistence/memory_repo.mli
@@ -0,0 +1,8 @@
1
Added:
(** In-memory {!Repository.S} for tests. Nothing survives a restart, and it is
2
Added:
never used in production — durable storage is {!Sqlite_repo}. *)
3
Added:
4
Added:
open Hito_app
5
Added:
include Repository.S
6
Added:
7
Added:
val create : unit -> t
8
Added:
(** Seeded with the shared routine catalog. *)
lib/persistence/migrations.ml
@@ -0,0 +1,231 @@
1
Added:
type migration = { version : int; name : string; statements : string list }
2
Added:
3
Added:
let migrations =
4
Added:
[
5
Added:
{
6
Added:
version = 1;
7
Added:
name = "initial schema";
8
Added:
statements =
9
Added:
[
10
Added:
{|CREATE TABLE IF NOT EXISTS trainee (
11
Added:
id TEXT PRIMARY KEY,
12
Added:
username TEXT NOT NULL UNIQUE,
13
Added:
credential TEXT NOT NULL
14
Added:
)|};
15
Added:
{|CREATE TABLE IF NOT EXISTS active_routine (
16
Added:
trainee_id TEXT PRIMARY KEY,
17
Added:
routine_id TEXT NOT NULL
18
Added:
)|};
19
Added:
{|CREATE TABLE IF NOT EXISTS in_progress (
20
Added:
trainee_id TEXT PRIMARY KEY,
21
Added:
encoded TEXT NOT NULL
22
Added:
)|};
23
Added:
{|CREATE TABLE IF NOT EXISTS workout (
24
Added:
id TEXT PRIMARY KEY,
25
Added:
trainee_id TEXT NOT NULL,
26
Added:
seq INTEGER NOT NULL,
27
Added:
encoded TEXT NOT NULL
28
Added:
)|};
29
Added:
{|CREATE INDEX IF NOT EXISTS workout_by_trainee
30
Added:
ON workout (trainee_id, seq DESC)|};
31
Added:
(* The table Dream's sql_sessions back end expects. *)
32
Added:
{|CREATE TABLE IF NOT EXISTS dream_session (
33
Added:
id TEXT PRIMARY KEY,
34
Added:
label TEXT NOT NULL,
35
Added:
expires_at REAL NOT NULL,
36
Added:
payload TEXT NOT NULL
37
Added:
)|};
38
Added:
];
39
Added:
};
40
Added:
{
41
Added:
version = 2;
42
Added:
name = "subjective feedback";
43
Added:
statements =
44
Added:
[
45
Added:
{|CREATE TABLE IF NOT EXISTS feedback (
46
Added:
trainee_id TEXT NOT NULL,
47
Added:
seq INTEGER NOT NULL,
48
Added:
encoded TEXT NOT NULL,
49
Added:
PRIMARY KEY (trainee_id, seq)
50
Added:
)|};
51
Added:
{|CREATE INDEX IF NOT EXISTS feedback_by_trainee
52
Added:
ON feedback (trainee_id, seq DESC)|};
53
Added:
];
54
Added:
};
55
Added:
{
56
Added:
version = 3;
57
Added:
name = "application feedback";
58
Added:
statements =
59
Added:
[
60
Added:
{|CREATE TABLE IF NOT EXISTS app_feedback (
61
Added:
trainee_id TEXT NOT NULL,
62
Added:
seq INTEGER NOT NULL,
63
Added:
submitted_at TEXT NOT NULL,
64
Added:
message TEXT NOT NULL,
65
Added:
PRIMARY KEY (trainee_id, seq)
66
Added:
)|};
67
Added:
{|CREATE INDEX IF NOT EXISTS app_feedback_by_trainee
68
Added:
ON app_feedback (trainee_id, seq DESC)|};
69
Added:
];
70
Added:
};
71
Added:
{
72
Added:
version = 4;
73
Added:
name = "application feedback votes";
74
Added:
statements =
75
Added:
[
76
Added:
{|CREATE TABLE IF NOT EXISTS app_feedback_vote (
77
Added:
feedback_trainee_id TEXT NOT NULL,
78
Added:
feedback_seq INTEGER NOT NULL,
79
Added:
voter_id TEXT NOT NULL,
80
Added:
PRIMARY KEY (feedback_trainee_id, feedback_seq, voter_id)
81
Added:
)|};
82
Added:
{|CREATE INDEX IF NOT EXISTS app_feedback_vote_by_voter
83
Added:
ON app_feedback_vote (voter_id)|};
84
Added:
];
85
Added:
};
86
Added:
{
87
Added:
version = 5;
88
Added:
name = "ISO 8601 UTC timestamps";
89
Added:
statements =
90
Added:
[
91
Added:
{|DROP TABLE IF EXISTS app_feedback_vote|};
92
Added:
{|DROP TABLE IF EXISTS app_feedback|};
93
Added:
{|DROP TABLE IF EXISTS feedback|};
94
Added:
{|DROP TABLE IF EXISTS workout|};
95
Added:
{|DROP TABLE IF EXISTS in_progress|};
96
Added:
{|CREATE TABLE IF NOT EXISTS in_progress (
97
Added:
trainee_id TEXT PRIMARY KEY,
98
Added:
encoded TEXT NOT NULL
99
Added:
)|};
100
Added:
{|CREATE TABLE IF NOT EXISTS workout (
101
Added:
id TEXT PRIMARY KEY,
102
Added:
trainee_id TEXT NOT NULL,
103
Added:
seq INTEGER NOT NULL,
104
Added:
encoded TEXT NOT NULL
105
Added:
)|};
106
Added:
{|CREATE INDEX IF NOT EXISTS workout_by_trainee
107
Added:
ON workout (trainee_id, seq DESC)|};
108
Added:
{|CREATE TABLE IF NOT EXISTS feedback (
109
Added:
trainee_id TEXT NOT NULL,
110
Added:
seq INTEGER NOT NULL,
111
Added:
encoded TEXT NOT NULL,
112
Added:
PRIMARY KEY (trainee_id, seq)
113
Added:
)|};
114
Added:
{|CREATE INDEX IF NOT EXISTS feedback_by_trainee
115
Added:
ON feedback (trainee_id, seq DESC)|};
116
Added:
{|CREATE TABLE IF NOT EXISTS app_feedback (
117
Added:
trainee_id TEXT NOT NULL,
118
Added:
seq INTEGER NOT NULL,
119
Added:
submitted_at TEXT NOT NULL,
120
Added:
message TEXT NOT NULL,
121
Added:
PRIMARY KEY (trainee_id, seq)
122
Added:
)|};
123
Added:
{|CREATE INDEX IF NOT EXISTS app_feedback_by_trainee
124
Added:
ON app_feedback (trainee_id, seq DESC)|};
125
Added:
{|CREATE TABLE IF NOT EXISTS app_feedback_vote (
126
Added:
feedback_trainee_id TEXT NOT NULL,
127
Added:
feedback_seq INTEGER NOT NULL,
128
Added:
voter_id TEXT NOT NULL,
129
Added:
PRIMARY KEY (feedback_trainee_id, feedback_seq, voter_id)
130
Added:
)|};
131
Added:
{|CREATE INDEX IF NOT EXISTS app_feedback_vote_by_voter
132
Added:
ON app_feedback_vote (voter_id)|};
133
Added:
];
134
Added:
};
135
Added:
{
136
Added:
version = 6;
137
Added:
name = "five-point feedback scores";
138
Added:
(* Subjective feedback now encodes levels as scores 1..5, so rows written
139
Added:
with the old below/usual/above codes no longer decode. Feedback is
140
Added:
observed, not authored, so the domain permits dropping it rather than
141
Added:
migrating it. *)
142
Added:
statements =
143
Added:
[
144
Added:
{|DROP TABLE IF EXISTS feedback|};
145
Added:
{|CREATE TABLE IF NOT EXISTS feedback (
146
Added:
trainee_id TEXT NOT NULL,
147
Added:
seq INTEGER NOT NULL,
148
Added:
encoded TEXT NOT NULL,
149
Added:
PRIMARY KEY (trainee_id, seq)
150
Added:
)|};
151
Added:
{|CREATE INDEX IF NOT EXISTS feedback_by_trainee
152
Added:
ON feedback (trainee_id, seq DESC)|};
153
Added:
];
154
Added:
};
155
Added:
]
156
Added:
157
Added:
(* The ledger of applied migrations. A row per version, so a reconnect knows
158
Added:
what the file already carries and skips it. *)
159
Added:
let ledger =
160
Added:
{|CREATE TABLE IF NOT EXISTS schema_migrations (
161
Added:
version INTEGER PRIMARY KEY,
162
Added:
name TEXT NOT NULL,
163
Added:
applied_at REAL NOT NULL
164
Added:
)|}
165
Added:
166
Added:
let statements =
167
Added:
List.concat_map (fun migration -> migration.statements) migrations
168
Added:
169
Added:
(* --- request helpers --- *)
170
Added:
171
Added:
let exec_sql (module Db : Caqti_lwt.CONNECTION) sql =
172
Added:
let request =
173
Added:
let open Caqti_request.Infix in
174
Added:
let open Caqti_type.Std in
175
Added:
(unit ->. unit) ~oneshot:true sql
176
Added:
in
177
Added:
Db.exec request ()
178
Added:
179
Added:
let is_applied (module Db : Caqti_lwt.CONNECTION) version =
180
Added:
let request =
181
Added:
let open Caqti_request.Infix in
182
Added:
let open Caqti_type.Std in
183
Added:
(int ->! int) ~oneshot:true
184
Added:
"SELECT COUNT(*) FROM schema_migrations WHERE version = ?"
185
Added:
in
186
Added:
Db.find request version
187
Added:
188
Added:
let record_applied (module Db : Caqti_lwt.CONNECTION) migration =
189
Added:
let request =
190
Added:
let open Caqti_request.Infix in
191
Added:
let open Caqti_type.Std in
192
Added:
(t2 int string ->. unit)
193
Added:
~oneshot:true
194
Added:
"INSERT INTO schema_migrations (version, name, applied_at) VALUES (?, ?, \
195
Added:
strftime('%s','now'))"
196
Added:
in
197
Added:
Db.exec request (migration.version, migration.name)
198
Added:
199
Added:
(* Apply one migration inside a transaction, then record it. The ledger check
200
Added:
makes this idempotent; the [IF NOT EXISTS] clauses keep an already-populated
201
Added:
file from a pre-ledger build safe. *)
202
Added:
let apply_migration ((module Db : Caqti_lwt.CONNECTION) as db) migration =
203
Added:
let open Lwt_result.Syntax in
204
Added:
let* applied = is_applied db migration.version in
205
Added:
if applied > 0 then Lwt_result.return ()
206
Added:
else
207
Added:
Db.with_transaction (fun () ->
208
Added:
let rec go = function
209
Added:
| [] -> record_applied db migration
210
Added:
| sql :: tl ->
211
Added:
let* () = exec_sql db sql in
212
Added:
go tl
213
Added:
in
214
Added:
go migration.statements)
215
Added:
216
Added:
let apply (module Db : Caqti_lwt.CONNECTION) =
217
Added:
let db = (module Db : Caqti_lwt.CONNECTION) in
218
Added:
let open Lwt_result.Syntax in
219
Added:
let run =
220
Added:
let* () = exec_sql db ledger in
221
Added:
let rec go = function
222
Added:
| [] -> Lwt_result.return ()
223
Added:
| migration :: tl ->
224
Added:
let* () = apply_migration db migration in
225
Added:
go tl
226
Added:
in
227
Added:
go migrations
228
Added:
in
229
Added:
Lwt.map
230
Added:
(function Ok () -> Ok () | Error e -> Error (e :> Caqti_error.t))
231
Added:
run
lib/persistence/migrations.mli
@@ -0,0 +1,24 @@
1
Added:
(** Versioned schema migrations for the SQLite store.
2
Added:
3
Added:
Each migration is a numbered, named set of statements. A [schema_migrations]
4
Added:
ledger records which versions a database file already carries, so applying
5
Added:
on connect runs only the migrations the file is missing and never repeats
6
Added:
one. Every statement still uses [IF NOT EXISTS], so a database created by an
7
Added:
earlier, ledger-less build stays safe.
8
Added:
9
Added:
Includes the [dream_session] table {!Dream.sql_sessions} expects. *)
10
Added:
11
Added:
type migration = { version : int; name : string; statements : string list }
12
Added:
(** One migration: a version, a human name, and the ordered statements it runs.
13
Added:
*)
14
Added:
15
Added:
val migrations : migration list
16
Added:
(** Every migration, in ascending version order. *)
17
Added:
18
Added:
val apply : (module Caqti_lwt.CONNECTION) -> (unit, Caqti_error.t) result Lwt.t
19
Added:
(** Create the ledger, then apply every migration not yet recorded, each inside
20
Added:
a transaction. Idempotent across reconnects. *)
21
Added:
22
Added:
val statements : string list
23
Added:
(** Every migration's statements, in order, exposed for documentation and tests.
24
Added:
*)
lib/persistence/sqlite_repo.ml
@@ -0,0 +1,479 @@
1
Added:
open Lwt.Infix
2
Added:
open Hito_app
3
Added:
4
Added:
exception Corrupt of Codec.error
5
Added:
6
Added:
type t = {
7
Added:
pool : (Caqti_lwt.connection, Caqti_error.t) Caqti_lwt_unix.Pool.t;
8
Added:
mutable next_trainee : int;
9
Added:
}
10
Added:
11
Added:
(* --- request definitions --- *)
12
Added:
13
Added:
module Q = struct
14
Added:
open Caqti_request.Infix
15
Added:
open Caqti_type.Std
16
Added:
17
Added:
let insert_trainee =
18
Added:
(t3 string string string ->. unit)
19
Added:
"INSERT INTO trainee (id, username, credential) VALUES (?, ?, ?)"
20
Added:
21
Added:
let trainee_by_username =
22
Added:
(string ->? t3 string string string)
23
Added:
"SELECT id, username, credential FROM trainee WHERE username = ?"
24
Added:
25
Added:
let trainee_by_id =
26
Added:
(string ->? t3 string string string)
27
Added:
"SELECT id, username, credential FROM trainee WHERE id = ?"
28
Added:
29
Added:
let next_trainee =
30
Added:
(unit ->! int)
31
Added:
"SELECT COALESCE(MAX(CAST(SUBSTR(id, 2) AS INTEGER)), 0) + 1 FROM \
32
Added:
trainee WHERE id GLOB 't[0-9]*'"
33
Added:
34
Added:
let update_username =
35
Added:
(t2 string string ->. unit) "UPDATE trainee SET username = ? WHERE id = ?"
36
Added:
37
Added:
let update_credential =
38
Added:
(t2 string string ->. unit) "UPDATE trainee SET credential = ? WHERE id = ?"
39
Added:
40
Added:
let get_active =
41
Added:
(string ->? string)
42
Added:
"SELECT routine_id FROM active_routine WHERE trainee_id = ?"
43
Added:
44
Added:
let set_active =
45
Added:
(t2 string string ->. unit)
46
Added:
"INSERT INTO active_routine (trainee_id, routine_id) VALUES (?, ?) ON \
47
Added:
CONFLICT (trainee_id) DO UPDATE SET routine_id = excluded.routine_id"
48
Added:
49
Added:
let get_in_progress =
50
Added:
(string ->? string) "SELECT encoded FROM in_progress WHERE trainee_id = ?"
51
Added:
52
Added:
let set_in_progress =
53
Added:
(t2 string string ->. unit)
54
Added:
"INSERT INTO in_progress (trainee_id, encoded) VALUES (?, ?) ON CONFLICT \
55
Added:
(trainee_id) DO UPDATE SET encoded = excluded.encoded"
56
Added:
57
Added:
let clear_in_progress =
58
Added:
(string ->. unit) "DELETE FROM in_progress WHERE trainee_id = ?"
59
Added:
60
Added:
let next_seq =
61
Added:
(string ->! int)
62
Added:
"SELECT COALESCE(MAX(seq), 0) + 1 FROM workout WHERE trainee_id = ?"
63
Added:
64
Added:
let insert_workout =
65
Added:
(t4 string string int string ->. unit)
66
Added:
"INSERT INTO workout (id, trainee_id, seq, encoded) VALUES (?, ?, ?, ?)"
67
Added:
68
Added:
let workout_by_id =
69
Added:
(t2 string string ->? string)
70
Added:
"SELECT encoded FROM workout WHERE trainee_id = ? AND id = ?"
71
Added:
72
Added:
let update_workout =
73
Added:
(t3 string string string ->. unit)
74
Added:
"UPDATE workout SET encoded = ? WHERE trainee_id = ? AND id = ?"
75
Added:
76
Added:
let history =
77
Added:
(string ->* t2 string string)
78
Added:
"SELECT id, encoded FROM workout WHERE trainee_id = ? ORDER BY seq DESC"
79
Added:
80
Added:
let next_feedback_seq =
81
Added:
(string ->! int)
82
Added:
"SELECT COALESCE(MAX(seq), 0) + 1 FROM feedback WHERE trainee_id = ?"
83
Added:
84
Added:
let insert_feedback =
85
Added:
(t3 string int string ->. unit)
86
Added:
"INSERT INTO feedback (trainee_id, seq, encoded) VALUES (?, ?, ?)"
87
Added:
88
Added:
let feedback =
89
Added:
(string ->* string)
90
Added:
"SELECT encoded FROM feedback WHERE trainee_id = ? ORDER BY seq DESC"
91
Added:
92
Added:
let next_app_feedback_seq =
93
Added:
(string ->! int)
94
Added:
"SELECT COALESCE(MAX(seq), 0) + 1 FROM app_feedback WHERE trainee_id = ?"
95
Added:
96
Added:
let insert_app_feedback =
97
Added:
(t4 string int string string ->. unit)
98
Added:
"INSERT INTO app_feedback (trainee_id, seq, submitted_at, message) \
99
Added:
VALUES (?, ?, ?, ?)"
100
Added:
101
Added:
let app_feedback =
102
Added:
(unit ->* t7 string int string string string int int)
103
Added:
"SELECT f.trainee_id, f.seq, t.username, f.submitted_at, f.message, \
104
Added:
(SELECT COUNT(*) FROM app_feedback c WHERE c.trainee_id = \
105
Added:
f.trainee_id), (SELECT COUNT(*) FROM app_feedback_vote v WHERE \
106
Added:
v.feedback_trainee_id = f.trainee_id AND v.feedback_seq = f.seq) FROM \
107
Added:
app_feedback f JOIN trainee t ON t.id = f.trainee_id ORDER BY 7 DESC, \
108
Added:
f.submitted_at DESC, f.trainee_id, f.seq DESC"
109
Added:
110
Added:
let viewer_votes =
111
Added:
(string ->* t2 string int)
112
Added:
"SELECT feedback_trainee_id, feedback_seq FROM app_feedback_vote WHERE \
113
Added:
voter_id = ?"
114
Added:
115
Added:
let feedback_owner =
116
Added:
(t2 string int ->? string)
117
Added:
"SELECT trainee_id FROM app_feedback WHERE trainee_id = ? AND seq = ?"
118
Added:
119
Added:
let vote_exists =
120
Added:
(t3 string int string ->? int)
121
Added:
"SELECT 1 FROM app_feedback_vote WHERE feedback_trainee_id = ? AND \
122
Added:
feedback_seq = ? AND voter_id = ?"
123
Added:
124
Added:
let insert_vote =
125
Added:
(t3 string int string ->. unit)
126
Added:
"INSERT INTO app_feedback_vote (feedback_trainee_id, feedback_seq, \
127
Added:
voter_id) VALUES (?, ?, ?)"
128
Added:
129
Added:
let update_app_feedback =
130
Added:
(t3 string string int ->. unit)
131
Added:
"UPDATE app_feedback SET message = ? WHERE trainee_id = ? AND seq = ?"
132
Added:
133
Added:
let delete_feedback_votes =
134
Added:
(t2 string int ->. unit)
135
Added:
"DELETE FROM app_feedback_vote WHERE feedback_trainee_id = ? AND \
136
Added:
feedback_seq = ?"
137
Added:
138
Added:
let delete_app_feedback =
139
Added:
(t2 string int ->. unit)
140
Added:
"DELETE FROM app_feedback WHERE trainee_id = ? AND seq = ?"
141
Added:
end
142
Added:
143
Added:
(* --- pool helper --- *)
144
Added:
145
Added:
let run t f = Caqti_lwt_unix.Pool.use f t.pool >>= Caqti_lwt.or_fail
146
Added:
147
Added:
let connect uri =
148
Added:
match Caqti_lwt_unix.connect_pool (Uri.of_string uri) with
149
Added:
| Error e -> Lwt.return (Error (e :> Caqti_error.t))
150
Added:
| Ok pool ->
151
Added:
let open Lwt_result.Syntax in
152
Added:
let* () = Caqti_lwt_unix.Pool.use Migrations.apply pool in
153
Added:
let* next_trainee =
154
Added:
Caqti_lwt_unix.Pool.use
155
Added:
(fun (module Db : Caqti_lwt.CONNECTION) -> Db.find Q.next_trainee ())
156
Added:
pool
157
Added:
in
158
Added:
Lwt_result.return { pool; next_trainee }
159
Added:
160
Added:
(* --- decoding stored workouts --- *)
161
Added:
162
Added:
let find_routine_by_name = Catalog.find_by_name
163
Added:
164
Added:
let decode encoded =
165
Added:
match Codec.decode_workout ~find_routine:find_routine_by_name encoded with
166
Added:
| Ok workout -> workout
167
Added:
| Error e -> raise (Corrupt e)
168
Added:
169
Added:
(* --- accounts --- *)
170
Added:
171
Added:
let create_trainee t ~username ~credential =
172
Added:
let username_s = Trainee.username_to_string username in
173
Added:
let credential_s = Trainee.credential_to_hash credential in
174
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
175
Added:
Db.find_opt Q.trainee_by_username username_s)
176
Added:
>>= function
177
Added:
| Some _ -> Lwt.return (Error `Username_taken)
178
Added:
| None ->
179
Added:
let id = Printf.sprintf "t%d" t.next_trainee in
180
Added:
t.next_trainee <- t.next_trainee + 1;
181
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
182
Added:
Db.exec Q.insert_trainee (id, username_s, credential_s))
183
Added:
>|= fun () -> Ok { Trainee.id = Trainee.id id; username; credential }
184
Added:
185
Added:
let trainee_of_row (id, username, credential) =
186
Added:
match Trainee.username username with
187
Added:
| Ok username ->
188
Added:
Some
189
Added:
{
190
Added:
Trainee.id = Trainee.id id;
191
Added:
username;
192
Added:
credential = Trainee.credential_of_hash credential;
193
Added:
}
194
Added:
| Error _ -> None
195
Added:
196
Added:
let find_trainee_by_username t username =
197
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
198
Added:
Db.find_opt Q.trainee_by_username (Trainee.username_to_string username))
199
Added:
>|= function
200
Added:
| Some row -> trainee_of_row row
201
Added:
| None -> None
202
Added:
203
Added:
let find_trainee t id =
204
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
205
Added:
Db.find_opt Q.trainee_by_id (Trainee.id_to_string id))
206
Added:
>|= function
207
Added:
| Some row -> trainee_of_row row
208
Added:
| None -> None
209
Added:
210
Added:
(* Rename in one transaction: check the name is free for anyone else, then
211
Added:
update. Running both on the same connection keeps the check and the write
212
Added:
from racing another rename. The trainee's own current name is a no-op. *)
213
Added:
let update_username t id (username : Trainee.username) =
214
Added:
let trainee = Trainee.id_to_string id in
215
Added:
let username_s = Trainee.username_to_string username in
216
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
217
Added:
let open Lwt_result.Syntax in
218
Added:
Db.with_transaction (fun () ->
219
Added:
let* holder = Db.find_opt Q.trainee_by_username username_s in
220
Added:
match holder with
221
Added:
| Some (holder_id, _, _) when not (String.equal holder_id trainee) ->
222
Added:
Lwt_result.return (Error `Username_taken)
223
Added:
| _ ->
224
Added:
let* () = Db.exec Q.update_username (username_s, trainee) in
225
Added:
let* row = Db.find_opt Q.trainee_by_id trainee in
226
Added:
Lwt_result.return
227
Added:
(match Option.bind row trainee_of_row with
228
Added:
| Some updated -> Ok updated
229
Added:
| None -> Error `Username_taken)))
230
Added:
231
Added:
let update_credential t id credential =
232
Added:
let trainee = Trainee.id_to_string id in
233
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
234
Added:
Db.exec Q.update_credential
235
Added:
(Trainee.credential_to_hash credential, trainee))
236
Added:
>>= fun () -> find_trainee t id
237
Added:
238
Added:
(* --- catalog --- *)
239
Added:
240
Added:
let list_routines _ = Catalog.routines
241
Added:
let find_routine _ id = Catalog.find id
242
Added:
243
Added:
(* The routine name a workout's prescription belongs to, for encoding. Only the
244
Added:
ideal routine exists, but resolve it honestly rather than hard-code. *)
245
Added:
let routine_name_of workout =
246
Added:
let workout_name =
247
Added:
Prescription.Workout.name (Evidence.Workout.prescription workout)
248
Added:
in
249
Added:
List.find_map
250
Added:
(fun (_, routine) ->
251
Added:
if
252
Added:
List.exists
253
Added:
(fun w -> String.equal (Prescription.Workout.name w) workout_name)
254
Added:
(Prescription.Routine.workouts routine)
255
Added:
then Some (Prescription.Routine.name routine)
256
Added:
else None)
257
Added:
Catalog.routines
258
Added:
|> Option.value ~default:""
259
Added:
260
Added:
let encode workout =
261
Added:
Codec.encode_workout ~routine_name:(routine_name_of workout) workout
262
Added:
263
Added:
(* --- per-trainee selection and workout in progress --- *)
264
Added:
265
Added:
let active_routine t id =
266
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
267
Added:
Db.find_opt Q.get_active (Trainee.id_to_string id))
268
Added:
>|= Option.map Repository.routine_id
269
Added:
270
Added:
let set_active_routine t id (routine : Repository.routine_id) =
271
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
272
Added:
Db.exec Q.set_active (Trainee.id_to_string id, (routine :> string)))
273
Added:
274
Added:
let in_progress t id =
275
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
276
Added:
Db.find_opt Q.get_in_progress (Trainee.id_to_string id))
277
Added:
>|= function
278
Added:
| None -> None
279
Added:
| Some encoded -> Some (decode encoded)
280
Added:
281
Added:
let set_in_progress t id workout =
282
Added:
let trainee = Trainee.id_to_string id in
283
Added:
match workout with
284
Added:
| None ->
285
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
286
Added:
Db.exec Q.clear_in_progress trainee)
287
Added:
| Some workout ->
288
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
289
Added:
Db.exec Q.set_in_progress (trainee, encode workout))
290
Added:
291
Added:
(* --- history --- *)
292
Added:
293
Added:
(* Save a finished workout and clear the in-progress slot in one transaction,
294
Added:
so the two rows never disagree after a crash. Both statements run on the same
295
Added:
connection, checked out once, inside [with_transaction]. *)
296
Added:
let finish_workout t id workout =
297
Added:
let trainee = Trainee.id_to_string id in
298
Added:
let encoded = encode workout in
299
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
300
Added:
let open Lwt_result.Syntax in
301
Added:
Db.with_transaction (fun () ->
302
Added:
let* seq = Db.find Q.next_seq trainee in
303
Added:
let wid = Printf.sprintf "%s:w%d" trainee seq in
304
Added:
let* () = Db.exec Q.insert_workout (wid, trainee, seq, encoded) in
305
Added:
let* () = Db.exec Q.clear_in_progress trainee in
306
Added:
Lwt_result.return
307
Added:
{ Repository.id = Repository.workout_id wid; workout }))
308
Added:
309
Added:
let find t id (wid : Repository.workout_id) =
310
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
311
Added:
Db.find_opt Q.workout_by_id (Trainee.id_to_string id, (wid :> string)))
312
Added:
>|= function
313
Added:
| None -> None
314
Added:
| Some encoded -> Some { Repository.id = wid; workout = decode encoded }
315
Added:
316
Added:
let replace t id record =
317
Added:
let trainee = Trainee.id_to_string id in
318
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
319
Added:
Db.find_opt Q.workout_by_id (trainee, (record.Repository.id :> string)))
320
Added:
>>= function
321
Added:
| None -> Lwt.return false
322
Added:
| Some _ ->
323
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
324
Added:
Db.exec Q.update_workout
325
Added:
( encode record.Repository.workout,
326
Added:
trainee,
327
Added:
(record.Repository.id :> string) ))
328
Added:
>|= fun () -> true
329
Added:
330
Added:
let history t id =
331
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
332
Added:
Db.collect_list Q.history (Trainee.id_to_string id))
333
Added:
>|= fun rows ->
334
Added:
List.map
335
Added:
(fun (wid, encoded) ->
336
Added:
{ Repository.id = Repository.workout_id wid; workout = decode encoded })
337
Added:
rows
338
Added:
339
Added:
let log t id =
340
Added:
history t id >|= fun records ->
341
Added:
List.fold_left
342
Added:
(fun log record -> Evidence.Log.add log record.Repository.workout)
343
Added:
Evidence.Log.empty (List.rev records)
344
Added:
345
Added:
(* --- subjective feedback --- *)
346
Added:
347
Added:
let save_feedback t id report =
348
Added:
let trainee = Trainee.id_to_string id in
349
Added:
let encoded = Codec.encode_feedback report in
350
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
351
Added:
Db.find Q.next_feedback_seq trainee)
352
Added:
>>= fun seq ->
353
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
354
Added:
Db.exec Q.insert_feedback (trainee, seq, encoded))
355
Added:
356
Added:
let decode_feedback encoded =
357
Added:
match Codec.decode_feedback encoded with
358
Added:
| Ok report -> report
359
Added:
| Error e -> raise (Corrupt e)
360
Added:
361
Added:
let feedback t id =
362
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
363
Added:
Db.collect_list Q.feedback (Trainee.id_to_string id))
364
Added:
>|= List.map decode_feedback
365
Added:
366
Added:
let save_app_feedback t id ~submitted_at ~message =
367
Added:
let trainee = Trainee.id_to_string id in
368
Added:
find_trainee t id >>= function
369
Added:
| None ->
370
Added:
Lwt.fail_with "cannot save application feedback for an unknown trainee"
371
Added:
| Some author ->
372
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
373
Added:
Db.find Q.next_app_feedback_seq trainee)
374
Added:
>>= fun seq ->
375
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
376
Added:
Db.exec Q.insert_app_feedback
377
Added:
(trainee, seq, Timestamp.encode submitted_at, message))
378
Added:
>|= fun () ->
379
Added:
Repository.
380
Added:
{
381
Added:
feedback_id = app_feedback_id (Printf.sprintf "%s:%d" trainee seq);
382
Added:
author = Trainee.username_to_string author.Trainee.username;
383
Added:
contributions = seq;
384
Added:
submitted_at;
385
Added:
message;
386
Added:
upvotes = 0;
387
Added:
viewer_upvoted = false;
388
Added:
viewer_owns = true;
389
Added:
}
390
Added:
391
Added:
let app_feedback t ~viewer =
392
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
393
Added:
Db.collect_list Q.app_feedback ())
394
Added:
>>= fun rows ->
395
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
396
Added:
Db.collect_list Q.viewer_votes (Trainee.id_to_string viewer))
397
Added:
>|= fun voted ->
398
Added:
List.map
399
Added:
(fun (trainee, seq, author, submitted_at, message, contributions, upvotes)
400
Added:
->
401
Added:
let submitted_at =
402
Added:
match Timestamp.decode submitted_at with
403
Added:
| Ok timestamp -> timestamp
404
Added:
| Error _ ->
405
Added:
raise (Corrupt (Codec.Malformed "application feedback timestamp"))
406
Added:
in
407
Added:
Repository.
408
Added:
{
409
Added:
feedback_id = app_feedback_id (Printf.sprintf "%s:%d" trainee seq);
410
Added:
author;
411
Added:
contributions;
412
Added:
submitted_at;
413
Added:
message;
414
Added:
upvotes;
415
Added:
viewer_upvoted = List.mem (trainee, seq) voted;
416
Added:
viewer_owns = String.equal trainee (Trainee.id_to_string viewer);
417
Added:
})
418
Added:
rows
419
Added:
420
Added:
let split_app_feedback_id id =
421
Added:
let raw = Repository.app_feedback_id_to_string id in
422
Added:
match String.rindex_opt raw ':' with
423
Added:
| None -> None
424
Added:
| Some separator ->
425
Added:
let trainee = String.sub raw 0 separator in
426
Added:
let seq_start = separator + 1 in
427
Added:
let seq_length = String.length raw - seq_start in
428
Added:
Option.map
429
Added:
(fun seq -> (trainee, seq))
430
Added:
(int_of_string_opt (String.sub raw seq_start seq_length))
431
Added:
432
Added:
let upvote_app_feedback t ~voter id =
433
Added:
match split_app_feedback_id id with
434
Added:
| None -> Lwt.return false
435
Added:
| Some (trainee, seq) -> (
436
Added:
let voter = Trainee.id_to_string voter in
437
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
438
Added:
Db.find_opt Q.feedback_owner (trainee, seq))
439
Added:
>>= function
440
Added:
| None -> Lwt.return false
441
Added:
| Some owner when String.equal owner voter -> Lwt.return false
442
Added:
| Some _ -> (
443
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
444
Added:
Db.find_opt Q.vote_exists (trainee, seq, voter))
445
Added:
>>= function
446
Added:
| Some _ -> Lwt.return false
447
Added:
| None ->
448
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
449
Added:
Db.exec Q.insert_vote (trainee, seq, voter))
450
Added:
>|= fun () -> true))
451
Added:
452
Added:
let update_app_feedback t ~author id ~message =
453
Added:
match split_app_feedback_id id with
454
Added:
| None -> Lwt.return false
455
Added:
| Some (trainee, seq) -> (
456
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
457
Added:
Db.find_opt Q.feedback_owner (trainee, seq))
458
Added:
>>= function
459
Added:
| Some owner when String.equal owner (Trainee.id_to_string author) ->
460
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
461
Added:
Db.exec Q.update_app_feedback (message, trainee, seq))
462
Added:
>|= fun () -> true
463
Added:
| _ -> Lwt.return false)
464
Added:
465
Added:
let delete_app_feedback t ~author id =
466
Added:
match split_app_feedback_id id with
467
Added:
| None -> Lwt.return false
468
Added:
| Some (trainee, seq) -> (
469
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
470
Added:
Db.find_opt Q.feedback_owner (trainee, seq))
471
Added:
>>= function
472
Added:
| Some owner when String.equal owner (Trainee.id_to_string author) ->
473
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
474
Added:
Db.exec Q.delete_feedback_votes (trainee, seq))
475
Added:
>>= fun () ->
476
Added:
run t (fun (module Db : Caqti_lwt.CONNECTION) ->
477
Added:
Db.exec Q.delete_app_feedback (trainee, seq))
478
Added:
>|= fun () -> true
479
Added:
| _ -> Lwt.return false)
lib/persistence/sqlite_repo.mli
@@ -0,0 +1,22 @@
1
Added:
(** Durable {!Repository.S} backed by SQLite through Caqti. The production
2
Added:
store.
3
Added:
4
Added:
All performed facts are stored through {!Codec}: the adapter never inspects
5
Added:
domain shape, it stores and returns opaque encoded strings. Prescriptions
6
Added:
are not stored — a workout resolves its prescription against the shared
7
Added:
{!Catalog} on read.
8
Added:
9
Added:
Identity is assigned here: trainees and workouts get string ids the adapter
10
Added:
mints. *)
11
Added:
12
Added:
open Hito_app
13
Added:
include Repository.S
14
Added:
15
Added:
exception Corrupt of Codec.error
16
Added:
(** Raised when a stored workout cannot be decoded — a corrupted database or a
17
Added:
catalog that no longer names a stored routine or workout. This is a fault,
18
Added:
not a normal outcome. *)
19
Added:
20
Added:
val connect : string -> (t, Caqti_error.t) result Lwt.t
21
Added:
(** [connect uri] opens a connection pool and applies {!Migrations}. [uri] is a
22
Added:
Caqti URI such as ["sqlite3:hito.sqlite"]. *)
lib/persistence/timestamp.ml
@@ -0,0 +1,73 @@
1
Added:
type error = Malformed of string
2
Added:
3
Added:
let pp_error ppf = function
4
Added:
| Malformed detail -> Format.fprintf ppf "malformed timestamp: %s" detail
5
Added:
6
Added:
let encode timestamp =
7
Added:
let time =
8
Added:
Unix.gmtime (float_of_int (Recovery.timestamp_to_unix_seconds timestamp))
9
Added:
in
10
Added:
Printf.sprintf "%04d-%02d-%02dT%02d:%02d:%02dZ" (time.Unix.tm_year + 1900)
11
Added:
(time.Unix.tm_mon + 1) time.Unix.tm_mday time.Unix.tm_hour time.Unix.tm_min
12
Added:
time.Unix.tm_sec
13
Added:
14
Added:
let digit text index =
15
Added:
let value = Char.code text.[index] - Char.code '0' in
16
Added:
if value >= 0 && value <= 9 then Some value else None
17
Added:
18
Added:
let number text start length =
19
Added:
let rec loop index value =
20
Added:
if index = start + length then Some value
21
Added:
else
22
Added:
match digit text index with
23
Added:
| None -> None
24
Added:
| Some value' -> loop (index + 1) ((value * 10) + value')
25
Added:
in
26
Added:
loop start 0
27
Added:
28
Added:
(* Return the number of days from 1970-01-01 for a Gregorian date. *)
29
Added:
let days_from_civil year month day =
30
Added:
let year = year - if month <= 2 then 1 else 0 in
31
Added:
let era = if year >= 0 then year / 400 else (year - 399) / 400 in
32
Added:
let year_of_era = year - (era * 400) in
33
Added:
let month = month + if month > 2 then -3 else 9 in
34
Added:
let day_of_year = (((153 * month) + 2) / 5) + day - 1 in
35
Added:
let day_of_era =
36
Added:
(year_of_era * 365) + (year_of_era / 4) - (year_of_era / 100) + day_of_year
37
Added:
in
38
Added:
(era * 146097) + day_of_era - 719468
39
Added:
40
Added:
let decode text =
41
Added:
let malformed detail = Error (Malformed detail) in
42
Added:
if String.length text <> 20 then malformed "expected YYYY-MM-DDTHH:MM:SSZ"
43
Added:
else if
44
Added:
text.[4] <> '-'
45
Added:
|| text.[7] <> '-'
46
Added:
|| text.[10] <> 'T'
47
Added:
|| text.[13] <> ':'
48
Added:
|| text.[16] <> ':'
49
Added:
|| text.[19] <> 'Z'
50
Added:
then malformed "expected YYYY-MM-DDTHH:MM:SSZ"
51
Added:
else
52
Added:
match
53
Added:
( number text 0 4,
54
Added:
number text 5 2,
55
Added:
number text 8 2,
56
Added:
number text 11 2,
57
Added:
number text 14 2,
58
Added:
number text 17 2 )
59
Added:
with
60
Added:
| Some year, Some month, Some day, Some hour, Some minute, Some second ->
61
Added:
if
62
Added:
month < 1 || month > 12 || day < 1 || day > 31 || hour > 23
63
Added:
|| minute > 59 || second > 59
64
Added:
then malformed "timestamp component out of range"
65
Added:
else
66
Added:
let seconds =
67
Added:
(days_from_civil year month day * 86_400)
68
Added:
+ (hour * 3_600) + (minute * 60) + second
69
Added:
in
70
Added:
let timestamp = Recovery.timestamp_of_unix_seconds seconds in
71
Added:
if String.equal (encode timestamp) text then Ok timestamp
72
Added:
else malformed "invalid calendar date"
73
Added:
| _ -> malformed "timestamp contains a non-digit"
lib/persistence/timestamp.mli
@@ -0,0 +1,10 @@
1
Added:
(** Strict UTC Zulu timestamps used at persistence boundaries. *)
2
Added:
type error = Malformed of string
3
Added:
4
Added:
val encode : Recovery.timestamp -> string
5
Added:
(** Encode seconds as [YYYY-MM-DDTHH:MM:SSZ]. *)
6
Added:
7
Added:
val decode : string -> (Recovery.timestamp, error) result
8
Added:
(** Decode a strict UTC Zulu timestamp. *)
9
Added:
10
Added:
val pp_error : Format.formatter -> error -> unit
test/dune
@@ -12,4 +12,13 @@
12
12
test_sqlite_repo
13
13
test_decode
14
14
test_web)
15
Removed:
(libraries hito.core hito.app hito.web alcotest dream dream-html lwt caqti))
15
Added:
(libraries
16
Added:
hito.core
17
Added:
hito.app
18
Added:
hito.persistence
19
Added:
hito.web
20
Added:
alcotest
21
Added:
dream
22
Added:
dream-html
23
Added:
lwt
24
Added:
caqti))
test/test_codec.ml
@@ -3,6 +3,7 @@
3
3
source of evidence. *)
4
4
5
5
open Hito_app
6
Added:
open Hito_persistence
6
7
module Stimulus = Evidence.Stimulus
7
8
module Workout = Evidence.Workout
8
9
test/test_service.ml
@@ -2,6 +2,7 @@
2
2
scoped to a trainee and driven over Lwt against the in-memory repository. *)
3
3
4
4
open Hito_app
5
Added:
open Hito_persistence
5
6
module S = Service.Make (Memory_repo)
6
7
module Stimulus = Evidence.Stimulus
7
8
module Workout = Evidence.Workout
test/test_sqlite_repo.ml
@@ -2,6 +2,7 @@
2
2
survives reconnecting to the same file, and that trainees stay isolated. *)
3
3
4
4
open Hito_app
5
Added:
open Hito_persistence
5
6
module S = Service.Make (Sqlite_repo)
6
7
module Stimulus = Evidence.Stimulus
7
8
module Workout = Evidence.Workout
test/test_web.ml
@@ -3,7 +3,7 @@
3
3
the rendered page, exactly as a browser would. The in-memory repository
4
4
stands in for SQLite; session storage is Dream's in-memory back end. *)
5
5
6
Removed:
open Hito_app
6
Added:
open Hito_persistence
7
7
module Handlers = Hito_web.Handlers.Make (Memory_repo)
8
8
9
9
(* A fresh, fully wired application: secret, in-memory sessions, routes.