···
3
+
let src = Logs.Src.create "requests.session" ~doc:"HTTP Session"
4
+
module Log = (val Logs.src_log src : Logs.LOG)
8
+
type ('clock, 'net) t = {
10
+
client : ('clock, 'net) Client.t;
12
+
cookie_jar : Cookie_jar.t;
13
+
mutable default_headers : Headers.t;
14
+
mutable auth : Auth.t option;
15
+
mutable timeout : Timeout.t;
16
+
mutable follow_redirects : bool;
17
+
mutable max_redirects : int;
18
+
mutable retry : Retry.config option;
19
+
persist_cookies : bool;
20
+
xdg : Xdge.t option;
22
+
mutable requests_made : int;
23
+
mutable total_time : float;
24
+
mutable retries_count : int;
28
+
(** {1 Session Creation} *)
34
+
?(default_headers = Headers.empty)
36
+
?(timeout = Timeout.default)
37
+
?(follow_redirects = true)
38
+
?(max_redirects = 10)
39
+
?(verify_tls = true)
41
+
?(persist_cookies = false)
45
+
(* Create default XDG context if needed *)
46
+
let xdg = match xdg, persist_cookies with
47
+
| Some x, _ -> Some x
48
+
| None, true -> Some (Xdge.create env#fs "requests")
49
+
| None, false -> None
52
+
Log.info (fun m -> m "Creating new session%s"
54
+
| Some x -> Printf.sprintf " with XDG app=%s" (Xdge.app_name x)
57
+
(* Create or use provided client *)
58
+
let client = match client with
61
+
Client.create ~verify_tls ~timeout
62
+
~clock:env#clock ~net:env#net ()
65
+
(* Create or load cookie jar *)
66
+
let cookie_jar = match cookie_jar, persist_cookies, xdg with
67
+
| Some jar, _, _ -> jar
68
+
| None, true, Some xdg_ctx ->
69
+
Log.debug (fun m -> m "Loading persistent cookie jar from XDG data dir");
70
+
Cookie_jar.load ~xdg:xdg_ctx ()
72
+
Cookie_jar.create ()
91
+
mutex = Mutex.create ();
94
+
(* Register cleanup on switch *)
95
+
Switch.on_release sw (fun () ->
96
+
if persist_cookies && Option.is_some xdg then begin
97
+
Log.info (fun m -> m "Saving cookies on session close");
98
+
Cookie_jar.save ?xdg session.cookie_jar
104
+
and with_session ~sw ?client ?cookie_jar ?default_headers ?auth ?timeout
105
+
?follow_redirects ?max_redirects ?verify_tls ?retry ?persist_cookies
107
+
let session = create ~sw ?client ?cookie_jar ?default_headers ?auth
108
+
?timeout ?follow_redirects ?max_redirects ?verify_tls ?retry
109
+
?persist_cookies ?xdg env in
111
+
let result = f session in
118
+
(** {1 Configuration Management} *)
120
+
and set_default_header t key value =
121
+
Mutex.lock t.mutex;
122
+
t.default_headers <- Headers.set key value t.default_headers;
123
+
Mutex.unlock t.mutex;
124
+
Log.debug (fun m -> m "Set default header %s: %s" key value)
126
+
and remove_default_header t key =
127
+
Mutex.lock t.mutex;
128
+
t.default_headers <- Headers.remove key t.default_headers;
129
+
Mutex.unlock t.mutex;
130
+
Log.debug (fun m -> m "Removed default header %s" key)
132
+
and set_auth t auth =
133
+
Mutex.lock t.mutex;
134
+
t.auth <- Some auth;
135
+
Mutex.unlock t.mutex;
136
+
Log.debug (fun m -> m "Set session authentication")
139
+
Mutex.lock t.mutex;
141
+
Mutex.unlock t.mutex;
142
+
Log.debug (fun m -> m "Cleared session authentication")
144
+
and set_timeout t timeout =
145
+
Mutex.lock t.mutex;
146
+
t.timeout <- timeout;
147
+
Mutex.unlock t.mutex
149
+
and set_retry t retry =
150
+
Mutex.lock t.mutex;
151
+
t.retry <- Some retry;
152
+
Mutex.unlock t.mutex
154
+
and disable_retry t =
155
+
Mutex.lock t.mutex;
157
+
Mutex.unlock t.mutex
159
+
(** {1 Cookie Management} *)
161
+
and cookies t = t.cookie_jar
163
+
and clear_cookies t =
164
+
Cookie_jar.clear t.cookie_jar
166
+
and save_cookies t =
167
+
if t.persist_cookies && Option.is_some t.xdg then
168
+
Cookie_jar.save ?xdg:t.xdg t.cookie_jar
170
+
and load_cookies t =
171
+
if t.persist_cookies && Option.is_some t.xdg then
172
+
let loaded = Cookie_jar.load ?xdg:t.xdg () in
173
+
(* Copy loaded cookies into our jar *)
174
+
Cookie_jar.clear t.cookie_jar;
175
+
let cookies_from_loaded = Cookie_jar.to_mozilla_format loaded in
176
+
let reloaded = Cookie_jar.from_mozilla_format cookies_from_loaded in
177
+
(* This is a bit convoluted but maintains the same jar reference *)
180
+
(** {1 Internal Request Function} *)
182
+
and execute_request t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
183
+
let start_time = Unix.gettimeofday () in
185
+
(* Merge headers: default -> cookie -> provided *)
188
+
|> Headers.merge (Option.value headers ~default:Headers.empty)
189
+
|> Cookie_jar.add_to_headers t.cookie_jar ~url
192
+
(* Use provided auth or session default *)
193
+
let auth = match auth with Some a -> Some a | None -> t.auth in
195
+
(* Use provided or session defaults *)
196
+
let timeout = Option.value timeout ~default:t.timeout in
197
+
let follow_redirects = Option.value follow_redirects ~default:t.follow_redirects in
198
+
let max_redirects = Option.value max_redirects ~default:t.max_redirects in
200
+
Log.info (fun m -> m "Session request: %s %s"
201
+
(Method.to_string method_) url);
203
+
(* Make the actual request with retry if configured *)
204
+
let make_request () =
205
+
(* TODO: Implement actual HTTP request using cohttp-eio *)
206
+
(* For now, return a dummy response *)
207
+
let status = 200 in
208
+
let headers = Headers.empty in
209
+
let body_str = "TODO: Implement actual HTTP request" in
210
+
let body = Buf_read.of_string body_str in
211
+
Response.make ~status ~headers ~body ~url ~elapsed:0.0
214
+
let response = match t.retry with
215
+
| None -> make_request ()
216
+
| Some retry_config ->
217
+
Retry.with_retry ~sw:t.sw ~clock:t.clock
218
+
~config:retry_config
220
+
~should_retry_exn:(function
221
+
(* TODO: Handle Stream exceptions once Stream module is properly imported *)
225
+
(* Extract cookies from response *)
226
+
Cookie_jar.extract_from_headers t.cookie_jar ~url (Response.headers response);
228
+
(* Update statistics *)
229
+
Mutex.lock t.mutex;
230
+
t.requests_made <- t.requests_made + 1;
231
+
t.total_time <- t.total_time +. (Unix.gettimeofday () -. start_time);
232
+
Mutex.unlock t.mutex;
236
+
(** {1 Request Methods} *)
238
+
and request t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url =
239
+
execute_request t ?headers ?body ?auth ?timeout ?follow_redirects ?max_redirects ~method_ url
241
+
and get t ?headers ?auth ?timeout ?params url =
242
+
let url = match params with
245
+
let uri = Uri.of_string url in
246
+
let uri = List.fold_left (fun u (k, v) ->
247
+
Uri.add_query_param' u (k, v)
251
+
execute_request t ?headers ?auth ?timeout ~method_:Method.GET url
253
+
and post t ?headers ?body ?auth ?timeout ?json ?form url =
254
+
let body, headers = match json, form, body with
255
+
| Some json, _, _ ->
256
+
let json_str = Yojson.Safe.to_string json in
257
+
let body = Body.json json_str in
258
+
let headers = Option.value headers ~default:Headers.empty
259
+
|> Headers.content_type Mime.json in
260
+
Some body, Some headers
261
+
| _, Some form, _ ->
264
+
|> List.map (fun (k, v) -> Uri.pct_encode k ^ "=" ^ Uri.pct_encode v)
265
+
|> String.concat "&"
267
+
let body = Body.text form_str in
268
+
let headers = Option.value headers ~default:Headers.empty
269
+
|> Headers.content_type Mime.form in
270
+
Some body, Some headers
271
+
| _, _, body -> body, headers
273
+
execute_request t ?headers ?body ?auth ?timeout ~method_:Method.POST url
275
+
and put t ?headers ?body ?auth ?timeout ?json url =
276
+
let body, headers = match json with
278
+
let json_str = Yojson.Safe.to_string json in
279
+
let body = Body.json json_str in
280
+
let headers = Option.value headers ~default:Headers.empty
281
+
|> Headers.content_type Mime.json in
282
+
Some body, Some headers
283
+
| None -> body, headers
285
+
execute_request t ?headers ?body ?auth ?timeout ~method_:Method.PUT url
287
+
and patch t ?headers ?body ?auth ?timeout ?json url =
288
+
let body, headers = match json with
290
+
let json_str = Yojson.Safe.to_string json in
291
+
let body = Body.json json_str in
292
+
let headers = Option.value headers ~default:Headers.empty
293
+
|> Headers.content_type Mime.json in
294
+
Some body, Some headers
295
+
| None -> body, headers
297
+
execute_request t ?headers ?body ?auth ?timeout ~method_:Method.PATCH url
299
+
and delete t ?headers ?auth ?timeout url =
300
+
execute_request t ?headers ?auth ?timeout ~method_:Method.DELETE url
302
+
and head t ?headers ?auth ?timeout url =
303
+
execute_request t ?headers ?auth ?timeout ~method_:Method.HEAD url
305
+
and options t ?headers ?auth ?timeout url =
306
+
execute_request t ?headers ?auth ?timeout ~method_:Method.OPTIONS url
308
+
(** {1 Streaming Operations} *)
310
+
and upload t ?headers ?auth ?timeout ?method_ ?mime ?length ?on_progress ~source url =
311
+
let method_ = Option.value method_ ~default:Method.POST in
312
+
let body = Body.of_stream ?length (Option.value mime ~default:Mime.octet_stream) source in
313
+
(* TODO: Add progress tracking wrapper around source *)
314
+
execute_request t ?headers ~body ?auth ?timeout ~method_ url
316
+
and download t ?headers ?auth ?timeout ?on_progress url ~sink =
317
+
let response = execute_request t ?headers ?auth ?timeout ~method_:Method.GET url in
318
+
let body = Response.body response in
319
+
(* TODO: Add progress tracking wrapper *)
320
+
(* Copy from Buf_read to sink *)
321
+
let data = Buf_read.take_all body in
322
+
Flow.write sink [ Cstruct.of_string data ]
324
+
and download_file t ?headers ?auth ?timeout ?on_progress url path =
325
+
path |> Path.with_open_out (fun sink ->
326
+
download t ?headers ?auth ?timeout ?on_progress url ~sink
329
+
(** {1 Batch Operations} *)
331
+
and concurrent_requests t ?(max_concurrent = 10) tasks =
332
+
let sem = Semaphore.make max_concurrent in
334
+
tasks |> Fiber.List.map ~max_fibers:max_concurrent (fun task ->
335
+
Semaphore.acquire sem;
337
+
let result = task t in
338
+
Semaphore.release sem;
341
+
Semaphore.release sem;
345
+
and map_concurrent t ?max_concurrent ~f items =
346
+
let tasks = List.map (fun item session -> f session item) items in
347
+
concurrent_requests t ?max_concurrent tasks
349
+
(** {1 Session Utilities} *)
352
+
Log.info (fun m -> m "Closing session after %d requests" t.requests_made);
353
+
if t.persist_cookies && Option.is_some t.xdg then
356
+
(** {1 Prepared Requests} *)
358
+
module Prepared = struct
362
+
headers : Headers.t;
363
+
body : Body.t option;
364
+
auth : Auth.t option;
365
+
timeout : Timeout.t;
366
+
method_ : Method.t;
370
+
let create ~session ?headers ?body ?auth ?timeout ~method_ url =
372
+
session.default_headers
373
+
|> Headers.merge (Option.value headers ~default:Headers.empty)
374
+
|> Cookie_jar.add_to_headers session.cookie_jar ~url
376
+
let auth = Option.first auth session.auth in
377
+
let timeout = Option.value timeout ~default:session.timeout in
378
+
{ session; headers; body; auth; timeout; method_; url }
380
+
let headers t = t.headers
381
+
let set_header t key value = { t with headers = Headers.set key value t.headers }
382
+
let body t = t.body
383
+
let set_body t body = { t with body = Some body }
385
+
let method_ t = t.method_
388
+
execute_request t.session ~headers:t.headers ?body:t.body ?auth:t.auth
389
+
~timeout:t.timeout ~method_:t.method_ t.url
392
+
Format.fprintf ppf "@[<v>Prepared Request:@,\
398
+
(Method.to_string t.method_)
400
+
Headers.pp t.headers
401
+
(if Option.is_some t.auth then "present" else "none")
402
+
(if Option.is_some t.body then "present" else "none")
406
+
Mutex.lock t.mutex;
407
+
let stats = t.requests_made, t.total_time,
408
+
(match t.cookie_jar with jar -> 0) in (* TODO: Get actual count *)
409
+
Mutex.unlock t.mutex;
410
+
let requests, time, cookies = stats in
411
+
Format.fprintf ppf "@[<v>Session:@,\
412
+
requests made: %d@,\
413
+
total time: %.3fs@,\
416
+
follow redirects: %b@,\
417
+
max redirects: %d@,\
419
+
persist cookies: %b@,\
421
+
requests time cookies
422
+
(if Option.is_some t.auth then "configured" else "none")
425
+
(if Option.is_some t.retry then "enabled" else "disabled")
428
+
| Some x -> Xdge.app_name x
432
+
Mutex.lock t.mutex;
433
+
let result = object
434
+
method requests_made = t.requests_made
435
+
method total_time = t.total_time
436
+
method cookies_count = 0 (* TODO: Get from cookie jar *)
437
+
method retries_count = t.retries_count
439
+
Mutex.unlock t.mutex;
442
+
(** {1 Cmdliner Integration} *)
444
+
module Cmd = struct
448
+
xdg : Xdge.t * Xdge.Cmd.t;
449
+
persist_cookies : bool;
451
+
timeout : float option;
453
+
retry_backoff : float;
454
+
follow_redirects : bool;
455
+
max_redirects : int;
456
+
user_agent : string option;
459
+
let default_config app_name xdg = {
460
+
xdg = (xdg, Xdge.Cmd.term app_name (Xdge.data_dir xdg) ());
461
+
persist_cookies = false;
465
+
retry_backoff = 0.3;
466
+
follow_redirects = true;
467
+
max_redirects = 10;
471
+
let create config env sw =
472
+
let xdg, _xdg_cmd = config.xdg in
473
+
let retry = if config.max_retries > 0 then
474
+
Some (Retry.create_config
475
+
~max_retries:config.max_retries
476
+
~backoff_factor:config.retry_backoff ())
479
+
let timeout = match config.timeout with
480
+
| Some t -> Timeout.create ~total:t ()
481
+
| None -> Timeout.default in
483
+
let session = create ~sw
485
+
~persist_cookies:config.persist_cookies
486
+
~verify_tls:config.verify_tls
489
+
~follow_redirects:config.follow_redirects
490
+
~max_redirects:config.max_redirects
493
+
(* Set user agent if provided *)
494
+
Option.iter (set_default_header session "User-Agent") config.user_agent;
498
+
(* Individual terms *)
500
+
let persist_cookies_term =
501
+
let doc = "Persist cookies to disk between sessions" in
502
+
let env = Cmd.Env.info "REQUESTS_PERSIST_COOKIES" in
503
+
Arg.(value & flag & info ["persist-cookies"] ~env ~doc)
505
+
let verify_tls_term =
506
+
let doc = "Skip TLS certificate verification (insecure)" in
507
+
let env = Cmd.Env.info "REQUESTS_NO_VERIFY_TLS" in
508
+
Term.(const (fun no_verify -> not no_verify) $
509
+
Arg.(value & flag & info ["no-verify-tls"] ~env ~doc))
512
+
let doc = "Request timeout in seconds" in
513
+
let env = Cmd.Env.info "REQUESTS_TIMEOUT" in
514
+
Arg.(value & opt (some float) None & info ["timeout"] ~env ~docv:"SECONDS" ~doc)
517
+
let doc = "Maximum number of request retries" in
518
+
let env = Cmd.Env.info "REQUESTS_MAX_RETRIES" in
519
+
Arg.(value & opt int 3 & info ["max-retries"] ~env ~docv:"N" ~doc)
521
+
let retry_backoff_term =
522
+
let doc = "Retry backoff factor for exponential delay" in
523
+
let env = Cmd.Env.info "REQUESTS_RETRY_BACKOFF" in
524
+
Arg.(value & opt float 0.3 & info ["retry-backoff"] ~env ~docv:"FACTOR" ~doc)
526
+
let follow_redirects_term =
527
+
let doc = "Don't follow HTTP redirects" in
528
+
let env = Cmd.Env.info "REQUESTS_NO_FOLLOW_REDIRECTS" in
529
+
Term.(const (fun no_follow -> not no_follow) $
530
+
Arg.(value & flag & info ["no-follow-redirects"] ~env ~doc))
532
+
let max_redirects_term =
533
+
let doc = "Maximum number of redirects to follow" in
534
+
let env = Cmd.Env.info "REQUESTS_MAX_REDIRECTS" in
535
+
Arg.(value & opt int 10 & info ["max-redirects"] ~env ~docv:"N" ~doc)
537
+
let user_agent_term =
538
+
let doc = "User-Agent header to send with requests" in
539
+
let env = Cmd.Env.info "REQUESTS_USER_AGENT" in
540
+
Arg.(value & opt (some string) None & info ["user-agent"] ~env ~docv:"STRING" ~doc)
542
+
(* Combined terms *)
544
+
let config_term app_name fs =
545
+
let xdg_term = Xdge.Cmd.term app_name fs
546
+
~config:true ~data:true ~cache:true ~state:false ~runtime:false () in
547
+
Term.(const (fun xdg persist verify timeout retries backoff follow max_redir ua ->
548
+
{ xdg; persist_cookies = persist; verify_tls = verify;
549
+
timeout; max_retries = retries; retry_backoff = backoff;
550
+
follow_redirects = follow; max_redirects = max_redir;
553
+
$ persist_cookies_term
557
+
$ retry_backoff_term
558
+
$ follow_redirects_term
559
+
$ max_redirects_term
562
+
let session_term app_name env sw =
563
+
let config_t = config_term app_name env#fs in
564
+
Term.(const (fun config -> create config env sw) $ config_t)
566
+
let minimal_term app_name fs =
567
+
let xdg_term = Xdge.Cmd.term app_name fs
568
+
~config:false ~data:true ~cache:true ~state:false ~runtime:false () in
569
+
Term.(const (fun (xdg, _xdg_cmd) persist -> (xdg, persist))
571
+
$ persist_cookies_term)
573
+
let env_docs app_name =
574
+
let app_upper = String.uppercase_ascii app_name in
576
+
"## ENVIRONMENT\n\n\
577
+
The following environment variables affect %s:\n\n\
578
+
**%s_CONFIG_DIR**\n\
579
+
: Override configuration directory location\n\n\
581
+
: Override data directory location (for cookies)\n\n\
582
+
**%s_CACHE_DIR**\n\
583
+
: Override cache directory location\n\n\
584
+
**XDG_CONFIG_HOME**\n\
585
+
: Base directory for user configuration files (default: ~/.config)\n\n\
586
+
**XDG_DATA_HOME**\n\
587
+
: Base directory for user data files (default: ~/.local/share)\n\n\
588
+
**XDG_CACHE_HOME**\n\
589
+
: Base directory for user cache files (default: ~/.cache)\n\n\
590
+
**REQUESTS_PERSIST_COOKIES**\n\
591
+
: Set to '1' to persist cookies by default\n\n\
592
+
**REQUESTS_NO_VERIFY_TLS**\n\
593
+
: Set to '1' to disable TLS verification (insecure)\n\n\
594
+
**REQUESTS_TIMEOUT**\n\
595
+
: Default request timeout in seconds\n\n\
596
+
**REQUESTS_MAX_RETRIES**\n\
597
+
: Maximum number of retries for failed requests\n\n\
598
+
**REQUESTS_USER_AGENT**\n\
599
+
: Default User-Agent header\n\n\
600
+
**HTTP_PROXY**, **HTTPS_PROXY**, **NO_PROXY**\n\
601
+
: Proxy configuration (when proxy support is implemented)"
602
+
app_name app_upper app_upper app_upper
604
+
let pp_config ppf config =
605
+
let xdg, xdg_cmd = config.xdg in
606
+
Format.fprintf ppf "@[<v>Session Configuration:@,\
607
+
@[<v 2>XDG Directories:@,%a@]@,\
608
+
persist cookies: %b@,\
612
+
retry backoff: %.2f@,\
613
+
follow redirects: %b@,\
614
+
max redirects: %d@,\
616
+
Xdge.Cmd.pp xdg_cmd
617
+
config.persist_cookies
619
+
(match config.timeout with None -> "none" | Some t -> Printf.sprintf "%.1fs" t)
621
+
config.retry_backoff
622
+
config.follow_redirects
623
+
config.max_redirects
624
+
(Option.value config.user_agent ~default:"default")
anil.recoil.org