My aggregated monorepo of OCaml code, automaintained
Squashed 'sortal/' content from commit 6d6eeb7
git-subtree-dir: sortal
git-subtree-split: 6d6eeb7fb9780e94218b661b9f0ed1cb4ef9dc9c
+3863
+17
.gitignore
+17
.gitignore
+1
.ocamlformat
+1
.ocamlformat
···
1
+
version=0.28.1
+53
.tangled/workflows/build.yml
+53
.tangled/workflows/build.yml
···
1
+
when:
2
+
- event: ["push", "pull_request"]
3
+
branch: ["main"]
4
+
5
+
engine: nixery
6
+
7
+
dependencies:
8
+
nixpkgs:
9
+
- shell
10
+
- stdenv
11
+
- findutils
12
+
- binutils
13
+
- libunwind
14
+
- ncurses
15
+
- opam
16
+
- git
17
+
- gawk
18
+
- gnupatch
19
+
- gnum4
20
+
- gnumake
21
+
- gnutar
22
+
- gnused
23
+
- gnugrep
24
+
- diffutils
25
+
- gzip
26
+
- bzip2
27
+
- gcc
28
+
- ocaml
29
+
- pkg-config
30
+
31
+
steps:
32
+
- name: opam
33
+
command: |
34
+
opam init --disable-sandboxing -a -y
35
+
- name: repo
36
+
command: |
37
+
opam repo add aoah https://tangled.org/anil.recoil.org/aoah-opam-repo.git
38
+
- name: switch
39
+
command: |
40
+
opam install . --confirm-level=unsafe-yes --deps-only
41
+
- name: build
42
+
command: |
43
+
opam exec -- dune build -p sortal
44
+
- name: switch-test
45
+
command: |
46
+
opam install . --confirm-level=unsafe-yes --deps-only --with-test
47
+
- name: test
48
+
command: |
49
+
opam exec -- dune runtest --verbose
50
+
- name: doc
51
+
command: |
52
+
opam install -y odoc
53
+
opam exec -- dune build @doc
+15
LICENSE.md
+15
LICENSE.md
···
1
+
ISC License
2
+
3
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>
4
+
5
+
Permission to use, copy, modify, and distribute this software for any
6
+
purpose with or without fee is hereby granted, provided that the above
7
+
copyright notice and this permission notice appear in all copies.
8
+
9
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
10
+
WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
11
+
MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
12
+
ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
13
+
WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
14
+
ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
15
+
OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+170
README.md
+170
README.md
···
1
+
# Sortal - Contact Metadata Management Library
2
+
3
+
Sortal is an OCaml library that provides a comprehensive system for managing
4
+
contact metadata with temporal validity tracking. It stores data in
5
+
XDG-compliant locations using the YAML format and optionally versions all changes
6
+
with git.
7
+
8
+
## Features
9
+
10
+
- **Temporal Support**: Track how contact information changes over time (emails, organizations, URLs)
11
+
- **XDG-compliant storage**: Contact metadata stored in standard XDG data directories
12
+
- **YAML format**: Human-readable YAML files with type-safe encoding/decoding using yamlt
13
+
- **Rich metadata**: Support for multiple names, emails (typed), organizations, services (GitHub, social media), ORCID, URLs, and Atom feeds
14
+
- **Git Versioning**: Optional automatic git commits for all changes with descriptive messages
15
+
- **CLI Interface**: Full command-line interface for CRUD operations on contacts
16
+
- **Simple API**: Easy-to-use functions for saving, loading, searching, and deleting contacts
17
+
18
+
## Metadata Fields
19
+
20
+
Each contact can include:
21
+
22
+
- `handle`: Unique identifier/username (required)
23
+
- `names`: List of full names with primary name first (required)
24
+
- `email`: Email address
25
+
- `icon`: Avatar/icon URL
26
+
- `thumbnail`: Path to a local thumbnail image file
27
+
- `github`: GitHub username
28
+
- `twitter`: Twitter/X username
29
+
- `bluesky`: Bluesky handle
30
+
- `mastodon`: Mastodon handle (with instance)
31
+
- `orcid`: ORCID identifier
32
+
- `url`: Personal/professional website
33
+
- `atom_feeds`: List of Atom/RSS feed URLs
34
+
35
+
## Storage
36
+
37
+
Contact data is stored as individual YAML files in the XDG data directory:
38
+
39
+
- Default location: `$HOME/.local/share/sortal/`
40
+
- Override with: `SORTAL_DATA_DIR` or `XDG_DATA_HOME`
41
+
- Each contact stored as: `{handle}.yaml`
42
+
- Format: Human-readable YAML with temporal data support
43
+
44
+
## Usage Example
45
+
46
+
### Basic Usage
47
+
48
+
```ocaml
49
+
(* Create a contact store from filesystem *)
50
+
let store = Sortal.create env#fs "myapp" in
51
+
52
+
(* Or create from an existing XDG context (recommended when using eiocmd) *)
53
+
let store = Sortal.create_from_xdg xdg in
54
+
55
+
(* Create a new contact *)
56
+
let contact = Sortal.Contact.make
57
+
~handle:"avsm"
58
+
~names:["Anil Madhavapeddy"]
59
+
~email:"anil@recoil.org"
60
+
~github:"avsm"
61
+
~orcid:"0000-0002-7890-1234"
62
+
() in
63
+
64
+
(* Save the contact *)
65
+
Sortal.save store contact;
66
+
67
+
(* Lookup by handle *)
68
+
match Sortal.lookup store "avsm" with
69
+
| Some c -> Printf.printf "Found: %s\n" (Sortal.Contact.name c)
70
+
| None -> Printf.printf "Not found\n"
71
+
72
+
(* Search for contacts by name *)
73
+
let matches = Sortal.search_all store "Anil" in
74
+
List.iter (fun c ->
75
+
Printf.printf "%s: %s\n"
76
+
(Sortal.Contact.handle c)
77
+
(Sortal.Contact.name c)
78
+
) matches
79
+
80
+
(* List all contacts *)
81
+
let all_contacts = Sortal.list store in
82
+
List.iter (fun c ->
83
+
Printf.printf "%s: %s\n"
84
+
(Sortal.Contact.handle c)
85
+
(Sortal.Contact.name c)
86
+
) all_contacts
87
+
```
88
+
89
+
## CLI Tool
90
+
91
+
The library includes a standalone `sortal` CLI tool with full CRUD functionality:
92
+
93
+
```bash
94
+
# Initialize git versioning (optional)
95
+
sortal git-init
96
+
97
+
# List all contacts
98
+
sortal list
99
+
100
+
# Show details for a specific contact
101
+
sortal show avsm
102
+
103
+
# Search for contacts
104
+
sortal search "Anil"
105
+
106
+
# Show database statistics
107
+
sortal stats
108
+
109
+
# Add a new contact
110
+
sortal add jsmith --name "John Smith" --email "john@example.com" --kind person
111
+
112
+
# Add metadata to contacts
113
+
sortal add-org jsmith "Acme Corp" --title "Software Engineer" --from 2020-01
114
+
sortal add-service jsmith "https://github.com/jsmith" --kind github --handle jsmith
115
+
sortal add-email jsmith "john.work@example.com" --type work --from 2020-01
116
+
sortal add-url jsmith "https://jsmith.example.com" --label "Personal website"
117
+
118
+
# Remove metadata
119
+
sortal remove-email jsmith "old@example.com"
120
+
sortal remove-service jsmith "https://old-service.com"
121
+
sortal remove-org jsmith "Old Company"
122
+
sortal remove-url jsmith "https://old-url.com"
123
+
124
+
# Delete a contact
125
+
sortal delete jsmith
126
+
127
+
# Synchronize data (convert thumbnails to PNG)
128
+
sortal sync
129
+
```
130
+
131
+
## Git Versioning
132
+
133
+
Sortal includes a `Sortal_git_store` module that provides automatic git commits
134
+
for all contact modifications:
135
+
136
+
```ocaml
137
+
open Sortal
138
+
139
+
(* Create a git-backed store *)
140
+
let git_store = Git_store.create store env in
141
+
142
+
(* Initialize git repository *)
143
+
let () = match Git_store.init git_store with
144
+
| Ok () -> Logs.app (fun m -> m "Git initialized")
145
+
| Error msg -> Logs.err (fun m -> m "Error: %s" msg)
146
+
in
147
+
148
+
(* Save a contact - automatically commits with descriptive message *)
149
+
let contact = Contact.make ~handle:"jsmith" ~names:["John Smith"] () in
150
+
match Git_store.save git_store contact with
151
+
| Ok () -> Logs.app (fun m -> m "Contact saved and committed")
152
+
| Error msg -> Logs.err (fun m -> m "Error: %s" msg)
153
+
```
154
+
155
+
**Commit Messages**: All git store operations create descriptive commit messages:
156
+
- `save`: "Add contact @handle (Name)" or "Update contact @handle (Name)"
157
+
- `delete`: "Delete contact @handle (Name)"
158
+
- `add_email`: "Update @handle: add email address@example.com"
159
+
- `remove_email`: "Update @handle: remove email address@example.com"
160
+
- `add_service`: "Update @handle: add service Kind (url)"
161
+
- `add_organization`: "Update @handle: add organization Org Name"
162
+
- And similar for all other operations
163
+
164
+
## Project Status
165
+
166
+
Still very much just used by Anil Madhavapeddy. You're welcome to try it, but let me know...
167
+
168
+
## License
169
+
170
+
ISC License - see [LICENSE.md](LICENSE.md) for details.
+15
bin/dune
+15
bin/dune
+249
bin/sortal_cli.ml
+249
bin/sortal_cli.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Cmdliner
7
+
8
+
(* Main command *)
9
+
let () =
10
+
Random.self_init ();
11
+
Fmt.set_style_renderer Fmt.stdout `Ansi_tty;
12
+
Fmt.set_style_renderer Fmt.stderr `Ansi_tty;
13
+
14
+
Eio_main.run @@ fun env ->
15
+
16
+
let xdg_term = Xdge.Cmd.term "sortal" env#fs ~dirs:[`Data] () in
17
+
18
+
let info = Cmd.info "sortal"
19
+
~version:"0.1.0"
20
+
~doc:"Contact metadata management"
21
+
~man:[
22
+
`S Manpage.s_description;
23
+
`P "Sortal manages contact metadata including URLs, emails, ORCID identifiers, \
24
+
and social media handles. Data is stored in XDG-compliant locations.";
25
+
`S Manpage.s_commands;
26
+
`P "Use $(b,sortal COMMAND --help) for detailed help on each command.";
27
+
]
28
+
in
29
+
30
+
let make_term info main_term =
31
+
let term =
32
+
let open Term.Syntax in
33
+
let+ (xdg, _) = xdg_term
34
+
and+ main = main_term
35
+
and+ log_level = Logs_cli.level () in
36
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
37
+
Logs.set_level log_level;
38
+
main xdg
39
+
in
40
+
Cmd.v info term
41
+
in
42
+
43
+
let list_cmd = make_term Sortal.Cmd.list_info (Term.const Sortal.Cmd.list_cmd) in
44
+
let show_cmd = make_term Sortal.Cmd.show_info Term.(const Sortal.Cmd.show_cmd $ Sortal.Cmd.handle_arg) in
45
+
let search_cmd = make_term Sortal.Cmd.search_info Term.(const Sortal.Cmd.search_cmd $ Sortal.Cmd.query_arg) in
46
+
let stats_cmd = make_term Sortal.Cmd.stats_info Term.(const (fun () -> Sortal.Cmd.stats_cmd ()) $ const ()) in
47
+
let sync_cmd = make_term Sortal.Cmd.sync_info Term.(const (fun () -> Sortal.Cmd.sync_cmd ()) $ const ()) in
48
+
49
+
(* Git init command needs special handling to pass env *)
50
+
let git_init_cmd =
51
+
let term =
52
+
let open Term.Syntax in
53
+
let+ (xdg, _) = xdg_term
54
+
and+ log_level = Logs_cli.level () in
55
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
56
+
Logs.set_level log_level;
57
+
Sortal.Cmd.git_init_cmd xdg env
58
+
in
59
+
Cmd.v Sortal.Cmd.git_init_info term
60
+
in
61
+
62
+
(* Contact management commands - need special handling for env *)
63
+
let add_cmd =
64
+
let term =
65
+
let open Term.Syntax in
66
+
let+ (xdg, _) = xdg_term
67
+
and+ handle = Sortal.Cmd.add_handle_arg
68
+
and+ names = Sortal.Cmd.add_names_arg
69
+
and+ kind = Sortal.Cmd.add_kind_arg
70
+
and+ email = Sortal.Cmd.add_email_arg
71
+
and+ github = Sortal.Cmd.add_github_arg
72
+
and+ url = Sortal.Cmd.add_url_arg
73
+
and+ orcid = Sortal.Cmd.add_orcid_arg
74
+
and+ log_level = Logs_cli.level () in
75
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
76
+
Logs.set_level log_level;
77
+
Sortal.Cmd.add_cmd handle names kind email github url orcid xdg env
78
+
in
79
+
Cmd.v Sortal.Cmd.add_info term
80
+
in
81
+
82
+
let delete_cmd =
83
+
let term =
84
+
let open Term.Syntax in
85
+
let+ (xdg, _) = xdg_term
86
+
and+ handle = Sortal.Cmd.handle_arg
87
+
and+ log_level = Logs_cli.level () in
88
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
89
+
Logs.set_level log_level;
90
+
Sortal.Cmd.delete_cmd handle xdg env
91
+
in
92
+
Cmd.v Sortal.Cmd.delete_info term
93
+
in
94
+
95
+
(* Entry management commands *)
96
+
let add_email_cmd =
97
+
let term =
98
+
let open Term.Syntax in
99
+
let+ (xdg, _) = xdg_term
100
+
and+ handle = Sortal.Cmd.handle_arg
101
+
and+ address = Sortal.Cmd.email_address_arg
102
+
and+ type_ = Sortal.Cmd.email_type_arg
103
+
and+ from = Sortal.Cmd.date_arg "from"
104
+
and+ until = Sortal.Cmd.date_arg "until"
105
+
and+ note = Sortal.Cmd.note_arg
106
+
and+ log_level = Logs_cli.level () in
107
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
108
+
Logs.set_level log_level;
109
+
Sortal.Cmd.add_email_cmd handle address type_ from until note xdg env
110
+
in
111
+
Cmd.v Sortal.Cmd.add_email_info term
112
+
in
113
+
114
+
let remove_email_cmd =
115
+
let term =
116
+
let open Term.Syntax in
117
+
let+ (xdg, _) = xdg_term
118
+
and+ handle = Sortal.Cmd.handle_arg
119
+
and+ address = Sortal.Cmd.email_address_arg
120
+
and+ log_level = Logs_cli.level () in
121
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
122
+
Logs.set_level log_level;
123
+
Sortal.Cmd.remove_email_cmd handle address xdg env
124
+
in
125
+
Cmd.v Sortal.Cmd.remove_email_info term
126
+
in
127
+
128
+
let add_service_cmd =
129
+
let term =
130
+
let open Term.Syntax in
131
+
let+ (xdg, _) = xdg_term
132
+
and+ handle = Sortal.Cmd.handle_arg
133
+
and+ url = Sortal.Cmd.service_url_arg
134
+
and+ kind = Sortal.Cmd.service_kind_arg
135
+
and+ service_handle = Sortal.Cmd.service_handle_arg
136
+
and+ label = Sortal.Cmd.label_arg
137
+
and+ log_level = Logs_cli.level () in
138
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
139
+
Logs.set_level log_level;
140
+
Sortal.Cmd.add_service_cmd handle url kind service_handle label xdg env
141
+
in
142
+
Cmd.v Sortal.Cmd.add_service_info term
143
+
in
144
+
145
+
let remove_service_cmd =
146
+
let term =
147
+
let open Term.Syntax in
148
+
let+ (xdg, _) = xdg_term
149
+
and+ handle = Sortal.Cmd.handle_arg
150
+
and+ url = Sortal.Cmd.service_url_arg
151
+
and+ log_level = Logs_cli.level () in
152
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
153
+
Logs.set_level log_level;
154
+
Sortal.Cmd.remove_service_cmd handle url xdg env
155
+
in
156
+
Cmd.v Sortal.Cmd.remove_service_info term
157
+
in
158
+
159
+
let add_org_cmd =
160
+
let term =
161
+
let open Term.Syntax in
162
+
let+ (xdg, _) = xdg_term
163
+
and+ handle = Sortal.Cmd.handle_arg
164
+
and+ org_name = Sortal.Cmd.org_name_arg
165
+
and+ title = Sortal.Cmd.org_title_arg
166
+
and+ department = Sortal.Cmd.org_department_arg
167
+
and+ from = Sortal.Cmd.date_arg "from"
168
+
and+ until = Sortal.Cmd.date_arg "until"
169
+
and+ org_email = Sortal.Cmd.org_email_arg
170
+
and+ org_url = Sortal.Cmd.org_url_arg
171
+
and+ log_level = Logs_cli.level () in
172
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
173
+
Logs.set_level log_level;
174
+
Sortal.Cmd.add_org_cmd handle org_name title department from until org_email org_url xdg env
175
+
in
176
+
Cmd.v Sortal.Cmd.add_org_info term
177
+
in
178
+
179
+
let remove_org_cmd =
180
+
let term =
181
+
let open Term.Syntax in
182
+
let+ (xdg, _) = xdg_term
183
+
and+ handle = Sortal.Cmd.handle_arg
184
+
and+ org_name = Sortal.Cmd.org_name_arg
185
+
and+ log_level = Logs_cli.level () in
186
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
187
+
Logs.set_level log_level;
188
+
Sortal.Cmd.remove_org_cmd handle org_name xdg env
189
+
in
190
+
Cmd.v Sortal.Cmd.remove_org_info term
191
+
in
192
+
193
+
let add_url_cmd =
194
+
let term =
195
+
let open Term.Syntax in
196
+
let+ (xdg, _) = xdg_term
197
+
and+ handle = Sortal.Cmd.handle_arg
198
+
and+ url = Sortal.Cmd.url_value_arg
199
+
and+ label = Sortal.Cmd.label_arg
200
+
and+ log_level = Logs_cli.level () in
201
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
202
+
Logs.set_level log_level;
203
+
Sortal.Cmd.add_url_cmd handle url label xdg env
204
+
in
205
+
Cmd.v Sortal.Cmd.add_url_info term
206
+
in
207
+
208
+
let remove_url_cmd =
209
+
let term =
210
+
let open Term.Syntax in
211
+
let+ (xdg, _) = xdg_term
212
+
and+ handle = Sortal.Cmd.handle_arg
213
+
and+ url = Sortal.Cmd.url_value_arg
214
+
and+ log_level = Logs_cli.level () in
215
+
Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ());
216
+
Logs.set_level log_level;
217
+
Sortal.Cmd.remove_url_cmd handle url xdg env
218
+
in
219
+
Cmd.v Sortal.Cmd.remove_url_info term
220
+
in
221
+
222
+
let default_term =
223
+
let open Term.Syntax in
224
+
let+ _ = xdg_term
225
+
and+ _ = Logs_cli.level () in
226
+
`Help (`Pager, None)
227
+
in
228
+
let default_term = Term.ret default_term in
229
+
230
+
let cmd = Cmd.group info ~default:default_term [
231
+
list_cmd;
232
+
show_cmd;
233
+
search_cmd;
234
+
stats_cmd;
235
+
sync_cmd;
236
+
git_init_cmd;
237
+
add_cmd;
238
+
delete_cmd;
239
+
add_email_cmd;
240
+
remove_email_cmd;
241
+
add_service_cmd;
242
+
remove_service_cmd;
243
+
add_org_cmd;
244
+
remove_org_cmd;
245
+
add_url_cmd;
246
+
remove_url_cmd;
247
+
] in
248
+
249
+
exit (Cmd.eval' cmd)
+5
dune
+5
dune
+37
dune-project
+37
dune-project
···
1
+
(lang dune 3.20)
2
+
3
+
(name sortal)
4
+
5
+
(generate_opam_files true)
6
+
7
+
(license ISC)
8
+
(authors "Anil Madhavapeddy")
9
+
(homepage "https://tangled.org/@anil.recoil.org/sortal")
10
+
(maintainers "Anil Madhavapeddy <anil@recoil.org>")
11
+
(bug_reports "https://tangled.org/@anil.recoil.org/sortal/issues")
12
+
(maintenance_intent "(latest)")
13
+
14
+
(package
15
+
(name sortal)
16
+
(synopsis "Contact metadata management with XDG storage and versioned schemas")
17
+
(description
18
+
"Sortal provides contact metadata management with versioned schemas,
19
+
XDG-compliant storage, git versioning, and CLI tools.
20
+
21
+
The library is split into two components:
22
+
- sortal.schema: Versioned data types with minimal dependencies
23
+
- sortal: Core library with storage, git integration, and CLI support")
24
+
(depends
25
+
(ocaml (>= 5.1.0))
26
+
eio
27
+
eio_main
28
+
xdge
29
+
jsont
30
+
ptime
31
+
yamlt
32
+
bytesrw
33
+
fmt
34
+
cmdliner
35
+
logs
36
+
(odoc :with-doc)
37
+
(alcotest (and :with-test (>= 1.7.0)))))
+17
lib/core/dune
+17
lib/core/dune
+26
lib/core/sortal.ml
+26
lib/core/sortal.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Temporal = Sortal_schema.Temporal
7
+
module Feed = Sortal_schema.Feed
8
+
module Contact = Sortal_schema.Contact
9
+
module Store = Sortal_store
10
+
module Git_store = Sortal_git_store
11
+
module Cmd = Sortal_cmd
12
+
13
+
type t = Store.t
14
+
15
+
let create = Store.create
16
+
let create_from_xdg = Store.create_from_xdg
17
+
let save = Store.save
18
+
let lookup = Store.lookup
19
+
let delete = Store.delete
20
+
let list = Store.list
21
+
let thumbnail_path = Store.thumbnail_path
22
+
let find_by_name = Store.find_by_name
23
+
let find_by_name_opt = Store.find_by_name_opt
24
+
let search_all = Store.search_all
25
+
let handle_of_name = Store.handle_of_name
26
+
let pp = Store.pp
+119
lib/core/sortal.mli
+119
lib/core/sortal.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Sortal - Username to metadata mapping with XDG storage
7
+
8
+
This library provides a system for mapping usernames to various metadata
9
+
including URLs, emails, ORCID identifiers, and social media handles.
10
+
It uses XDG Base Directory Specification for storage locations and
11
+
provides temporal support for time-bounded information like historical
12
+
email addresses and employment records.
13
+
14
+
{b Storage:}
15
+
16
+
Contact metadata is stored as YAML files in the XDG data directory,
17
+
with one file per contact using the handle as the filename. The YAML
18
+
format uses the same Jsont codec definitions as JSON for seamless
19
+
compatibility.
20
+
21
+
{b Typical Usage:}
22
+
23
+
{[
24
+
let store = Sortal.create env#fs "myapp" in
25
+
let contact = Sortal.Contact.make
26
+
~handle:"avsm"
27
+
~names:["Anil Madhavapeddy"]
28
+
~email:"anil@recoil.org"
29
+
~github:"avsm"
30
+
~orcid:"0000-0002-7890-1234"
31
+
() in
32
+
Sortal.save store contact;
33
+
34
+
match Sortal.lookup store "avsm" with
35
+
| Some c -> Printf.printf "Found: %s\n" (Sortal.Contact.name c)
36
+
| None -> Printf.printf "Not found\n"
37
+
]}
38
+
*)
39
+
40
+
(** {1 Schema Modules}
41
+
42
+
These modules define the data types and serialization formats.
43
+
They are re-exported from {!Sortal_schema} for convenience.
44
+
For version-specific access, use [Sortal_schema.V1.*]. *)
45
+
46
+
(** Temporal validity support for time-bounded contact fields. *)
47
+
module Temporal = Sortal_schema.Temporal
48
+
49
+
(** Feed subscription metadata. *)
50
+
module Feed = Sortal_schema.Feed
51
+
52
+
(** Contact metadata with temporal support. *)
53
+
module Contact = Sortal_schema.Contact
54
+
55
+
(** {1 Core Modules} *)
56
+
57
+
(** Contact store with XDG-compliant storage. *)
58
+
module Store = Sortal_store
59
+
60
+
(** Git-backed contact store with automatic version control. *)
61
+
module Git_store = Sortal_git_store
62
+
63
+
(** Cmdliner integration for CLI applications. *)
64
+
module Cmd = Sortal_cmd
65
+
66
+
(** {1 Convenience Re-exports}
67
+
68
+
These are re-exported from {!Store} for easier top-level access. *)
69
+
70
+
(** The contact store type. *)
71
+
type t = Store.t
72
+
73
+
(** [create fs app_name] creates a new contact store.
74
+
See {!Store.create} for details. *)
75
+
val create : Eio.Fs.dir_ty Eio.Path.t -> string -> t
76
+
77
+
(** [create_from_xdg xdg] creates a contact store from an XDG context.
78
+
See {!Store.create_from_xdg} for details. *)
79
+
val create_from_xdg : Xdge.t -> t
80
+
81
+
(** [save t contact] saves a contact to the store.
82
+
See {!Store.save} for details. *)
83
+
val save : t -> Contact.t -> unit
84
+
85
+
(** [lookup t handle] retrieves a contact by handle.
86
+
See {!Store.lookup} for details. *)
87
+
val lookup : t -> string -> Contact.t option
88
+
89
+
(** [delete t handle] removes a contact from the store.
90
+
See {!Store.delete} for details. *)
91
+
val delete : t -> string -> unit
92
+
93
+
(** [list t] returns all contacts in the store.
94
+
See {!Store.list} for details. *)
95
+
val list : t -> Contact.t list
96
+
97
+
(** [thumbnail_path t contact] returns the path to a contact's thumbnail.
98
+
See {!Store.thumbnail_path} for details. *)
99
+
val thumbnail_path : t -> Contact.t -> Eio.Fs.dir_ty Eio.Path.t option
100
+
101
+
(** [find_by_name t name] searches for contacts by name.
102
+
See {!Store.find_by_name} for details. *)
103
+
val find_by_name : t -> string -> Contact.t
104
+
105
+
(** [find_by_name_opt t name] searches for contacts by name.
106
+
See {!Store.find_by_name_opt} for details. *)
107
+
val find_by_name_opt : t -> string -> Contact.t option
108
+
109
+
(** [search_all t query] searches for contacts matching a query.
110
+
See {!Store.search_all} for details. *)
111
+
val search_all : t -> string -> Contact.t list
112
+
113
+
(** [handle_of_name name] generates a handle from a full name.
114
+
See {!Store.handle_of_name} for details. *)
115
+
val handle_of_name : string -> string
116
+
117
+
(** [pp ppf t] pretty prints the contact store.
118
+
See {!Store.pp} for details. *)
119
+
val pp : Format.formatter -> t -> unit
+464
lib/core/sortal_cmd.ml
+464
lib/core/sortal_cmd.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Cmdliner
7
+
8
+
module Contact = Sortal_schema.Contact
9
+
module Temporal = Sortal_schema.Temporal
10
+
11
+
let is_png path =
12
+
let ext = String.lowercase_ascii (Filename.extension path) in
13
+
ext = ".png"
14
+
15
+
let convert_to_png src_path =
16
+
let base = Filename.remove_extension src_path in
17
+
let dst_path = base ^ ".png" in
18
+
let cmd = Printf.sprintf "magick %s %s" (Filename.quote src_path) (Filename.quote dst_path) in
19
+
let ret = Unix.system cmd in
20
+
match ret with
21
+
| Unix.WEXITED 0 -> Ok dst_path
22
+
| Unix.WEXITED n -> Error (Printf.sprintf "magick exited with code %d" n)
23
+
| Unix.WSIGNALED n -> Error (Printf.sprintf "magick killed by signal %d" n)
24
+
| Unix.WSTOPPED n -> Error (Printf.sprintf "magick stopped by signal %d" n)
25
+
26
+
let list_cmd xdg =
27
+
let store = Sortal_store.create_from_xdg xdg in
28
+
let contacts = Sortal_store.list store in
29
+
let sorted = List.sort Contact.compare contacts in
30
+
Printf.printf "Total contacts: %d\n" (List.length sorted);
31
+
List.iter (fun c ->
32
+
Printf.printf "@%s: %s\n" (Contact.handle c) (Contact.name c)
33
+
) sorted;
34
+
0
35
+
36
+
let show_cmd handle xdg =
37
+
let store = Sortal_store.create_from_xdg xdg in
38
+
match Sortal_store.lookup store handle with
39
+
| Some c ->
40
+
(* Use the pretty printer for rich temporal display *)
41
+
Fmt.pr "%a@." Contact.pp c;
42
+
0
43
+
| None -> Logs.err (fun m -> m "Contact not found: %s" handle); 1
44
+
45
+
let search_cmd query xdg =
46
+
let store = Sortal_store.create_from_xdg xdg in
47
+
match Sortal_store.search_all store query with
48
+
| [] ->
49
+
Logs.warn (fun m -> m "No contacts found matching: %s" query);
50
+
1
51
+
| matches ->
52
+
Logs.app (fun m -> m "Found %d match%s:"
53
+
(List.length matches)
54
+
(if List.length matches = 1 then "" else "es"));
55
+
List.iter (fun c ->
56
+
Logs.app (fun m -> m "@%s: %s" (Contact.handle c) (Contact.name c));
57
+
Option.iter (fun e -> Logs.app (fun m -> m " Email: %s" e)) (Contact.current_email c);
58
+
Option.iter (fun u -> Logs.app (fun m -> m " URL: %s" u)) (Contact.best_url c)
59
+
) matches;
60
+
0
61
+
62
+
let stats_cmd () xdg =
63
+
let store = Sortal_store.create_from_xdg xdg in
64
+
let contacts = Sortal_store.list store in
65
+
let total = List.length contacts in
66
+
let count pred = List.filter pred contacts |> List.length in
67
+
let with_email = count (fun c -> Contact.emails c <> []) in
68
+
let with_org = count (fun c -> Contact.organizations c <> []) in
69
+
let with_url = count (fun c -> Contact.urls c <> []) in
70
+
let with_service = count (fun c -> Contact.services c <> []) in
71
+
let with_orcid = count (fun c -> Option.is_some (Contact.orcid c)) in
72
+
let with_feeds = count (fun c -> Option.is_some (Contact.feeds c)) in
73
+
let total_feeds =
74
+
List.fold_left (fun acc c ->
75
+
acc + Option.fold ~none:0 ~some:List.length (Contact.feeds c)
76
+
) 0 contacts
77
+
in
78
+
let total_services =
79
+
List.fold_left (fun acc c ->
80
+
acc + List.length (Contact.services c)
81
+
) 0 contacts
82
+
in
83
+
let pct n = float_of_int n /. float_of_int total *. 100. in
84
+
Logs.app (fun m -> m "Contact Database Statistics:");
85
+
Logs.app (fun m -> m " Total contacts: %d" total);
86
+
Logs.app (fun m -> m " With email: %d (%.1f%%)" with_email (pct with_email));
87
+
Logs.app (fun m -> m " With organization: %d (%.1f%%)" with_org (pct with_org));
88
+
Logs.app (fun m -> m " With services: %d (%.1f%%), total %d services" with_service (pct with_service) total_services);
89
+
Logs.app (fun m -> m " With ORCID: %d (%.1f%%)" with_orcid (pct with_orcid));
90
+
Logs.app (fun m -> m " With URL: %d (%.1f%%)" with_url (pct with_url));
91
+
Logs.app (fun m -> m " With feeds: %d (%.1f%%), total %d feeds" with_feeds (pct with_feeds) total_feeds);
92
+
0
93
+
94
+
let sync_cmd () xdg =
95
+
let store = Sortal_store.create_from_xdg xdg in
96
+
let contacts = Sortal_store.list store in
97
+
Logs.app (fun m -> m "Syncing %d contacts..." (List.length contacts));
98
+
let converted = ref 0 in
99
+
let skipped = ref 0 in
100
+
let no_thumbnail = ref 0 in
101
+
let errors = ref 0 in
102
+
List.iter (fun contact ->
103
+
let handle = Contact.handle contact in
104
+
match Sortal_store.thumbnail_path store contact with
105
+
| None ->
106
+
Logs.info (fun m -> m "@%s: no thumbnail" handle);
107
+
incr no_thumbnail
108
+
| Some eio_path ->
109
+
let path = Eio.Path.native_exn eio_path in
110
+
if is_png path then begin
111
+
Logs.info (fun m -> m "@%s: already PNG (%s)" handle (Filename.basename path));
112
+
incr skipped
113
+
end else begin
114
+
Logs.app (fun m -> m "@%s: converting %s to PNG..." handle (Filename.basename path));
115
+
match convert_to_png path with
116
+
| Ok new_path ->
117
+
Logs.app (fun m -> m " Converted: %s -> %s"
118
+
(Filename.basename path) (Filename.basename new_path));
119
+
incr converted
120
+
| Error msg ->
121
+
Logs.err (fun m -> m " Failed to convert %s: %s" path msg);
122
+
incr errors
123
+
end
124
+
) contacts;
125
+
Logs.app (fun m -> m "Sync complete:");
126
+
Logs.app (fun m -> m " %d contacts without thumbnails" !no_thumbnail);
127
+
Logs.app (fun m -> m " %d already PNG (skipped)" !skipped);
128
+
Logs.app (fun m -> m " %d converted to PNG" !converted);
129
+
Logs.app (fun m -> m " %d errors" !errors);
130
+
if !errors > 0 then 1 else 0
131
+
132
+
(* Initialize git repository *)
133
+
let git_init_cmd xdg env =
134
+
let store = Sortal_store.create_from_xdg xdg in
135
+
let git_store = Sortal_git_store.create store env in
136
+
match Sortal_git_store.init git_store with
137
+
| Ok () ->
138
+
if Sortal_git_store.is_initialized git_store then
139
+
Logs.app (fun m -> m "Git repository initialized in data directory")
140
+
else
141
+
Logs.app (fun m -> m "Git repository already initialized");
142
+
0
143
+
| Error msg ->
144
+
Logs.err (fun m -> m "Failed to initialize git repository: %s" msg);
145
+
1
146
+
147
+
(* Add a new contact *)
148
+
let add_cmd handle names kind email github url orcid xdg env =
149
+
let store = Sortal_store.create_from_xdg xdg in
150
+
let git_store = Sortal_git_store.create store env in
151
+
(* Check if contact already exists *)
152
+
match Sortal_store.lookup store handle with
153
+
| Some _ ->
154
+
Logs.err (fun m -> m "Contact @%s already exists" handle);
155
+
1
156
+
| None ->
157
+
let emails = match email with
158
+
| Some e -> [Contact.make_email e]
159
+
| None -> []
160
+
in
161
+
let services = match github with
162
+
| Some gh -> [Contact.make_service ~kind:Contact.Github ~handle:gh (Printf.sprintf "https://github.com/%s" gh)]
163
+
| None -> []
164
+
in
165
+
let urls = match url with
166
+
| Some u -> [Contact.make_url u]
167
+
| None -> []
168
+
in
169
+
let contact = Contact.make
170
+
~handle
171
+
~names
172
+
?kind
173
+
~emails
174
+
~services
175
+
~urls
176
+
?orcid
177
+
()
178
+
in
179
+
match Sortal_git_store.save git_store contact with
180
+
| Ok () ->
181
+
Logs.app (fun m -> m "Created contact @%s: %s" handle (Contact.name contact));
182
+
0
183
+
| Error msg ->
184
+
Logs.err (fun m -> m "Failed to save contact: %s" msg);
185
+
1
186
+
187
+
(* Delete a contact *)
188
+
let delete_cmd handle xdg env =
189
+
let store = Sortal_store.create_from_xdg xdg in
190
+
let git_store = Sortal_git_store.create store env in
191
+
match Sortal_git_store.delete git_store handle with
192
+
| Ok () ->
193
+
Logs.app (fun m -> m "Deleted contact @%s" handle);
194
+
0
195
+
| Error msg ->
196
+
Logs.err (fun m -> m "%s" msg);
197
+
1
198
+
199
+
(* Convert string option to Ptime.date option *)
200
+
let parse_date_opt (s_opt : string option) : Sortal_schema.Temporal.date option =
201
+
match s_opt with
202
+
| None -> None
203
+
| Some s ->
204
+
match Sortal_schema.Temporal.parse_date_string s with
205
+
| Some d -> Some d
206
+
| None ->
207
+
Logs.warn (fun m -> m "Invalid date format: %s (using ISO 8601: YYYY, YYYY-MM, or YYYY-MM-DD)" s);
208
+
None
209
+
210
+
(* Add email to existing contact *)
211
+
let add_email_cmd handle address type_ from until note xdg env =
212
+
let store = Sortal_store.create_from_xdg xdg in
213
+
let git_store = Sortal_git_store.create store env in
214
+
let from = parse_date_opt from in
215
+
let until = parse_date_opt until in
216
+
let email = Contact.make_email ?type_ ?from ?until ?note address in
217
+
match Sortal_git_store.add_email git_store handle email with
218
+
| Ok () ->
219
+
Logs.app (fun m -> m "Added email %s to @%s" address handle);
220
+
0
221
+
| Error msg ->
222
+
Logs.err (fun m -> m "%s" msg);
223
+
1
224
+
225
+
(* Remove email from contact *)
226
+
let remove_email_cmd handle address xdg env =
227
+
let store = Sortal_store.create_from_xdg xdg in
228
+
let git_store = Sortal_git_store.create store env in
229
+
match Sortal_git_store.remove_email git_store handle address with
230
+
| Ok () ->
231
+
Logs.app (fun m -> m "Removed email %s from @%s" address handle);
232
+
0
233
+
| Error msg ->
234
+
Logs.err (fun m -> m "%s" msg);
235
+
1
236
+
237
+
(* Add service to existing contact *)
238
+
let add_service_cmd handle url kind service_handle label xdg env =
239
+
let store = Sortal_store.create_from_xdg xdg in
240
+
let git_store = Sortal_git_store.create store env in
241
+
let service = Contact.make_service ?kind ?handle:service_handle ?label url in
242
+
match Sortal_git_store.add_service git_store handle service with
243
+
| Ok () ->
244
+
Logs.app (fun m -> m "Added service %s to @%s" url handle);
245
+
0
246
+
| Error msg ->
247
+
Logs.err (fun m -> m "%s" msg);
248
+
1
249
+
250
+
(* Remove service from contact *)
251
+
let remove_service_cmd handle url xdg env =
252
+
let store = Sortal_store.create_from_xdg xdg in
253
+
let git_store = Sortal_git_store.create store env in
254
+
match Sortal_git_store.remove_service git_store handle url with
255
+
| Ok () ->
256
+
Logs.app (fun m -> m "Removed service %s from @%s" url handle);
257
+
0
258
+
| Error msg ->
259
+
Logs.err (fun m -> m "%s" msg);
260
+
1
261
+
262
+
(* Add organization to existing contact *)
263
+
let add_org_cmd handle org_name title department from until org_email org_url xdg env =
264
+
let store = Sortal_store.create_from_xdg xdg in
265
+
let git_store = Sortal_git_store.create store env in
266
+
let from = parse_date_opt from in
267
+
let until = parse_date_opt until in
268
+
let org = Contact.make_org ?title ?department ?from ?until ?email:org_email ?url:org_url org_name in
269
+
match Sortal_git_store.add_organization git_store handle org with
270
+
| Ok () ->
271
+
Logs.app (fun m -> m "Added organization %s to @%s" org_name handle);
272
+
0
273
+
| Error msg ->
274
+
Logs.err (fun m -> m "%s" msg);
275
+
1
276
+
277
+
(* Remove organization from contact *)
278
+
let remove_org_cmd handle org_name xdg env =
279
+
let store = Sortal_store.create_from_xdg xdg in
280
+
let git_store = Sortal_git_store.create store env in
281
+
match Sortal_git_store.remove_organization git_store handle org_name with
282
+
| Ok () ->
283
+
Logs.app (fun m -> m "Removed organization %s from @%s" org_name handle);
284
+
0
285
+
| Error msg ->
286
+
Logs.err (fun m -> m "%s" msg);
287
+
1
288
+
289
+
(* Add URL to existing contact *)
290
+
let add_url_cmd handle url label xdg env =
291
+
let store = Sortal_store.create_from_xdg xdg in
292
+
let git_store = Sortal_git_store.create store env in
293
+
let url_entry = Contact.make_url ?label url in
294
+
match Sortal_git_store.add_url git_store handle url_entry with
295
+
| Ok () ->
296
+
Logs.app (fun m -> m "Added URL %s to @%s" url handle);
297
+
0
298
+
| Error msg ->
299
+
Logs.err (fun m -> m "%s" msg);
300
+
1
301
+
302
+
(* Remove URL from contact *)
303
+
let remove_url_cmd handle url xdg env =
304
+
let store = Sortal_store.create_from_xdg xdg in
305
+
let git_store = Sortal_git_store.create store env in
306
+
match Sortal_git_store.remove_url git_store handle url with
307
+
| Ok () ->
308
+
Logs.app (fun m -> m "Removed URL %s from @%s" url handle);
309
+
0
310
+
| Error msg ->
311
+
Logs.err (fun m -> m "%s" msg);
312
+
1
313
+
314
+
(* Command info and args *)
315
+
let list_info = Cmd.info "list" ~doc:"List all contacts"
316
+
let show_info = Cmd.info "show" ~doc:"Show detailed information about a contact"
317
+
let search_info = Cmd.info "search" ~doc:"Search contacts by name"
318
+
let stats_info = Cmd.info "stats" ~doc:"Show statistics about the contact database"
319
+
let sync_info = Cmd.info "sync" ~doc:"Synchronize and normalize contact data"
320
+
321
+
let git_init_info = Cmd.info "git-init" ~doc:"Initialize git repository for contact versioning"
322
+
~man:[
323
+
`S Manpage.s_description;
324
+
`P "Initialize a git repository in the XDG data directory to track contact changes.";
325
+
`P "Once initialized, all contact modifications will be automatically committed with descriptive messages.";
326
+
]
327
+
328
+
let add_info = Cmd.info "add" ~doc:"Create a new contact"
329
+
~man:[
330
+
`S Manpage.s_description;
331
+
`P "Create a new contact with the given handle and name.";
332
+
`P "Additional metadata can be added using options or via add-email, add-service, etc. commands.";
333
+
]
334
+
335
+
let delete_info = Cmd.info "delete" ~doc:"Delete a contact"
336
+
let add_email_info = Cmd.info "add-email" ~doc:"Add an email address to a contact"
337
+
let remove_email_info = Cmd.info "remove-email" ~doc:"Remove an email address from a contact"
338
+
let add_service_info = Cmd.info "add-service" ~doc:"Add a service (GitHub, Twitter, etc.) to a contact"
339
+
let remove_service_info = Cmd.info "remove-service" ~doc:"Remove a service from a contact"
340
+
let add_org_info = Cmd.info "add-org" ~doc:"Add an organization/affiliation to a contact"
341
+
let remove_org_info = Cmd.info "remove-org" ~doc:"Remove an organization from a contact"
342
+
let add_url_info = Cmd.info "add-url" ~doc:"Add a URL to a contact"
343
+
let remove_url_info = Cmd.info "remove-url" ~doc:"Remove a URL from a contact"
344
+
345
+
let handle_arg =
346
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE"
347
+
~doc:"Contact handle to display")
348
+
349
+
let query_arg =
350
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"QUERY"
351
+
~doc:"Name or partial name to search for")
352
+
353
+
(* Add command arguments *)
354
+
let add_handle_arg =
355
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE"
356
+
~doc:"Contact handle (unique identifier)")
357
+
358
+
let add_names_arg =
359
+
Arg.(non_empty & opt_all string [] & info ["n"; "name"] ~docv:"NAME"
360
+
~doc:"Full name (can be specified multiple times for aliases)")
361
+
362
+
let add_kind_arg =
363
+
let kind_conv =
364
+
let parse s = match Contact.contact_kind_of_string s with
365
+
| Some k -> Ok k
366
+
| None -> Error (`Msg (Printf.sprintf "Invalid kind: %s" s))
367
+
in
368
+
let print ppf k = Format.pp_print_string ppf (Contact.contact_kind_to_string k) in
369
+
Arg.conv (parse, print)
370
+
in
371
+
Arg.(value & opt (some kind_conv) None & info ["k"; "kind"] ~docv:"KIND"
372
+
~doc:"Contact kind (person, organization, group, role)")
373
+
374
+
let add_email_arg =
375
+
Arg.(value & opt (some string) None & info ["e"; "email"] ~docv:"EMAIL"
376
+
~doc:"Email address")
377
+
378
+
let add_github_arg =
379
+
Arg.(value & opt (some string) None & info ["g"; "github"] ~docv:"HANDLE"
380
+
~doc:"GitHub handle")
381
+
382
+
let add_url_arg =
383
+
Arg.(value & opt (some string) None & info ["u"; "url"] ~docv:"URL"
384
+
~doc:"Personal/professional website URL")
385
+
386
+
let add_orcid_arg =
387
+
Arg.(value & opt (some string) None & info ["orcid"] ~docv:"ORCID"
388
+
~doc:"ORCID identifier")
389
+
390
+
(* Add-email command arguments *)
391
+
let email_address_arg =
392
+
Arg.(required & pos 1 (some string) None & info [] ~docv:"EMAIL"
393
+
~doc:"Email address")
394
+
395
+
let email_type_arg =
396
+
let type_conv =
397
+
let parse s = match Contact.email_type_of_string s with
398
+
| Some t -> Ok t
399
+
| None -> Error (`Msg (Printf.sprintf "Invalid email type: %s" s))
400
+
in
401
+
let print ppf t = Format.pp_print_string ppf (Contact.email_type_to_string t) in
402
+
Arg.conv (parse, print)
403
+
in
404
+
Arg.(value & opt (some type_conv) None & info ["t"; "type"] ~docv:"TYPE"
405
+
~doc:"Email type (work, personal, other)")
406
+
407
+
let date_arg name =
408
+
Arg.(value & opt (some string) None & info [name] ~docv:"DATE"
409
+
~doc:"ISO 8601 date (e.g., 2023, 2023-01, 2023-01-15)")
410
+
411
+
let note_arg =
412
+
Arg.(value & opt (some string) None & info ["note"] ~docv:"NOTE"
413
+
~doc:"Contextual note")
414
+
415
+
(* Add-service command arguments *)
416
+
let service_url_arg =
417
+
Arg.(required & pos 1 (some string) None & info [] ~docv:"URL"
418
+
~doc:"Service URL")
419
+
420
+
let service_kind_arg =
421
+
let kind_conv =
422
+
let parse s = match Contact.service_kind_of_string s with
423
+
| Some k -> Ok k
424
+
| None -> Error (`Msg (Printf.sprintf "Invalid service kind: %s" s))
425
+
in
426
+
let print ppf k = Format.pp_print_string ppf (Contact.service_kind_to_string k) in
427
+
Arg.conv (parse, print)
428
+
in
429
+
Arg.(value & opt (some kind_conv) None & info ["k"; "kind"] ~docv:"KIND"
430
+
~doc:"Service kind (github, git, social, activitypub, photo)")
431
+
432
+
let service_handle_arg =
433
+
Arg.(value & opt (some string) None & info ["handle"] ~docv:"HANDLE"
434
+
~doc:"Service handle/username")
435
+
436
+
let label_arg =
437
+
Arg.(value & opt (some string) None & info ["l"; "label"] ~docv:"LABEL"
438
+
~doc:"Human-readable label")
439
+
440
+
(* Add-org command arguments *)
441
+
let org_name_arg =
442
+
Arg.(required & pos 1 (some string) None & info [] ~docv:"ORG"
443
+
~doc:"Organization name")
444
+
445
+
let org_title_arg =
446
+
Arg.(value & opt (some string) None & info ["title"] ~docv:"TITLE"
447
+
~doc:"Job title")
448
+
449
+
let org_department_arg =
450
+
Arg.(value & opt (some string) None & info ["dept"; "department"] ~docv:"DEPT"
451
+
~doc:"Department")
452
+
453
+
let org_email_arg =
454
+
Arg.(value & opt (some string) None & info ["email"] ~docv:"EMAIL"
455
+
~doc:"Work email during this period")
456
+
457
+
let org_url_arg =
458
+
Arg.(value & opt (some string) None & info ["url"] ~docv:"URL"
459
+
~doc:"Work homepage during this period")
460
+
461
+
(* URL command arguments *)
462
+
let url_value_arg =
463
+
Arg.(required & pos 1 (some string) None & info [] ~docv:"URL"
464
+
~doc:"URL")
+235
lib/core/sortal_cmd.mli
+235
lib/core/sortal_cmd.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Cmdliner terms and commands for contact management.
7
+
8
+
This module provides ready-to-use Cmdliner terms for building
9
+
CLI applications that work with contact metadata. *)
10
+
11
+
module Contact = Sortal_schema.Contact
12
+
module Temporal = Sortal_schema.Temporal
13
+
14
+
(** {1 Command Implementations} *)
15
+
16
+
(** [list_cmd] is a Cmdliner command that lists all contacts.
17
+
18
+
Returns a function that takes an XDG context and returns an exit code. *)
19
+
val list_cmd : (Xdge.t -> int)
20
+
21
+
(** [show_cmd handle] creates a command to show detailed contact information.
22
+
23
+
@param handle The contact handle to display *)
24
+
val show_cmd : string -> (Xdge.t -> int)
25
+
26
+
(** [search_cmd query] creates a command to search contacts by name.
27
+
28
+
@param query The search query string *)
29
+
val search_cmd : string -> (Xdge.t -> int)
30
+
31
+
(** [stats_cmd] is a command that shows database statistics. *)
32
+
val stats_cmd : unit -> (Xdge.t -> int)
33
+
34
+
(** [sync_cmd] is a command that synchronizes and normalizes contact data.
35
+
36
+
Currently performs the following operations:
37
+
- Converts non-JPG thumbnail images to PNG using ImageMagick *)
38
+
val sync_cmd : unit -> (Xdge.t -> int)
39
+
40
+
(** [git_init_cmd xdg env] initializes a git repository in the data directory.
41
+
42
+
Once initialized, all contact modifications will be automatically committed.
43
+
@param xdg XDG context
44
+
@param env Eio environment for process spawning *)
45
+
val git_init_cmd : Xdge.t -> Eio_unix.Stdenv.base -> int
46
+
47
+
(** [add_cmd handle names kind email github url orcid xdg env] creates a new contact.
48
+
49
+
@param handle Contact handle (unique identifier)
50
+
@param names List of names (first is primary)
51
+
@param kind Optional contact kind
52
+
@param email Optional email address
53
+
@param github Optional GitHub handle
54
+
@param url Optional personal/professional website
55
+
@param orcid Optional ORCID identifier
56
+
@param xdg XDG context
57
+
@param env Eio environment for git operations *)
58
+
val add_cmd : string -> string list -> Contact.contact_kind option ->
59
+
string option -> string option -> string option -> string option ->
60
+
Xdge.t -> Eio_unix.Stdenv.base -> int
61
+
62
+
(** [delete_cmd handle xdg env] deletes a contact.
63
+
64
+
@param handle The contact handle to delete
65
+
@param xdg XDG context
66
+
@param env Eio environment for git operations *)
67
+
val delete_cmd : string -> Xdge.t -> Eio_unix.Stdenv.base -> int
68
+
69
+
(** [add_email_cmd handle address type_ from until note xdg env] adds an email to a contact.
70
+
71
+
@param handle Contact handle
72
+
@param address Email address
73
+
@param type_ Email type (work, personal, other)
74
+
@param from Start date of validity
75
+
@param until End date of validity
76
+
@param note Contextual note
77
+
@param xdg XDG context
78
+
@param env Eio environment for git operations *)
79
+
val add_email_cmd : string -> string -> Contact.email_type option ->
80
+
string option -> string option -> string option ->
81
+
Xdge.t -> Eio_unix.Stdenv.base -> int
82
+
83
+
(** [remove_email_cmd handle address xdg env] removes an email from a contact. *)
84
+
val remove_email_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int
85
+
86
+
(** [add_service_cmd handle url kind service_handle label xdg env] adds a service to a contact.
87
+
88
+
@param handle Contact handle
89
+
@param url Service URL
90
+
@param kind Service kind
91
+
@param service_handle Service username/handle
92
+
@param label Human-readable label
93
+
@param xdg XDG context
94
+
@param env Eio environment for git operations *)
95
+
val add_service_cmd : string -> string -> Contact.service_kind option ->
96
+
string option -> string option -> Xdge.t -> Eio_unix.Stdenv.base -> int
97
+
98
+
(** [remove_service_cmd handle url xdg env] removes a service from a contact. *)
99
+
val remove_service_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int
100
+
101
+
(** [add_org_cmd handle org_name title department from until org_email org_url xdg env]
102
+
adds an organization to a contact. *)
103
+
val add_org_cmd : string -> string -> string option -> string option ->
104
+
string option -> string option -> string option -> string option ->
105
+
Xdge.t -> Eio_unix.Stdenv.base -> int
106
+
107
+
(** [remove_org_cmd handle org_name xdg env] removes an organization from a contact. *)
108
+
val remove_org_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int
109
+
110
+
(** [add_url_cmd handle url label xdg env] adds a URL to a contact. *)
111
+
val add_url_cmd : string -> string -> string option -> Xdge.t -> Eio_unix.Stdenv.base -> int
112
+
113
+
(** [remove_url_cmd handle url xdg env] removes a URL from a contact. *)
114
+
val remove_url_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int
115
+
116
+
(** {1 Cmdliner Info Objects} *)
117
+
118
+
(** [list_info] is the command info for the list command. *)
119
+
val list_info : Cmdliner.Cmd.info
120
+
121
+
(** [show_info] is the command info for the show command. *)
122
+
val show_info : Cmdliner.Cmd.info
123
+
124
+
(** [search_info] is the command info for the search command. *)
125
+
val search_info : Cmdliner.Cmd.info
126
+
127
+
(** [stats_info] is the command info for the stats command. *)
128
+
val stats_info : Cmdliner.Cmd.info
129
+
130
+
(** [sync_info] is the command info for the sync command. *)
131
+
val sync_info : Cmdliner.Cmd.info
132
+
133
+
(** [git_init_info] is the command info for the git-init command. *)
134
+
val git_init_info : Cmdliner.Cmd.info
135
+
136
+
(** [add_info] is the command info for the add command. *)
137
+
val add_info : Cmdliner.Cmd.info
138
+
139
+
(** [delete_info] is the command info for the delete command. *)
140
+
val delete_info : Cmdliner.Cmd.info
141
+
142
+
(** [add_email_info] is the command info for the add-email command. *)
143
+
val add_email_info : Cmdliner.Cmd.info
144
+
145
+
(** [remove_email_info] is the command info for the remove-email command. *)
146
+
val remove_email_info : Cmdliner.Cmd.info
147
+
148
+
(** [add_service_info] is the command info for the add-service command. *)
149
+
val add_service_info : Cmdliner.Cmd.info
150
+
151
+
(** [remove_service_info] is the command info for the remove-service command. *)
152
+
val remove_service_info : Cmdliner.Cmd.info
153
+
154
+
(** [add_org_info] is the command info for the add-org command. *)
155
+
val add_org_info : Cmdliner.Cmd.info
156
+
157
+
(** [remove_org_info] is the command info for the remove-org command. *)
158
+
val remove_org_info : Cmdliner.Cmd.info
159
+
160
+
(** [add_url_info] is the command info for the add-url command. *)
161
+
val add_url_info : Cmdliner.Cmd.info
162
+
163
+
(** [remove_url_info] is the command info for the remove-url command. *)
164
+
val remove_url_info : Cmdliner.Cmd.info
165
+
166
+
(** {1 Cmdliner Argument Definitions} *)
167
+
168
+
(** [handle_arg] is the positional argument for a contact handle. *)
169
+
val handle_arg : string Cmdliner.Term.t
170
+
171
+
(** [query_arg] is the positional argument for a search query. *)
172
+
val query_arg : string Cmdliner.Term.t
173
+
174
+
(** [add_handle_arg] is the positional argument for a new contact handle. *)
175
+
val add_handle_arg : string Cmdliner.Term.t
176
+
177
+
(** [add_names_arg] is the repeatable option for contact names. *)
178
+
val add_names_arg : string list Cmdliner.Term.t
179
+
180
+
(** [add_kind_arg] is the optional argument for contact kind. *)
181
+
val add_kind_arg : Contact.contact_kind option Cmdliner.Term.t
182
+
183
+
(** [add_email_arg] is the optional argument for email. *)
184
+
val add_email_arg : string option Cmdliner.Term.t
185
+
186
+
(** [add_github_arg] is the optional argument for GitHub handle. *)
187
+
val add_github_arg : string option Cmdliner.Term.t
188
+
189
+
(** [add_url_arg] is the optional argument for URL. *)
190
+
val add_url_arg : string option Cmdliner.Term.t
191
+
192
+
(** [add_orcid_arg] is the optional argument for ORCID. *)
193
+
val add_orcid_arg : string option Cmdliner.Term.t
194
+
195
+
(** [email_address_arg] is the positional argument for email address. *)
196
+
val email_address_arg : string Cmdliner.Term.t
197
+
198
+
(** [email_type_arg] is the optional argument for email type. *)
199
+
val email_type_arg : Contact.email_type option Cmdliner.Term.t
200
+
201
+
(** [date_arg name] creates a date argument with the given option name. *)
202
+
val date_arg : string -> string option Cmdliner.Term.t
203
+
204
+
(** [note_arg] is the optional argument for notes. *)
205
+
val note_arg : string option Cmdliner.Term.t
206
+
207
+
(** [service_url_arg] is the positional argument for service URL. *)
208
+
val service_url_arg : string Cmdliner.Term.t
209
+
210
+
(** [service_kind_arg] is the optional argument for service kind. *)
211
+
val service_kind_arg : Contact.service_kind option Cmdliner.Term.t
212
+
213
+
(** [service_handle_arg] is the optional argument for service handle. *)
214
+
val service_handle_arg : string option Cmdliner.Term.t
215
+
216
+
(** [label_arg] is the optional argument for labels. *)
217
+
val label_arg : string option Cmdliner.Term.t
218
+
219
+
(** [org_name_arg] is the positional argument for organization name. *)
220
+
val org_name_arg : string Cmdliner.Term.t
221
+
222
+
(** [org_title_arg] is the optional argument for job title. *)
223
+
val org_title_arg : string option Cmdliner.Term.t
224
+
225
+
(** [org_department_arg] is the optional argument for department. *)
226
+
val org_department_arg : string option Cmdliner.Term.t
227
+
228
+
(** [org_email_arg] is the optional argument for work email. *)
229
+
val org_email_arg : string option Cmdliner.Term.t
230
+
231
+
(** [org_url_arg] is the optional argument for work URL. *)
232
+
val org_url_arg : string option Cmdliner.Term.t
233
+
234
+
(** [url_value_arg] is the positional argument for URL. *)
235
+
val url_value_arg : string Cmdliner.Term.t
+233
lib/core/sortal_git_store.ml
+233
lib/core/sortal_git_store.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Contact = Sortal_schema.Contact
7
+
8
+
type t = {
9
+
store : Sortal_store.t;
10
+
env : Eio_unix.Stdenv.base;
11
+
}
12
+
13
+
let create store env = { store; env }
14
+
15
+
let store t = t.store
16
+
17
+
(* Helper to check if a string contains a substring *)
18
+
let contains_substring ~needle haystack =
19
+
try
20
+
let _ = Str.search_forward (Str.regexp_string needle) haystack 0 in
21
+
true
22
+
with Not_found -> false
23
+
24
+
(* Helper to get the data directory path as a native string *)
25
+
let data_dir_path t =
26
+
(* We need to extract the data directory from the store somehow.
27
+
For now, we'll use the XDG environment to locate it. *)
28
+
let xdg = Xdge.create t.env#fs "sortal" in
29
+
let data_path = Xdge.data_dir xdg in
30
+
Eio.Path.native_exn data_path
31
+
32
+
(* Execute a git command in the data directory *)
33
+
let run_git t args =
34
+
let data_dir = data_dir_path t in
35
+
Eio.Switch.run @@ fun sw ->
36
+
try
37
+
let mgr = t.env#process_mgr in
38
+
let cmd = ["git"; "-C"; data_dir] @ args in
39
+
let proc = Eio.Process.spawn ~sw mgr cmd in
40
+
match Eio.Process.await proc with
41
+
| `Exited 0 -> Ok ()
42
+
| `Exited n -> Error (Printf.sprintf "git %s exited with code %d" (String.concat " " args) n)
43
+
| `Signaled n -> Error (Printf.sprintf "git killed by signal %d" n)
44
+
with
45
+
| exn ->
46
+
let msg = Printexc.to_string exn in
47
+
if contains_substring ~needle:"not found" msg ||
48
+
contains_substring ~needle:"No such file" msg then
49
+
Error "git executable not found - please install git"
50
+
else
51
+
Error (Printf.sprintf "git command failed: %s" msg)
52
+
53
+
let is_initialized t =
54
+
let data_dir = data_dir_path t in
55
+
let git_dir = Filename.concat data_dir ".git" in
56
+
Sys.file_exists git_dir && Sys.is_directory git_dir
57
+
58
+
let init t =
59
+
if is_initialized t then
60
+
Ok ()
61
+
else begin
62
+
match run_git t ["init"] with
63
+
| Error _ as e -> e
64
+
| Ok () ->
65
+
(* Create initial commit *)
66
+
match run_git t ["add"; "."] with
67
+
| Error _ as e -> e
68
+
| Ok () ->
69
+
let msg = "Initialize sortal contact database" in
70
+
run_git t ["commit"; "--allow-empty"; "-m"; msg]
71
+
end
72
+
73
+
(* Helper to commit a file with a message *)
74
+
let commit_file t filename msg =
75
+
match run_git t ["add"; filename] with
76
+
| Error _ as e -> e
77
+
| Ok () ->
78
+
run_git t ["commit"; "-m"; msg]
79
+
80
+
(* Helper to commit a deletion *)
81
+
let commit_deletion t filename msg =
82
+
match run_git t ["rm"; filename] with
83
+
| Error _ as e -> e
84
+
| Ok () ->
85
+
run_git t ["commit"; "-m"; msg]
86
+
87
+
let save t contact =
88
+
let handle = Contact.handle contact in
89
+
let name = Contact.name contact in
90
+
let filename = handle ^ ".yaml" in
91
+
92
+
(* Check if contact already exists *)
93
+
let is_new = match Sortal_store.lookup t.store handle with
94
+
| None -> true
95
+
| Some _ -> false
96
+
in
97
+
98
+
(* Save to store *)
99
+
Sortal_store.save t.store contact;
100
+
101
+
(* Commit to git *)
102
+
if not (is_initialized t) then
103
+
Ok ()
104
+
else
105
+
let msg = if is_new then
106
+
Printf.sprintf "Add contact @%s (%s)" handle name
107
+
else
108
+
Printf.sprintf "Update contact @%s (%s)" handle name
109
+
in
110
+
commit_file t filename msg
111
+
112
+
let delete t handle =
113
+
match Sortal_store.lookup t.store handle with
114
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
115
+
| Some contact ->
116
+
let name = Contact.name contact in
117
+
let filename = handle ^ ".yaml" in
118
+
119
+
(* Delete from store *)
120
+
Sortal_store.delete t.store handle;
121
+
122
+
(* Commit deletion to git *)
123
+
if not (is_initialized t) then
124
+
Ok ()
125
+
else
126
+
let msg = Printf.sprintf "Delete contact @%s (%s)" handle name in
127
+
commit_deletion t filename msg
128
+
129
+
let update_contact t handle f ~msg =
130
+
match Sortal_store.update_contact t.store handle f with
131
+
| Error _ as e -> e
132
+
| Ok () ->
133
+
if not (is_initialized t) then
134
+
Ok ()
135
+
else
136
+
let filename = handle ^ ".yaml" in
137
+
commit_file t filename msg
138
+
139
+
let add_email t handle (email : Contact.email) =
140
+
let msg = Printf.sprintf "Update @%s: add email %s"
141
+
handle email.address in
142
+
match Sortal_store.add_email t.store handle email with
143
+
| Error _ as e -> e
144
+
| Ok () ->
145
+
if not (is_initialized t) then
146
+
Ok ()
147
+
else
148
+
let filename = handle ^ ".yaml" in
149
+
commit_file t filename msg
150
+
151
+
let remove_email t handle address =
152
+
let msg = Printf.sprintf "Update @%s: remove email %s" handle address in
153
+
match Sortal_store.remove_email t.store handle address with
154
+
| Error _ as e -> e
155
+
| Ok () ->
156
+
if not (is_initialized t) then
157
+
Ok ()
158
+
else
159
+
let filename = handle ^ ".yaml" in
160
+
commit_file t filename msg
161
+
162
+
let add_service t handle (service : Contact.service) =
163
+
let kind_str = match service.kind with
164
+
| Some k -> Contact.service_kind_to_string k
165
+
| None -> "unknown"
166
+
in
167
+
let msg = Printf.sprintf "Update @%s: add service %s (%s)"
168
+
handle kind_str service.url in
169
+
match Sortal_store.add_service t.store handle service with
170
+
| Error _ as e -> e
171
+
| Ok () ->
172
+
if not (is_initialized t) then
173
+
Ok ()
174
+
else
175
+
let filename = handle ^ ".yaml" in
176
+
commit_file t filename msg
177
+
178
+
let remove_service t handle url =
179
+
let msg = Printf.sprintf "Update @%s: remove service %s" handle url in
180
+
match Sortal_store.remove_service t.store handle url with
181
+
| Error _ as e -> e
182
+
| Ok () ->
183
+
if not (is_initialized t) then
184
+
Ok ()
185
+
else
186
+
let filename = handle ^ ".yaml" in
187
+
commit_file t filename msg
188
+
189
+
let add_organization t handle (org : Contact.organization) =
190
+
let msg = Printf.sprintf "Update @%s: add organization %s"
191
+
handle org.name in
192
+
match Sortal_store.add_organization t.store handle org with
193
+
| Error _ as e -> e
194
+
| Ok () ->
195
+
if not (is_initialized t) then
196
+
Ok ()
197
+
else
198
+
let filename = handle ^ ".yaml" in
199
+
commit_file t filename msg
200
+
201
+
let remove_organization t handle name =
202
+
let msg = Printf.sprintf "Update @%s: remove organization %s" handle name in
203
+
match Sortal_store.remove_organization t.store handle name with
204
+
| Error _ as e -> e
205
+
| Ok () ->
206
+
if not (is_initialized t) then
207
+
Ok ()
208
+
else
209
+
let filename = handle ^ ".yaml" in
210
+
commit_file t filename msg
211
+
212
+
let add_url t handle (url_entry : Contact.url_entry) =
213
+
let msg = Printf.sprintf "Update @%s: add URL %s"
214
+
handle url_entry.url in
215
+
match Sortal_store.add_url t.store handle url_entry with
216
+
| Error _ as e -> e
217
+
| Ok () ->
218
+
if not (is_initialized t) then
219
+
Ok ()
220
+
else
221
+
let filename = handle ^ ".yaml" in
222
+
commit_file t filename msg
223
+
224
+
let remove_url t handle url =
225
+
let msg = Printf.sprintf "Update @%s: remove URL %s" handle url in
226
+
match Sortal_store.remove_url t.store handle url with
227
+
| Error _ as e -> e
228
+
| Ok () ->
229
+
if not (is_initialized t) then
230
+
Ok ()
231
+
else
232
+
let filename = handle ^ ".yaml" in
233
+
commit_file t filename msg
+116
lib/core/sortal_git_store.mli
+116
lib/core/sortal_git_store.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Git-backed contact store with automatic version control.
7
+
8
+
This module wraps {!Sortal_store} to provide automatic git versioning
9
+
of all contact modifications. Each change (add, update, delete) is
10
+
automatically committed to a git repository with descriptive commit
11
+
messages. *)
12
+
13
+
module Contact = Sortal_schema.Contact
14
+
15
+
type t
16
+
(** A git-backed contact store. *)
17
+
18
+
(** {1 Creation and Initialization} *)
19
+
20
+
val create : Sortal_store.t -> Eio_unix.Stdenv.base -> t
21
+
(** [create store env] creates a git-backed store wrapping [store].
22
+
23
+
@param store The underlying contact store
24
+
@param env The Eio environment for spawning git processes *)
25
+
26
+
val init : t -> (unit, string) result
27
+
(** [init t] initializes a git repository in the data directory.
28
+
29
+
Creates a new git repository with an initial commit if one doesn't exist.
30
+
Safe to call multiple times - returns [Ok ()] if already initialized.
31
+
32
+
@return [Ok ()] if initialized successfully or already initialized,
33
+
[Error msg] if git initialization fails *)
34
+
35
+
val is_initialized : t -> bool
36
+
(** [is_initialized t] checks if the data directory is a git repository.
37
+
38
+
@return [true] if a .git directory exists, [false] otherwise *)
39
+
40
+
(** {1 Contact Operations} *)
41
+
42
+
val save : t -> Contact.t -> (unit, string) result
43
+
(** [save t contact] saves a contact and commits the change to git.
44
+
45
+
If the contact is new, commits with message "Add contact @handle (Name)".
46
+
If updating an existing contact, commits with "Update contact @handle (Name)".
47
+
48
+
@param contact The contact to save *)
49
+
50
+
val delete : t -> string -> (unit, string) result
51
+
(** [delete t handle] deletes a contact and commits the removal to git.
52
+
53
+
Commits with message "Delete contact @handle (Name)".
54
+
55
+
@param handle The contact handle to delete
56
+
@return [Error msg] if contact not found *)
57
+
58
+
(** {1 Contact Modification} *)
59
+
60
+
val add_email : t -> string -> Contact.email -> (unit, string) result
61
+
(** [add_email t handle email] adds an email to a contact and commits.
62
+
63
+
Commits with message "Update @handle: add email address@example.com". *)
64
+
65
+
val remove_email : t -> string -> string -> (unit, string) result
66
+
(** [remove_email t handle address] removes an email and commits.
67
+
68
+
Commits with message "Update @handle: remove email address@example.com". *)
69
+
70
+
val add_service : t -> string -> Contact.service -> (unit, string) result
71
+
(** [add_service t handle service] adds a service to a contact and commits.
72
+
73
+
Commits with message "Update @handle: add service Kind (url)". *)
74
+
75
+
val remove_service : t -> string -> string -> (unit, string) result
76
+
(** [remove_service t handle url] removes a service and commits.
77
+
78
+
Commits with message "Update @handle: remove service url". *)
79
+
80
+
val add_organization : t -> string -> Contact.organization -> (unit, string) result
81
+
(** [add_organization t handle org] adds an organization and commits.
82
+
83
+
Commits with message "Update @handle: add organization Org Name". *)
84
+
85
+
val remove_organization : t -> string -> string -> (unit, string) result
86
+
(** [remove_organization t handle name] removes an organization and commits.
87
+
88
+
Commits with message "Update @handle: remove organization Org Name". *)
89
+
90
+
val add_url : t -> string -> Contact.url_entry -> (unit, string) result
91
+
(** [add_url t handle url_entry] adds a URL and commits.
92
+
93
+
Commits with message "Update @handle: add URL url". *)
94
+
95
+
val remove_url : t -> string -> string -> (unit, string) result
96
+
(** [remove_url t handle url] removes a URL and commits.
97
+
98
+
Commits with message "Update @handle: remove URL url". *)
99
+
100
+
(** {1 Low-level Operations} *)
101
+
102
+
val update_contact : t -> string -> (Contact.t -> Contact.t) ->
103
+
msg:string -> (unit, string) result
104
+
(** [update_contact t handle f ~msg] updates a contact and commits with custom message.
105
+
106
+
This is a low-level function that applies transformation [f] to the contact
107
+
and commits with the provided commit message.
108
+
109
+
@param handle The contact handle
110
+
@param f Function to transform the contact
111
+
@param msg The git commit message *)
112
+
113
+
val store : t -> Sortal_store.t
114
+
(** [store t] returns the underlying contact store.
115
+
116
+
Use this when you need direct store access without git commits. *)
+370
lib/core/sortal_store.ml
+370
lib/core/sortal_store.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Contact = Sortal_schema.Contact
7
+
module Temporal = Sortal_schema.Temporal
8
+
9
+
type t = {
10
+
xdg : Xdge.t; [@warning "-69"]
11
+
data_dir : Eio.Fs.dir_ty Eio.Path.t;
12
+
}
13
+
14
+
let create fs app_name =
15
+
let xdg = Xdge.create fs app_name in
16
+
let data_dir = Xdge.data_dir xdg in
17
+
{ xdg; data_dir }
18
+
19
+
let create_from_xdg xdg =
20
+
let data_dir = Xdge.data_dir xdg in
21
+
{ xdg; data_dir }
22
+
23
+
let contact_file t handle =
24
+
Eio.Path.(t.data_dir / (handle ^ ".yaml"))
25
+
26
+
let save t contact =
27
+
let path = contact_file t (Contact.handle contact) in
28
+
let buf = Buffer.create 4096 in
29
+
let writer = Bytesrw.Bytes.Writer.of_buffer buf in
30
+
match Yamlt.encode Contact.json_t contact ~eod:true writer with
31
+
| Ok () -> Eio.Path.save ~create:(`Or_truncate 0o644) path (Buffer.contents buf)
32
+
| Error err -> failwith ("Failed to encode contact: " ^ err)
33
+
34
+
let lookup t handle =
35
+
let path = contact_file t handle in
36
+
try
37
+
let yaml_str = Eio.Path.load path in
38
+
let reader = Bytesrw.Bytes.Reader.of_string yaml_str in
39
+
match Yamlt.decode Contact.json_t reader with
40
+
| Ok contact -> Some contact
41
+
| Error msg ->
42
+
Logs.warn (fun m -> m "Failed to decode contact %s: %s" handle msg);
43
+
None
44
+
with exn ->
45
+
Logs.warn (fun m -> m "Failed to load contact %s: %s" handle (Printexc.to_string exn));
46
+
None
47
+
48
+
let delete t handle =
49
+
let path = contact_file t handle in
50
+
try
51
+
Eio.Path.unlink path
52
+
with
53
+
| _ -> ()
54
+
55
+
(* Contact modification helpers *)
56
+
let update_contact t handle f =
57
+
match lookup t handle with
58
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
59
+
| Some contact ->
60
+
let updated = f contact in
61
+
save t updated;
62
+
Ok ()
63
+
64
+
let add_email t handle (email : Contact.email) =
65
+
match lookup t handle with
66
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
67
+
| Some contact ->
68
+
let emails = Contact.emails contact in
69
+
(* Check for duplicate email address *)
70
+
if List.exists (fun (e : Contact.email) -> e.address = email.address) emails then
71
+
Error (Printf.sprintf "Email %s already exists for contact @%s" email.address handle)
72
+
else
73
+
update_contact t handle (fun contact ->
74
+
let emails = Contact.emails contact in
75
+
Contact.make
76
+
~handle:(Contact.handle contact)
77
+
~names:(Contact.names contact)
78
+
~kind:(Contact.kind contact)
79
+
~emails:(emails @ [email])
80
+
~organizations:(Contact.organizations contact)
81
+
~urls:(Contact.urls contact)
82
+
~services:(Contact.services contact)
83
+
?icon:(Contact.icon contact)
84
+
?thumbnail:(Contact.thumbnail contact)
85
+
?orcid:(Contact.orcid contact)
86
+
?feeds:(Contact.feeds contact)
87
+
()
88
+
)
89
+
90
+
let remove_email t handle address =
91
+
update_contact t handle (fun contact ->
92
+
let emails = Contact.emails contact
93
+
|> List.filter (fun (e : Contact.email) -> e.address <> address) in
94
+
Contact.make
95
+
~handle:(Contact.handle contact)
96
+
~names:(Contact.names contact)
97
+
~kind:(Contact.kind contact)
98
+
~emails
99
+
~organizations:(Contact.organizations contact)
100
+
~urls:(Contact.urls contact)
101
+
~services:(Contact.services contact)
102
+
?icon:(Contact.icon contact)
103
+
?thumbnail:(Contact.thumbnail contact)
104
+
?orcid:(Contact.orcid contact)
105
+
?feeds:(Contact.feeds contact)
106
+
()
107
+
)
108
+
109
+
let add_service t handle (service : Contact.service) =
110
+
match lookup t handle with
111
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
112
+
| Some contact ->
113
+
let services = Contact.services contact in
114
+
(* Check for duplicate service URL *)
115
+
if List.exists (fun (s : Contact.service) -> s.url = service.url) services then
116
+
Error (Printf.sprintf "Service URL %s already exists for contact @%s" service.url handle)
117
+
else
118
+
update_contact t handle (fun contact ->
119
+
let services = Contact.services contact in
120
+
Contact.make
121
+
~handle:(Contact.handle contact)
122
+
~names:(Contact.names contact)
123
+
~kind:(Contact.kind contact)
124
+
~emails:(Contact.emails contact)
125
+
~organizations:(Contact.organizations contact)
126
+
~urls:(Contact.urls contact)
127
+
~services:(services @ [service])
128
+
?icon:(Contact.icon contact)
129
+
?thumbnail:(Contact.thumbnail contact)
130
+
?orcid:(Contact.orcid contact)
131
+
?feeds:(Contact.feeds contact)
132
+
()
133
+
)
134
+
135
+
let remove_service t handle url =
136
+
update_contact t handle (fun contact ->
137
+
let services = Contact.services contact
138
+
|> List.filter (fun (s : Contact.service) -> s.url <> url) in
139
+
Contact.make
140
+
~handle:(Contact.handle contact)
141
+
~names:(Contact.names contact)
142
+
~kind:(Contact.kind contact)
143
+
~emails:(Contact.emails contact)
144
+
~organizations:(Contact.organizations contact)
145
+
~urls:(Contact.urls contact)
146
+
~services
147
+
?icon:(Contact.icon contact)
148
+
?thumbnail:(Contact.thumbnail contact)
149
+
?orcid:(Contact.orcid contact)
150
+
?feeds:(Contact.feeds contact)
151
+
()
152
+
)
153
+
154
+
let add_organization t handle (org : Contact.organization) =
155
+
match lookup t handle with
156
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
157
+
| Some contact ->
158
+
let orgs = Contact.organizations contact in
159
+
(* Check for exact duplicate organization (same name, title, and department) *)
160
+
let is_duplicate = List.exists (fun (o : Contact.organization) ->
161
+
o.name = org.name &&
162
+
o.title = org.title &&
163
+
o.department = org.department
164
+
) orgs in
165
+
if is_duplicate then
166
+
Error (Printf.sprintf "Organization %s with the same title/department already exists for contact @%s" org.name handle)
167
+
else
168
+
update_contact t handle (fun contact ->
169
+
let orgs = Contact.organizations contact in
170
+
Contact.make
171
+
~handle:(Contact.handle contact)
172
+
~names:(Contact.names contact)
173
+
~kind:(Contact.kind contact)
174
+
~emails:(Contact.emails contact)
175
+
~organizations:(orgs @ [org])
176
+
~urls:(Contact.urls contact)
177
+
~services:(Contact.services contact)
178
+
?icon:(Contact.icon contact)
179
+
?thumbnail:(Contact.thumbnail contact)
180
+
?orcid:(Contact.orcid contact)
181
+
?feeds:(Contact.feeds contact)
182
+
()
183
+
)
184
+
185
+
let remove_organization t handle name =
186
+
update_contact t handle (fun contact ->
187
+
let orgs = Contact.organizations contact
188
+
|> List.filter (fun (o : Contact.organization) -> o.name <> name) in
189
+
Contact.make
190
+
~handle:(Contact.handle contact)
191
+
~names:(Contact.names contact)
192
+
~kind:(Contact.kind contact)
193
+
~emails:(Contact.emails contact)
194
+
~organizations:orgs
195
+
~urls:(Contact.urls contact)
196
+
~services:(Contact.services contact)
197
+
?icon:(Contact.icon contact)
198
+
?thumbnail:(Contact.thumbnail contact)
199
+
?orcid:(Contact.orcid contact)
200
+
?feeds:(Contact.feeds contact)
201
+
()
202
+
)
203
+
204
+
let add_url t handle (url_entry : Contact.url_entry) =
205
+
match lookup t handle with
206
+
| None -> Error (Printf.sprintf "Contact not found: %s" handle)
207
+
| Some contact ->
208
+
let urls = Contact.urls contact in
209
+
(* Check for duplicate URL *)
210
+
if List.exists (fun (u : Contact.url_entry) -> u.url = url_entry.url) urls then
211
+
Error (Printf.sprintf "URL %s already exists for contact @%s" url_entry.url handle)
212
+
else
213
+
update_contact t handle (fun contact ->
214
+
let urls = Contact.urls contact in
215
+
Contact.make
216
+
~handle:(Contact.handle contact)
217
+
~names:(Contact.names contact)
218
+
~kind:(Contact.kind contact)
219
+
~emails:(Contact.emails contact)
220
+
~organizations:(Contact.organizations contact)
221
+
~urls:(urls @ [url_entry])
222
+
~services:(Contact.services contact)
223
+
?icon:(Contact.icon contact)
224
+
?thumbnail:(Contact.thumbnail contact)
225
+
?orcid:(Contact.orcid contact)
226
+
?feeds:(Contact.feeds contact)
227
+
()
228
+
)
229
+
230
+
let remove_url t handle url =
231
+
update_contact t handle (fun contact ->
232
+
let urls = Contact.urls contact
233
+
|> List.filter (fun (u : Contact.url_entry) -> u.url <> url) in
234
+
Contact.make
235
+
~handle:(Contact.handle contact)
236
+
~names:(Contact.names contact)
237
+
~kind:(Contact.kind contact)
238
+
~emails:(Contact.emails contact)
239
+
~organizations:(Contact.organizations contact)
240
+
~urls
241
+
~services:(Contact.services contact)
242
+
?icon:(Contact.icon contact)
243
+
?thumbnail:(Contact.thumbnail contact)
244
+
?orcid:(Contact.orcid contact)
245
+
?feeds:(Contact.feeds contact)
246
+
()
247
+
)
248
+
249
+
let list t =
250
+
try
251
+
let entries = Eio.Path.read_dir t.data_dir in
252
+
List.filter_map (fun entry ->
253
+
if Filename.check_suffix entry ".yaml" then
254
+
let handle = Filename.chop_suffix entry ".yaml" in
255
+
lookup t handle
256
+
else
257
+
None
258
+
) entries
259
+
with
260
+
| _ -> []
261
+
262
+
let thumbnail_path t contact =
263
+
Contact.thumbnail contact
264
+
|> Option.map (fun relative_path -> Eio.Path.(t.data_dir / relative_path))
265
+
266
+
let png_thumbnail_path t contact =
267
+
match Contact.thumbnail contact with
268
+
| None -> None
269
+
| Some relative_path ->
270
+
let base = Filename.remove_extension relative_path in
271
+
let png_path = base ^ ".png" in
272
+
let full_path = Eio.Path.(t.data_dir / png_path) in
273
+
try
274
+
ignore (Eio.Path.load full_path);
275
+
Some full_path
276
+
with _ -> None
277
+
278
+
let handle_of_name name =
279
+
let name = String.lowercase_ascii name in
280
+
let words = String.split_on_char ' ' name in
281
+
let initials = String.concat "" (List.map (fun w -> String.sub w 0 1) words) in
282
+
initials ^ List.hd (List.rev words)
283
+
284
+
let find_by_name t name =
285
+
let name_lower = String.lowercase_ascii name in
286
+
let all_contacts = list t in
287
+
let matches = List.filter (fun c ->
288
+
List.exists (fun n -> String.lowercase_ascii n = name_lower)
289
+
(Contact.names c)
290
+
) all_contacts in
291
+
match matches with
292
+
| [contact] -> contact
293
+
| [] -> raise Not_found
294
+
| _ -> raise (Invalid_argument ("Multiple contacts match: " ^ name))
295
+
296
+
let find_by_name_opt t name =
297
+
try
298
+
Some (find_by_name t name)
299
+
with
300
+
| Not_found | Invalid_argument _ -> None
301
+
302
+
let contains_substring ~needle haystack =
303
+
let needle_len = String.length needle in
304
+
let haystack_len = String.length haystack in
305
+
if needle_len = 0 then true
306
+
else if needle_len > haystack_len then false
307
+
else
308
+
let rec check i =
309
+
if i > haystack_len - needle_len then false
310
+
else if String.sub haystack i needle_len = needle then true
311
+
else check (i + 1)
312
+
in
313
+
check 0
314
+
315
+
let search_all t query =
316
+
let query_lower = String.lowercase_ascii query in
317
+
let all = list t in
318
+
let matches = List.filter (fun c ->
319
+
List.exists (fun name ->
320
+
let name_lower = String.lowercase_ascii name in
321
+
String.equal name_lower query_lower ||
322
+
String.starts_with ~prefix:query_lower name_lower ||
323
+
contains_substring ~needle:query_lower name_lower ||
324
+
(String.contains name_lower ' ' &&
325
+
String.split_on_char ' ' name_lower |> List.exists (fun word ->
326
+
String.starts_with ~prefix:query_lower word
327
+
))
328
+
) (Contact.names c)
329
+
) all in
330
+
List.sort Contact.compare matches
331
+
332
+
let find_by_email_at t ~email ~date =
333
+
let all = list t in
334
+
List.find_opt (fun c ->
335
+
let emails_at_date = Contact.emails_at c ~date in
336
+
List.exists (fun e -> e.Contact.address = email) emails_at_date
337
+
) all
338
+
339
+
let find_by_org t ~org ?from ?until () =
340
+
let org_lower = String.lowercase_ascii org in
341
+
let all = list t in
342
+
let matches = List.filter (fun c ->
343
+
let orgs : Contact.organization list = Contact.organizations c in
344
+
let filtered_orgs = match from, until with
345
+
| None, None -> orgs
346
+
| _, _ -> Temporal.filter ~get:(fun (o : Contact.organization) -> o.range)
347
+
~from ~until orgs
348
+
in
349
+
List.exists (fun (o : Contact.organization) ->
350
+
contains_substring ~needle:org_lower
351
+
(String.lowercase_ascii o.name)
352
+
) filtered_orgs
353
+
) all in
354
+
List.sort Contact.compare matches
355
+
356
+
let list_at t ~date =
357
+
let all = list t in
358
+
List.filter (fun c ->
359
+
(* Contact is active if it has any email, org, or URL valid at date *)
360
+
let has_email = Contact.emails_at c ~date <> [] in
361
+
let has_org = Contact.organization_at c ~date <> None in
362
+
let has_url = Contact.url_at c ~date <> None in
363
+
has_email || has_org || has_url
364
+
) all
365
+
366
+
let pp ppf t =
367
+
let all = list t in
368
+
Fmt.pf ppf "@[<v>%a: %d contacts stored in XDG data directory@]"
369
+
(Fmt.styled `Bold Fmt.string) "Sortal Store"
370
+
(List.length all)
+261
lib/core/sortal_store.mli
+261
lib/core/sortal_store.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Contact store with XDG-compliant storage.
7
+
8
+
The contact store manages reading and writing contact metadata
9
+
using XDG-compliant storage locations. Contacts are stored as
10
+
YAML files (one per contact) using the handle as the filename. *)
11
+
12
+
module Contact = Sortal_schema.Contact
13
+
module Temporal = Sortal_schema.Temporal
14
+
15
+
type t
16
+
17
+
(** [create fs app_name] creates a new contact store.
18
+
19
+
The store will use XDG data directories for persistent storage
20
+
of contact metadata. Each contact is stored as a separate YAML
21
+
file named after its handle.
22
+
23
+
@param fs Eio filesystem for file operations
24
+
@param app_name Application name for XDG directory structure *)
25
+
val create : Eio.Fs.dir_ty Eio.Path.t -> string -> t
26
+
27
+
(** [create_from_xdg xdg] creates a contact store from an XDG context.
28
+
29
+
This is a convenience function for creating a store when you already
30
+
have an XDG context (e.g., from your own XDG initialization).
31
+
The store will use the XDG data directory for the application.
32
+
33
+
@param xdg An existing XDG context
34
+
@return A contact store using the XDG data directory *)
35
+
val create_from_xdg : Xdge.t -> t
36
+
37
+
(** {1 Storage Operations} *)
38
+
39
+
(** [save t contact] saves a contact to the store.
40
+
41
+
The contact is serialized to YAML and written to a file
42
+
named "handle.yaml" in the XDG data directory.
43
+
44
+
If a contact with the same handle already exists, it is overwritten. *)
45
+
val save : t -> Contact.t -> unit
46
+
47
+
(** [lookup t handle] retrieves a contact by handle.
48
+
49
+
Searches for a file named "handle.yaml" in the XDG data directory
50
+
and deserializes it if found.
51
+
52
+
@return [Some contact] if found, [None] if not found or deserialization fails *)
53
+
val lookup : t -> string -> Contact.t option
54
+
55
+
(** [delete t handle] removes a contact from the store.
56
+
57
+
Deletes the file "handle.yaml" from the XDG data directory.
58
+
Does nothing if the contact does not exist. *)
59
+
val delete : t -> string -> unit
60
+
61
+
(** {1 Contact Modification} *)
62
+
63
+
(** [add_email t handle email] adds an email to an existing contact.
64
+
65
+
@param t The store
66
+
@param handle The contact handle
67
+
@param email The email entry to add
68
+
@return [Ok ()] on success, [Error msg] if contact not found
69
+
@raise Failure if the contact cannot be saved *)
70
+
val add_email : t -> string -> Contact.email -> (unit, string) result
71
+
72
+
(** [remove_email t handle address] removes an email from a contact.
73
+
74
+
Removes all email entries with the given address.
75
+
76
+
@param t The store
77
+
@param handle The contact handle
78
+
@param address The email address to remove
79
+
@return [Ok ()] on success, [Error msg] if contact not found *)
80
+
val remove_email : t -> string -> string -> (unit, string) result
81
+
82
+
(** [add_service t handle service] adds a service to an existing contact.
83
+
84
+
@param t The store
85
+
@param handle The contact handle
86
+
@param service The service entry to add
87
+
@return [Ok ()] on success, [Error msg] if contact not found *)
88
+
val add_service : t -> string -> Contact.service -> (unit, string) result
89
+
90
+
(** [remove_service t handle url] removes a service from a contact.
91
+
92
+
Removes all service entries with the given URL.
93
+
94
+
@param t The store
95
+
@param handle The contact handle
96
+
@param url The service URL to remove
97
+
@return [Ok ()] on success, [Error msg] if contact not found *)
98
+
val remove_service : t -> string -> string -> (unit, string) result
99
+
100
+
(** [add_organization t handle org] adds an organization to an existing contact.
101
+
102
+
@param t The store
103
+
@param handle The contact handle
104
+
@param org The organization entry to add
105
+
@return [Ok ()] on success, [Error msg] if contact not found *)
106
+
val add_organization : t -> string -> Contact.organization -> (unit, string) result
107
+
108
+
(** [remove_organization t handle name] removes an organization from a contact.
109
+
110
+
Removes all organization entries with the given name.
111
+
112
+
@param t The store
113
+
@param handle The contact handle
114
+
@param name The organization name to remove
115
+
@return [Ok ()] on success, [Error msg] if contact not found *)
116
+
val remove_organization : t -> string -> string -> (unit, string) result
117
+
118
+
(** [add_url t handle url_entry] adds a URL to an existing contact.
119
+
120
+
@param t The store
121
+
@param handle The contact handle
122
+
@param url_entry The URL entry to add
123
+
@return [Ok ()] on success, [Error msg] if contact not found *)
124
+
val add_url : t -> string -> Contact.url_entry -> (unit, string) result
125
+
126
+
(** [remove_url t handle url] removes a URL from a contact.
127
+
128
+
Removes all URL entries with the given URL.
129
+
130
+
@param t The store
131
+
@param handle The contact handle
132
+
@param url The URL to remove
133
+
@return [Ok ()] on success, [Error msg] if contact not found *)
134
+
val remove_url : t -> string -> string -> (unit, string) result
135
+
136
+
(** [update_contact t handle f] updates a contact by applying function [f].
137
+
138
+
Looks up the contact, applies [f] to transform it, and saves the result.
139
+
140
+
@param t The store
141
+
@param handle The contact handle
142
+
@param f Function to transform the contact
143
+
@return [Ok ()] on success, [Error msg] if contact not found *)
144
+
val update_contact : t -> string -> (Contact.t -> Contact.t) -> (unit, string) result
145
+
146
+
(** [list t] returns all contacts in the store.
147
+
148
+
Scans the XDG data directory for all .yaml files and attempts
149
+
to deserialize them as contacts. Files that fail to parse are
150
+
silently skipped.
151
+
152
+
@return A list of all successfully loaded contacts *)
153
+
val list : t -> Contact.t list
154
+
155
+
(** [thumbnail_path t contact] returns the absolute filesystem path to the contact's thumbnail.
156
+
157
+
Returns [None] if the contact has no thumbnail set, or [Some path] with
158
+
the full path to the thumbnail file in Sortal's data directory.
159
+
160
+
@param t The Sortal store
161
+
@param contact The contact whose thumbnail path to retrieve *)
162
+
val thumbnail_path : t -> Contact.t -> Eio.Fs.dir_ty Eio.Path.t option
163
+
164
+
(** [png_thumbnail_path t contact] returns the path to the PNG version of the contact's thumbnail.
165
+
166
+
Returns [None] if the contact has no thumbnail set or if no PNG version exists.
167
+
This looks for a .png file with the same base name as the contact's thumbnail.
168
+
Use this after running [sync] to get the converted PNG thumbnails.
169
+
170
+
@param t The Sortal store
171
+
@param contact The contact whose PNG thumbnail path to retrieve *)
172
+
val png_thumbnail_path : t -> Contact.t -> Eio.Fs.dir_ty Eio.Path.t option
173
+
174
+
(** {1 Searching} *)
175
+
176
+
(** [find_by_name t name] searches for contacts by name.
177
+
178
+
Performs a case-insensitive search through all contacts,
179
+
checking if any of their names match the provided name.
180
+
181
+
@param name The name to search for (case-insensitive)
182
+
@return The matching contact if exactly one match is found
183
+
@raise Not_found if no contacts match the name
184
+
@raise Invalid_argument if multiple contacts match the name *)
185
+
val find_by_name : t -> string -> Contact.t
186
+
187
+
(** [find_by_name_opt t name] searches for contacts by name, returning an option.
188
+
189
+
Like {!find_by_name} but returns [None] instead of raising exceptions
190
+
when no match or multiple matches are found.
191
+
192
+
@param name The name to search for (case-insensitive)
193
+
@return [Some contact] if exactly one match is found, [None] otherwise *)
194
+
val find_by_name_opt : t -> string -> Contact.t option
195
+
196
+
(** [search_all t query] searches for contacts matching a query string.
197
+
198
+
Performs a flexible search through all contact names, looking for:
199
+
- Exact matches (case-insensitive)
200
+
- Names that start with the query
201
+
- Multi-word names where any word starts with the query
202
+
203
+
This is useful for autocomplete or fuzzy search functionality.
204
+
205
+
@param t The contact store
206
+
@param query The search query (case-insensitive)
207
+
@return A list of matching contacts, sorted by handle *)
208
+
val search_all : t -> string -> Contact.t list
209
+
210
+
(** {1 Temporal Queries} *)
211
+
212
+
(** [find_by_email_at t ~email ~date] finds a contact by email address at a specific date.
213
+
214
+
Searches for a contact that had the given email address valid at [date].
215
+
216
+
@param email Email address to search for
217
+
@param date ISO 8601 date string
218
+
@return The first matching contact, or [None] if not found *)
219
+
val find_by_email_at : t -> email:string -> date:Temporal.date ->
220
+
Contact.t option
221
+
222
+
(** [find_by_org t ~org ?from ?until ()] finds contacts who worked at an organization.
223
+
224
+
Searches for contacts whose organization records overlap with the given period.
225
+
If [from] and [until] are omitted, returns all contacts who ever worked there.
226
+
227
+
@param org Organization name (case-insensitive substring match)
228
+
@param from Start date of period to check (inclusive, optional)
229
+
@param until End date of period to check (exclusive, optional)
230
+
@return List of matching contacts, sorted by handle *)
231
+
val find_by_org : t -> org:string -> ?from:Temporal.date ->
232
+
?until:Temporal.date -> unit -> Contact.t list
233
+
234
+
(** [list_at t ~date] returns contacts that were active at a specific date.
235
+
236
+
A contact is considered active at a date if it has at least one
237
+
email, organization, or URL valid at that date.
238
+
239
+
@param date ISO 8601 date string
240
+
@return List of active contacts at that date *)
241
+
val list_at : t -> date:Temporal.date -> Contact.t list
242
+
243
+
(** {1 Utilities} *)
244
+
245
+
(** [handle_of_name name] generates a handle from a full name.
246
+
247
+
Creates a handle by concatenating the initials of all words
248
+
in the name with the full last name, all in lowercase.
249
+
250
+
Examples:
251
+
- "Anil Madhavapeddy" -> "ammadhavapeddy"
252
+
- "John Smith" -> "jssmith"
253
+
254
+
@param name The full name to convert
255
+
@return A suggested handle *)
256
+
val handle_of_name : string -> string
257
+
258
+
(** {1 Pretty Printing} *)
259
+
260
+
(** [pp ppf t] pretty prints the contact store showing statistics. *)
261
+
val pp : Format.formatter -> t -> unit
+4
lib/schema/dune
+4
lib/schema/dune
+14
lib/schema/sortal_schema.ml
+14
lib/schema/sortal_schema.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module V1 = struct
7
+
module Temporal = Sortal_schema_temporal
8
+
module Feed = Sortal_schema_feed
9
+
module Contact = Sortal_schema_contact_v1
10
+
end
11
+
12
+
module Temporal = V1.Temporal
13
+
module Feed = V1.Feed
14
+
module Contact = V1.Contact
+40
lib/schema/sortal_schema.mli
+40
lib/schema/sortal_schema.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Sortal Schema - Versioned data types and serialization
7
+
8
+
This library provides versioned schema definitions for contact metadata
9
+
with minimal I/O dependencies. It includes:
10
+
- Temporal validity support (ISO 8601 dates and ranges)
11
+
- Feed subscription types
12
+
- Contact metadata schemas (versioned)
13
+
14
+
The schema library depends on jsont, yamlt, bytesrw, fmt for serialization
15
+
and formatting, plus ptime and ptime.clock.os for date/time operations. *)
16
+
17
+
(** {1 Schema Version 1} *)
18
+
19
+
module V1 : sig
20
+
(** Version 1 of the contact schema (current stable version). *)
21
+
22
+
(** Temporal validity support for time-bounded fields. *)
23
+
module Temporal = Sortal_schema_temporal
24
+
25
+
(** Feed subscription metadata. *)
26
+
module Feed = Sortal_schema_feed
27
+
28
+
(** Contact metadata with temporal support. *)
29
+
module Contact = Sortal_schema_contact_v1
30
+
end
31
+
32
+
(** {1 Current Version Aliases}
33
+
34
+
These aliases point to the current stable schema version (V1).
35
+
When V2 is introduced, these will continue pointing to V1 for
36
+
backward compatibility. *)
37
+
38
+
module Temporal = V1.Temporal
39
+
module Feed = V1.Feed
40
+
module Contact = V1.Contact
+475
lib/schema/sortal_schema_contact_v1.ml
+475
lib/schema/sortal_schema_contact_v1.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
let version = 1
7
+
8
+
type contact_kind = Person | Organization | Group | Role
9
+
10
+
type service_kind =
11
+
| ActivityPub
12
+
| Github
13
+
| Git
14
+
| Social
15
+
| Photo
16
+
| Custom of string
17
+
18
+
type service = {
19
+
url: string;
20
+
kind: service_kind option;
21
+
handle: string option;
22
+
label: string option;
23
+
range: Sortal_schema_temporal.range option;
24
+
primary: bool;
25
+
}
26
+
27
+
type email_type = Work | Personal | Other
28
+
29
+
type email = {
30
+
address: string;
31
+
type_: email_type option;
32
+
range: Sortal_schema_temporal.range option;
33
+
note: string option;
34
+
}
35
+
36
+
type organization = {
37
+
name: string;
38
+
title: string option;
39
+
department: string option;
40
+
range: Sortal_schema_temporal.range option;
41
+
email: string option;
42
+
url: string option;
43
+
}
44
+
45
+
type url_entry = {
46
+
url: string;
47
+
label: string option;
48
+
range: Sortal_schema_temporal.range option;
49
+
}
50
+
51
+
type t = {
52
+
version: int;
53
+
kind: contact_kind;
54
+
handle: string;
55
+
names: string list;
56
+
emails: email list;
57
+
organizations: organization list;
58
+
urls: url_entry list;
59
+
services: service list;
60
+
icon: string option;
61
+
thumbnail: string option;
62
+
orcid: string option;
63
+
feeds: Sortal_schema_feed.t list option;
64
+
}
65
+
66
+
(* Helpers *)
67
+
let make_email ?type_ ?from ?until ?note address =
68
+
let range = match from, until with
69
+
| None, None -> None
70
+
| _, _ -> Some (Sortal_schema_temporal.make ?from ?until ())
71
+
in
72
+
{ address; type_; range; note }
73
+
74
+
let email_of_string address =
75
+
{ address; type_ = Some Personal; range = None; note = None }
76
+
77
+
let make_org ?title ?department ?from ?until ?email ?url name =
78
+
let range = match from, until with
79
+
| None, None -> None
80
+
| _, _ -> Some (Sortal_schema_temporal.make ?from ?until ())
81
+
in
82
+
{ name; title; department; range; email; url }
83
+
84
+
let make_url ?label ?from ?until url =
85
+
let range = match from, until with
86
+
| None, None -> None
87
+
| _, _ -> Some (Sortal_schema_temporal.make ?from ?until ())
88
+
in
89
+
{ url; label; range }
90
+
91
+
let url_of_string url =
92
+
{ url; label = None; range = None }
93
+
94
+
let make_service ?kind ?handle ?label ?from ?until ?(primary = false) url =
95
+
let range = match from, until with
96
+
| None, None -> None
97
+
| _, _ -> Some (Sortal_schema_temporal.make ?from ?until ())
98
+
in
99
+
{ url; kind; handle; label; range; primary }
100
+
101
+
let service_of_url url =
102
+
{ url; kind = None; handle = None; label = None; range = None; primary = false }
103
+
104
+
let make ~handle ~names ?(kind = Person) ?(emails = []) ?(organizations = [])
105
+
?(urls = []) ?(services = []) ?icon ?thumbnail ?orcid ?feeds () =
106
+
{ version; kind; handle; names; emails; organizations; urls; services;
107
+
icon; thumbnail; orcid; feeds }
108
+
109
+
(* Accessors *)
110
+
let version_of t = t.version
111
+
let kind t = t.kind
112
+
let handle t = t.handle
113
+
let names t = t.names
114
+
let name t = List.hd t.names
115
+
let primary_name = name
116
+
let emails t = t.emails
117
+
let organizations t = t.organizations
118
+
let urls t = t.urls
119
+
let services t = t.services
120
+
let icon t = t.icon
121
+
let thumbnail t = t.thumbnail
122
+
let orcid t = t.orcid
123
+
let feeds t = t.feeds
124
+
125
+
(* Temporal queries *)
126
+
let emails_at t ~date =
127
+
Sortal_schema_temporal.at_date ~get:(fun (e : email) -> e.range) ~date t.emails
128
+
129
+
let email_at t ~date =
130
+
match emails_at t ~date with
131
+
| e :: _ -> Some e.address
132
+
| [] -> None
133
+
134
+
let current_email t =
135
+
match Sortal_schema_temporal.current ~get:(fun (e : email) -> e.range) t.emails with
136
+
| Some e -> Some e.address
137
+
| None -> None
138
+
139
+
let organization_at t ~date =
140
+
match Sortal_schema_temporal.at_date ~get:(fun (o : organization) -> o.range) ~date t.organizations with
141
+
| o :: _ -> Some o
142
+
| [] -> None
143
+
144
+
let current_organization t =
145
+
Sortal_schema_temporal.current ~get:(fun (o : organization) -> o.range) t.organizations
146
+
147
+
let url_at t ~date =
148
+
match Sortal_schema_temporal.at_date ~get:(fun (u : url_entry) -> u.range) ~date t.urls with
149
+
| u :: _ -> Some u.url
150
+
| [] -> None
151
+
152
+
let current_url t =
153
+
match Sortal_schema_temporal.current ~get:(fun (u : url_entry) -> u.range) t.urls with
154
+
| Some u -> Some u.url
155
+
| None -> None
156
+
157
+
let all_email_addresses t =
158
+
List.map (fun e -> e.address) t.emails
159
+
160
+
(* Service queries *)
161
+
let services_of_kind t (kind : service_kind) =
162
+
List.filter (fun (s : service) ->
163
+
match (s.kind : service_kind option) with
164
+
| Some k when k = kind -> true
165
+
| _ -> false
166
+
) t.services
167
+
168
+
let services_at t ~date =
169
+
Sortal_schema_temporal.at_date ~get:(fun (s : service) -> s.range) ~date t.services
170
+
171
+
let current_services t =
172
+
List.filter (fun (s : service) -> Sortal_schema_temporal.is_current s.range) t.services
173
+
174
+
let primary_service t (kind : service_kind) =
175
+
List.find_opt (fun (s : service) ->
176
+
match (s.kind : service_kind option) with
177
+
| Some k when k = kind && s.primary -> true
178
+
| _ -> false
179
+
) t.services
180
+
181
+
let best_url t =
182
+
current_url t
183
+
|> Option.fold ~none:(
184
+
match current_services t with
185
+
| s :: _ -> Some s.url
186
+
| [] -> current_email t |> Option.map (fun e -> "mailto:" ^ e)
187
+
) ~some:Option.some
188
+
189
+
(* Modification *)
190
+
let add_feed t feed =
191
+
{ t with feeds = Some (feed :: Option.value t.feeds ~default:[]) }
192
+
193
+
let remove_feed t url =
194
+
{ t with feeds = Option.map (List.filter (fun f -> Sortal_schema_feed.url f <> url)) t.feeds }
195
+
196
+
(* Comparison *)
197
+
let compare a b = String.compare a.handle b.handle
198
+
199
+
(* Type conversions *)
200
+
let contact_kind_to_string = function
201
+
| Person -> "person"
202
+
| Organization -> "organization"
203
+
| Group -> "group"
204
+
| Role -> "role"
205
+
206
+
let contact_kind_of_string = function
207
+
| "person" -> Some Person
208
+
| "organization" -> Some Organization
209
+
| "group" -> Some Group
210
+
| "role" -> Some Role
211
+
| _ -> None
212
+
213
+
let service_kind_to_string = function
214
+
| ActivityPub -> "activitypub"
215
+
| Github -> "github"
216
+
| Git -> "git"
217
+
| Social -> "social"
218
+
| Photo -> "photo"
219
+
| Custom s -> s
220
+
221
+
let service_kind_of_string s =
222
+
match String.lowercase_ascii s with
223
+
| "activitypub" -> Some ActivityPub
224
+
| "github" -> Some Github
225
+
| "git" -> Some Git
226
+
| "social" -> Some Social
227
+
| "photo" -> Some Photo
228
+
| "" | "custom" -> None
229
+
| _ -> Some (Custom s)
230
+
231
+
let email_type_to_string = function
232
+
| Work -> "work"
233
+
| Personal -> "personal"
234
+
| Other -> "other"
235
+
236
+
let email_type_of_string = function
237
+
| "work" -> Some Work
238
+
| "personal" -> Some Personal
239
+
| "other" -> Some Other
240
+
| _ -> None
241
+
242
+
(* JSON encoding *)
243
+
244
+
(* Helper: case-insensitive enum decoder *)
245
+
let case_insensitive_enum ~kind:kind_name cases =
246
+
let open Jsont in
247
+
let lowercase_cases = List.map (fun (s, v) -> (String.lowercase_ascii s, v)) cases in
248
+
let dec s =
249
+
match List.assoc_opt (String.lowercase_ascii s) lowercase_cases with
250
+
| Some v -> v
251
+
| None -> failwith ("unknown " ^ kind_name ^ ": " ^ s)
252
+
in
253
+
let enc v =
254
+
match List.find_opt (fun (_, v') -> v = v') cases with
255
+
| Some (s, _) -> s
256
+
| None -> failwith ("invalid " ^ kind_name)
257
+
in
258
+
let t = map ~kind:kind_name ~dec ~enc string in
259
+
t
260
+
261
+
let contact_kind_json =
262
+
case_insensitive_enum ~kind:"ContactKind" [
263
+
"person", Person;
264
+
"organization", Organization;
265
+
"group", Group;
266
+
"role", Role;
267
+
]
268
+
269
+
let service_json : service Jsont.t =
270
+
let open Jsont in
271
+
let open Jsont.Object in
272
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
273
+
(* Convert string option to/from service_kind option *)
274
+
let dec_kind_opt kind_str =
275
+
match kind_str with
276
+
| None -> None
277
+
| Some s -> service_kind_of_string s
278
+
in
279
+
let enc_kind_opt = Option.map service_kind_to_string in
280
+
let make url kind_str handle label range primary : service =
281
+
let kind = dec_kind_opt kind_str in
282
+
{ url; kind; handle; label; range; primary }
283
+
in
284
+
map ~kind:"Service" make
285
+
|> mem "url" string ~enc:(fun (s : service) -> s.url)
286
+
|> mem_opt "kind" (some string) ~enc:(fun (s : service) -> enc_kind_opt s.kind)
287
+
|> mem_opt "handle" (some string) ~enc:(fun (s : service) -> s.handle)
288
+
|> mem_opt "label" (some string) ~enc:(fun (s : service) -> s.label)
289
+
|> mem_opt "range" (some Sortal_schema_temporal.json_t) ~enc:(fun (s : service) -> s.range)
290
+
|> mem "primary" bool ~dec_absent:false ~enc:(fun (s : service) -> s.primary)
291
+
|> finish
292
+
293
+
let email_type_json =
294
+
case_insensitive_enum ~kind:"EmailType" [
295
+
"work", Work;
296
+
"personal", Personal;
297
+
"other", Other;
298
+
]
299
+
300
+
let email_json : email Jsont.t =
301
+
let open Jsont in
302
+
let open Jsont.Object in
303
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
304
+
let make address type_ range note : email = { address; type_; range; note } in
305
+
map ~kind:"Email" make
306
+
|> mem "address" string ~enc:(fun (e : email) -> e.address)
307
+
|> mem_opt "type" (some email_type_json) ~enc:(fun (e : email) -> e.type_)
308
+
|> mem_opt "range" (some Sortal_schema_temporal.json_t) ~enc:(fun (e : email) -> e.range)
309
+
|> mem_opt "note" (some string) ~enc:(fun (e : email) -> e.note)
310
+
|> finish
311
+
312
+
let organization_json : organization Jsont.t =
313
+
let open Jsont in
314
+
let open Jsont.Object in
315
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
316
+
let make name title department range email url : organization =
317
+
{ name; title; department; range; email; url }
318
+
in
319
+
map ~kind:"Organization" make
320
+
|> mem "name" string ~enc:(fun (o : organization) -> o.name)
321
+
|> mem_opt "title" (some string) ~enc:(fun (o : organization) -> o.title)
322
+
|> mem_opt "department" (some string) ~enc:(fun (o : organization) -> o.department)
323
+
|> mem_opt "range" (some Sortal_schema_temporal.json_t) ~enc:(fun (o : organization) -> o.range)
324
+
|> mem_opt "email" (some string) ~enc:(fun (o : organization) -> o.email)
325
+
|> mem_opt "url" (some string) ~enc:(fun (o : organization) -> o.url)
326
+
|> finish
327
+
328
+
let url_entry_json : url_entry Jsont.t =
329
+
let open Jsont in
330
+
let open Jsont.Object in
331
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
332
+
let make url label range : url_entry = { url; label; range } in
333
+
map ~kind:"URL" make
334
+
|> mem "url" string ~enc:(fun (u : url_entry) -> u.url)
335
+
|> mem_opt "label" (some string) ~enc:(fun (u : url_entry) -> u.label)
336
+
|> mem_opt "range" (some Sortal_schema_temporal.json_t) ~enc:(fun (u : url_entry) -> u.range)
337
+
|> finish
338
+
339
+
let json_t =
340
+
let open Jsont in
341
+
let open Jsont.Object in
342
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
343
+
let make version kind handle names emails organizations urls services
344
+
icon thumbnail orcid feeds =
345
+
if version <> 1 then
346
+
failwith (Printf.sprintf "Unsupported contact schema version: %d" version);
347
+
{ version; kind; handle; names; emails; organizations; urls; services;
348
+
icon; thumbnail; orcid; feeds }
349
+
in
350
+
map ~kind:"Contact" make
351
+
|> mem "version" int ~enc:(fun _ -> 1)
352
+
|> mem "kind" contact_kind_json ~dec_absent:Person ~enc:(fun c -> c.kind)
353
+
|> mem "handle" string ~enc:(fun c -> c.handle)
354
+
|> mem "names" (list string) ~dec_absent:[] ~enc:(fun c -> c.names)
355
+
|> mem "emails" (list email_json) ~dec_absent:[] ~enc:(fun c -> c.emails)
356
+
|> mem "organizations" (list organization_json) ~dec_absent:[] ~enc:(fun c -> c.organizations)
357
+
|> mem "urls" (list url_entry_json) ~dec_absent:[] ~enc:(fun c -> c.urls)
358
+
|> mem "services" (list service_json) ~dec_absent:[] ~enc:(fun c -> c.services)
359
+
|> mem_opt "icon" (some string) ~enc:(fun c -> c.icon)
360
+
|> mem_opt "thumbnail" (some string) ~enc:(fun c -> c.thumbnail)
361
+
|> mem_opt "orcid" (some string) ~enc:(fun c -> c.orcid)
362
+
|> mem_opt "feeds" (some (list Sortal_schema_feed.json_t)) ~enc:(fun c -> c.feeds)
363
+
|> finish
364
+
365
+
(* Pretty printing *)
366
+
let pp ppf t =
367
+
let open Fmt in
368
+
let label = styled (`Fg `Cyan) string in
369
+
let url_style = styled (`Fg `Blue) in
370
+
let date_style = styled (`Fg `Green) in
371
+
let field lbl fmt_v = Option.iter (fun v -> pf ppf "%a: %a@," label lbl fmt_v v) in
372
+
373
+
let pp_range ppf = function
374
+
| None -> ()
375
+
| Some { Sortal_schema_temporal.from; until } ->
376
+
match from, until with
377
+
| Some f, Some u ->
378
+
let fs = Sortal_schema_temporal.format_date f in
379
+
let us = Sortal_schema_temporal.format_date u in
380
+
pf ppf " %a" (date_style string) (Printf.sprintf "[%s to %s]" fs us)
381
+
| Some f, None ->
382
+
let fs = Sortal_schema_temporal.format_date f in
383
+
pf ppf " %a" (date_style string) (Printf.sprintf "[from %s]" fs)
384
+
| None, Some u ->
385
+
let us = Sortal_schema_temporal.format_date u in
386
+
pf ppf " %a" (date_style string) (Printf.sprintf "[until %s]" us)
387
+
| None, None -> ()
388
+
in
389
+
390
+
pf ppf "@[<v>";
391
+
pf ppf "%a: %a@," label "Handle" (styled `Bold (fun ppf s -> pf ppf "@%s" s)) t.handle;
392
+
393
+
(* Show kind if not a person *)
394
+
(match t.kind with
395
+
| Person -> ()
396
+
| k -> pf ppf "%a: %a@," label "Kind" (styled (`Fg `Magenta) string) (contact_kind_to_string k));
397
+
398
+
pf ppf "%a: %a@," label "Name" (styled `Bold string) (name t);
399
+
400
+
if List.length (names t) > 1 then
401
+
pf ppf "%a: @[<h>%a@]@," label "Aliases"
402
+
(list ~sep:comma string) (List.tl (names t));
403
+
404
+
(* Emails with temporal info *)
405
+
if emails t <> [] then begin
406
+
pf ppf "%a:@," label "Emails";
407
+
List.iter (fun e ->
408
+
pf ppf " %a%s%s%a%a@,"
409
+
(styled (`Fg `Yellow) string) e.address
410
+
(match e.type_ with Some Work -> " (work)" | Some Personal -> " (personal)" | Some Other -> " (other)" | None -> "")
411
+
(match e.note with Some n -> " - " ^ n | None -> "")
412
+
pp_range e.range
413
+
(fun ppf current -> if current then pf ppf " %a" (styled (`Fg `Magenta) string) "[current]" else ())
414
+
(Sortal_schema_temporal.is_current e.range)
415
+
) (emails t)
416
+
end;
417
+
418
+
(* Organizations with temporal info *)
419
+
if organizations t <> [] then begin
420
+
pf ppf "%a:@," label "Organizations";
421
+
List.iter (fun o ->
422
+
pf ppf " %a" (styled `Bold string) o.name;
423
+
Option.iter (fun title -> pf ppf " - %s" title) o.title;
424
+
Option.iter (fun dept -> pf ppf " (%s)" dept) o.department;
425
+
pf ppf "%a" pp_range o.range;
426
+
if Sortal_schema_temporal.is_current o.range then
427
+
pf ppf " %a" (styled (`Fg `Magenta) string) "[current]";
428
+
pf ppf "@,";
429
+
Option.iter (fun email -> pf ppf " Email: %a@," (styled (`Fg `Yellow) string) email) o.email;
430
+
Option.iter (fun url -> pf ppf " URL: %a@," (url_style string) url) o.url;
431
+
) (organizations t)
432
+
end;
433
+
434
+
(* URLs *)
435
+
if urls t <> [] then begin
436
+
pf ppf "%a:@," label "URLs";
437
+
List.iter (fun u ->
438
+
pf ppf " %a" (url_style string) u.url;
439
+
Option.iter (fun lbl -> pf ppf " (%s)" lbl) u.label;
440
+
pf ppf "%a" pp_range u.range;
441
+
if Sortal_schema_temporal.is_current u.range then
442
+
pf ppf " %a" (styled (`Fg `Magenta) string) "[current]";
443
+
pf ppf "@,"
444
+
) (urls t)
445
+
end;
446
+
447
+
(* Services *)
448
+
if services t <> [] then begin
449
+
pf ppf "%a:@," label "Services";
450
+
List.iter (fun (s : service) ->
451
+
pf ppf " %a" (url_style string) s.url;
452
+
Option.iter (fun k -> pf ppf " (%s)" (service_kind_to_string k)) s.kind;
453
+
Option.iter (fun h -> pf ppf " [@%s]" h) s.handle;
454
+
Option.iter (fun lbl -> pf ppf " - %s" lbl) s.label;
455
+
pf ppf "%a" pp_range s.range;
456
+
if s.primary then pf ppf " %a" (styled (`Fg `Yellow) string) "[primary]";
457
+
if Sortal_schema_temporal.is_current s.range then
458
+
pf ppf " %a" (styled (`Fg `Magenta) string) "[current]";
459
+
pf ppf "@,"
460
+
) (services t)
461
+
end;
462
+
463
+
field "ORCID" (url_style (fun ppf o -> pf ppf "https://orcid.org/%s" o)) t.orcid;
464
+
465
+
field "Icon" (url_style string) t.icon;
466
+
field "Thumbnail" (styled (`Fg `White) string) t.thumbnail;
467
+
468
+
Option.iter (function
469
+
| [] -> ()
470
+
| feeds ->
471
+
pf ppf "%a:@," label "Feeds";
472
+
List.iter (fun feed -> pf ppf " - %a@," Sortal_schema_feed.pp feed) feeds
473
+
) t.feeds;
474
+
475
+
pf ppf "@]"
+277
lib/schema/sortal_schema_contact_v1.mli
+277
lib/schema/sortal_schema_contact_v1.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Contact schema V1 with temporal support.
7
+
8
+
This module defines the V1 contact schema with support for time-bounded
9
+
information such as emails and organizations that are valid only during
10
+
specific periods.
11
+
12
+
{b Schema Version Policy:}
13
+
- New optional fields can be added without bumping the version
14
+
- The version must be bumped only if the {i meaning} of an existing
15
+
field changes
16
+
- This allows forward compatibility: older readers can ignore new fields *)
17
+
18
+
(** {1 Schema Version} *)
19
+
20
+
val version : int
21
+
(** The schema version number for V1. Currently [1]. *)
22
+
23
+
(** {1 Types} *)
24
+
25
+
(** Contact kind - what type of entity this represents. *)
26
+
type contact_kind =
27
+
| Person (** Individual person *)
28
+
| Organization (** Company, lab, department *)
29
+
| Group (** Research group, project team *)
30
+
| Role (** Generic role email like info@, admin@ *)
31
+
32
+
(** Service kind - categorization of online presence. *)
33
+
type service_kind =
34
+
| ActivityPub (** Mastodon, Pixelfed, PeerTube, etc *)
35
+
| Github (** GitHub *)
36
+
| Git (** GitLab, Gitea, Codeberg, etc *)
37
+
| Social (** Twitter/X, LinkedIn, etc *)
38
+
| Photo (** Immich, Flickr, Instagram, etc *)
39
+
| Custom of string (** Other service types *)
40
+
41
+
(** An online service/identity. *)
42
+
type service = {
43
+
url: string; (** Full URL (primary identifier) *)
44
+
kind: service_kind option; (** Optional service categorization *)
45
+
handle: string option; (** Optional short handle/username *)
46
+
label: string option; (** Human description: "Cambridge GitLab", "Work account" *)
47
+
range: Sortal_schema_temporal.range option; (** Temporal validity *)
48
+
primary: bool; (** Is this the primary/preferred service of its kind? *)
49
+
}
50
+
51
+
type email_type = Work | Personal | Other
52
+
53
+
type email = {
54
+
address: string;
55
+
type_: email_type option;
56
+
range: Sortal_schema_temporal.range option; (** Validity period *)
57
+
note: string option; (** Context note, e.g., "NetApp position" *)
58
+
}
59
+
60
+
type organization = {
61
+
name: string;
62
+
title: string option;
63
+
department: string option;
64
+
range: Sortal_schema_temporal.range option; (** Employment period *)
65
+
email: string option; (** Work email during this period *)
66
+
url: string option; (** Work homepage during this period *)
67
+
}
68
+
69
+
type url_entry = {
70
+
url: string;
71
+
label: string option; (** Human-readable label *)
72
+
range: Sortal_schema_temporal.range option; (** Validity period *)
73
+
}
74
+
75
+
type t = {
76
+
version: int; (** Schema version (always 1 for V1) *)
77
+
kind: contact_kind; (** Type of entity (Person, Organization, etc) *)
78
+
handle: string; (** Unique identifier *)
79
+
names: string list; (** Names, first is primary *)
80
+
81
+
(* Temporal fields *)
82
+
emails: email list; (** Email addresses with temporal validity *)
83
+
organizations: organization list; (** Employment/affiliation history *)
84
+
urls: url_entry list; (** URLs with optional temporal validity *)
85
+
services: service list; (** Online services/identities *)
86
+
87
+
(* Simple fields - rarely change over time *)
88
+
icon: string option; (** Avatar URL *)
89
+
thumbnail: string option; (** Local thumbnail path *)
90
+
orcid: string option; (** ORCID identifier *)
91
+
92
+
(* Other *)
93
+
feeds: Sortal_schema_feed.t list option; (** Feed subscriptions *)
94
+
}
95
+
96
+
(** {1 Construction} *)
97
+
98
+
(** [make ~handle ~names ?kind ?emails ?organizations ?urls ?services
99
+
?icon ?thumbnail ?orcid ?feeds ()]
100
+
creates a new V1 contact.
101
+
102
+
The [version] field is automatically set to [1].
103
+
The [kind] defaults to [Person] if not specified. *)
104
+
val make :
105
+
handle:string ->
106
+
names:string list ->
107
+
?kind:contact_kind ->
108
+
?emails:email list ->
109
+
?organizations:organization list ->
110
+
?urls:url_entry list ->
111
+
?services:service list ->
112
+
?icon:string ->
113
+
?thumbnail:string ->
114
+
?orcid:string ->
115
+
?feeds:Sortal_schema_feed.t list ->
116
+
unit ->
117
+
t
118
+
119
+
(** {1 Email Helpers} *)
120
+
121
+
(** [make_email ?type_ ?from ?until ?note address] creates an email entry.
122
+
123
+
@param type_ Email type (Work, Personal, Other)
124
+
@param from Start date of validity
125
+
@param until End date of validity (exclusive)
126
+
@param note Contextual note *)
127
+
val make_email :
128
+
?type_:email_type ->
129
+
?from:Sortal_schema_temporal.date ->
130
+
?until:Sortal_schema_temporal.date ->
131
+
?note:string ->
132
+
string ->
133
+
email
134
+
135
+
(** [email_of_string s] creates a simple always-valid personal email. *)
136
+
val email_of_string : string -> email
137
+
138
+
(** {1 Organization Helpers} *)
139
+
140
+
(** [make_org ?title ?department ?from ?until ?email ?url name]
141
+
creates an organization entry. *)
142
+
val make_org :
143
+
?title:string ->
144
+
?department:string ->
145
+
?from:Sortal_schema_temporal.date ->
146
+
?until:Sortal_schema_temporal.date ->
147
+
?email:string ->
148
+
?url:string ->
149
+
string ->
150
+
organization
151
+
152
+
(** {1 URL Helpers} *)
153
+
154
+
(** [make_url ?label ?from ?until url] creates a URL entry. *)
155
+
val make_url :
156
+
?label:string ->
157
+
?from:Sortal_schema_temporal.date ->
158
+
?until:Sortal_schema_temporal.date ->
159
+
string ->
160
+
url_entry
161
+
162
+
(** [url_of_string s] creates a simple always-valid URL. *)
163
+
val url_of_string : string -> url_entry
164
+
165
+
(** {1 Service Helpers} *)
166
+
167
+
(** [make_service ?kind ?handle ?label ?from ?until ?primary url]
168
+
creates a service entry.
169
+
170
+
@param kind Optional service categorization
171
+
@param handle Optional short handle/username
172
+
@param label Optional description (e.g., "Work account", "Cambridge GitLab")
173
+
@param from Start date of validity
174
+
@param until End date of validity (exclusive)
175
+
@param primary Whether this is the primary service of its kind
176
+
@param url Full URL to the service (required) *)
177
+
val make_service :
178
+
?kind:service_kind ->
179
+
?handle:string ->
180
+
?label:string ->
181
+
?from:Sortal_schema_temporal.date ->
182
+
?until:Sortal_schema_temporal.date ->
183
+
?primary:bool ->
184
+
string ->
185
+
service
186
+
187
+
(** [service_of_url url] creates a simple always-valid service from just a URL. *)
188
+
val service_of_url : string -> service
189
+
190
+
(** {1 Accessors} *)
191
+
192
+
val version_of : t -> int
193
+
val kind : t -> contact_kind
194
+
val handle : t -> string
195
+
val names : t -> string list
196
+
val name : t -> string
197
+
val primary_name : t -> string
198
+
val emails : t -> email list
199
+
val organizations : t -> organization list
200
+
val urls : t -> url_entry list
201
+
val services : t -> service list
202
+
val icon : t -> string option
203
+
val thumbnail : t -> string option
204
+
val orcid : t -> string option
205
+
val feeds : t -> Sortal_schema_feed.t list option
206
+
207
+
(** {1 Temporal Queries} *)
208
+
209
+
(** [email_at t ~date] returns the primary email valid at [date]. *)
210
+
val email_at : t -> date:Sortal_schema_temporal.date -> string option
211
+
212
+
(** [emails_at t ~date] returns all emails valid at [date]. *)
213
+
val emails_at : t -> date:Sortal_schema_temporal.date -> email list
214
+
215
+
(** [current_email t] returns the current primary email. *)
216
+
val current_email : t -> string option
217
+
218
+
(** [organization_at t ~date] returns the organization at [date]. *)
219
+
val organization_at : t -> date:Sortal_schema_temporal.date -> organization option
220
+
221
+
(** [current_organization t] returns the current organization. *)
222
+
val current_organization : t -> organization option
223
+
224
+
(** [url_at t ~date] returns the primary URL valid at [date]. *)
225
+
val url_at : t -> date:Sortal_schema_temporal.date -> string option
226
+
227
+
(** [current_url t] returns the current primary URL. *)
228
+
val current_url : t -> string option
229
+
230
+
(** [all_email_addresses t] returns all email addresses (any period). *)
231
+
val all_email_addresses : t -> string list
232
+
233
+
(** [best_url t] returns the best available URL (current URL or service fallback). *)
234
+
val best_url : t -> string option
235
+
236
+
(** {1 Service Queries} *)
237
+
238
+
(** [services_of_kind t kind] returns all services matching the given kind. *)
239
+
val services_of_kind : t -> service_kind -> service list
240
+
241
+
(** [services_at t ~date] returns all services valid at [date]. *)
242
+
val services_at : t -> date:Sortal_schema_temporal.date -> service list
243
+
244
+
(** [current_services t] returns all currently valid services. *)
245
+
val current_services : t -> service list
246
+
247
+
(** [primary_service t kind] returns the primary service of the given kind. *)
248
+
val primary_service : t -> service_kind -> service option
249
+
250
+
(** {1 Modification} *)
251
+
252
+
val add_feed : t -> Sortal_schema_feed.t -> t
253
+
val remove_feed : t -> string -> t
254
+
255
+
(** {1 Comparison and Display} *)
256
+
257
+
val compare : t -> t -> int
258
+
val pp : Format.formatter -> t -> unit
259
+
260
+
(** {1 JSON Encoding} *)
261
+
262
+
(** [json_t] is the jsont encoder/decoder for V1 contacts.
263
+
264
+
The schema includes a [version] field that is always encoded and
265
+
must equal [1] when decoded. *)
266
+
val json_t : t Jsont.t
267
+
268
+
(** {1 Type Utilities} *)
269
+
270
+
val contact_kind_to_string : contact_kind -> string
271
+
val contact_kind_of_string : string -> contact_kind option
272
+
273
+
val service_kind_to_string : service_kind -> string
274
+
val service_kind_of_string : string -> service_kind option
275
+
276
+
val email_type_to_string : email_type -> string
277
+
val email_type_of_string : string -> email_type option
+57
lib/schema/sortal_schema_feed.ml
+57
lib/schema/sortal_schema_feed.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type feed_type =
7
+
| Atom
8
+
| Rss
9
+
| Json
10
+
11
+
type t = {
12
+
feed_type : feed_type;
13
+
url : string;
14
+
name : string option;
15
+
}
16
+
17
+
let make ~feed_type ~url ?name () =
18
+
{ feed_type; url; name }
19
+
20
+
let feed_type t = t.feed_type
21
+
let url t = t.url
22
+
let name t = t.name
23
+
24
+
let set_name t name = { t with name = Some name }
25
+
26
+
let feed_type_to_string = function
27
+
| Atom -> "atom"
28
+
| Rss -> "rss"
29
+
| Json -> "json"
30
+
31
+
let feed_type_of_string s =
32
+
match String.lowercase_ascii s with
33
+
| "atom" -> Some Atom
34
+
| "rss" -> Some Rss
35
+
| "json" -> Some Json
36
+
| _ -> None
37
+
38
+
let json_t =
39
+
let open Jsont in
40
+
let open Jsont.Object in
41
+
let make feed_type url name =
42
+
match feed_type_of_string feed_type with
43
+
| Some ft -> { feed_type = ft; url; name }
44
+
| None -> failwith ("Invalid feed type: " ^ feed_type)
45
+
in
46
+
map ~kind:"Feed" make
47
+
|> mem "type" string ~enc:(fun f -> feed_type_to_string f.feed_type)
48
+
|> mem "url" string ~enc:(fun f -> f.url)
49
+
|> opt_mem "name" string ~enc:(fun f -> f.name)
50
+
|> finish
51
+
52
+
let pp ppf t =
53
+
let open Fmt in
54
+
pf ppf "%a: %a%a"
55
+
(styled (`Fg `Green) string) (feed_type_to_string t.feed_type)
56
+
(styled (`Fg `Blue) string) t.url
57
+
(option (fun ppf name -> pf ppf " (%a)" (styled `Faint string) name)) t.name
+48
lib/schema/sortal_schema_feed.mli
+48
lib/schema/sortal_schema_feed.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Feed subscription with type and URL.
7
+
8
+
A feed represents a subscription to a content source (Atom, RSS, or JSONFeed). *)
9
+
10
+
type t
11
+
12
+
(** Feed type identifier. *)
13
+
type feed_type =
14
+
| Atom (** Atom feed format *)
15
+
| Rss (** RSS feed format *)
16
+
| Json (** JSON Feed format *)
17
+
18
+
(** [make ~feed_type ~url ?name ()] creates a new feed.
19
+
20
+
@param feed_type The type of feed (Atom, RSS, or JSON)
21
+
@param url The feed URL
22
+
@param name Optional human-readable name/label for the feed *)
23
+
val make : feed_type:feed_type -> url:string -> ?name:string -> unit -> t
24
+
25
+
(** [feed_type t] returns the feed type. *)
26
+
val feed_type : t -> feed_type
27
+
28
+
(** [url t] returns the feed URL. *)
29
+
val url : t -> string
30
+
31
+
(** [name t] returns the feed name if set. *)
32
+
val name : t -> string option
33
+
34
+
(** [set_name t name] returns a new feed with the name updated. *)
35
+
val set_name : t -> string -> t
36
+
37
+
(** [feed_type_to_string ft] converts a feed type to a string. *)
38
+
val feed_type_to_string : feed_type -> string
39
+
40
+
(** [feed_type_of_string s] parses a feed type from a string.
41
+
Returns [None] if the string is not recognized. *)
42
+
val feed_type_of_string : string -> feed_type option
43
+
44
+
(** [json_t] is the jsont encoder/decoder for feeds. *)
45
+
val json_t : t Jsont.t
46
+
47
+
(** [pp ppf t] pretty prints a feed. *)
48
+
val pp : Format.formatter -> t -> unit
+135
lib/schema/sortal_schema_temporal.ml
+135
lib/schema/sortal_schema_temporal.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
type date = Ptime.date
7
+
8
+
type range = {
9
+
from: date option;
10
+
until: date option;
11
+
}
12
+
13
+
let make ?from ?until () = { from; until }
14
+
15
+
let always = { from = None; until = None }
16
+
17
+
(* Compare Ptime dates (year, month, day tuples) *)
18
+
let date_compare ((y1, m1, d1) : date) ((y2, m2, d2) : date) : int =
19
+
match compare y1 y2 with
20
+
| 0 -> (
21
+
match compare m1 m2 with
22
+
| 0 -> compare d1 d2
23
+
| c -> c)
24
+
| c -> c
25
+
26
+
let date_gte d1 d2 = date_compare d1 d2 >= 0
27
+
28
+
let valid_at range_opt ~date =
29
+
match range_opt with
30
+
| None -> true (* No range = always valid *)
31
+
| Some { from; until } ->
32
+
let after_start = match from with
33
+
| None -> true
34
+
| Some f -> date_gte date f
35
+
in
36
+
let before_end = match until with
37
+
| None -> true
38
+
| Some u -> date_compare date u < 0 (* until is exclusive *)
39
+
in
40
+
after_start && before_end
41
+
42
+
let overlaps r1 r2 =
43
+
(* Two ranges overlap if neither ends before the other starts *)
44
+
let r1_starts_before_r2_ends = match r2.until with
45
+
| None -> true
46
+
| Some u2 -> match r1.from with
47
+
| None -> true
48
+
| Some f1 -> date_compare f1 u2 < 0
49
+
in
50
+
let r2_starts_before_r1_ends = match r1.until with
51
+
| None -> true
52
+
| Some u1 -> match r2.from with
53
+
| None -> true
54
+
| Some f2 -> date_compare f2 u1 < 0
55
+
in
56
+
r1_starts_before_r2_ends && r2_starts_before_r1_ends
57
+
58
+
let today () =
59
+
Ptime_clock.now () |> Ptime.to_date
60
+
61
+
let is_current range_opt =
62
+
valid_at range_opt ~date:(today ())
63
+
64
+
let current ~get list =
65
+
(* Find first currently valid item, or first item without temporal bounds *)
66
+
let current_items = List.filter (fun item -> is_current (get item)) list in
67
+
match current_items with
68
+
| x :: _ -> Some x
69
+
| [] ->
70
+
(* No current items, try to find one without temporal bounds *)
71
+
List.find_opt (fun item -> get item = None) list
72
+
73
+
let at_date ~get ~date list =
74
+
List.filter (fun item -> valid_at (get item) ~date) list
75
+
76
+
let filter ~get ~from ~until list =
77
+
let query_range = { from; until } in
78
+
List.filter (fun item ->
79
+
match get item with
80
+
| None -> true (* Items without range match all queries *)
81
+
| Some r -> overlaps r query_range
82
+
) list
83
+
84
+
(* Parse ISO 8601 date string to Ptime.date, handling partial dates *)
85
+
let parse_date_string (s : string) : date option =
86
+
match String.split_on_char '-' s with
87
+
| [year_s] -> (
88
+
try
89
+
let year = int_of_string year_s in
90
+
Some (year, 1, 1) (* Year only → January 1st *)
91
+
with Failure _ -> None)
92
+
| [year_s; month_s] -> (
93
+
try
94
+
let year = int_of_string year_s in
95
+
let month = int_of_string month_s in
96
+
if month >= 1 && month <= 12 then
97
+
Some (year, month, 1) (* Year-Month → 1st of month *)
98
+
else None
99
+
with Failure _ -> None)
100
+
| [year_s; month_s; day_s] -> (
101
+
try
102
+
let year = int_of_string year_s in
103
+
let month = int_of_string month_s in
104
+
let day = int_of_string day_s in
105
+
if month >= 1 && month <= 12 && day >= 1 && day <= 31 then
106
+
Some (year, month, day)
107
+
else None
108
+
with Failure _ -> None)
109
+
| _ -> None
110
+
111
+
(* Format Ptime.date as ISO 8601 string YYYY-MM-DD *)
112
+
let format_date ((year, month, day) : date) : string =
113
+
Printf.sprintf "%04d-%02d-%02d" year month day
114
+
115
+
let json_t =
116
+
let open Jsont in
117
+
let open Jsont.Object in
118
+
let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in
119
+
120
+
(* Create a jsont type for date that converts between string and Ptime.date *)
121
+
let date_jsont =
122
+
let dec meta s =
123
+
match parse_date_string s with
124
+
| Some d -> d
125
+
| None -> Error.msgf meta "TemporalDate: invalid ISO 8601 date: %S" s
126
+
in
127
+
let enc = format_date in
128
+
Base.string (Base.map ~kind:"TemporalDate" ~dec ~enc ())
129
+
in
130
+
131
+
let make_range from until = { from; until } in
132
+
map ~kind:"TemporalRange" make_range
133
+
|> mem_opt "from" (some date_jsont) ~enc:(fun r -> r.from)
134
+
|> mem_opt "until" (some date_jsont) ~enc:(fun r -> r.until)
135
+
|> finish
+98
lib/schema/sortal_schema_temporal.mli
+98
lib/schema/sortal_schema_temporal.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Temporal validity support for contact fields.
7
+
8
+
This module provides types and functions for managing time-bounded
9
+
information in contacts, such as emails valid only during certain
10
+
employment periods. *)
11
+
12
+
(** Date represented as a Ptime.date tuple (year, month, day).
13
+
14
+
When parsing from strings, partial dates are normalized:
15
+
- Year: ["2001"] → (2001, 1, 1)
16
+
- Year-Month: ["2001-01"] → (2001, 1, 1)
17
+
- Full date: ["2001-01-15"] → (2001, 1, 15) *)
18
+
type date = Ptime.date
19
+
20
+
(** {1 Date Conversion} *)
21
+
22
+
(** [parse_date_string s] parses an ISO 8601 date string.
23
+
24
+
Accepts various formats with partial date support:
25
+
- "2001" (year only) → (2001, 1, 1)
26
+
- "2001-01" (year-month) → (2001, 1, 1)
27
+
- "2001-01-15" (full date) → (2001, 1, 15)
28
+
29
+
Returns [None] if the string is not a valid date format. *)
30
+
val parse_date_string : string -> date option
31
+
32
+
(** [format_date date] formats a date as ISO 8601 (YYYY-MM-DD).
33
+
34
+
{b Example:} [format_date (2001, 1, 15)] returns ["2001-01-15"] *)
35
+
val format_date : date -> string
36
+
37
+
(** {1 Temporal Ranges} *)
38
+
39
+
(** A temporal range indicating validity period. *)
40
+
type range = {
41
+
from: date option; (** Start date (inclusive). [None] means from the beginning. *)
42
+
until: date option; (** End date (exclusive). [None] means continuing/indefinite. *)
43
+
}
44
+
45
+
(** {1 Range Construction} *)
46
+
47
+
(** [make ?from ?until ()] creates a temporal range. *)
48
+
val make : ?from:date -> ?until:date -> unit -> range
49
+
50
+
(** [always] is a range that is always valid (no from/until bounds). *)
51
+
val always : range
52
+
53
+
(** {1 Range Queries} *)
54
+
55
+
(** [valid_at range ~date] checks if [range] is valid at the given [date].
56
+
57
+
- [None] range means always valid
58
+
- [None] from means valid from beginning
59
+
- [None] until means valid continuing *)
60
+
val valid_at : range option -> date:date -> bool
61
+
62
+
(** [overlaps r1 r2] checks if two ranges overlap in time. *)
63
+
val overlaps : range -> range -> bool
64
+
65
+
(** [is_current range] checks if range is valid at the current date.
66
+
Uses today's date for the check. *)
67
+
val is_current : range option -> bool
68
+
69
+
(** {1 List Filtering} *)
70
+
71
+
(** [current ~get list] returns the first current/valid item from [list].
72
+
73
+
@param get Function to extract the temporal range from an item.
74
+
Returns the first item where the range is currently valid,
75
+
or the first item without temporal bounds if none are current. *)
76
+
val current : get:('a -> range option) -> 'a list -> 'a option
77
+
78
+
(** [at_date ~get ~date list] filters [list] to items valid at [date].
79
+
80
+
@param get Function to extract the temporal range from an item.
81
+
@param date The date to check validity against. *)
82
+
val at_date : get:('a -> range option) -> date:date -> 'a list -> 'a list
83
+
84
+
(** [filter ~get ~from ~until list] filters [list] to items overlapping the period.
85
+
86
+
Returns items whose temporal range overlaps with the given period. *)
87
+
val filter : get:('a -> range option) -> from:date option -> until:date option ->
88
+
'a list -> 'a list
89
+
90
+
(** {1 JSON Encoding} *)
91
+
92
+
(** [json_t] is the jsont encoder/decoder for temporal ranges.
93
+
94
+
Encodes as a JSON object with optional [from] and [until] fields:
95
+
{[ { "from": "2001-01", "until": "2003-12" } ]}
96
+
97
+
Empty object [\{\}] or missing field represents [always]. *)
98
+
val json_t : range Jsont.t
+47
sortal.opam
+47
sortal.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis:
4
+
"Contact metadata management with XDG storage and versioned schemas"
5
+
description: """
6
+
Sortal provides contact metadata management with versioned schemas,
7
+
XDG-compliant storage, git versioning, and CLI tools.
8
+
9
+
The library is split into two components:
10
+
- sortal.schema: Versioned data types with minimal dependencies
11
+
- sortal: Core library with storage, git integration, and CLI support"""
12
+
maintainer: ["Anil Madhavapeddy <anil@recoil.org>"]
13
+
authors: ["Anil Madhavapeddy"]
14
+
license: "ISC"
15
+
homepage: "https://tangled.org/@anil.recoil.org/sortal"
16
+
bug-reports: "https://tangled.org/@anil.recoil.org/sortal/issues"
17
+
depends: [
18
+
"dune" {>= "3.20"}
19
+
"ocaml" {>= "5.1.0"}
20
+
"eio"
21
+
"eio_main"
22
+
"xdge"
23
+
"jsont"
24
+
"ptime"
25
+
"yamlt"
26
+
"bytesrw"
27
+
"fmt"
28
+
"cmdliner"
29
+
"logs"
30
+
"odoc" {with-doc}
31
+
"alcotest" {with-test & >= "1.7.0"}
32
+
]
33
+
build: [
34
+
["dune" "subst"] {dev}
35
+
[
36
+
"dune"
37
+
"build"
38
+
"-p"
39
+
name
40
+
"-j"
41
+
jobs
42
+
"@install"
43
+
"@runtest" {with-test}
44
+
"@doc" {with-doc}
45
+
]
46
+
]
47
+
x-maintenance-intent: ["(latest)"]
+7
test/dune
+7
test/dune
+53
test/test_schema.ml
+53
test/test_schema.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Schema-only tests (no I/O dependencies) *)
7
+
8
+
let test_temporal () =
9
+
(* Parse dates from strings *)
10
+
let from_date = Sortal_schema.Temporal.parse_date_string "2020-01" |> Option.get in
11
+
let until_date = Sortal_schema.Temporal.parse_date_string "2023-12" |> Option.get in
12
+
let test_date_1 = Sortal_schema.Temporal.parse_date_string "2021-06" |> Option.get in
13
+
let test_date_2 = Sortal_schema.Temporal.parse_date_string "2024-01" |> Option.get in
14
+
15
+
let r = Sortal_schema.Temporal.make ~from:from_date ~until:until_date () in
16
+
assert (Sortal_schema.Temporal.valid_at (Some r) ~date:test_date_1);
17
+
assert (not (Sortal_schema.Temporal.valid_at (Some r) ~date:test_date_2));
18
+
print_endline "✓ Temporal ranges work"
19
+
20
+
let test_feed_types () =
21
+
let feed = Sortal_schema.Feed.make ~feed_type:Atom ~url:"https://example.com/feed" () in
22
+
assert (Sortal_schema.Feed.url feed = "https://example.com/feed");
23
+
print_endline "✓ Feed types work"
24
+
25
+
let test_contact_construction () =
26
+
let c = Sortal_schema.Contact.make
27
+
~handle:"test"
28
+
~names:["Test User"]
29
+
~emails:[Sortal_schema.Contact.email_of_string "test@example.com"]
30
+
() in
31
+
assert (Sortal_schema.Contact.handle c = "test");
32
+
assert (Sortal_schema.Contact.name c = "Test User");
33
+
print_endline "✓ Contact construction works"
34
+
35
+
let test_json_roundtrip () =
36
+
let c = Sortal_schema.Contact.make ~handle:"json" ~names:["JSON Test"] () in
37
+
match Jsont_bytesrw.encode_string Sortal_schema.Contact.json_t c with
38
+
| Ok json ->
39
+
(match Jsont_bytesrw.decode_string Sortal_schema.Contact.json_t json with
40
+
| Ok decoded ->
41
+
assert (Sortal_schema.Contact.handle decoded = "json");
42
+
assert (Sortal_schema.Contact.name decoded = "JSON Test");
43
+
print_endline "✓ JSON roundtrip works"
44
+
| Error e -> failwith ("Decode failed: " ^ e))
45
+
| Error e -> failwith ("Encode failed: " ^ e)
46
+
47
+
let () =
48
+
print_endline "\n=== Schema Tests ===\n";
49
+
test_temporal ();
50
+
test_feed_types ();
51
+
test_contact_construction ();
52
+
test_json_roundtrip ();
53
+
print_endline "\n=== All Schema Tests Passed ===\n"
+205
test/test_sortal.ml
+205
test/test_sortal.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Tests for the Sortal library *)
7
+
8
+
open Eio.Std
9
+
10
+
let test_contact_creation () =
11
+
let c = Sortal.Contact.make
12
+
~handle:"test"
13
+
~names:["Test User"; "T. User"]
14
+
~emails:[Sortal.Contact.email_of_string "test@example.com"]
15
+
~services:[Sortal.Contact.make_service ~kind:Git ~handle:"testuser" "https://github.com/testuser"]
16
+
() in
17
+
assert (Sortal.Contact.handle c = "test");
18
+
assert (Sortal.Contact.name c = "Test User");
19
+
assert (List.length (Sortal.Contact.names c) = 2);
20
+
assert (Sortal.Contact.current_email c = Some "test@example.com");
21
+
assert (List.length (Sortal.Contact.services c) = 1);
22
+
assert (List.length (Sortal.Contact.services_of_kind c Git) = 1);
23
+
traceln "✓ Contact creation works"
24
+
25
+
let test_best_url () =
26
+
let c1 = Sortal.Contact.make
27
+
~handle:"test1"
28
+
~names:["Test 1"]
29
+
~urls:[Sortal.Contact.url_of_string "https://example.com"]
30
+
~services:[Sortal.Contact.service_of_url "https://github.com/test1"]
31
+
() in
32
+
assert (Sortal.Contact.best_url c1 = Some "https://example.com");
33
+
34
+
let c2 = Sortal.Contact.make
35
+
~handle:"test2"
36
+
~names:["Test 2"]
37
+
~services:[Sortal.Contact.service_of_url "https://github.com/test2"]
38
+
() in
39
+
assert (Sortal.Contact.best_url c2 = Some "https://github.com/test2");
40
+
41
+
let c3 = Sortal.Contact.make
42
+
~handle:"test3"
43
+
~names:["Test 3"]
44
+
~emails:[Sortal.Contact.email_of_string "test3@example.com"]
45
+
() in
46
+
assert (Sortal.Contact.best_url c3 = Some "mailto:test3@example.com");
47
+
48
+
let c4 = Sortal.Contact.make
49
+
~handle:"test4"
50
+
~names:["Test 4"]
51
+
() in
52
+
assert (Sortal.Contact.best_url c4 = None);
53
+
54
+
traceln "✓ Best URL selection works"
55
+
56
+
let test_json_encoding () =
57
+
let c = Sortal.Contact.make
58
+
~handle:"json_test"
59
+
~names:["JSON Test"]
60
+
~emails:[Sortal.Contact.email_of_string "json@example.com"]
61
+
~services:[Sortal.Contact.make_service ~kind:Git ~handle:"jsontest" "https://github.com/jsontest"]
62
+
~orcid:"0000-0001-2345-6789"
63
+
() in
64
+
65
+
match Jsont_bytesrw.encode_string Sortal.Contact.json_t c with
66
+
| Ok json_str ->
67
+
(match Jsont_bytesrw.decode_string Sortal.Contact.json_t json_str with
68
+
| Ok decoded ->
69
+
assert (Sortal.Contact.handle decoded = "json_test");
70
+
assert (Sortal.Contact.current_email decoded = Some "json@example.com");
71
+
assert (List.length (Sortal.Contact.services_of_kind decoded Git) = 1);
72
+
assert (Sortal.Contact.orcid decoded = Some "0000-0001-2345-6789");
73
+
traceln "✓ JSON encoding/decoding works"
74
+
| Error err ->
75
+
failwith ("JSON decode failed: " ^ err))
76
+
| Error err ->
77
+
failwith ("JSON encode failed: " ^ err)
78
+
79
+
let test_handle_generation () =
80
+
assert (Sortal.handle_of_name "John Smith" = "jssmith");
81
+
assert (Sortal.handle_of_name "Alice Barbara Cooper" = "abccooper");
82
+
assert (Sortal.handle_of_name "Bob" = "bbob");
83
+
traceln "✓ Handle generation works"
84
+
85
+
let test_store_operations () =
86
+
Eio_main.run @@ fun env ->
87
+
88
+
(* Create a store with a test app name *)
89
+
let store = Sortal.create env#fs "sortal-test" in
90
+
91
+
(* Create test contacts *)
92
+
let c1 = Sortal.Contact.make
93
+
~handle:"alice"
94
+
~names:["Alice Anderson"]
95
+
~emails:[Sortal.Contact.email_of_string "alice@example.com"]
96
+
() in
97
+
98
+
let c2 = Sortal.Contact.make
99
+
~handle:"bob"
100
+
~names:["Bob Brown"; "Robert Brown"]
101
+
~services:[Sortal.Contact.service_of_url "https://github.com/bobbrown"]
102
+
() in
103
+
104
+
(* Test save *)
105
+
Sortal.save store c1;
106
+
Sortal.save store c2;
107
+
traceln "✓ Saving contacts works";
108
+
109
+
(* Test lookup *)
110
+
(match Sortal.lookup store "alice" with
111
+
| Some c ->
112
+
assert (Sortal.Contact.name c = "Alice Anderson");
113
+
traceln "✓ Lookup works"
114
+
| None -> failwith "Lookup failed to find saved contact");
115
+
116
+
(* Test lookup of non-existent contact *)
117
+
(match Sortal.lookup store "nonexistent" with
118
+
| None -> traceln "✓ Lookup correctly returns None for missing contact"
119
+
| Some _ -> failwith "Lookup should return None for non-existent contact");
120
+
121
+
(* Test list *)
122
+
let all = Sortal.list store in
123
+
assert (List.length all >= 2);
124
+
traceln "✓ List returns saved contacts (%d total)" (List.length all);
125
+
126
+
(* Test find_by_name *)
127
+
let found = Sortal.find_by_name store "Bob Brown" in
128
+
assert (Sortal.Contact.handle found = "bob");
129
+
traceln "✓ Find by name works";
130
+
131
+
(* Test find_by_name_opt *)
132
+
(match Sortal.find_by_name_opt store "Alice Anderson" with
133
+
| Some c ->
134
+
assert (Sortal.Contact.handle c = "alice");
135
+
traceln "✓ Find by name (optional) works"
136
+
| None -> failwith "find_by_name_opt failed");
137
+
138
+
(match Sortal.find_by_name_opt store "Nobody" with
139
+
| None -> traceln "✓ Find by name (optional) returns None for missing"
140
+
| Some _ -> failwith "find_by_name_opt should return None");
141
+
142
+
(* Test delete *)
143
+
Sortal.delete store "alice";
144
+
(match Sortal.lookup store "alice" with
145
+
| None -> traceln "✓ Delete works"
146
+
| Some _ -> failwith "Contact should have been deleted");
147
+
148
+
(* Clean up remaining test contact *)
149
+
Sortal.delete store "bob";
150
+
traceln "✓ Test cleanup complete"
151
+
152
+
let test_contact_compare () =
153
+
let c1 = Sortal.Contact.make ~handle:"alice" ~names:["Alice"] () in
154
+
let c2 = Sortal.Contact.make ~handle:"bob" ~names:["Bob"] () in
155
+
let c3 = Sortal.Contact.make ~handle:"alice" ~names:["Alice2"] () in
156
+
157
+
assert (Sortal.Contact.compare c1 c2 < 0);
158
+
assert (Sortal.Contact.compare c2 c1 > 0);
159
+
assert (Sortal.Contact.compare c1 c3 = 0);
160
+
traceln "✓ Contact comparison works"
161
+
162
+
let test_urls () =
163
+
(* Test with only url set *)
164
+
let c1 = Sortal.Contact.make
165
+
~handle:"test1"
166
+
~names:["Test 1"]
167
+
~urls:[Sortal.Contact.url_of_string "https://example.com"]
168
+
() in
169
+
assert (Sortal.Contact.current_url c1 = Some "https://example.com");
170
+
assert (List.length (Sortal.Contact.urls c1) = 1);
171
+
172
+
(* Test with multiple urls *)
173
+
let c2 = Sortal.Contact.make
174
+
~handle:"test2"
175
+
~names:["Test 2"]
176
+
~urls:[
177
+
Sortal.Contact.url_of_string "https://one.com";
178
+
Sortal.Contact.url_of_string "https://two.com"
179
+
]
180
+
() in
181
+
assert (Sortal.Contact.current_url c2 = Some "https://one.com");
182
+
assert (List.length (Sortal.Contact.urls c2) = 2);
183
+
184
+
(* Test with no urls *)
185
+
let c3 = Sortal.Contact.make
186
+
~handle:"test3"
187
+
~names:["Test 3"]
188
+
() in
189
+
assert (Sortal.Contact.current_url c3 = None);
190
+
assert (Sortal.Contact.urls c3 = []);
191
+
192
+
traceln "✓ URLs field works correctly"
193
+
194
+
let () =
195
+
traceln "\n=== Running Sortal Tests ===\n";
196
+
197
+
test_contact_creation ();
198
+
test_best_url ();
199
+
test_json_encoding ();
200
+
test_handle_generation ();
201
+
test_contact_compare ();
202
+
test_urls ();
203
+
test_store_operations ();
204
+
205
+
traceln "\n=== All Tests Passed ===\n"