1 (** Shared support for the web tier tests. Sessions and CSRF are exercised end 2 to end: a small client carries the session cookie between requests and pulls 3 the CSRF token out of the rendered page, exactly as a browser would. The 4 SQLite runs in an isolated in-memory database; session storage is Dream's 5 in-memory back end. *) 6 7 open Hito_app 8 9 module Handlers = 10 Hito_web.Handlers.Make (Test_repo) (Test_hash) (Hito_import.Hevy_csv) 11 12 (* A fresh, fully wired application: secret, in-memory sessions, routes. 13 Registration is opened here so the auth-flow tests can create trainees via 14 [/register]; production keeps it closed. *) 15 let app ?(import_open = true) () = 16 let handlers = 17 Handlers.make ~repo:(Test_repo.create ()) ~registration_open:true 18 ~import_open () 19 in 20 Dream.memory_sessions @@ Handlers.security_headers 21 @@ Dream.router (Handlers.routes handlers) 22 |> fun handler -> Dream.set_secret "test-secret-value" handler 23 24 let status response = Dream.status response |> Dream.status_to_int 25 let body response = Lwt_main.run (Dream.body response) 26 27 (* The redirect target of a 3xx response — the URL half of a URL-to-URL flow. *) 28 let location response = 29 match Dream.header response "Location" with 30 | Some target -> target 31 | None -> Alcotest.failf "expected a Location header on a redirect" 32 33 (* --- a cookie-carrying client --- *) 34 35 (* Extract cookies (name=value) from all Set-Cookie response headers. *) 36 let cookies_of response = 37 Dream.headers response "Set-Cookie" 38 |> List.filter_map (fun sc -> 39 match String.index_opt sc ';' with 40 | Some i -> Some (String.sub sc 0 i) 41 | None -> Some sc) 42 43 type client = { app : Dream.handler; mutable jar : string list } 44 45 let client ?(import_open = true) () = { app = app ~import_open (); jar = [] } 46 47 let cookie_header client = 48 if client.jar = [] then [] else [ ("Cookie", String.concat "; " client.jar) ] 49 50 let remember client response = 51 (* Replace cookies of the same name; keep the rest. *) 52 List.iter 53 (fun fresh -> 54 let name = 55 match String.index_opt fresh '=' with 56 | Some i -> String.sub fresh 0 i 57 | None -> fresh 58 in 59 client.jar <- 60 fresh 61 :: List.filter 62 (fun old -> 63 not 64 (String.length old >= String.length name 65 && String.sub old 0 (String.length name) = name 66 && (String.length old = String.length name 67 || old.[String.length name] = '='))) 68 client.jar) 69 (cookies_of response) 70 71 let get client target = 72 let response = 73 Dream.test client.app 74 (Dream.request ~method_:`GET ~target ~headers:(cookie_header client) "") 75 in 76 remember client response; 77 response 78 79 let post client target fields = 80 let body = 81 fields 82 |> List.map (fun (k, v) -> 83 Dream.to_percent_encoded k ^ "=" ^ Dream.to_percent_encoded v) 84 |> String.concat "&" 85 in 86 let response = 87 Dream.test client.app 88 (Dream.request ~method_:`POST ~target 89 ~headers: 90 (("Content-Type", "application/x-www-form-urlencoded") 91 :: cookie_header client) 92 body) 93 in 94 remember client response; 95 response 96 97 (* A multipart/form-data POST. [file] is [(field, filename, content)]; [fields] 98 are plain text parts. The CSRF token rides as its own text part, exactly as 99 [Dream.csrf_tag] renders it into a browser form, so [Dream.multipart ~csrf] 100 verifies it. The boundary is fixed but improbable in the body. *) 101 let post_multipart client target ~file ~fields = 102 let boundary = "----hitotestboundary7Xk2p" in 103 let buf = Buffer.create 1024 in 104 let part_field (name, value) = 105 Buffer.add_string buf ("--" ^ boundary ^ "\r\n"); 106 Buffer.add_string buf 107 (Printf.sprintf "Content-Disposition: form-data; name=%S\r\n\r\n" name); 108 Buffer.add_string buf value; 109 Buffer.add_string buf "\r\n" 110 in 111 List.iter part_field fields; 112 (match file with 113 | Some (name, filename, content) -> 114 Buffer.add_string buf ("--" ^ boundary ^ "\r\n"); 115 Buffer.add_string buf 116 (Printf.sprintf 117 "Content-Disposition: form-data; name=%S; filename=%S\r\n" name 118 filename); 119 Buffer.add_string buf "Content-Type: text/csv\r\n\r\n"; 120 Buffer.add_string buf content; 121 Buffer.add_string buf "\r\n" 122 | None -> ()); 123 Buffer.add_string buf ("--" ^ boundary ^ "--\r\n"); 124 let response = 125 Dream.test client.app 126 (Dream.request ~method_:`POST ~target 127 ~headers: 128 (("Content-Type", "multipart/form-data; boundary=" ^ boundary) 129 :: cookie_header client) 130 (Buffer.contents buf)) 131 in 132 remember client response; 133 response 134 135 let index_from ~needle haystack start = 136 let n = String.length needle and h = String.length haystack in 137 let rec at i = 138 if i + n > h then None 139 else if String.sub haystack i n = needle then Some i 140 else at (i + 1) 141 in 142 if start < 0 then None else at start 143 144 (* Extract the CSRF token from a rendered form. The test client needs this 145 browser-facing value to submit the same protected requests as a user. *) 146 let csrf_token html = 147 match index_from ~needle:"name=\"dream.csrf\"" html 0 with 148 | None -> None 149 | Some idx -> ( 150 match index_from ~needle:"value=\"" html idx with 151 | None -> None 152 | Some v -> 153 let start = v + String.length "value=\"" in 154 let stop = String.index_from html start '"' in 155 Some (String.sub html start (stop - start))) 156 157 let register client ~username ~password = 158 let page = body (get client "/register") in 159 let token = Option.get (csrf_token page) in 160 post client "/register" 161 [ ("dream.csrf", token); ("username", username); ("password", password) ] 162 163 let sign_in_new client = 164 register client ~username:"lifter" ~password:"heavyduty1" 165 166 (* Sign in through the credential form, as a returning trainee would. Unlike 167 [register], this exercises the [POST /login] path. *) 168 let sign_in client ~username ~password = 169 let page = body (get client "/login") in 170 let token = Option.get (csrf_token page) in 171 post client "/login" 172 [ ("dream.csrf", token); ("username", username); ("password", password) ] 173 174 (* An application whose clock the test drives. A shared [Test_repo] and a 175 mutable [now] cell let a deep test advance time across the recovery gate, 176 which the wall-clock default cannot. Registration is open so the test can 177 create the trainee it drives. Also hands back the repository, so a deep test 178 can assert the domain state its flow produced. *) 179 let clocked_client () = 180 let now = ref 0 in 181 let repo = Test_repo.create () in 182 let handlers = 183 Handlers.make ~repo 184 ~now:(fun () -> Recovery.timestamp_of_unix_seconds !now) 185 ~registration_open:true () 186 in 187 let app = 188 Dream.memory_sessions @@ Dream.router (Handlers.routes handlers) |> fun h -> 189 Dream.set_secret "test-secret-value" h 190 in 191 ({ app; jar = [] }, now, repo) 192 193 let day n = n * 86_400 194 195 (* A client that hands back its repository, so a test can assert the domain 196 state the flow produced — the log, the stored feedback, the renamed account — 197 rather than reading it back out of rendered HTML. *) 198 let client_with_repo ?(import_open = true) () = 199 let repo = Test_repo.create () in 200 let handlers = Handlers.make ~repo ~registration_open:true ~import_open () in 201 let app = 202 Dream.memory_sessions @@ Dream.router (Handlers.routes handlers) |> fun h -> 203 Dream.set_secret "test-secret-value" h 204 in 205 ({ app; jar = [] }, repo) 206 207 (* Look up the sole seeded trainee by the name the flow helpers register. *) 208 let the_trainee repo ~username = 209 match Trainee.username username with 210 | Error _ -> Alcotest.failf "test username %S is invalid" username 211 | Ok u -> ( 212 match Lwt_main.run (Test_repo.find_trainee_by_username repo u) with 213 | Some trainee -> trainee 214 | None -> Alcotest.failf "no trainee named %S" username) 215 216 (* Drive a trainee to the start of a fresh Day 1 workout: select the ideal 217 routine and begin without an override. Returns the client. *) 218 let start_day_one c = 219 let token = Option.get (csrf_token (body (get c "/"))) in 220 let _ = post c "/routines/ideal/select" [ ("dream.csrf", token) ] in 221 let token = Option.get (csrf_token (body (get c "/"))) in 222 post c "/workout" [ ("dream.csrf", token); ("override", "false") ] 223 224 (* Record every slot of the in-progress Day 1 workout, one at a time, addressed 225 by [?slot=]. Slot 0 is the flyes/incline-press pair; slot 3 is the 226 french-press/dips pair; slots 1 and 2 are single lateral movements. *) 227 let record_all_day_one_slots c = 228 let record_pair slot comp_load = 229 let token = 230 Option.get (csrf_token (body (get c ("/workout?slot=" ^ slot)))) 231 in 232 post c ("/workout/slots/" ^ slot) 233 [ 234 ("dream.csrf", token); 235 ("iso_load", "20"); 236 ("iso_reps", "9"); 237 ("comp_load", comp_load); 238 ("comp_reps", "7"); 239 ("extension", ""); 240 ] 241 in 242 let record_single slot load reps = 243 let token = 244 Option.get (csrf_token (body (get c ("/workout?slot=" ^ slot)))) 245 in 246 post c ("/workout/slots/" ^ slot) 247 [ 248 ("dream.csrf", token); ("load", load); ("reps", reps); ("extension", ""); 249 ] 250 in 251 let _ = record_pair "0" "60" in 252 let _ = record_single "1" "12" "8" in 253 let _ = record_single "2" "10" "9" in 254 let _ = record_pair "3" "0" in 255 () 256