anil.recoil.org
A CLI and OCaml library for managing contacts
sync
+2343
-340
+205
-28
bin/sortal_cli.ml
+205
-28
bin/sortal_cli.ml
···
1
1
open Cmdliner
2
2
3
-
let run ~info main_term =
4
-
let run_main main =
5
-
Eio_main.run @@ fun env ->
6
-
let xdg = Xdge.create env#fs "sortal" in
7
-
main xdg
8
-
in
9
-
let term =
10
-
let open Term.Syntax in
11
-
let+ main = main_term
12
-
and+ log_level = Logs_cli.level () in
13
-
Fmt.set_style_renderer Fmt.stdout `Ansi_tty;
14
-
Fmt.set_style_renderer Fmt.stderr `Ansi_tty;
15
-
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
16
-
Logs.set_level log_level;
17
-
run_main main
18
-
in
19
-
Cmd.v info term
20
-
21
3
(* Main command *)
22
4
let () =
23
5
Random.self_init ();
6
+
Fmt.set_style_renderer Fmt.stdout `Ansi_tty;
7
+
Fmt.set_style_renderer Fmt.stderr `Ansi_tty;
8
+
24
9
let info = Cmd.info "sortal"
25
10
~version:"0.1.0"
26
11
~doc:"Contact metadata management"
···
33
18
]
34
19
in
35
20
36
-
let list_cmd_term = Term.const Sortal.Cmd.list_cmd in
37
-
let list_cmd = run ~info:Sortal.Cmd.list_info list_cmd_term in
21
+
Eio_main.run @@ fun env ->
22
+
23
+
let xdg_term = Xdge.Cmd.term "sortal" env#fs () in
24
+
25
+
let make_term info main_term =
26
+
let term =
27
+
let open Term.Syntax in
28
+
let+ (xdg, _) = xdg_term
29
+
and+ main = main_term
30
+
and+ log_level = Logs_cli.level () in
31
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
32
+
Logs.set_level log_level;
33
+
main xdg
34
+
in
35
+
Cmd.v info term
36
+
in
37
+
38
+
let list_cmd = make_term Sortal.Cmd.list_info (Term.const Sortal.Cmd.list_cmd) in
39
+
let show_cmd = make_term Sortal.Cmd.show_info Term.(const Sortal.Cmd.show_cmd $ Sortal.Cmd.handle_arg) in
40
+
let search_cmd = make_term Sortal.Cmd.search_info Term.(const Sortal.Cmd.search_cmd $ Sortal.Cmd.query_arg) in
41
+
let stats_cmd = make_term Sortal.Cmd.stats_info Term.(const (fun () -> Sortal.Cmd.stats_cmd ()) $ const ()) in
42
+
let sync_cmd = make_term Sortal.Cmd.sync_info Term.(const (fun () -> Sortal.Cmd.sync_cmd ()) $ const ()) in
43
+
44
+
(* Git init command needs special handling to pass env *)
45
+
let git_init_cmd =
46
+
let term =
47
+
let open Term.Syntax in
48
+
let+ (xdg, _) = xdg_term
49
+
and+ log_level = Logs_cli.level () in
50
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
51
+
Logs.set_level log_level;
52
+
Sortal.Cmd.git_init_cmd xdg env
53
+
in
54
+
Cmd.v Sortal.Cmd.git_init_info term
55
+
in
56
+
57
+
(* Contact management commands - need special handling for env *)
58
+
let add_cmd =
59
+
let term =
60
+
let open Term.Syntax in
61
+
let+ (xdg, _) = xdg_term
62
+
and+ handle = Sortal.Cmd.add_handle_arg
63
+
and+ names = Sortal.Cmd.add_names_arg
64
+
and+ kind = Sortal.Cmd.add_kind_arg
65
+
and+ email = Sortal.Cmd.add_email_arg
66
+
and+ github = Sortal.Cmd.add_github_arg
67
+
and+ url = Sortal.Cmd.add_url_arg
68
+
and+ orcid = Sortal.Cmd.add_orcid_arg
69
+
and+ log_level = Logs_cli.level () in
70
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
71
+
Logs.set_level log_level;
72
+
Sortal.Cmd.add_cmd handle names kind email github url orcid xdg env
73
+
in
74
+
Cmd.v Sortal.Cmd.add_info term
75
+
in
76
+
77
+
let delete_cmd =
78
+
let term =
79
+
let open Term.Syntax in
80
+
let+ (xdg, _) = xdg_term
81
+
and+ handle = Sortal.Cmd.handle_arg
82
+
and+ log_level = Logs_cli.level () in
83
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
84
+
Logs.set_level log_level;
85
+
Sortal.Cmd.delete_cmd handle xdg env
86
+
in
87
+
Cmd.v Sortal.Cmd.delete_info term
88
+
in
89
+
90
+
(* Entry management commands *)
91
+
let add_email_cmd =
92
+
let term =
93
+
let open Term.Syntax in
94
+
let+ (xdg, _) = xdg_term
95
+
and+ handle = Sortal.Cmd.handle_arg
96
+
and+ address = Sortal.Cmd.email_address_arg
97
+
and+ type_ = Sortal.Cmd.email_type_arg
98
+
and+ from = Sortal.Cmd.date_arg "from"
99
+
and+ until = Sortal.Cmd.date_arg "until"
100
+
and+ note = Sortal.Cmd.note_arg
101
+
and+ log_level = Logs_cli.level () in
102
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
103
+
Logs.set_level log_level;
104
+
Sortal.Cmd.add_email_cmd handle address type_ from until note xdg env
105
+
in
106
+
Cmd.v Sortal.Cmd.add_email_info term
107
+
in
108
+
109
+
let remove_email_cmd =
110
+
let term =
111
+
let open Term.Syntax in
112
+
let+ (xdg, _) = xdg_term
113
+
and+ handle = Sortal.Cmd.handle_arg
114
+
and+ address = Sortal.Cmd.email_address_arg
115
+
and+ log_level = Logs_cli.level () in
116
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
117
+
Logs.set_level log_level;
118
+
Sortal.Cmd.remove_email_cmd handle address xdg env
119
+
in
120
+
Cmd.v Sortal.Cmd.remove_email_info term
121
+
in
38
122
39
-
let show_cmd_term = Term.(const Sortal.Cmd.show_cmd $ Sortal.Cmd.handle_arg) in
40
-
let show_cmd = run ~info:Sortal.Cmd.show_info show_cmd_term in
123
+
let add_service_cmd =
124
+
let term =
125
+
let open Term.Syntax in
126
+
let+ (xdg, _) = xdg_term
127
+
and+ handle = Sortal.Cmd.handle_arg
128
+
and+ url = Sortal.Cmd.service_url_arg
129
+
and+ kind = Sortal.Cmd.service_kind_arg
130
+
and+ service_handle = Sortal.Cmd.service_handle_arg
131
+
and+ label = Sortal.Cmd.label_arg
132
+
and+ log_level = Logs_cli.level () in
133
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
134
+
Logs.set_level log_level;
135
+
Sortal.Cmd.add_service_cmd handle url kind service_handle label xdg env
136
+
in
137
+
Cmd.v Sortal.Cmd.add_service_info term
138
+
in
41
139
42
-
let search_cmd_term = Term.(const (fun query -> Sortal.Cmd.search_cmd query) $ Sortal.Cmd.query_arg) in
43
-
let search_cmd = run ~info:Sortal.Cmd.search_info search_cmd_term in
140
+
let remove_service_cmd =
141
+
let term =
142
+
let open Term.Syntax in
143
+
let+ (xdg, _) = xdg_term
144
+
and+ handle = Sortal.Cmd.handle_arg
145
+
and+ url = Sortal.Cmd.service_url_arg
146
+
and+ log_level = Logs_cli.level () in
147
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
148
+
Logs.set_level log_level;
149
+
Sortal.Cmd.remove_service_cmd handle url xdg env
150
+
in
151
+
Cmd.v Sortal.Cmd.remove_service_info term
152
+
in
44
153
45
-
let stats_cmd_term = Term.(const (fun () -> Sortal.Cmd.stats_cmd ()) $ const ()) in
46
-
let stats_cmd = run ~info:Sortal.Cmd.stats_info stats_cmd_term in
154
+
let add_org_cmd =
155
+
let term =
156
+
let open Term.Syntax in
157
+
let+ (xdg, _) = xdg_term
158
+
and+ handle = Sortal.Cmd.handle_arg
159
+
and+ org_name = Sortal.Cmd.org_name_arg
160
+
and+ title = Sortal.Cmd.org_title_arg
161
+
and+ department = Sortal.Cmd.org_department_arg
162
+
and+ from = Sortal.Cmd.date_arg "from"
163
+
and+ until = Sortal.Cmd.date_arg "until"
164
+
and+ org_email = Sortal.Cmd.org_email_arg
165
+
and+ org_url = Sortal.Cmd.org_url_arg
166
+
and+ log_level = Logs_cli.level () in
167
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
168
+
Logs.set_level log_level;
169
+
Sortal.Cmd.add_org_cmd handle org_name title department from until org_email org_url xdg env
170
+
in
171
+
Cmd.v Sortal.Cmd.add_org_info term
172
+
in
47
173
48
-
let sync_cmd_term = Term.(const (fun () -> Sortal.Cmd.sync_cmd ()) $ const ()) in
49
-
let sync_cmd = run ~info:Sortal.Cmd.sync_info sync_cmd_term in
174
+
let remove_org_cmd =
175
+
let term =
176
+
let open Term.Syntax in
177
+
let+ (xdg, _) = xdg_term
178
+
and+ handle = Sortal.Cmd.handle_arg
179
+
and+ org_name = Sortal.Cmd.org_name_arg
180
+
and+ log_level = Logs_cli.level () in
181
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
182
+
Logs.set_level log_level;
183
+
Sortal.Cmd.remove_org_cmd handle org_name xdg env
184
+
in
185
+
Cmd.v Sortal.Cmd.remove_org_info term
186
+
in
187
+
188
+
let add_url_cmd =
189
+
let term =
190
+
let open Term.Syntax in
191
+
let+ (xdg, _) = xdg_term
192
+
and+ handle = Sortal.Cmd.handle_arg
193
+
and+ url = Sortal.Cmd.url_value_arg
194
+
and+ label = Sortal.Cmd.label_arg
195
+
and+ log_level = Logs_cli.level () in
196
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
197
+
Logs.set_level log_level;
198
+
Sortal.Cmd.add_url_cmd handle url label xdg env
199
+
in
200
+
Cmd.v Sortal.Cmd.add_url_info term
201
+
in
202
+
203
+
let remove_url_cmd =
204
+
let term =
205
+
let open Term.Syntax in
206
+
let+ (xdg, _) = xdg_term
207
+
and+ handle = Sortal.Cmd.handle_arg
208
+
and+ url = Sortal.Cmd.url_value_arg
209
+
and+ log_level = Logs_cli.level () in
210
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
211
+
Logs.set_level log_level;
212
+
Sortal.Cmd.remove_url_cmd handle url xdg env
213
+
in
214
+
Cmd.v Sortal.Cmd.remove_url_info term
215
+
in
50
216
51
217
let default_term = Term.(ret (const (`Help (`Pager, None)))) in
52
218
···
56
222
search_cmd;
57
223
stats_cmd;
58
224
sync_cmd;
225
+
git_init_cmd;
226
+
add_cmd;
227
+
delete_cmd;
228
+
add_email_cmd;
229
+
remove_email_cmd;
230
+
add_service_cmd;
231
+
remove_service_cmd;
232
+
add_org_cmd;
233
+
remove_org_cmd;
234
+
add_url_cmd;
235
+
remove_url_cmd;
59
236
] in
60
237
61
238
exit (Cmd.eval' cmd)
+1
-1
lib/dune
+1
-1
lib/dune
+2
lib/sortal.ml
+2
lib/sortal.ml
+10
-4
lib/sortal.mli
+10
-4
lib/sortal.mli
···
3
3
This library provides a system for mapping usernames to various metadata
4
4
including URLs, emails, ORCID identifiers, and social media handles.
5
5
It uses XDG Base Directory Specification for storage locations and
6
-
jsont for JSON encoding/decoding.
6
+
provides temporal support for time-bounded information like historical
7
+
email addresses and employment records.
7
8
8
9
{b Storage:}
9
10
10
-
Contact metadata is stored as JSON files in the XDG data directory,
11
-
with one file per contact using the handle as the filename.
11
+
Contact metadata is stored as YAML files in the XDG data directory,
12
+
with one file per contact using the handle as the filename. The YAML
13
+
format uses the same Jsont codec definitions as JSON for seamless
14
+
compatibility.
12
15
13
16
{b Typical Usage:}
14
17
···
31
34
32
35
(** {1 Core Modules} *)
33
36
37
+
(** Temporal validity support for time-bounded contact fields. *)
38
+
module Temporal = Sortal_temporal
39
+
34
40
(** Feed subscription metadata. *)
35
41
module Feed = Sortal_feed
36
42
37
-
(** Contact metadata. *)
43
+
(** Contact metadata with temporal support. *)
38
44
module Contact = Sortal_contact
39
45
40
46
(** Contact store with XDG-compliant storage. *)
+319
-14
lib/sortal_cmd.ml
+319
-14
lib/sortal_cmd.ml
···
29
29
let store = Sortal_store.create_from_xdg xdg in
30
30
match Sortal_store.lookup store handle with
31
31
| Some c ->
32
-
Printf.printf "@%s: %s\n" (Sortal_contact.handle c) (Sortal_contact.name c);
33
-
Option.iter (fun e -> Printf.printf "Email: %s\n" e) (Sortal_contact.email c);
34
-
Option.iter (fun g -> Printf.printf "GitHub: https://github.com/%s\n" g) (Sortal_contact.github c);
35
-
Option.iter (fun u -> Printf.printf "URL: %s\n" u) (Sortal_contact.best_url c);
36
-
Option.iter (fun tw -> Printf.printf "Twitter: https://twitter.com/%s\n" tw) (Sortal_contact.twitter c);
37
-
Option.iter (fun b -> Printf.printf "Bluesky: %s\n" b) (Sortal_contact.bluesky c);
38
-
Option.iter (fun m -> Printf.printf "Mastodon: %s\n" m) (Sortal_contact.mastodon c);
39
-
Option.iter (fun o -> Printf.printf "ORCID: https://orcid.org/%s\n" o) (Sortal_contact.orcid c);
32
+
(* Use the pretty printer for rich temporal display *)
33
+
Fmt.pr "%a@." Sortal_contact.pp c;
40
34
0
41
35
| None -> Logs.err (fun m -> m "Contact not found: %s" handle); 1
42
36
···
52
46
(if List.length matches = 1 then "" else "es"));
53
47
List.iter (fun c ->
54
48
Logs.app (fun m -> m "@%s: %s" (Sortal_contact.handle c) (Sortal_contact.name c));
55
-
Option.iter (fun e -> Logs.app (fun m -> m " Email: %s" e)) (Sortal_contact.email c);
56
-
Option.iter (fun g -> Logs.app (fun m -> m " GitHub: @%s" g)) (Sortal_contact.github c);
49
+
Option.iter (fun e -> Logs.app (fun m -> m " Email: %s" e)) (Sortal_contact.current_email c);
57
50
Option.iter (fun u -> Logs.app (fun m -> m " URL: %s" u)) (Sortal_contact.best_url c)
58
51
) matches;
59
52
0
···
63
56
let contacts = Sortal_store.list store in
64
57
let total = List.length contacts in
65
58
let count pred = List.filter pred contacts |> List.length in
66
-
let with_email = count (fun c -> Option.is_some (Sortal_contact.email c)) in
67
-
let with_github = count (fun c -> Option.is_some (Sortal_contact.github c)) in
59
+
let with_email = count (fun c -> Sortal_contact.emails c <> []) in
60
+
let with_org = count (fun c -> Sortal_contact.organizations c <> []) in
61
+
let with_url = count (fun c -> Sortal_contact.urls c <> []) in
62
+
let with_service = count (fun c -> Sortal_contact.services c <> []) in
68
63
let with_orcid = count (fun c -> Option.is_some (Sortal_contact.orcid c)) in
69
-
let with_url = count (fun c -> Option.is_some (Sortal_contact.url c)) in
70
64
let with_feeds = count (fun c -> Option.is_some (Sortal_contact.feeds c)) in
71
65
let total_feeds =
72
66
List.fold_left (fun acc c ->
73
67
acc + Option.fold ~none:0 ~some:List.length (Sortal_contact.feeds c)
74
68
) 0 contacts
75
69
in
70
+
let total_services =
71
+
List.fold_left (fun acc c ->
72
+
acc + List.length (Sortal_contact.services c)
73
+
) 0 contacts
74
+
in
76
75
let pct n = float_of_int n /. float_of_int total *. 100. in
77
76
Logs.app (fun m -> m "Contact Database Statistics:");
78
77
Logs.app (fun m -> m " Total contacts: %d" total);
79
78
Logs.app (fun m -> m " With email: %d (%.1f%%)" with_email (pct with_email));
80
-
Logs.app (fun m -> m " With GitHub: %d (%.1f%%)" with_github (pct with_github));
79
+
Logs.app (fun m -> m " With organization: %d (%.1f%%)" with_org (pct with_org));
80
+
Logs.app (fun m -> m " With services: %d (%.1f%%), total %d services" with_service (pct with_service) total_services);
81
81
Logs.app (fun m -> m " With ORCID: %d (%.1f%%)" with_orcid (pct with_orcid));
82
82
Logs.app (fun m -> m " With URL: %d (%.1f%%)" with_url (pct with_url));
83
83
Logs.app (fun m -> m " With feeds: %d (%.1f%%), total %d feeds" with_feeds (pct with_feeds) total_feeds);
···
121
121
Logs.app (fun m -> m " %d errors" !errors);
122
122
if !errors > 0 then 1 else 0
123
123
124
+
(* Initialize git repository *)
125
+
let git_init_cmd xdg env =
126
+
let store = Sortal_store.create_from_xdg xdg in
127
+
let git_store = Sortal_git_store.create store env in
128
+
match Sortal_git_store.init git_store with
129
+
| Ok () ->
130
+
if Sortal_git_store.is_initialized git_store then
131
+
Logs.app (fun m -> m "Git repository initialized in data directory")
132
+
else
133
+
Logs.app (fun m -> m "Git repository already initialized");
134
+
0
135
+
| Error msg ->
136
+
Logs.err (fun m -> m "Failed to initialize git repository: %s" msg);
137
+
1
138
+
139
+
(* Add a new contact *)
140
+
let add_cmd handle names kind email github url orcid xdg env =
141
+
let store = Sortal_store.create_from_xdg xdg in
142
+
let git_store = Sortal_git_store.create store env in
143
+
(* Check if contact already exists *)
144
+
match Sortal_store.lookup store handle with
145
+
| Some _ ->
146
+
Logs.err (fun m -> m "Contact @%s already exists" handle);
147
+
1
148
+
| None ->
149
+
let emails = match email with
150
+
| Some e -> [Sortal_contact.make_email e]
151
+
| None -> []
152
+
in
153
+
let services = match github with
154
+
| Some gh -> [Sortal_contact.make_service ~kind:Sortal_contact.Github ~handle:gh (Printf.sprintf "https://github.com/%s" gh)]
155
+
| None -> []
156
+
in
157
+
let urls = match url with
158
+
| Some u -> [Sortal_contact.make_url u]
159
+
| None -> []
160
+
in
161
+
let contact = Sortal_contact.make
162
+
~handle
163
+
~names
164
+
?kind
165
+
~emails
166
+
~services
167
+
~urls
168
+
?orcid
169
+
()
170
+
in
171
+
match Sortal_git_store.save git_store contact with
172
+
| Ok () ->
173
+
Logs.app (fun m -> m "Created contact @%s: %s" handle (Sortal_contact.name contact));
174
+
0
175
+
| Error msg ->
176
+
Logs.err (fun m -> m "Failed to save contact: %s" msg);
177
+
1
178
+
179
+
(* Delete a contact *)
180
+
let delete_cmd handle xdg env =
181
+
let store = Sortal_store.create_from_xdg xdg in
182
+
let git_store = Sortal_git_store.create store env in
183
+
match Sortal_git_store.delete git_store handle with
184
+
| Ok () ->
185
+
Logs.app (fun m -> m "Deleted contact @%s" handle);
186
+
0
187
+
| Error msg ->
188
+
Logs.err (fun m -> m "%s" msg);
189
+
1
190
+
191
+
(* Add email to existing contact *)
192
+
let add_email_cmd handle address type_ from until note xdg env =
193
+
let store = Sortal_store.create_from_xdg xdg in
194
+
let git_store = Sortal_git_store.create store env in
195
+
let email = Sortal_contact.make_email ?type_ ?from ?until ?note address in
196
+
match Sortal_git_store.add_email git_store handle email with
197
+
| Ok () ->
198
+
Logs.app (fun m -> m "Added email %s to @%s" address handle);
199
+
0
200
+
| Error msg ->
201
+
Logs.err (fun m -> m "%s" msg);
202
+
1
203
+
204
+
(* Remove email from contact *)
205
+
let remove_email_cmd handle address xdg env =
206
+
let store = Sortal_store.create_from_xdg xdg in
207
+
let git_store = Sortal_git_store.create store env in
208
+
match Sortal_git_store.remove_email git_store handle address with
209
+
| Ok () ->
210
+
Logs.app (fun m -> m "Removed email %s from @%s" address handle);
211
+
0
212
+
| Error msg ->
213
+
Logs.err (fun m -> m "%s" msg);
214
+
1
215
+
216
+
(* Add service to existing contact *)
217
+
let add_service_cmd handle url kind service_handle label xdg env =
218
+
let store = Sortal_store.create_from_xdg xdg in
219
+
let git_store = Sortal_git_store.create store env in
220
+
let service = Sortal_contact.make_service ?kind ?handle:service_handle ?label url in
221
+
match Sortal_git_store.add_service git_store handle service with
222
+
| Ok () ->
223
+
Logs.app (fun m -> m "Added service %s to @%s" url handle);
224
+
0
225
+
| Error msg ->
226
+
Logs.err (fun m -> m "%s" msg);
227
+
1
228
+
229
+
(* Remove service from contact *)
230
+
let remove_service_cmd handle url xdg env =
231
+
let store = Sortal_store.create_from_xdg xdg in
232
+
let git_store = Sortal_git_store.create store env in
233
+
match Sortal_git_store.remove_service git_store handle url with
234
+
| Ok () ->
235
+
Logs.app (fun m -> m "Removed service %s from @%s" url handle);
236
+
0
237
+
| Error msg ->
238
+
Logs.err (fun m -> m "%s" msg);
239
+
1
240
+
241
+
(* Add organization to existing contact *)
242
+
let add_org_cmd handle org_name title department from until org_email org_url xdg env =
243
+
let store = Sortal_store.create_from_xdg xdg in
244
+
let git_store = Sortal_git_store.create store env in
245
+
let org = Sortal_contact.make_org ?title ?department ?from ?until ?email:org_email ?url:org_url org_name in
246
+
match Sortal_git_store.add_organization git_store handle org with
247
+
| Ok () ->
248
+
Logs.app (fun m -> m "Added organization %s to @%s" org_name handle);
249
+
0
250
+
| Error msg ->
251
+
Logs.err (fun m -> m "%s" msg);
252
+
1
253
+
254
+
(* Remove organization from contact *)
255
+
let remove_org_cmd handle org_name xdg env =
256
+
let store = Sortal_store.create_from_xdg xdg in
257
+
let git_store = Sortal_git_store.create store env in
258
+
match Sortal_git_store.remove_organization git_store handle org_name with
259
+
| Ok () ->
260
+
Logs.app (fun m -> m "Removed organization %s from @%s" org_name handle);
261
+
0
262
+
| Error msg ->
263
+
Logs.err (fun m -> m "%s" msg);
264
+
1
265
+
266
+
(* Add URL to existing contact *)
267
+
let add_url_cmd handle url label xdg env =
268
+
let store = Sortal_store.create_from_xdg xdg in
269
+
let git_store = Sortal_git_store.create store env in
270
+
let url_entry = Sortal_contact.make_url ?label url in
271
+
match Sortal_git_store.add_url git_store handle url_entry with
272
+
| Ok () ->
273
+
Logs.app (fun m -> m "Added URL %s to @%s" url handle);
274
+
0
275
+
| Error msg ->
276
+
Logs.err (fun m -> m "%s" msg);
277
+
1
278
+
279
+
(* Remove URL from contact *)
280
+
let remove_url_cmd handle url xdg env =
281
+
let store = Sortal_store.create_from_xdg xdg in
282
+
let git_store = Sortal_git_store.create store env in
283
+
match Sortal_git_store.remove_url git_store handle url with
284
+
| Ok () ->
285
+
Logs.app (fun m -> m "Removed URL %s from @%s" url handle);
286
+
0
287
+
| Error msg ->
288
+
Logs.err (fun m -> m "%s" msg);
289
+
1
290
+
291
+
(* Command info and args *)
124
292
let list_info = Cmd.info "list" ~doc:"List all contacts"
125
293
let show_info = Cmd.info "show" ~doc:"Show detailed information about a contact"
126
294
let search_info = Cmd.info "search" ~doc:"Search contacts by name"
127
295
let stats_info = Cmd.info "stats" ~doc:"Show statistics about the contact database"
128
296
let sync_info = Cmd.info "sync" ~doc:"Synchronize and normalize contact data"
129
297
298
+
let git_init_info = Cmd.info "git-init" ~doc:"Initialize git repository for contact versioning"
299
+
~man:[
300
+
`S Manpage.s_description;
301
+
`P "Initialize a git repository in the XDG data directory to track contact changes.";
302
+
`P "Once initialized, all contact modifications will be automatically committed with descriptive messages.";
303
+
]
304
+
305
+
let add_info = Cmd.info "add" ~doc:"Create a new contact"
306
+
~man:[
307
+
`S Manpage.s_description;
308
+
`P "Create a new contact with the given handle and name.";
309
+
`P "Additional metadata can be added using options or via add-email, add-service, etc. commands.";
310
+
]
311
+
312
+
let delete_info = Cmd.info "delete" ~doc:"Delete a contact"
313
+
let add_email_info = Cmd.info "add-email" ~doc:"Add an email address to a contact"
314
+
let remove_email_info = Cmd.info "remove-email" ~doc:"Remove an email address from a contact"
315
+
let add_service_info = Cmd.info "add-service" ~doc:"Add a service (GitHub, Twitter, etc.) to a contact"
316
+
let remove_service_info = Cmd.info "remove-service" ~doc:"Remove a service from a contact"
317
+
let add_org_info = Cmd.info "add-org" ~doc:"Add an organization/affiliation to a contact"
318
+
let remove_org_info = Cmd.info "remove-org" ~doc:"Remove an organization from a contact"
319
+
let add_url_info = Cmd.info "add-url" ~doc:"Add a URL to a contact"
320
+
let remove_url_info = Cmd.info "remove-url" ~doc:"Remove a URL from a contact"
321
+
130
322
let handle_arg =
131
323
Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE"
132
324
~doc:"Contact handle to display")
···
134
326
let query_arg =
135
327
Arg.(required & pos 0 (some string) None & info [] ~docv:"QUERY"
136
328
~doc:"Name or partial name to search for")
329
+
330
+
(* Add command arguments *)
331
+
let add_handle_arg =
332
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE"
333
+
~doc:"Contact handle (unique identifier)")
334
+
335
+
let add_names_arg =
336
+
Arg.(non_empty & opt_all string [] & info ["n"; "name"] ~docv:"NAME"
337
+
~doc:"Full name (can be specified multiple times for aliases)")
338
+
339
+
let add_kind_arg =
340
+
let kind_conv =
341
+
let parse s = match Sortal_contact.contact_kind_of_string s with
342
+
| Some k -> Ok k
343
+
| None -> Error (`Msg (Printf.sprintf "Invalid kind: %s" s))
344
+
in
345
+
let print ppf k = Format.pp_print_string ppf (Sortal_contact.contact_kind_to_string k) in
346
+
Arg.conv (parse, print)
347
+
in
348
+
Arg.(value & opt (some kind_conv) None & info ["k"; "kind"] ~docv:"KIND"
349
+
~doc:"Contact kind (person, organization, group, role)")
350
+
351
+
let add_email_arg =
352
+
Arg.(value & opt (some string) None & info ["e"; "email"] ~docv:"EMAIL"
353
+
~doc:"Email address")
354
+
355
+
let add_github_arg =
356
+
Arg.(value & opt (some string) None & info ["g"; "github"] ~docv:"HANDLE"
357
+
~doc:"GitHub handle")
358
+
359
+
let add_url_arg =
360
+
Arg.(value & opt (some string) None & info ["u"; "url"] ~docv:"URL"
361
+
~doc:"Personal/professional website URL")
362
+
363
+
let add_orcid_arg =
364
+
Arg.(value & opt (some string) None & info ["orcid"] ~docv:"ORCID"
365
+
~doc:"ORCID identifier")
366
+
367
+
(* Add-email command arguments *)
368
+
let email_address_arg =
369
+
Arg.(required & pos 1 (some string) None & info [] ~docv:"EMAIL"
370
+
~doc:"Email address")
371
+
372
+
let email_type_arg =
373
+
let type_conv =
374
+
let parse s = match Sortal_contact.email_type_of_string s with
375
+
| Some t -> Ok t
376
+
| None -> Error (`Msg (Printf.sprintf "Invalid email type: %s" s))
377
+
in
378
+
let print ppf t = Format.pp_print_string ppf (Sortal_contact.email_type_to_string t) in
379
+
Arg.conv (parse, print)
380
+
in
381
+
Arg.(value & opt (some type_conv) None & info ["t"; "type"] ~docv:"TYPE"
382
+
~doc:"Email type (work, personal, other)")
383
+
384
+
let date_arg name =
385
+
Arg.(value & opt (some string) None & info [name] ~docv:"DATE"
386
+
~doc:"ISO 8601 date (e.g., 2023, 2023-01, 2023-01-15)")
387
+
388
+
let note_arg =
389
+
Arg.(value & opt (some string) None & info ["note"] ~docv:"NOTE"
390
+
~doc:"Contextual note")
391
+
392
+
(* Add-service command arguments *)
393
+
let service_url_arg =
394
+
Arg.(required & pos 1 (some string) None & info [] ~docv:"URL"
395
+
~doc:"Service URL")
396
+
397
+
let service_kind_arg =
398
+
let kind_conv =
399
+
let parse s = match Sortal_contact.service_kind_of_string s with
400
+
| Some k -> Ok k
401
+
| None -> Error (`Msg (Printf.sprintf "Invalid service kind: %s" s))
402
+
in
403
+
let print ppf k = Format.pp_print_string ppf (Sortal_contact.service_kind_to_string k) in
404
+
Arg.conv (parse, print)
405
+
in
406
+
Arg.(value & opt (some kind_conv) None & info ["k"; "kind"] ~docv:"KIND"
407
+
~doc:"Service kind (github, git, social, activitypub, photo)")
408
+
409
+
let service_handle_arg =
410
+
Arg.(value & opt (some string) None & info ["handle"] ~docv:"HANDLE"
411
+
~doc:"Service handle/username")
412
+
413
+
let label_arg =
414
+
Arg.(value & opt (some string) None & info ["l"; "label"] ~docv:"LABEL"
415
+
~doc:"Human-readable label")
416
+
417
+
(* Add-org command arguments *)
418
+
let org_name_arg =
419
+
Arg.(required & pos 1 (some string) None & info [] ~docv:"ORG"
420
+
~doc:"Organization name")
421
+
422
+
let org_title_arg =
423
+
Arg.(value & opt (some string) None & info ["title"] ~docv:"TITLE"
424
+
~doc:"Job title")
425
+
426
+
let org_department_arg =
427
+
Arg.(value & opt (some string) None & info ["dept"; "department"] ~docv:"DEPT"
428
+
~doc:"Department")
429
+
430
+
let org_email_arg =
431
+
Arg.(value & opt (some string) None & info ["email"] ~docv:"EMAIL"
432
+
~doc:"Work email during this period")
433
+
434
+
let org_url_arg =
435
+
Arg.(value & opt (some string) None & info ["url"] ~docv:"URL"
436
+
~doc:"Work homepage during this period")
437
+
438
+
(* URL command arguments *)
439
+
let url_value_arg =
440
+
Arg.(required & pos 1 (some string) None & info [] ~docv:"URL"
441
+
~doc:"URL")
+172
lib/sortal_cmd.mli
+172
lib/sortal_cmd.mli
···
29
29
- Converts non-JPG thumbnail images to PNG using ImageMagick *)
30
30
val sync_cmd : unit -> (Xdge.t -> int)
31
31
32
+
(** [git_init_cmd xdg env] initializes a git repository in the data directory.
33
+
34
+
Once initialized, all contact modifications will be automatically committed.
35
+
@param xdg XDG context
36
+
@param env Eio environment for process spawning *)
37
+
val git_init_cmd : Xdge.t -> Eio_unix.Stdenv.base -> int
38
+
39
+
(** [add_cmd handle names kind email github url orcid xdg env] creates a new contact.
40
+
41
+
@param handle Contact handle (unique identifier)
42
+
@param names List of names (first is primary)
43
+
@param kind Optional contact kind
44
+
@param email Optional email address
45
+
@param github Optional GitHub handle
46
+
@param url Optional personal/professional website
47
+
@param orcid Optional ORCID identifier
48
+
@param xdg XDG context
49
+
@param env Eio environment for git operations *)
50
+
val add_cmd : string -> string list -> Sortal_contact.contact_kind option ->
51
+
string option -> string option -> string option -> string option ->
52
+
Xdge.t -> Eio_unix.Stdenv.base -> int
53
+
54
+
(** [delete_cmd handle xdg env] deletes a contact.
55
+
56
+
@param handle The contact handle to delete
57
+
@param xdg XDG context
58
+
@param env Eio environment for git operations *)
59
+
val delete_cmd : string -> Xdge.t -> Eio_unix.Stdenv.base -> int
60
+
61
+
(** [add_email_cmd handle address type_ from until note xdg env] adds an email to a contact.
62
+
63
+
@param handle Contact handle
64
+
@param address Email address
65
+
@param type_ Email type (work, personal, other)
66
+
@param from Start date of validity
67
+
@param until End date of validity
68
+
@param note Contextual note
69
+
@param xdg XDG context
70
+
@param env Eio environment for git operations *)
71
+
val add_email_cmd : string -> string -> Sortal_contact.email_type option ->
72
+
string option -> string option -> string option ->
73
+
Xdge.t -> Eio_unix.Stdenv.base -> int
74
+
75
+
(** [remove_email_cmd handle address xdg env] removes an email from a contact. *)
76
+
val remove_email_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int
77
+
78
+
(** [add_service_cmd handle url kind service_handle label xdg env] adds a service to a contact.
79
+
80
+
@param handle Contact handle
81
+
@param url Service URL
82
+
@param kind Service kind
83
+
@param service_handle Service username/handle
84
+
@param label Human-readable label
85
+
@param xdg XDG context
86
+
@param env Eio environment for git operations *)
87
+
val add_service_cmd : string -> string -> Sortal_contact.service_kind option ->
88
+
string option -> string option -> Xdge.t -> Eio_unix.Stdenv.base -> int
89
+
90
+
(** [remove_service_cmd handle url xdg env] removes a service from a contact. *)
91
+
val remove_service_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int
92
+
93
+
(** [add_org_cmd handle org_name title department from until org_email org_url xdg env]
94
+
adds an organization to a contact. *)
95
+
val add_org_cmd : string -> string -> string option -> string option ->
96
+
string option -> string option -> string option -> string option ->
97
+
Xdge.t -> Eio_unix.Stdenv.base -> int
98
+
99
+
(** [remove_org_cmd handle org_name xdg env] removes an organization from a contact. *)
100
+
val remove_org_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int
101
+
102
+
(** [add_url_cmd handle url label xdg env] adds a URL to a contact. *)
103
+
val add_url_cmd : string -> string -> string option -> Xdge.t -> Eio_unix.Stdenv.base -> int
104
+
105
+
(** [remove_url_cmd handle url xdg env] removes a URL from a contact. *)
106
+
val remove_url_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int
107
+
32
108
(** {1 Cmdliner Info Objects} *)
33
109
34
110
(** [list_info] is the command info for the list command. *)
···
46
122
(** [sync_info] is the command info for the sync command. *)
47
123
val sync_info : Cmdliner.Cmd.info
48
124
125
+
(** [git_init_info] is the command info for the git-init command. *)
126
+
val git_init_info : Cmdliner.Cmd.info
127
+
128
+
(** [add_info] is the command info for the add command. *)
129
+
val add_info : Cmdliner.Cmd.info
130
+
131
+
(** [delete_info] is the command info for the delete command. *)
132
+
val delete_info : Cmdliner.Cmd.info
133
+
134
+
(** [add_email_info] is the command info for the add-email command. *)
135
+
val add_email_info : Cmdliner.Cmd.info
136
+
137
+
(** [remove_email_info] is the command info for the remove-email command. *)
138
+
val remove_email_info : Cmdliner.Cmd.info
139
+
140
+
(** [add_service_info] is the command info for the add-service command. *)
141
+
val add_service_info : Cmdliner.Cmd.info
142
+
143
+
(** [remove_service_info] is the command info for the remove-service command. *)
144
+
val remove_service_info : Cmdliner.Cmd.info
145
+
146
+
(** [add_org_info] is the command info for the add-org command. *)
147
+
val add_org_info : Cmdliner.Cmd.info
148
+
149
+
(** [remove_org_info] is the command info for the remove-org command. *)
150
+
val remove_org_info : Cmdliner.Cmd.info
151
+
152
+
(** [add_url_info] is the command info for the add-url command. *)
153
+
val add_url_info : Cmdliner.Cmd.info
154
+
155
+
(** [remove_url_info] is the command info for the remove-url command. *)
156
+
val remove_url_info : Cmdliner.Cmd.info
157
+
49
158
(** {1 Cmdliner Argument Definitions} *)
50
159
51
160
(** [handle_arg] is the positional argument for a contact handle. *)
···
53
162
54
163
(** [query_arg] is the positional argument for a search query. *)
55
164
val query_arg : string Cmdliner.Term.t
165
+
166
+
(** [add_handle_arg] is the positional argument for a new contact handle. *)
167
+
val add_handle_arg : string Cmdliner.Term.t
168
+
169
+
(** [add_names_arg] is the repeatable option for contact names. *)
170
+
val add_names_arg : string list Cmdliner.Term.t
171
+
172
+
(** [add_kind_arg] is the optional argument for contact kind. *)
173
+
val add_kind_arg : Sortal_contact.contact_kind option Cmdliner.Term.t
174
+
175
+
(** [add_email_arg] is the optional argument for email. *)
176
+
val add_email_arg : string option Cmdliner.Term.t
177
+
178
+
(** [add_github_arg] is the optional argument for GitHub handle. *)
179
+
val add_github_arg : string option Cmdliner.Term.t
180
+
181
+
(** [add_url_arg] is the optional argument for URL. *)
182
+
val add_url_arg : string option Cmdliner.Term.t
183
+
184
+
(** [add_orcid_arg] is the optional argument for ORCID. *)
185
+
val add_orcid_arg : string option Cmdliner.Term.t
186
+
187
+
(** [email_address_arg] is the positional argument for email address. *)
188
+
val email_address_arg : string Cmdliner.Term.t
189
+
190
+
(** [email_type_arg] is the optional argument for email type. *)
191
+
val email_type_arg : Sortal_contact.email_type option Cmdliner.Term.t
192
+
193
+
(** [date_arg name] creates a date argument with the given option name. *)
194
+
val date_arg : string -> string option Cmdliner.Term.t
195
+
196
+
(** [note_arg] is the optional argument for notes. *)
197
+
val note_arg : string option Cmdliner.Term.t
198
+
199
+
(** [service_url_arg] is the positional argument for service URL. *)
200
+
val service_url_arg : string Cmdliner.Term.t
201
+
202
+
(** [service_kind_arg] is the optional argument for service kind. *)
203
+
val service_kind_arg : Sortal_contact.service_kind option Cmdliner.Term.t
204
+
205
+
(** [service_handle_arg] is the optional argument for service handle. *)
206
+
val service_handle_arg : string option Cmdliner.Term.t
207
+
208
+
(** [label_arg] is the optional argument for labels. *)
209
+
val label_arg : string option Cmdliner.Term.t
210
+
211
+
(** [org_name_arg] is the positional argument for organization name. *)
212
+
val org_name_arg : string Cmdliner.Term.t
213
+
214
+
(** [org_title_arg] is the optional argument for job title. *)
215
+
val org_title_arg : string option Cmdliner.Term.t
216
+
217
+
(** [org_department_arg] is the optional argument for department. *)
218
+
val org_department_arg : string option Cmdliner.Term.t
219
+
220
+
(** [org_email_arg] is the optional argument for work email. *)
221
+
val org_email_arg : string option Cmdliner.Term.t
222
+
223
+
(** [org_url_arg] is the optional argument for work URL. *)
224
+
val org_url_arg : string option Cmdliner.Term.t
225
+
226
+
(** [url_value_arg] is the positional argument for URL. *)
227
+
val url_value_arg : string Cmdliner.Term.t
+2
-115
lib/sortal_contact.ml
+2
-115
lib/sortal_contact.ml
···
1
-
type t = {
2
-
handle : string;
3
-
names : string list;
4
-
email : string option;
5
-
icon : string option;
6
-
thumbnail : string option;
7
-
github : string option;
8
-
twitter : string option;
9
-
bluesky : string option;
10
-
mastodon : string option;
11
-
orcid : string option;
12
-
url_ : string option;
13
-
urls_ : string list option;
14
-
feeds : Sortal_feed.t list option;
15
-
}
16
-
17
-
let make ~handle ~names ?email ?icon ?thumbnail ?github ?twitter ?bluesky ?mastodon
18
-
?orcid ?url ?urls ?feeds () =
19
-
{ handle; names; email; icon; thumbnail; github; twitter; bluesky; mastodon;
20
-
orcid; url_ = url; urls_ = urls; feeds }
21
-
22
-
let handle t = t.handle
23
-
let names t = t.names
24
-
let name t = List.hd t.names
25
-
let primary_name = name
26
-
let email t = t.email
27
-
let icon t = t.icon
28
-
let thumbnail t = t.thumbnail
29
-
let github t = t.github
30
-
let twitter t = t.twitter
31
-
let bluesky t = t.bluesky
32
-
let mastodon t = t.mastodon
33
-
let orcid t = t.orcid
34
-
35
-
let url t =
36
-
t.url_ |> Option.fold ~none:(Option.bind t.urls_ (Fun.flip List.nth_opt 0)) ~some:Option.some
37
-
38
-
let urls t =
39
-
match t.url_, t.urls_ with
40
-
| Some u, Some us -> u :: us
41
-
| Some u, None -> [u]
42
-
| None, Some us -> us
43
-
| None, None -> []
44
-
45
-
let feeds t = t.feeds
46
-
47
-
let add_feed t feed =
48
-
{ t with feeds = Some (feed :: Option.value t.feeds ~default:[]) }
49
-
50
-
let remove_feed t url =
51
-
{ t with feeds = Option.map (List.filter (fun f -> Sortal_feed.url f <> url)) t.feeds }
52
-
53
-
let best_url t =
54
-
url t
55
-
|> Option.fold ~none:(Option.map (fun g -> "https://github.com/" ^ g) t.github) ~some:Option.some
56
-
|> Option.fold ~none:(Option.map (fun e -> "mailto:" ^ e) t.email) ~some:Option.some
57
-
58
-
let json_t =
59
-
let open Jsont in
60
-
let open Jsont.Object in
61
-
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
62
-
let make handle names email icon thumbnail github twitter bluesky mastodon orcid url urls feeds =
63
-
{ handle; names; email; icon; thumbnail; github; twitter; bluesky; mastodon;
64
-
orcid; url_ = url; urls_ = urls; feeds }
65
-
in
66
-
map ~kind:"Contact" make
67
-
|> mem "handle" string ~enc:handle
68
-
|> mem "names" (list string) ~dec_absent:[] ~enc:names
69
-
|> mem_opt "email" (some string) ~enc:email
70
-
|> mem_opt "icon" (some string) ~enc:icon
71
-
|> mem_opt "thumbnail" (some string) ~enc:thumbnail
72
-
|> mem_opt "github" (some string) ~enc:github
73
-
|> mem_opt "twitter" (some string) ~enc:twitter
74
-
|> mem_opt "bluesky" (some string) ~enc:bluesky
75
-
|> mem_opt "mastodon" (some string) ~enc:mastodon
76
-
|> mem_opt "orcid" (some string) ~enc:orcid
77
-
|> mem_opt "url" (some string) ~enc:(fun t -> t.url_)
78
-
|> mem_opt "urls" (some (list string)) ~enc:(fun t -> t.urls_)
79
-
|> mem_opt "feeds" (some (list Sortal_feed.json_t)) ~enc:feeds
80
-
|> finish
81
-
82
-
let compare a b = String.compare a.handle b.handle
83
-
84
-
let pp ppf t =
85
-
let open Fmt in
86
-
let label = styled (`Fg `Cyan) string in
87
-
let url_style = styled (`Fg `Blue) in
88
-
let field lbl fmt_v = Option.iter (fun v -> pf ppf "%a: %a@," label lbl fmt_v v) in
89
-
pf ppf "@[<v>";
90
-
pf ppf "%a: %a@," label "Handle" (styled `Bold (fun ppf s -> pf ppf "@%s" s)) t.handle;
91
-
pf ppf "%a: %a@," label "Name" (styled `Bold string) (name t);
92
-
if List.length (names t) > 1 then
93
-
pf ppf "%a: @[<h>%a@]@," label "Aliases"
94
-
(list ~sep:comma string) (List.tl (names t));
95
-
field "Email" (styled (`Fg `Yellow) string) t.email;
96
-
field "GitHub" (url_style (fun ppf g -> pf ppf "https://github.com/%s" g)) t.github;
97
-
field "Twitter" (url_style (fun ppf tw -> pf ppf "https://twitter.com/%s" tw)) t.twitter;
98
-
field "Bluesky" (styled (`Fg `Magenta) string) t.bluesky;
99
-
field "Mastodon" (styled (`Fg `Magenta) string) t.mastodon;
100
-
field "ORCID" (url_style (fun ppf o -> pf ppf "https://orcid.org/%s" o)) t.orcid;
101
-
(match urls t with
102
-
| [] -> ()
103
-
| [u] -> pf ppf "%a: %a@," label "URL" (url_style string) u
104
-
| all_urls ->
105
-
pf ppf "%a:@," label "URLs";
106
-
List.iter (fun u -> pf ppf " - %a@," (url_style string) u) all_urls);
107
-
field "Icon" (url_style string) t.icon;
108
-
field "Thumbnail" (styled (`Fg `White) string) t.thumbnail;
109
-
Option.iter (function
110
-
| [] -> ()
111
-
| feeds ->
112
-
pf ppf "%a:@," label "Feeds";
113
-
List.iter (fun feed -> pf ppf " - %a@," Sortal_feed.pp feed) feeds
114
-
) t.feeds;
115
-
pf ppf "@]"
1
+
module V1 = Sortal_contact_v1
2
+
include Sortal_contact_v1
+7
-132
lib/sortal_contact.mli
+7
-132
lib/sortal_contact.mli
···
1
1
(** Individual contact metadata.
2
2
3
-
A contact represents metadata about a person, including their name(s),
4
-
social media handles, professional identifiers, and other contact information. *)
5
-
6
-
type t
7
-
8
-
(** [make ~handle ~names ?email ?icon ?thumbnail ?github ?twitter ?bluesky ?mastodon
9
-
?orcid ?url ?feeds ()] creates a new contact.
10
-
11
-
@param handle A unique identifier/username for this contact (required)
12
-
@param names A list of names for this contact, with the first being primary (required)
13
-
@param email Email address
14
-
@param icon URL to an avatar/icon image
15
-
@param thumbnail Path to a local thumbnail image file
16
-
@param github GitHub username (without the [\@] prefix)
17
-
@param twitter Twitter/X username (without the [\@] prefix)
18
-
@param bluesky Bluesky handle
19
-
@param mastodon Mastodon handle (including instance)
20
-
@param orcid ORCID identifier
21
-
@param url Personal or professional website URL (primary URL)
22
-
@param urls Additional website URLs
23
-
@param feeds List of feed subscriptions (Atom/RSS/JSON) associated with this contact *)
24
-
val make :
25
-
handle:string ->
26
-
names:string list ->
27
-
?email:string ->
28
-
?icon:string ->
29
-
?thumbnail:string ->
30
-
?github:string ->
31
-
?twitter:string ->
32
-
?bluesky:string ->
33
-
?mastodon:string ->
34
-
?orcid:string ->
35
-
?url:string ->
36
-
?urls:string list ->
37
-
?feeds:Sortal_feed.t list ->
38
-
unit ->
39
-
t
40
-
41
-
(** {1 Accessors} *)
42
-
43
-
(** [handle t] returns the unique handle/username. *)
44
-
val handle : t -> string
3
+
This module re-exports the current contact schema version (V1).
4
+
See {!Sortal_contact_v1} for the full API documentation. *)
45
5
46
-
(** [names t] returns all names associated with this contact. *)
47
-
val names : t -> string list
6
+
(** {1 Current Schema Version} *)
48
7
49
-
(** [name t] returns the primary (first) name. *)
50
-
val name : t -> string
8
+
module V1 = Sortal_contact_v1
9
+
(** Current schema version. All functions below are aliases to V1. *)
51
10
52
-
(** [primary_name t] returns the primary (first) name.
53
-
This is an alias for {!name} for clarity. *)
54
-
val primary_name : t -> string
55
-
56
-
(** [email t] returns the email address if available. *)
57
-
val email : t -> string option
58
-
59
-
(** [icon t] returns the icon/avatar URL if available. *)
60
-
val icon : t -> string option
61
-
62
-
(** [thumbnail t] returns the path to the local thumbnail image if available.
63
-
This is a relative path from the Sortal data directory. *)
64
-
val thumbnail : t -> string option
65
-
66
-
(** [github t] returns the GitHub username if available. *)
67
-
val github : t -> string option
68
-
69
-
(** [twitter t] returns the Twitter/X username if available. *)
70
-
val twitter : t -> string option
71
-
72
-
(** [bluesky t] returns the Bluesky handle if available. *)
73
-
val bluesky : t -> string option
74
-
75
-
(** [mastodon t] returns the Mastodon handle if available. *)
76
-
val mastodon : t -> string option
77
-
78
-
(** [orcid t] returns the ORCID identifier if available. *)
79
-
val orcid : t -> string option
80
-
81
-
(** [url t] returns the primary URL if available.
82
-
83
-
Returns the [url] field if set, otherwise returns the first element
84
-
of [urls] if available, or [None] if neither is set. *)
85
-
val url : t -> string option
86
-
87
-
(** [urls t] returns all URLs associated with this contact.
88
-
89
-
Combines the [url] field (if set) with the [urls] list (if set).
90
-
The primary [url] appears first if present. Returns an empty list
91
-
if neither [url] nor [urls] is set. *)
92
-
val urls : t -> string list
93
-
94
-
(** [feeds t] returns the list of feed subscriptions if available. *)
95
-
val feeds : t -> Sortal_feed.t list option
96
-
97
-
(** [add_feed t feed] returns a new contact with the feed added. *)
98
-
val add_feed : t -> Sortal_feed.t -> t
99
-
100
-
(** [remove_feed t url] returns a new contact with the feed matching the URL removed. *)
101
-
val remove_feed : t -> string -> t
102
-
103
-
(** {1 Derived Information} *)
104
-
105
-
(** [best_url t] returns the best available URL for this contact.
106
-
107
-
Priority order:
108
-
1. Personal URL (if set)
109
-
2. GitHub profile URL (if GitHub username is set)
110
-
3. Email as mailto: link (if email is set)
111
-
4. None if no URL-like information is available *)
112
-
val best_url : t -> string option
113
-
114
-
(** {1 JSON Encoding} *)
115
-
116
-
(** [json_t] is the jsont encoder/decoder for contacts.
117
-
118
-
The JSON schema includes all contact fields with optional values
119
-
omitted when not present:
120
-
{[
121
-
{
122
-
"handle": "avsm",
123
-
"names": ["Anil Madhavapeddy"],
124
-
"email": "anil@recoil.org",
125
-
"github": "avsm",
126
-
"orcid": "0000-0002-7890-1234"
127
-
}
128
-
]} *)
129
-
val json_t : t Jsont.t
130
-
131
-
(** {1 Utilities} *)
132
-
133
-
(** [compare a b] compares two contacts by their handles. *)
134
-
val compare : t -> t -> int
135
-
136
-
(** [pp ppf t] pretty prints a contact with formatting. *)
137
-
val pp : Format.formatter -> t -> unit
11
+
include module type of Sortal_contact_v1
12
+
(** @inline *)
+463
lib/sortal_contact_v1.ml
+463
lib/sortal_contact_v1.ml
···
1
+
let version = 1
2
+
3
+
type contact_kind = Person | Organization | Group | Role
4
+
5
+
type service_kind =
6
+
| ActivityPub
7
+
| Github
8
+
| Git
9
+
| Social
10
+
| Photo
11
+
| Custom of string
12
+
13
+
type service = {
14
+
url: string;
15
+
kind: service_kind option;
16
+
handle: string option;
17
+
label: string option;
18
+
range: Sortal_temporal.range option;
19
+
primary: bool;
20
+
}
21
+
22
+
type email_type = Work | Personal | Other
23
+
24
+
type email = {
25
+
address: string;
26
+
type_: email_type option;
27
+
range: Sortal_temporal.range option;
28
+
note: string option;
29
+
}
30
+
31
+
type organization = {
32
+
name: string;
33
+
title: string option;
34
+
department: string option;
35
+
range: Sortal_temporal.range option;
36
+
email: string option;
37
+
url: string option;
38
+
}
39
+
40
+
type url_entry = {
41
+
url: string;
42
+
label: string option;
43
+
range: Sortal_temporal.range option;
44
+
}
45
+
46
+
type t = {
47
+
version: int;
48
+
kind: contact_kind;
49
+
handle: string;
50
+
names: string list;
51
+
emails: email list;
52
+
organizations: organization list;
53
+
urls: url_entry list;
54
+
services: service list;
55
+
icon: string option;
56
+
thumbnail: string option;
57
+
orcid: string option;
58
+
feeds: Sortal_feed.t list option;
59
+
}
60
+
61
+
(* Helpers *)
62
+
let make_email ?type_ ?from ?until ?note address =
63
+
let range = match from, until with
64
+
| None, None -> None
65
+
| _, _ -> Some (Sortal_temporal.make ?from ?until ())
66
+
in
67
+
{ address; type_; range; note }
68
+
69
+
let email_of_string address =
70
+
{ address; type_ = Some Personal; range = None; note = None }
71
+
72
+
let make_org ?title ?department ?from ?until ?email ?url name =
73
+
let range = match from, until with
74
+
| None, None -> None
75
+
| _, _ -> Some (Sortal_temporal.make ?from ?until ())
76
+
in
77
+
{ name; title; department; range; email; url }
78
+
79
+
let make_url ?label ?from ?until url =
80
+
let range = match from, until with
81
+
| None, None -> None
82
+
| _, _ -> Some (Sortal_temporal.make ?from ?until ())
83
+
in
84
+
{ url; label; range }
85
+
86
+
let url_of_string url =
87
+
{ url; label = None; range = None }
88
+
89
+
let make_service ?kind ?handle ?label ?from ?until ?(primary = false) url =
90
+
let range = match from, until with
91
+
| None, None -> None
92
+
| _, _ -> Some (Sortal_temporal.make ?from ?until ())
93
+
in
94
+
{ url; kind; handle; label; range; primary }
95
+
96
+
let service_of_url url =
97
+
{ url; kind = None; handle = None; label = None; range = None; primary = false }
98
+
99
+
let make ~handle ~names ?(kind = Person) ?(emails = []) ?(organizations = [])
100
+
?(urls = []) ?(services = []) ?icon ?thumbnail ?orcid ?feeds () =
101
+
{ version; kind; handle; names; emails; organizations; urls; services;
102
+
icon; thumbnail; orcid; feeds }
103
+
104
+
(* Accessors *)
105
+
let version_of t = t.version
106
+
let kind t = t.kind
107
+
let handle t = t.handle
108
+
let names t = t.names
109
+
let name t = List.hd t.names
110
+
let primary_name = name
111
+
let emails t = t.emails
112
+
let organizations t = t.organizations
113
+
let urls t = t.urls
114
+
let services t = t.services
115
+
let icon t = t.icon
116
+
let thumbnail t = t.thumbnail
117
+
let orcid t = t.orcid
118
+
let feeds t = t.feeds
119
+
120
+
(* Temporal queries *)
121
+
let emails_at t ~date =
122
+
Sortal_temporal.at_date ~get:(fun (e : email) -> e.range) ~date t.emails
123
+
124
+
let email_at t ~date =
125
+
match emails_at t ~date with
126
+
| e :: _ -> Some e.address
127
+
| [] -> None
128
+
129
+
let current_email t =
130
+
match Sortal_temporal.current ~get:(fun (e : email) -> e.range) t.emails with
131
+
| Some e -> Some e.address
132
+
| None -> None
133
+
134
+
let organization_at t ~date =
135
+
match Sortal_temporal.at_date ~get:(fun (o : organization) -> o.range) ~date t.organizations with
136
+
| o :: _ -> Some o
137
+
| [] -> None
138
+
139
+
let current_organization t =
140
+
Sortal_temporal.current ~get:(fun (o : organization) -> o.range) t.organizations
141
+
142
+
let url_at t ~date =
143
+
match Sortal_temporal.at_date ~get:(fun (u : url_entry) -> u.range) ~date t.urls with
144
+
| u :: _ -> Some u.url
145
+
| [] -> None
146
+
147
+
let current_url t =
148
+
match Sortal_temporal.current ~get:(fun (u : url_entry) -> u.range) t.urls with
149
+
| Some u -> Some u.url
150
+
| None -> None
151
+
152
+
let all_email_addresses t =
153
+
List.map (fun e -> e.address) t.emails
154
+
155
+
(* Service queries *)
156
+
let services_of_kind t (kind : service_kind) =
157
+
List.filter (fun (s : service) ->
158
+
match (s.kind : service_kind option) with
159
+
| Some k when k = kind -> true
160
+
| _ -> false
161
+
) t.services
162
+
163
+
let services_at t ~date =
164
+
Sortal_temporal.at_date ~get:(fun (s : service) -> s.range) ~date t.services
165
+
166
+
let current_services t =
167
+
List.filter (fun (s : service) -> Sortal_temporal.is_current s.range) t.services
168
+
169
+
let primary_service t (kind : service_kind) =
170
+
List.find_opt (fun (s : service) ->
171
+
match (s.kind : service_kind option) with
172
+
| Some k when k = kind && s.primary -> true
173
+
| _ -> false
174
+
) t.services
175
+
176
+
let best_url t =
177
+
current_url t
178
+
|> Option.fold ~none:(
179
+
match current_services t with
180
+
| s :: _ -> Some s.url
181
+
| [] -> current_email t |> Option.map (fun e -> "mailto:" ^ e)
182
+
) ~some:Option.some
183
+
184
+
(* Modification *)
185
+
let add_feed t feed =
186
+
{ t with feeds = Some (feed :: Option.value t.feeds ~default:[]) }
187
+
188
+
let remove_feed t url =
189
+
{ t with feeds = Option.map (List.filter (fun f -> Sortal_feed.url f <> url)) t.feeds }
190
+
191
+
(* Comparison *)
192
+
let compare a b = String.compare a.handle b.handle
193
+
194
+
(* Type conversions *)
195
+
let contact_kind_to_string = function
196
+
| Person -> "person"
197
+
| Organization -> "organization"
198
+
| Group -> "group"
199
+
| Role -> "role"
200
+
201
+
let contact_kind_of_string = function
202
+
| "person" -> Some Person
203
+
| "organization" -> Some Organization
204
+
| "group" -> Some Group
205
+
| "role" -> Some Role
206
+
| _ -> None
207
+
208
+
let service_kind_to_string = function
209
+
| ActivityPub -> "activitypub"
210
+
| Github -> "github"
211
+
| Git -> "git"
212
+
| Social -> "social"
213
+
| Photo -> "photo"
214
+
| Custom s -> s
215
+
216
+
let service_kind_of_string s =
217
+
match String.lowercase_ascii s with
218
+
| "activitypub" -> Some ActivityPub
219
+
| "github" -> Some Github
220
+
| "git" -> Some Git
221
+
| "social" -> Some Social
222
+
| "photo" -> Some Photo
223
+
| "" | "custom" -> None
224
+
| _ -> Some (Custom s)
225
+
226
+
let email_type_to_string = function
227
+
| Work -> "work"
228
+
| Personal -> "personal"
229
+
| Other -> "other"
230
+
231
+
let email_type_of_string = function
232
+
| "work" -> Some Work
233
+
| "personal" -> Some Personal
234
+
| "other" -> Some Other
235
+
| _ -> None
236
+
237
+
(* JSON encoding *)
238
+
239
+
(* Helper: case-insensitive enum decoder *)
240
+
let case_insensitive_enum ~kind:kind_name cases =
241
+
let open Jsont in
242
+
let lowercase_cases = List.map (fun (s, v) -> (String.lowercase_ascii s, v)) cases in
243
+
let dec s =
244
+
match List.assoc_opt (String.lowercase_ascii s) lowercase_cases with
245
+
| Some v -> v
246
+
| None -> failwith ("unknown " ^ kind_name ^ ": " ^ s)
247
+
in
248
+
let enc v =
249
+
match List.find_opt (fun (_, v') -> v = v') cases with
250
+
| Some (s, _) -> s
251
+
| None -> failwith ("invalid " ^ kind_name)
252
+
in
253
+
let t = map ~kind:kind_name ~dec ~enc string in
254
+
t
255
+
256
+
let contact_kind_json =
257
+
case_insensitive_enum ~kind:"ContactKind" [
258
+
"person", Person;
259
+
"organization", Organization;
260
+
"group", Group;
261
+
"role", Role;
262
+
]
263
+
264
+
let service_json : service Jsont.t =
265
+
let open Jsont in
266
+
let open Jsont.Object in
267
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
268
+
(* Convert string option to/from service_kind option *)
269
+
let dec_kind_opt kind_str =
270
+
match kind_str with
271
+
| None -> None
272
+
| Some s -> service_kind_of_string s
273
+
in
274
+
let enc_kind_opt = Option.map service_kind_to_string in
275
+
let make url kind_str handle label range primary : service =
276
+
let kind = dec_kind_opt kind_str in
277
+
{ url; kind; handle; label; range; primary }
278
+
in
279
+
map ~kind:"Service" make
280
+
|> mem "url" string ~enc:(fun (s : service) -> s.url)
281
+
|> mem_opt "kind" (some string) ~enc:(fun (s : service) -> enc_kind_opt s.kind)
282
+
|> mem_opt "handle" (some string) ~enc:(fun (s : service) -> s.handle)
283
+
|> mem_opt "label" (some string) ~enc:(fun (s : service) -> s.label)
284
+
|> mem_opt "range" (some Sortal_temporal.json_t) ~enc:(fun (s : service) -> s.range)
285
+
|> mem "primary" bool ~dec_absent:false ~enc:(fun (s : service) -> s.primary)
286
+
|> finish
287
+
288
+
let email_type_json =
289
+
case_insensitive_enum ~kind:"EmailType" [
290
+
"work", Work;
291
+
"personal", Personal;
292
+
"other", Other;
293
+
]
294
+
295
+
let email_json : email Jsont.t =
296
+
let open Jsont in
297
+
let open Jsont.Object in
298
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
299
+
let make address type_ range note : email = { address; type_; range; note } in
300
+
map ~kind:"Email" make
301
+
|> mem "address" string ~enc:(fun (e : email) -> e.address)
302
+
|> mem_opt "type" (some email_type_json) ~enc:(fun (e : email) -> e.type_)
303
+
|> mem_opt "range" (some Sortal_temporal.json_t) ~enc:(fun (e : email) -> e.range)
304
+
|> mem_opt "note" (some string) ~enc:(fun (e : email) -> e.note)
305
+
|> finish
306
+
307
+
let organization_json : organization Jsont.t =
308
+
let open Jsont in
309
+
let open Jsont.Object in
310
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
311
+
let make name title department range email url : organization =
312
+
{ name; title; department; range; email; url }
313
+
in
314
+
map ~kind:"Organization" make
315
+
|> mem "name" string ~enc:(fun (o : organization) -> o.name)
316
+
|> mem_opt "title" (some string) ~enc:(fun (o : organization) -> o.title)
317
+
|> mem_opt "department" (some string) ~enc:(fun (o : organization) -> o.department)
318
+
|> mem_opt "range" (some Sortal_temporal.json_t) ~enc:(fun (o : organization) -> o.range)
319
+
|> mem_opt "email" (some string) ~enc:(fun (o : organization) -> o.email)
320
+
|> mem_opt "url" (some string) ~enc:(fun (o : organization) -> o.url)
321
+
|> finish
322
+
323
+
let url_entry_json : url_entry Jsont.t =
324
+
let open Jsont in
325
+
let open Jsont.Object in
326
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
327
+
let make url label range : url_entry = { url; label; range } in
328
+
map ~kind:"URL" make
329
+
|> mem "url" string ~enc:(fun (u : url_entry) -> u.url)
330
+
|> mem_opt "label" (some string) ~enc:(fun (u : url_entry) -> u.label)
331
+
|> mem_opt "range" (some Sortal_temporal.json_t) ~enc:(fun (u : url_entry) -> u.range)
332
+
|> finish
333
+
334
+
let json_t =
335
+
let open Jsont in
336
+
let open Jsont.Object in
337
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
338
+
let make version kind handle names emails organizations urls services
339
+
icon thumbnail orcid feeds =
340
+
if version <> 1 then
341
+
failwith (Printf.sprintf "Unsupported contact schema version: %d" version);
342
+
{ version; kind; handle; names; emails; organizations; urls; services;
343
+
icon; thumbnail; orcid; feeds }
344
+
in
345
+
map ~kind:"Contact" make
346
+
|> mem "version" int ~enc:(fun _ -> 1)
347
+
|> mem "kind" contact_kind_json ~dec_absent:Person ~enc:(fun c -> c.kind)
348
+
|> mem "handle" string ~enc:(fun c -> c.handle)
349
+
|> mem "names" (list string) ~dec_absent:[] ~enc:(fun c -> c.names)
350
+
|> mem "emails" (list email_json) ~dec_absent:[] ~enc:(fun c -> c.emails)
351
+
|> mem "organizations" (list organization_json) ~dec_absent:[] ~enc:(fun c -> c.organizations)
352
+
|> mem "urls" (list url_entry_json) ~dec_absent:[] ~enc:(fun c -> c.urls)
353
+
|> mem "services" (list service_json) ~dec_absent:[] ~enc:(fun c -> c.services)
354
+
|> mem_opt "icon" (some string) ~enc:(fun c -> c.icon)
355
+
|> mem_opt "thumbnail" (some string) ~enc:(fun c -> c.thumbnail)
356
+
|> mem_opt "orcid" (some string) ~enc:(fun c -> c.orcid)
357
+
|> mem_opt "feeds" (some (list Sortal_feed.json_t)) ~enc:(fun c -> c.feeds)
358
+
|> finish
359
+
360
+
(* Pretty printing *)
361
+
let pp ppf t =
362
+
let open Fmt in
363
+
let label = styled (`Fg `Cyan) string in
364
+
let url_style = styled (`Fg `Blue) in
365
+
let date_style = styled (`Fg `Green) in
366
+
let field lbl fmt_v = Option.iter (fun v -> pf ppf "%a: %a@," label lbl fmt_v v) in
367
+
368
+
let pp_range ppf = function
369
+
| None -> ()
370
+
| Some { Sortal_temporal.from; until } ->
371
+
match from, until with
372
+
| Some f, Some u -> pf ppf " %a" (date_style string) (Printf.sprintf "[%s to %s]" f u)
373
+
| Some f, None -> pf ppf " %a" (date_style string) (Printf.sprintf "[from %s]" f)
374
+
| None, Some u -> pf ppf " %a" (date_style string) (Printf.sprintf "[until %s]" u)
375
+
| None, None -> ()
376
+
in
377
+
378
+
pf ppf "@[<v>";
379
+
pf ppf "%a: %a@," label "Handle" (styled `Bold (fun ppf s -> pf ppf "@%s" s)) t.handle;
380
+
381
+
(* Show kind if not a person *)
382
+
(match t.kind with
383
+
| Person -> ()
384
+
| k -> pf ppf "%a: %a@," label "Kind" (styled (`Fg `Magenta) string) (contact_kind_to_string k));
385
+
386
+
pf ppf "%a: %a@," label "Name" (styled `Bold string) (name t);
387
+
388
+
if List.length (names t) > 1 then
389
+
pf ppf "%a: @[<h>%a@]@," label "Aliases"
390
+
(list ~sep:comma string) (List.tl (names t));
391
+
392
+
(* Emails with temporal info *)
393
+
if emails t <> [] then begin
394
+
pf ppf "%a:@," label "Emails";
395
+
List.iter (fun e ->
396
+
pf ppf " %a%s%s%a%a@,"
397
+
(styled (`Fg `Yellow) string) e.address
398
+
(match e.type_ with Some Work -> " (work)" | Some Personal -> " (personal)" | Some Other -> " (other)" | None -> "")
399
+
(match e.note with Some n -> " - " ^ n | None -> "")
400
+
pp_range e.range
401
+
(fun ppf current -> if current then pf ppf " %a" (styled (`Fg `Magenta) string) "[current]" else ())
402
+
(Sortal_temporal.is_current e.range)
403
+
) (emails t)
404
+
end;
405
+
406
+
(* Organizations with temporal info *)
407
+
if organizations t <> [] then begin
408
+
pf ppf "%a:@," label "Organizations";
409
+
List.iter (fun o ->
410
+
pf ppf " %a" (styled `Bold string) o.name;
411
+
Option.iter (fun title -> pf ppf " - %s" title) o.title;
412
+
Option.iter (fun dept -> pf ppf " (%s)" dept) o.department;
413
+
pf ppf "%a" pp_range o.range;
414
+
if Sortal_temporal.is_current o.range then
415
+
pf ppf " %a" (styled (`Fg `Magenta) string) "[current]";
416
+
pf ppf "@,";
417
+
Option.iter (fun email -> pf ppf " Email: %a@," (styled (`Fg `Yellow) string) email) o.email;
418
+
Option.iter (fun url -> pf ppf " URL: %a@," (url_style string) url) o.url;
419
+
) (organizations t)
420
+
end;
421
+
422
+
(* URLs *)
423
+
if urls t <> [] then begin
424
+
pf ppf "%a:@," label "URLs";
425
+
List.iter (fun u ->
426
+
pf ppf " %a" (url_style string) u.url;
427
+
Option.iter (fun lbl -> pf ppf " (%s)" lbl) u.label;
428
+
pf ppf "%a" pp_range u.range;
429
+
if Sortal_temporal.is_current u.range then
430
+
pf ppf " %a" (styled (`Fg `Magenta) string) "[current]";
431
+
pf ppf "@,"
432
+
) (urls t)
433
+
end;
434
+
435
+
(* Services *)
436
+
if services t <> [] then begin
437
+
pf ppf "%a:@," label "Services";
438
+
List.iter (fun (s : service) ->
439
+
pf ppf " %a" (url_style string) s.url;
440
+
Option.iter (fun k -> pf ppf " (%s)" (service_kind_to_string k)) s.kind;
441
+
Option.iter (fun h -> pf ppf " [@%s]" h) s.handle;
442
+
Option.iter (fun lbl -> pf ppf " - %s" lbl) s.label;
443
+
pf ppf "%a" pp_range s.range;
444
+
if s.primary then pf ppf " %a" (styled (`Fg `Yellow) string) "[primary]";
445
+
if Sortal_temporal.is_current s.range then
446
+
pf ppf " %a" (styled (`Fg `Magenta) string) "[current]";
447
+
pf ppf "@,"
448
+
) (services t)
449
+
end;
450
+
451
+
field "ORCID" (url_style (fun ppf o -> pf ppf "https://orcid.org/%s" o)) t.orcid;
452
+
453
+
field "Icon" (url_style string) t.icon;
454
+
field "Thumbnail" (styled (`Fg `White) string) t.thumbnail;
455
+
456
+
Option.iter (function
457
+
| [] -> ()
458
+
| feeds ->
459
+
pf ppf "%a:@," label "Feeds";
460
+
List.iter (fun feed -> pf ppf " - %a@," Sortal_feed.pp feed) feeds
461
+
) t.feeds;
462
+
463
+
pf ppf "@]"
+272
lib/sortal_contact_v1.mli
+272
lib/sortal_contact_v1.mli
···
1
+
(** Contact schema V1 with temporal support.
2
+
3
+
This module defines the V1 contact schema with support for time-bounded
4
+
information such as emails and organizations that are valid only during
5
+
specific periods.
6
+
7
+
{b Schema Version Policy:}
8
+
- New optional fields can be added without bumping the version
9
+
- The version must be bumped only if the {i meaning} of an existing
10
+
field changes
11
+
- This allows forward compatibility: older readers can ignore new fields *)
12
+
13
+
(** {1 Schema Version} *)
14
+
15
+
val version : int
16
+
(** The schema version number for V1. Currently [1]. *)
17
+
18
+
(** {1 Types} *)
19
+
20
+
(** Contact kind - what type of entity this represents. *)
21
+
type contact_kind =
22
+
| Person (** Individual person *)
23
+
| Organization (** Company, lab, department *)
24
+
| Group (** Research group, project team *)
25
+
| Role (** Generic role email like info@, admin@ *)
26
+
27
+
(** Service kind - categorization of online presence. *)
28
+
type service_kind =
29
+
| ActivityPub (** Mastodon, Pixelfed, PeerTube, etc *)
30
+
| Github (** GitHub *)
31
+
| Git (** GitLab, Gitea, Codeberg, etc *)
32
+
| Social (** Twitter/X, LinkedIn, etc *)
33
+
| Photo (** Immich, Flickr, Instagram, etc *)
34
+
| Custom of string (** Other service types *)
35
+
36
+
(** An online service/identity. *)
37
+
type service = {
38
+
url: string; (** Full URL (primary identifier) *)
39
+
kind: service_kind option; (** Optional service categorization *)
40
+
handle: string option; (** Optional short handle/username *)
41
+
label: string option; (** Human description: "Cambridge GitLab", "Work account" *)
42
+
range: Sortal_temporal.range option; (** Temporal validity *)
43
+
primary: bool; (** Is this the primary/preferred service of its kind? *)
44
+
}
45
+
46
+
type email_type = Work | Personal | Other
47
+
48
+
type email = {
49
+
address: string;
50
+
type_: email_type option;
51
+
range: Sortal_temporal.range option; (** Validity period *)
52
+
note: string option; (** Context note, e.g., "NetApp position" *)
53
+
}
54
+
55
+
type organization = {
56
+
name: string;
57
+
title: string option;
58
+
department: string option;
59
+
range: Sortal_temporal.range option; (** Employment period *)
60
+
email: string option; (** Work email during this period *)
61
+
url: string option; (** Work homepage during this period *)
62
+
}
63
+
64
+
type url_entry = {
65
+
url: string;
66
+
label: string option; (** Human-readable label *)
67
+
range: Sortal_temporal.range option; (** Validity period *)
68
+
}
69
+
70
+
type t = {
71
+
version: int; (** Schema version (always 1 for V1) *)
72
+
kind: contact_kind; (** Type of entity (Person, Organization, etc) *)
73
+
handle: string; (** Unique identifier *)
74
+
names: string list; (** Names, first is primary *)
75
+
76
+
(* Temporal fields *)
77
+
emails: email list; (** Email addresses with temporal validity *)
78
+
organizations: organization list; (** Employment/affiliation history *)
79
+
urls: url_entry list; (** URLs with optional temporal validity *)
80
+
services: service list; (** Online services/identities *)
81
+
82
+
(* Simple fields - rarely change over time *)
83
+
icon: string option; (** Avatar URL *)
84
+
thumbnail: string option; (** Local thumbnail path *)
85
+
orcid: string option; (** ORCID identifier *)
86
+
87
+
(* Other *)
88
+
feeds: Sortal_feed.t list option; (** Feed subscriptions *)
89
+
}
90
+
91
+
(** {1 Construction} *)
92
+
93
+
(** [make ~handle ~names ?kind ?emails ?organizations ?urls ?services
94
+
?icon ?thumbnail ?orcid ?feeds ()]
95
+
creates a new V1 contact.
96
+
97
+
The [version] field is automatically set to [1].
98
+
The [kind] defaults to [Person] if not specified. *)
99
+
val make :
100
+
handle:string ->
101
+
names:string list ->
102
+
?kind:contact_kind ->
103
+
?emails:email list ->
104
+
?organizations:organization list ->
105
+
?urls:url_entry list ->
106
+
?services:service list ->
107
+
?icon:string ->
108
+
?thumbnail:string ->
109
+
?orcid:string ->
110
+
?feeds:Sortal_feed.t list ->
111
+
unit ->
112
+
t
113
+
114
+
(** {1 Email Helpers} *)
115
+
116
+
(** [make_email ?type_ ?from ?until ?note address] creates an email entry.
117
+
118
+
@param type_ Email type (Work, Personal, Other)
119
+
@param from Start date of validity
120
+
@param until End date of validity (exclusive)
121
+
@param note Contextual note *)
122
+
val make_email :
123
+
?type_:email_type ->
124
+
?from:Sortal_temporal.date ->
125
+
?until:Sortal_temporal.date ->
126
+
?note:string ->
127
+
string ->
128
+
email
129
+
130
+
(** [email_of_string s] creates a simple always-valid personal email. *)
131
+
val email_of_string : string -> email
132
+
133
+
(** {1 Organization Helpers} *)
134
+
135
+
(** [make_org ?title ?department ?from ?until ?email ?url name]
136
+
creates an organization entry. *)
137
+
val make_org :
138
+
?title:string ->
139
+
?department:string ->
140
+
?from:Sortal_temporal.date ->
141
+
?until:Sortal_temporal.date ->
142
+
?email:string ->
143
+
?url:string ->
144
+
string ->
145
+
organization
146
+
147
+
(** {1 URL Helpers} *)
148
+
149
+
(** [make_url ?label ?from ?until url] creates a URL entry. *)
150
+
val make_url :
151
+
?label:string ->
152
+
?from:Sortal_temporal.date ->
153
+
?until:Sortal_temporal.date ->
154
+
string ->
155
+
url_entry
156
+
157
+
(** [url_of_string s] creates a simple always-valid URL. *)
158
+
val url_of_string : string -> url_entry
159
+
160
+
(** {1 Service Helpers} *)
161
+
162
+
(** [make_service ?kind ?handle ?label ?from ?until ?primary url]
163
+
creates a service entry.
164
+
165
+
@param kind Optional service categorization
166
+
@param handle Optional short handle/username
167
+
@param label Optional description (e.g., "Work account", "Cambridge GitLab")
168
+
@param from Start date of validity
169
+
@param until End date of validity (exclusive)
170
+
@param primary Whether this is the primary service of its kind
171
+
@param url Full URL to the service (required) *)
172
+
val make_service :
173
+
?kind:service_kind ->
174
+
?handle:string ->
175
+
?label:string ->
176
+
?from:Sortal_temporal.date ->
177
+
?until:Sortal_temporal.date ->
178
+
?primary:bool ->
179
+
string ->
180
+
service
181
+
182
+
(** [service_of_url url] creates a simple always-valid service from just a URL. *)
183
+
val service_of_url : string -> service
184
+
185
+
(** {1 Accessors} *)
186
+
187
+
val version_of : t -> int
188
+
val kind : t -> contact_kind
189
+
val handle : t -> string
190
+
val names : t -> string list
191
+
val name : t -> string
192
+
val primary_name : t -> string
193
+
val emails : t -> email list
194
+
val organizations : t -> organization list
195
+
val urls : t -> url_entry list
196
+
val services : t -> service list
197
+
val icon : t -> string option
198
+
val thumbnail : t -> string option
199
+
val orcid : t -> string option
200
+
val feeds : t -> Sortal_feed.t list option
201
+
202
+
(** {1 Temporal Queries} *)
203
+
204
+
(** [email_at t ~date] returns the primary email valid at [date]. *)
205
+
val email_at : t -> date:Sortal_temporal.date -> string option
206
+
207
+
(** [emails_at t ~date] returns all emails valid at [date]. *)
208
+
val emails_at : t -> date:Sortal_temporal.date -> email list
209
+
210
+
(** [current_email t] returns the current primary email. *)
211
+
val current_email : t -> string option
212
+
213
+
(** [organization_at t ~date] returns the organization at [date]. *)
214
+
val organization_at : t -> date:Sortal_temporal.date -> organization option
215
+
216
+
(** [current_organization t] returns the current organization. *)
217
+
val current_organization : t -> organization option
218
+
219
+
(** [url_at t ~date] returns the primary URL valid at [date]. *)
220
+
val url_at : t -> date:Sortal_temporal.date -> string option
221
+
222
+
(** [current_url t] returns the current primary URL. *)
223
+
val current_url : t -> string option
224
+
225
+
(** [all_email_addresses t] returns all email addresses (any period). *)
226
+
val all_email_addresses : t -> string list
227
+
228
+
(** [best_url t] returns the best available URL (current URL or service fallback). *)
229
+
val best_url : t -> string option
230
+
231
+
(** {1 Service Queries} *)
232
+
233
+
(** [services_of_kind t kind] returns all services matching the given kind. *)
234
+
val services_of_kind : t -> service_kind -> service list
235
+
236
+
(** [services_at t ~date] returns all services valid at [date]. *)
237
+
val services_at : t -> date:Sortal_temporal.date -> service list
238
+
239
+
(** [current_services t] returns all currently valid services. *)
240
+
val current_services : t -> service list
241
+
242
+
(** [primary_service t kind] returns the primary service of the given kind. *)
243
+
val primary_service : t -> service_kind -> service option
244
+
245
+
(** {1 Modification} *)
246
+
247
+
val add_feed : t -> Sortal_feed.t -> t
248
+
val remove_feed : t -> string -> t
249
+
250
+
(** {1 Comparison and Display} *)
251
+
252
+
val compare : t -> t -> int
253
+
val pp : Format.formatter -> t -> unit
254
+
255
+
(** {1 JSON Encoding} *)
256
+
257
+
(** [json_t] is the jsont encoder/decoder for V1 contacts.
258
+
259
+
The schema includes a [version] field that is always encoded and
260
+
must equal [1] when decoded. *)
261
+
val json_t : t Jsont.t
262
+
263
+
(** {1 Type Utilities} *)
264
+
265
+
val contact_kind_to_string : contact_kind -> string
266
+
val contact_kind_of_string : string -> contact_kind option
267
+
268
+
val service_kind_to_string : service_kind -> string
269
+
val service_kind_of_string : string -> service_kind option
270
+
271
+
val email_type_to_string : email_type -> string
272
+
val email_type_of_string : string -> email_type option
+2
-1
lib/sortal_feed.ml
+2
-1
lib/sortal_feed.ml
+226
lib/sortal_git_store.ml
+226
lib/sortal_git_store.ml
···
1
+
type t = {
2
+
store : Sortal_store.t;
3
+
env : Eio_unix.Stdenv.base;
4
+
}
5
+
6
+
let create store env = { store; env }
7
+
8
+
let store t = t.store
9
+
10
+
(* Helper to check if a string contains a substring *)
11
+
let contains_substring ~needle haystack =
12
+
try
13
+
let _ = Str.search_forward (Str.regexp_string needle) haystack 0 in
14
+
true
15
+
with Not_found -> false
16
+
17
+
(* Helper to get the data directory path as a native string *)
18
+
let data_dir_path t =
19
+
(* We need to extract the data directory from the store somehow.
20
+
For now, we'll use the XDG environment to locate it. *)
21
+
let xdg = Xdge.create t.env#fs "sortal" in
22
+
let data_path = Xdge.data_dir xdg in
23
+
Eio.Path.native_exn data_path
24
+
25
+
(* Execute a git command in the data directory *)
26
+
let run_git t args =
27
+
let data_dir = data_dir_path t in
28
+
Eio.Switch.run @@ fun sw ->
29
+
try
30
+
let mgr = t.env#process_mgr in
31
+
let cmd = ["git"; "-C"; data_dir] @ args in
32
+
let proc = Eio.Process.spawn ~sw mgr cmd in
33
+
match Eio.Process.await proc with
34
+
| `Exited 0 -> Ok ()
35
+
| `Exited n -> Error (Printf.sprintf "git %s exited with code %d" (String.concat " " args) n)
36
+
| `Signaled n -> Error (Printf.sprintf "git killed by signal %d" n)
37
+
with
38
+
| exn ->
39
+
let msg = Printexc.to_string exn in
40
+
if contains_substring ~needle:"not found" msg ||
41
+
contains_substring ~needle:"No such file" msg then
42
+
Error "git executable not found - please install git"
43
+
else
44
+
Error (Printf.sprintf "git command failed: %s" msg)
45
+
46
+
let is_initialized t =
47
+
let data_dir = data_dir_path t in
48
+
let git_dir = Filename.concat data_dir ".git" in
49
+
Sys.file_exists git_dir && Sys.is_directory git_dir
50
+
51
+
let init t =
52
+
if is_initialized t then
53
+
Ok ()
54
+
else begin
55
+
match run_git t ["init"] with
56
+
| Error _ as e -> e
57
+
| Ok () ->
58
+
(* Create initial commit *)
59
+
match run_git t ["add"; "."] with
60
+
| Error _ as e -> e
61
+
| Ok () ->
62
+
let msg = "Initialize sortal contact database" in
63
+
run_git t ["commit"; "--allow-empty"; "-m"; msg]
64
+
end
65
+
66
+
(* Helper to commit a file with a message *)
67
+
let commit_file t filename msg =
68
+
match run_git t ["add"; filename] with
69
+
| Error _ as e -> e
70
+
| Ok () ->
71
+
run_git t ["commit"; "-m"; msg]
72
+
73
+
(* Helper to commit a deletion *)
74
+
let commit_deletion t filename msg =
75
+
match run_git t ["rm"; filename] with
76
+
| Error _ as e -> e
77
+
| Ok () ->
78
+
run_git t ["commit"; "-m"; msg]
79
+
80
+
let save t contact =
81
+
let handle = Sortal_contact.handle contact in
82
+
let name = Sortal_contact.name contact in
83
+
let filename = handle ^ ".yaml" in
84
+
85
+
(* Check if contact already exists *)
86
+
let is_new = match Sortal_store.lookup t.store handle with
87
+
| None -> true
88
+
| Some _ -> false
89
+
in
90
+
91
+
(* Save to store *)
92
+
Sortal_store.save t.store contact;
93
+
94
+
(* Commit to git *)
95
+
if not (is_initialized t) then
96
+
Ok ()
97
+
else
98
+
let msg = if is_new then
99
+
Printf.sprintf "Add contact @%s (%s)" handle name
100
+
else
101
+
Printf.sprintf "Update contact @%s (%s)" handle name
102
+
in
103
+
commit_file t filename msg
104
+
105
+
let delete t handle =
106
+
match Sortal_store.lookup t.store handle with
107
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
108
+
| Some contact ->
109
+
let name = Sortal_contact.name contact in
110
+
let filename = handle ^ ".yaml" in
111
+
112
+
(* Delete from store *)
113
+
Sortal_store.delete t.store handle;
114
+
115
+
(* Commit deletion to git *)
116
+
if not (is_initialized t) then
117
+
Ok ()
118
+
else
119
+
let msg = Printf.sprintf "Delete contact @%s (%s)" handle name in
120
+
commit_deletion t filename msg
121
+
122
+
let update_contact t handle f ~msg =
123
+
match Sortal_store.update_contact t.store handle f with
124
+
| Error _ as e -> e
125
+
| Ok () ->
126
+
if not (is_initialized t) then
127
+
Ok ()
128
+
else
129
+
let filename = handle ^ ".yaml" in
130
+
commit_file t filename msg
131
+
132
+
let add_email t handle (email : Sortal_contact_v1.email) =
133
+
let msg = Printf.sprintf "Update @%s: add email %s"
134
+
handle email.address in
135
+
match Sortal_store.add_email t.store handle email with
136
+
| Error _ as e -> e
137
+
| Ok () ->
138
+
if not (is_initialized t) then
139
+
Ok ()
140
+
else
141
+
let filename = handle ^ ".yaml" in
142
+
commit_file t filename msg
143
+
144
+
let remove_email t handle address =
145
+
let msg = Printf.sprintf "Update @%s: remove email %s" handle address in
146
+
match Sortal_store.remove_email t.store handle address with
147
+
| Error _ as e -> e
148
+
| Ok () ->
149
+
if not (is_initialized t) then
150
+
Ok ()
151
+
else
152
+
let filename = handle ^ ".yaml" in
153
+
commit_file t filename msg
154
+
155
+
let add_service t handle (service : Sortal_contact_v1.service) =
156
+
let kind_str = match service.kind with
157
+
| Some k -> Sortal_contact.service_kind_to_string k
158
+
| None -> "unknown"
159
+
in
160
+
let msg = Printf.sprintf "Update @%s: add service %s (%s)"
161
+
handle kind_str service.url in
162
+
match Sortal_store.add_service t.store handle service with
163
+
| Error _ as e -> e
164
+
| Ok () ->
165
+
if not (is_initialized t) then
166
+
Ok ()
167
+
else
168
+
let filename = handle ^ ".yaml" in
169
+
commit_file t filename msg
170
+
171
+
let remove_service t handle url =
172
+
let msg = Printf.sprintf "Update @%s: remove service %s" handle url in
173
+
match Sortal_store.remove_service t.store handle url with
174
+
| Error _ as e -> e
175
+
| Ok () ->
176
+
if not (is_initialized t) then
177
+
Ok ()
178
+
else
179
+
let filename = handle ^ ".yaml" in
180
+
commit_file t filename msg
181
+
182
+
let add_organization t handle (org : Sortal_contact_v1.organization) =
183
+
let msg = Printf.sprintf "Update @%s: add organization %s"
184
+
handle org.name in
185
+
match Sortal_store.add_organization t.store handle org with
186
+
| Error _ as e -> e
187
+
| Ok () ->
188
+
if not (is_initialized t) then
189
+
Ok ()
190
+
else
191
+
let filename = handle ^ ".yaml" in
192
+
commit_file t filename msg
193
+
194
+
let remove_organization t handle name =
195
+
let msg = Printf.sprintf "Update @%s: remove organization %s" handle name in
196
+
match Sortal_store.remove_organization t.store handle name with
197
+
| Error _ as e -> e
198
+
| Ok () ->
199
+
if not (is_initialized t) then
200
+
Ok ()
201
+
else
202
+
let filename = handle ^ ".yaml" in
203
+
commit_file t filename msg
204
+
205
+
let add_url t handle (url_entry : Sortal_contact_v1.url_entry) =
206
+
let msg = Printf.sprintf "Update @%s: add URL %s"
207
+
handle url_entry.url in
208
+
match Sortal_store.add_url t.store handle url_entry with
209
+
| Error _ as e -> e
210
+
| Ok () ->
211
+
if not (is_initialized t) then
212
+
Ok ()
213
+
else
214
+
let filename = handle ^ ".yaml" in
215
+
commit_file t filename msg
216
+
217
+
let remove_url t handle url =
218
+
let msg = Printf.sprintf "Update @%s: remove URL %s" handle url in
219
+
match Sortal_store.remove_url t.store handle url with
220
+
| Error _ as e -> e
221
+
| Ok () ->
222
+
if not (is_initialized t) then
223
+
Ok ()
224
+
else
225
+
let filename = handle ^ ".yaml" in
226
+
commit_file t filename msg
+109
lib/sortal_git_store.mli
+109
lib/sortal_git_store.mli
···
1
+
(** Git-backed contact store with automatic version control.
2
+
3
+
This module wraps {!Sortal_store} to provide automatic git versioning
4
+
of all contact modifications. Each change (add, update, delete) is
5
+
automatically committed to a git repository with descriptive commit
6
+
messages. *)
7
+
8
+
type t
9
+
(** A git-backed contact store. *)
10
+
11
+
(** {1 Creation and Initialization} *)
12
+
13
+
val create : Sortal_store.t -> Eio_unix.Stdenv.base -> t
14
+
(** [create store env] creates a git-backed store wrapping [store].
15
+
16
+
@param store The underlying contact store
17
+
@param env The Eio environment for spawning git processes *)
18
+
19
+
val init : t -> (unit, string) result
20
+
(** [init t] initializes a git repository in the data directory.
21
+
22
+
Creates a new git repository with an initial commit if one doesn't exist.
23
+
Safe to call multiple times - returns [Ok ()] if already initialized.
24
+
25
+
@return [Ok ()] if initialized successfully or already initialized,
26
+
[Error msg] if git initialization fails *)
27
+
28
+
val is_initialized : t -> bool
29
+
(** [is_initialized t] checks if the data directory is a git repository.
30
+
31
+
@return [true] if a .git directory exists, [false] otherwise *)
32
+
33
+
(** {1 Contact Operations} *)
34
+
35
+
val save : t -> Sortal_contact.t -> (unit, string) result
36
+
(** [save t contact] saves a contact and commits the change to git.
37
+
38
+
If the contact is new, commits with message "Add contact @handle (Name)".
39
+
If updating an existing contact, commits with "Update contact @handle (Name)".
40
+
41
+
@param contact The contact to save *)
42
+
43
+
val delete : t -> string -> (unit, string) result
44
+
(** [delete t handle] deletes a contact and commits the removal to git.
45
+
46
+
Commits with message "Delete contact @handle (Name)".
47
+
48
+
@param handle The contact handle to delete
49
+
@return [Error msg] if contact not found *)
50
+
51
+
(** {1 Contact Modification} *)
52
+
53
+
val add_email : t -> string -> Sortal_contact.email -> (unit, string) result
54
+
(** [add_email t handle email] adds an email to a contact and commits.
55
+
56
+
Commits with message "Update @handle: add email address@example.com". *)
57
+
58
+
val remove_email : t -> string -> string -> (unit, string) result
59
+
(** [remove_email t handle address] removes an email and commits.
60
+
61
+
Commits with message "Update @handle: remove email address@example.com". *)
62
+
63
+
val add_service : t -> string -> Sortal_contact.service -> (unit, string) result
64
+
(** [add_service t handle service] adds a service to a contact and commits.
65
+
66
+
Commits with message "Update @handle: add service Kind (url)". *)
67
+
68
+
val remove_service : t -> string -> string -> (unit, string) result
69
+
(** [remove_service t handle url] removes a service and commits.
70
+
71
+
Commits with message "Update @handle: remove service url". *)
72
+
73
+
val add_organization : t -> string -> Sortal_contact.organization -> (unit, string) result
74
+
(** [add_organization t handle org] adds an organization and commits.
75
+
76
+
Commits with message "Update @handle: add organization Org Name". *)
77
+
78
+
val remove_organization : t -> string -> string -> (unit, string) result
79
+
(** [remove_organization t handle name] removes an organization and commits.
80
+
81
+
Commits with message "Update @handle: remove organization Org Name". *)
82
+
83
+
val add_url : t -> string -> Sortal_contact.url_entry -> (unit, string) result
84
+
(** [add_url t handle url_entry] adds a URL and commits.
85
+
86
+
Commits with message "Update @handle: add URL url". *)
87
+
88
+
val remove_url : t -> string -> string -> (unit, string) result
89
+
(** [remove_url t handle url] removes a URL and commits.
90
+
91
+
Commits with message "Update @handle: remove URL url". *)
92
+
93
+
(** {1 Low-level Operations} *)
94
+
95
+
val update_contact : t -> string -> (Sortal_contact.t -> Sortal_contact.t) ->
96
+
msg:string -> (unit, string) result
97
+
(** [update_contact t handle f ~msg] updates a contact and commits with custom message.
98
+
99
+
This is a low-level function that applies transformation [f] to the contact
100
+
and commits with the provided commit message.
101
+
102
+
@param handle The contact handle
103
+
@param f Function to transform the contact
104
+
@param msg The git commit message *)
105
+
106
+
val store : t -> Sortal_store.t
107
+
(** [store t] returns the underlying contact store.
108
+
109
+
Use this when you need direct store access without git commits. *)
+236
-3
lib/sortal_store.ml
+236
-3
lib/sortal_store.ml
···
28
28
try
29
29
let yaml_str = Eio.Path.load path in
30
30
let reader = Bytesrw.Bytes.Reader.of_string yaml_str in
31
-
Yamlt.decode Sortal_contact.json_t reader
32
-
|> Result.to_option
33
-
with _ -> None
31
+
match Yamlt.decode Sortal_contact.json_t reader with
32
+
| Ok contact -> Some contact
33
+
| Error msg ->
34
+
Logs.warn (fun m -> m "Failed to decode contact %s: %s" handle msg);
35
+
None
36
+
with exn ->
37
+
Logs.warn (fun m -> m "Failed to load contact %s: %s" handle (Printexc.to_string exn));
38
+
None
34
39
35
40
let delete t handle =
36
41
let path = contact_file t handle in
···
39
44
with
40
45
| _ -> ()
41
46
47
+
(* Contact modification helpers *)
48
+
let update_contact t handle f =
49
+
match lookup t handle with
50
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
51
+
| Some contact ->
52
+
let updated = f contact in
53
+
save t updated;
54
+
Ok ()
55
+
56
+
let add_email t handle (email : Sortal_contact_v1.email) =
57
+
match lookup t handle with
58
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
59
+
| Some contact ->
60
+
let emails = Sortal_contact.emails contact in
61
+
(* Check for duplicate email address *)
62
+
if List.exists (fun (e : Sortal_contact_v1.email) -> e.address = email.address) emails then
63
+
Error (Printf.sprintf "Email %s already exists for contact @%s" email.address handle)
64
+
else
65
+
update_contact t handle (fun contact ->
66
+
let emails = Sortal_contact.emails contact in
67
+
Sortal_contact.make
68
+
~handle:(Sortal_contact.handle contact)
69
+
~names:(Sortal_contact.names contact)
70
+
~kind:(Sortal_contact.kind contact)
71
+
~emails:(emails @ [email])
72
+
~organizations:(Sortal_contact.organizations contact)
73
+
~urls:(Sortal_contact.urls contact)
74
+
~services:(Sortal_contact.services contact)
75
+
?icon:(Sortal_contact.icon contact)
76
+
?thumbnail:(Sortal_contact.thumbnail contact)
77
+
?orcid:(Sortal_contact.orcid contact)
78
+
?feeds:(Sortal_contact.feeds contact)
79
+
()
80
+
)
81
+
82
+
let remove_email t handle address =
83
+
update_contact t handle (fun contact ->
84
+
let emails = Sortal_contact.emails contact
85
+
|> List.filter (fun (e : Sortal_contact.email) -> e.address <> address) in
86
+
Sortal_contact.make
87
+
~handle:(Sortal_contact.handle contact)
88
+
~names:(Sortal_contact.names contact)
89
+
~kind:(Sortal_contact.kind contact)
90
+
~emails
91
+
~organizations:(Sortal_contact.organizations contact)
92
+
~urls:(Sortal_contact.urls contact)
93
+
~services:(Sortal_contact.services contact)
94
+
?icon:(Sortal_contact.icon contact)
95
+
?thumbnail:(Sortal_contact.thumbnail contact)
96
+
?orcid:(Sortal_contact.orcid contact)
97
+
?feeds:(Sortal_contact.feeds contact)
98
+
()
99
+
)
100
+
101
+
let add_service t handle (service : Sortal_contact_v1.service) =
102
+
match lookup t handle with
103
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
104
+
| Some contact ->
105
+
let services = Sortal_contact.services contact in
106
+
(* Check for duplicate service URL *)
107
+
if List.exists (fun (s : Sortal_contact_v1.service) -> s.url = service.url) services then
108
+
Error (Printf.sprintf "Service URL %s already exists for contact @%s" service.url handle)
109
+
else
110
+
update_contact t handle (fun contact ->
111
+
let services = Sortal_contact.services contact in
112
+
Sortal_contact.make
113
+
~handle:(Sortal_contact.handle contact)
114
+
~names:(Sortal_contact.names contact)
115
+
~kind:(Sortal_contact.kind contact)
116
+
~emails:(Sortal_contact.emails contact)
117
+
~organizations:(Sortal_contact.organizations contact)
118
+
~urls:(Sortal_contact.urls contact)
119
+
~services:(services @ [service])
120
+
?icon:(Sortal_contact.icon contact)
121
+
?thumbnail:(Sortal_contact.thumbnail contact)
122
+
?orcid:(Sortal_contact.orcid contact)
123
+
?feeds:(Sortal_contact.feeds contact)
124
+
()
125
+
)
126
+
127
+
let remove_service t handle url =
128
+
update_contact t handle (fun contact ->
129
+
let services = Sortal_contact.services contact
130
+
|> List.filter (fun (s : Sortal_contact.service) -> s.url <> url) in
131
+
Sortal_contact.make
132
+
~handle:(Sortal_contact.handle contact)
133
+
~names:(Sortal_contact.names contact)
134
+
~kind:(Sortal_contact.kind contact)
135
+
~emails:(Sortal_contact.emails contact)
136
+
~organizations:(Sortal_contact.organizations contact)
137
+
~urls:(Sortal_contact.urls contact)
138
+
~services
139
+
?icon:(Sortal_contact.icon contact)
140
+
?thumbnail:(Sortal_contact.thumbnail contact)
141
+
?orcid:(Sortal_contact.orcid contact)
142
+
?feeds:(Sortal_contact.feeds contact)
143
+
()
144
+
)
145
+
146
+
let add_organization t handle (org : Sortal_contact_v1.organization) =
147
+
match lookup t handle with
148
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
149
+
| Some contact ->
150
+
let orgs = Sortal_contact.organizations contact in
151
+
(* Check for exact duplicate organization (same name, title, and department) *)
152
+
let is_duplicate = List.exists (fun (o : Sortal_contact_v1.organization) ->
153
+
o.name = org.name &&
154
+
o.title = org.title &&
155
+
o.department = org.department
156
+
) orgs in
157
+
if is_duplicate then
158
+
Error (Printf.sprintf "Organization %s with the same title/department already exists for contact @%s" org.name handle)
159
+
else
160
+
update_contact t handle (fun contact ->
161
+
let orgs = Sortal_contact.organizations contact in
162
+
Sortal_contact.make
163
+
~handle:(Sortal_contact.handle contact)
164
+
~names:(Sortal_contact.names contact)
165
+
~kind:(Sortal_contact.kind contact)
166
+
~emails:(Sortal_contact.emails contact)
167
+
~organizations:(orgs @ [org])
168
+
~urls:(Sortal_contact.urls contact)
169
+
~services:(Sortal_contact.services contact)
170
+
?icon:(Sortal_contact.icon contact)
171
+
?thumbnail:(Sortal_contact.thumbnail contact)
172
+
?orcid:(Sortal_contact.orcid contact)
173
+
?feeds:(Sortal_contact.feeds contact)
174
+
()
175
+
)
176
+
177
+
let remove_organization t handle name =
178
+
update_contact t handle (fun contact ->
179
+
let orgs = Sortal_contact.organizations contact
180
+
|> List.filter (fun (o : Sortal_contact.organization) -> o.name <> name) in
181
+
Sortal_contact.make
182
+
~handle:(Sortal_contact.handle contact)
183
+
~names:(Sortal_contact.names contact)
184
+
~kind:(Sortal_contact.kind contact)
185
+
~emails:(Sortal_contact.emails contact)
186
+
~organizations:orgs
187
+
~urls:(Sortal_contact.urls contact)
188
+
~services:(Sortal_contact.services contact)
189
+
?icon:(Sortal_contact.icon contact)
190
+
?thumbnail:(Sortal_contact.thumbnail contact)
191
+
?orcid:(Sortal_contact.orcid contact)
192
+
?feeds:(Sortal_contact.feeds contact)
193
+
()
194
+
)
195
+
196
+
let add_url t handle (url_entry : Sortal_contact_v1.url_entry) =
197
+
match lookup t handle with
198
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
199
+
| Some contact ->
200
+
let urls = Sortal_contact.urls contact in
201
+
(* Check for duplicate URL *)
202
+
if List.exists (fun (u : Sortal_contact_v1.url_entry) -> u.url = url_entry.url) urls then
203
+
Error (Printf.sprintf "URL %s already exists for contact @%s" url_entry.url handle)
204
+
else
205
+
update_contact t handle (fun contact ->
206
+
let urls = Sortal_contact.urls contact in
207
+
Sortal_contact.make
208
+
~handle:(Sortal_contact.handle contact)
209
+
~names:(Sortal_contact.names contact)
210
+
~kind:(Sortal_contact.kind contact)
211
+
~emails:(Sortal_contact.emails contact)
212
+
~organizations:(Sortal_contact.organizations contact)
213
+
~urls:(urls @ [url_entry])
214
+
~services:(Sortal_contact.services contact)
215
+
?icon:(Sortal_contact.icon contact)
216
+
?thumbnail:(Sortal_contact.thumbnail contact)
217
+
?orcid:(Sortal_contact.orcid contact)
218
+
?feeds:(Sortal_contact.feeds contact)
219
+
()
220
+
)
221
+
222
+
let remove_url t handle url =
223
+
update_contact t handle (fun contact ->
224
+
let urls = Sortal_contact.urls contact
225
+
|> List.filter (fun (u : Sortal_contact.url_entry) -> u.url <> url) in
226
+
Sortal_contact.make
227
+
~handle:(Sortal_contact.handle contact)
228
+
~names:(Sortal_contact.names contact)
229
+
~kind:(Sortal_contact.kind contact)
230
+
~emails:(Sortal_contact.emails contact)
231
+
~organizations:(Sortal_contact.organizations contact)
232
+
~urls
233
+
~services:(Sortal_contact.services contact)
234
+
?icon:(Sortal_contact.icon contact)
235
+
?thumbnail:(Sortal_contact.thumbnail contact)
236
+
?orcid:(Sortal_contact.orcid contact)
237
+
?feeds:(Sortal_contact.feeds contact)
238
+
()
239
+
)
240
+
42
241
let list t =
43
242
try
44
243
let entries = Eio.Path.read_dir t.data_dir in
···
121
320
) (Sortal_contact.names c)
122
321
) all in
123
322
List.sort Sortal_contact.compare matches
323
+
324
+
let find_by_email_at t ~email ~date =
325
+
let all = list t in
326
+
List.find_opt (fun c ->
327
+
let emails_at_date = Sortal_contact.emails_at c ~date in
328
+
List.exists (fun e -> e.Sortal_contact_v1.address = email) emails_at_date
329
+
) all
330
+
331
+
let find_by_org t ~org ?from ?until () =
332
+
let org_lower = String.lowercase_ascii org in
333
+
let all = list t in
334
+
let matches = List.filter (fun c ->
335
+
let orgs : Sortal_contact_v1.organization list = Sortal_contact.organizations c in
336
+
let filtered_orgs = match from, until with
337
+
| None, None -> orgs
338
+
| _, _ -> Sortal_temporal.filter ~get:(fun (o : Sortal_contact_v1.organization) -> o.range)
339
+
~from ~until orgs
340
+
in
341
+
List.exists (fun (o : Sortal_contact_v1.organization) ->
342
+
contains_substring ~needle:org_lower
343
+
(String.lowercase_ascii o.name)
344
+
) filtered_orgs
345
+
) all in
346
+
List.sort Sortal_contact.compare matches
347
+
348
+
let list_at t ~date =
349
+
let all = list t in
350
+
List.filter (fun c ->
351
+
(* Contact is active if it has any email, org, or URL valid at date *)
352
+
let has_email = Sortal_contact.emails_at c ~date <> [] in
353
+
let has_org = Sortal_contact.organization_at c ~date <> None in
354
+
let has_url = Sortal_contact.url_at c ~date <> None in
355
+
has_email || has_org || has_url
356
+
) all
124
357
125
358
let pp ppf t =
126
359
let all = list t in
+126
-7
lib/sortal_store.mli
+126
-7
lib/sortal_store.mli
···
1
1
(** Contact store with XDG-compliant storage.
2
2
3
3
The contact store manages reading and writing contact metadata
4
-
using XDG-compliant storage locations. *)
4
+
using XDG-compliant storage locations. Contacts are stored as
5
+
YAML files (one per contact) using the handle as the filename. *)
5
6
6
7
type t
7
8
8
9
(** [create fs app_name] creates a new contact store.
9
10
10
11
The store will use XDG data directories for persistent storage
11
-
of contact metadata. Each contact is stored as a separate JSON
12
+
of contact metadata. Each contact is stored as a separate YAML
12
13
file named after its handle.
13
14
14
15
@param fs Eio filesystem for file operations
···
29
30
30
31
(** [save t contact] saves a contact to the store.
31
32
32
-
The contact is serialized to JSON and written to a file
33
-
named "handle.json" in the XDG data directory.
33
+
The contact is serialized to YAML and written to a file
34
+
named "handle.yaml" in the XDG data directory.
34
35
35
36
If a contact with the same handle already exists, it is overwritten. *)
36
37
val save : t -> Sortal_contact.t -> unit
37
38
38
39
(** [lookup t handle] retrieves a contact by handle.
39
40
40
-
Searches for a file named "handle.json" in the XDG data directory
41
+
Searches for a file named "handle.yaml" in the XDG data directory
41
42
and deserializes it if found.
42
43
43
44
@return [Some contact] if found, [None] if not found or deserialization fails *)
···
45
46
46
47
(** [delete t handle] removes a contact from the store.
47
48
48
-
Deletes the file "handle.json" from the XDG data directory.
49
+
Deletes the file "handle.yaml" from the XDG data directory.
49
50
Does nothing if the contact does not exist. *)
50
51
val delete : t -> string -> unit
51
52
53
+
(** {1 Contact Modification} *)
54
+
55
+
(** [add_email t handle email] adds an email to an existing contact.
56
+
57
+
@param t The store
58
+
@param handle The contact handle
59
+
@param email The email entry to add
60
+
@return [Ok ()] on success, [Error msg] if contact not found
61
+
@raise Failure if the contact cannot be saved *)
62
+
val add_email : t -> string -> Sortal_contact.email -> (unit, string) result
63
+
64
+
(** [remove_email t handle address] removes an email from a contact.
65
+
66
+
Removes all email entries with the given address.
67
+
68
+
@param t The store
69
+
@param handle The contact handle
70
+
@param address The email address to remove
71
+
@return [Ok ()] on success, [Error msg] if contact not found *)
72
+
val remove_email : t -> string -> string -> (unit, string) result
73
+
74
+
(** [add_service t handle service] adds a service to an existing contact.
75
+
76
+
@param t The store
77
+
@param handle The contact handle
78
+
@param service The service entry to add
79
+
@return [Ok ()] on success, [Error msg] if contact not found *)
80
+
val add_service : t -> string -> Sortal_contact.service -> (unit, string) result
81
+
82
+
(** [remove_service t handle url] removes a service from a contact.
83
+
84
+
Removes all service entries with the given URL.
85
+
86
+
@param t The store
87
+
@param handle The contact handle
88
+
@param url The service URL to remove
89
+
@return [Ok ()] on success, [Error msg] if contact not found *)
90
+
val remove_service : t -> string -> string -> (unit, string) result
91
+
92
+
(** [add_organization t handle org] adds an organization to an existing contact.
93
+
94
+
@param t The store
95
+
@param handle The contact handle
96
+
@param org The organization entry to add
97
+
@return [Ok ()] on success, [Error msg] if contact not found *)
98
+
val add_organization : t -> string -> Sortal_contact.organization -> (unit, string) result
99
+
100
+
(** [remove_organization t handle name] removes an organization from a contact.
101
+
102
+
Removes all organization entries with the given name.
103
+
104
+
@param t The store
105
+
@param handle The contact handle
106
+
@param name The organization name to remove
107
+
@return [Ok ()] on success, [Error msg] if contact not found *)
108
+
val remove_organization : t -> string -> string -> (unit, string) result
109
+
110
+
(** [add_url t handle url_entry] adds a URL to an existing contact.
111
+
112
+
@param t The store
113
+
@param handle The contact handle
114
+
@param url_entry The URL entry to add
115
+
@return [Ok ()] on success, [Error msg] if contact not found *)
116
+
val add_url : t -> string -> Sortal_contact.url_entry -> (unit, string) result
117
+
118
+
(** [remove_url t handle url] removes a URL from a contact.
119
+
120
+
Removes all URL entries with the given URL.
121
+
122
+
@param t The store
123
+
@param handle The contact handle
124
+
@param url The URL to remove
125
+
@return [Ok ()] on success, [Error msg] if contact not found *)
126
+
val remove_url : t -> string -> string -> (unit, string) result
127
+
128
+
(** [update_contact t handle f] updates a contact by applying function [f].
129
+
130
+
Looks up the contact, applies [f] to transform it, and saves the result.
131
+
132
+
@param t The store
133
+
@param handle The contact handle
134
+
@param f Function to transform the contact
135
+
@return [Ok ()] on success, [Error msg] if contact not found *)
136
+
val update_contact : t -> string -> (Sortal_contact.t -> Sortal_contact.t) -> (unit, string) result
137
+
52
138
(** [list t] returns all contacts in the store.
53
139
54
-
Scans the XDG data directory for all .json files and attempts
140
+
Scans the XDG data directory for all .yaml files and attempts
55
141
to deserialize them as contacts. Files that fail to parse are
56
142
silently skipped.
57
143
···
112
198
@param query The search query (case-insensitive)
113
199
@return A list of matching contacts, sorted by handle *)
114
200
val search_all : t -> string -> Sortal_contact.t list
201
+
202
+
(** {1 Temporal Queries} *)
203
+
204
+
(** [find_by_email_at t ~email ~date] finds a contact by email address at a specific date.
205
+
206
+
Searches for a contact that had the given email address valid at [date].
207
+
208
+
@param email Email address to search for
209
+
@param date ISO 8601 date string
210
+
@return The first matching contact, or [None] if not found *)
211
+
val find_by_email_at : t -> email:string -> date:Sortal_temporal.date ->
212
+
Sortal_contact.t option
213
+
214
+
(** [find_by_org t ~org ?from ?until ()] finds contacts who worked at an organization.
215
+
216
+
Searches for contacts whose organization records overlap with the given period.
217
+
If [from] and [until] are omitted, returns all contacts who ever worked there.
218
+
219
+
@param org Organization name (case-insensitive substring match)
220
+
@param from Start date of period to check (inclusive, optional)
221
+
@param until End date of period to check (exclusive, optional)
222
+
@return List of matching contacts, sorted by handle *)
223
+
val find_by_org : t -> org:string -> ?from:Sortal_temporal.date ->
224
+
?until:Sortal_temporal.date -> unit -> Sortal_contact.t list
225
+
226
+
(** [list_at t ~date] returns contacts that were active at a specific date.
227
+
228
+
A contact is considered active at a date if it has at least one
229
+
email, organization, or URL valid at that date.
230
+
231
+
@param date ISO 8601 date string
232
+
@return List of active contacts at that date *)
233
+
val list_at : t -> date:Sortal_temporal.date -> Sortal_contact.t list
115
234
116
235
(** {1 Utilities} *)
117
236
+87
lib/sortal_temporal.ml
+87
lib/sortal_temporal.ml
···
1
+
type date = string
2
+
3
+
type range = {
4
+
from: date option;
5
+
until: date option;
6
+
}
7
+
8
+
let make ?from ?until () = { from; until }
9
+
10
+
let always = { from = None; until = None }
11
+
12
+
(* Compare ISO 8601 dates lexicographically - works for YYYY, YYYY-MM, YYYY-MM-DD *)
13
+
let date_compare (d1 : date) (d2 : date) : int =
14
+
String.compare d1 d2
15
+
16
+
let date_gte d1 d2 = date_compare d1 d2 >= 0
17
+
18
+
let valid_at range_opt ~date =
19
+
match range_opt with
20
+
| None -> true (* No range = always valid *)
21
+
| Some { from; until } ->
22
+
let after_start = match from with
23
+
| None -> true
24
+
| Some f -> date_gte date f
25
+
in
26
+
let before_end = match until with
27
+
| None -> true
28
+
| Some u -> date_compare date u < 0 (* until is exclusive *)
29
+
in
30
+
after_start && before_end
31
+
32
+
let overlaps r1 r2 =
33
+
(* Two ranges overlap if neither ends before the other starts *)
34
+
let r1_starts_before_r2_ends = match r2.until with
35
+
| None -> true
36
+
| Some u2 -> match r1.from with
37
+
| None -> true
38
+
| Some f1 -> date_compare f1 u2 < 0
39
+
in
40
+
let r2_starts_before_r1_ends = match r1.until with
41
+
| None -> true
42
+
| Some u1 -> match r2.from with
43
+
| None -> true
44
+
| Some f2 -> date_compare f2 u1 < 0
45
+
in
46
+
r1_starts_before_r2_ends && r2_starts_before_r1_ends
47
+
48
+
let today () =
49
+
let open Unix in
50
+
let tm = localtime (time ()) in
51
+
Printf.sprintf "%04d-%02d-%02d"
52
+
(tm.tm_year + 1900)
53
+
(tm.tm_mon + 1)
54
+
tm.tm_mday
55
+
56
+
let is_current range_opt =
57
+
valid_at range_opt ~date:(today ())
58
+
59
+
let current ~get list =
60
+
(* Find first currently valid item, or first item without temporal bounds *)
61
+
let current_items = List.filter (fun item -> is_current (get item)) list in
62
+
match current_items with
63
+
| x :: _ -> Some x
64
+
| [] ->
65
+
(* No current items, try to find one without temporal bounds *)
66
+
List.find_opt (fun item -> get item = None) list
67
+
68
+
let at_date ~get ~date list =
69
+
List.filter (fun item -> valid_at (get item) ~date) list
70
+
71
+
let filter ~get ~from ~until list =
72
+
let query_range = { from; until } in
73
+
List.filter (fun item ->
74
+
match get item with
75
+
| None -> true (* Items without range match all queries *)
76
+
| Some r -> overlaps r query_range
77
+
) list
78
+
79
+
let json_t =
80
+
let open Jsont in
81
+
let open Jsont.Object in
82
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
83
+
let make_range from until = { from; until } in
84
+
map ~kind:"TemporalRange" make_range
85
+
|> mem_opt "from" (some string) ~enc:(fun r -> r.from)
86
+
|> mem_opt "until" (some string) ~enc:(fun r -> r.until)
87
+
|> finish
+76
lib/sortal_temporal.mli
+76
lib/sortal_temporal.mli
···
1
+
(** Temporal validity support for contact fields.
2
+
3
+
This module provides types and functions for managing time-bounded
4
+
information in contacts, such as emails valid only during certain
5
+
employment periods. *)
6
+
7
+
(** ISO 8601 date string.
8
+
9
+
Supports multiple granularities:
10
+
- Year: ["2001"]
11
+
- Year-Month: ["2001-01"]
12
+
- Full date: ["2001-01-15"]
13
+
14
+
For querying, partial dates are treated as inclusive ranges. *)
15
+
type date = string
16
+
17
+
(** A temporal range indicating validity period. *)
18
+
type range = {
19
+
from: date option; (** Start date (inclusive). [None] means from the beginning. *)
20
+
until: date option; (** End date (exclusive). [None] means continuing/indefinite. *)
21
+
}
22
+
23
+
(** {1 Range Construction} *)
24
+
25
+
(** [make ?from ?until ()] creates a temporal range. *)
26
+
val make : ?from:date -> ?until:date -> unit -> range
27
+
28
+
(** [always] is a range that is always valid (no from/until bounds). *)
29
+
val always : range
30
+
31
+
(** {1 Range Queries} *)
32
+
33
+
(** [valid_at range ~date] checks if [range] is valid at the given [date].
34
+
35
+
- [None] range means always valid
36
+
- [None] from means valid from beginning
37
+
- [None] until means valid continuing *)
38
+
val valid_at : range option -> date:date -> bool
39
+
40
+
(** [overlaps r1 r2] checks if two ranges overlap in time. *)
41
+
val overlaps : range -> range -> bool
42
+
43
+
(** [is_current range] checks if range is valid at the current date.
44
+
Uses today's date for the check. *)
45
+
val is_current : range option -> bool
46
+
47
+
(** {1 List Filtering} *)
48
+
49
+
(** [current ~get list] returns the first current/valid item from [list].
50
+
51
+
@param get Function to extract the temporal range from an item.
52
+
Returns the first item where the range is currently valid,
53
+
or the first item without temporal bounds if none are current. *)
54
+
val current : get:('a -> range option) -> 'a list -> 'a option
55
+
56
+
(** [at_date ~get ~date list] filters [list] to items valid at [date].
57
+
58
+
@param get Function to extract the temporal range from an item.
59
+
@param date The date to check validity against. *)
60
+
val at_date : get:('a -> range option) -> date:date -> 'a list -> 'a list
61
+
62
+
(** [filter ~get ~from ~until list] filters [list] to items overlapping the period.
63
+
64
+
Returns items whose temporal range overlaps with the given period. *)
65
+
val filter : get:('a -> range option) -> from:date option -> until:date option ->
66
+
'a list -> 'a list
67
+
68
+
(** {1 JSON Encoding} *)
69
+
70
+
(** [json_t] is the jsont encoder/decoder for temporal ranges.
71
+
72
+
Encodes as a JSON object with optional [from] and [until] fields:
73
+
{[ { "from": "2001-01", "until": "2003-12" } ]}
74
+
75
+
Empty object [\{\}] or missing field represents [always]. *)
76
+
val json_t : range Jsont.t
+28
-35
test/test_sortal.ml
+28
-35
test/test_sortal.ml
···
6
6
let c = Sortal.Contact.make
7
7
~handle:"test"
8
8
~names:["Test User"; "T. User"]
9
-
~email:"test@example.com"
10
-
~github:"testuser"
9
+
~emails:[Sortal.Contact.email_of_string "test@example.com"]
10
+
~services:[Sortal.Contact.make_service ~kind:Git ~handle:"testuser" "https://github.com/testuser"]
11
11
() in
12
12
assert (Sortal.Contact.handle c = "test");
13
13
assert (Sortal.Contact.name c = "Test User");
14
14
assert (List.length (Sortal.Contact.names c) = 2);
15
-
assert (Sortal.Contact.email c = Some "test@example.com");
16
-
assert (Sortal.Contact.github c = Some "testuser");
17
-
assert (Sortal.Contact.twitter c = None);
15
+
assert (Sortal.Contact.current_email c = Some "test@example.com");
16
+
assert (List.length (Sortal.Contact.services c) = 1);
17
+
assert (List.length (Sortal.Contact.services_of_kind c Git) = 1);
18
18
traceln "✓ Contact creation works"
19
19
20
20
let test_best_url () =
21
21
let c1 = Sortal.Contact.make
22
22
~handle:"test1"
23
23
~names:["Test 1"]
24
-
~url:"https://example.com"
25
-
~github:"test1"
24
+
~urls:[Sortal.Contact.url_of_string "https://example.com"]
25
+
~services:[Sortal.Contact.service_of_url "https://github.com/test1"]
26
26
() in
27
27
assert (Sortal.Contact.best_url c1 = Some "https://example.com");
28
28
29
29
let c2 = Sortal.Contact.make
30
30
~handle:"test2"
31
31
~names:["Test 2"]
32
-
~github:"test2"
32
+
~services:[Sortal.Contact.service_of_url "https://github.com/test2"]
33
33
() in
34
34
assert (Sortal.Contact.best_url c2 = Some "https://github.com/test2");
35
35
36
36
let c3 = Sortal.Contact.make
37
37
~handle:"test3"
38
38
~names:["Test 3"]
39
-
~email:"test3@example.com"
39
+
~emails:[Sortal.Contact.email_of_string "test3@example.com"]
40
40
() in
41
41
assert (Sortal.Contact.best_url c3 = Some "mailto:test3@example.com");
42
42
···
52
52
let c = Sortal.Contact.make
53
53
~handle:"json_test"
54
54
~names:["JSON Test"]
55
-
~email:"json@example.com"
56
-
~github:"jsontest"
55
+
~emails:[Sortal.Contact.email_of_string "json@example.com"]
56
+
~services:[Sortal.Contact.make_service ~kind:Git ~handle:"jsontest" "https://github.com/jsontest"]
57
57
~orcid:"0000-0001-2345-6789"
58
58
() in
59
59
···
62
62
(match Jsont_bytesrw.decode_string Sortal.Contact.json_t json_str with
63
63
| Ok decoded ->
64
64
assert (Sortal.Contact.handle decoded = "json_test");
65
-
assert (Sortal.Contact.email decoded = Some "json@example.com");
66
-
assert (Sortal.Contact.github decoded = Some "jsontest");
65
+
assert (Sortal.Contact.current_email decoded = Some "json@example.com");
66
+
assert (List.length (Sortal.Contact.services_of_kind decoded Git) = 1);
67
67
assert (Sortal.Contact.orcid decoded = Some "0000-0001-2345-6789");
68
68
traceln "✓ JSON encoding/decoding works"
69
69
| Error err ->
···
87
87
let c1 = Sortal.Contact.make
88
88
~handle:"alice"
89
89
~names:["Alice Anderson"]
90
-
~email:"alice@example.com"
90
+
~emails:[Sortal.Contact.email_of_string "alice@example.com"]
91
91
() in
92
92
93
93
let c2 = Sortal.Contact.make
94
94
~handle:"bob"
95
95
~names:["Bob Brown"; "Robert Brown"]
96
-
~github:"bobbrown"
96
+
~services:[Sortal.Contact.service_of_url "https://github.com/bobbrown"]
97
97
() in
98
98
99
99
(* Test save *)
···
159
159
let c1 = Sortal.Contact.make
160
160
~handle:"test1"
161
161
~names:["Test 1"]
162
-
~url:"https://example.com"
162
+
~urls:[Sortal.Contact.url_of_string "https://example.com"]
163
163
() in
164
-
assert (Sortal.Contact.url c1 = Some "https://example.com");
165
-
assert (Sortal.Contact.urls c1 = ["https://example.com"]);
164
+
assert (Sortal.Contact.current_url c1 = Some "https://example.com");
165
+
assert (List.length (Sortal.Contact.urls c1) = 1);
166
166
167
-
(* Test with only urls set *)
167
+
(* Test with multiple urls *)
168
168
let c2 = Sortal.Contact.make
169
169
~handle:"test2"
170
170
~names:["Test 2"]
171
-
~urls:["https://one.com"; "https://two.com"]
171
+
~urls:[
172
+
Sortal.Contact.url_of_string "https://one.com";
173
+
Sortal.Contact.url_of_string "https://two.com"
174
+
]
172
175
() in
173
-
assert (Sortal.Contact.url c2 = Some "https://one.com");
174
-
assert (Sortal.Contact.urls c2 = ["https://one.com"; "https://two.com"]);
176
+
assert (Sortal.Contact.current_url c2 = Some "https://one.com");
177
+
assert (List.length (Sortal.Contact.urls c2) = 2);
175
178
176
-
(* Test with both url and urls set *)
179
+
(* Test with no urls *)
177
180
let c3 = Sortal.Contact.make
178
181
~handle:"test3"
179
182
~names:["Test 3"]
180
-
~url:"https://primary.com"
181
-
~urls:["https://secondary.com"; "https://tertiary.com"]
182
183
() in
183
-
assert (Sortal.Contact.url c3 = Some "https://primary.com");
184
-
assert (Sortal.Contact.urls c3 = ["https://primary.com"; "https://secondary.com"; "https://tertiary.com"]);
185
-
186
-
(* Test with neither set *)
187
-
let c4 = Sortal.Contact.make
188
-
~handle:"test4"
189
-
~names:["Test 4"]
190
-
() in
191
-
assert (Sortal.Contact.url c4 = None);
192
-
assert (Sortal.Contact.urls c4 = []);
184
+
assert (Sortal.Contact.current_url c3 = None);
185
+
assert (Sortal.Contact.urls c3 = []);
193
186
194
187
traceln "✓ URLs field works correctly"
195
188