Source file `sql.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
(* This file is part of Dream, released under the MIT license. See
   LICENSE.md for details, or visit https://github.com/aantron/dream.

   Copyright 2021 Anton Bachin *)



module Dream = Dream__pure.Inmost



let log =
  Dream__middleware.Log.sub_log "dream.sql"

let pool : (_, Caqti_error.t) Caqti_lwt.Pool.t option ref Dream.global =
  Dream.new_global (fun () -> ref None)

let foreign_keys_on =
  Caqti_request.exec Caqti_type.unit "PRAGMA foreign_keys = ON"

let post_connect (module Db : Caqti_lwt.CONNECTION) =
  match Caqti_driver_info.dialect_tag Db.driver_info with
  | `Sqlite -> Db.exec foreign_keys_on ()
  | _ -> Lwt.return (Ok ())

let sql_pool ?size uri inner_handler request =
  let pool_cell = Dream.global pool request in
  begin match !pool_cell with
  | Some _ -> inner_handler request
  | None ->
    let pool =
      Caqti_lwt.connect_pool ?max_size:size ~post_connect (Uri.of_string uri) in
    match pool with
    | Ok pool ->
      pool_cell := Some pool;
      inner_handler request
    | Error error ->
      (* Deliberately raise an exception so that it can be communicated to any
         debug handler. *)
      let message =
        Printf.sprintf "Dream.sql_pool: cannot create pool for '%s': %s"
         uri (Caqti_error.show error) in
      log.error (fun log -> log ~request "%s" message);
      failwith message
  end

let sql callback request =
  match !(Dream.global pool request) with
  | None ->
    let message = "Dream.sql: no pool; did you apply Dream.sql_pool?" in
    log.error (fun log -> log ~request "%s" message);
    failwith message
  | Some pool ->
    let%lwt result =
      Caqti_lwt.Pool.use (fun db ->
        let%lwt result = callback db in
        Lwt.return (Ok result))
        pool
    in
    Caqti_lwt.or_fail result