[OCaml] High Intensity Training Online
refactor Simplify repository test architecture
Use the SQLite adapter in all repository-dependent tests. This removes a second behavioral implementation that could drift from production. Flatten the repository port because no consumer used its concern-specific module types. Keep functors where they enforce library boundaries and permit fast password hashing in tests.
Changed files
- .kiro/steering/ocaml.md
- ARCHITECTURE.org
- lib/app/repository.ml
- lib/app/repository.mli
- lib/persistence/sqlite_repo.ml
- lib/persistence/sqlite_repo.mli
- lib/web/handlers.mli
- test/memory_repo.ml
- test/memory_repo.mli
- test/test_import_repo.ml
- test/test_import_service.ml
- test/test_repo.ml
- test/test_repo.mli
- test/test_service.ml
- test/web/app_feedback.ml
- test/web/auth.ml
- test/web/import.ml
- test/web/isolation.ml
- test/web/logbook.ml
- test/web/overview.ml
- test/web/profile.ml
- test/web/support.ml
- test/web/workout.ml
.kiro/steering/ocaml.md
@@ -66,7 +66,10 @@
66
66
Rules:
67
67
68
68
- Ports are module types. Adapters implement them. `Service.Make` and
69
Removed:
`Handlers.Make` are the dependency inversion.
69
Added:
`Handlers.Make` are the dependency inversion. Keep a port only when it
70
Added:
enforces a library boundary or permits a materially different test adapter.
71
Added:
Test persistence with `Sqlite_repo` on an isolated in-memory database. Do not
72
Added:
maintain a second behavioral repository implementation.
70
73
- `hito.app` assigns persistence identity. The core does not.
71
74
- Data that crosses a boundary is a plain value. A view-model DTO goes outward.
72
75
A core type comes inward. Never send an entity into the presenter. Never
ARCHITECTURE.org
@@ -319,7 +319,9 @@
319
319
clears the in-progress slot as one unit, so a workout is never both filed in
320
320
history and still shown as in progress.
321
321
322
Removed:
Adapters: =Memory_repo= for tests, =Sqlite_repo= over Caqti for production.
322
Added:
The sole adapter is =Sqlite_repo= over Caqti. Production uses a database file.
323
Added:
Tests use the same adapter with a one-connection =sqlite3::memory:= pool. This
324
Added:
keeps tests isolated without maintaining a second repository implementation.
323
325
=Migrations= is a versioned ledger — each migration numbered and named, applied
324
326
inside a transaction, recorded in =schema_migrations= so a reconnect applies
325
327
only what is missing. Statements still use =IF NOT EXISTS= so a file from an
@@ -611,9 +613,6 @@
611
613
612
614
What the less obvious suites are for:
613
615
614
Removed:
- =test_architecture= — the Clean Architecture guard. It reads the source tree
615
Removed:
and fails the build if a dependency points outward, or if the presenter names
616
Removed:
a core entity. The Dependency Rule is a test, not a convention.
617
616
- =test_bcrypt_hash= — the hashing adapter satisfies the =Password_hash.S=
618
617
port: a hash verifies against itself, a wrong password fails, and a malformed
619
618
stored hash is rejected rather than raised.
@@ -622,8 +621,8 @@
622
621
- =test_hevy_csv= — the native schema, RFC4180 fields, explicit timezone offset,
623
622
grouping, warm-up and unsupported-row warnings, and immutable source retention.
624
623
- =test_import_codec=, =test_import_repo=, and =test_import_sqlite= — safe
625
Removed:
round-trip storage, reconnects, trainee isolation, replacement, and independent
626
Removed:
batch and promoted-record lifecycles.
624
Added:
round-trip storage, in-memory SQLite behavior, reconnects, trainee isolation,
625
Added:
replacement, and independent batch and promoted-record lifecycles.
627
626
- =test_import_service= — duplicate override, cleaning persistence, partial
628
627
promotion, merged insights, recovery gating, and native-only routine rotation.
629
628
- =test_codec= — a stored workout round-trips faithfully, and
@@ -637,9 +636,9 @@
637
636
authentication, the recovery gate, corrections, and the no-JavaScript
638
637
behaviour are exercised end to end, one file per controller.
639
638
640
Removed:
Done means, in order: =dune build @check= clean, =dune runtest=
641
Removed:
passing, =dune fmt= applied with =dune build @fmt= clean, and
642
Removed:
documentation that matches the change.
639
Added:
Done means that touched OCaml files have been formatted with =ocamlformat= and
640
Added:
that =scripts/ci.sh= passes for the exact tree. Documentation must match the
641
Added:
change.
643
642
644
643
* Tensions with the source
645
644
:PROPERTIES:
lib/app/repository.ml
@@ -6,7 +6,6 @@
6
6
7
7
type username_taken = Username_taken
8
8
9
Removed:
(* Callers reach these fields through the module type, not from here. *)
10
9
type record = { id : workout_id; workout : Evidence.Workout.t }
11
10
[@@warning "-69"]
12
11
@@ -37,10 +36,7 @@
37
36
provenance : Workout_import.provenance;
38
37
}
39
38
40
Removed:
(* The concern signatures mirror repository.mli; the interface carries the
41
Removed:
documentation. *)
42
Removed:
43
Removed:
module type Accounts = sig
39
Added:
module type S = sig
44
40
type t
45
41
46
42
val create_trainee :
@@ -60,18 +56,9 @@
60
56
61
57
val update_credential :
62
58
t -> Trainee.id -> Trainee.credential -> Trainee.t option Lwt.t
63
Removed:
end
64
59
65
Removed:
module type Catalog = sig
66
Removed:
type t
67
Removed:
68
60
val list_routines : t -> (routine_id * Prescription.Routine.t) list
69
61
val find_routine : t -> routine_id -> Prescription.Routine.t option
70
Removed:
end
71
Removed:
72
Removed:
module type Workouts = sig
73
Removed:
type t
74
Removed:
75
62
val active_routine : t -> Trainee.id -> routine_id option Lwt.t
76
63
val set_active_routine : t -> Trainee.id -> routine_id -> unit Lwt.t
77
64
val in_progress : t -> Trainee.id -> Evidence.Workout.t option Lwt.t
@@ -85,18 +72,9 @@
85
72
val delete_workout : t -> Trainee.id -> workout_id -> bool Lwt.t
86
73
val log : t -> Trainee.id -> Evidence.Log.t Lwt.t
87
74
val history : t -> Trainee.id -> record list Lwt.t
88
Removed:
end
89
Removed:
90
Removed:
module type Self_reports = sig
91
Removed:
type t
92
Removed:
93
75
val save_feedback : t -> Trainee.id -> Feedback.t -> unit Lwt.t
94
76
val feedback : t -> Trainee.id -> Feedback.t list Lwt.t
95
Removed:
end
96
77
97
Removed:
module type App_feedback = sig
98
Removed:
type t
99
Removed:
100
78
val save_app_feedback :
101
79
t ->
102
80
Trainee.id ->
@@ -114,11 +92,7 @@
114
92
115
93
val delete_app_feedback :
116
94
t -> author:Trainee.id -> app_feedback_id -> bool Lwt.t
117
Removed:
end
118
95
119
Removed:
module type Imports = sig
120
Removed:
type t
121
Removed:
122
96
val save_import_batch : t -> Trainee.id -> Workout_import.batch -> unit Lwt.t
123
97
124
98
val find_import_batch :
@@ -134,15 +108,4 @@
134
108
135
109
val replace_imported_record : t -> Trainee.id -> imported_record -> unit Lwt.t
136
110
val imported_records : t -> Trainee.id -> imported_record list Lwt.t
137
Removed:
end
138
Removed:
139
Removed:
module type S = sig
140
Removed:
type t
141
Removed:
142
Removed:
include Accounts with type t := t
143
Removed:
include Catalog with type t := t
144
Removed:
include Workouts with type t := t
145
Removed:
include Self_reports with type t := t
146
Removed:
include App_feedback with type t := t
147
Removed:
include Imports with type t := t
148
111
end
lib/app/repository.mli
@@ -1,28 +1,15 @@
1
Removed:
(** Persistence port. A pure module type: no database or web framework.
1
Added:
(** Persistence values and the adapter contract. *)
2
2
3
Removed:
Identity lives here rather than in the core, which carries none. A routine,
4
Removed:
a stored workout, or a trainee needs a name only once something has to
5
Removed:
remember it.
6
Removed:
7
Removed:
Every operation is scoped to a {!Trainee.id}. The port holds no server-wide
8
Removed:
state. The active routine and the workout in progress belong to a trainee
9
Removed:
and are stored. Nothing is therefore lost across a restart, and no two
10
Removed:
trainees share a slot. *)
11
Removed:
12
3
type routine_id = private string
13
4
type workout_id = private string
14
5
15
6
val routine_id : string -> routine_id
16
7
val workout_id : string -> workout_id
17
8
18
Removed:
type username_taken =
19
Removed:
| Username_taken
20
Removed:
(** The one way creating or renaming an account fails at the store:
21
Removed:
another account already holds the name. *)
9
Added:
type username_taken = Username_taken
22
10
23
11
type record = { id : workout_id; workout : Evidence.Workout.t }
24
Removed:
(** A stored workout. It already knows its prescription, its timestamps, and the
25
Removed:
basis on which it was begun. *)
12
Added:
(** A stored native workout. *)
26
13
27
14
type app_feedback_id = private string
28
15
@@ -39,7 +26,7 @@
39
26
viewer_upvoted : bool;
40
27
viewer_owns : bool;
41
28
}
42
Removed:
(** A ranked application comment with viewer vote and ownership state. *)
29
Added:
(** Application feedback with values calculated for the current viewer. *)
43
30
44
31
type imported_record = {
45
32
batch_id : Workout_import.batch_id;
@@ -51,22 +38,11 @@
51
38
observations : Evidence.Observation.t list;
52
39
provenance : Workout_import.provenance;
53
40
}
54
Removed:
(** A promoted workout, stored as canonical evidence independent of the batch it
55
Removed:
came from. A batch is provisional and may be discarded. Its promoted records
56
Removed:
outlive it. The [revision] is the workout revision the promotion reflects,
57
Removed:
so a re-promotion after an edit replaces the record rather than duplicating
58
Removed:
it. *)
41
Added:
(** Canonical evidence promoted from a provisional import batch. *)
59
42
60
Removed:
(** {1 Concern signatures}
61
Removed:
62
Removed:
The port is split by concern, each a standalone module type over a shared
63
Removed:
store [t]. {!S} composes them into the whole repository an adapter
64
Removed:
implements. A use case or test double that needs only one concern can name
65
Removed:
that concern's signature instead of the whole, so a narrow consumer never
66
Removed:
carries operations it does not use. *)
67
Removed:
68
Removed:
(** Accounts: trainee identity and credentials. *)
69
Removed:
module type Accounts = sig
43
Added:
(** The complete repository port. Every operation is scoped by trainee identity,
44
Added:
except for the shared routine catalog. *)
45
Added:
module type S = sig
70
46
type t
71
47
72
48
val create_trainee :
@@ -83,149 +59,65 @@
83
59
Trainee.id ->
84
60
Trainee.username ->
85
61
(Trainee.t, username_taken) result Lwt.t
86
Removed:
(** Rename the account. [Username_taken] if another account holds the name.
87
Removed:
The trainee's own current name is accepted as a no-op. Returns the updated
88
Removed:
trainee on success. *)
62
Added:
(** Accept the current username as a no-op. *)
89
63
90
64
val update_credential :
91
65
t -> Trainee.id -> Trainee.credential -> Trainee.t option Lwt.t
92
Removed:
(** Replace the account's password verifier. [None] if unknown. *)
93
Removed:
end
94
66
95
Removed:
(** Catalog: the authored routines. Shared, not trainee-scoped. *)
96
Removed:
module type Catalog = sig
97
Removed:
type t
98
Removed:
99
67
val list_routines : t -> (routine_id * Prescription.Routine.t) list
100
68
val find_routine : t -> routine_id -> Prescription.Routine.t option
101
Removed:
end
102
Removed:
103
Removed:
(** Workouts: a trainee's routine selection, the workout in progress, and the
104
Removed:
saved history. *)
105
Removed:
module type Workouts = sig
106
Removed:
type t
107
Removed:
108
69
val active_routine : t -> Trainee.id -> routine_id option Lwt.t
109
70
val set_active_routine : t -> Trainee.id -> routine_id -> unit Lwt.t
110
71
val in_progress : t -> Trainee.id -> Evidence.Workout.t option Lwt.t
111
72
112
73
val set_in_progress :
113
74
t -> Trainee.id -> Evidence.Workout.t option -> unit Lwt.t
114
Removed:
(** [None] clears the slot. *)
115
75
116
76
val finish_workout : t -> Trainee.id -> Evidence.Workout.t -> record Lwt.t
117
Removed:
(** Store a finished workout and clear the in-progress slot as one unit. An
118
Removed:
adapter with transactions performs both in a single transaction, so a
119
Removed:
workout never appears both in history and in progress at once. *)
77
Added:
(** Store the workout and clear the current workout in one transaction. *)
120
78
121
79
val find : t -> Trainee.id -> workout_id -> record option Lwt.t
122
Removed:
123
80
val replace : t -> Trainee.id -> record -> bool Lwt.t
124
Removed:
(** Replace an existing record by identity. *)
125
Removed:
126
81
val delete_workout : t -> Trainee.id -> workout_id -> bool Lwt.t
127
Removed:
(** Delete one saved workout only when [id] owns it. [false] when it no longer
128
Removed:
exists. This does not affect an in-progress workout. *)
129
Removed:
130
82
val log : t -> Trainee.id -> Evidence.Log.t Lwt.t
131
Removed:
(** Canonical workouts logged through hito. Promoted import observations are
132
Removed:
stored separately in {!Imports.imported_records}. *)
133
Removed:
134
83
val history : t -> Trainee.id -> record list Lwt.t
135
Removed:
(** Most recent first. *)
136
Removed:
end
137
Removed:
138
Removed:
(** Self-reports: the trainee's subjective feedback. *)
139
Removed:
module type Self_reports = sig
140
Removed:
type t
141
Removed:
142
84
val save_feedback : t -> Trainee.id -> Feedback.t -> unit Lwt.t
143
Removed:
(** Store a subjective feedback report. Feedback is a standalone observation,
144
Removed:
not tied to a workout: a trainee may report it at any time. *)
145
Removed:
146
85
val feedback : t -> Trainee.id -> Feedback.t list Lwt.t
147
Removed:
(** Stored feedback reports, most recent first. *)
148
Removed:
end
149
86
150
Removed:
(** Application feedback: freeform reports about the app, ranked by vote. *)
151
Removed:
module type App_feedback = sig
152
Removed:
type t
153
Removed:
154
87
val save_app_feedback :
155
88
t ->
156
89
Trainee.id ->
157
90
submitted_at:Recovery.timestamp ->
158
91
message:string ->
159
92
app_feedback Lwt.t
160
Removed:
(** Store a freeform application feedback report and return its identity. *)
161
93
162
94
val app_feedback : t -> viewer:Trainee.id -> app_feedback list Lwt.t
163
Removed:
(** Return all reports, ranked by upvotes, with the viewer's vote state. *)
164
95
165
96
val upvote_app_feedback :
166
97
t -> voter:Trainee.id -> app_feedback_id -> bool Lwt.t
167
Removed:
(** Add one vote from another trainee. [false] means no vote was added. *)
168
98
169
99
val update_app_feedback :
170
100
t -> author:Trainee.id -> app_feedback_id -> message:string -> bool Lwt.t
171
Removed:
(** Update a report only when [author] owns it. *)
172
101
173
102
val delete_app_feedback :
174
103
t -> author:Trainee.id -> app_feedback_id -> bool Lwt.t
175
Removed:
(** Remove a report and its votes only when [author] owns it. *)
176
Removed:
end
177
104
178
Removed:
(** Workout import.
179
Removed:
180
Removed:
A provisional import batch and the canonical records promoted from it have
181
Removed:
independent lifecycles. A batch is stored so cleaning and promotion survive
182
Removed:
a reconnect, and may be deleted once it is no longer needed. A promoted
183
Removed:
record is canonical evidence and is never removed by deleting its batch. *)
184
Removed:
module type Imports = sig
185
Removed:
type t
186
Removed:
187
105
val save_import_batch : t -> Trainee.id -> Workout_import.batch -> unit Lwt.t
188
Removed:
(** Store or replace a provisional import batch by its identity, including its
189
Removed:
mappings, acknowledgements, and any prior promotions, so the batch's full
190
Removed:
state survives a reconnect. *)
191
106
192
107
val find_import_batch :
193
108
t ->
194
109
Trainee.id ->
195
110
Workout_import.batch_id ->
196
111
Workout_import.batch option Lwt.t
197
Removed:
(** The stored batch with the given identity, or [None]. *)
198
112
199
113
val import_batches : t -> Trainee.id -> Workout_import.batch list Lwt.t
200
Removed:
(** Every stored batch for the trainee, most recent [imported_at] first, with
201
Removed:
ties broken by batch id in descending order for a deterministic result. *)
202
114
203
115
val delete_import_batch :
204
116
t -> Trainee.id -> Workout_import.batch_id -> bool Lwt.t
205
Removed:
(** Remove the provisional batch with the given identity. [false] when no such
206
Removed:
batch exists. This never removes an {!imported_record}: promoted evidence
207
Removed:
outlives the batch it came from. *)
117
Added:
(** Delete only the provisional batch. Promoted records remain. *)
208
118
209
119
val replace_imported_record : t -> Trainee.id -> imported_record -> unit Lwt.t
210
Removed:
(** Store a promoted record, replacing any existing record for the same
211
Removed:
trainee and [workout_id] with the new observations and revision. An atomic
212
Removed:
upsert keyed by [(trainee, workout_id)]. *)
120
Added:
(** Replace the record with the same trainee and workout identity. *)
213
121
214
122
val imported_records : t -> Trainee.id -> imported_record list Lwt.t
215
Removed:
(** Every promoted record for the trainee, most recent [ended_at] first. *)
216
Removed:
end
217
Removed:
218
Removed:
(** {1 The whole port}
219
Removed:
220
Removed:
Effects run in Lwt: an adapter may talk to a database. Every concern shares
221
Removed:
the one store [t]. *)
222
Removed:
module type S = sig
223
Removed:
type t
224
Removed:
225
Removed:
include Accounts with type t := t
226
Removed:
include Catalog with type t := t
227
Removed:
include Workouts with type t := t
228
Removed:
include Self_reports with type t := t
229
Removed:
include App_feedback with type t := t
230
Removed:
include Imports with type t := t
231
123
end
lib/persistence/sqlite_repo.ml
@@ -213,8 +213,11 @@
213
213
Uri.add_query_param' uri
214
214
("busy_timeout", string_of_int default_busy_timeout_ms)
215
215
216
Removed:
let connect uri =
217
Removed:
match Caqti_lwt_unix.connect_pool (with_busy_timeout (Uri.of_string uri)) with
216
Added:
let connect ?pool_config uri =
217
Added:
match
218
Added:
Caqti_lwt_unix.connect_pool ?pool_config
219
Added:
(with_busy_timeout (Uri.of_string uri))
220
Added:
with
218
221
| Error e -> Lwt.return (Error (e :> Caqti_error.t))
219
222
| Ok pool ->
220
223
let open Lwt_result.Syntax in
lib/persistence/sqlite_repo.mli
@@ -22,6 +22,8 @@
22
22
cause is a corrupted database, or a catalog that no longer names a stored
23
23
exercise. This is a fault, not a normal outcome. *)
24
24
25
Removed:
val connect : string -> (t, Caqti_error.t) result Lwt.t
25
Added:
val connect :
26
Added:
?pool_config:Caqti_pool_config.t -> string -> (t, Caqti_error.t) result Lwt.t
26
27
(** [connect uri] opens a connection pool and applies {!Migrations}. [uri] is a
27
Removed:
Caqti URI such as ["sqlite3:hito.sqlite"]. *)
28
Added:
Caqti URI such as ["sqlite3:hito.sqlite"]. Use a one-connection pool for
29
Added:
["sqlite3::memory:"] because each connection has a separate database. *)
lib/web/handlers.mli
@@ -1,6 +1,6 @@
1
1
(** The web tier: routing, authentication, sessions, and CSRF. Functorized over
2
Removed:
the repository so tests drive it with an in-memory store while production
3
Removed:
uses SQLite. *)
2
Added:
the ports so the composition root selects the concrete adapters. Tests use
3
Added:
the SQLite adapter with an isolated in-memory database. *)
4
4
5
5
module Make
6
6
(R : Hito_app.Repository.S)
test/memory_repo.ml
@@ -1,503 +0,0 @@
1
Removed:
open Hito_app
2
Removed:
3
Removed:
(* Per-trainee mutable state, held in a hashtable keyed by trainee id. *)
4
Removed:
type trainee_state = {
5
Removed:
mutable active : Repository.routine_id option;
6
Removed:
mutable current : Evidence.Workout.t option;
7
Removed:
mutable stored : Repository.record list; (* most recent first *)
8
Removed:
mutable feedback : Feedback.t list; (* most recent first *)
9
Removed:
mutable batches : Workout_import.batch list;
10
Removed:
(* insertion order, newest first *)
11
Removed:
mutable records : Repository.imported_record list; (* newest ended_at first *)
12
Removed:
mutable next_id : int;
13
Removed:
mutable next_app_feedback : int;
14
Removed:
}
15
Removed:
16
Removed:
type t = {
17
Removed:
mutable trainees : Trainee.t list;
18
Removed:
states : (string, trainee_state) Hashtbl.t;
19
Removed:
mutable app_feedback : (Trainee.id * Repository.app_feedback) list;
20
Removed:
mutable app_feedback_votes : (Repository.app_feedback_id * Trainee.id) list;
21
Removed:
mutable next_trainee : int;
22
Removed:
}
23
Removed:
24
Removed:
let create () =
25
Removed:
{
26
Removed:
trainees = [];
27
Removed:
states = Hashtbl.create 16;
28
Removed:
app_feedback = [];
29
Removed:
app_feedback_votes = [];
30
Removed:
next_trainee = 1;
31
Removed:
}
32
Removed:
33
Removed:
let state t id =
34
Removed:
let key = Trainee.id_to_string id in
35
Removed:
match Hashtbl.find_opt t.states key with
36
Removed:
| Some s -> s
37
Removed:
| None ->
38
Removed:
let s =
39
Removed:
{
40
Removed:
active = None;
41
Removed:
current = None;
42
Removed:
stored = [];
43
Removed:
feedback = [];
44
Removed:
batches = [];
45
Removed:
records = [];
46
Removed:
next_id = 1;
47
Removed:
next_app_feedback = 1;
48
Removed:
}
49
Removed:
in
50
Removed:
Hashtbl.replace t.states key s;
51
Removed:
s
52
Removed:
53
Removed:
let create_trainee t ~(username : Trainee.username) ~credential =
54
Removed:
match
55
Removed:
List.find_opt
56
Removed:
(fun (tr : Trainee.t) ->
57
Removed:
String.equal
58
Removed:
(Trainee.username_to_string tr.username)
59
Removed:
(Trainee.username_to_string username))
60
Removed:
t.trainees
61
Removed:
with
62
Removed:
| Some _ -> Lwt.return (Error Repository.Username_taken)
63
Removed:
| None ->
64
Removed:
let id = Trainee.id (Printf.sprintf "t%d" t.next_trainee) in
65
Removed:
t.next_trainee <- t.next_trainee + 1;
66
Removed:
let trainee = { Trainee.id; username; credential } in
67
Removed:
t.trainees <- trainee :: t.trainees;
68
Removed:
Lwt.return (Ok trainee)
69
Removed:
70
Removed:
let find_trainee_by_username t (username : Trainee.username) =
71
Removed:
Lwt.return
72
Removed:
(List.find_opt
73
Removed:
(fun (tr : Trainee.t) ->
74
Removed:
String.equal
75
Removed:
(Trainee.username_to_string tr.username)
76
Removed:
(Trainee.username_to_string username))
77
Removed:
t.trainees)
78
Removed:
79
Removed:
let find_trainee t id =
80
Removed:
Lwt.return
81
Removed:
(List.find_opt
82
Removed:
(fun (tr : Trainee.t) ->
83
Removed:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
84
Removed:
t.trainees)
85
Removed:
86
Removed:
let replace_trainee t (updated : Trainee.t) =
87
Removed:
t.trainees <-
88
Removed:
List.map
89
Removed:
(fun (tr : Trainee.t) ->
90
Removed:
if
91
Removed:
String.equal
92
Removed:
(Trainee.id_to_string tr.id)
93
Removed:
(Trainee.id_to_string updated.id)
94
Removed:
then updated
95
Removed:
else tr)
96
Removed:
t.trainees
97
Removed:
98
Removed:
let update_username t id (username : Trainee.username) =
99
Removed:
match
100
Removed:
List.find_opt
101
Removed:
(fun (tr : Trainee.t) ->
102
Removed:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
103
Removed:
t.trainees
104
Removed:
with
105
Removed:
| None -> Lwt.return (Error Repository.Username_taken)
106
Removed:
| Some current ->
107
Removed:
let taken =
108
Removed:
List.exists
109
Removed:
(fun (tr : Trainee.t) ->
110
Removed:
(not
111
Removed:
(String.equal
112
Removed:
(Trainee.id_to_string tr.id)
113
Removed:
(Trainee.id_to_string id)))
114
Removed:
&& String.equal
115
Removed:
(Trainee.username_to_string tr.username)
116
Removed:
(Trainee.username_to_string username))
117
Removed:
t.trainees
118
Removed:
in
119
Removed:
if taken then Lwt.return (Error Repository.Username_taken)
120
Removed:
else begin
121
Removed:
let updated = { current with Trainee.username } in
122
Removed:
replace_trainee t updated;
123
Removed:
Lwt.return (Ok updated)
124
Removed:
end
125
Removed:
126
Removed:
let update_credential t id credential =
127
Removed:
match
128
Removed:
List.find_opt
129
Removed:
(fun (tr : Trainee.t) ->
130
Removed:
String.equal (Trainee.id_to_string tr.id) (Trainee.id_to_string id))
131
Removed:
t.trainees
132
Removed:
with
133
Removed:
| None -> Lwt.return None
134
Removed:
| Some current ->
135
Removed:
let updated = { current with Trainee.credential } in
136
Removed:
replace_trainee t updated;
137
Removed:
Lwt.return (Some updated)
138
Removed:
139
Removed:
let list_routines _ = Catalog.routines
140
Removed:
let find_routine _ id = Catalog.find id
141
Removed:
let active_routine t id = Lwt.return (state t id).active
142
Removed:
143
Removed:
let set_active_routine t id routine =
144
Removed:
(state t id).active <- Some routine;
145
Removed:
Lwt.return_unit
146
Removed:
147
Removed:
let in_progress t id = Lwt.return (state t id).current
148
Removed:
149
Removed:
let set_in_progress t id workout =
150
Removed:
(state t id).current <- workout;
151
Removed:
Lwt.return_unit
152
Removed:
153
Removed:
(* Store the finished workout and clear the in-progress slot together. In
154
Removed:
memory this is a single synchronous update, so it cannot tear. *)
155
Removed:
let finish_workout t id workout =
156
Removed:
let s = state t id in
157
Removed:
let wid = Repository.workout_id (Printf.sprintf "w%d" s.next_id) in
158
Removed:
let record = { Repository.id = wid; workout } in
159
Removed:
s.next_id <- s.next_id + 1;
160
Removed:
s.stored <- record :: s.stored;
161
Removed:
s.current <- None;
162
Removed:
Lwt.return record
163
Removed:
164
Removed:
let equal_id (a : Repository.workout_id) (b : Repository.workout_id) =
165
Removed:
String.equal (a :> string) (b :> string)
166
Removed:
167
Removed:
let find t id wid =
168
Removed:
let s = state t id in
169
Removed:
Lwt.return (List.find_opt (fun r -> equal_id r.Repository.id wid) s.stored)
170
Removed:
171
Removed:
let replace t id record =
172
Removed:
let s = state t id in
173
Removed:
if
174
Removed:
not
175
Removed:
(List.exists
176
Removed:
(fun r -> equal_id r.Repository.id record.Repository.id)
177
Removed:
s.stored)
178
Removed:
then Lwt.return false
179
Removed:
else begin
180
Removed:
s.stored <-
181
Removed:
List.map
182
Removed:
(fun existing ->
183
Removed:
if equal_id existing.Repository.id record.Repository.id then record
184
Removed:
else existing)
185
Removed:
s.stored;
186
Removed:
Lwt.return true
187
Removed:
end
188
Removed:
189
Removed:
let delete_workout t id wid =
190
Removed:
let s = state t id in
191
Removed:
let removed = List.exists (fun r -> equal_id r.Repository.id wid) s.stored in
192
Removed:
if removed then
193
Removed:
s.stored <-
194
Removed:
List.filter (fun r -> not (equal_id r.Repository.id wid)) s.stored;
195
Removed:
Lwt.return removed
196
Removed:
197
Removed:
let log t id =
198
Removed:
let s = state t id in
199
Removed:
Lwt.return
200
Removed:
(List.fold_left
201
Removed:
(fun log record -> Evidence.Log.add log record.Repository.workout)
202
Removed:
Evidence.Log.empty (List.rev s.stored))
203
Removed:
204
Removed:
let history t id = Lwt.return (state t id).stored
205
Removed:
206
Removed:
let save_feedback t id report =
207
Removed:
let s = state t id in
208
Removed:
s.feedback <- report :: s.feedback;
209
Removed:
Lwt.return_unit
210
Removed:
211
Removed:
let feedback t id = Lwt.return (state t id).feedback
212
Removed:
213
Removed:
let save_app_feedback t id ~submitted_at ~message =
214
Removed:
let author =
215
Removed:
match
216
Removed:
List.find_opt
217
Removed:
(fun (trainee : Trainee.t) ->
218
Removed:
String.equal
219
Removed:
(Trainee.id_to_string trainee.id)
220
Removed:
(Trainee.id_to_string id))
221
Removed:
t.trainees
222
Removed:
with
223
Removed:
| Some trainee -> Trainee.username_to_string trainee.username
224
Removed:
| None -> ""
225
Removed:
in
226
Removed:
let contributions =
227
Removed:
1
228
Removed:
+ List.fold_left
229
Removed:
(fun count (owner, _) ->
230
Removed:
if String.equal (Trainee.id_to_string owner) (Trainee.id_to_string id)
231
Removed:
then count + 1
232
Removed:
else count)
233
Removed:
0 t.app_feedback
234
Removed:
in
235
Removed:
let s = state t id in
236
Removed:
let feedback_id =
237
Removed:
Repository.app_feedback_id
238
Removed:
(Printf.sprintf "%s:%d" (Trainee.id_to_string id) s.next_app_feedback)
239
Removed:
in
240
Removed:
s.next_app_feedback <- s.next_app_feedback + 1;
241
Removed:
let report =
242
Removed:
Repository.
243
Removed:
{
244
Removed:
feedback_id;
245
Removed:
author;
246
Removed:
contributions;
247
Removed:
submitted_at;
248
Removed:
message;
249
Removed:
upvotes = 0;
250
Removed:
viewer_upvoted = false;
251
Removed:
viewer_owns = true;
252
Removed:
}
253
Removed:
in
254
Removed:
t.app_feedback <- (id, report) :: t.app_feedback;
255
Removed:
Lwt.return report
256
Removed:
257
Removed:
let app_feedback_id_parts report =
258
Removed:
let raw =
259
Removed:
Repository.app_feedback_id_to_string report.Repository.feedback_id
260
Removed:
in
261
Removed:
match String.rindex_opt raw ':' with
262
Removed:
| None -> (raw, 0)
263
Removed:
| Some separator ->
264
Removed:
let owner = String.sub raw 0 separator in
265
Removed:
let sequence =
266
Removed:
String.sub raw (separator + 1) (String.length raw - separator - 1)
267
Removed:
|> int_of_string_opt |> Option.value ~default:0
268
Removed:
in
269
Removed:
(owner, sequence)
270
Removed:
271
Removed:
let app_feedback t ~viewer =
272
Removed:
let reports =
273
Removed:
List.map
274
Removed:
(fun (owner, report) ->
275
Removed:
let owner_id = Trainee.id_to_string owner in
276
Removed:
let contributions =
277
Removed:
List.fold_left
278
Removed:
(fun count (candidate, _) ->
279
Removed:
if String.equal owner_id (Trainee.id_to_string candidate) then
280
Removed:
count + 1
281
Removed:
else count)
282
Removed:
0 t.app_feedback
283
Removed:
in
284
Removed:
let author =
285
Removed:
match
286
Removed:
List.find_opt
287
Removed:
(fun (trainee : Trainee.t) ->
288
Removed:
String.equal owner_id (Trainee.id_to_string trainee.id))
289
Removed:
t.trainees
290
Removed:
with
291
Removed:
| Some trainee -> Trainee.username_to_string trainee.username
292
Removed:
| None -> report.Repository.author
293
Removed:
in
294
Removed:
let viewer_upvoted =
295
Removed:
List.exists
296
Removed:
(fun (feedback_id, voter) ->
297
Removed:
String.equal
298
Removed:
(Repository.app_feedback_id_to_string feedback_id)
299
Removed:
(Repository.app_feedback_id_to_string
300
Removed:
report.Repository.feedback_id)
301
Removed:
&& String.equal
302
Removed:
(Trainee.id_to_string voter)
303
Removed:
(Trainee.id_to_string viewer))
304
Removed:
t.app_feedback_votes
305
Removed:
in
306
Removed:
let viewer_owns = String.equal owner_id (Trainee.id_to_string viewer) in
307
Removed:
{ report with author; contributions; viewer_upvoted; viewer_owns })
308
Removed:
t.app_feedback
309
Removed:
in
310
Removed:
let compare left right =
311
Removed:
let by_votes =
312
Removed:
Int.compare right.Repository.upvotes left.Repository.upvotes
313
Removed:
in
314
Removed:
if by_votes <> 0 then by_votes
315
Removed:
else
316
Removed:
let by_time =
317
Removed:
Int.compare
318
Removed:
(Recovery.timestamp_to_unix_seconds right.submitted_at)
319
Removed:
(Recovery.timestamp_to_unix_seconds left.submitted_at)
320
Removed:
in
321
Removed:
if by_time <> 0 then by_time
322
Removed:
else
323
Removed:
let left_owner, left_sequence = app_feedback_id_parts left in
324
Removed:
let right_owner, right_sequence = app_feedback_id_parts right in
325
Removed:
let by_owner = String.compare left_owner right_owner in
326
Removed:
if by_owner <> 0 then by_owner
327
Removed:
else Int.compare right_sequence left_sequence
328
Removed:
in
329
Removed:
Lwt.return (List.sort compare reports)
330
Removed:
331
Removed:
let upvote_app_feedback t ~voter feedback_id =
332
Removed:
match
333
Removed:
List.find_opt
334
Removed:
(fun (_, report) ->
335
Removed:
String.equal
336
Removed:
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
337
Removed:
(Repository.app_feedback_id_to_string feedback_id))
338
Removed:
t.app_feedback
339
Removed:
with
340
Removed:
| None -> Lwt.return false
341
Removed:
| Some (owner, _)
342
Removed:
when String.equal (Trainee.id_to_string owner) (Trainee.id_to_string voter)
343
Removed:
->
344
Removed:
Lwt.return false
345
Removed:
| Some (_, report) ->
346
Removed:
if
347
Removed:
List.exists
348
Removed:
(fun (voted_feedback, existing_voter) ->
349
Removed:
String.equal
350
Removed:
(Repository.app_feedback_id_to_string voted_feedback)
351
Removed:
(Repository.app_feedback_id_to_string feedback_id)
352
Removed:
&& String.equal
353
Removed:
(Trainee.id_to_string existing_voter)
354
Removed:
(Trainee.id_to_string voter))
355
Removed:
t.app_feedback_votes
356
Removed:
then Lwt.return false
357
Removed:
else begin
358
Removed:
t.app_feedback_votes <- (feedback_id, voter) :: t.app_feedback_votes;
359
Removed:
t.app_feedback <-
360
Removed:
List.map
361
Removed:
(fun (owner, current) ->
362
Removed:
if
363
Removed:
String.equal
364
Removed:
(Repository.app_feedback_id_to_string
365
Removed:
current.Repository.feedback_id)
366
Removed:
(Repository.app_feedback_id_to_string
367
Removed:
report.Repository.feedback_id)
368
Removed:
then (owner, { current with upvotes = current.upvotes + 1 })
369
Removed:
else (owner, current))
370
Removed:
t.app_feedback;
371
Removed:
Lwt.return true
372
Removed:
end
373
Removed:
374
Removed:
let update_app_feedback t ~author id ~message =
375
Removed:
let author_id = Trainee.id_to_string author in
376
Removed:
let updated = ref false in
377
Removed:
t.app_feedback <-
378
Removed:
List.map
379
Removed:
(fun (owner, report) ->
380
Removed:
if
381
Removed:
String.equal (Trainee.id_to_string owner) author_id
382
Removed:
&& String.equal
383
Removed:
(Repository.app_feedback_id_to_string
384
Removed:
report.Repository.feedback_id)
385
Removed:
(Repository.app_feedback_id_to_string id)
386
Removed:
then begin
387
Removed:
updated := true;
388
Removed:
(owner, { report with message })
389
Removed:
end
390
Removed:
else (owner, report))
391
Removed:
t.app_feedback;
392
Removed:
Lwt.return !updated
393
Removed:
394
Removed:
let delete_app_feedback t ~author id =
395
Removed:
let author_id = Trainee.id_to_string author in
396
Removed:
let owned (owner, report) =
397
Removed:
String.equal (Trainee.id_to_string owner) author_id
398
Removed:
&& String.equal
399
Removed:
(Repository.app_feedback_id_to_string report.Repository.feedback_id)
400
Removed:
(Repository.app_feedback_id_to_string id)
401
Removed:
in
402
Removed:
let removed = List.exists owned t.app_feedback in
403
Removed:
if removed then begin
404
Removed:
t.app_feedback <- List.filter (fun item -> not (owned item)) t.app_feedback;
405
Removed:
t.app_feedback_votes <-
406
Removed:
List.filter
407
Removed:
(fun (feedback_id, _) ->
408
Removed:
not
409
Removed:
(String.equal
410
Removed:
(Repository.app_feedback_id_to_string feedback_id)
411
Removed:
(Repository.app_feedback_id_to_string id)))
412
Removed:
t.app_feedback_votes
413
Removed:
end;
414
Removed:
Lwt.return removed
415
Removed:
416
Removed:
(* --- workout import --- *)
417
Removed:
418
Removed:
let batch_id_eq a b =
419
Removed:
String.equal
420
Removed:
(Workout_import.batch_id_to_string a)
421
Removed:
(Workout_import.batch_id_to_string b)
422
Removed:
423
Removed:
(* Upsert a batch by its identity, dropping any earlier version and prepending
424
Removed:
the new one so the list stays newest-first by insertion. *)
425
Removed:
let save_import_batch t id batch =
426
Removed:
let s = state t id in
427
Removed:
let identity = Workout_import.batch_identity batch in
428
Removed:
s.batches <-
429
Removed:
batch
430
Removed:
:: List.filter
431
Removed:
(fun b -> not (batch_id_eq (Workout_import.batch_identity b) identity))
432
Removed:
s.batches;
433
Removed:
Lwt.return_unit
434
Removed:
435
Removed:
let find_import_batch t id batch_id =
436
Removed:
let s = state t id in
437
Removed:
Lwt.return
438
Removed:
(List.find_opt
439
Removed:
(fun b -> batch_id_eq (Workout_import.batch_identity b) batch_id)
440
Removed:
s.batches)
441
Removed:
442
Removed:
(* Most recent [imported_at] first; ties broken by batch id descending, for a
443
Removed:
deterministic order that does not depend on insertion. *)
444
Removed:
let import_batches t id =
445
Removed:
let s = state t id in
446
Removed:
let compare a b =
447
Removed:
let by_time =
448
Removed:
Int.compare
449
Removed:
(Recovery.timestamp_to_unix_seconds
450
Removed:
(Workout_import.batch_imported_at b))
451
Removed:
(Recovery.timestamp_to_unix_seconds
452
Removed:
(Workout_import.batch_imported_at a))
453
Removed:
in
454
Removed:
if by_time <> 0 then by_time
455
Removed:
else
456
Removed:
String.compare
457
Removed:
(Workout_import.batch_id_to_string (Workout_import.batch_identity b))
458
Removed:
(Workout_import.batch_id_to_string (Workout_import.batch_identity a))
459
Removed:
in
460
Removed:
Lwt.return (List.stable_sort compare s.batches)
461
Removed:
462
Removed:
(* Deleting a provisional batch never touches promoted records: their lifecycle
463
Removed:
is independent. *)
464
Removed:
let delete_import_batch t id batch_id =
465
Removed:
let s = state t id in
466
Removed:
let present =
467
Removed:
List.exists
468
Removed:
(fun b -> batch_id_eq (Workout_import.batch_identity b) batch_id)
469
Removed:
s.batches
470
Removed:
in
471
Removed:
if present then
472
Removed:
s.batches <-
473
Removed:
List.filter
474
Removed:
(fun b -> not (batch_id_eq (Workout_import.batch_identity b) batch_id))
475
Removed:
s.batches;
476
Removed:
Lwt.return present
477
Removed:
478
Removed:
let workout_id_eq a b =
479
Removed:
String.equal
480
Removed:
(Workout_import.workout_id_to_string a)
481
Removed:
(Workout_import.workout_id_to_string b)
482
Removed:
483
Removed:
(* Atomic upsert keyed by workout id: a re-promotion replaces the observations
484
Removed:
and revision of the prior record for the same workout. *)
485
Removed:
let replace_imported_record t id record =
486
Removed:
let s = state t id in
487
Removed:
s.records <-
488
Removed:
record
489
Removed:
:: List.filter
490
Removed:
(fun r ->
491
Removed:
not
492
Removed:
(workout_id_eq r.Repository.workout_id record.Repository.workout_id))
493
Removed:
s.records;
494
Removed:
Lwt.return_unit
495
Removed:
496
Removed:
let imported_records t id =
497
Removed:
let s = state t id in
498
Removed:
let compare a b =
499
Removed:
Int.compare
500
Removed:
(Recovery.timestamp_to_unix_seconds b.Repository.ended_at)
501
Removed:
(Recovery.timestamp_to_unix_seconds a.Repository.ended_at)
502
Removed:
in
503
Removed:
Lwt.return (List.stable_sort compare s.records)
test/memory_repo.mli
@@ -1,8 +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:
open Hito_app
5
Removed:
include Repository.S
6
Removed:
7
Removed:
val create : unit -> t
8
Removed:
(** Seeded with the shared routine catalog. *)
test/test_import_repo.ml
@@ -1,4 +1,4 @@
1
Removed:
(** Tests for the workout-import persistence operations on {!Memory_repo}:
1
Added:
(** Tests for the workout-import persistence operations on {!Test_repo}:
2
2
per-trainee isolation, deterministic ordering, that deleting a provisional
3
3
batch leaves promoted records, and that a promoted record is replaced by
4
4
workout id. *)
@@ -74,62 +74,62 @@
74
74
let batch_ids bs =
75
75
List.map (fun b -> WI.batch_id_to_string (WI.batch_identity b)) bs
76
76
77
Removed:
let memory_tests =
77
Added:
let repository_tests =
78
78
[
79
79
( "batches and records are isolated per trainee",
80
80
`Quick,
81
81
fun () ->
82
Removed:
let repo = Memory_repo.create () in
82
Added:
let repo = Test_repo.create () in
83
83
let a = trainee 1 and b = trainee 2 in
84
84
run
85
Removed:
(Memory_repo.save_import_batch repo a
85
Added:
(Test_repo.save_import_batch repo a
86
86
(batch ~id:"ba" ~imported_at:(at 100)));
87
87
run
88
Removed:
(Memory_repo.replace_imported_record repo a
88
Added:
(Test_repo.replace_imported_record repo a
89
89
(record ~batch_id:"ba" ~workout_id:"w1" ~revision:0
90
90
~ended_at:(at 3_610) ~load:100.));
91
91
Alcotest.(check int)
92
92
"b has no batches" 0
93
Removed:
(List.length (run (Memory_repo.import_batches repo b)));
93
Added:
(List.length (run (Test_repo.import_batches repo b)));
94
94
Alcotest.(check int)
95
95
"b has no records" 0
96
Removed:
(List.length (run (Memory_repo.imported_records repo b)));
96
Added:
(List.length (run (Test_repo.imported_records repo b)));
97
97
Alcotest.(check int)
98
98
"a has one batch" 1
99
Removed:
(List.length (run (Memory_repo.import_batches repo a))) );
99
Added:
(List.length (run (Test_repo.import_batches repo a))) );
100
100
( "batches list most recent imported_at first, ties by id descending",
101
101
`Quick,
102
102
fun () ->
103
Removed:
let repo = Memory_repo.create () in
103
Added:
let repo = Test_repo.create () in
104
104
let a = trainee 1 in
105
105
run
106
Removed:
(Memory_repo.save_import_batch repo a
106
Added:
(Test_repo.save_import_batch repo a
107
107
(batch ~id:"b1" ~imported_at:(at 100)));
108
108
run
109
Removed:
(Memory_repo.save_import_batch repo a
109
Added:
(Test_repo.save_import_batch repo a
110
110
(batch ~id:"b3" ~imported_at:(at 300)));
111
111
run
112
Removed:
(Memory_repo.save_import_batch repo a
112
Added:
(Test_repo.save_import_batch repo a
113
113
(batch ~id:"b2a" ~imported_at:(at 200)));
114
114
run
115
Removed:
(Memory_repo.save_import_batch repo a
115
Added:
(Test_repo.save_import_batch repo a
116
116
(batch ~id:"b2b" ~imported_at:(at 200)));
117
117
Alcotest.(check (list string))
118
118
"newest first, id tie-break descending"
119
119
[ "b3"; "b2b"; "b2a"; "b1" ]
120
Removed:
(batch_ids (run (Memory_repo.import_batches repo a))) );
120
Added:
(batch_ids (run (Test_repo.import_batches repo a))) );
121
121
( "saving a batch with the same id replaces it",
122
122
`Quick,
123
123
fun () ->
124
Removed:
let repo = Memory_repo.create () in
124
Added:
let repo = Test_repo.create () in
125
125
let a = trainee 1 in
126
126
run
127
Removed:
(Memory_repo.save_import_batch repo a
127
Added:
(Test_repo.save_import_batch repo a
128
128
(batch ~id:"b1" ~imported_at:(at 100)));
129
129
run
130
Removed:
(Memory_repo.save_import_batch repo a
130
Added:
(Test_repo.save_import_batch repo a
131
131
(batch ~id:"b1" ~imported_at:(at 500)));
132
Removed:
let bs = run (Memory_repo.import_batches repo a) in
132
Added:
let bs = run (Test_repo.import_batches repo a) in
133
133
Alcotest.(check int) "still one batch" 1 (List.length bs);
134
134
Alcotest.(check int)
135
135
"imported_at updated" 500
@@ -138,65 +138,63 @@
138
138
( "find_import_batch returns the stored batch or none",
139
139
`Quick,
140
140
fun () ->
141
Removed:
let repo = Memory_repo.create () in
141
Added:
let repo = Test_repo.create () in
142
142
let a = trainee 1 in
143
143
run
144
Removed:
(Memory_repo.save_import_batch repo a
144
Added:
(Test_repo.save_import_batch repo a
145
145
(batch ~id:"b1" ~imported_at:(at 100)));
146
146
Alcotest.(check bool)
147
147
"found" true
148
148
(Option.is_some
149
Removed:
(run (Memory_repo.find_import_batch repo a (WI.batch_id "b1"))));
149
Added:
(run (Test_repo.find_import_batch repo a (WI.batch_id "b1"))));
150
150
Alcotest.(check bool)
151
151
"absent" false
152
152
(Option.is_some
153
Removed:
(run (Memory_repo.find_import_batch repo a (WI.batch_id "nope"))))
154
Removed:
);
153
Added:
(run (Test_repo.find_import_batch repo a (WI.batch_id "nope")))) );
155
154
( "deleting a batch leaves promoted records untouched",
156
155
`Quick,
157
156
fun () ->
158
Removed:
let repo = Memory_repo.create () in
157
Added:
let repo = Test_repo.create () in
159
158
let a = trainee 1 in
160
159
run
161
Removed:
(Memory_repo.save_import_batch repo a
160
Added:
(Test_repo.save_import_batch repo a
162
161
(batch ~id:"b1" ~imported_at:(at 100)));
163
162
run
164
Removed:
(Memory_repo.replace_imported_record repo a
163
Added:
(Test_repo.replace_imported_record repo a
165
164
(record ~batch_id:"b1" ~workout_id:"w1" ~revision:0
166
165
~ended_at:(at 3_610) ~load:100.));
167
166
let deleted =
168
Removed:
run (Memory_repo.delete_import_batch repo a (WI.batch_id "b1"))
167
Added:
run (Test_repo.delete_import_batch repo a (WI.batch_id "b1"))
169
168
in
170
169
Alcotest.(check bool) "batch deleted" true deleted;
171
170
Alcotest.(check int)
172
171
"no batches remain" 0
173
Removed:
(List.length (run (Memory_repo.import_batches repo a)));
172
Added:
(List.length (run (Test_repo.import_batches repo a)));
174
173
Alcotest.(check int)
175
174
"record survives" 1
176
Removed:
(List.length (run (Memory_repo.imported_records repo a))) );
175
Added:
(List.length (run (Test_repo.imported_records repo a))) );
177
176
( "deleting an absent batch reports false",
178
177
`Quick,
179
178
fun () ->
180
Removed:
let repo = Memory_repo.create () in
179
Added:
let repo = Test_repo.create () in
181
180
let a = trainee 1 in
182
181
Alcotest.(check bool)
183
182
"nothing to delete" false
184
Removed:
(run (Memory_repo.delete_import_batch repo a (WI.batch_id "ghost")))
185
Removed:
);
183
Added:
(run (Test_repo.delete_import_batch repo a (WI.batch_id "ghost"))) );
186
184
( "a promoted record is replaced by workout id",
187
185
`Quick,
188
186
fun () ->
189
Removed:
let repo = Memory_repo.create () in
187
Added:
let repo = Test_repo.create () in
190
188
let a = trainee 1 in
191
189
run
192
Removed:
(Memory_repo.replace_imported_record repo a
190
Added:
(Test_repo.replace_imported_record repo a
193
191
(record ~batch_id:"b1" ~workout_id:"w1" ~revision:0
194
192
~ended_at:(at 3_610) ~load:100.));
195
193
run
196
Removed:
(Memory_repo.replace_imported_record repo a
194
Added:
(Test_repo.replace_imported_record repo a
197
195
(record ~batch_id:"b1" ~workout_id:"w1" ~revision:1
198
196
~ended_at:(at 3_610) ~load:110.));
199
Removed:
let records = run (Memory_repo.imported_records repo a) in
197
Added:
let records = run (Test_repo.imported_records repo a) in
200
198
Alcotest.(check int) "still one record" 1 (List.length records);
201
199
Alcotest.(check int)
202
200
"revision advanced" 1 (List.hd records).Repository.revision;
@@ -209,27 +207,27 @@
209
207
( "records list most recent ended_at first",
210
208
`Quick,
211
209
fun () ->
212
Removed:
let repo = Memory_repo.create () in
210
Added:
let repo = Test_repo.create () in
213
211
let a = trainee 1 in
214
212
run
215
Removed:
(Memory_repo.replace_imported_record repo a
213
Added:
(Test_repo.replace_imported_record repo a
216
214
(record ~batch_id:"b1" ~workout_id:"w1" ~revision:0
217
215
~ended_at:(at 1_000) ~load:100.));
218
216
run
219
Removed:
(Memory_repo.replace_imported_record repo a
217
Added:
(Test_repo.replace_imported_record repo a
220
218
(record ~batch_id:"b1" ~workout_id:"w2" ~revision:0
221
219
~ended_at:(at 9_000) ~load:100.));
222
220
run
223
Removed:
(Memory_repo.replace_imported_record repo a
221
Added:
(Test_repo.replace_imported_record repo a
224
222
(record ~batch_id:"b1" ~workout_id:"w3" ~revision:0
225
223
~ended_at:(at 5_000) ~load:100.));
226
224
let ended =
227
225
List.map
228
226
(fun r -> Recovery.timestamp_to_unix_seconds r.Repository.ended_at)
229
Removed:
(run (Memory_repo.imported_records repo a))
227
Added:
(run (Test_repo.imported_records repo a))
230
228
in
231
229
Alcotest.(check (list int))
232
230
"newest ended_at first" [ 9_000; 5_000; 1_000 ] ended );
233
231
]
234
232
235
Removed:
let suite = [ ("import_memory_repo", memory_tests) ]
233
Added:
let suite = [ ("import_repository", repository_tests) ]
test/test_import_service.ml
@@ -5,7 +5,7 @@
5
5
against service.mli. *)
6
6
7
7
open Hito_app
8
Removed:
module S = Service.Make (Memory_repo) (Test_hash)
8
Added:
module S = Service.Make (Test_repo) (Test_hash)
9
9
module WI = Workout_import
10
10
11
11
let run = Lwt_main.run
@@ -22,7 +22,7 @@
22
22
let ideal = Repository.routine_id "ideal"
23
23
24
24
let fixture () =
25
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
25
Added:
let s = S.make ~repo:(Test_repo.create ()) in
26
26
let trainee =
27
27
ok (run (S.register s ~username:"lifter" ~password:"heavyduty1"))
28
28
in
test/test_repo.ml
@@ -0,0 +1,16 @@
1
Added:
open Hito_persistence
2
Added:
include Sqlite_repo
3
Added:
4
Added:
let create () =
5
Added:
match
6
Added:
Lwt_main.run
7
Added:
(Sqlite_repo.connect
8
Added:
~pool_config:
9
Added:
(Caqti_pool_config.create ~max_size:1 ~max_idle_size:1
10
Added:
~max_idle_age:None ~max_use_count:None ())
11
Added:
"sqlite3::memory:")
12
Added:
with
13
Added:
| Ok repo -> repo
14
Added:
| Error error ->
15
Added:
failwith
16
Added:
(Printf.sprintf "cannot open test database: %s" (Caqti_error.show error))
test/test_repo.mli
@@ -0,0 +1,6 @@
1
Added:
(** The production SQLite repository on an isolated in-memory database. *)
2
Added:
3
Added:
include module type of Hito_persistence.Sqlite_repo
4
Added:
5
Added:
val create : unit -> t
6
Added:
(** Open a new migrated database for one test. *)
test/test_service.ml
@@ -1,8 +1,8 @@
1
1
(** Tests for {!Hito_app.Service} — the whole HD flow with no web tier, now
2
Removed:
scoped to a trainee and driven over Lwt against the in-memory repository. *)
2
Added:
scoped to a trainee and driven over Lwt against in-memory SQLite. *)
3
3
4
4
open Hito_app
5
Removed:
module S = Service.Make (Memory_repo) (Test_hash)
5
Added:
module S = Service.Make (Test_repo) (Test_hash)
6
6
module Stimulus = Evidence.Stimulus
7
7
module Workout = Evidence.Workout
8
8
@@ -22,7 +22,7 @@
22
22
23
23
(* A fresh service and a registered trainee to own everything. *)
24
24
let fixture () =
25
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
25
Added:
let s = S.make ~repo:(Test_repo.create ()) in
26
26
let trainee =
27
27
ok (run (S.register s ~username:"lifter" ~password:"heavyduty1"))
28
28
in
@@ -52,7 +52,7 @@
52
52
( "registration then authentication with the same password",
53
53
`Quick,
54
54
fun () ->
55
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
55
Added:
let s = S.make ~repo:(Test_repo.create ()) in
56
56
let trainee =
57
57
ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))
58
58
in
@@ -68,7 +68,7 @@
68
68
( "the wrong password does not authenticate",
69
69
`Quick,
70
70
fun () ->
71
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
71
Added:
let s = S.make ~repo:(Test_repo.create ()) in
72
72
let _ =
73
73
ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))
74
74
in
@@ -79,7 +79,7 @@
79
79
( "a duplicate username is refused after normalization",
80
80
`Quick,
81
81
fun () ->
82
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
82
Added:
let s = S.make ~repo:(Test_repo.create ()) in
83
83
let _ =
84
84
ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))
85
85
in
@@ -92,7 +92,7 @@
92
92
( "a normalized username authenticates regardless of case or spacing",
93
93
`Quick,
94
94
fun () ->
95
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
95
Added:
let s = S.make ~repo:(Test_repo.create ()) in
96
96
let _ =
97
97
ok (run (S.register s ~username:"alice" ~password:"heavyduty1"))
98
98
in
@@ -105,14 +105,14 @@
105
105
( "a username under four characters is refused",
106
106
`Quick,
107
107
fun () ->
108
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
108
Added:
let s = S.make ~repo:(Test_repo.create ()) in
109
109
match run (S.register s ~username:"abc" ~password:"heavyduty1") with
110
110
| Error (S.Username_invalid Trainee.Too_short) -> ()
111
111
| _ -> Alcotest.fail "expected Too_short" );
112
112
( "a four-character username is accepted",
113
113
`Quick,
114
114
fun () ->
115
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
115
Added:
let s = S.make ~repo:(Test_repo.create ()) in
116
116
match run (S.register s ~username:"abcd" ~password:"heavyduty1") with
117
117
| Ok _ -> ()
118
118
| Error _ ->
@@ -120,7 +120,7 @@
120
120
( "a twenty-character username is accepted",
121
121
`Quick,
122
122
fun () ->
123
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
123
Added:
let s = S.make ~repo:(Test_repo.create ()) in
124
124
match
125
125
run (S.register s ~username:"abcdefghijklmnopqrst" ~password:"pw")
126
126
with
@@ -130,7 +130,7 @@
130
130
( "a username over twenty characters is refused",
131
131
`Quick,
132
132
fun () ->
133
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
133
Added:
let s = S.make ~repo:(Test_repo.create ()) in
134
134
match
135
135
run (S.register s ~username:"abcdefghijklmnopqrstu" ~password:"pw")
136
136
with
@@ -139,7 +139,7 @@
139
139
( "surrounding whitespace does not count toward the length bounds",
140
140
`Quick,
141
141
fun () ->
142
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
142
Added:
let s = S.make ~repo:(Test_repo.create ()) in
143
143
(* " abcd " normalizes to the four-character "abcd". *)
144
144
match run (S.register s ~username:" abcd " ~password:"pw") with
145
145
| Ok trainee ->
@@ -151,14 +151,14 @@
151
151
( "a short password is accepted",
152
152
`Quick,
153
153
fun () ->
154
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
154
Added:
let s = S.make ~repo:(Test_repo.create ()) in
155
155
match run (S.register s ~username:"alice" ~password:"x") with
156
156
| Ok _ -> ()
157
157
| Error _ -> Alcotest.fail "expected a short password to be accepted" );
158
158
( "an empty password is accepted",
159
159
`Quick,
160
160
fun () ->
161
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
161
Added:
let s = S.make ~repo:(Test_repo.create ()) in
162
162
match run (S.register s ~username:"bobby" ~password:"") with
163
163
| Ok _ -> ()
164
164
| Error _ -> Alcotest.fail "expected an empty password to be accepted"
@@ -166,7 +166,7 @@
166
166
( "a short password still authenticates",
167
167
`Quick,
168
168
fun () ->
169
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
169
Added:
let s = S.make ~repo:(Test_repo.create ()) in
170
170
let _ = ok (run (S.register s ~username:"carol" ~password:"x")) in
171
171
Alcotest.(check bool)
172
172
"signs in" true
@@ -175,7 +175,7 @@
175
175
( "two trainees keep separate logs",
176
176
`Quick,
177
177
fun () ->
178
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
178
Added:
let s = S.make ~repo:(Test_repo.create ()) in
179
179
let a =
180
180
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
181
181
.Trainee.id
@@ -192,7 +192,7 @@
192
192
( "changing the username renames the account",
193
193
`Quick,
194
194
fun () ->
195
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
195
Added:
let s = S.make ~repo:(Test_repo.create ()) in
196
196
let id =
197
197
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
198
198
.Trainee.id
@@ -213,7 +213,7 @@
213
213
( "renaming to the account's own name is a no-op success",
214
214
`Quick,
215
215
fun () ->
216
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
216
Added:
let s = S.make ~repo:(Test_repo.create ()) in
217
217
let id =
218
218
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
219
219
.Trainee.id
@@ -227,7 +227,7 @@
227
227
( "renaming to another trainee's name is refused",
228
228
`Quick,
229
229
fun () ->
230
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
230
Added:
let s = S.make ~repo:(Test_repo.create ()) in
231
231
let a =
232
232
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
233
233
.Trainee.id
@@ -241,7 +241,7 @@
241
241
( "an invalid new username is refused",
242
242
`Quick,
243
243
fun () ->
244
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
244
Added:
let s = S.make ~repo:(Test_repo.create ()) in
245
245
let id =
246
246
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
247
247
.Trainee.id
@@ -252,7 +252,7 @@
252
252
( "changing the password requires the current one",
253
253
`Quick,
254
254
fun () ->
255
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
255
Added:
let s = S.make ~repo:(Test_repo.create ()) in
256
256
let id =
257
257
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
258
258
.Trainee.id
@@ -271,7 +271,7 @@
271
271
( "a correct current password changes the password",
272
272
`Quick,
273
273
fun () ->
274
Removed:
let s = S.make ~repo:(Memory_repo.create ()) in
274
Added:
let s = S.make ~repo:(Test_repo.create ()) in
275
275
let id =
276
276
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
277
277
.Trainee.id
test/web/app_feedback.ml
@@ -25,7 +25,7 @@
25
25
let stored_count () =
26
26
List.length
27
27
(Lwt_main.run
28
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id))
28
Added:
(Test_repo.app_feedback repo ~viewer:trainee.Trainee.id))
29
29
in
30
30
let token =
31
31
Option.get (csrf_token (body (get c "/app-feedback")))
@@ -60,7 +60,7 @@
60
60
(* The report now exists with the exact message. *)
61
61
let reports =
62
62
Lwt_main.run
63
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)
63
Added:
(Test_repo.app_feedback repo ~viewer:trainee.Trainee.id)
64
64
in
65
65
Alcotest.(check int) "one report stored" 1 (List.length reports);
66
66
Alcotest.(check string)
@@ -110,7 +110,7 @@
110
110
let feedback_id () =
111
111
(List.hd
112
112
(Lwt_main.run
113
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
113
Added:
(Test_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
114
114
.Repository.feedback_id |> Repository.app_feedback_id_to_string
115
115
in
116
116
let id = feedback_id () in
@@ -129,7 +129,7 @@
129
129
"message unchanged by blank edit" "First report"
130
130
(List.hd
131
131
(Lwt_main.run
132
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
132
Added:
(Test_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
133
133
.Repository.message;
134
134
(* A real edit changes the stored message. *)
135
135
let token =
@@ -146,7 +146,7 @@
146
146
"message updated by edit" "Edited report"
147
147
(List.hd
148
148
(Lwt_main.run
149
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
149
Added:
(Test_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
150
150
.Repository.message;
151
151
(* Removal deletes the report. *)
152
152
let token =
@@ -163,7 +163,7 @@
163
163
"report removed" 0
164
164
(List.length
165
165
(Lwt_main.run
166
Removed:
(Memory_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
166
Added:
(Test_repo.app_feedback repo ~viewer:trainee.Trainee.id)))
167
167
);
168
168
( "another trainee cannot edit or remove app feedback",
169
169
`Quick,
@@ -185,7 +185,7 @@
185
185
in
186
186
let stored () =
187
187
Lwt_main.run
188
Removed:
(Memory_repo.app_feedback repo ~viewer:bob_trainee.Trainee.id)
188
Added:
(Test_repo.app_feedback repo ~viewer:bob_trainee.Trainee.id)
189
189
in
190
190
Alcotest.(check int)
191
191
"one report before cross-user attempts" 1
test/web/auth.ml
@@ -215,7 +215,7 @@
215
215
"no active routine" true
216
216
(Option.is_none
217
217
(Lwt_main.run
218
Removed:
(Memory_repo.active_routine repo trainee.Trainee.id))) );
218
Added:
(Test_repo.active_routine repo trainee.Trainee.id))) );
219
219
( "a too-short username is refused",
220
220
`Quick,
221
221
fun () ->
@@ -226,7 +226,7 @@
226
226
"no account created" None
227
227
(Lwt_main.run
228
228
(match Trainee.username "abc" with
229
Removed:
| Ok u -> Memory_repo.find_trainee_by_username repo u
229
Added:
| Ok u -> Test_repo.find_trainee_by_username repo u
230
230
| Error _ -> Lwt.return None)
231
231
|> Option.map (fun t -> Trainee.id_to_string t.Trainee.id)) );
232
232
( "a too-long username is refused",
@@ -251,7 +251,7 @@
251
251
`Quick,
252
252
fun () ->
253
253
(* The production default: [registration_open] unset. *)
254
Removed:
let handlers = Handlers.make ~repo:(Memory_repo.create ()) () in
254
Added:
let handlers = Handlers.make ~repo:(Test_repo.create ()) () in
255
255
let app =
256
256
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers)
257
257
|> fun h -> Dream.set_secret "test-secret-value" h
test/web/import.ml
@@ -25,10 +25,10 @@
25
25
in
26
26
let review_token c url = Option.get (csrf_token (body (get c url))) in
27
27
let batches repo trainee =
28
Removed:
Lwt_main.run (Memory_repo.import_batches repo trainee.Trainee.id)
28
Added:
Lwt_main.run (Test_repo.import_batches repo trainee.Trainee.id)
29
29
in
30
30
let imported repo trainee =
31
Removed:
Lwt_main.run (Memory_repo.imported_records repo trainee.Trainee.id)
31
Added:
Lwt_main.run (Test_repo.imported_records repo trainee.Trainee.id)
32
32
in
33
33
[
34
34
( "a valid native export uploads to a stored batch with immutable source",
test/web/isolation.ml
@@ -44,34 +44,33 @@
44
44
Alcotest.(check bool)
45
45
"Alice has a workout in progress" true
46
46
(Option.is_some
47
Removed:
(Lwt_main.run
48
Removed:
(Memory_repo.in_progress repo alice_t.Trainee.id)));
47
Added:
(Lwt_main.run (Test_repo.in_progress repo alice_t.Trainee.id)));
49
48
Alcotest.(check bool)
50
49
"Bob has no workout in progress" true
51
50
(Option.is_none
52
Removed:
(Lwt_main.run (Memory_repo.in_progress repo bob_t.Trainee.id)));
51
Added:
(Lwt_main.run (Test_repo.in_progress repo bob_t.Trainee.id)));
53
52
Alcotest.(check int)
54
53
"Bob's workout view redirects" 303
55
54
(status (get bob "/workout"));
56
Removed:
(* Alice finishes; her record becomes w1 for her. *)
55
Added:
(* Alice finishes; her record becomes t1:w1 for her. *)
57
56
let token = Option.get (csrf_token (body (get alice "/workout"))) in
58
57
let _ = post alice "/workout/finish" [ ("dream.csrf", token) ] in
59
58
Alcotest.(check int)
60
59
"Alice has one saved workout" 1
61
60
(List.length
62
Removed:
(Lwt_main.run (Memory_repo.history repo alice_t.Trainee.id)));
61
Added:
(Lwt_main.run (Test_repo.history repo alice_t.Trainee.id)));
63
62
Alcotest.(check int)
64
63
"Alice sees her saved workout" 200
65
Removed:
(status (get alice "/logbook/w1"));
64
Added:
(status (get alice "/logbook/t1:w1"));
66
65
(* Bob's history is empty, and Alice's record is unreachable from
67
Removed:
Bob's session. Ids are per-trainee, so Bob's own w1 does not
66
Added:
Bob's session. The stored identity names Alice, so it does not
68
67
exist. *)
69
68
Alcotest.(check int)
70
69
"Bob's history is empty" 0
71
70
(List.length
72
Removed:
(Lwt_main.run (Memory_repo.history repo bob_t.Trainee.id)));
71
Added:
(Lwt_main.run (Test_repo.history repo bob_t.Trainee.id)));
73
72
Alcotest.(check int)
74
73
"Bob cannot open a record he does not own" 404
75
Removed:
(status (get bob "/logbook/w1")) );
74
Added:
(status (get bob "/logbook/t1:w1")) );
76
75
] );
77
76
]
test/web/logbook.ml
@@ -157,11 +157,11 @@
157
157
in
158
158
ignore
159
159
(Lwt_main.run
160
Removed:
(Memory_repo.finish_workout repo trainee.Trainee.id
160
Added:
(Test_repo.finish_workout repo trainee.Trainee.id
161
161
(saved ~started:0 ~load:10. ~reps:8)));
162
162
ignore
163
163
(Lwt_main.run
164
Removed:
(Memory_repo.finish_workout repo trainee.Trainee.id
164
Added:
(Test_repo.finish_workout repo trainee.Trainee.id
165
165
(saved ~started:172_800 ~load:12. ~reps:9)));
166
166
(* Progress lives in the entry's accordion panel, always in the
167
167
markup — no expand round-trip. The later workout progressed, so
@@ -192,27 +192,27 @@
192
192
("accordion panel contains " ^ needle)
193
193
true
194
194
(Option.is_some (index_from ~needle page 0)))
195
Removed:
[ "Edit"; "Delete"; "/logbook?delete=w1" ];
196
Removed:
let confirm = body (get c "/logbook?delete=w1") in
195
Added:
[ "Edit"; "Delete"; "/logbook?delete=t1:w1" ];
196
Added:
let confirm = body (get c "/logbook?delete=t1:w1") in
197
197
Alcotest.(check bool)
198
198
"delete asks for confirmation" true
199
199
(Option.is_some
200
200
(index_from ~needle:"Delete this workout log?" confirm 0));
201
201
let confirm_token = Option.get (csrf_token confirm) in
202
202
let deleted =
203
Removed:
post c "/logbook/w1/delete" [ ("dream.csrf", confirm_token) ]
203
Added:
post c "/logbook/t1:w1/delete" [ ("dream.csrf", confirm_token) ]
204
204
in
205
205
Alcotest.(check int) "delete redirects" 303 (status deleted);
206
206
Alcotest.(check int)
207
207
"record removed from history" 0
208
208
(List.length
209
Removed:
(Lwt_main.run (Memory_repo.history repo trainee.Trainee.id)));
209
Added:
(Lwt_main.run (Test_repo.history repo trainee.Trainee.id)));
210
210
Alcotest.(check bool)
211
211
"record cannot be found" true
212
212
(Option.is_none
213
213
(Lwt_main.run
214
Removed:
(Memory_repo.find repo trainee.Trainee.id
215
Removed:
(Repository.workout_id "w1")))) );
214
Added:
(Test_repo.find repo trainee.Trainee.id
215
Added:
(Repository.workout_id "t1:w1")))) );
216
216
( "a saved workout's slot can be corrected from the logbook view",
217
217
`Quick,
218
218
fun () ->
@@ -239,13 +239,13 @@
239
239
in
240
240
let token = Option.get (csrf_token (body (get c "/workout"))) in
241
241
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
242
Removed:
(* The one saved workout is w1 for this trainee. Correct its slot
242
Added:
(* The one saved workout is t1:w1 for this trainee. Correct its slot
243
243
through the logbook path, then confirm the store still has one
244
244
filled slot — a correction, not extra volume. *)
245
Removed:
let record_page = body (get c "/logbook/w1?slot=1") in
245
Added:
let record_page = body (get c "/logbook/t1:w1?slot=1") in
246
246
let token = Option.get (csrf_token record_page) in
247
247
let corrected =
248
Removed:
post c "/logbook/w1/slots/1/edit"
248
Added:
post c "/logbook/t1:w1/slots/1/edit"
249
249
[
250
250
("dream.csrf", token);
251
251
("load", "20");
@@ -256,14 +256,14 @@
256
256
Alcotest.(check int) "corrected" 303 (status corrected);
257
257
let record =
258
258
Lwt_main.run
259
Removed:
(Memory_repo.find repo trainee.Trainee.id
260
Removed:
(Repository.workout_id "w1"))
259
Added:
(Test_repo.find repo trainee.Trainee.id
260
Added:
(Repository.workout_id "t1:w1"))
261
261
in
262
262
Alcotest.(check int)
263
263
"still one filled slot" 1
264
264
(match record with
265
265
| Some r -> Evidence.Workout.filled_slots r.Repository.workout
266
Removed:
| None -> Alcotest.failf "expected the saved workout w1") );
266
Added:
| None -> Alcotest.failf "expected the saved workout t1:w1") );
267
267
( "an outstanding slot of a saved workout can be recorded, not only \
268
268
corrected",
269
269
`Quick,
@@ -296,23 +296,23 @@
296
296
in
297
297
let token = Option.get (csrf_token (body (get c "/workout"))) in
298
298
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
299
Removed:
let filled_of_w1 () =
299
Added:
let filled_of_record () =
300
300
match
301
301
Lwt_main.run
302
Removed:
(Memory_repo.find repo trainee.Trainee.id
303
Removed:
(Repository.workout_id "w1"))
302
Added:
(Test_repo.find repo trainee.Trainee.id
303
Added:
(Repository.workout_id "t1:w1"))
304
304
with
305
305
| Some r -> Evidence.Workout.filled_slots r.Repository.workout
306
Removed:
| None -> Alcotest.failf "expected the saved workout w1"
306
Added:
| None -> Alcotest.failf "expected the saved workout t1:w1"
307
307
in
308
308
Alcotest.(check int)
309
Removed:
"saved workout starts with one slot" 1 (filled_of_w1 ());
309
Added:
"saved workout starts with one slot" 1 (filled_of_record ());
310
310
(* Add slot 2 through the non-edit path. *)
311
311
let token =
312
Removed:
Option.get (csrf_token (body (get c "/logbook/w1?slot=2")))
312
Added:
Option.get (csrf_token (body (get c "/logbook/t1:w1?slot=2")))
313
313
in
314
314
let added =
315
Removed:
post c "/logbook/w1/slots/2"
315
Added:
post c "/logbook/t1:w1/slots/2"
316
316
[
317
317
("dream.csrf", token);
318
318
("load", "10");
@@ -322,7 +322,8 @@
322
322
in
323
323
Alcotest.(check int)
324
324
"recorded a saved-workout slot" 303 (status added);
325
Removed:
Alcotest.(check int) "now two filled slots" 2 (filled_of_w1 ()) );
325
Added:
Alcotest.(check int) "now two filled slots" 2 (filled_of_record ())
326
Added:
);
326
327
( "recording an already-filled slot through the add path is refused",
327
328
`Quick,
328
329
fun () ->
@@ -354,10 +355,10 @@
354
355
let _ = post c "/workout/finish" [ ("dream.csrf", token) ] in
355
356
(* Slot 1 is filled. Re-posting to its add path is refused. *)
356
357
let token =
357
Removed:
Option.get (csrf_token (body (get c "/logbook/w1?slot=2")))
358
Added:
Option.get (csrf_token (body (get c "/logbook/t1:w1?slot=2")))
358
359
in
359
360
let refused =
360
Removed:
post c "/logbook/w1/slots/1"
361
Added:
post c "/logbook/t1:w1/slots/1"
361
362
[
362
363
("dream.csrf", token);
363
364
("load", "20");
@@ -372,11 +373,11 @@
372
373
"still one filled slot" 1
373
374
(match
374
375
Lwt_main.run
375
Removed:
(Memory_repo.find repo trainee.Trainee.id
376
Removed:
(Repository.workout_id "w1"))
376
Added:
(Test_repo.find repo trainee.Trainee.id
377
Added:
(Repository.workout_id "t1:w1"))
377
378
with
378
379
| Some r -> Evidence.Workout.filled_slots r.Repository.workout
379
Removed:
| None -> Alcotest.failf "expected the saved workout w1") );
380
Added:
| None -> Alcotest.failf "expected the saved workout t1:w1") );
380
381
( "the feedback modal shows every factor with three choices, none \
381
382
preselected, and one submit",
382
383
`Quick,
@@ -430,7 +431,7 @@
430
431
Alcotest.(check string)
431
432
"back to the logbook" "/logbook" (location saved);
432
433
let reports =
433
Removed:
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
434
Added:
Lwt_main.run (Test_repo.feedback repo trainee.Trainee.id)
434
435
in
435
436
Alcotest.(check int) "one report stored" 1 (List.length reports);
436
437
Alcotest.(check bool)
@@ -454,7 +455,7 @@
454
455
in
455
456
Alcotest.(check int) "submit redirects" 303 (status saved);
456
457
let reports =
457
Removed:
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
458
Added:
Lwt_main.run (Test_repo.feedback repo trainee.Trainee.id)
458
459
in
459
460
Alcotest.(check int) "one report stored" 1 (List.length reports);
460
461
let signals = Feedback.signals (List.hd reports) in
@@ -480,8 +481,7 @@
480
481
Alcotest.(check int)
481
482
"no report stored" 0
482
483
(List.length
483
Removed:
(Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)))
484
Removed:
);
484
Added:
(Lwt_main.run (Test_repo.feedback repo trainee.Trainee.id))) );
485
485
( "a value outside the three choices is ignored",
486
486
`Quick,
487
487
fun () ->
@@ -501,7 +501,7 @@
501
501
in
502
502
Alcotest.(check int) "submit redirects" 303 (status bad);
503
503
let reports =
504
Removed:
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
504
Added:
Lwt_main.run (Test_repo.feedback repo trainee.Trainee.id)
505
505
in
506
506
Alcotest.(check int) "one report stored" 1 (List.length reports);
507
507
Alcotest.(check bool)
@@ -534,7 +534,7 @@
534
534
let batch =
535
535
List.hd
536
536
(Lwt_main.run
537
Removed:
(Memory_repo.import_batches repo trainee.Trainee.id))
537
Added:
(Test_repo.import_batches repo trainee.Trainee.id))
538
538
in
539
539
let bid =
540
540
Workout_import.batch_id_to_string
@@ -566,7 +566,7 @@
566
566
"the import is promoted" 1
567
567
(List.length
568
568
(Lwt_main.run
569
Removed:
(Memory_repo.imported_records repo trainee.Trainee.id)));
569
Added:
(Test_repo.imported_records repo trainee.Trainee.id)));
570
570
let page = body (get c "/logbook?year=2024&month=1") in
571
571
Alcotest.(check bool)
572
572
"the imported workout title is shown" true
@@ -636,7 +636,7 @@
636
636
let batch =
637
637
List.hd
638
638
(Lwt_main.run
639
Removed:
(Memory_repo.import_batches repo trainee.Trainee.id))
639
Added:
(Test_repo.import_batches repo trainee.Trainee.id))
640
640
in
641
641
let bid =
642
642
Workout_import.batch_id_to_string
@@ -671,7 +671,7 @@
671
671
"both imports promoted" 2
672
672
(List.length
673
673
(Lwt_main.run
674
Removed:
(Memory_repo.imported_records repo trainee.Trainee.id)));
674
Added:
(Test_repo.imported_records repo trainee.Trainee.id)));
675
675
let page = body (get c "/logbook?year=2024&month=1") in
676
676
(* The later import gained 10 kg over the earlier one, shown as a
677
677
green weight delta. *)
@@ -708,7 +708,7 @@
708
708
let batch =
709
709
List.hd
710
710
(Lwt_main.run
711
Removed:
(Memory_repo.import_batches repo trainee.Trainee.id))
711
Added:
(Test_repo.import_batches repo trainee.Trainee.id))
712
712
in
713
713
let bid =
714
714
Workout_import.batch_id_to_string
@@ -777,7 +777,7 @@
777
777
let batch =
778
778
List.hd
779
779
(Lwt_main.run
780
Removed:
(Memory_repo.import_batches repo trainee.Trainee.id))
780
Added:
(Test_repo.import_batches repo trainee.Trainee.id))
781
781
in
782
782
let bid =
783
783
Workout_import.batch_id_to_string
test/web/overview.ml
@@ -18,7 +18,7 @@
18
18
"no active routine before selection" true
19
19
(Option.is_none
20
20
(Lwt_main.run
21
Removed:
(Memory_repo.active_routine repo trainee.Trainee.id)));
21
Added:
(Test_repo.active_routine repo trainee.Trainee.id)));
22
22
let token = Option.get (csrf_token (body (get c "/"))) in
23
23
let selection =
24
24
post c "/routines/ideal/select" [ ("dream.csrf", token) ]
@@ -28,7 +28,7 @@
28
28
"a routine is now active" true
29
29
(Option.is_some
30
30
(Lwt_main.run
31
Removed:
(Memory_repo.active_routine repo trainee.Trainee.id)));
31
Added:
(Test_repo.active_routine repo trainee.Trainee.id)));
32
32
(* The redirected GET is served. *)
33
33
Alcotest.(check int)
34
34
"the redirected GET is 200" 200
@@ -79,7 +79,7 @@
79
79
let batch =
80
80
List.hd
81
81
(Lwt_main.run
82
Removed:
(Memory_repo.import_batches repo trainee.Trainee.id))
82
Added:
(Test_repo.import_batches repo trainee.Trainee.id))
83
83
in
84
84
let bid =
85
85
Workout_import.batch_id_to_string
@@ -199,6 +199,6 @@
199
199
"no routine was selected" true
200
200
(Option.is_none
201
201
(Lwt_main.run
202
Removed:
(Memory_repo.active_routine repo trainee.Trainee.id))) );
202
Added:
(Test_repo.active_routine repo trainee.Trainee.id))) );
203
203
] );
204
204
]
test/web/profile.ml
@@ -33,7 +33,7 @@
33
33
(* The account now answers to the new name, and no longer to the
34
34
old one. *)
35
35
let renamed =
36
Removed:
Lwt_main.run (Memory_repo.find_trainee repo trainee.Trainee.id)
36
Added:
Lwt_main.run (Test_repo.find_trainee repo trainee.Trainee.id)
37
37
in
38
38
Alcotest.(check (option string))
39
39
"stored under the new username" (Some "athlete")
@@ -45,7 +45,7 @@
45
45
(Option.is_none
46
46
(Lwt_main.run
47
47
(match Trainee.username "lifter" with
48
Removed:
| Ok u -> Memory_repo.find_trainee_by_username repo u
48
Added:
| Ok u -> Test_repo.find_trainee_by_username repo u
49
49
| Error _ -> Lwt.return None))) );
50
50
( "a taken username is refused and the account keeps its name",
51
51
`Quick,
@@ -68,8 +68,8 @@
68
68
"name unchanged after refusal" (Some "lifter")
69
69
(Option.map
70
70
(fun t -> Trainee.username_to_string t.Trainee.username)
71
Removed:
(Lwt_main.run
72
Removed:
(Memory_repo.find_trainee repo trainee.Trainee.id))) );
71
Added:
(Lwt_main.run (Test_repo.find_trainee repo trainee.Trainee.id)))
72
Added:
);
73
73
( "changing the password requires the current one",
74
74
`Quick,
75
75
fun () ->
test/web/support.ml
@@ -1,20 +1,20 @@
1
1
(** Shared support for the web tier tests. Sessions and CSRF are exercised end
2
2
to end: a small client carries the session cookie between requests and pulls
3
3
the CSRF token out of the rendered page, exactly as a browser would. The
4
Removed:
in-memory repository stands in for SQLite; session storage is Dream's
4
Added:
SQLite runs in an isolated in-memory database; session storage is Dream's
5
5
in-memory back end. *)
6
6
7
7
open Hito_app
8
8
9
9
module Handlers =
10
Removed:
Hito_web.Handlers.Make (Memory_repo) (Test_hash) (Hito_import.Hevy_csv)
10
Added:
Hito_web.Handlers.Make (Test_repo) (Test_hash) (Hito_import.Hevy_csv)
11
11
12
12
(* A fresh, fully wired application: secret, in-memory sessions, routes.
13
13
Registration is opened here so the auth-flow tests can create trainees via
14
14
[/register]; production keeps it closed. *)
15
15
let app () =
16
16
let handlers =
17
Removed:
Handlers.make ~repo:(Memory_repo.create ()) ~registration_open:true ()
17
Added:
Handlers.make ~repo:(Test_repo.create ()) ~registration_open:true ()
18
18
in
19
19
Dream.memory_sessions @@ Handlers.security_headers
20
20
@@ Dream.router (Handlers.routes handlers)
@@ -208,14 +208,14 @@
208
208
post client "/login"
209
209
[ ("dream.csrf", token); ("username", username); ("password", password) ]
210
210
211
Removed:
(* An application whose clock the test drives. A shared [Memory_repo] and a
211
Added:
(* An application whose clock the test drives. A shared [Test_repo] and a
212
212
mutable [now] cell let a deep test advance time across the recovery gate,
213
213
which the wall-clock default cannot. Registration is open so the test can
214
214
create the trainee it drives. Also hands back the repository, so a deep test
215
215
can assert the domain state its flow produced. *)
216
216
let clocked_client () =
217
217
let now = ref 0 in
218
Removed:
let repo = Memory_repo.create () in
218
Added:
let repo = Test_repo.create () in
219
219
let handlers =
220
220
Handlers.make ~repo
221
221
~now:(fun () -> Recovery.timestamp_of_unix_seconds !now)
@@ -233,7 +233,7 @@
233
233
state the flow produced — the log, the stored feedback, the renamed account —
234
234
rather than reading it back out of rendered HTML. *)
235
235
let client_with_repo () =
236
Removed:
let repo = Memory_repo.create () in
236
Added:
let repo = Test_repo.create () in
237
237
let handlers = Handlers.make ~repo ~registration_open:true () in
238
238
let app =
239
239
Dream.memory_sessions @@ Dream.router (Handlers.routes handlers) |> fun h ->
@@ -246,7 +246,7 @@
246
246
match Trainee.username username with
247
247
| Error _ -> Alcotest.failf "test username %S is invalid" username
248
248
| Ok u -> (
249
Removed:
match Lwt_main.run (Memory_repo.find_trainee_by_username repo u) with
249
Added:
match Lwt_main.run (Test_repo.find_trainee_by_username repo u) with
250
250
| Some trainee -> trainee
251
251
| None -> Alcotest.failf "no trainee named %S" username)
252
252
test/web/workout.ml
@@ -26,8 +26,7 @@
26
26
Alcotest.(check bool)
27
27
"a workout is in progress" true
28
28
(Option.is_some
29
Removed:
(Lwt_main.run
30
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id)));
29
Added:
(Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)));
31
30
Alcotest.(check int)
32
31
"the workout view is served" 200
33
32
(status (get c "/workout"));
@@ -123,8 +122,8 @@
123
122
Alcotest.(check bool)
124
123
"no new workout in progress" true
125
124
(Option.is_none
126
Removed:
(Lwt_main.run
127
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id))) );
125
Added:
(Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)))
126
Added:
);
128
127
( "overriding recovery begins the next workout on an override basis",
129
128
`Quick,
130
129
fun () ->
@@ -149,7 +148,7 @@
149
148
Alcotest.(check int) "override begin succeeds" 303 (status began);
150
149
let basis =
151
150
match
152
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
151
Added:
Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)
153
152
with
154
153
| Some w -> Recovery.basis (Evidence.Workout.clearance w)
155
154
| None -> Alcotest.failf "expected a workout in progress"
@@ -171,7 +170,7 @@
171
170
in
172
171
let filled () =
173
172
match
174
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
173
Added:
Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)
175
174
with
176
175
| Some w -> Evidence.Workout.filled_slots w
177
176
| None -> Alcotest.failf "expected a workout in progress"
@@ -221,7 +220,7 @@
221
220
Alcotest.(check int) "recorded" 303 (status recorded);
222
221
let filled_after_record () =
223
222
match
224
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
223
Added:
Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)
225
224
with
226
225
| Some w -> Evidence.Workout.filled_slots w
227
226
| None -> Alcotest.failf "expected a workout in progress"
@@ -246,7 +245,7 @@
246
245
(* The stored slot now holds the corrected values, not the originals. *)
247
246
let slot1_effort () =
248
247
match
249
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
248
Added:
Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)
250
249
with
251
250
| Some w -> (
252
251
match List.assoc_opt 1 (Evidence.Workout.performed w) with
@@ -298,7 +297,7 @@
298
297
Alcotest.(check int)
299
298
"no slot was filled" 0
300
299
(match
301
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
300
Added:
Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)
302
301
with
303
302
| Some w -> Evidence.Workout.filled_slots w
304
303
| None -> Alcotest.failf "expected a workout in progress") );
@@ -327,7 +326,7 @@
327
326
Alcotest.(check int)
328
327
"nothing recorded" 0
329
328
(match
330
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
329
Added:
Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)
331
330
with
332
331
| Some w -> Evidence.Workout.filled_slots w
333
332
| None -> Alcotest.failf "expected a workout in progress") );
@@ -391,8 +390,8 @@
391
390
Alcotest.(check bool)
392
391
"workout still in progress" true
393
392
(Option.is_some
394
Removed:
(Lwt_main.run
395
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id))) );
393
Added:
(Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)))
394
Added:
);
396
395
( "cancelling after recording a set discards the workout entirely",
397
396
`Quick,
398
397
fun () ->
@@ -431,15 +430,14 @@
431
430
Alcotest.(check bool)
432
431
"no workout in progress" true
433
432
(Option.is_none
434
Removed:
(Lwt_main.run
435
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id)));
433
Added:
(Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)));
436
434
Alcotest.(check int)
437
435
"history is empty" 0
438
436
(List.length
439
Removed:
(Lwt_main.run (Memory_repo.history repo trainee.Trainee.id)));
437
Added:
(Lwt_main.run (Test_repo.history repo trainee.Trainee.id)));
440
438
Alcotest.(check int)
441
439
"the discarded workout has no record" 404
442
Removed:
(status (get c "/logbook/w1")) );
440
Added:
(status (get c "/logbook/t1:w1")) );
443
441
( "finishing a workout redirects to the logbook feedback prompt",
444
442
`Quick,
445
443
fun () ->
@@ -463,12 +461,12 @@
463
461
Alcotest.(check int)
464
462
"one workout in history" 1
465
463
(List.length
466
Removed:
(Lwt_main.run (Memory_repo.history repo trainee.Trainee.id)));
464
Added:
(Lwt_main.run (Test_repo.history repo trainee.Trainee.id)));
467
465
Alcotest.(check bool)
468
466
"nothing in progress" true
469
467
(Option.is_none
470
Removed:
(Lwt_main.run
471
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id))) );
468
Added:
(Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)))
469
Added:
);
472
470
( "a full cycle: begin Day 1, record every slot, finish, and see it \
473
471
saved complete",
474
472
`Quick,
@@ -485,7 +483,7 @@
485
483
let _ = start_day_one c in
486
484
let in_progress_filled () =
487
485
match
488
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
486
Added:
Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)
489
487
with
490
488
| Some w -> Evidence.Workout.filled_slots w
491
489
| None -> Alcotest.failf "expected a workout in progress"
@@ -504,7 +502,7 @@
504
502
(Dream.headers finished "Location"));
505
503
(* History holds one complete Day 1 with four stimuli. *)
506
504
let history =
507
Removed:
Lwt_main.run (Memory_repo.history repo trainee.Trainee.id)
505
Added:
Lwt_main.run (Test_repo.history repo trainee.Trainee.id)
508
506
in
509
507
Alcotest.(check int)
510
508
"one workout in history" 1 (List.length history);
@@ -521,7 +519,7 @@
521
519
(* The saved workout is durable and reachable at its own URL. *)
522
520
Alcotest.(check int)
523
521
"the saved workout is reachable" 200
524
Removed:
(status (get c "/logbook/w1")) );
522
Added:
(status (get c "/logbook/t1:w1")) );
525
523
( "the finish actions read as an outline until every slot is recorded",
526
524
`Quick,
527
525
fun () ->
@@ -610,8 +608,7 @@
610
608
Alcotest.(check bool)
611
609
"no workout was started" true
612
610
(Option.is_none
613
Removed:
(Lwt_main.run
614
Removed:
(Memory_repo.in_progress repo trainee.Trainee.id)));
611
Added:
(Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)));
615
612
(* Rest two full days: past the 48-hour training interval. The gate
616
613
clears and the next begin succeeds. *)
617
614
now := day 13;
@@ -627,7 +624,7 @@
627
624
override. *)
628
625
let workout =
629
626
match
630
Removed:
Lwt_main.run (Memory_repo.in_progress repo trainee.Trainee.id)
627
Added:
Lwt_main.run (Test_repo.in_progress repo trainee.Trainee.id)
631
628
with
632
629
| Some w -> w
633
630
| None -> Alcotest.failf "expected a workout in progress"