1 type migration = { version : int; name : string; statements : string list } 2 3 let migrations = 4 [ 5 { 6 version = 1; 7 name = "initial schema"; 8 statements = 9 [ 10 {|CREATE TABLE IF NOT EXISTS trainee ( 11 id TEXT PRIMARY KEY, 12 username TEXT NOT NULL UNIQUE, 13 credential TEXT NOT NULL 14 )|}; 15 {|CREATE TABLE IF NOT EXISTS active_routine ( 16 trainee_id TEXT PRIMARY KEY, 17 routine_id TEXT NOT NULL 18 )|}; 19 {|CREATE TABLE IF NOT EXISTS in_progress ( 20 trainee_id TEXT PRIMARY KEY, 21 encoded TEXT NOT NULL 22 )|}; 23 {|CREATE TABLE IF NOT EXISTS workout ( 24 id TEXT PRIMARY KEY, 25 trainee_id TEXT NOT NULL, 26 seq INTEGER NOT NULL, 27 encoded TEXT NOT NULL 28 )|}; 29 {|CREATE INDEX IF NOT EXISTS workout_by_trainee 30 ON workout (trainee_id, seq DESC)|}; 31 (* The table Dream's sql_sessions back end expects. *) 32 {|CREATE TABLE IF NOT EXISTS dream_session ( 33 id TEXT PRIMARY KEY, 34 label TEXT NOT NULL, 35 expires_at REAL NOT NULL, 36 payload TEXT NOT NULL 37 )|}; 38 ]; 39 }; 40 { 41 version = 2; 42 name = "subjective feedback"; 43 statements = 44 [ 45 {|CREATE TABLE IF NOT EXISTS feedback ( 46 trainee_id TEXT NOT NULL, 47 seq INTEGER NOT NULL, 48 encoded TEXT NOT NULL, 49 PRIMARY KEY (trainee_id, seq) 50 )|}; 51 {|CREATE INDEX IF NOT EXISTS feedback_by_trainee 52 ON feedback (trainee_id, seq DESC)|}; 53 ]; 54 }; 55 { 56 version = 3; 57 name = "application feedback"; 58 statements = 59 [ 60 {|CREATE TABLE IF NOT EXISTS app_feedback ( 61 trainee_id TEXT NOT NULL, 62 seq INTEGER NOT NULL, 63 submitted_at TEXT NOT NULL, 64 message TEXT NOT NULL, 65 PRIMARY KEY (trainee_id, seq) 66 )|}; 67 {|CREATE INDEX IF NOT EXISTS app_feedback_by_trainee 68 ON app_feedback (trainee_id, seq DESC)|}; 69 ]; 70 }; 71 { 72 version = 4; 73 name = "application feedback votes"; 74 statements = 75 [ 76 {|CREATE TABLE IF NOT EXISTS app_feedback_vote ( 77 feedback_trainee_id TEXT NOT NULL, 78 feedback_seq INTEGER NOT NULL, 79 voter_id TEXT NOT NULL, 80 PRIMARY KEY (feedback_trainee_id, feedback_seq, voter_id) 81 )|}; 82 {|CREATE INDEX IF NOT EXISTS app_feedback_vote_by_voter 83 ON app_feedback_vote (voter_id)|}; 84 ]; 85 }; 86 { 87 version = 5; 88 name = "ISO 8601 UTC timestamps"; 89 statements = 90 [ 91 {|DROP TABLE IF EXISTS app_feedback_vote|}; 92 {|DROP TABLE IF EXISTS app_feedback|}; 93 {|DROP TABLE IF EXISTS feedback|}; 94 {|DROP TABLE IF EXISTS workout|}; 95 {|DROP TABLE IF EXISTS in_progress|}; 96 {|CREATE TABLE IF NOT EXISTS in_progress ( 97 trainee_id TEXT PRIMARY KEY, 98 encoded TEXT NOT NULL 99 )|}; 100 {|CREATE TABLE IF NOT EXISTS workout ( 101 id TEXT PRIMARY KEY, 102 trainee_id TEXT NOT NULL, 103 seq INTEGER NOT NULL, 104 encoded TEXT NOT NULL 105 )|}; 106 {|CREATE INDEX IF NOT EXISTS workout_by_trainee 107 ON workout (trainee_id, seq DESC)|}; 108 {|CREATE TABLE IF NOT EXISTS feedback ( 109 trainee_id TEXT NOT NULL, 110 seq INTEGER NOT NULL, 111 encoded TEXT NOT NULL, 112 PRIMARY KEY (trainee_id, seq) 113 )|}; 114 {|CREATE INDEX IF NOT EXISTS feedback_by_trainee 115 ON feedback (trainee_id, seq DESC)|}; 116 {|CREATE TABLE IF NOT EXISTS app_feedback ( 117 trainee_id TEXT NOT NULL, 118 seq INTEGER NOT NULL, 119 submitted_at TEXT NOT NULL, 120 message TEXT NOT NULL, 121 PRIMARY KEY (trainee_id, seq) 122 )|}; 123 {|CREATE INDEX IF NOT EXISTS app_feedback_by_trainee 124 ON app_feedback (trainee_id, seq DESC)|}; 125 {|CREATE TABLE IF NOT EXISTS app_feedback_vote ( 126 feedback_trainee_id TEXT NOT NULL, 127 feedback_seq INTEGER NOT NULL, 128 voter_id TEXT NOT NULL, 129 PRIMARY KEY (feedback_trainee_id, feedback_seq, voter_id) 130 )|}; 131 {|CREATE INDEX IF NOT EXISTS app_feedback_vote_by_voter 132 ON app_feedback_vote (voter_id)|}; 133 ]; 134 }; 135 { 136 version = 6; 137 name = "five-point feedback scores"; 138 (* Subjective feedback now encodes levels as scores 1..5, so rows written 139 with the old below/usual/above codes no longer decode. Feedback is 140 observed, not authored, so the domain permits dropping it rather than 141 migrating it. *) 142 statements = 143 [ 144 {|DROP TABLE IF EXISTS feedback|}; 145 {|CREATE TABLE IF NOT EXISTS feedback ( 146 trainee_id TEXT NOT NULL, 147 seq INTEGER NOT NULL, 148 encoded TEXT NOT NULL, 149 PRIMARY KEY (trainee_id, seq) 150 )|}; 151 {|CREATE INDEX IF NOT EXISTS feedback_by_trainee 152 ON feedback (trainee_id, seq DESC)|}; 153 ]; 154 }; 155 ] 156 157 (* The ledger of applied migrations. A row per version, so a reconnect knows 158 what the file already carries and skips it. *) 159 let ledger = 160 {|CREATE TABLE IF NOT EXISTS schema_migrations ( 161 version INTEGER PRIMARY KEY, 162 name TEXT NOT NULL, 163 applied_at REAL NOT NULL 164 )|} 165 166 let statements = 167 List.concat_map (fun migration -> migration.statements) migrations 168 169 (* --- request helpers --- *) 170 171 let exec_sql (module Db : Caqti_lwt.CONNECTION) sql = 172 let request = 173 let open Caqti_request.Infix in 174 let open Caqti_type.Std in 175 (unit ->. unit) ~oneshot:true sql 176 in 177 Db.exec request () 178 179 let is_applied (module Db : Caqti_lwt.CONNECTION) version = 180 let request = 181 let open Caqti_request.Infix in 182 let open Caqti_type.Std in 183 (int ->! int) ~oneshot:true 184 "SELECT COUNT(*) FROM schema_migrations WHERE version = ?" 185 in 186 Db.find request version 187 188 let record_applied (module Db : Caqti_lwt.CONNECTION) migration = 189 let request = 190 let open Caqti_request.Infix in 191 let open Caqti_type.Std in 192 (t2 int string ->. unit) 193 ~oneshot:true 194 "INSERT INTO schema_migrations (version, name, applied_at) VALUES (?, ?, \ 195 strftime('%s','now'))" 196 in 197 Db.exec request (migration.version, migration.name) 198 199 (* Apply one migration inside a transaction, then record it. The ledger check 200 makes this idempotent; the [IF NOT EXISTS] clauses keep an already-populated 201 file from a pre-ledger build safe. *) 202 let apply_migration ((module Db : Caqti_lwt.CONNECTION) as db) migration = 203 let open Lwt_result.Syntax in 204 let* applied = is_applied db migration.version in 205 if applied > 0 then Lwt_result.return () 206 else 207 Db.with_transaction (fun () -> 208 let rec go = function 209 | [] -> record_applied db migration 210 | sql :: tl -> 211 let* () = exec_sql db sql in 212 go tl 213 in 214 go migration.statements) 215 216 let apply (module Db : Caqti_lwt.CONNECTION) = 217 let db = (module Db : Caqti_lwt.CONNECTION) in 218 let open Lwt_result.Syntax in 219 let run = 220 let* () = exec_sql db ledger in 221 let rec go = function 222 | [] -> Lwt_result.return () 223 | migration :: tl -> 224 let* () = apply_migration db migration in 225 go tl 226 in 227 go migrations 228 in 229 Lwt.map 230 (function Ok () -> Ok () | Error e -> Error (e :> Caqti_error.t)) 231 run 232