anil.recoil.org
Matrix protocol in OCaml, Eio specialised
1(** Session persistence for Matrix clients.
2
3 Implementation using tomlt for TOML serialization and
4 xdge for XDG directory management. *)
5
6module Ed25519 = Mirage_crypto_ec.Ed25519
7module X25519 = Mirage_crypto_ec.X25519
8
9(* Helper for URI TOML codec *)
10let uri_tomlt : Uri.t Tomlt.t =
11 Tomlt.map
12 ~dec:Uri.of_string
13 ~enc:Uri.to_string
14 Tomlt.string
15
16(* Helper for User_id TOML codec *)
17let user_id_tomlt : Matrix_proto.Id.User_id.t Tomlt.t =
18 Tomlt.map
19 ~dec:(fun s ->
20 match Matrix_proto.Id.User_id.of_string s with
21 | Ok id -> id
22 | Error _ -> failwith ("Invalid user_id: " ^ s))
23 ~enc:Matrix_proto.Id.User_id.to_string
24 Tomlt.string
25
26(* Helper for Device_id TOML codec *)
27let device_id_tomlt : Matrix_proto.Id.Device_id.t Tomlt.t =
28 Tomlt.map
29 ~dec:(fun s ->
30 match Matrix_proto.Id.Device_id.of_string s with
31 | Ok id -> id
32 | Error _ -> failwith ("Invalid device_id: " ^ s))
33 ~enc:Matrix_proto.Id.Device_id.to_string
34 Tomlt.string
35
36(* Helper for Room_id TOML codec *)
37let room_id_tomlt : Matrix_proto.Id.Room_id.t Tomlt.t =
38 Tomlt.map
39 ~dec:(fun s ->
40 match Matrix_proto.Id.Room_id.of_string s with
41 | Ok id -> id
42 | Error _ -> failwith ("Invalid room_id: " ^ s))
43 ~enc:Matrix_proto.Id.Room_id.to_string
44 Tomlt.string
45
46(* Ptime codec using UTC *)
47let ptime_tomlt : Ptime.t Tomlt.t = Tomlt.ptime ~tz_offset_s:0 ()
48
49module Server = struct
50 type t = {
51 homeserver : Uri.t;
52 user_id : Matrix_proto.Id.User_id.t;
53 }
54
55 let tomlt : t Tomlt.t =
56 Tomlt.Table.(
57 obj (fun homeserver user_id -> { homeserver; user_id })
58 |> mem "homeserver" uri_tomlt ~enc:(fun t -> t.homeserver)
59 |> mem "user_id" user_id_tomlt ~enc:(fun t -> t.user_id)
60 |> finish)
61end
62
63module Auth = struct
64 type t = {
65 access_token : string;
66 device_id : Matrix_proto.Id.Device_id.t;
67 refresh_token : string option;
68 }
69
70 let tomlt : t Tomlt.t =
71 Tomlt.Table.(
72 obj (fun access_token device_id refresh_token ->
73 { access_token; device_id; refresh_token })
74 |> mem "access_token" Tomlt.string ~enc:(fun t -> t.access_token)
75 |> mem "device_id" device_id_tomlt ~enc:(fun t -> t.device_id)
76 |> opt_mem "refresh_token" Tomlt.string ~enc:(fun t -> t.refresh_token)
77 |> finish)
78end
79
80module Sync_state = struct
81 type t = {
82 next_batch : string option;
83 filter_id : string option;
84 }
85
86 let tomlt : t Tomlt.t =
87 Tomlt.Table.(
88 obj (fun next_batch filter_id -> { next_batch; filter_id })
89 |> opt_mem "next_batch" Tomlt.string ~enc:(fun t -> t.next_batch)
90 |> opt_mem "filter_id" Tomlt.string ~enc:(fun t -> t.filter_id)
91 |> finish)
92end
93
94module Metadata = struct
95 type t = {
96 created_at : Ptime.t;
97 last_used_at : Ptime.t;
98 client_name : string;
99 }
100
101 let tomlt : t Tomlt.t =
102 Tomlt.Table.(
103 obj (fun created_at last_used_at client_name ->
104 { created_at; last_used_at; client_name })
105 |> mem "created_at" ptime_tomlt ~enc:(fun t -> t.created_at)
106 |> mem "last_used_at" ptime_tomlt ~enc:(fun t -> t.last_used_at)
107 |> mem "client_name" Tomlt.string ~enc:(fun t -> t.client_name)
108 |> finish)
109end
110
111module Session_file = struct
112 type t = {
113 server : Server.t;
114 auth : Auth.t;
115 sync : Sync_state.t;
116 metadata : Metadata.t;
117 }
118
119 let tomlt : t Tomlt.t =
120 Tomlt.Table.(
121 obj (fun server auth sync metadata ->
122 { server; auth; sync; metadata })
123 |> mem "server" Server.tomlt ~enc:(fun t -> t.server)
124 |> mem "auth" Auth.tomlt ~enc:(fun t -> t.auth)
125 |> mem "sync" Sync_state.tomlt ~enc:(fun t -> t.sync)
126 |> mem "metadata" Metadata.tomlt ~enc:(fun t -> t.metadata)
127 |> finish)
128end
129
130module Device_keys = struct
131 type t = {
132 ed25519_public : string;
133 ed25519_private : string;
134 curve25519_public : string;
135 curve25519_private : string;
136 uploaded_at : Ptime.t option;
137 algorithms : string list;
138 }
139
140 let tomlt : t Tomlt.t =
141 Tomlt.Table.(
142 obj (fun ed25519_public ed25519_private curve25519_public
143 curve25519_private uploaded_at algorithms ->
144 { ed25519_public; ed25519_private; curve25519_public;
145 curve25519_private; uploaded_at; algorithms })
146 |> mem "ed25519_public" Tomlt.string ~enc:(fun t -> t.ed25519_public)
147 |> mem "ed25519_private" Tomlt.string ~enc:(fun t -> t.ed25519_private)
148 |> mem "curve25519_public" Tomlt.string ~enc:(fun t -> t.curve25519_public)
149 |> mem "curve25519_private" Tomlt.string ~enc:(fun t -> t.curve25519_private)
150 |> opt_mem "uploaded_at" ptime_tomlt ~enc:(fun t -> t.uploaded_at)
151 |> mem "algorithms" (Tomlt.list Tomlt.string) ~dec_absent:[]
152 ~enc:(fun t -> t.algorithms)
153 |> finish)
154end
155
156module One_time_key = struct
157 type t = {
158 key_id : string;
159 public : string;
160 private_ : string;
161 created_at : Ptime.t;
162 }
163
164 let tomlt : t Tomlt.t =
165 Tomlt.Table.(
166 obj (fun key_id public private_ created_at ->
167 { key_id; public; private_; created_at })
168 |> mem "key_id" Tomlt.string ~enc:(fun t -> t.key_id)
169 |> mem "public" Tomlt.string ~enc:(fun t -> t.public)
170 |> mem "private" Tomlt.string ~enc:(fun t -> t.private_)
171 |> mem "created_at" ptime_tomlt ~enc:(fun t -> t.created_at)
172 |> finish)
173end
174
175module One_time_keys_file = struct
176 type t = {
177 target_count : int;
178 last_upload_at : Ptime.t option;
179 next_key_id : int;
180 keys : One_time_key.t list;
181 fallback : One_time_key.t option;
182 fallback_used : bool;
183 }
184
185 let config_tomlt =
186 Tomlt.Table.(
187 obj (fun target_count last_upload_at next_key_id ->
188 (target_count, last_upload_at, next_key_id))
189 |> mem "target_count" Tomlt.int ~dec_absent:50
190 ~enc:(fun (tc, _, _) -> tc)
191 |> opt_mem "last_upload_at" ptime_tomlt
192 ~enc:(fun (_, lu, _) -> lu)
193 |> mem "next_key_id" Tomlt.int ~dec_absent:0
194 ~enc:(fun (_, _, nk) -> nk)
195 |> finish)
196
197 let tomlt : t Tomlt.t =
198 Tomlt.Table.(
199 obj (fun config keys fallback fallback_used ->
200 let target_count, last_upload_at, next_key_id = config in
201 { target_count; last_upload_at; next_key_id;
202 keys; fallback; fallback_used })
203 |> mem "config" config_tomlt
204 ~enc:(fun t -> (t.target_count, t.last_upload_at, t.next_key_id))
205 |> mem "keys" (Tomlt.list One_time_key.tomlt) ~dec_absent:[]
206 ~enc:(fun t -> t.keys)
207 |> opt_mem "fallback" One_time_key.tomlt ~enc:(fun t -> t.fallback)
208 |> mem "fallback_used" Tomlt.bool ~dec_absent:false
209 ~enc:(fun t -> t.fallback_used)
210 |> finish)
211end
212
213module Olm_session = struct
214 type t = {
215 their_identity_key : string;
216 session_id : string;
217 pickle : string;
218 created_at : Ptime.t;
219 last_used_at : Ptime.t;
220 }
221
222 let tomlt : t Tomlt.t =
223 Tomlt.Table.(
224 obj (fun their_identity_key session_id pickle created_at last_used_at ->
225 { their_identity_key; session_id; pickle; created_at; last_used_at })
226 |> mem "their_identity_key" Tomlt.string
227 ~enc:(fun t -> t.their_identity_key)
228 |> mem "session_id" Tomlt.string ~enc:(fun t -> t.session_id)
229 |> mem "pickle" Tomlt.string ~enc:(fun t -> t.pickle)
230 |> mem "created_at" ptime_tomlt ~enc:(fun t -> t.created_at)
231 |> mem "last_used_at" ptime_tomlt ~enc:(fun t -> t.last_used_at)
232 |> finish)
233end
234
235module Olm_sessions_file = struct
236 type t = { sessions : Olm_session.t list }
237
238 let tomlt : t Tomlt.t =
239 Tomlt.Table.(
240 obj (fun sessions -> { sessions })
241 |> mem "sessions" (Tomlt.list Olm_session.tomlt) ~dec_absent:[]
242 ~enc:(fun t -> t.sessions)
243 |> finish)
244end
245
246module Megolm_inbound = struct
247 type t = {
248 room_id : Matrix_proto.Id.Room_id.t;
249 session_id : string;
250 sender_key : string;
251 signing_key : string;
252 pickle : string;
253 first_known_index : int;
254 created_at : Ptime.t;
255 }
256
257 let tomlt : t Tomlt.t =
258 Tomlt.Table.(
259 obj (fun room_id session_id sender_key signing_key pickle
260 first_known_index created_at ->
261 { room_id; session_id; sender_key; signing_key; pickle;
262 first_known_index; created_at })
263 |> mem "room_id" room_id_tomlt ~enc:(fun t -> t.room_id)
264 |> mem "session_id" Tomlt.string ~enc:(fun t -> t.session_id)
265 |> mem "sender_key" Tomlt.string ~enc:(fun t -> t.sender_key)
266 |> mem "signing_key" Tomlt.string ~enc:(fun t -> t.signing_key)
267 |> mem "pickle" Tomlt.string ~enc:(fun t -> t.pickle)
268 |> mem "first_known_index" Tomlt.int ~enc:(fun t -> t.first_known_index)
269 |> mem "created_at" ptime_tomlt ~enc:(fun t -> t.created_at)
270 |> finish)
271end
272
273module Megolm_inbound_file = struct
274 type t = { sessions : Megolm_inbound.t list }
275
276 let tomlt : t Tomlt.t =
277 Tomlt.Table.(
278 obj (fun sessions -> { sessions })
279 |> mem "sessions" (Tomlt.list Megolm_inbound.tomlt) ~dec_absent:[]
280 ~enc:(fun t -> t.sessions)
281 |> finish)
282end
283
284module Shared_with = struct
285 type t = {
286 user_id : Matrix_proto.Id.User_id.t;
287 device_id : Matrix_proto.Id.Device_id.t;
288 shared_at : Ptime.t;
289 }
290
291 let tomlt : t Tomlt.t =
292 Tomlt.Table.(
293 obj (fun user_id device_id shared_at ->
294 { user_id; device_id; shared_at })
295 |> mem "user_id" user_id_tomlt ~enc:(fun t -> t.user_id)
296 |> mem "device_id" device_id_tomlt ~enc:(fun t -> t.device_id)
297 |> mem "shared_at" ptime_tomlt ~enc:(fun t -> t.shared_at)
298 |> finish)
299end
300
301module Megolm_outbound = struct
302 type t = {
303 room_id : Matrix_proto.Id.Room_id.t;
304 session_id : string;
305 pickle : string;
306 message_index : int;
307 created_at : Ptime.t;
308 message_count : int;
309 max_age_ms : int64;
310 shared_with : Shared_with.t list;
311 }
312
313 let tomlt : t Tomlt.t =
314 Tomlt.Table.(
315 obj (fun room_id session_id pickle message_index created_at
316 message_count max_age_ms shared_with ->
317 { room_id; session_id; pickle; message_index; created_at;
318 message_count; max_age_ms; shared_with })
319 |> mem "room_id" room_id_tomlt ~enc:(fun t -> t.room_id)
320 |> mem "session_id" Tomlt.string ~enc:(fun t -> t.session_id)
321 |> mem "pickle" Tomlt.string ~enc:(fun t -> t.pickle)
322 |> mem "message_index" Tomlt.int ~enc:(fun t -> t.message_index)
323 |> mem "created_at" ptime_tomlt ~enc:(fun t -> t.created_at)
324 |> mem "message_count" Tomlt.int ~enc:(fun t -> t.message_count)
325 |> mem "max_age_ms" Tomlt.int64 ~enc:(fun t -> t.max_age_ms)
326 |> mem "shared_with" (Tomlt.list Shared_with.tomlt) ~dec_absent:[]
327 ~enc:(fun t -> t.shared_with)
328 |> finish)
329end
330
331module Megolm_outbound_file = struct
332 type t = { sessions : Megolm_outbound.t list }
333
334 let tomlt : t Tomlt.t =
335 Tomlt.Table.(
336 obj (fun sessions -> { sessions })
337 |> mem "sessions" (Tomlt.list Megolm_outbound.tomlt) ~dec_absent:[]
338 ~enc:(fun t -> t.sessions)
339 |> finish)
340end
341
342(* ============================================================ *)
343(* Pickle Functions using jsont *)
344(* ============================================================ *)
345
346module Pickle = struct
347 (* Base64 encoding/decoding - Matrix uses unpadded base64 *)
348 let base64_encode s = Base64.encode_string ~pad:false s
349 let base64_decode s =
350 match Base64.decode ~pad:false s with
351 | Ok s -> s
352 | Error _ -> failwith "Invalid base64"
353
354 (* Jsont codec for Ed25519 private key *)
355 let ed25519_priv_jsont : Ed25519.priv Jsont.t =
356 Jsont.map
357 ~dec:(fun s ->
358 let octets = base64_decode s in
359 match Ed25519.priv_of_octets octets with
360 | Ok priv -> priv
361 | Error _ -> failwith "Invalid Ed25519 private key")
362 ~enc:(fun priv -> Ed25519.priv_to_octets priv |> base64_encode)
363 Jsont.string
364
365 (* Jsont codec for Ed25519 public key *)
366 let ed25519_pub_jsont : Ed25519.pub Jsont.t =
367 Jsont.map
368 ~dec:(fun s ->
369 let octets = base64_decode s in
370 match Ed25519.pub_of_octets octets with
371 | Ok pub -> pub
372 | Error _ -> failwith "Invalid Ed25519 public key")
373 ~enc:(fun pub -> Ed25519.pub_to_octets pub |> base64_encode)
374 Jsont.string
375
376 (* Jsont codec for X25519 secret *)
377 let x25519_secret_jsont : X25519.secret Jsont.t =
378 Jsont.map
379 ~dec:(fun s ->
380 let octets = base64_decode s in
381 match X25519.secret_of_octets octets with
382 | Ok (secret, _) -> secret
383 | Error _ -> failwith "Invalid X25519 secret key")
384 ~enc:(fun secret -> X25519.secret_to_octets secret |> base64_encode)
385 Jsont.string
386
387 (* Jsont codec for Ptime.t as ISO 8601 string *)
388 let ptime_jsont : Ptime.t Jsont.t =
389 Jsont.map
390 ~dec:(fun s ->
391 match Ptime.of_rfc3339 s with
392 | Ok (t, _, _) -> t
393 | Error _ -> failwith "Invalid RFC3339 timestamp")
394 ~enc:(fun t -> Ptime.to_rfc3339 ~tz_offset_s:0 t)
395 Jsont.string
396
397 (* ------------------------------------------------------------ *)
398 (* Olm.Account pickle *)
399 (* ------------------------------------------------------------ *)
400
401 type account_pickle = {
402 ed25519_priv : Ed25519.priv;
403 ed25519_pub : Ed25519.pub;
404 curve25519_secret : X25519.secret;
405 curve25519_public : string;
406 one_time_keys : (string * string * string) list;
407 (* key_id, secret_b64, public_b64 *)
408 fallback_key : (string * string * string) option;
409 next_key_id : int;
410 max_one_time_keys : int;
411 }
412
413 let account_pickle_jsont : account_pickle Jsont.t =
414 Jsont.Object.(
415 map (fun ed25519_priv ed25519_pub curve25519_secret curve25519_public
416 one_time_keys fallback_key next_key_id max_one_time_keys ->
417 { ed25519_priv; ed25519_pub; curve25519_secret; curve25519_public;
418 one_time_keys; fallback_key; next_key_id; max_one_time_keys })
419 |> mem "ed25519_priv" ed25519_priv_jsont
420 |> mem "ed25519_pub" ed25519_pub_jsont
421 |> mem "curve25519_secret" x25519_secret_jsont
422 |> mem "curve25519_public" Jsont.string
423 |> mem "one_time_keys"
424 (Jsont.list (Jsont.list Jsont.string |> Jsont.map
425 ~dec:(function
426 | [a; b; c] -> (a, b, c)
427 | _ -> failwith "Expected 3 elements")
428 ~enc:(fun (a, b, c) -> [a; b; c])))
429 |> opt_mem "fallback_key"
430 (Jsont.list Jsont.string |> Jsont.map
431 ~dec:(function
432 | [a; b; c] -> (a, b, c)
433 | _ -> failwith "Expected 3 elements")
434 ~enc:(fun (a, b, c) -> [a; b; c]))
435 |> mem "next_key_id" Jsont.int
436 |> mem "max_one_time_keys" Jsont.int
437 |> finish)
438
439 let pickle_account (account : Olm.Account.t) : string =
440 let one_time_keys =
441 List.map (fun (key_id, (secret, public)) ->
442 (key_id, X25519.secret_to_octets secret |> base64_encode,
443 base64_encode public))
444 account.one_time_keys
445 in
446 let fallback_key =
447 Option.map (fun (key_id, (secret, public)) ->
448 (key_id, X25519.secret_to_octets secret |> base64_encode,
449 base64_encode public))
450 account.fallback_key
451 in
452 let pickle = {
453 ed25519_priv = account.ed25519_priv;
454 ed25519_pub = account.ed25519_pub;
455 curve25519_secret = account.curve25519_secret;
456 curve25519_public = account.curve25519_public;
457 one_time_keys;
458 fallback_key;
459 next_key_id = account.next_key_id;
460 max_one_time_keys = account.max_one_time_keys;
461 } in
462 match Jsont_bytesrw.encode_string account_pickle_jsont pickle with
463 | Ok s -> s
464 | Error e -> failwith ("Failed to pickle account: " ^ e)
465
466 let unpickle_account (s : string) : (Olm.Account.t, string) result =
467 match Jsont_bytesrw.decode_string account_pickle_jsont s with
468 | Error e -> Error ("Failed to unpickle account: " ^ e)
469 | Ok pickle ->
470 let one_time_keys =
471 List.map (fun (key_id, secret_b64, public_b64) ->
472 let secret =
473 match X25519.secret_of_octets (base64_decode secret_b64) with
474 | Ok (s, _) -> s
475 | Error _ -> failwith "Invalid X25519 secret"
476 in
477 let public = base64_decode public_b64 in
478 (key_id, (secret, public)))
479 pickle.one_time_keys
480 in
481 let fallback_key =
482 Option.map (fun (key_id, secret_b64, public_b64) ->
483 let secret =
484 match X25519.secret_of_octets (base64_decode secret_b64) with
485 | Ok (s, _) -> s
486 | Error _ -> failwith "Invalid X25519 secret"
487 in
488 let public = base64_decode public_b64 in
489 (key_id, (secret, public)))
490 pickle.fallback_key
491 in
492 Ok {
493 Olm.Account.ed25519_priv = pickle.ed25519_priv;
494 ed25519_pub = pickle.ed25519_pub;
495 curve25519_secret = pickle.curve25519_secret;
496 curve25519_public = pickle.curve25519_public;
497 one_time_keys;
498 fallback_key;
499 next_key_id = pickle.next_key_id;
500 max_one_time_keys = pickle.max_one_time_keys;
501 }
502
503 (* ------------------------------------------------------------ *)
504 (* Olm.Session pickle *)
505 (* ------------------------------------------------------------ *)
506
507 type chain_key_pickle = {
508 key : string; (* base64 *)
509 index : int;
510 }
511
512 let chain_key_pickle_jsont : chain_key_pickle Jsont.t =
513 Jsont.Object.(
514 map (fun key index -> { key; index })
515 |> mem "key" Jsont.string
516 |> mem "index" Jsont.int
517 |> finish)
518
519 type session_pickle = {
520 session_id : string;
521 their_identity_key : string;
522 their_ratchet_key : string option;
523 our_ratchet_secret : string;
524 our_ratchet_public : string;
525 root_key : string;
526 sending_chain : chain_key_pickle option;
527 receiving_chains : (string * chain_key_pickle) list;
528 skipped_keys : ((string * int) * string) list;
529 creation_time : Ptime.t;
530 }
531
532 (* Encode (string, int) pair as a JSON object with "key" and "index" *)
533 let string_int_pair_jsont : (string * int) Jsont.t =
534 Jsont.Object.(
535 map (fun k i -> (k, i))
536 |> mem "key" Jsont.string
537 |> mem "index" Jsont.int
538 |> finish)
539
540 let session_pickle_jsont : session_pickle Jsont.t =
541 Jsont.Object.(
542 map (fun session_id their_identity_key their_ratchet_key
543 our_ratchet_secret our_ratchet_public root_key sending_chain
544 receiving_chains skipped_keys creation_time ->
545 { session_id; their_identity_key; their_ratchet_key;
546 our_ratchet_secret; our_ratchet_public; root_key; sending_chain;
547 receiving_chains; skipped_keys; creation_time })
548 |> mem "session_id" Jsont.string
549 |> mem "their_identity_key" Jsont.string
550 |> opt_mem "their_ratchet_key" Jsont.string
551 |> mem "our_ratchet_secret" Jsont.string
552 |> mem "our_ratchet_public" Jsont.string
553 |> mem "root_key" Jsont.string
554 |> opt_mem "sending_chain" chain_key_pickle_jsont
555 |> mem "receiving_chains"
556 (Jsont.list (Jsont.Object.(
557 map (fun k v -> (k, v))
558 |> mem "key" Jsont.string
559 |> mem "chain" chain_key_pickle_jsont
560 |> finish)))
561 |> mem "skipped_keys"
562 (Jsont.list (Jsont.Object.(
563 map (fun idx_key msg_key -> (idx_key, msg_key))
564 |> mem "index_key" string_int_pair_jsont
565 |> mem "msg_key" Jsont.string
566 |> finish)))
567 |> mem "creation_time" ptime_jsont
568 |> finish)
569
570 let pickle_session (session : Olm.Session.t) : string =
571 let sending_chain = Option.map (fun (ck : Olm.Session.chain_key) ->
572 { key = base64_encode ck.key; index = ck.index })
573 session.sending_chain
574 in
575 let receiving_chains =
576 List.map (fun (rk, (ck : Olm.Session.chain_key)) ->
577 (base64_encode rk, { key = base64_encode ck.key; index = ck.index }))
578 session.receiving_chains
579 in
580 let skipped_keys =
581 List.map (fun ((rk, idx), mk) ->
582 ((base64_encode rk, idx), base64_encode mk))
583 session.skipped_keys
584 in
585 let pickle = {
586 session_id = session.session_id;
587 their_identity_key = base64_encode session.their_identity_key;
588 their_ratchet_key = Option.map base64_encode session.their_ratchet_key;
589 our_ratchet_secret = X25519.secret_to_octets session.our_ratchet_secret
590 |> base64_encode;
591 our_ratchet_public = base64_encode session.our_ratchet_public;
592 root_key = base64_encode session.root_key;
593 sending_chain;
594 receiving_chains;
595 skipped_keys;
596 creation_time = session.creation_time;
597 } in
598 match Jsont_bytesrw.encode_string session_pickle_jsont pickle with
599 | Ok s -> s
600 | Error e -> failwith ("Failed to pickle session: " ^ e)
601
602 let unpickle_session (s : string) : (Olm.Session.t, string) result =
603 match Jsont_bytesrw.decode_string session_pickle_jsont s with
604 | Error e -> Error ("Failed to unpickle session: " ^ e)
605 | Ok pickle ->
606 let our_ratchet_secret =
607 match X25519.secret_of_octets (base64_decode pickle.our_ratchet_secret) with
608 | Ok (s, _) -> s
609 | Error _ -> failwith "Invalid ratchet secret"
610 in
611 let sending_chain = Option.map (fun p ->
612 { Olm.Session.key = base64_decode p.key; index = p.index })
613 pickle.sending_chain
614 in
615 let receiving_chains =
616 List.map (fun (rk_b64, p) ->
617 (base64_decode rk_b64,
618 { Olm.Session.key = base64_decode p.key; index = p.index }))
619 pickle.receiving_chains
620 in
621 let skipped_keys =
622 List.map (fun ((rk_b64, idx), mk_b64) ->
623 ((base64_decode rk_b64, idx), base64_decode mk_b64))
624 pickle.skipped_keys
625 in
626 Ok {
627 Olm.Session.session_id = pickle.session_id;
628 their_identity_key = base64_decode pickle.their_identity_key;
629 their_ratchet_key = Option.map base64_decode pickle.their_ratchet_key;
630 our_ratchet_secret;
631 our_ratchet_public = base64_decode pickle.our_ratchet_public;
632 root_key = base64_decode pickle.root_key;
633 sending_chain;
634 receiving_chains;
635 skipped_keys;
636 creation_time = pickle.creation_time;
637 }
638
639 (* ------------------------------------------------------------ *)
640 (* Megolm.Inbound pickle *)
641 (* ------------------------------------------------------------ *)
642
643 type megolm_inbound_pickle = {
644 session_id : string;
645 sender_key : string;
646 room_id : string;
647 ratchet : string list; (* 4 x base64 strings *)
648 message_index : int;
649 received_indices : int list;
650 signing_key : string;
651 creation_time : Ptime.t;
652 }
653
654 let megolm_inbound_pickle_jsont : megolm_inbound_pickle Jsont.t =
655 Jsont.Object.(
656 map (fun session_id sender_key room_id ratchet message_index
657 received_indices signing_key creation_time ->
658 { session_id; sender_key; room_id; ratchet; message_index;
659 received_indices; signing_key; creation_time })
660 |> mem "session_id" Jsont.string
661 |> mem "sender_key" Jsont.string
662 |> mem "room_id" Jsont.string
663 |> mem "ratchet" (Jsont.list Jsont.string)
664 |> mem "message_index" Jsont.int
665 |> mem "received_indices" (Jsont.list Jsont.int)
666 |> mem "signing_key" Jsont.string
667 |> mem "creation_time" ptime_jsont
668 |> finish)
669
670 let pickle_megolm_inbound (session : Olm.Megolm.Inbound.t) : string =
671 let ratchet = Array.to_list session.ratchet |> List.map base64_encode in
672 let pickle = {
673 session_id = session.session_id;
674 sender_key = session.sender_key;
675 room_id = session.room_id;
676 ratchet;
677 message_index = session.message_index;
678 received_indices = session.received_indices;
679 signing_key = session.signing_key;
680 creation_time = session.creation_time;
681 } in
682 match Jsont_bytesrw.encode_string megolm_inbound_pickle_jsont pickle with
683 | Ok s -> s
684 | Error e -> failwith ("Failed to pickle megolm inbound: " ^ e)
685
686 let unpickle_megolm_inbound (s : string)
687 : (Olm.Megolm.Inbound.t, string) result =
688 match Jsont_bytesrw.decode_string megolm_inbound_pickle_jsont s with
689 | Error e -> Error ("Failed to unpickle megolm inbound: " ^ e)
690 | Ok pickle ->
691 let ratchet =
692 List.map base64_decode pickle.ratchet |> Array.of_list
693 in
694 Ok {
695 Olm.Megolm.Inbound.session_id = pickle.session_id;
696 sender_key = pickle.sender_key;
697 room_id = pickle.room_id;
698 ratchet;
699 message_index = pickle.message_index;
700 received_indices = pickle.received_indices;
701 signing_key = pickle.signing_key;
702 creation_time = pickle.creation_time;
703 }
704
705 (* ------------------------------------------------------------ *)
706 (* Megolm.Outbound pickle *)
707 (* ------------------------------------------------------------ *)
708
709 type megolm_outbound_pickle = {
710 session_id : string;
711 room_id : string;
712 ratchet : string list;
713 message_index : int;
714 signing_priv : Ed25519.priv;
715 signing_pub : Ed25519.pub;
716 creation_time : Ptime.t;
717 message_count : int;
718 max_messages : int;
719 max_age_s : int; (* stored as seconds *)
720 shared_with : (string * string) list; (* user_id, device_id pairs *)
721 }
722
723 let megolm_outbound_pickle_jsont : megolm_outbound_pickle Jsont.t =
724 Jsont.Object.(
725 map (fun session_id room_id ratchet message_index signing_priv
726 signing_pub creation_time message_count max_messages max_age_s
727 shared_with ->
728 { session_id; room_id; ratchet; message_index; signing_priv;
729 signing_pub; creation_time; message_count; max_messages; max_age_s;
730 shared_with })
731 |> mem "session_id" Jsont.string
732 |> mem "room_id" Jsont.string
733 |> mem "ratchet" (Jsont.list Jsont.string)
734 |> mem "message_index" Jsont.int
735 |> mem "signing_priv" ed25519_priv_jsont
736 |> mem "signing_pub" ed25519_pub_jsont
737 |> mem "creation_time" ptime_jsont
738 |> mem "message_count" Jsont.int
739 |> mem "max_messages" Jsont.int
740 |> mem "max_age_s" Jsont.int
741 |> mem "shared_with"
742 (Jsont.list (Jsont.list Jsont.string |> Jsont.map
743 ~dec:(function
744 | [a; b] -> (a, b)
745 | _ -> failwith "Expected 2 elements")
746 ~enc:(fun (a, b) -> [a; b])))
747 |> finish)
748
749 let pickle_megolm_outbound (session : Olm.Megolm.Outbound.t) : string =
750 let ratchet = Array.to_list session.ratchet |> List.map base64_encode in
751 let max_age_s =
752 match Ptime.Span.to_int_s session.max_age with
753 | Some s -> s
754 | None -> 604800 (* default 1 week *)
755 in
756 let pickle = {
757 session_id = session.session_id;
758 room_id = session.room_id;
759 ratchet;
760 message_index = session.message_index;
761 signing_priv = session.signing_priv;
762 signing_pub = session.signing_pub;
763 creation_time = session.creation_time;
764 message_count = session.message_count;
765 max_messages = session.max_messages;
766 max_age_s;
767 shared_with = session.shared_with;
768 } in
769 match Jsont_bytesrw.encode_string megolm_outbound_pickle_jsont pickle with
770 | Ok s -> s
771 | Error e -> failwith ("Failed to pickle megolm outbound: " ^ e)
772
773 let unpickle_megolm_outbound (s : string)
774 : (Olm.Megolm.Outbound.t, string) result =
775 match Jsont_bytesrw.decode_string megolm_outbound_pickle_jsont s with
776 | Error e -> Error ("Failed to unpickle megolm outbound: " ^ e)
777 | Ok pickle ->
778 let ratchet =
779 List.map base64_decode pickle.ratchet |> Array.of_list
780 in
781 let max_age = Ptime.Span.of_int_s pickle.max_age_s in
782 Ok {
783 Olm.Megolm.Outbound.session_id = pickle.session_id;
784 room_id = pickle.room_id;
785 ratchet;
786 message_index = pickle.message_index;
787 signing_priv = pickle.signing_priv;
788 signing_pub = pickle.signing_pub;
789 creation_time = pickle.creation_time;
790 message_count = pickle.message_count;
791 max_messages = pickle.max_messages;
792 max_age;
793 shared_with = pickle.shared_with;
794 }
795end
796
797(* ============================================================ *)
798(* Session Store *)
799(* ============================================================ *)
800
801module Store = struct
802 type t = {
803 profile_path : Eio.Fs.dir_ty Eio.Path.t;
804 }
805
806 let create ~xdg ~profile =
807 let data_dir = Xdge.data_dir xdg in
808 let profile_path = Eio.Path.(data_dir / "profiles" / profile) in
809 (* Ensure directory exists *)
810 Eio.Path.mkdirs ~exists_ok:true ~perm:0o700 profile_path;
811 { profile_path }
812
813 let profile_dir t = t.profile_path
814
815 let exists t =
816 Eio.Path.is_file Eio.Path.(t.profile_path / "session.toml")
817
818 (* Helper to load a TOML file with a codec *)
819 let load_toml (type a) (codec : a Tomlt.t) (path : _ Eio.Path.t)
820 : a option =
821 if Eio.Path.is_file path then
822 match Tomlt_eio.decode_file codec path with
823 | Ok v -> Some v
824 | Error _ -> None
825 else
826 None
827
828 (* Helper to save a TOML file with a codec *)
829 let save_toml (type a) (codec : a Tomlt.t) (path : _ Eio.Path.t) (value : a)
830 : unit =
831 Tomlt_eio.encode_file codec value path
832
833 let load_session t =
834 load_toml Session_file.tomlt Eio.Path.(t.profile_path / "session.toml")
835
836 let save_session t session =
837 save_toml Session_file.tomlt Eio.Path.(t.profile_path / "session.toml")
838 session
839
840 let load_device_keys t =
841 load_toml Device_keys.tomlt Eio.Path.(t.profile_path / "device.toml")
842
843 let save_device_keys t keys =
844 save_toml Device_keys.tomlt Eio.Path.(t.profile_path / "device.toml") keys
845
846 let load_one_time_keys t =
847 load_toml One_time_keys_file.tomlt
848 Eio.Path.(t.profile_path / "one_time_keys.toml")
849
850 let save_one_time_keys t keys =
851 save_toml One_time_keys_file.tomlt
852 Eio.Path.(t.profile_path / "one_time_keys.toml") keys
853
854 let load_olm_sessions t =
855 load_toml Olm_sessions_file.tomlt
856 Eio.Path.(t.profile_path / "olm_sessions.toml")
857
858 let save_olm_sessions t sessions =
859 save_toml Olm_sessions_file.tomlt
860 Eio.Path.(t.profile_path / "olm_sessions.toml") sessions
861
862 let load_megolm_inbound t =
863 load_toml Megolm_inbound_file.tomlt
864 Eio.Path.(t.profile_path / "megolm_inbound.toml")
865
866 let save_megolm_inbound t sessions =
867 save_toml Megolm_inbound_file.tomlt
868 Eio.Path.(t.profile_path / "megolm_inbound.toml") sessions
869
870 let load_megolm_outbound t =
871 load_toml Megolm_outbound_file.tomlt
872 Eio.Path.(t.profile_path / "megolm_outbound.toml")
873
874 let save_megolm_outbound t sessions =
875 save_toml Megolm_outbound_file.tomlt
876 Eio.Path.(t.profile_path / "megolm_outbound.toml") sessions
877
878 let clear t =
879 let files = [
880 "session.toml"; "device.toml"; "one_time_keys.toml";
881 "olm_sessions.toml"; "megolm_inbound.toml"; "megolm_outbound.toml"
882 ] in
883 List.iter (fun filename ->
884 let path = Eio.Path.(t.profile_path / filename) in
885 if Eio.Path.is_file path then
886 Eio.Path.unlink path)
887 files
888end