a database layer insipred by caqti and ecto
gdiazlo.tngl.sh
1module Driver : Repodb.Driver.S = struct
2 type connection = Postgresql.connection
3 type error = string
4
5 let dialect = Repodb.Driver.PostgreSQL
6 let error_message e = e
7
8 let connect conninfo =
9 try
10 let conn = new Postgresql.connection ~conninfo () in
11 match conn#status with
12 | Postgresql.Ok -> Ok conn
13 | Postgresql.Bad -> Error conn#error_message
14 | _ -> Error "Connection in unexpected state"
15 with Postgresql.Error e -> Error (Postgresql.string_of_error e)
16
17 let close conn = conn#finish
18
19 let with_connection conninfo f =
20 match connect conninfo with
21 | Error e -> Error e
22 | Ok conn ->
23 let result = f conn in
24 close conn;
25 result
26
27 let value_to_string (v : Repodb.Driver.Value.t) : string =
28 match v with
29 | Repodb.Driver.Value.Null -> Postgresql.null
30 | Repodb.Driver.Value.Int n -> string_of_int n
31 | Repodb.Driver.Value.Int64 n -> Int64.to_string n
32 | Repodb.Driver.Value.Float f -> string_of_float f
33 | Repodb.Driver.Value.Text s -> s
34 | Repodb.Driver.Value.Blob s ->
35 "\\x"
36 ^ (String.to_bytes s
37 |> Bytes.fold_left
38 (fun acc b -> acc ^ Printf.sprintf "%02x" (Char.code b))
39 "")
40 | Repodb.Driver.Value.Bool b -> if b then "t" else "f"
41
42 let result_to_rows (result : Postgresql.result) : Repodb.Driver.row list =
43 let ntuples = result#ntuples in
44 let nfields = result#nfields in
45 let columns = Array.init nfields (fun i -> result#fname i) in
46 List.init ntuples (fun row ->
47 let values =
48 Array.init nfields (fun col ->
49 if result#getisnull row col then Repodb.Driver.Value.Null
50 else Repodb.Driver.Value.Text (result#getvalue row col))
51 in
52 { Repodb.Driver.columns; values })
53
54 let exec (conn : connection) (sql : string)
55 ~(params : Repodb.Driver.Value.t array) =
56 try
57 let params_arr = Array.map value_to_string params in
58 let result = conn#exec ~params:params_arr sql in
59 match result#status with
60 | Postgresql.Command_ok | Postgresql.Tuples_ok -> Ok ()
61 | _ -> Error result#error
62 with Postgresql.Error e -> Error (Postgresql.string_of_error e)
63
64 let query (conn : connection) (sql : string)
65 ~(params : Repodb.Driver.Value.t array) =
66 try
67 let params_arr = Array.map value_to_string params in
68 let result = conn#exec ~params:params_arr sql in
69 match result#status with
70 | Postgresql.Tuples_ok -> Ok (result_to_rows result)
71 | Postgresql.Command_ok -> Ok []
72 | _ -> Error result#error
73 with Postgresql.Error e -> Error (Postgresql.string_of_error e)
74
75 let query_one (conn : connection) (sql : string)
76 ~(params : Repodb.Driver.Value.t array) =
77 match query conn sql ~params with
78 | Error e -> Error e
79 | Ok [] -> Ok None
80 | Ok (row :: _) -> Ok (Some row)
81
82 let query_fold (conn : connection) (sql : string)
83 ~(params : Repodb.Driver.Value.t array) ~(init : 'acc)
84 ~(f : 'acc -> Repodb.Driver.row -> 'acc) =
85 try
86 let params_arr = Array.map value_to_string params in
87 let result = conn#exec ~params:params_arr sql in
88 match result#status with
89 | Postgresql.Tuples_ok ->
90 let ntuples = result#ntuples in
91 let nfields = result#nfields in
92 let columns = Array.init nfields (fun i -> result#fname i) in
93 let acc = ref init in
94 for row = 0 to ntuples - 1 do
95 let values =
96 Array.init nfields (fun col ->
97 if result#getisnull row col then Repodb.Driver.Value.Null
98 else Repodb.Driver.Value.Text (result#getvalue row col))
99 in
100 acc := f !acc { Repodb.Driver.columns; values }
101 done;
102 Ok !acc
103 | Postgresql.Command_ok -> Ok init
104 | _ -> Error result#error
105 with Postgresql.Error e -> Error (Postgresql.string_of_error e)
106
107 let query_iter (conn : connection) (sql : string)
108 ~(params : Repodb.Driver.Value.t array) ~(f : Repodb.Driver.row -> unit) =
109 try
110 let params_arr = Array.map value_to_string params in
111 let result = conn#exec ~params:params_arr sql in
112 match result#status with
113 | Postgresql.Tuples_ok ->
114 let ntuples = result#ntuples in
115 let nfields = result#nfields in
116 let columns = Array.init nfields (fun i -> result#fname i) in
117 for row = 0 to ntuples - 1 do
118 let values =
119 Array.init nfields (fun col ->
120 if result#getisnull row col then Repodb.Driver.Value.Null
121 else Repodb.Driver.Value.Text (result#getvalue row col))
122 in
123 f { Repodb.Driver.columns; values }
124 done;
125 Ok ()
126 | Postgresql.Command_ok -> Ok ()
127 | _ -> Error result#error
128 with Postgresql.Error e -> Error (Postgresql.string_of_error e)
129
130 let transaction (conn : connection) (f : connection -> ('a, error) result) =
131 match exec conn "BEGIN" ~params:[||] with
132 | Error e -> Error e
133 | Ok () -> (
134 match f conn with
135 | Ok v -> (
136 match exec conn "COMMIT" ~params:[||] with
137 | Ok () -> Ok v
138 | Error e -> Error e)
139 | Error e ->
140 let _ = exec conn "ROLLBACK" ~params:[||] in
141 Error e)
142
143 let placeholder n = Printf.sprintf "$%d" n
144 let returning_supported = true
145 let upsert_syntax = `PostgreSQL
146 let last_insert_id (_conn : connection) = Error "Use RETURNING clause instead"
147end
148
149type connection = Driver.connection
150type error = Driver.error
151
152let dialect = Driver.dialect
153let error_message = Driver.error_message
154let connect = Driver.connect
155let close = Driver.close
156let with_connection = Driver.with_connection
157let exec = Driver.exec
158let query = Driver.query
159let query_one = Driver.query_one
160let query_fold = Driver.query_fold
161let query_iter = Driver.query_iter
162let transaction = Driver.transaction
163let placeholder = Driver.placeholder
164let returning_supported = Driver.returning_supported
165let upsert_syntax = Driver.upsert_syntax
166let last_insert_id = Driver.last_insert_id
167let driver : Repodb.Driver.driver = (module Driver)