objective categorical abstract machine language personal data server
Actor store
+125
+1
dune-project
+1
dune-project
+1
pegasus.opam
+1
pegasus.opam
+107
pegasus/lib/actor_store.ml
+107
pegasus/lib/actor_store.ml
···
1
+
open Util.Rapper
2
+
open Util.Syntax
3
+
4
+
module Types = struct
5
+
type actor =
6
+
{ id: int
7
+
; did: string
8
+
; handle: string
9
+
; email: string
10
+
; password_hash: bytes
11
+
; signing_key: bytes
12
+
; preferences: Yojson.Safe.t
13
+
; created_at: int
14
+
; deactivated_at: int option }
15
+
end
16
+
17
+
open Types
18
+
19
+
module Queries = struct
20
+
let create_tables =
21
+
[%rapper
22
+
execute
23
+
{sql| CREATE TABLE IF NOT EXISTS actors (
24
+
id INTEGER PRIMARY KEY,
25
+
did TEXT NOT NULL UNIQUE,
26
+
handle TEXT NOT NULL UNIQUE,
27
+
email TEXT NOT NULL UNIQUE,
28
+
password_hash BLOB NOT NULL,
29
+
signing_key BLOB NOT NULL,
30
+
preferences TEXT NOT NULL,
31
+
created_at INTEGER NOT NULL,
32
+
deactivated_at INTEGER
33
+
);
34
+
CREATE INDEX IF NOT EXISTS actors_did_idx ON actors (did);
35
+
CREATE INDEX IF NOT EXISTS actors_handle_idx ON actors (handle);
36
+
CREATE INDEX IF NOT EXISTS actors_email_idx ON actors (email);
37
+
|sql}]
38
+
()
39
+
40
+
let create_actor =
41
+
[%rapper
42
+
execute
43
+
{sql| INSERT INTO actors (
44
+
did,
45
+
handle,
46
+
email,
47
+
password_hash,
48
+
signing_key,
49
+
preferences,
50
+
created_at
51
+
) VALUES (
52
+
%string{did},
53
+
%string{handle},
54
+
%string{email},
55
+
%Blob{password_hash},
56
+
%Blob{signing_key},
57
+
%Json{preferences},
58
+
%int{created_at}
59
+
);
60
+
|sql}]
61
+
62
+
let get_actor_by_identifier id =
63
+
[%rapper
64
+
get_opt
65
+
{sql| SELECT @int{id}, @string{did}, @string{handle}, @string{email}, @Blob{password_hash}, @Blob{signing_key}, @Json{preferences}, @int{created_at}, @int?{deactivated_at}
66
+
FROM actors WHERE did = %string{id} OR handle = %string{id} OR email = %string{id}
67
+
LIMIT 1
68
+
|sql}
69
+
record_out]
70
+
id
71
+
72
+
let list_actors =
73
+
[%rapper
74
+
get_many
75
+
{sql| SELECT @int{id}, @string{did}, @string{handle}, @string{email}, @Blob{password_hash}, @Blob{signing_key}, @Json{preferences}, @int{created_at}, @int?{deactivated_at}
76
+
FROM actors
77
+
ORDER BY created_at DESC LIMIT %int{limit} OFFSET %int{offset}
78
+
|sql}
79
+
record_out]
80
+
end
81
+
82
+
type t = (module Rapper_helper.CONNECTION)
83
+
84
+
let init conn : unit Lwt.t =
85
+
let$! () = Queries.create_tables conn in
86
+
Lwt.return_unit
87
+
88
+
let create_actor ~did ~handle ~email ~password ~signing_key conn =
89
+
let password_hash =
90
+
Bcrypt.hash password |> Bcrypt.string_of_hash |> Bytes.of_string
91
+
in
92
+
let now = Unix.gettimeofday () *. 1000. |> int_of_float in
93
+
let$! () =
94
+
Queries.create_actor ~did ~handle ~email ~password_hash ~signing_key
95
+
~created_at:now
96
+
~preferences:(Yojson.Safe.from_string "{}")
97
+
conn
98
+
in
99
+
Lwt.return_unit
100
+
101
+
let get_actor_by_identifier id conn =
102
+
let$! actor = Queries.get_actor_by_identifier ~id conn in
103
+
Lwt.return actor
104
+
105
+
let list_actors ?(limit = 100) ?(offset = 0) conn =
106
+
let$! actors = Queries.list_actors ~limit ~offset conn in
107
+
Lwt.return actors
+1
pegasus/lib/dune
+1
pegasus/lib/dune
+15
pegasus/lib/util.ml
+15
pegasus/lib/util.ml
···
39
39
in
40
40
Caqti_type.(custom ~encode ~decode string)
41
41
end
42
+
43
+
module Json : Rapper.CUSTOM with type t = Yojson.Safe.t = struct
44
+
type t = Yojson.Safe.t
45
+
46
+
let t =
47
+
let encode json =
48
+
try Ok (Yojson.Safe.to_string json ~std:true)
49
+
with e -> Error (Printexc.to_string e)
50
+
in
51
+
let decode json =
52
+
try Ok (Yojson.Safe.from_string json)
53
+
with e -> Error (Printexc.to_string e)
54
+
in
55
+
Caqti_type.(custom ~encode ~decode string)
56
+
end
42
57
end
43
58
44
59
(* turns a caqti error into an exception *)