+2 -1

README.md

reviewed

··· 60 60 | [**ocaml-zulip**](https://tangled.org/anil.recoil.org/ocaml-zulip.git) | zulip | OCaml bindings for the Zulip REST API with bot framework | 61 61 | [**odoc-xo**](https://tangled.org/anil.recoil.org/odoc-xo.git) | odoc-xo | Transform odoc HTML to use x-ocaml web components | 62 62 | [**poe**](https://tangled.org/anil.recoil.org/poe.git) | poe | Zulip bot for broadcasting monorepo changes with Claude integration | 63 63 + | [**sortal**](https://tangled.org/@anil.recoil.org/sortal.git) | sortal | Contact metadata management with XDG storage and versioned schemas | 63 64 | [**srcsetter**](https://tangled.org/anil.recoil.org/srcsetter.git) | srcsetter | Image srcset library for webp images | 64 65 | | srcsetter-cmd | Image processing tool to generate responsive images | 65 66 | [**xdge**](https://tangled.sh/@anil.recoil.org/xdge.git) | xdge | XDG Base Directory Specification support for Eio | 66 67 67 68 --- 68 69 69 69 - _Generated by monopam. 59 packages from 41 repositories._ 70 70 + _Generated by monopam. 60 packages from 42 repositories._

+367 -256

monopam/bin/main.ml

reviewed

··· 55 55 | Ok config -> f config 56 56 | Error msg -> 57 57 Fmt.epr "Error loading config: %s@." msg; 58 58 - Fmt.epr "Run 'monopam verse init' first to create a workspace.@."; 58 58 + Fmt.epr "Run 'monopam init' first to create a workspace.@."; 59 59 `Error (false, "configuration error") 60 60 61 61 (* Status command *) ··· 115 115 let proc = Eio.Stdenv.process_mgr env in 116 116 match Monopam.status ~proc ~fs ~config () with 117 117 | Ok statuses -> 118 118 - Fmt.pr "%a" Monopam.Status.pp_summary statuses; 118 118 + (* Load sources.toml for origin indicators *) 119 119 + let sources = 120 120 + let mono_path = Monopam.Config.Paths.monorepo config in 121 121 + let sources_path = Fpath.(mono_path / "sources.toml") in 122 122 + match Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with 123 123 + | Ok s -> Some s 124 124 + | Error _ -> None 125 125 + in 126 126 + Fmt.pr "%a" (Monopam.Status.pp_summary ?sources) statuses; 119 127 (* Check for unregistered opam files *) 120 128 (match Monopam.discover_packages ~fs ~config () with 121 129 | Ok pkgs -> ··· 438 446 let info = Cmd.info "opam" ~doc ~man in 439 447 Cmd.group info [ opam_sync_cmd ] 440 448 441 441 - (* Verse commands *) 442 442 - 443 443 - (* Helper to load verse config from XDG *) 444 444 - let with_verse_config env f = 445 445 - let fs = Eio.Stdenv.fs env in 446 446 - match Monopam.Verse_config.load ~fs () with 447 447 - | Ok config -> f config 448 448 - | Error msg -> 449 449 - Fmt.epr "Error loading opamverse config: %s@." msg; 450 450 - Fmt.epr "Run 'monopam verse init' to create a workspace.@."; 451 451 - `Error (false, "configuration error") 449 449 + (* Init command - initialize a new monopam workspace *) 452 450 453 453 - let verse_root_arg = 451 451 + let init_root_arg = 454 452 let doc = 455 453 "Path to workspace root directory. Defaults to current directory." 456 454 in ··· 459 457 & opt (some (conv (Fpath.of_string, Fpath.pp))) None 460 458 & info [ "root" ] ~docv:"PATH" ~doc) 461 459 462 462 - let verse_handle_arg = 463 463 - let doc = "Tangled handle (e.g., alice.bsky.social)" in 460 460 + let init_handle_arg = 461 461 + let doc = "Your handle (e.g., alice.bsky.social)" in 464 462 Arg.( 465 463 required & opt (some string) None & info [ "handle" ] ~docv:"HANDLE" ~doc) 466 464 467 467 - let verse_handle_opt_pos_arg = 468 468 - let doc = 469 469 - "Tangled handle. If not specified, operates on all tracked members." 470 470 - in 471 471 - Arg.(value & pos 0 (some string) None & info [] ~docv:"HANDLE" ~doc) 472 472 - 473 473 - let verse_init_cmd = 474 474 - let doc = "Initialize a new opamverse workspace" in 465 465 + let init_cmd = 466 466 + let doc = "Initialize a new monopam workspace" in 475 467 let man = 476 468 [ 477 469 `S Manpage.s_description; 478 470 `P 479 479 - "Creates a new opamverse workspace for federated monorepo \ 480 480 - collaboration. An opamverse workspace lets you browse and track other \ 481 481 - developers' monorepos alongside your own."; 471 471 + "Creates a new monopam workspace for monorepo development. The workspace \ 472 472 + lets you manage your own monorepo and optionally browse and track other \ 473 473 + developers' monorepos."; 482 474 `S "WORKSPACE STRUCTURE"; 483 475 `P 484 476 "The init command creates the following directory structure at the \ ··· 503 495 verse = \"verse\"\n\n\ 504 496 [identity]\n\ 505 497 handle = \"yourname.bsky.social\""; 506 506 - `S "AUTHENTICATION"; 507 507 - `P "Before running init, you must authenticate with the tangled network:"; 508 508 - `Pre "tangled auth login"; 498 498 + `S "HANDLE VALIDATION"; 509 499 `P 510 510 - "The handle you provide is validated against the AT Protocol identity \ 511 511 - system to ensure it exists and you are authenticated."; 500 500 + "The handle you provide identifies you in the community. \ 501 501 + It should be a valid domain name (e.g., yourname.bsky.social or \ 502 502 + your-domain.com)."; 512 503 `S "REGISTRY"; 513 504 `P 514 514 - "The opamverse registry is a git repository containing an \ 515 515 - opamverse.toml file that lists community members and their monorepo \ 516 516 - URLs. The default registry is at: \ 517 517 - https://tangled.org/eeg.cl.cam.ac.uk/opamverse"; 505 505 + "The registry is a git repository containing an opamverse.toml file \ 506 506 + that lists community members and their monorepo URLs. The default \ 507 507 + registry is at: https://tangled.org/eeg.cl.cam.ac.uk/opamverse"; 518 508 `S Manpage.s_examples; 519 519 - `P "Initialize a workspace in ~/tangled:"; 520 520 - `Pre "cd ~/tangled\nmonopam verse init --handle alice.bsky.social"; 509 509 + `P "Initialize a workspace in the current directory:"; 510 510 + `Pre "monopam init --handle alice.bsky.social"; 521 511 `P "Initialize with explicit root path:"; 522 522 - `Pre "monopam verse init --root ~/my-workspace --handle alice.bsky.social"; 512 512 + `Pre "monopam init --root ~/my-workspace --handle alice.bsky.social"; 523 513 ] 524 514 in 525 515 let info = Cmd.info "init" ~doc ~man in ··· 539 529 in 540 530 match Monopam.Verse.init ~proc ~fs ~root ~handle () with 541 531 | Ok () -> 542 542 - Fmt.pr "Monoverse workspace initialized at %a@." Fpath.pp root; 532 532 + Fmt.pr "Workspace initialized at %a@." Fpath.pp root; 543 533 `Ok () 544 534 | Error e -> 545 535 Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e; 546 536 `Error (false, "init failed") 547 537 in 548 538 Cmd.v info 549 549 - Term.(ret (const run $ verse_root_arg $ verse_handle_arg $ logging_term)) 539 539 + Term.(ret (const run $ init_root_arg $ init_handle_arg $ logging_term)) 540 540 + 541 541 + (* Verse commands *) 542 542 + 543 543 + (* Helper to load verse config from XDG *) 544 544 + let with_verse_config env f = 545 545 + let fs = Eio.Stdenv.fs env in 546 546 + match Monopam.Verse_config.load ~fs () with 547 547 + | Ok config -> f config 548 548 + | Error msg -> 549 549 + Fmt.epr "Error loading opamverse config: %s@." msg; 550 550 + Fmt.epr "Run 'monopam init' to create a workspace.@."; 551 551 + `Error (false, "configuration error") 550 552 551 553 let verse_members_cmd = 552 554 let doc = "List registry members" in ··· 602 604 in 603 605 Cmd.v info Term.(ret (const run $ logging_term)) 604 606 605 605 - let verse_pull_cmd = 606 606 - let doc = "Sync all registry members to local workspace" in 607 607 - let man = 608 608 - [ 609 609 - `S Manpage.s_description; 610 610 - `P 611 611 - "Clones or pulls all members from the opamverse registry. For each \ 612 612 - member, syncs both their monorepo and opam overlay repository."; 613 613 - `S "WHAT IT DOES"; 614 614 - `P "For each member in the registry:"; 615 615 - `I ("1.", "Clones or pulls their monorepo to verse/<handle>/"); 616 616 - `I ("2.", "Clones or pulls their opam repo to verse/<handle>-opam/"); 617 617 - `S "SCOPE"; 618 618 - `P "With a handle argument: syncs only that specific member."; 619 619 - `P "Without arguments: syncs all members in the registry."; 620 620 - `S "ERROR HANDLING"; 621 621 - `P 622 622 - "If a sync fails for one member (e.g., network error), the error is \ 623 623 - reported but other members are still synced."; 624 624 - `S Manpage.s_examples; 625 625 - `Pre 626 626 - "# Sync all registry members\n\ 627 627 - monopam verse pull\n\n\ 628 628 - # Sync a specific member\n\ 629 629 - monopam verse pull alice.bsky.social\n\n\ 630 630 - # Browse their code\n\ 631 631 - ls verse/alice.bsky.social/"; 632 632 - ] 633 633 - in 634 634 - let info = Cmd.info "pull" ~doc ~man in 635 635 - let run handle () = 636 636 - Eio_main.run @@ fun env -> 637 637 - with_verse_config env @@ fun config -> 638 638 - let fs = Eio.Stdenv.fs env in 639 639 - let proc = Eio.Stdenv.process_mgr env in 640 640 - match Monopam.Verse.pull ~proc ~fs ~config ?handle () with 641 641 - | Ok () -> 642 642 - Fmt.pr "Sync completed.@."; 643 643 - `Ok () 644 644 - | Error e -> 645 645 - Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e; 646 646 - `Error (false, "pull failed") 647 647 - in 648 648 - Cmd.v info Term.(ret (const run $ verse_handle_opt_pos_arg $ logging_term)) 649 649 - 650 650 - let verse_sync_cmd = 651 651 - let doc = "Sync the workspace" in 652 652 - let man = 653 653 - [ 654 654 - `S Manpage.s_description; 655 655 - `P 656 656 - "Synchronizes your entire opamverse workspace with the latest upstream \ 657 657 - changes. This is the command to run regularly to stay up to date."; 658 658 - `S "WHAT IT DOES"; 659 659 - `P "The sync command performs two operations:"; 660 660 - `I 661 661 - ( "1.", 662 662 - "Updates the registry: git pull in \ 663 663 - ~/.local/share/monopam/opamverse-registry/" ); 664 664 - `I ("2.", "Pulls all tracked members: git pull in each verse/<handle>/"); 665 665 - `S "USE CASES"; 666 666 - `P "Run sync when you want to:"; 667 667 - `I ("-", "See if any new members have joined the community"); 668 668 - `I ("-", "Get the latest code from all tracked members"); 669 669 - `I ("-", "Catch up after being away for a while"); 670 670 - `S "COMPARISON WITH PULL"; 671 671 - `P 672 672 - "'verse sync' updates the registry AND pulls members. 'verse pull' \ 673 673 - only pulls members (skips registry update)."; 674 674 - `S Manpage.s_examples; 675 675 - `Pre 676 676 - "# Daily sync routine\n\ 677 677 - cd ~/tangled\n\ 678 678 - monopam verse sync\n\ 679 679 - monopam verse status"; 680 680 - ] 681 681 - in 682 682 - let info = Cmd.info "sync" ~doc ~man in 683 683 - let run () = 684 684 - Eio_main.run @@ fun env -> 685 685 - with_verse_config env @@ fun config -> 686 686 - let fs = Eio.Stdenv.fs env in 687 687 - let proc = Eio.Stdenv.process_mgr env in 688 688 - match Monopam.Verse.sync ~proc ~fs ~config () with 689 689 - | Ok () -> 690 690 - Fmt.pr "Sync completed.@."; 691 691 - `Ok () 692 692 - | Error e -> 693 693 - Fmt.epr "Error: %a@." Monopam.Verse.pp_error_with_hint e; 694 694 - `Error (false, "sync failed") 695 695 - in 696 696 - Cmd.v info Term.(ret (const run $ logging_term)) 697 697 - 698 607 let verse_fork_cmd = 699 608 let doc = "Fork a package from a verse member's repository" in 700 609 let man = ··· 782 691 upstream = Some result.upstream_url; 783 692 branch = None; 784 693 reason = Some (Fmt.str "Forked from %s" result.source_handle); 694 694 + origin = Some Join; (* Forked from verse = joined *) 785 695 } in 786 696 let sources = Monopam.Sources_registry.add sources ~subtree:result.subtree_name entry in 787 697 (match Monopam.Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with ··· 804 714 Cmd.v info Term.(ret (const run $ package_arg $ from_arg $ url_arg $ dry_run_arg $ logging_term)) 805 715 806 716 let verse_cmd = 807 807 - let doc = "Federated monorepo collaboration" in 717 717 + let doc = "Verse member operations" in 808 718 let man = 809 719 [ 810 720 `S Manpage.s_description; 811 721 `P 812 812 - "The opamverse system enables federated collaboration across multiple \ 813 813 - developers' monorepos. Each developer maintains their own monorepo \ 814 814 - (managed by standard monopam commands), and can track other \ 815 815 - developers' monorepos for code browsing, learning, and collaboration."; 816 816 - `P 817 817 - "Members are identified by tangled handles - decentralized identities \ 818 818 - from the AT Protocol network (the same system used by Bluesky)."; 819 819 - `S "QUICK START FOR NEW USERS"; 820 820 - `P "Run these commands in order to get started:"; 821 821 - `Pre 822 822 - "# Step 1: Authenticate with tangled (one-time setup)\n\ 823 823 - tangled auth login\n\n\ 824 824 - # Step 2: Create and initialize your workspace\n\ 825 825 - mkdir ~/tangled && cd ~/tangled\n\ 826 826 - monopam verse init --handle yourname.bsky.social\n\n\ 827 827 - # Step 3: Sync all community members\n\ 828 828 - monopam verse pull\n\n\ 829 829 - # Step 4: Browse their code\n\ 830 830 - ls verse/\n\ 831 831 - cd verse/alice.bsky.social && dune build\n\n\ 832 832 - # Step 5: Keep everything updated (run daily/weekly)\n\ 833 833 - monopam verse sync"; 834 834 - `S "KEY CONCEPTS"; 835 835 - `I 836 836 - ( "Workspace", 837 837 - "A directory containing your monorepo plus all registry members' \ 838 838 - repos" ); 839 839 - `I 840 840 - ( "Registry", 841 841 - "A git repository listing community members and their repo URLs" ); 842 842 - `I 843 843 - ( "Handle", 844 844 - "A tangled identity like 'alice.bsky.social' validated via AT \ 845 845 - Protocol" ); 846 846 - `S "WORKSPACE STRUCTURE"; 847 847 - `P "An opamverse workspace has this layout:"; 848 848 - `Pre 849 849 - "~/tangled/ # workspace root\n\ 850 850 - ├── mono/ # YOUR monorepo\n\ 851 851 - ├── src/ # YOUR fork checkouts\n\ 852 852 - ├── opam-repo/ # YOUR opam overlay\n\ 853 853 - └── verse/\n\ 854 854 - \ ├── alice.bsky.social/ # Alice's monorepo\n\ 855 855 - \ ├── alice.bsky.social-opam/ # Alice's opam overlay\n\ 856 856 - \ ├── bob.example.com/ # Bob's monorepo\n\ 857 857 - \ └── bob.example.com-opam/ # Bob's opam overlay"; 858 858 - `P "Configuration and data are stored in XDG directories:"; 859 859 - `Pre 860 860 - "~/.config/monopam/\n\ 861 861 - └── opamverse.toml # workspace configuration\n\n\ 862 862 - ~/.local/share/monopam/\n\ 863 863 - └── opamverse-registry/ # cloned registry git repo"; 864 864 - `S "COMMAND FLOW"; 865 865 - `P "The expected sequence of commands for typical workflows:"; 866 866 - `P "$(b,First-time setup) (once per machine):"; 867 867 - `Pre 868 868 - "tangled auth login # authenticate\n\ 869 869 - monopam verse init --handle you.bsky.social # create workspace"; 870 870 - `P "$(b,Syncing all members):"; 871 871 - `Pre 872 872 - "monopam verse pull # clone/pull all \ 873 873 - members\n\ 874 874 - monopam verse status # check status"; 875 875 - `P "$(b,Daily maintenance):"; 876 876 - `Pre 877 877 - "monopam verse sync # update everything\n\ 878 878 - monopam verse status # check for changes"; 879 879 - `P "$(b,Working in your own monorepo):"; 880 880 - `Pre 881 881 - "cd ~/tangled/mono\n\ 882 882 - monopam pull # fetch upstream \ 883 883 - changes\n\ 884 884 - # ... make edits ...\n\ 885 885 - monopam push # export to checkouts"; 886 886 - `S "INTEGRATION WITH MONOPAM"; 722 722 + "Commands for working with verse community members. The verse system \ 723 723 + enables federated collaboration across multiple developers' monorepos."; 887 724 `P 888 888 - "The verse system complements standard monopam commands. Your mono/ \ 889 889 - directory works exactly like a normal monopam-managed monorepo:"; 890 890 - `Pre 891 891 - "# Work in your monorepo\n\ 892 892 - cd ~/tangled/mono\n\ 893 893 - monopam status\n\ 894 894 - monopam pull\n\ 895 895 - # ... make changes ...\n\ 896 896 - monopam push"; 725 725 + "Members are identified by handles - typically domain names like \ 726 726 + 'yourname.bsky.social' or 'your-domain.com'."; 727 727 + `S "NOTE"; 897 728 `P 898 898 - "The verse/ directories are for reading and learning from others' \ 899 899 - code. You generally don't push to them (unless you're a \ 900 900 - collaborator)."; 901 901 - `S "REGISTRY FORMAT"; 902 902 - `P "The registry is a git repository containing opamverse.toml:"; 903 903 - `Pre 904 904 - "[registry]\n\ 905 905 - name = \"tangled-community\"\n\n\ 906 906 - [[members]]\n\ 907 907 - handle = \"alice.bsky.social\"\n\ 908 908 - monorepo = \"https://github.com/alice/mono\""; 909 909 - `P "Default registry: https://tangled.org/eeg.cl.cam.ac.uk/opamverse"; 910 910 - `S "COMMANDS REFERENCE"; 911 911 - `I ("init", "Create a new workspace with config and directories"); 912 912 - `I ("status", "Show members and their git status"); 913 913 - `I ("members", "List all members in the registry"); 914 914 - `I ("pull [<handle>]", "Clone/pull all members (or specific member)"); 915 915 - `I ("sync", "Update registry and pull all members"); 729 729 + "The $(b,monopam init) command creates your workspace and \ 730 730 + $(b,monopam sync) automatically syncs verse members. These commands \ 731 731 + are for additional verse-specific operations."; 732 732 + `S "COMMANDS"; 733 733 + `I ("members", "List all members in the community registry"); 916 734 `I ("fork <pkg> --from <handle> --url <url>", "Fork a package from a verse member"); 917 917 - `S "AUTHENTICATION"; 918 918 - `P 919 919 - "Handle validation uses the AT Protocol identity system. The tangled \ 920 920 - CLI stores session credentials that monopam verse commands reuse."; 921 921 - `P "If you see 'Not authenticated', run:"; 922 922 - `Pre "tangled auth login"; 735 735 + `S Manpage.s_examples; 736 736 + `P "List all community members:"; 737 737 + `Pre "monopam verse members"; 738 738 + `P "Fork a package from another member:"; 739 739 + `Pre "monopam verse fork cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git"; 923 740 ] 924 741 in 925 742 let info = Cmd.info "verse" ~doc ~man in 926 743 Cmd.group info 927 744 [ 928 928 - verse_init_cmd; 929 745 verse_members_cmd; 930 930 - verse_pull_cmd; 931 931 - verse_sync_cmd; 932 746 verse_fork_cmd; 933 747 ] 934 748 ··· 1459 1273 in 1460 1274 Cmd.v info Term.(ret (const run $ path_arg $ url_arg $ logging_term)) 1461 1275 1276 1276 + (* Fork command *) 1277 1277 + 1278 1278 + let fork_cmd = 1279 1279 + let doc = "Fork a monorepo subtree into its own repository" in 1280 1280 + let man = 1281 1281 + [ 1282 1282 + `S Manpage.s_description; 1283 1283 + `P 1284 1284 + "Splits a monorepo subdirectory into its own git repository. This \ 1285 1285 + extracts the commit history for the subtree and creates a standalone \ 1286 1286 + repository in src/<name>/."; 1287 1287 + `S "WHAT IT DOES"; 1288 1288 + `P "The fork command:"; 1289 1289 + `I ("1.", "Validates mono/<name>/ exists as a subtree"); 1290 1290 + `I ("2.", "Uses $(b,git subtree split) to extract history"); 1291 1291 + `I ("3.", "Creates a new git repo at src/<name>/"); 1292 1292 + `I ("4.", "Pushes the extracted history to the new repo"); 1293 1293 + `I ("5.", "Updates sources.toml with $(b,origin = \"fork\")"); 1294 1294 + `I ("6.", "Auto-discovers packages from .opam files"); 1295 1295 + `S "AFTER FORKING"; 1296 1296 + `P "After forking, the subtree will be tracked via src/<name>/:"; 1297 1297 + `I ("1.", "Make changes in mono/<name>/ as usual"); 1298 1298 + `I ("2.", "Run $(b,monopam sync) to push changes to src/<name>/"); 1299 1299 + `I ("3.", "If you provided a URL, push to remote: $(b,cd src/<name> && git push)"); 1300 1300 + `S Manpage.s_examples; 1301 1301 + `P "Fork a subtree with local-only repo:"; 1302 1302 + `Pre "monopam fork my-lib"; 1303 1303 + `P "Fork with a remote push URL:"; 1304 1304 + `Pre "monopam fork my-lib git@github.com:me/my-lib.git"; 1305 1305 + `P "Preview what would be done:"; 1306 1306 + `Pre "monopam fork my-lib --dry-run"; 1307 1307 + ] 1308 1308 + in 1309 1309 + let info = Cmd.info "fork" ~doc ~man in 1310 1310 + let name_arg = 1311 1311 + let doc = "Name of the subtree to fork (directory name under mono/)" in 1312 1312 + Arg.(required & pos 0 (some string) None & info [] ~docv:"NAME" ~doc) 1313 1313 + in 1314 1314 + let url_arg = 1315 1315 + let doc = "Optional remote URL to add as 'origin' for pushing" in 1316 1316 + Arg.(value & pos 1 (some string) None & info [] ~docv:"URL" ~doc) 1317 1317 + in 1318 1318 + let dry_run_arg = 1319 1319 + let doc = "Show what would be done without making changes" in 1320 1320 + Arg.(value & flag & info [ "dry-run"; "n" ] ~doc) 1321 1321 + in 1322 1322 + let run name url dry_run () = 1323 1323 + Eio_main.run @@ fun env -> 1324 1324 + with_verse_config env @@ fun config -> 1325 1325 + let fs = Eio.Stdenv.fs env in 1326 1326 + let proc = Eio.Stdenv.process_mgr env in 1327 1327 + match Monopam.Fork_join.fork ~proc ~fs ~config ~name ?push_url:url ~dry_run () with 1328 1328 + | Ok result -> 1329 1329 + if dry_run then begin 1330 1330 + Fmt.pr "Would fork subtree '%s':@." result.name; 1331 1331 + Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_created; 1332 1332 + Fmt.pr " Destination: %a@." Fpath.pp result.src_path; 1333 1333 + match url with 1334 1334 + | Some u -> Fmt.pr " Push URL: %s@." u 1335 1335 + | None -> () 1336 1336 + end else begin 1337 1337 + Fmt.pr "%a@." Monopam.Fork_join.pp_fork_result result; 1338 1338 + Fmt.pr "@.Next steps:@."; 1339 1339 + Fmt.pr " 1. Review the new repo: cd src/%s@." result.name; 1340 1340 + match url with 1341 1341 + | Some _ -> Fmt.pr " 2. Push to remote: git push -u origin main@." 1342 1342 + | None -> Fmt.pr " 2. Add a remote: git remote add origin <url>@." 1343 1343 + end; 1344 1344 + `Ok () 1345 1345 + | Error e -> 1346 1346 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1347 1347 + `Error (false, "fork failed") 1348 1348 + in 1349 1349 + Cmd.v info Term.(ret (const run $ name_arg $ url_arg $ dry_run_arg $ logging_term)) 1350 1350 + 1351 1351 + (* Join command *) 1352 1352 + 1353 1353 + let join_cmd = 1354 1354 + let doc = "Bring an external repository into the monorepo" in 1355 1355 + let man = 1356 1356 + [ 1357 1357 + `S Manpage.s_description; 1358 1358 + `P 1359 1359 + "Clones an external git repository and adds it as a subtree in the \ 1360 1360 + monorepo. This is the inverse of $(b,monopam fork)."; 1361 1361 + `S "WHAT IT DOES"; 1362 1362 + `P "The join command:"; 1363 1363 + `I ("1.", "Derives subtree name from URL (or uses --as)"); 1364 1364 + `I ("2.", "Validates mono/<name>/ does not exist"); 1365 1365 + `I ("3.", "Clones the repository to src/<name>/"); 1366 1366 + `I ("4.", "Uses $(b,git subtree add) to bring into monorepo"); 1367 1367 + `I ("5.", "Updates sources.toml with $(b,origin = \"join\")"); 1368 1368 + `I ("6.", "Auto-discovers packages from .opam files"); 1369 1369 + `S "JOINING FROM VERSE"; 1370 1370 + `P "To join a package from a verse member, use $(b,--from):"; 1371 1371 + `Pre "monopam join --from avsm.bsky.social --url git@github.com:me/cohttp.git cohttp"; 1372 1372 + `P "This will:"; 1373 1373 + `I ("-", "Look up the package in their opam-repo"); 1374 1374 + `I ("-", "Find all packages from the same git repository"); 1375 1375 + `I ("-", "Create opam entries pointing to your fork"); 1376 1376 + `I ("-", "Clone and add the subtree"); 1377 1377 + `S "AFTER JOINING"; 1378 1378 + `P "After joining, work with the subtree normally:"; 1379 1379 + `I ("1.", "Make changes in mono/<name>/"); 1380 1380 + `I ("2.", "Commit in mono/"); 1381 1381 + `I ("3.", "Run $(b,monopam sync --remote) to push upstream"); 1382 1382 + `S Manpage.s_examples; 1383 1383 + `P "Join a repository:"; 1384 1384 + `Pre "monopam join https://github.com/someone/some-lib"; 1385 1385 + `P "Join with explicit name using --url:"; 1386 1386 + `Pre "monopam join --url https://tangled.org/handle/sortal sortal"; 1387 1387 + `P "Join with a custom name using --as:"; 1388 1388 + `Pre "monopam join https://github.com/someone/some-lib --as my-lib"; 1389 1389 + `P "Join with upstream tracking (for forks):"; 1390 1390 + `Pre "monopam join https://github.com/me/cohttp --upstream https://github.com/mirage/cohttp"; 1391 1391 + `P "Join from a verse member:"; 1392 1392 + `Pre "monopam join cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git"; 1393 1393 + `P "Preview what would be done:"; 1394 1394 + `Pre "monopam join https://github.com/someone/lib --dry-run"; 1395 1395 + ] 1396 1396 + in 1397 1397 + let info = Cmd.info "join" ~doc ~man in 1398 1398 + let url_or_pkg_arg = 1399 1399 + let doc = "Git URL to join, or subtree name (when using --url)" in 1400 1400 + Arg.(required & pos 0 (some string) None & info [] ~docv:"URL|NAME" ~doc) 1401 1401 + in 1402 1402 + let as_arg = 1403 1403 + let doc = "Override subtree directory name" in 1404 1404 + Arg.(value & opt (some string) None & info [ "as" ] ~docv:"NAME" ~doc) 1405 1405 + in 1406 1406 + let upstream_arg = 1407 1407 + let doc = "Original upstream URL (for tracking forks)" in 1408 1408 + Arg.(value & opt (some string) None & info [ "upstream" ] ~docv:"URL" ~doc) 1409 1409 + in 1410 1410 + let from_arg = 1411 1411 + let doc = "Verse member handle to join from (requires --url)" in 1412 1412 + Arg.(value & opt (some string) None & info [ "from" ] ~docv:"HANDLE" ~doc) 1413 1413 + in 1414 1414 + let fork_url_arg = 1415 1415 + let doc = "Git URL to clone from (makes positional arg the subtree name)" in 1416 1416 + Arg.(value & opt (some string) None & info [ "url" ] ~docv:"URL" ~doc) 1417 1417 + in 1418 1418 + let dry_run_arg = 1419 1419 + let doc = "Show what would be done without making changes" in 1420 1420 + Arg.(value & flag & info [ "dry-run"; "n" ] ~doc) 1421 1421 + in 1422 1422 + let run url_or_pkg as_name upstream from fork_url dry_run () = 1423 1423 + Eio_main.run @@ fun env -> 1424 1424 + with_verse_config env @@ fun config -> 1425 1425 + let fs = Eio.Stdenv.fs env in 1426 1426 + let proc = Eio.Stdenv.process_mgr env in 1427 1427 + match from with 1428 1428 + | Some handle -> 1429 1429 + (* Join from verse member - requires --url for your fork *) 1430 1430 + (match fork_url with 1431 1431 + | None -> 1432 1432 + Fmt.epr "Error: --url is required when using --from@."; 1433 1433 + `Error (false, "--url required") 1434 1434 + | Some fork_url -> 1435 1435 + match Monopam.Fork_join.join_from_verse ~proc ~fs ~config ~verse_config:config 1436 1436 + ~package:url_or_pkg ~handle ~fork_url ~dry_run () with 1437 1437 + | Ok result -> 1438 1438 + if dry_run then begin 1439 1439 + Fmt.pr "Would join '%s' from %s:@." result.name (Option.value ~default:"verse" result.from_handle); 1440 1440 + Fmt.pr " Source: %s@." result.source_url; 1441 1441 + Option.iter (fun u -> Fmt.pr " Upstream: %s@." u) result.upstream_url; 1442 1442 + Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_added 1443 1443 + end else begin 1444 1444 + Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result; 1445 1445 + Fmt.pr "@.Next steps:@."; 1446 1446 + Fmt.pr " 1. Commit the opam changes: cd opam-repo && git add -A && git commit@."; 1447 1447 + Fmt.pr " 2. Run $(b,monopam sync) to synchronize@." 1448 1448 + end; 1449 1449 + `Ok () 1450 1450 + | Error e -> 1451 1451 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1452 1452 + `Error (false, "join failed")) 1453 1453 + | None -> 1454 1454 + (* Normal join from URL - use --url if provided, otherwise positional arg *) 1455 1455 + let url = match fork_url with Some u -> u | None -> url_or_pkg in 1456 1456 + let name = match fork_url with Some _ -> Some url_or_pkg | None -> as_name in 1457 1457 + match Monopam.Fork_join.join ~proc ~fs ~config ~url ?name ?upstream ~dry_run () with 1458 1458 + | Ok result -> 1459 1459 + if dry_run then begin 1460 1460 + Fmt.pr "Would join '%s':@." result.name; 1461 1461 + Fmt.pr " Source: %s@." result.source_url; 1462 1462 + Option.iter (fun u -> Fmt.pr " Upstream: %s@." u) result.upstream_url; 1463 1463 + Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_added 1464 1464 + end else begin 1465 1465 + Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result; 1466 1466 + Fmt.pr "@.Next steps:@."; 1467 1467 + Fmt.pr " 1. Run $(b,monopam sync) to synchronize@." 1468 1468 + end; 1469 1469 + `Ok () 1470 1470 + | Error e -> 1471 1471 + Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e; 1472 1472 + `Error (false, "join failed") 1473 1473 + in 1474 1474 + Cmd.v info Term.(ret (const run $ url_or_pkg_arg $ as_arg $ upstream_arg $ from_arg $ fork_url_arg $ dry_run_arg $ logging_term)) 1475 1475 + 1476 1476 + (* Site command *) 1477 1477 + 1478 1478 + let site_cmd = 1479 1479 + let doc = "Generate a static HTML site representing the monoverse map" in 1480 1480 + let man = 1481 1481 + [ 1482 1482 + `S Manpage.s_description; 1483 1483 + `P 1484 1484 + "Generates a static index.html file that maps the monoverse, showing all \ 1485 1485 + verse members, their packages, and the relationships between them."; 1486 1486 + `S "OUTPUT"; 1487 1487 + `P "The generated site includes:"; 1488 1488 + `I ("Members", "All verse members with links to their monorepo and opam repos"); 1489 1489 + `I ("Summary", "Overview of common libraries and member-specific packages"); 1490 1490 + `I ("Repository Details", "Each shared repo with packages and fork status"); 1491 1491 + `S "FORK STATUS"; 1492 1492 + `P "Use $(b,--status) to include fork relationship information:"; 1493 1493 + `I ("+N", "You are N commits ahead of them"); 1494 1494 + `I ("-N", "They are N commits ahead of you"); 1495 1495 + `I ("+N/-M", "Diverged: you have N new, they have M new"); 1496 1496 + `I ("sync", "Same commit"); 1497 1497 + `S "DESIGN"; 1498 1498 + `P "The HTML is designed to be:"; 1499 1499 + `I ("-", "Simple and clean with a 10pt font"); 1500 1500 + `I ("-", "Responsive and compact"); 1501 1501 + `I ("-", "External links marked with icon and teal color"); 1502 1502 + `S Manpage.s_examples; 1503 1503 + `P "Generate site to default location (mono/index.html):"; 1504 1504 + `Pre "monopam site"; 1505 1505 + `P "Generate site with fork status (slower, fetches remotes):"; 1506 1506 + `Pre "monopam site --status"; 1507 1507 + `P "Generate site to custom location:"; 1508 1508 + `Pre "monopam site -o /var/www/monoverse/index.html"; 1509 1509 + `P "Print HTML to stdout:"; 1510 1510 + `Pre "monopam site --stdout"; 1511 1511 + ] 1512 1512 + in 1513 1513 + let info = Cmd.info "site" ~doc ~man in 1514 1514 + let output_arg = 1515 1515 + let doc = "Output file path. Defaults to mono/index.html." in 1516 1516 + Arg.(value & opt (some string) None & info [ "o"; "output" ] ~docv:"FILE" ~doc) 1517 1517 + in 1518 1518 + let stdout_arg = 1519 1519 + let doc = "Print HTML to stdout instead of writing to file." in 1520 1520 + Arg.(value & flag & info [ "stdout" ] ~doc) 1521 1521 + in 1522 1522 + let status_arg = 1523 1523 + let doc = "Include fork status (ahead/behind) for each repository. \ 1524 1524 + This fetches from remotes and may be slower." in 1525 1525 + Arg.(value & flag & info [ "status"; "s" ] ~doc) 1526 1526 + in 1527 1527 + let run output to_stdout with_status () = 1528 1528 + Eio_main.run @@ fun env -> 1529 1529 + with_config env @@ fun monopam_config -> 1530 1530 + with_verse_config env @@ fun verse_config -> 1531 1531 + let fs = Eio.Stdenv.fs env in 1532 1532 + let proc = Eio.Stdenv.process_mgr env in 1533 1533 + (* Pull/clone registry to get latest metadata *) 1534 1534 + Fmt.pr "Syncing registry...@."; 1535 1535 + let registry = 1536 1536 + match Monopam.Verse_registry.clone_or_pull ~proc ~fs:(fs :> _ Eio.Path.t) ~config:verse_config () with 1537 1537 + | Ok r -> r 1538 1538 + | Error msg -> 1539 1539 + Fmt.epr "Warning: Could not sync registry: %s@." msg; 1540 1540 + Monopam.Verse_registry.{ name = "opamverse"; description = None; members = [] } 1541 1541 + in 1542 1542 + (* Compute forks if --status is requested *) 1543 1543 + let forks = 1544 1544 + if with_status then begin 1545 1545 + Fmt.pr "Computing fork status...@."; 1546 1546 + Some (Monopam.Forks.compute ~proc ~fs:(fs :> _ Eio.Path.t) 1547 1547 + ~verse_config ~monopam_config ()) 1548 1548 + end else None 1549 1549 + in 1550 1550 + if to_stdout then begin 1551 1551 + let html = Monopam.Site.generate ~fs:(fs :> _ Eio.Path.t) ~config:verse_config ?forks ~registry () in 1552 1552 + print_string html; 1553 1553 + `Ok () 1554 1554 + end else begin 1555 1555 + let output_path = 1556 1556 + match output with 1557 1557 + | Some p -> ( 1558 1558 + match Fpath.of_string p with 1559 1559 + | Ok fp -> fp 1560 1560 + | Error (`Msg _) -> Fpath.v p) 1561 1561 + | None -> Fpath.(Monopam.Verse_config.mono_path verse_config / "index.html") 1562 1562 + in 1563 1563 + match Monopam.Site.write ~fs:(fs :> _ Eio.Path.t) ~config:verse_config ?forks ~registry ~output_path () with 1564 1564 + | Ok () -> 1565 1565 + Fmt.pr "Site generated: %a@." Fpath.pp output_path; 1566 1566 + `Ok () 1567 1567 + | Error msg -> 1568 1568 + Fmt.epr "Error: %s@." msg; 1569 1569 + `Error (false, "site generation failed") 1570 1570 + end 1571 1571 + in 1572 1572 + Cmd.v info Term.(ret (const run $ output_arg $ stdout_arg $ status_arg $ logging_term)) 1573 1573 + 1462 1574 (* Main command group *) 1463 1575 1464 1576 let main_cmd = ··· 1480 1592 `P "Inside the devcontainer, initialize your workspace:"; 1481 1593 `Pre 1482 1594 "cd ~/tangled\n\ 1483 1483 - monopam verse init --handle yourname.bsky.social\n\ 1595 1595 + monopam init --handle yourname.bsky.social\n\ 1484 1596 cd mono"; 1485 1597 `P "Daily workflow:"; 1486 1598 `Pre ··· 1513 1625 `I 1514 1626 ( "4. monopam sync --remote", 1515 1627 "Sync again, including pushing to upstream git remotes" ); 1516 1516 - `P "For finer control, use $(b,push) and $(b,pull) separately:"; 1628 1628 + `P "For finer control over the sync phases:"; 1517 1629 `I 1518 1518 - ( "monopam push", 1519 1519 - "Export monorepo changes to checkouts (for manual review/push)" ); 1630 1630 + ( "monopam sync --skip-pull", 1631 1631 + "Export monorepo changes to checkouts only (skip fetching remotes)" ); 1520 1632 `I 1521 1521 - ( "monopam pull", 1522 1522 - "Pull remote changes into monorepo (when you know there are no local \ 1523 1523 - changes)" ); 1633 1633 + ( "monopam sync --skip-push", 1634 1634 + "Pull remote changes only (skip exporting local changes)" ); 1524 1635 `S "CHECKING STATUS"; 1525 1636 `P "Run $(b,monopam status) to see the state of all repositories:"; 1526 1637 `I ("local:+N", "Your monorepo is N commits ahead of the checkout"); ··· 1529 1640 `I ("remote:+N", "Your checkout is N commits ahead of upstream"); 1530 1641 `I ("remote:-N", "Upstream is N commits ahead (run $(b,monopam sync))"); 1531 1642 `S "COMMON TASKS"; 1532 1532 - `I ("Start fresh", "monopam verse init --handle you.bsky.social"); 1643 1643 + `I ("Start fresh", "monopam init --handle you.bsky.social"); 1533 1644 `I ("Check status", "monopam status"); 1534 1645 `I ("Sync everything", "monopam sync"); 1535 1646 `I ("Sync and push upstream", "monopam sync --remote"); 1536 1647 `I ("Sync one package", "monopam sync <package-name>"); 1537 1648 `S "CONFIGURATION"; 1538 1649 `P 1539 1539 - "Run $(b,monopam verse init --handle <handle>) to create a workspace. \ 1650 1650 + "Run $(b,monopam init --handle <handle>) to create a workspace. \ 1540 1651 Configuration is stored in ~/.config/monopam/opamverse.toml."; 1541 1652 `P "Workspace structure:"; 1542 1653 `Pre ··· 1561 1672 in 1562 1673 let info = Cmd.info "monopam" ~version:"%%VERSION%%" ~doc ~man in 1563 1674 Cmd.group info 1564 1564 - [ status_cmd; diff_cmd; pull_cmd; cherrypick_cmd; sync_cmd; changes_cmd; opam_cmd; doctor_cmd; verse_cmd; feature_cmd; devcontainer_cmd ] 1675 1675 + [ init_cmd; status_cmd; diff_cmd; pull_cmd; cherrypick_cmd; sync_cmd; changes_cmd; opam_cmd; doctor_cmd; verse_cmd; feature_cmd; fork_cmd; join_cmd; devcontainer_cmd; site_cmd ] 1565 1676 1566 1677 let () = exit (Cmd.eval main_cmd)

+1 -1

monopam/lib/doctor.ml

reviewed

··· 436 436 Buffer.add_string buf "## Current Monorepo Status\n\n"; 437 437 Buffer.add_string buf "Output of `monopam status`:\n```\n"; 438 438 (* Capture formatted pp_summary output (strip ANSI codes for prompt) *) 439 439 - let fmt_output = Fmt.str "%a" Status.pp_summary statuses in 439 439 + let fmt_output = Fmt.str "%a" (Status.pp_summary ?sources:None) statuses in 440 440 Buffer.add_string buf (strip_ansi fmt_output); 441 441 Buffer.add_string buf "```\n\n"; 442 442 Buffer.add_string buf "Detailed status per repository:\n";

+1 -1

monopam/lib/feature.ml

reviewed

··· 16 16 Some (Printf.sprintf "Run 'monopam feature remove %s' first if you want to recreate it" name) 17 17 | Feature_not_found name -> 18 18 Some (Printf.sprintf "Run 'monopam feature list' to see available features, or 'monopam feature add %s' to create it" name) 19 19 - | Config_error _ -> Some "Run 'monopam verse init' to create a workspace configuration" 19 19 + | Config_error _ -> Some "Run 'monopam init' to create a workspace configuration" 20 20 21 21 let pp_error_with_hint ppf e = 22 22 pp_error ppf e;

+289

monopam/lib/fork_join.ml

reviewed

··· 1 1 + (** Fork and join operations for managing monorepo sources. *) 2 2 + 3 3 + type error = 4 4 + | Config_error of string 5 5 + | Git_error of Git.error 6 6 + | Subtree_not_found of string 7 7 + | Src_already_exists of string 8 8 + | Subtree_already_exists of string 9 9 + | No_opam_files of string 10 10 + | Verse_error of Verse.error 11 11 + 12 12 + let pp_error ppf = function 13 13 + | Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg 14 14 + | Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e 15 15 + | Subtree_not_found name -> Fmt.pf ppf "Subtree not found in monorepo: %s" name 16 16 + | Src_already_exists name -> Fmt.pf ppf "Source checkout already exists: src/%s" name 17 17 + | Subtree_already_exists name -> Fmt.pf ppf "Subtree already exists in monorepo: mono/%s" name 18 18 + | No_opam_files name -> Fmt.pf ppf "No .opam files found in subtree: %s" name 19 19 + | Verse_error e -> Fmt.pf ppf "Verse error: %a" Verse.pp_error e 20 20 + 21 21 + let error_hint = function 22 22 + | Config_error _ -> 23 23 + Some "Run 'monopam init --handle <your-handle>' to create a workspace." 24 24 + | Git_error (Git.Dirty_worktree _) -> 25 25 + Some "Commit or stash your changes first: git status" 26 26 + | Git_error _ -> None 27 27 + | Subtree_not_found name -> 28 28 + Some (Fmt.str "Check that mono/%s exists in your monorepo" name) 29 29 + | Src_already_exists name -> 30 30 + Some (Fmt.str "Remove or rename src/%s first, or choose a different name" name) 31 31 + | Subtree_already_exists name -> 32 32 + Some (Fmt.str "Remove mono/%s first, or use a different name with --as" name) 33 33 + | No_opam_files name -> 34 34 + Some (Fmt.str "Add a .opam file to mono/%s before forking" name) 35 35 + | Verse_error e -> Verse.error_hint e 36 36 + 37 37 + let pp_error_with_hint ppf e = 38 38 + pp_error ppf e; 39 39 + match error_hint e with 40 40 + | Some hint -> Fmt.pf ppf "@.@[<v 2>Hint: %s@]" hint 41 41 + | None -> () 42 42 + 43 43 + type fork_result = { 44 44 + name : string; 45 45 + split_commit : string; 46 46 + src_path : Fpath.t; 47 47 + push_url : string option; 48 48 + packages_created : string list; 49 49 + } 50 50 + 51 51 + type join_result = { 52 52 + name : string; 53 53 + source_url : string; 54 54 + upstream_url : string option; 55 55 + packages_added : string list; 56 56 + from_handle : string option; 57 57 + } 58 58 + 59 59 + let pp_fork_result ppf (r : fork_result) = 60 60 + Fmt.pf ppf "@[<v>Forked subtree '%s':@, Split commit: %s@, Local repo: %a@," 61 61 + r.name 62 62 + (String.sub r.split_commit 0 (min 7 (String.length r.split_commit))) 63 63 + Fpath.pp r.src_path; 64 64 + (match r.push_url with 65 65 + | Some url -> Fmt.pf ppf " Push URL: %s@," url 66 66 + | None -> ()); 67 67 + if r.packages_created <> [] then 68 68 + Fmt.pf ppf " Packages: %a@]" Fmt.(list ~sep:(any ", ") string) r.packages_created 69 69 + else 70 70 + Fmt.pf ppf "@]" 71 71 + 72 72 + let pp_join_result ppf (r : join_result) = 73 73 + Fmt.pf ppf "@[<v>Joined repository '%s':@, Source: %s@," 74 74 + r.name r.source_url; 75 75 + (match r.upstream_url with 76 76 + | Some url -> Fmt.pf ppf " Upstream: %s@," url 77 77 + | None -> ()); 78 78 + (match r.from_handle with 79 79 + | Some h -> Fmt.pf ppf " From verse: %s@," h 80 80 + | None -> ()); 81 81 + if r.packages_added <> [] then 82 82 + Fmt.pf ppf " Packages: %a@]" Fmt.(list ~sep:(any ", ") string) r.packages_added 83 83 + else 84 84 + Fmt.pf ppf "@]" 85 85 + 86 86 + (** Helper to check if a path is a directory *) 87 87 + let is_directory ~fs path = 88 88 + let eio_path = Eio.Path.(fs / Fpath.to_string path) in 89 89 + match Eio.Path.kind ~follow:true eio_path with 90 90 + | `Directory -> true 91 91 + | _ -> false 92 92 + | exception _ -> false 93 93 + 94 94 + (** Helper to create a directory if it doesn't exist *) 95 95 + let ensure_dir ~fs path = 96 96 + let eio_path = Eio.Path.(fs / Fpath.to_string path) in 97 97 + try Eio.Path.mkdirs ~perm:0o755 eio_path with Eio.Io _ -> () 98 98 + 99 99 + (** Scan a directory for .opam files *) 100 100 + let find_opam_files ~fs path = 101 101 + let eio_path = Eio.Path.(fs / Fpath.to_string path) in 102 102 + try 103 103 + Eio.Path.read_dir eio_path 104 104 + |> List.filter (fun name -> String.ends_with ~suffix:".opam" name) 105 105 + |> List.map (fun name -> 106 106 + (* Extract package name from filename.opam *) 107 107 + String.sub name 0 (String.length name - 5)) 108 108 + with Eio.Io _ -> [] 109 109 + 110 110 + (** Normalize URL to git+ format for dev-repo *) 111 111 + let normalize_git_url url = 112 112 + if String.starts_with ~prefix:"git+" url then url 113 113 + else if String.starts_with ~prefix:"git://" url then url 114 114 + else if String.starts_with ~prefix:"https://" url then "git+" ^ url 115 115 + else if String.starts_with ~prefix:"http://" url then "git+" ^ url 116 116 + else url 117 117 + 118 118 + (** Extract name from URL (last path component without .git suffix) *) 119 119 + let name_from_url url = 120 120 + let uri = Uri.of_string url in 121 121 + let path = Uri.path uri in 122 122 + (* Remove leading slash and .git suffix *) 123 123 + let path = if String.length path > 0 && path.[0] = '/' then 124 124 + String.sub path 1 (String.length path - 1) 125 125 + else path in 126 126 + let path = if String.ends_with ~suffix:".git" path then 127 127 + String.sub path 0 (String.length path - 4) 128 128 + else path in 129 129 + (* Get last component *) 130 130 + match String.rindex_opt path '/' with 131 131 + | Some i -> String.sub path (i + 1) (String.length path - i - 1) 132 132 + | None -> path 133 133 + 134 134 + let fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () = 135 135 + let monorepo = Verse_config.mono_path config in 136 136 + let checkouts = Verse_config.src_path config in 137 137 + let prefix = name in 138 138 + let subtree_path = Fpath.(monorepo / prefix) in 139 139 + let src_path = Fpath.(checkouts / name) in 140 140 + (* Validate: mono/<name>/ must exist *) 141 141 + if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then 142 142 + Error (Subtree_not_found name) 143 143 + (* Validate: src/<name>/ must not exist *) 144 144 + else if is_directory ~fs src_path then 145 145 + Error (Src_already_exists name) 146 146 + else begin 147 147 + (* Find .opam files in subtree *) 148 148 + let packages = find_opam_files ~fs subtree_path in 149 149 + if packages = [] then 150 150 + Error (No_opam_files name) 151 151 + else if dry_run then 152 152 + Ok { name; split_commit = "(dry-run)"; src_path; push_url; packages_created = packages } 153 153 + else begin 154 154 + (* Split the subtree to get history *) 155 155 + match Git.Subtree.split ~proc ~fs ~repo:monorepo ~prefix () with 156 156 + | Error e -> Error (Git_error e) 157 157 + | Ok split_commit -> 158 158 + (* Ensure src/ exists *) 159 159 + ensure_dir ~fs checkouts; 160 160 + (* Initialize new git repo at src/<name>/ *) 161 161 + match Git.init ~proc ~fs src_path with 162 162 + | Error e -> Error (Git_error e) 163 163 + | Ok () -> 164 164 + (* Add 'origin' remote pointing to monorepo path temporarily *) 165 165 + let mono_str = Fpath.to_string monorepo in 166 166 + (match Git.add_remote ~proc ~fs ~name:"mono" ~url:mono_str src_path with 167 167 + | Error e -> Error (Git_error e) 168 168 + | Ok () -> 169 169 + (* Push split commit to local repo *) 170 170 + let ref_spec = split_commit ^ ":refs/heads/main" in 171 171 + match Git.push_ref ~proc ~fs ~repo:monorepo ~target:(Fpath.to_string src_path) ~ref_spec () with 172 172 + | Error e -> Error (Git_error e) 173 173 + | Ok () -> 174 174 + (* Checkout main branch *) 175 175 + (match Git.checkout ~proc ~fs ~branch:"main" src_path with 176 176 + | Error e -> Error (Git_error e) 177 177 + | Ok () -> 178 178 + (* Set push URL if provided *) 179 179 + let push_result = 180 180 + match push_url with 181 181 + | Some url -> 182 182 + (match Git.add_remote ~proc ~fs ~name:"origin" ~url src_path with 183 183 + | Error e -> Error (Git_error e) 184 184 + | Ok () -> Ok ()) 185 185 + | None -> Ok () 186 186 + in 187 187 + match push_result with 188 188 + | Error _ as e -> e 189 189 + | Ok () -> 190 190 + (* Only update sources.toml if there's a push URL *) 191 191 + (match push_url with 192 192 + | Some url -> 193 193 + let sources_path = Fpath.(monorepo / "sources.toml") in 194 194 + let sources = 195 195 + match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with 196 196 + | Ok s -> s 197 197 + | Error _ -> Sources_registry.empty 198 198 + in 199 199 + let entry = Sources_registry.{ 200 200 + url = normalize_git_url url; 201 201 + upstream = None; 202 202 + branch = Some "main"; 203 203 + reason = None; 204 204 + origin = Some Fork; 205 205 + } in 206 206 + let sources = Sources_registry.add sources ~subtree:name entry in 207 207 + (match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with 208 208 + | Ok () -> () 209 209 + | Error msg -> Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg)) 210 210 + | None -> ()); 211 211 + Ok { name; split_commit; src_path; push_url; packages_created = packages })) 212 212 + end 213 213 + end 214 214 + 215 215 + let join ~proc ~fs ~config ~url ?name ?upstream ?(dry_run = false) () = 216 216 + let name = match name with Some n -> n | None -> name_from_url url in 217 217 + let monorepo = Verse_config.mono_path config in 218 218 + let checkouts = Verse_config.src_path config in 219 219 + let prefix = name in 220 220 + let subtree_path = Fpath.(monorepo / prefix) in 221 221 + let src_path = Fpath.(checkouts / name) in 222 222 + (* Validate: mono/<name>/ must not exist *) 223 223 + if Git.Subtree.exists ~fs ~repo:monorepo ~prefix then 224 224 + Error (Subtree_already_exists name) 225 225 + else if dry_run then 226 226 + Ok { name; source_url = url; upstream_url = upstream; packages_added = []; from_handle = None } 227 227 + else begin 228 228 + (* Ensure src/ exists *) 229 229 + ensure_dir ~fs checkouts; 230 230 + (* Clone to src/<name>/ *) 231 231 + let branch = Verse_config.default_branch in 232 232 + let uri = Uri.of_string url in 233 233 + match Git.clone ~proc ~fs ~url:uri ~branch src_path with 234 234 + | Error e -> Error (Git_error e) 235 235 + | Ok () -> 236 236 + (* Add subtree to monorepo *) 237 237 + match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url:uri ~branch () with 238 238 + | Error e -> Error (Git_error e) 239 239 + | Ok () -> 240 240 + (* Find .opam files in the new subtree *) 241 241 + let packages = find_opam_files ~fs subtree_path in 242 242 + (* Only update sources.toml if there's an upstream to track *) 243 243 + (match upstream with 244 244 + | Some _ -> 245 245 + let sources_path = Fpath.(monorepo / "sources.toml") in 246 246 + let sources = 247 247 + match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with 248 248 + | Ok s -> s 249 249 + | Error _ -> Sources_registry.empty 250 250 + in 251 251 + let entry = Sources_registry.{ 252 252 + url = normalize_git_url url; 253 253 + upstream = Option.map normalize_git_url upstream; 254 254 + branch = Some branch; 255 255 + reason = None; 256 256 + origin = Some Join; 257 257 + } in 258 258 + let sources = Sources_registry.add sources ~subtree:name entry in 259 259 + (match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with 260 260 + | Ok () -> () 261 261 + | Error msg -> Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg)) 262 262 + | None -> ()); 263 263 + Ok { name; source_url = url; upstream_url = upstream; packages_added = packages; from_handle = None } 264 264 + end 265 265 + 266 266 + let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url ?(dry_run = false) () = 267 267 + (* First use verse fork to set up the opam entries *) 268 268 + match Verse.fork ~proc ~fs ~config:verse_config ~handle ~package ~fork_url ~dry_run () with 269 269 + | Error e -> Error (Verse_error e) 270 270 + | Ok fork_result -> 271 271 + if dry_run then 272 272 + Ok { 273 273 + name = fork_result.subtree_name; 274 274 + source_url = fork_url; 275 275 + upstream_url = Some fork_result.upstream_url; 276 276 + packages_added = fork_result.packages_forked; 277 277 + from_handle = Some handle; 278 278 + } 279 279 + else begin 280 280 + (* Now join the repository *) 281 281 + let name = fork_result.subtree_name in 282 282 + match join ~proc ~fs ~config ~url:fork_url ~name ~upstream:fork_result.upstream_url ~dry_run () with 283 283 + | Error e -> Error e 284 284 + | Ok join_result -> 285 285 + Ok { join_result with 286 286 + packages_added = fork_result.packages_forked; 287 287 + from_handle = Some handle; 288 288 + } 289 289 + end

+132

monopam/lib/fork_join.mli

reviewed

··· 1 1 + (** Fork and join operations for managing monorepo sources. 2 2 + 3 3 + This module provides operations to: 4 4 + - Fork: Split a monorepo subtree into its own repository in src/ 5 5 + - Join: Bring an external repository into the monorepo as a subtree 6 6 + 7 7 + Both operations update sources.toml to track the origin of each source. *) 8 8 + 9 9 + (** {1 Error Types} *) 10 10 + 11 11 + type error = 12 12 + | Config_error of string (** Configuration error *) 13 13 + | Git_error of Git.error (** Git operation failed *) 14 14 + | Subtree_not_found of string (** Subtree not found in monorepo *) 15 15 + | Src_already_exists of string (** Source checkout already exists *) 16 16 + | Subtree_already_exists of string (** Subtree already exists in monorepo *) 17 17 + | No_opam_files of string (** No .opam files found in subtree *) 18 18 + | Verse_error of Verse.error (** Error from verse operations *) 19 19 + 20 20 + val pp_error : error Fmt.t 21 21 + (** [pp_error] formats errors. *) 22 22 + 23 23 + val pp_error_with_hint : error Fmt.t 24 24 + (** [pp_error_with_hint] formats errors with helpful hints. *) 25 25 + 26 26 + val error_hint : error -> string option 27 27 + (** [error_hint e] returns a hint string for the given error, if available. *) 28 28 + 29 29 + (** {1 Fork Operations} *) 30 30 + 31 31 + (** Result of a fork operation. *) 32 32 + type fork_result = { 33 33 + name : string; (** Subtree/repository name *) 34 34 + split_commit : string; (** Git commit SHA from subtree split *) 35 35 + src_path : Fpath.t; (** Path to the new source checkout *) 36 36 + push_url : string option; (** Remote push URL if provided *) 37 37 + packages_created : string list; (** Package names from .opam files *) 38 38 + } 39 39 + 40 40 + val pp_fork_result : fork_result Fmt.t 41 41 + (** [pp_fork_result] formats a fork result. *) 42 42 + 43 43 + val fork : 44 44 + proc:_ Eio.Process.mgr -> 45 45 + fs:Eio.Fs.dir_ty Eio.Path.t -> 46 46 + config:Verse_config.t -> 47 47 + name:string -> 48 48 + ?push_url:string -> 49 49 + ?dry_run:bool -> 50 50 + unit -> 51 51 + (fork_result, error) result 52 52 + (** [fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] splits a monorepo 53 53 + subtree into its own repository. 54 54 + 55 55 + This operation: 56 56 + 1. Validates mono/<name>/ exists 57 57 + 2. Validates src/<name>/ does not exist 58 58 + 3. Uses [git subtree split] to extract history 59 59 + 4. Creates a new git repo at src/<name>/ 60 60 + 5. Pushes the split commit to the new repo 61 61 + 6. Updates sources.toml with [origin = "fork"] 62 62 + 7. Auto-discovers packages from .opam files 63 63 + 64 64 + @param name Name of the subtree to fork (directory name under mono/) 65 65 + @param push_url Optional remote URL to add as origin for pushing 66 66 + @param dry_run If true, validate and report what would be done *) 67 67 + 68 68 + (** {1 Join Operations} *) 69 69 + 70 70 + (** Result of a join operation. *) 71 71 + type join_result = { 72 72 + name : string; (** Subtree/repository name *) 73 73 + source_url : string; (** URL the repository was cloned from *) 74 74 + upstream_url : string option; (** Original upstream if this is a fork *) 75 75 + packages_added : string list; (** Package names from .opam files *) 76 76 + from_handle : string option; (** Verse handle if joined from verse *) 77 77 + } 78 78 + 79 79 + val pp_join_result : join_result Fmt.t 80 80 + (** [pp_join_result] formats a join result. *) 81 81 + 82 82 + val join : 83 83 + proc:_ Eio.Process.mgr -> 84 84 + fs:Eio.Fs.dir_ty Eio.Path.t -> 85 85 + config:Verse_config.t -> 86 86 + url:string -> 87 87 + ?name:string -> 88 88 + ?upstream:string -> 89 89 + ?dry_run:bool -> 90 90 + unit -> 91 91 + (join_result, error) result 92 92 + (** [join ~proc ~fs ~config ~url ?name ?upstream ?dry_run ()] brings an external 93 93 + repository into the monorepo. 94 94 + 95 95 + This operation: 96 96 + 1. Derives name from URL if not provided 97 97 + 2. Validates mono/<name>/ does not exist 98 98 + 3. Clones the repository to src/<name>/ 99 99 + 4. Uses [git subtree add] to bring into monorepo 100 100 + 5. Updates sources.toml with [origin = "join"] 101 101 + 6. Auto-discovers packages from .opam files 102 102 + 103 103 + @param url Git URL to clone from 104 104 + @param name Override the subtree directory name (default: derived from URL) 105 105 + @param upstream Original upstream URL if this is your fork of another project 106 106 + @param dry_run If true, validate and report what would be done *) 107 107 + 108 108 + val join_from_verse : 109 109 + proc:_ Eio.Process.mgr -> 110 110 + fs:Eio.Fs.dir_ty Eio.Path.t -> 111 111 + config:Verse_config.t -> 112 112 + verse_config:Verse_config.t -> 113 113 + package:string -> 114 114 + handle:string -> 115 115 + fork_url:string -> 116 116 + ?dry_run:bool -> 117 117 + unit -> 118 118 + (join_result, error) result 119 119 + (** [join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url 120 120 + ?dry_run ()] joins a package from a verse member's repository. 121 121 + 122 122 + This combines [Verse.fork] (to set up opam entries) with [join]: 123 123 + 1. Looks up the package in verse/<handle>-opam/ 124 124 + 2. Finds all packages sharing the same git repository 125 125 + 3. Creates opam entries pointing to your fork 126 126 + 4. Clones and adds the subtree 127 127 + 128 128 + @param verse_config Verse configuration (for accessing verse/ directory) 129 129 + @param package Package name to look up 130 130 + @param handle Verse member handle (e.g., "avsm.bsky.social") 131 131 + @param fork_url Your fork URL 132 132 + @param dry_run If true, validate and report what would be done *)

+4

monopam/lib/git.ml

reviewed

··· 272 272 in 273 273 run_git_ok_with_retry ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore 274 274 275 275 + let push_ref ~proc ~fs ~repo ~target ~ref_spec () = 276 276 + let cwd = path_to_eio ~fs repo in 277 277 + run_git_ok ~proc ~cwd [ "push"; target; ref_spec ] |> Result.map ignore 278 278 + 275 279 let set_push_url ~proc ~fs ?(remote = "origin") ~url path = 276 280 let cwd = path_to_eio ~fs path in 277 281 run_git_ok ~proc ~cwd [ "remote"; "set-url"; "--push"; remote; url ]

+15

monopam/lib/git.mli

reviewed

··· 274 274 @param remote Remote name (default: "origin") 275 275 @param branch Branch to push (default: current branch) *) 276 276 277 277 + val push_ref : 278 278 + proc:_ Eio.Process.mgr -> 279 279 + fs:Eio.Fs.dir_ty Eio.Path.t -> 280 280 + repo:Fpath.t -> 281 281 + target:string -> 282 282 + ref_spec:string -> 283 283 + unit -> 284 284 + (unit, error) result 285 285 + (** [push_ref ~proc ~fs ~repo ~target ~ref_spec ()] pushes a specific ref to a 286 286 + target repository or path. 287 287 + 288 288 + @param repo Path to the git repository to push from 289 289 + @param target Target repository path or remote name 290 290 + @param ref_spec The refspec to push (e.g., "abc123:refs/heads/main") *) 291 291 + 277 292 val set_push_url : 278 293 proc:_ Eio.Process.mgr -> 279 294 fs:Eio.Fs.dir_ty Eio.Path.t ->

+32 -4

monopam/lib/monopam.ml

reviewed

··· 14 14 module Dune_project = Dune_project 15 15 module Opam_transform = Opam_transform 16 16 module Sources_registry = Sources_registry 17 17 + module Fork_join = Fork_join 18 18 + module Site = Site 17 19 18 20 let src = Logs.Src.create "monopam" ~doc:"Monopam operations" 19 21 ··· 43 45 let error_hint = function 44 46 | Config_error _ -> 45 47 Some 46 46 - "Run 'monopam verse init --handle <your-handle>' to create a workspace." 48 48 + "Run 'monopam init --handle <your-handle>' to create a workspace." 47 49 | Repo_error (Opam_repo.No_dev_repo _) -> 48 50 Some 49 51 "Add a 'dev-repo' field to the package's opam file pointing to a git \ ··· 1543 1545 ?(skip_pull = false) () = 1544 1546 let fs_t = fs_typed fs in 1545 1547 1548 1548 + (* Step 0: Sync verse members if verse config exists and not skipping pull *) 1549 1549 + (if not skip_pull then 1550 1550 + match Verse_config.load ~fs:fs_t () with 1551 1551 + | Error _ -> () (* No verse config = skip *) 1552 1552 + | Ok verse_config -> 1553 1553 + Log.app (fun m -> m "Syncing verse members..."); 1554 1554 + match Verse.pull ~proc ~fs:fs_t ~config:verse_config () with 1555 1555 + | Ok () -> () 1556 1556 + | Error e -> Log.warn (fun m -> m "Verse sync: %a" Verse.pp_error e)); 1557 1557 + 1546 1558 (* Clone from verse registry if repos don't exist *) 1547 1559 match clone_from_verse_if_needed ~proc ~fs:fs_t ~config () with 1548 1560 | Error e -> Error e ··· 1607 1619 List.assoc_opt (Package.name pkg) status_by_name 1608 1620 |> Option.fold ~none:true ~some:(fun s -> 1609 1621 sync_needs_push s.Status.subtree_sync) 1622 1622 + in 1623 1623 + let sync_needs_pull = function 1624 1624 + | Status.Subtree_behind _ | Status.Trees_differ -> true 1625 1625 + | Status.In_sync | Status.Subtree_ahead _ | Status.Unknown -> 1626 1626 + false 1627 1627 + in 1628 1628 + let needs_pull pkg = 1629 1629 + List.assoc_opt (Package.name pkg) status_by_name 1630 1630 + |> Option.fold ~none:true ~some:(fun s -> 1631 1631 + sync_needs_pull s.Status.subtree_sync) 1610 1632 in 1611 1633 1612 1634 (* Step 2: Push phase - export monorepo changes to checkouts (PARALLEL) *) ··· 1755 1777 m " Skipping subtree updates (local modifications)...") 1756 1778 end 1757 1779 else begin 1780 1780 + (* OPTIMIZATION: skip packages already in sync *) 1781 1781 + let to_pull, to_skip = List.partition needs_pull successfully_fetched in 1758 1782 Log.app (fun m -> m " Updating subtrees..."); 1759 1759 - let fetched_count = List.length successfully_fetched in 1783 1783 + if to_skip <> [] then 1784 1784 + Log.app (fun m -> 1785 1785 + m " Skipping %d already-synced subtrees" 1786 1786 + (List.length to_skip)); 1787 1787 + let pull_count = List.length to_pull in 1760 1788 List.iteri 1761 1789 (fun i pkg -> 1762 1790 Log.info (fun m -> 1763 1763 - m "[%d/%d] Subtree %s" (i + 1) fetched_count 1791 1791 + m "[%d/%d] Subtree %s" (i + 1) pull_count 1764 1792 (Package.subtree_prefix pkg)); 1765 1793 match pull_subtree ~proc ~fs ~config pkg with 1766 1794 | Ok _ -> () ··· 1773 1801 } 1774 1802 :: !subtree_errs 1775 1803 | Error _ -> ()) 1776 1776 - successfully_fetched 1804 1804 + to_pull 1777 1805 end; 1778 1806 ( fetch_errs, 1779 1807 unchanged,

+2

monopam/lib/monopam.mli

reviewed

··· 38 38 module Dune_project = Dune_project 39 39 module Opam_transform = Opam_transform 40 40 module Sources_registry = Sources_registry 41 41 + module Fork_join = Fork_join 42 42 + module Site = Site 41 43 42 44 (** {1 High-Level Operations} *) 43 45

+535

monopam/lib/site.ml

reviewed

··· 1 1 + (** Generate a static HTML site representing the monoverse map. *) 2 2 + 3 3 + (** Information about a package in the verse *) 4 4 + type pkg_info = { 5 5 + name : string; 6 6 + synopsis : string option; 7 7 + repo_name : string; 8 8 + dev_repo : string; (** Upstream git URL *) 9 9 + owners : string list; (** List of handles that have this package *) 10 10 + depends : string list; (** Package dependencies *) 11 11 + } 12 12 + 13 13 + (** Information about a repository (group of packages) *) 14 14 + type repo_info = { 15 15 + ri_name : string; 16 16 + ri_dev_repo : string; 17 17 + ri_packages : pkg_info list; 18 18 + ri_owners : string list; (** All handles that have any package from this repo *) 19 19 + ri_fork_status : (string * Forks.relationship) list; (** (handle, relationship) *) 20 20 + ri_dep_count : int; (** Number of dependencies (for sorting) *) 21 21 + } 22 22 + 23 23 + (** Information about a verse member *) 24 24 + type member_info = { 25 25 + handle : string; 26 26 + display_name : string; (** Name to display (from registry or handle) *) 27 27 + monorepo_url : string; 28 28 + opam_url : string; 29 29 + package_count : int; 30 30 + unique_packages : string list; (** Packages unique to this member *) 31 31 + } 32 32 + 33 33 + (** Aggregated site data *) 34 34 + type site_data = { 35 35 + local_handle : string; 36 36 + registry_name : string; 37 37 + registry_description : string option; 38 38 + members : member_info list; 39 39 + common_repos : repo_info list; (** Repos that exist in multiple members *) 40 40 + unique_repos : repo_info list; (** Repos unique to one member *) 41 41 + all_packages : pkg_info list; (** All packages *) 42 42 + } 43 43 + 44 44 + (** Scan a member's opam repo and return package info *) 45 45 + let scan_member_packages ~fs opam_repo_path = 46 46 + let pkgs, _errors = Opam_repo.scan_all ~fs opam_repo_path in 47 47 + List.map (fun pkg -> 48 48 + { 49 49 + name = Package.name pkg; 50 50 + synopsis = Package.synopsis pkg; 51 51 + repo_name = Package.repo_name pkg; 52 52 + dev_repo = Uri.to_string (Package.dev_repo pkg); 53 53 + owners = []; 54 54 + depends = Package.depends pkg; 55 55 + } 56 56 + ) pkgs 57 57 + 58 58 + (** Check if a directory exists *) 59 59 + let dir_exists ~fs path = 60 60 + let eio_path = Eio.Path.(fs / Fpath.to_string path) in 61 61 + match Eio.Path.kind ~follow:true eio_path with 62 62 + | `Directory -> true 63 63 + | _ -> false 64 64 + | exception _ -> false 65 65 + 66 66 + (** Collect site data from the workspace *) 67 67 + let collect_data ~fs ~config ?forks ~registry () = 68 68 + let local_handle = Verse_config.handle config in 69 69 + let local_opam_repo = Verse_config.opam_repo_path config in 70 70 + let verse_path = Verse_config.verse_path config in 71 71 + 72 72 + (* Scan local packages *) 73 73 + let local_pkgs = 74 74 + if dir_exists ~fs local_opam_repo then 75 75 + scan_member_packages ~fs local_opam_repo 76 76 + else [] 77 77 + in 78 78 + 79 79 + (* Build a map: package name -> list of (handle, pkg_info) *) 80 80 + let pkg_map : (string, (string * pkg_info) list) Hashtbl.t = Hashtbl.create 256 in 81 81 + 82 82 + (* Add local packages *) 83 83 + List.iter (fun pkg -> 84 84 + let existing = try Hashtbl.find pkg_map pkg.name with Not_found -> [] in 85 85 + Hashtbl.replace pkg_map pkg.name ((local_handle, pkg) :: existing) 86 86 + ) local_pkgs; 87 87 + 88 88 + let registry_name = registry.Verse_registry.name in 89 89 + let registry_description = registry.Verse_registry.description in 90 90 + 91 91 + (* Build handle -> display name lookup *) 92 92 + let handle_to_name = Hashtbl.create 16 in 93 93 + List.iter (fun (m : Verse_registry.member) -> 94 94 + let display = match m.name with Some n -> n | None -> m.handle in 95 95 + Hashtbl.replace handle_to_name m.handle display 96 96 + ) registry.Verse_registry.members; 97 97 + 98 98 + (* Get tracked handles from verse directory, excluding local handle *) 99 99 + let tracked_handles = 100 100 + if dir_exists ~fs verse_path then 101 101 + let eio_path = Eio.Path.(fs / Fpath.to_string verse_path) in 102 102 + try 103 103 + Eio.Path.read_dir eio_path 104 104 + |> List.filter (fun name -> 105 105 + not (String.ends_with ~suffix:"-opam" name) && 106 106 + name <> local_handle && 107 107 + dir_exists ~fs Fpath.(verse_path / name)) 108 108 + with Eio.Io _ -> [] 109 109 + else [] 110 110 + in 111 111 + 112 112 + (* Scan each tracked member's opam repo *) 113 113 + let member_infos = 114 114 + List.filter_map (fun handle -> 115 115 + let opam_path = Fpath.(verse_path / (handle ^ "-opam")) in 116 116 + if dir_exists ~fs opam_path then begin 117 117 + let pkgs = scan_member_packages ~fs opam_path in 118 118 + (* Add to package map *) 119 119 + List.iter (fun pkg -> 120 120 + let existing = try Hashtbl.find pkg_map pkg.name with Not_found -> [] in 121 121 + Hashtbl.replace pkg_map pkg.name ((handle, pkg) :: existing) 122 122 + ) pkgs; 123 123 + (* Look up member in registry for URLs *) 124 124 + let member = Verse_registry.find_member registry ~handle in 125 125 + let display_name = 126 126 + try Hashtbl.find handle_to_name handle 127 127 + with Not_found -> handle 128 128 + in 129 129 + Some { 130 130 + handle; 131 131 + display_name; 132 132 + monorepo_url = (match member with Some m -> m.monorepo | None -> ""); 133 133 + opam_url = (match member with Some m -> m.opamrepo | None -> ""); 134 134 + package_count = List.length pkgs; 135 135 + unique_packages = []; (* Will be filled in later *) 136 136 + } 137 137 + end else None 138 138 + ) tracked_handles 139 139 + in 140 140 + 141 141 + (* Add local member info *) 142 142 + let local_member = 143 143 + let member = Verse_registry.find_member registry ~handle:local_handle in 144 144 + let display_name = 145 145 + try Hashtbl.find handle_to_name local_handle 146 146 + with Not_found -> local_handle 147 147 + in 148 148 + { 149 149 + handle = local_handle; 150 150 + display_name; 151 151 + monorepo_url = (match member with Some m -> m.monorepo | None -> ""); 152 152 + opam_url = (match member with Some m -> m.opamrepo | None -> ""); 153 153 + package_count = List.length local_pkgs; 154 154 + unique_packages = []; 155 155 + } 156 156 + in 157 157 + 158 158 + (* Build final package list with owners *) 159 159 + let all_packages = 160 160 + Hashtbl.fold (fun _name entries acc -> 161 161 + match entries with 162 162 + | [] -> acc 163 163 + | (_, pkg) :: _ as all -> 164 164 + let owners = List.map fst all in 165 165 + (* Pick the best synopsis (first non-None) *) 166 166 + let synopsis = 167 167 + List.find_map (fun (_, p) -> p.synopsis) all 168 168 + in 169 169 + (* Merge depends from all sources *) 170 170 + let depends = 171 171 + List.concat_map (fun (_, p) -> p.depends) all 172 172 + |> List.sort_uniq String.compare 173 173 + in 174 174 + { pkg with owners; synopsis; depends } :: acc 175 175 + ) pkg_map [] 176 176 + |> List.sort (fun a b -> String.compare a.name b.name) 177 177 + in 178 178 + 179 179 + (* Build set of all package names for dependency counting *) 180 180 + let all_pkg_names = 181 181 + List.fold_left (fun s p -> Hashtbl.replace s p.name (); s) 182 182 + (Hashtbl.create 256) all_packages 183 183 + in 184 184 + 185 185 + (* Group packages by repo *) 186 186 + let repos_map : (string, pkg_info list) Hashtbl.t = Hashtbl.create 64 in 187 187 + List.iter (fun (pkg : pkg_info) -> 188 188 + let existing = try Hashtbl.find repos_map pkg.repo_name with Not_found -> [] in 189 189 + Hashtbl.replace repos_map pkg.repo_name (pkg :: existing) 190 190 + ) all_packages; 191 191 + 192 192 + (* Build forks status lookup from forks data if provided *) 193 193 + let forks_by_repo : (string, (string * Forks.relationship) list) Hashtbl.t = Hashtbl.create 64 in 194 194 + (match forks with 195 195 + | Some f -> 196 196 + List.iter (fun (ra : Forks.repo_analysis) -> 197 197 + let statuses = List.map (fun (h, _src, rel) -> (h, rel)) ra.verse_sources in 198 198 + Hashtbl.replace forks_by_repo ra.repo_name statuses 199 199 + ) f.Forks.repos 200 200 + | None -> ()); 201 201 + 202 202 + (* Build repo_info list with dependency counts *) 203 203 + let all_repos = 204 204 + Hashtbl.fold (fun repo_name pkgs acc -> 205 205 + let dev_repo = (List.hd pkgs).dev_repo in 206 206 + let owners = 207 207 + List.sort_uniq String.compare (List.concat_map (fun (p : pkg_info) -> p.owners) pkgs) 208 208 + in 209 209 + let fork_status = 210 210 + try Hashtbl.find forks_by_repo repo_name with Not_found -> [] 211 211 + in 212 212 + (* Count dependencies that are in our package set *) 213 213 + let dep_count = 214 214 + List.concat_map (fun (p : pkg_info) -> p.depends) pkgs 215 215 + |> List.filter (fun d -> Hashtbl.mem all_pkg_names d) 216 216 + |> List.sort_uniq String.compare 217 217 + |> List.length 218 218 + in 219 219 + { ri_name = repo_name; 220 220 + ri_dev_repo = dev_repo; 221 221 + ri_packages = List.sort (fun a b -> String.compare a.name b.name) pkgs; 222 222 + ri_owners = owners; 223 223 + ri_fork_status = fork_status; 224 224 + ri_dep_count = dep_count } :: acc 225 225 + ) repos_map [] 226 226 + (* Sort by dependency count descending (apps with most deps first), then by name *) 227 227 + |> List.sort (fun a b -> 228 228 + let cmp = compare b.ri_dep_count a.ri_dep_count in 229 229 + if cmp <> 0 then cmp else String.compare a.ri_name b.ri_name) 230 230 + in 231 231 + 232 232 + (* Separate common and unique repos *) 233 233 + let common_repos = List.filter (fun r -> List.length r.ri_owners > 1) all_repos in 234 234 + let unique_repos = List.filter (fun r -> List.length r.ri_owners = 1) all_repos in 235 235 + 236 236 + (* Compute unique packages per member *) 237 237 + let unique_by_handle = Hashtbl.create 32 in 238 238 + List.iter (fun (pkg : pkg_info) -> 239 239 + if List.length pkg.owners = 1 then begin 240 240 + let handle = List.hd pkg.owners in 241 241 + let existing = try Hashtbl.find unique_by_handle handle with Not_found -> [] in 242 242 + Hashtbl.replace unique_by_handle handle (pkg.name :: existing) 243 243 + end 244 244 + ) all_packages; 245 245 + 246 246 + (* Update member infos with unique packages *) 247 247 + let update_member m = 248 248 + let unique = try Hashtbl.find unique_by_handle m.handle with Not_found -> [] in 249 249 + { m with unique_packages = List.sort String.compare unique } 250 250 + in 251 251 + 252 252 + let all_members = local_member :: member_infos in 253 253 + let members = List.map update_member all_members in 254 254 + 255 255 + { local_handle; registry_name; registry_description; members; common_repos; unique_repos; all_packages } 256 256 + 257 257 + (** Escape HTML special characters *) 258 258 + let html_escape s = 259 259 + let buf = Buffer.create (String.length s) in 260 260 + String.iter (function 261 261 + | '<' -> Buffer.add_string buf "&lt;" 262 262 + | '>' -> Buffer.add_string buf "&gt;" 263 263 + | '&' -> Buffer.add_string buf "&amp;" 264 264 + | '"' -> Buffer.add_string buf "&quot;" 265 265 + | c -> Buffer.add_char buf c 266 266 + ) s; 267 267 + Buffer.contents buf 268 268 + 269 269 + (** External link SVG icon *) 270 270 + let external_link_icon = 271 271 + {|<svg class="ext-icon" viewBox="0 0 12 12" fill="none" stroke="currentColor" stroke-width="1.5"><path d="M3.5 3H9V8.5M9 3L3 9"/></svg>|} 272 272 + 273 273 + (** Format fork relationship as short string *) 274 274 + let format_relationship = function 275 275 + | Forks.Same_url -> "=" 276 276 + | Forks.Same_commit -> "sync" 277 277 + | Forks.I_am_ahead n -> Printf.sprintf "+%d" n 278 278 + | Forks.I_am_behind n -> Printf.sprintf "-%d" n 279 279 + | Forks.Diverged { my_ahead; their_ahead; _ } -> Printf.sprintf "+%d/-%d" my_ahead their_ahead 280 280 + | Forks.Unrelated -> "unrel" 281 281 + | Forks.Not_fetched -> "?" 282 282 + 283 283 + (** Generate HTML from site data *) 284 284 + let generate_html data = 285 285 + let buf = Buffer.create 16384 in 286 286 + let add = Buffer.add_string buf in 287 287 + 288 288 + (* Build member lookups *) 289 289 + let member_urls = Hashtbl.create 16 in 290 290 + let member_names = Hashtbl.create 16 in 291 291 + List.iter (fun m -> 292 292 + Hashtbl.replace member_urls m.handle (m.monorepo_url, m.opam_url); 293 293 + Hashtbl.replace member_names m.handle m.display_name 294 294 + ) data.members; 295 295 + 296 296 + (* Helper to get display name for handle *) 297 297 + let get_name handle = 298 298 + try Hashtbl.find member_names handle with Not_found -> handle 299 299 + in 300 300 + 301 301 + add {|<!DOCTYPE html> 302 302 + <html lang="en"> 303 303 + <head> 304 304 + <meta charset="UTF-8"> 305 305 + <meta name="viewport" content="width=device-width, initial-scale=1.0"> 306 306 + <title>|}; 307 307 + add (html_escape data.registry_name); 308 308 + add {|</title> 309 309 + <style> 310 310 + * { margin: 0; padding: 0; box-sizing: border-box; } 311 311 + body { font: 10pt/1.4 -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, sans-serif; color: #333; max-width: 900px; margin: 0 auto; padding: 12px; } 312 312 + h1 { font-size: 14pt; font-weight: 600; margin-bottom: 4px; } 313 313 + .subtitle { font-size: 9pt; color: #666; margin-bottom: 12px; border-bottom: 1px solid #ddd; padding-bottom: 8px; } 314 314 + h2 { font-size: 11pt; font-weight: 600; margin: 16px 0 8px; color: #444; } 315 315 + h3 { font-size: 10pt; font-weight: 600; margin: 12px 0 6px; color: #555; } 316 316 + a { color: #0066cc; text-decoration: none; } 317 317 + a:hover { text-decoration: underline; } 318 318 + a.ext { color: #0088aa; } 319 319 + a.ext:hover { color: #006688; } 320 320 + .ext-icon { width: 10px; height: 10px; margin-left: 2px; vertical-align: baseline; position: relative; top: 1px; } 321 321 + .members { display: grid; grid-template-columns: repeat(auto-fill, minmax(200px, 1fr)); gap: 8px; margin-bottom: 16px; } 322 322 + .member { background: #f8f8f8; padding: 8px; border-radius: 4px; border: 1px solid #e0e0e0; } 323 323 + .member-name { font-weight: 600; margin-bottom: 2px; } 324 324 + .member-handle { font-size: 8pt; color: #888; margin-bottom: 4px; } 325 325 + .member-stats { font-size: 9pt; color: #666; } 326 326 + .member-links { font-size: 9pt; margin-top: 4px; } 327 327 + .member-links a { margin-right: 8px; } 328 328 + .section { margin-bottom: 20px; } 329 329 + .summary { background: #fafafa; border: 1px solid #e8e8e8; border-radius: 4px; padding: 12px; margin-bottom: 16px; } 330 330 + .summary-title { font-weight: 600; margin-bottom: 8px; } 331 331 + .summary-list { font-size: 9pt; color: #555; line-height: 1.6; } 332 332 + .summary-item { display: inline-block; background: #fff; border: 1px solid #ddd; padding: 1px 6px; border-radius: 3px; margin: 2px 2px; } 333 333 + .summary-item a { color: #333; } 334 334 + .repo { margin-bottom: 12px; padding: 8px; background: #fafafa; border-radius: 4px; } 335 335 + .repo-header { display: flex; align-items: baseline; gap: 8px; margin-bottom: 4px; } 336 336 + .repo-name { font-weight: 600; } 337 337 + .repo-name a { color: #333; } 338 338 + .repo-packages { font-size: 9pt; color: #666; margin-bottom: 4px; } 339 339 + .pkg-list { list-style: none; margin: 4px 0 0 0; padding: 0; } 340 340 + .pkg-list li { padding: 1px 0; color: #555; font-size: 8pt; } 341 341 + .pkg-list li::before { content: "-"; color: #999; margin-right: 6px; } 342 342 + .pkg-list b { font-weight: 500; color: #444; } 343 343 + .repo-forks { margin-top: 6px; } 344 344 + .repo-forks summary { font-size: 9pt; color: #666; cursor: pointer; } 345 345 + .repo-forks summary:hover { color: #444; } 346 346 + .fork-list { margin-top: 4px; font-size: 9pt; display: flex; flex-wrap: wrap; gap: 4px 12px; } 347 347 + .fork-item { color: #555; } 348 348 + .fork-item a { margin-left: 4px; } 349 349 + .fork-status { font-family: monospace; font-size: 8pt; padding: 1px 4px; border-radius: 2px; margin-left: 4px; } 350 350 + .fork-status.ahead { background: #e6f4ea; color: #137333; } 351 351 + .fork-status.behind { background: #fce8e6; color: #c5221f; } 352 352 + .fork-status.diverged { background: #fef7e0; color: #b06000; } 353 353 + .fork-status.sync { background: #e8f0fe; color: #1a73e8; } 354 354 + .unique-section { margin-top: 12px; } 355 355 + .unique-member { margin-bottom: 8px; } 356 356 + .unique-member-name { font-weight: 500; font-size: 9pt; color: #555; } 357 357 + .unique-list { font-size: 9pt; color: #666; margin-top: 2px; } 358 358 + .intro { background: #f0f7ff; border: 1px solid #d0e3f5; border-radius: 4px; padding: 10px 12px; margin-bottom: 16px; font-size: 9pt; line-height: 1.5; color: #444; } 359 359 + footer { margin-top: 20px; padding-top: 8px; border-top: 1px solid #ddd; font-size: 9pt; color: #888; } 360 360 + </style> 361 361 + </head> 362 362 + <body> 363 363 + |}; 364 364 + 365 365 + (* Title and description *) 366 366 + add (Printf.sprintf "<h1>%s</h1>\n" (html_escape data.registry_name)); 367 367 + (match data.registry_description with 368 368 + | Some desc -> add (Printf.sprintf "<div class=\"subtitle\">%s</div>\n" (html_escape desc)) 369 369 + | None -> add "<div class=\"subtitle\"></div>\n"); 370 370 + 371 371 + (* Intro section *) 372 372 + add {|<div class="intro"> 373 373 + This is an experiment in large-scale agentic coding using OCaml and OxCaml, where we're building environments to exchange vibe code at scale. 374 374 + Managed by <a class="ext" href="https://tangled.org/anil.recoil.org/monopam">monopam|}; add external_link_icon; add {|</a>, 375 375 + with the central registry at <a class="ext" href="https://tangled.org/eeg.cl.cam.ac.uk/opamverse">opamverse|}; add external_link_icon; add {|</a>. 376 376 + </div> 377 377 + |}; 378 378 + 379 379 + (* Members section *) 380 380 + add "<div class=\"section\">\n<h2>Members</h2>\n<div class=\"members\">\n"; 381 381 + List.iter (fun m -> 382 382 + add "<div class=\"member\">\n"; 383 383 + add (Printf.sprintf "<div class=\"member-name\"><a href=\"https://%s\">%s</a></div>\n" 384 384 + (html_escape m.handle) (html_escape m.display_name)); 385 385 + if m.display_name <> m.handle then 386 386 + add (Printf.sprintf "<div class=\"member-handle\">%s</div>\n" (html_escape m.handle)); 387 387 + add (Printf.sprintf "<div class=\"member-stats\">%d packages" m.package_count); 388 388 + if m.unique_packages <> [] then 389 389 + add (Printf.sprintf ", %d unique" (List.length m.unique_packages)); 390 390 + add "</div>\n"; 391 391 + if m.monorepo_url <> "" || m.opam_url <> "" then begin 392 392 + add "<div class=\"member-links\">"; 393 393 + if m.monorepo_url <> "" then 394 394 + add (Printf.sprintf "<a class=\"ext\" href=\"%s\">mono%s</a>" (html_escape m.monorepo_url) external_link_icon); 395 395 + if m.opam_url <> "" then 396 396 + add (Printf.sprintf "<a class=\"ext\" href=\"%s\">opam%s</a>" (html_escape m.opam_url) external_link_icon); 397 397 + add "</div>\n" 398 398 + end; 399 399 + add "</div>\n" 400 400 + ) data.members; 401 401 + add "</div>\n</div>\n"; 402 402 + 403 403 + (* Summary section *) 404 404 + add "<div class=\"section\">\n"; 405 405 + add "<div class=\"summary\">\n"; 406 406 + add (Printf.sprintf "<div class=\"summary-title\">Common Libraries (%d repos, %d packages)</div>\n" 407 407 + (List.length data.common_repos) 408 408 + (List.fold_left (fun acc r -> acc + List.length r.ri_packages) 0 data.common_repos)); 409 409 + add "<div class=\"summary-list\">\n"; 410 410 + List.iter (fun r -> 411 411 + add (Printf.sprintf "<span class=\"summary-item\"><a href=\"#%s\">%s</a> <span style=\"color:#888\">(%d)</span></span>\n" 412 412 + (html_escape r.ri_name) (html_escape r.ri_name) (List.length r.ri_packages)) 413 413 + ) data.common_repos; 414 414 + add "</div>\n</div>\n"; 415 415 + 416 416 + (* Member-specific summary *) 417 417 + let members_with_unique = List.filter (fun m -> m.unique_packages <> []) data.members in 418 418 + if members_with_unique <> [] then begin 419 419 + add "<div class=\"summary\">\n"; 420 420 + add "<div class=\"summary-title\">Member-Specific Packages</div>\n"; 421 421 + add "<div class=\"unique-section\">\n"; 422 422 + List.iter (fun m -> 423 423 + add "<div class=\"unique-member\">\n"; 424 424 + add (Printf.sprintf "<span class=\"unique-member-name\"><a href=\"https://%s\">%s</a>:</span> " 425 425 + (html_escape m.handle) (html_escape m.display_name)); 426 426 + add "<span class=\"unique-list\">"; 427 427 + add (String.concat ", " (List.map html_escape m.unique_packages)); 428 428 + add "</span>\n"; 429 429 + add "</div>\n" 430 430 + ) members_with_unique; 431 431 + add "</div>\n</div>\n" 432 432 + end; 433 433 + add "</div>\n"; 434 434 + 435 435 + (* Detailed repos section *) 436 436 + if data.common_repos <> [] then begin 437 437 + add "<div class=\"section\">\n<h2>Repository Details</h2>\n"; 438 438 + 439 439 + List.iter (fun r -> 440 440 + add (Printf.sprintf "<div class=\"repo\" id=\"%s\">\n" (html_escape r.ri_name)); 441 441 + add "<div class=\"repo-header\">"; 442 442 + add (Printf.sprintf "<span class=\"repo-name\"><a class=\"ext\" href=\"%s\">%s%s</a></span>" 443 443 + (html_escape r.ri_dev_repo) (html_escape r.ri_name) external_link_icon); 444 444 + add "</div>\n"; 445 445 + 446 446 + (* Packages list - compact with names *) 447 447 + add "<div class=\"repo-packages\">"; 448 448 + let pkg_names = List.map (fun (p : pkg_info) -> p.name) r.ri_packages in 449 449 + add (String.concat ", " (List.map html_escape pkg_names)); 450 450 + add "</div>\n"; 451 451 + 452 452 + (* Package descriptions as bullet list *) 453 453 + let pkg_descs = List.filter_map (fun (p : pkg_info) -> 454 454 + match p.synopsis with 455 455 + | Some s -> Some (p.name, s) 456 456 + | None -> None 457 457 + ) r.ri_packages in 458 458 + if pkg_descs <> [] then begin 459 459 + add "<ul class=\"pkg-list\">\n"; 460 460 + List.iter (fun (name, desc) -> 461 461 + add (Printf.sprintf "<li><b>%s</b>: %s</li>\n" (html_escape name) (html_escape desc)) 462 462 + ) pkg_descs; 463 463 + add "</ul>\n" 464 464 + end; 465 465 + 466 466 + (* Forks - at repo level with names *) 467 467 + if List.length r.ri_owners > 1 then begin 468 468 + let owner_links = List.map (fun h -> 469 469 + Printf.sprintf "<a href=\"https://%s\">%s</a>" (html_escape h) (html_escape (get_name h)) 470 470 + ) (List.sort String.compare r.ri_owners) in 471 471 + add "<details class=\"repo-forks\">\n"; 472 472 + add (Printf.sprintf "<summary>%d members (%s)</summary>\n" 473 473 + (List.length r.ri_owners) 474 474 + (String.concat ", " owner_links)); 475 475 + add "<div class=\"fork-list\">\n"; 476 476 + List.iter (fun handle -> 477 477 + let mono_url, _opam_url = 478 478 + try Hashtbl.find member_urls handle 479 479 + with Not_found -> ("", "") 480 480 + in 481 481 + add "<span class=\"fork-item\">"; 482 482 + add (Printf.sprintf "<a href=\"https://%s\">%s</a>" (html_escape handle) (html_escape (get_name handle))); 483 483 + (* Add status if available *) 484 484 + (match List.assoc_opt handle r.ri_fork_status with 485 485 + | Some rel -> 486 486 + let status_str = format_relationship rel in 487 487 + let status_class = 488 488 + match rel with 489 489 + | Forks.Same_url | Forks.Same_commit -> "sync" 490 490 + | Forks.I_am_ahead _ -> "ahead" 491 491 + | Forks.I_am_behind _ -> "behind" 492 492 + | Forks.Diverged _ -> "diverged" 493 493 + | _ -> "" 494 494 + in 495 495 + if status_class <> "" then 496 496 + add (Printf.sprintf "<span class=\"fork-status %s\">%s</span>" status_class status_str) 497 497 + else 498 498 + add (Printf.sprintf "<span class=\"fork-status\">%s</span>" status_str) 499 499 + | None -> ()); 500 500 + if mono_url <> "" then 501 501 + add (Printf.sprintf "<a class=\"ext\" href=\"%s/%s\">mono%s</a>" 502 502 + (html_escape mono_url) (html_escape r.ri_name) external_link_icon); 503 503 + add "</span>\n" 504 504 + ) (List.sort String.compare r.ri_owners); 505 505 + add "</div>\n</details>\n" 506 506 + end; 507 507 + 508 508 + add "</div>\n" 509 509 + ) data.common_repos; 510 510 + 511 511 + add "</div>\n" 512 512 + end; 513 513 + 514 514 + (* Footer with generation date *) 515 515 + let now = Unix.gettimeofday () in 516 516 + let tm = Unix.gmtime now in 517 517 + let date_str = Printf.sprintf "%04d-%02d-%02d" 518 518 + (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday in 519 519 + add (Printf.sprintf "<footer>Generated by monopam on %s | %d members | %d repos | %d packages</footer>\n" 520 520 + date_str (List.length data.members) (List.length data.common_repos + List.length data.unique_repos) (List.length data.all_packages)); 521 521 + 522 522 + add "</body>\n</html>\n"; 523 523 + Buffer.contents buf 524 524 + 525 525 + (** Generate the site and return the HTML content *) 526 526 + let generate ~fs ~config ?forks ~registry () = 527 527 + let data = collect_data ~fs ~config ?forks ~registry () in 528 528 + generate_html data 529 529 + 530 530 + (** Write the site to a file *) 531 531 + let write ~fs ~config ?forks ~registry ~output_path () = 532 532 + let html = generate ~fs ~config ?forks ~registry () in 533 533 + let eio_path = Eio.Path.(fs / Fpath.to_string output_path) in 534 534 + Eio.Path.save ~create:(`Or_truncate 0o644) eio_path html; 535 535 + Ok ()

+82

monopam/lib/site.mli

reviewed

··· 1 1 + (** Generate a static HTML site representing the monoverse map. 2 2 + 3 3 + The site command generates an index.html that shows: 4 4 + - All verse members with links to their repos 5 5 + - Summary of common libraries and member-specific packages 6 6 + - Detailed repository information with fork status *) 7 7 + 8 8 + (** {1 Types} *) 9 9 + 10 10 + (** Information about a package in the verse *) 11 11 + type pkg_info = { 12 12 + name : string; 13 13 + synopsis : string option; 14 14 + repo_name : string; 15 15 + dev_repo : string; (** Upstream git URL *) 16 16 + owners : string list; (** List of handles that have this package *) 17 17 + depends : string list; (** Package dependencies *) 18 18 + } 19 19 + 20 20 + (** Information about a repository (group of packages) *) 21 21 + type repo_info = { 22 22 + ri_name : string; 23 23 + ri_dev_repo : string; 24 24 + ri_packages : pkg_info list; 25 25 + ri_owners : string list; (** All handles that have any package from this repo *) 26 26 + ri_fork_status : (string * Forks.relationship) list; (** (handle, relationship) *) 27 27 + ri_dep_count : int; (** Number of dependencies (for sorting) *) 28 28 + } 29 29 + 30 30 + (** Information about a verse member *) 31 31 + type member_info = { 32 32 + handle : string; 33 33 + display_name : string; (** Name to display (from registry or handle) *) 34 34 + monorepo_url : string; 35 35 + opam_url : string; 36 36 + package_count : int; 37 37 + unique_packages : string list; (** Packages unique to this member *) 38 38 + } 39 39 + 40 40 + (** Aggregated site data *) 41 41 + type site_data = { 42 42 + local_handle : string; 43 43 + registry_name : string; 44 44 + registry_description : string option; 45 45 + members : member_info list; 46 46 + common_repos : repo_info list; (** Repos that exist in multiple members *) 47 47 + unique_repos : repo_info list; (** Repos unique to one member *) 48 48 + all_packages : pkg_info list; (** All packages *) 49 49 + } 50 50 + 51 51 + (** {1 Generation} *) 52 52 + 53 53 + val collect_data : 54 54 + fs:Eio.Fs.dir_ty Eio.Path.t -> 55 55 + config:Verse_config.t -> 56 56 + ?forks:Forks.t -> 57 57 + registry:Verse_registry.t -> 58 58 + unit -> 59 59 + site_data 60 60 + (** [collect_data ~fs ~config ?forks ~registry ()] scans the workspace and verse members 61 61 + to collect package information for the site. If [forks] is provided, 62 62 + includes fork status information for each repository. *) 63 63 + 64 64 + val generate : 65 65 + fs:Eio.Fs.dir_ty Eio.Path.t -> 66 66 + config:Verse_config.t -> 67 67 + ?forks:Forks.t -> 68 68 + registry:Verse_registry.t -> 69 69 + unit -> 70 70 + string 71 71 + (** [generate ~fs ~config ?forks ~registry ()] generates the HTML content for the site. *) 72 72 + 73 73 + val write : 74 74 + fs:Eio.Fs.dir_ty Eio.Path.t -> 75 75 + config:Verse_config.t -> 76 76 + ?forks:Forks.t -> 77 77 + registry:Verse_registry.t -> 78 78 + output_path:Fpath.t -> 79 79 + unit -> 80 80 + (unit, string) result 81 81 + (** [write ~fs ~config ?forks ~registry ~output_path ()] generates and writes the site 82 82 + to the specified output path. *)

+19 -1

monopam/lib/sources_registry.ml

reviewed

··· 1 1 (** Sources registry for tracking forked/vendored package URLs. *) 2 2 3 3 + type origin = Fork | Join 4 4 + 3 5 type entry = { 4 6 url : string; 5 7 upstream : string option; 6 8 branch : string option; 7 9 reason : string option; 10 10 + origin : origin option; 8 11 } 9 12 10 13 type t = { ··· 58 61 branch = "backport-5.1" 59 62 *) 60 63 64 64 + let origin_codec : origin Tomlt.t = 65 65 + Tomlt.map 66 66 + ~dec:(function 67 67 + | "fork" -> Fork 68 68 + | "join" -> Join 69 69 + | s -> failwith (Printf.sprintf "Invalid origin: %s (expected 'fork' or 'join')" s)) 70 70 + ~enc:(function Fork -> "fork" | Join -> "join") 71 71 + Tomlt.string 72 72 + 61 73 let entry_codec : entry Tomlt.t = 62 74 Tomlt.( 63 75 Table.( 64 64 - obj (fun url upstream branch reason -> { url; upstream; branch; reason }) 76 76 + obj (fun url upstream branch reason origin -> { url; upstream; branch; reason; origin }) 65 77 |> mem "url" string ~enc:(fun e -> e.url) 66 78 |> opt_mem "upstream" string ~enc:(fun e -> e.upstream) 67 79 |> opt_mem "branch" string ~enc:(fun e -> e.branch) 68 80 |> opt_mem "reason" string ~enc:(fun e -> e.reason) 81 81 + |> opt_mem "origin" origin_codec ~enc:(fun e -> e.origin) 69 82 |> finish)) 70 83 71 84 let codec : t Tomlt.t = ··· 96 109 Ok () 97 110 with exn -> Error (Printexc.to_string exn) 98 111 112 112 + let pp_origin ppf = function 113 113 + | Fork -> Fmt.string ppf "fork" 114 114 + | Join -> Fmt.string ppf "join" 115 115 + 99 116 let pp_entry ppf e = 100 117 Fmt.pf ppf "@[<hov 2>url: %s" e.url; 101 118 Option.iter (fun u -> Fmt.pf ppf "@ upstream: %s" u) e.upstream; 102 119 Option.iter (fun b -> Fmt.pf ppf "@ branch: %s" b) e.branch; 103 120 Option.iter (fun r -> Fmt.pf ppf "@ reason: %s" r) e.reason; 121 121 + Option.iter (fun o -> Fmt.pf ppf "@ origin: %a" pp_origin o) e.origin; 104 122 Fmt.pf ppf "@]" 105 123 106 124 let pp ppf t =

+6

monopam/lib/sources_registry.mli

reviewed

··· 15 15 For a subtree named "ocaml-foo", this would produce: 16 16 [git+https://tangled.org/anil.recoil.org/ocaml-foo] *) 17 17 18 18 + (** How a source entry was created. *) 19 19 + type origin = 20 20 + | Fork (** Created via [monopam fork] - subtree split from monorepo *) 21 21 + | Join (** Created via [monopam join] - external repo brought into monorepo *) 22 22 + 18 23 (** A source entry for a subtree. *) 19 24 type entry = { 20 25 url : string; (** Our dev-repo URL (e.g., "git+https://github.com/avsm/braid") *) 21 26 upstream : string option; (** Original upstream URL if this is a fork *) 22 27 branch : string option; (** Override branch (default: main) *) 23 28 reason : string option; (** Why we have a custom source *) 29 29 + origin : origin option; (** How this entry was created *) 24 30 } 25 31 26 32 (** The sources registry - maps subtree names to source entries. *)

+69 -14

monopam/lib/status.ml

reviewed

··· 160 160 Fmt.pf ppf "@[<h>%-20s checkout: %a subtree: %a@]" (Package.name t.package) 161 161 pp_checkout_status t.checkout pp_subtree_status t.subtree 162 162 163 163 + (** Extract handle from a tangled.org URL like "git+https://tangled.org/handle/repo" *) 164 164 + let extract_handle_from_url url = 165 165 + let url = if String.starts_with ~prefix:"git+" url then 166 166 + String.sub url 4 (String.length url - 4) 167 167 + else url in 168 168 + let uri = Uri.of_string url in 169 169 + match Uri.host uri with 170 170 + | Some "tangled.org" -> 171 171 + let path = Uri.path uri in 172 172 + (* Path is like "/handle/repo" - extract first component *) 173 173 + let path = if String.length path > 0 && path.[0] = '/' then 174 174 + String.sub path 1 (String.length path - 1) 175 175 + else path in 176 176 + (match String.index_opt path '/' with 177 177 + | Some i -> Some (String.sub path 0 i) 178 178 + | None -> Some path) 179 179 + | _ -> None 180 180 + 181 181 + (** Format origin indicator from sources registry entry *) 182 182 + let pp_origin_indicator ppf entry = 183 183 + match entry with 184 184 + | None -> () 185 185 + | Some Sources_registry.{ origin = Some Sources_registry.Fork; _ } -> 186 186 + Fmt.pf ppf " %a" Fmt.(styled `Magenta string) "^" 187 187 + | Some Sources_registry.{ origin = Some Sources_registry.Join; upstream = Some url; _ } -> 188 188 + (match extract_handle_from_url url with 189 189 + | Some handle -> 190 190 + (* Abbreviate handle - take first part before dot, max 8 chars *) 191 191 + let abbrev = match String.index_opt handle '.' with 192 192 + | Some i -> String.sub handle 0 i 193 193 + | None -> handle 194 194 + in 195 195 + let abbrev = if String.length abbrev > 8 then String.sub abbrev 0 8 else abbrev in 196 196 + Fmt.pf ppf " %a" Fmt.(styled `Cyan (fun ppf s -> pf ppf "v:%s" s)) abbrev 197 197 + | None -> Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:") 198 198 + | Some Sources_registry.{ origin = Some Sources_registry.Join; _ } -> 199 199 + Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:" 200 200 + | Some _ -> () 201 201 + 163 202 (** Compact status for actionable items with colors *) 164 164 - let pp_compact ppf t = 203 203 + let pp_compact ?sources ppf t = 165 204 let name = Package.name t.package in 205 205 + let subtree = Package.subtree_prefix t.package in 206 206 + let entry = match sources with 207 207 + | Some s -> Sources_registry.find s ~subtree 208 208 + | None -> None 209 209 + in 166 210 (* Helper to print remote sync info *) 167 211 let pp_remote ab = 168 212 if ab.Git.ahead > 0 && ab.behind > 0 then ··· 184 228 Fmt.pf ppf "%-22s %a" name 185 229 Fmt.(styled `Blue (fun ppf n -> pf ppf "local:-%d" n)) 186 230 n; 187 187 - pp_remote ab 231 231 + pp_remote ab; 232 232 + pp_origin_indicator ppf entry 188 233 | Clean ab, Present, Subtree_ahead n -> 189 234 Fmt.pf ppf "%-22s %a" name 190 235 Fmt.(styled `Blue (fun ppf n -> pf ppf "local:+%d" n)) 191 236 n; 192 192 - pp_remote ab 237 237 + pp_remote ab; 238 238 + pp_origin_indicator ppf entry 193 239 (* Trees differ but can't determine count *) 194 240 | Clean ab, Present, Trees_differ -> 195 241 Fmt.pf ppf "%-22s %a" name Fmt.(styled `Blue string) "local:sync"; 196 196 - pp_remote ab 242 242 + pp_remote ab; 243 243 + pp_origin_indicator ppf entry 197 244 (* Remote sync issues only *) 198 245 | Clean ab, Present, (In_sync | Unknown) when ab.ahead > 0 && ab.behind > 0 -> 199 246 Fmt.pf ppf "%-22s %a" name 200 247 Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b)) 201 201 - (ab.ahead, ab.behind) 248 248 + (ab.ahead, ab.behind); 249 249 + pp_origin_indicator ppf entry 202 250 | Clean ab, Present, (In_sync | Unknown) when ab.ahead > 0 -> 203 251 Fmt.pf ppf "%-22s %a" name 204 252 Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n)) 205 205 - ab.ahead 253 253 + ab.ahead; 254 254 + pp_origin_indicator ppf entry 206 255 | Clean ab, Present, (In_sync | Unknown) when ab.behind > 0 -> 207 256 Fmt.pf ppf "%-22s %a" name 208 257 Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n)) 209 209 - ab.behind 258 258 + ab.behind; 259 259 + pp_origin_indicator ppf entry 210 260 (* Other issues *) 211 261 | Clean _, Not_added, _ -> 212 212 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Magenta string) "(no subtree)" 262 262 + Fmt.pf ppf "%-22s %a" name Fmt.(styled `Magenta string) "(no subtree)"; 263 263 + pp_origin_indicator ppf entry 213 264 | Missing, _, _ -> 214 214 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(no checkout)" 265 265 + Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(no checkout)"; 266 266 + pp_origin_indicator ppf entry 215 267 | Not_a_repo, _, _ -> 216 216 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(not a repo)" 268 268 + Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(not a repo)"; 269 269 + pp_origin_indicator ppf entry 217 270 | Dirty, _, _ -> 218 218 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow string) "(dirty)" 271 271 + Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow string) "(dirty)"; 272 272 + pp_origin_indicator ppf entry 219 273 | Clean _, Present, (In_sync | Unknown) -> 220 220 - Fmt.pf ppf "%-22s %a" name Fmt.(styled `Green string) "ok" 274 274 + Fmt.pf ppf "%-22s %a" name Fmt.(styled `Green string) "ok"; 275 275 + pp_origin_indicator ppf entry 221 276 222 222 - let pp_summary ppf statuses = 277 277 + let pp_summary ?sources ppf statuses = 223 278 let total = List.length statuses in 224 279 let actionable = filter_actionable statuses in 225 280 let synced = List.filter is_fully_synced statuses |> List.length in ··· 258 313 "all synced"; 259 314 (* Only show actionable items *) 260 315 if actionable <> [] then 261 261 - List.iter (fun t -> Fmt.pf ppf " %a\n" pp_compact t) actionable 316 316 + List.iter (fun t -> Fmt.pf ppf " %a\n" (pp_compact ?sources) t) actionable

+7 -2

monopam/lib/status.mli

reviewed

··· 112 112 val pp : t Fmt.t 113 113 (** [pp] formats a single package status. *) 114 114 115 115 - val pp_summary : t list Fmt.t 116 116 - (** [pp_summary] formats a summary of all package statuses. *) 115 115 + val pp_compact : ?sources:Sources_registry.t -> t Fmt.t 116 116 + (** [pp_compact ?sources] formats a single package status in compact form with colors. 117 117 + If [sources] is provided, displays origin indicators (^ for fork, v:handle for join). *) 118 118 + 119 119 + val pp_summary : ?sources:Sources_registry.t -> t list Fmt.t 120 120 + (** [pp_summary ?sources] formats a summary of all package statuses. 121 121 + If [sources] is provided, displays origin indicators for each package. *)

+2 -2

monopam/lib/verse.ml

reviewed

··· 26 26 let error_hint = function 27 27 | Config_error _ -> 28 28 Some 29 29 - "Run 'monopam verse init --handle <your-handle>' to create a workspace." 29 29 + "Run 'monopam init --handle <your-handle>' to create a workspace." 30 30 | Git_error (Git.Dirty_worktree _) -> 31 31 Some "Commit or stash your changes first: git status" 32 32 | Git_error (Git.Command_failed (cmd, _)) ··· 45 45 | Workspace_exists _ -> 46 46 Some "Use a different directory, or remove the existing workspace." 47 47 | Not_a_workspace _ -> 48 48 - Some "Run 'monopam verse init --handle <your-handle>' to create a workspace here." 48 48 + Some "Run 'monopam init --handle <your-handle>' to create a workspace here." 49 49 | Package_not_found (pkg, handle) -> 50 50 Some (Fmt.str "Run 'monopam verse pull %s' to sync their opam repo, then check package name: %s" handle pkg) 51 51 | Package_already_exists pkgs ->

+18 -13

monopam/lib/verse_registry.ml

reviewed

··· 1 1 type member = { 2 2 handle : string; 3 3 + name : string option; 3 4 monorepo : string; 4 5 monorepo_branch : string option; 5 6 opamrepo : string; 6 7 opamrepo_branch : string option; 7 8 } 8 8 - type t = { name : string; members : member list } 9 9 + type t = { name : string; description : string option; members : member list } 9 10 10 11 let default_url = "https://tangled.org/eeg.cl.cam.ac.uk/opamverse" 11 12 ··· 27 28 let pp_member ppf m = 28 29 let mono_str = encode_url_with_branch m.monorepo m.monorepo_branch in 29 30 let opam_str = encode_url_with_branch m.opamrepo m.opamrepo_branch in 30 30 - Fmt.pf ppf "@[<hov 2>%s ->@ mono:%s@ opam:%s@]" m.handle mono_str opam_str 31 31 + let name_str = match m.name with Some n -> n | None -> m.handle in 32 32 + Fmt.pf ppf "@[<hov 2>%s (%s) ->@ mono:%s@ opam:%s@]" name_str m.handle mono_str opam_str 31 33 32 34 let pp ppf t = 33 33 - Fmt.pf ppf "@[<v>registry: %s@,members:@, @[<v>%a@]@]" t.name 35 35 + Fmt.pf ppf "@[<v>registry: %s%a@,members:@, @[<v>%a@]@]" t.name 36 36 + Fmt.(option (fun ppf s -> pf ppf "@,description: %s" s)) t.description 34 37 Fmt.(list ~sep:cut pp_member) 35 38 t.members 36 39 ··· 47 50 let member_codec : member Tomlt.t = 48 51 Tomlt.( 49 52 Table.( 50 50 - obj (fun handle monorepo_raw opamrepo_raw -> 53 53 + obj (fun handle name monorepo_raw opamrepo_raw -> 51 54 let monorepo, monorepo_branch = parse_url_with_branch monorepo_raw in 52 55 let opamrepo, opamrepo_branch = parse_url_with_branch opamrepo_raw in 53 53 - { handle; monorepo; monorepo_branch; opamrepo; opamrepo_branch }) 54 54 - |> mem "handle" string ~enc:(fun m -> m.handle) 55 55 - |> mem "monorepo" string ~enc:(fun m -> encode_url_with_branch m.monorepo m.monorepo_branch) 56 56 - |> mem "opamrepo" string ~enc:(fun m -> encode_url_with_branch m.opamrepo m.opamrepo_branch) 56 56 + { handle; name; monorepo; monorepo_branch; opamrepo; opamrepo_branch }) 57 57 + |> mem "handle" string ~enc:(fun (m : member) -> m.handle) 58 58 + |> opt_mem "name" string ~enc:(fun (m : member) -> m.name) 59 59 + |> mem "monorepo" string ~enc:(fun (m : member) -> encode_url_with_branch m.monorepo m.monorepo_branch) 60 60 + |> mem "opamrepo" string ~enc:(fun (m : member) -> encode_url_with_branch m.opamrepo m.opamrepo_branch) 57 61 |> finish)) 58 62 59 59 - type registry_info = { r_name : string } 63 63 + type registry_info = { r_name : string; r_description : string option } 60 64 61 65 let registry_info_codec : registry_info Tomlt.t = 62 66 Tomlt.( 63 67 Table.( 64 64 - obj (fun r_name -> { r_name }) 68 68 + obj (fun r_name r_description -> { r_name; r_description }) 65 69 |> mem "name" string ~enc:(fun r -> r.r_name) 70 70 + |> opt_mem "description" string ~enc:(fun r -> r.r_description) 66 71 |> finish)) 67 72 68 73 let codec : t Tomlt.t = 69 74 Tomlt.( 70 75 Table.( 71 76 obj (fun registry members -> 72 72 - { name = registry.r_name; members = Option.value ~default:[] members }) 73 73 - |> mem "registry" registry_info_codec ~enc:(fun t -> { r_name = t.name }) 77 77 + { name = registry.r_name; description = registry.r_description; members = Option.value ~default:[] members }) 78 78 + |> mem "registry" registry_info_codec ~enc:(fun t -> { r_name = t.name; r_description = t.description }) 74 79 |> opt_mem "members" (list member_codec) ~enc:(fun t -> 75 80 match t.members with [] -> None | ms -> Some ms) 76 81 |> finish)) 77 82 78 78 - let empty_registry = { name = "opamverse"; members = [] } 83 83 + let empty_registry = { name = "opamverse"; description = None; members = [] } 79 84 80 85 let load ~fs path = 81 86 let path_str = Fpath.to_string path in

+2

monopam/lib/verse_registry.mli

reviewed

··· 7 7 8 8 type member = { 9 9 handle : string; (** Tangled handle (e.g., "alice.bsky.social") *) 10 10 + name : string option; (** Display name (e.g., "Alice Smith") *) 10 11 monorepo : string; (** Git URL of the member's monorepo *) 11 12 monorepo_branch : string option; (** Optional branch for monorepo (from URL#branch) *) 12 13 opamrepo : string; (** Git URL of the member's opam overlay repository *) ··· 19 20 20 21 type t = { 21 22 name : string; (** Registry name *) 23 23 + description : string option; (** Registry description *) 22 24 members : member list; (** List of registered members *) 23 25 } 24 26 (** The parsed registry contents. *)

+17

sortal/.gitignore

reviewed

··· 1 1 + # OCaml build artifacts 2 2 + _build/ 3 3 + *.install 4 4 + *.merlin 5 5 + 6 6 + # Third-party sources (fetch locally with opam source) 7 7 + third_party/ 8 8 + 9 9 + # Editor and OS files 10 10 + .DS_Store 11 11 + *.swp 12 12 + *~ 13 13 + .vscode/ 14 14 + .idea/ 15 15 + 16 16 + # Opam local switch 17 17 + _opam/

+1

sortal/.ocamlformat

reviewed

··· 1 1 + version=0.28.1

+53

sortal/.tangled/workflows/build.yml

reviewed

··· 1 1 + when: 2 2 + - event: ["push", "pull_request"] 3 3 + branch: ["main"] 4 4 + 5 5 + engine: nixery 6 6 + 7 7 + dependencies: 8 8 + nixpkgs: 9 9 + - shell 10 10 + - stdenv 11 11 + - findutils 12 12 + - binutils 13 13 + - libunwind 14 14 + - ncurses 15 15 + - opam 16 16 + - git 17 17 + - gawk 18 18 + - gnupatch 19 19 + - gnum4 20 20 + - gnumake 21 21 + - gnutar 22 22 + - gnused 23 23 + - gnugrep 24 24 + - diffutils 25 25 + - gzip 26 26 + - bzip2 27 27 + - gcc 28 28 + - ocaml 29 29 + - pkg-config 30 30 + 31 31 + steps: 32 32 + - name: opam 33 33 + command: | 34 34 + opam init --disable-sandboxing -a -y 35 35 + - name: repo 36 36 + command: | 37 37 + opam repo add aoah https://tangled.org/anil.recoil.org/aoah-opam-repo.git 38 38 + - name: switch 39 39 + command: | 40 40 + opam install . --confirm-level=unsafe-yes --deps-only 41 41 + - name: build 42 42 + command: | 43 43 + opam exec -- dune build -p sortal 44 44 + - name: switch-test 45 45 + command: | 46 46 + opam install . --confirm-level=unsafe-yes --deps-only --with-test 47 47 + - name: test 48 48 + command: | 49 49 + opam exec -- dune runtest --verbose 50 50 + - name: doc 51 51 + command: | 52 52 + opam install -y odoc 53 53 + opam exec -- dune build @doc

+15

sortal/LICENSE.md

reviewed

··· 1 1 + ISC License 2 2 + 3 3 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org> 4 4 + 5 5 + Permission to use, copy, modify, and distribute this software for any 6 6 + purpose with or without fee is hereby granted, provided that the above 7 7 + copyright notice and this permission notice appear in all copies. 8 8 + 9 9 + THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 10 + WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 11 + MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 12 + ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 13 + WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 14 + ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 15 + OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

+170

sortal/README.md

reviewed

··· 1 1 + # Sortal - Contact Metadata Management Library 2 2 + 3 3 + Sortal is an OCaml library that provides a comprehensive system for managing 4 4 + contact metadata with temporal validity tracking. It stores data in 5 5 + XDG-compliant locations using the YAML format and optionally versions all changes 6 6 + with git. 7 7 + 8 8 + ## Features 9 9 + 10 10 + - **Temporal Support**: Track how contact information changes over time (emails, organizations, URLs) 11 11 + - **XDG-compliant storage**: Contact metadata stored in standard XDG data directories 12 12 + - **YAML format**: Human-readable YAML files with type-safe encoding/decoding using yamlt 13 13 + - **Rich metadata**: Support for multiple names, emails (typed), organizations, services (GitHub, social media), ORCID, URLs, and Atom feeds 14 14 + - **Git Versioning**: Optional automatic git commits for all changes with descriptive messages 15 15 + - **CLI Interface**: Full command-line interface for CRUD operations on contacts 16 16 + - **Simple API**: Easy-to-use functions for saving, loading, searching, and deleting contacts 17 17 + 18 18 + ## Metadata Fields 19 19 + 20 20 + Each contact can include: 21 21 + 22 22 + - `handle`: Unique identifier/username (required) 23 23 + - `names`: List of full names with primary name first (required) 24 24 + - `email`: Email address 25 25 + - `icon`: Avatar/icon URL 26 26 + - `thumbnail`: Path to a local thumbnail image file 27 27 + - `github`: GitHub username 28 28 + - `twitter`: Twitter/X username 29 29 + - `bluesky`: Bluesky handle 30 30 + - `mastodon`: Mastodon handle (with instance) 31 31 + - `orcid`: ORCID identifier 32 32 + - `url`: Personal/professional website 33 33 + - `atom_feeds`: List of Atom/RSS feed URLs 34 34 + 35 35 + ## Storage 36 36 + 37 37 + Contact data is stored as individual YAML files in the XDG data directory: 38 38 + 39 39 + - Default location: `$HOME/.local/share/sortal/` 40 40 + - Override with: `SORTAL_DATA_DIR` or `XDG_DATA_HOME` 41 41 + - Each contact stored as: `{handle}.yaml` 42 42 + - Format: Human-readable YAML with temporal data support 43 43 + 44 44 + ## Usage Example 45 45 + 46 46 + ### Basic Usage 47 47 + 48 48 + ```ocaml 49 49 + (* Create a contact store from filesystem *) 50 50 + let store = Sortal.create env#fs "myapp" in 51 51 + 52 52 + (* Or create from an existing XDG context (recommended when using eiocmd) *) 53 53 + let store = Sortal.create_from_xdg xdg in 54 54 + 55 55 + (* Create a new contact *) 56 56 + let contact = Sortal.Contact.make 57 57 + ~handle:"avsm" 58 58 + ~names:["Anil Madhavapeddy"] 59 59 + ~email:"anil@recoil.org" 60 60 + ~github:"avsm" 61 61 + ~orcid:"0000-0002-7890-1234" 62 62 + () in 63 63 + 64 64 + (* Save the contact *) 65 65 + Sortal.save store contact; 66 66 + 67 67 + (* Lookup by handle *) 68 68 + match Sortal.lookup store "avsm" with 69 69 + | Some c -> Printf.printf "Found: %s\n" (Sortal.Contact.name c) 70 70 + | None -> Printf.printf "Not found\n" 71 71 + 72 72 + (* Search for contacts by name *) 73 73 + let matches = Sortal.search_all store "Anil" in 74 74 + List.iter (fun c -> 75 75 + Printf.printf "%s: %s\n" 76 76 + (Sortal.Contact.handle c) 77 77 + (Sortal.Contact.name c) 78 78 + ) matches 79 79 + 80 80 + (* List all contacts *) 81 81 + let all_contacts = Sortal.list store in 82 82 + List.iter (fun c -> 83 83 + Printf.printf "%s: %s\n" 84 84 + (Sortal.Contact.handle c) 85 85 + (Sortal.Contact.name c) 86 86 + ) all_contacts 87 87 + ``` 88 88 + 89 89 + ## CLI Tool 90 90 + 91 91 + The library includes a standalone `sortal` CLI tool with full CRUD functionality: 92 92 + 93 93 + ```bash 94 94 + # Initialize git versioning (optional) 95 95 + sortal git-init 96 96 + 97 97 + # List all contacts 98 98 + sortal list 99 99 + 100 100 + # Show details for a specific contact 101 101 + sortal show avsm 102 102 + 103 103 + # Search for contacts 104 104 + sortal search "Anil" 105 105 + 106 106 + # Show database statistics 107 107 + sortal stats 108 108 + 109 109 + # Add a new contact 110 110 + sortal add jsmith --name "John Smith" --email "john@example.com" --kind person 111 111 + 112 112 + # Add metadata to contacts 113 113 + sortal add-org jsmith "Acme Corp" --title "Software Engineer" --from 2020-01 114 114 + sortal add-service jsmith "https://github.com/jsmith" --kind github --handle jsmith 115 115 + sortal add-email jsmith "john.work@example.com" --type work --from 2020-01 116 116 + sortal add-url jsmith "https://jsmith.example.com" --label "Personal website" 117 117 + 118 118 + # Remove metadata 119 119 + sortal remove-email jsmith "old@example.com" 120 120 + sortal remove-service jsmith "https://old-service.com" 121 121 + sortal remove-org jsmith "Old Company" 122 122 + sortal remove-url jsmith "https://old-url.com" 123 123 + 124 124 + # Delete a contact 125 125 + sortal delete jsmith 126 126 + 127 127 + # Synchronize data (convert thumbnails to PNG) 128 128 + sortal sync 129 129 + ``` 130 130 + 131 131 + ## Git Versioning 132 132 + 133 133 + Sortal includes a `Sortal_git_store` module that provides automatic git commits 134 134 + for all contact modifications: 135 135 + 136 136 + ```ocaml 137 137 + open Sortal 138 138 + 139 139 + (* Create a git-backed store *) 140 140 + let git_store = Git_store.create store env in 141 141 + 142 142 + (* Initialize git repository *) 143 143 + let () = match Git_store.init git_store with 144 144 + | Ok () -> Logs.app (fun m -> m "Git initialized") 145 145 + | Error msg -> Logs.err (fun m -> m "Error: %s" msg) 146 146 + in 147 147 + 148 148 + (* Save a contact - automatically commits with descriptive message *) 149 149 + let contact = Contact.make ~handle:"jsmith" ~names:["John Smith"] () in 150 150 + match Git_store.save git_store contact with 151 151 + | Ok () -> Logs.app (fun m -> m "Contact saved and committed") 152 152 + | Error msg -> Logs.err (fun m -> m "Error: %s" msg) 153 153 + ``` 154 154 + 155 155 + **Commit Messages**: All git store operations create descriptive commit messages: 156 156 + - `save`: "Add contact @handle (Name)" or "Update contact @handle (Name)" 157 157 + - `delete`: "Delete contact @handle (Name)" 158 158 + - `add_email`: "Update @handle: add email address@example.com" 159 159 + - `remove_email`: "Update @handle: remove email address@example.com" 160 160 + - `add_service`: "Update @handle: add service Kind (url)" 161 161 + - `add_organization`: "Update @handle: add organization Org Name" 162 162 + - And similar for all other operations 163 163 + 164 164 + ## Project Status 165 165 + 166 166 + Still very much just used by Anil Madhavapeddy. You're welcome to try it, but let me know... 167 167 + 168 168 + ## License 169 169 + 170 170 + ISC License - see [LICENSE.md](LICENSE.md) for details.

+15

sortal/bin/dune

reviewed

··· 1 1 + (executable 2 2 + (name sortal_cli) 3 3 + (public_name sortal) 4 4 + (libraries 5 5 + sortal 6 6 + sortal.schema 7 7 + eio 8 8 + eio_main 9 9 + xdge 10 10 + cmdliner 11 11 + logs 12 12 + logs.cli 13 13 + logs.fmt 14 14 + fmt 15 15 + fmt.tty))

+249

sortal/bin/sortal_cli.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + open Cmdliner 7 7 + 8 8 + (* Main command *) 9 9 + let () = 10 10 + Random.self_init (); 11 11 + Fmt.set_style_renderer Fmt.stdout `Ansi_tty; 12 12 + Fmt.set_style_renderer Fmt.stderr `Ansi_tty; 13 13 + 14 14 + Eio_main.run @@ fun env -> 15 15 + 16 16 + let xdg_term = Xdge.Cmd.term "sortal" env#fs ~dirs:[`Data] () in 17 17 + 18 18 + let info = Cmd.info "sortal" 19 19 + ~version:"0.1.0" 20 20 + ~doc:"Contact metadata management" 21 21 + ~man:[ 22 22 + `S Manpage.s_description; 23 23 + `P "Sortal manages contact metadata including URLs, emails, ORCID identifiers, \ 24 24 + and social media handles. Data is stored in XDG-compliant locations."; 25 25 + `S Manpage.s_commands; 26 26 + `P "Use $(b,sortal COMMAND --help) for detailed help on each command."; 27 27 + ] 28 28 + in 29 29 + 30 30 + let make_term info main_term = 31 31 + let term = 32 32 + let open Term.Syntax in 33 33 + let+ (xdg, _) = xdg_term 34 34 + and+ main = main_term 35 35 + and+ log_level = Logs_cli.level () in 36 36 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 37 37 + Logs.set_level log_level; 38 38 + main xdg 39 39 + in 40 40 + Cmd.v info term 41 41 + in 42 42 + 43 43 + let list_cmd = make_term Sortal.Cmd.list_info (Term.const Sortal.Cmd.list_cmd) in 44 44 + let show_cmd = make_term Sortal.Cmd.show_info Term.(const Sortal.Cmd.show_cmd $ Sortal.Cmd.handle_arg) in 45 45 + let search_cmd = make_term Sortal.Cmd.search_info Term.(const Sortal.Cmd.search_cmd $ Sortal.Cmd.query_arg) in 46 46 + let stats_cmd = make_term Sortal.Cmd.stats_info Term.(const (fun () -> Sortal.Cmd.stats_cmd ()) $ const ()) in 47 47 + let sync_cmd = make_term Sortal.Cmd.sync_info Term.(const (fun () -> Sortal.Cmd.sync_cmd ()) $ const ()) in 48 48 + 49 49 + (* Git init command needs special handling to pass env *) 50 50 + let git_init_cmd = 51 51 + let term = 52 52 + let open Term.Syntax in 53 53 + let+ (xdg, _) = xdg_term 54 54 + and+ log_level = Logs_cli.level () in 55 55 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 56 56 + Logs.set_level log_level; 57 57 + Sortal.Cmd.git_init_cmd xdg env 58 58 + in 59 59 + Cmd.v Sortal.Cmd.git_init_info term 60 60 + in 61 61 + 62 62 + (* Contact management commands - need special handling for env *) 63 63 + let add_cmd = 64 64 + let term = 65 65 + let open Term.Syntax in 66 66 + let+ (xdg, _) = xdg_term 67 67 + and+ handle = Sortal.Cmd.add_handle_arg 68 68 + and+ names = Sortal.Cmd.add_names_arg 69 69 + and+ kind = Sortal.Cmd.add_kind_arg 70 70 + and+ email = Sortal.Cmd.add_email_arg 71 71 + and+ github = Sortal.Cmd.add_github_arg 72 72 + and+ url = Sortal.Cmd.add_url_arg 73 73 + and+ orcid = Sortal.Cmd.add_orcid_arg 74 74 + and+ log_level = Logs_cli.level () in 75 75 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 76 76 + Logs.set_level log_level; 77 77 + Sortal.Cmd.add_cmd handle names kind email github url orcid xdg env 78 78 + in 79 79 + Cmd.v Sortal.Cmd.add_info term 80 80 + in 81 81 + 82 82 + let delete_cmd = 83 83 + let term = 84 84 + let open Term.Syntax in 85 85 + let+ (xdg, _) = xdg_term 86 86 + and+ handle = Sortal.Cmd.handle_arg 87 87 + and+ log_level = Logs_cli.level () in 88 88 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 89 89 + Logs.set_level log_level; 90 90 + Sortal.Cmd.delete_cmd handle xdg env 91 91 + in 92 92 + Cmd.v Sortal.Cmd.delete_info term 93 93 + in 94 94 + 95 95 + (* Entry management commands *) 96 96 + let add_email_cmd = 97 97 + let term = 98 98 + let open Term.Syntax in 99 99 + let+ (xdg, _) = xdg_term 100 100 + and+ handle = Sortal.Cmd.handle_arg 101 101 + and+ address = Sortal.Cmd.email_address_arg 102 102 + and+ type_ = Sortal.Cmd.email_type_arg 103 103 + and+ from = Sortal.Cmd.date_arg "from" 104 104 + and+ until = Sortal.Cmd.date_arg "until" 105 105 + and+ note = Sortal.Cmd.note_arg 106 106 + and+ log_level = Logs_cli.level () in 107 107 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 108 108 + Logs.set_level log_level; 109 109 + Sortal.Cmd.add_email_cmd handle address type_ from until note xdg env 110 110 + in 111 111 + Cmd.v Sortal.Cmd.add_email_info term 112 112 + in 113 113 + 114 114 + let remove_email_cmd = 115 115 + let term = 116 116 + let open Term.Syntax in 117 117 + let+ (xdg, _) = xdg_term 118 118 + and+ handle = Sortal.Cmd.handle_arg 119 119 + and+ address = Sortal.Cmd.email_address_arg 120 120 + and+ log_level = Logs_cli.level () in 121 121 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 122 122 + Logs.set_level log_level; 123 123 + Sortal.Cmd.remove_email_cmd handle address xdg env 124 124 + in 125 125 + Cmd.v Sortal.Cmd.remove_email_info term 126 126 + in 127 127 + 128 128 + let add_service_cmd = 129 129 + let term = 130 130 + let open Term.Syntax in 131 131 + let+ (xdg, _) = xdg_term 132 132 + and+ handle = Sortal.Cmd.handle_arg 133 133 + and+ url = Sortal.Cmd.service_url_arg 134 134 + and+ kind = Sortal.Cmd.service_kind_arg 135 135 + and+ service_handle = Sortal.Cmd.service_handle_arg 136 136 + and+ label = Sortal.Cmd.label_arg 137 137 + and+ log_level = Logs_cli.level () in 138 138 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 139 139 + Logs.set_level log_level; 140 140 + Sortal.Cmd.add_service_cmd handle url kind service_handle label xdg env 141 141 + in 142 142 + Cmd.v Sortal.Cmd.add_service_info term 143 143 + in 144 144 + 145 145 + let remove_service_cmd = 146 146 + let term = 147 147 + let open Term.Syntax in 148 148 + let+ (xdg, _) = xdg_term 149 149 + and+ handle = Sortal.Cmd.handle_arg 150 150 + and+ url = Sortal.Cmd.service_url_arg 151 151 + and+ log_level = Logs_cli.level () in 152 152 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 153 153 + Logs.set_level log_level; 154 154 + Sortal.Cmd.remove_service_cmd handle url xdg env 155 155 + in 156 156 + Cmd.v Sortal.Cmd.remove_service_info term 157 157 + in 158 158 + 159 159 + let add_org_cmd = 160 160 + let term = 161 161 + let open Term.Syntax in 162 162 + let+ (xdg, _) = xdg_term 163 163 + and+ handle = Sortal.Cmd.handle_arg 164 164 + and+ org_name = Sortal.Cmd.org_name_arg 165 165 + and+ title = Sortal.Cmd.org_title_arg 166 166 + and+ department = Sortal.Cmd.org_department_arg 167 167 + and+ from = Sortal.Cmd.date_arg "from" 168 168 + and+ until = Sortal.Cmd.date_arg "until" 169 169 + and+ org_email = Sortal.Cmd.org_email_arg 170 170 + and+ org_url = Sortal.Cmd.org_url_arg 171 171 + and+ log_level = Logs_cli.level () in 172 172 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 173 173 + Logs.set_level log_level; 174 174 + Sortal.Cmd.add_org_cmd handle org_name title department from until org_email org_url xdg env 175 175 + in 176 176 + Cmd.v Sortal.Cmd.add_org_info term 177 177 + in 178 178 + 179 179 + let remove_org_cmd = 180 180 + let term = 181 181 + let open Term.Syntax in 182 182 + let+ (xdg, _) = xdg_term 183 183 + and+ handle = Sortal.Cmd.handle_arg 184 184 + and+ org_name = Sortal.Cmd.org_name_arg 185 185 + and+ log_level = Logs_cli.level () in 186 186 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 187 187 + Logs.set_level log_level; 188 188 + Sortal.Cmd.remove_org_cmd handle org_name xdg env 189 189 + in 190 190 + Cmd.v Sortal.Cmd.remove_org_info term 191 191 + in 192 192 + 193 193 + let add_url_cmd = 194 194 + let term = 195 195 + let open Term.Syntax in 196 196 + let+ (xdg, _) = xdg_term 197 197 + and+ handle = Sortal.Cmd.handle_arg 198 198 + and+ url = Sortal.Cmd.url_value_arg 199 199 + and+ label = Sortal.Cmd.label_arg 200 200 + and+ log_level = Logs_cli.level () in 201 201 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 202 202 + Logs.set_level log_level; 203 203 + Sortal.Cmd.add_url_cmd handle url label xdg env 204 204 + in 205 205 + Cmd.v Sortal.Cmd.add_url_info term 206 206 + in 207 207 + 208 208 + let remove_url_cmd = 209 209 + let term = 210 210 + let open Term.Syntax in 211 211 + let+ (xdg, _) = xdg_term 212 212 + and+ handle = Sortal.Cmd.handle_arg 213 213 + and+ url = Sortal.Cmd.url_value_arg 214 214 + and+ log_level = Logs_cli.level () in 215 215 + Logs.set_reporter (Logs_fmt.reporter ~app:Fmt.stdout ~dst:Fmt.stderr ()); 216 216 + Logs.set_level log_level; 217 217 + Sortal.Cmd.remove_url_cmd handle url xdg env 218 218 + in 219 219 + Cmd.v Sortal.Cmd.remove_url_info term 220 220 + in 221 221 + 222 222 + let default_term = 223 223 + let open Term.Syntax in 224 224 + let+ _ = xdg_term 225 225 + and+ _ = Logs_cli.level () in 226 226 + `Help (`Pager, None) 227 227 + in 228 228 + let default_term = Term.ret default_term in 229 229 + 230 230 + let cmd = Cmd.group info ~default:default_term [ 231 231 + list_cmd; 232 232 + show_cmd; 233 233 + search_cmd; 234 234 + stats_cmd; 235 235 + sync_cmd; 236 236 + git_init_cmd; 237 237 + add_cmd; 238 238 + delete_cmd; 239 239 + add_email_cmd; 240 240 + remove_email_cmd; 241 241 + add_service_cmd; 242 242 + remove_service_cmd; 243 243 + add_org_cmd; 244 244 + remove_org_cmd; 245 245 + add_url_cmd; 246 246 + remove_url_cmd; 247 247 + ] in 248 248 + 249 249 + exit (Cmd.eval' cmd)

+5

sortal/dune

reviewed

··· 1 1 + ; Root dune file 2 2 + 3 3 + ; Ignore third_party directory (for fetched dependency sources) 4 4 + 5 5 + (data_only_dirs third_party)

+37

sortal/dune-project

reviewed

··· 1 1 + (lang dune 3.21) 2 2 + 3 3 + (name sortal) 4 4 + 5 5 + (generate_opam_files true) 6 6 + 7 7 + (license ISC) 8 8 + (authors "Anil Madhavapeddy") 9 9 + (homepage "https://tangled.org/@anil.recoil.org/sortal") 10 10 + (maintainers "Anil Madhavapeddy <anil@recoil.org>") 11 11 + (maintenance_intent "(latest)") 12 12 + (source (tangled anil.recoil.org/sortal)) 13 13 + 14 14 + (package 15 15 + (name sortal) 16 16 + (synopsis "Contact metadata management with XDG storage and versioned schemas") 17 17 + (description 18 18 + "Sortal provides contact metadata management with versioned schemas, 19 19 + XDG-compliant storage, git versioning, and CLI tools. 20 20 + 21 21 + The library is split into two components: 22 22 + - sortal.schema: Versioned data types with minimal dependencies 23 23 + - sortal: Core library with storage, git integration, and CLI support") 24 24 + (depends 25 25 + (ocaml (>= 5.1.0)) 26 26 + eio 27 27 + eio_main 28 28 + xdge 29 29 + jsont 30 30 + ptime 31 31 + yamlt 32 32 + bytesrw 33 33 + fmt 34 34 + cmdliner 35 35 + logs 36 36 + (odoc :with-doc) 37 37 + (alcotest (and :with-test (>= 1.7.0)))))

+17

sortal/lib/core/dune

reviewed

··· 1 1 + (library 2 2 + (public_name sortal) 3 3 + (name sortal) 4 4 + (libraries 5 5 + sortal.schema 6 6 + eio 7 7 + eio.core 8 8 + eio_main 9 9 + xdge 10 10 + jsont 11 11 + jsont.bytesrw 12 12 + yamlt 13 13 + bytesrw 14 14 + fmt 15 15 + cmdliner 16 16 + logs 17 17 + str))

+26

sortal/lib/core/sortal.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + module Temporal = Sortal_schema.Temporal 7 7 + module Feed = Sortal_schema.Feed 8 8 + module Contact = Sortal_schema.Contact 9 9 + module Store = Sortal_store 10 10 + module Git_store = Sortal_git_store 11 11 + module Cmd = Sortal_cmd 12 12 + 13 13 + type t = Store.t 14 14 + 15 15 + let create = Store.create 16 16 + let create_from_xdg = Store.create_from_xdg 17 17 + let save = Store.save 18 18 + let lookup = Store.lookup 19 19 + let delete = Store.delete 20 20 + let list = Store.list 21 21 + let thumbnail_path = Store.thumbnail_path 22 22 + let find_by_name = Store.find_by_name 23 23 + let find_by_name_opt = Store.find_by_name_opt 24 24 + let search_all = Store.search_all 25 25 + let handle_of_name = Store.handle_of_name 26 26 + let pp = Store.pp

+119

sortal/lib/core/sortal.mli

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Sortal - Username to metadata mapping with XDG storage 7 7 + 8 8 + This library provides a system for mapping usernames to various metadata 9 9 + including URLs, emails, ORCID identifiers, and social media handles. 10 10 + It uses XDG Base Directory Specification for storage locations and 11 11 + provides temporal support for time-bounded information like historical 12 12 + email addresses and employment records. 13 13 + 14 14 + {b Storage:} 15 15 + 16 16 + Contact metadata is stored as YAML files in the XDG data directory, 17 17 + with one file per contact using the handle as the filename. The YAML 18 18 + format uses the same Jsont codec definitions as JSON for seamless 19 19 + compatibility. 20 20 + 21 21 + {b Typical Usage:} 22 22 + 23 23 + {[ 24 24 + let store = Sortal.create env#fs "myapp" in 25 25 + let contact = Sortal.Contact.make 26 26 + ~handle:"avsm" 27 27 + ~names:["Anil Madhavapeddy"] 28 28 + ~email:"anil@recoil.org" 29 29 + ~github:"avsm" 30 30 + ~orcid:"0000-0002-7890-1234" 31 31 + () in 32 32 + Sortal.save store contact; 33 33 + 34 34 + match Sortal.lookup store "avsm" with 35 35 + | Some c -> Printf.printf "Found: %s\n" (Sortal.Contact.name c) 36 36 + | None -> Printf.printf "Not found\n" 37 37 + ]} 38 38 + *) 39 39 + 40 40 + (** {1 Schema Modules} 41 41 + 42 42 + These modules define the data types and serialization formats. 43 43 + They are re-exported from {!Sortal_schema} for convenience. 44 44 + For version-specific access, use [Sortal_schema.V1.*]. *) 45 45 + 46 46 + (** Temporal validity support for time-bounded contact fields. *) 47 47 + module Temporal = Sortal_schema.Temporal 48 48 + 49 49 + (** Feed subscription metadata. *) 50 50 + module Feed = Sortal_schema.Feed 51 51 + 52 52 + (** Contact metadata with temporal support. *) 53 53 + module Contact = Sortal_schema.Contact 54 54 + 55 55 + (** {1 Core Modules} *) 56 56 + 57 57 + (** Contact store with XDG-compliant storage. *) 58 58 + module Store = Sortal_store 59 59 + 60 60 + (** Git-backed contact store with automatic version control. *) 61 61 + module Git_store = Sortal_git_store 62 62 + 63 63 + (** Cmdliner integration for CLI applications. *) 64 64 + module Cmd = Sortal_cmd 65 65 + 66 66 + (** {1 Convenience Re-exports} 67 67 + 68 68 + These are re-exported from {!Store} for easier top-level access. *) 69 69 + 70 70 + (** The contact store type. *) 71 71 + type t = Store.t 72 72 + 73 73 + (** [create fs app_name] creates a new contact store. 74 74 + See {!Store.create} for details. *) 75 75 + val create : Eio.Fs.dir_ty Eio.Path.t -> string -> t 76 76 + 77 77 + (** [create_from_xdg xdg] creates a contact store from an XDG context. 78 78 + See {!Store.create_from_xdg} for details. *) 79 79 + val create_from_xdg : Xdge.t -> t 80 80 + 81 81 + (** [save t contact] saves a contact to the store. 82 82 + See {!Store.save} for details. *) 83 83 + val save : t -> Contact.t -> unit 84 84 + 85 85 + (** [lookup t handle] retrieves a contact by handle. 86 86 + See {!Store.lookup} for details. *) 87 87 + val lookup : t -> string -> Contact.t option 88 88 + 89 89 + (** [delete t handle] removes a contact from the store. 90 90 + See {!Store.delete} for details. *) 91 91 + val delete : t -> string -> unit 92 92 + 93 93 + (** [list t] returns all contacts in the store. 94 94 + See {!Store.list} for details. *) 95 95 + val list : t -> Contact.t list 96 96 + 97 97 + (** [thumbnail_path t contact] returns the path to a contact's thumbnail. 98 98 + See {!Store.thumbnail_path} for details. *) 99 99 + val thumbnail_path : t -> Contact.t -> Eio.Fs.dir_ty Eio.Path.t option 100 100 + 101 101 + (** [find_by_name t name] searches for contacts by name. 102 102 + See {!Store.find_by_name} for details. *) 103 103 + val find_by_name : t -> string -> Contact.t 104 104 + 105 105 + (** [find_by_name_opt t name] searches for contacts by name. 106 106 + See {!Store.find_by_name_opt} for details. *) 107 107 + val find_by_name_opt : t -> string -> Contact.t option 108 108 + 109 109 + (** [search_all t query] searches for contacts matching a query. 110 110 + See {!Store.search_all} for details. *) 111 111 + val search_all : t -> string -> Contact.t list 112 112 + 113 113 + (** [handle_of_name name] generates a handle from a full name. 114 114 + See {!Store.handle_of_name} for details. *) 115 115 + val handle_of_name : string -> string 116 116 + 117 117 + (** [pp ppf t] pretty prints the contact store. 118 118 + See {!Store.pp} for details. *) 119 119 + val pp : Format.formatter -> t -> unit

+464

sortal/lib/core/sortal_cmd.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + open Cmdliner 7 7 + 8 8 + module Contact = Sortal_schema.Contact 9 9 + module Temporal = Sortal_schema.Temporal 10 10 + 11 11 + let is_png path = 12 12 + let ext = String.lowercase_ascii (Filename.extension path) in 13 13 + ext = ".png" 14 14 + 15 15 + let convert_to_png src_path = 16 16 + let base = Filename.remove_extension src_path in 17 17 + let dst_path = base ^ ".png" in 18 18 + let cmd = Printf.sprintf "magick %s %s" (Filename.quote src_path) (Filename.quote dst_path) in 19 19 + let ret = Unix.system cmd in 20 20 + match ret with 21 21 + | Unix.WEXITED 0 -> Ok dst_path 22 22 + | Unix.WEXITED n -> Error (Printf.sprintf "magick exited with code %d" n) 23 23 + | Unix.WSIGNALED n -> Error (Printf.sprintf "magick killed by signal %d" n) 24 24 + | Unix.WSTOPPED n -> Error (Printf.sprintf "magick stopped by signal %d" n) 25 25 + 26 26 + let list_cmd xdg = 27 27 + let store = Sortal_store.create_from_xdg xdg in 28 28 + let contacts = Sortal_store.list store in 29 29 + let sorted = List.sort Contact.compare contacts in 30 30 + Printf.printf "Total contacts: %d\n" (List.length sorted); 31 31 + List.iter (fun c -> 32 32 + Printf.printf "@%s: %s\n" (Contact.handle c) (Contact.name c) 33 33 + ) sorted; 34 34 + 0 35 35 + 36 36 + let show_cmd handle xdg = 37 37 + let store = Sortal_store.create_from_xdg xdg in 38 38 + match Sortal_store.lookup store handle with 39 39 + | Some c -> 40 40 + (* Use the pretty printer for rich temporal display *) 41 41 + Fmt.pr "%a@." Contact.pp c; 42 42 + 0 43 43 + | None -> Logs.err (fun m -> m "Contact not found: %s" handle); 1 44 44 + 45 45 + let search_cmd query xdg = 46 46 + let store = Sortal_store.create_from_xdg xdg in 47 47 + match Sortal_store.search_all store query with 48 48 + | [] -> 49 49 + Logs.warn (fun m -> m "No contacts found matching: %s" query); 50 50 + 1 51 51 + | matches -> 52 52 + Logs.app (fun m -> m "Found %d match%s:" 53 53 + (List.length matches) 54 54 + (if List.length matches = 1 then "" else "es")); 55 55 + List.iter (fun c -> 56 56 + Logs.app (fun m -> m "@%s: %s" (Contact.handle c) (Contact.name c)); 57 57 + Option.iter (fun e -> Logs.app (fun m -> m " Email: %s" e)) (Contact.current_email c); 58 58 + Option.iter (fun u -> Logs.app (fun m -> m " URL: %s" u)) (Contact.best_url c) 59 59 + ) matches; 60 60 + 0 61 61 + 62 62 + let stats_cmd () xdg = 63 63 + let store = Sortal_store.create_from_xdg xdg in 64 64 + let contacts = Sortal_store.list store in 65 65 + let total = List.length contacts in 66 66 + let count pred = List.filter pred contacts |> List.length in 67 67 + let with_email = count (fun c -> Contact.emails c <> []) in 68 68 + let with_org = count (fun c -> Contact.organizations c <> []) in 69 69 + let with_url = count (fun c -> Contact.urls c <> []) in 70 70 + let with_service = count (fun c -> Contact.services c <> []) in 71 71 + let with_orcid = count (fun c -> Option.is_some (Contact.orcid c)) in 72 72 + let with_feeds = count (fun c -> Option.is_some (Contact.feeds c)) in 73 73 + let total_feeds = 74 74 + List.fold_left (fun acc c -> 75 75 + acc + Option.fold ~none:0 ~some:List.length (Contact.feeds c) 76 76 + ) 0 contacts 77 77 + in 78 78 + let total_services = 79 79 + List.fold_left (fun acc c -> 80 80 + acc + List.length (Contact.services c) 81 81 + ) 0 contacts 82 82 + in 83 83 + let pct n = float_of_int n /. float_of_int total *. 100. in 84 84 + Logs.app (fun m -> m "Contact Database Statistics:"); 85 85 + Logs.app (fun m -> m " Total contacts: %d" total); 86 86 + Logs.app (fun m -> m " With email: %d (%.1f%%)" with_email (pct with_email)); 87 87 + Logs.app (fun m -> m " With organization: %d (%.1f%%)" with_org (pct with_org)); 88 88 + Logs.app (fun m -> m " With services: %d (%.1f%%), total %d services" with_service (pct with_service) total_services); 89 89 + Logs.app (fun m -> m " With ORCID: %d (%.1f%%)" with_orcid (pct with_orcid)); 90 90 + Logs.app (fun m -> m " With URL: %d (%.1f%%)" with_url (pct with_url)); 91 91 + Logs.app (fun m -> m " With feeds: %d (%.1f%%), total %d feeds" with_feeds (pct with_feeds) total_feeds); 92 92 + 0 93 93 + 94 94 + let sync_cmd () xdg = 95 95 + let store = Sortal_store.create_from_xdg xdg in 96 96 + let contacts = Sortal_store.list store in 97 97 + Logs.app (fun m -> m "Syncing %d contacts..." (List.length contacts)); 98 98 + let converted = ref 0 in 99 99 + let skipped = ref 0 in 100 100 + let no_thumbnail = ref 0 in 101 101 + let errors = ref 0 in 102 102 + List.iter (fun contact -> 103 103 + let handle = Contact.handle contact in 104 104 + match Sortal_store.thumbnail_path store contact with 105 105 + | None -> 106 106 + Logs.info (fun m -> m "@%s: no thumbnail" handle); 107 107 + incr no_thumbnail 108 108 + | Some eio_path -> 109 109 + let path = Eio.Path.native_exn eio_path in 110 110 + if is_png path then begin 111 111 + Logs.info (fun m -> m "@%s: already PNG (%s)" handle (Filename.basename path)); 112 112 + incr skipped 113 113 + end else begin 114 114 + Logs.app (fun m -> m "@%s: converting %s to PNG..." handle (Filename.basename path)); 115 115 + match convert_to_png path with 116 116 + | Ok new_path -> 117 117 + Logs.app (fun m -> m " Converted: %s -> %s" 118 118 + (Filename.basename path) (Filename.basename new_path)); 119 119 + incr converted 120 120 + | Error msg -> 121 121 + Logs.err (fun m -> m " Failed to convert %s: %s" path msg); 122 122 + incr errors 123 123 + end 124 124 + ) contacts; 125 125 + Logs.app (fun m -> m "Sync complete:"); 126 126 + Logs.app (fun m -> m " %d contacts without thumbnails" !no_thumbnail); 127 127 + Logs.app (fun m -> m " %d already PNG (skipped)" !skipped); 128 128 + Logs.app (fun m -> m " %d converted to PNG" !converted); 129 129 + Logs.app (fun m -> m " %d errors" !errors); 130 130 + if !errors > 0 then 1 else 0 131 131 + 132 132 + (* Initialize git repository *) 133 133 + let git_init_cmd xdg env = 134 134 + let store = Sortal_store.create_from_xdg xdg in 135 135 + let git_store = Sortal_git_store.create store env in 136 136 + match Sortal_git_store.init git_store with 137 137 + | Ok () -> 138 138 + if Sortal_git_store.is_initialized git_store then 139 139 + Logs.app (fun m -> m "Git repository initialized in data directory") 140 140 + else 141 141 + Logs.app (fun m -> m "Git repository already initialized"); 142 142 + 0 143 143 + | Error msg -> 144 144 + Logs.err (fun m -> m "Failed to initialize git repository: %s" msg); 145 145 + 1 146 146 + 147 147 + (* Add a new contact *) 148 148 + let add_cmd handle names kind email github url orcid xdg env = 149 149 + let store = Sortal_store.create_from_xdg xdg in 150 150 + let git_store = Sortal_git_store.create store env in 151 151 + (* Check if contact already exists *) 152 152 + match Sortal_store.lookup store handle with 153 153 + | Some _ -> 154 154 + Logs.err (fun m -> m "Contact @%s already exists" handle); 155 155 + 1 156 156 + | None -> 157 157 + let emails = match email with 158 158 + | Some e -> [Contact.make_email e] 159 159 + | None -> [] 160 160 + in 161 161 + let services = match github with 162 162 + | Some gh -> [Contact.make_service ~kind:Contact.Github ~handle:gh (Printf.sprintf "https://github.com/%s" gh)] 163 163 + | None -> [] 164 164 + in 165 165 + let urls = match url with 166 166 + | Some u -> [Contact.make_url u] 167 167 + | None -> [] 168 168 + in 169 169 + let contact = Contact.make 170 170 + ~handle 171 171 + ~names 172 172 + ?kind 173 173 + ~emails 174 174 + ~services 175 175 + ~urls 176 176 + ?orcid 177 177 + () 178 178 + in 179 179 + match Sortal_git_store.save git_store contact with 180 180 + | Ok () -> 181 181 + Logs.app (fun m -> m "Created contact @%s: %s" handle (Contact.name contact)); 182 182 + 0 183 183 + | Error msg -> 184 184 + Logs.err (fun m -> m "Failed to save contact: %s" msg); 185 185 + 1 186 186 + 187 187 + (* Delete a contact *) 188 188 + let delete_cmd handle xdg env = 189 189 + let store = Sortal_store.create_from_xdg xdg in 190 190 + let git_store = Sortal_git_store.create store env in 191 191 + match Sortal_git_store.delete git_store handle with 192 192 + | Ok () -> 193 193 + Logs.app (fun m -> m "Deleted contact @%s" handle); 194 194 + 0 195 195 + | Error msg -> 196 196 + Logs.err (fun m -> m "%s" msg); 197 197 + 1 198 198 + 199 199 + (* Convert string option to Ptime.date option *) 200 200 + let parse_date_opt (s_opt : string option) : Sortal_schema.Temporal.date option = 201 201 + match s_opt with 202 202 + | None -> None 203 203 + | Some s -> 204 204 + match Sortal_schema.Temporal.parse_date_string s with 205 205 + | Some d -> Some d 206 206 + | None -> 207 207 + Logs.warn (fun m -> m "Invalid date format: %s (using ISO 8601: YYYY, YYYY-MM, or YYYY-MM-DD)" s); 208 208 + None 209 209 + 210 210 + (* Add email to existing contact *) 211 211 + let add_email_cmd handle address type_ from until note xdg env = 212 212 + let store = Sortal_store.create_from_xdg xdg in 213 213 + let git_store = Sortal_git_store.create store env in 214 214 + let from = parse_date_opt from in 215 215 + let until = parse_date_opt until in 216 216 + let email = Contact.make_email ?type_ ?from ?until ?note address in 217 217 + match Sortal_git_store.add_email git_store handle email with 218 218 + | Ok () -> 219 219 + Logs.app (fun m -> m "Added email %s to @%s" address handle); 220 220 + 0 221 221 + | Error msg -> 222 222 + Logs.err (fun m -> m "%s" msg); 223 223 + 1 224 224 + 225 225 + (* Remove email from contact *) 226 226 + let remove_email_cmd handle address xdg env = 227 227 + let store = Sortal_store.create_from_xdg xdg in 228 228 + let git_store = Sortal_git_store.create store env in 229 229 + match Sortal_git_store.remove_email git_store handle address with 230 230 + | Ok () -> 231 231 + Logs.app (fun m -> m "Removed email %s from @%s" address handle); 232 232 + 0 233 233 + | Error msg -> 234 234 + Logs.err (fun m -> m "%s" msg); 235 235 + 1 236 236 + 237 237 + (* Add service to existing contact *) 238 238 + let add_service_cmd handle url kind service_handle label xdg env = 239 239 + let store = Sortal_store.create_from_xdg xdg in 240 240 + let git_store = Sortal_git_store.create store env in 241 241 + let service = Contact.make_service ?kind ?handle:service_handle ?label url in 242 242 + match Sortal_git_store.add_service git_store handle service with 243 243 + | Ok () -> 244 244 + Logs.app (fun m -> m "Added service %s to @%s" url handle); 245 245 + 0 246 246 + | Error msg -> 247 247 + Logs.err (fun m -> m "%s" msg); 248 248 + 1 249 249 + 250 250 + (* Remove service from contact *) 251 251 + let remove_service_cmd handle url xdg env = 252 252 + let store = Sortal_store.create_from_xdg xdg in 253 253 + let git_store = Sortal_git_store.create store env in 254 254 + match Sortal_git_store.remove_service git_store handle url with 255 255 + | Ok () -> 256 256 + Logs.app (fun m -> m "Removed service %s from @%s" url handle); 257 257 + 0 258 258 + | Error msg -> 259 259 + Logs.err (fun m -> m "%s" msg); 260 260 + 1 261 261 + 262 262 + (* Add organization to existing contact *) 263 263 + let add_org_cmd handle org_name title department from until org_email org_url xdg env = 264 264 + let store = Sortal_store.create_from_xdg xdg in 265 265 + let git_store = Sortal_git_store.create store env in 266 266 + let from = parse_date_opt from in 267 267 + let until = parse_date_opt until in 268 268 + let org = Contact.make_org ?title ?department ?from ?until ?email:org_email ?url:org_url org_name in 269 269 + match Sortal_git_store.add_organization git_store handle org with 270 270 + | Ok () -> 271 271 + Logs.app (fun m -> m "Added organization %s to @%s" org_name handle); 272 272 + 0 273 273 + | Error msg -> 274 274 + Logs.err (fun m -> m "%s" msg); 275 275 + 1 276 276 + 277 277 + (* Remove organization from contact *) 278 278 + let remove_org_cmd handle org_name xdg env = 279 279 + let store = Sortal_store.create_from_xdg xdg in 280 280 + let git_store = Sortal_git_store.create store env in 281 281 + match Sortal_git_store.remove_organization git_store handle org_name with 282 282 + | Ok () -> 283 283 + Logs.app (fun m -> m "Removed organization %s from @%s" org_name handle); 284 284 + 0 285 285 + | Error msg -> 286 286 + Logs.err (fun m -> m "%s" msg); 287 287 + 1 288 288 + 289 289 + (* Add URL to existing contact *) 290 290 + let add_url_cmd handle url label xdg env = 291 291 + let store = Sortal_store.create_from_xdg xdg in 292 292 + let git_store = Sortal_git_store.create store env in 293 293 + let url_entry = Contact.make_url ?label url in 294 294 + match Sortal_git_store.add_url git_store handle url_entry with 295 295 + | Ok () -> 296 296 + Logs.app (fun m -> m "Added URL %s to @%s" url handle); 297 297 + 0 298 298 + | Error msg -> 299 299 + Logs.err (fun m -> m "%s" msg); 300 300 + 1 301 301 + 302 302 + (* Remove URL from contact *) 303 303 + let remove_url_cmd handle url xdg env = 304 304 + let store = Sortal_store.create_from_xdg xdg in 305 305 + let git_store = Sortal_git_store.create store env in 306 306 + match Sortal_git_store.remove_url git_store handle url with 307 307 + | Ok () -> 308 308 + Logs.app (fun m -> m "Removed URL %s from @%s" url handle); 309 309 + 0 310 310 + | Error msg -> 311 311 + Logs.err (fun m -> m "%s" msg); 312 312 + 1 313 313 + 314 314 + (* Command info and args *) 315 315 + let list_info = Cmd.info "list" ~doc:"List all contacts" 316 316 + let show_info = Cmd.info "show" ~doc:"Show detailed information about a contact" 317 317 + let search_info = Cmd.info "search" ~doc:"Search contacts by name" 318 318 + let stats_info = Cmd.info "stats" ~doc:"Show statistics about the contact database" 319 319 + let sync_info = Cmd.info "sync" ~doc:"Synchronize and normalize contact data" 320 320 + 321 321 + let git_init_info = Cmd.info "git-init" ~doc:"Initialize git repository for contact versioning" 322 322 + ~man:[ 323 323 + `S Manpage.s_description; 324 324 + `P "Initialize a git repository in the XDG data directory to track contact changes."; 325 325 + `P "Once initialized, all contact modifications will be automatically committed with descriptive messages."; 326 326 + ] 327 327 + 328 328 + let add_info = Cmd.info "add" ~doc:"Create a new contact" 329 329 + ~man:[ 330 330 + `S Manpage.s_description; 331 331 + `P "Create a new contact with the given handle and name."; 332 332 + `P "Additional metadata can be added using options or via add-email, add-service, etc. commands."; 333 333 + ] 334 334 + 335 335 + let delete_info = Cmd.info "delete" ~doc:"Delete a contact" 336 336 + let add_email_info = Cmd.info "add-email" ~doc:"Add an email address to a contact" 337 337 + let remove_email_info = Cmd.info "remove-email" ~doc:"Remove an email address from a contact" 338 338 + let add_service_info = Cmd.info "add-service" ~doc:"Add a service (GitHub, Twitter, etc.) to a contact" 339 339 + let remove_service_info = Cmd.info "remove-service" ~doc:"Remove a service from a contact" 340 340 + let add_org_info = Cmd.info "add-org" ~doc:"Add an organization/affiliation to a contact" 341 341 + let remove_org_info = Cmd.info "remove-org" ~doc:"Remove an organization from a contact" 342 342 + let add_url_info = Cmd.info "add-url" ~doc:"Add a URL to a contact" 343 343 + let remove_url_info = Cmd.info "remove-url" ~doc:"Remove a URL from a contact" 344 344 + 345 345 + let handle_arg = 346 346 + Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE" 347 347 + ~doc:"Contact handle to display") 348 348 + 349 349 + let query_arg = 350 350 + Arg.(required & pos 0 (some string) None & info [] ~docv:"QUERY" 351 351 + ~doc:"Name or partial name to search for") 352 352 + 353 353 + (* Add command arguments *) 354 354 + let add_handle_arg = 355 355 + Arg.(required & pos 0 (some string) None & info [] ~docv:"HANDLE" 356 356 + ~doc:"Contact handle (unique identifier)") 357 357 + 358 358 + let add_names_arg = 359 359 + Arg.(non_empty & opt_all string [] & info ["n"; "name"] ~docv:"NAME" 360 360 + ~doc:"Full name (can be specified multiple times for aliases)") 361 361 + 362 362 + let add_kind_arg = 363 363 + let kind_conv = 364 364 + let parse s = match Contact.contact_kind_of_string s with 365 365 + | Some k -> Ok k 366 366 + | None -> Error (`Msg (Printf.sprintf "Invalid kind: %s" s)) 367 367 + in 368 368 + let print ppf k = Format.pp_print_string ppf (Contact.contact_kind_to_string k) in 369 369 + Arg.conv (parse, print) 370 370 + in 371 371 + Arg.(value & opt (some kind_conv) None & info ["k"; "kind"] ~docv:"KIND" 372 372 + ~doc:"Contact kind (person, organization, group, role)") 373 373 + 374 374 + let add_email_arg = 375 375 + Arg.(value & opt (some string) None & info ["e"; "email"] ~docv:"EMAIL" 376 376 + ~doc:"Email address") 377 377 + 378 378 + let add_github_arg = 379 379 + Arg.(value & opt (some string) None & info ["g"; "github"] ~docv:"HANDLE" 380 380 + ~doc:"GitHub handle") 381 381 + 382 382 + let add_url_arg = 383 383 + Arg.(value & opt (some string) None & info ["u"; "url"] ~docv:"URL" 384 384 + ~doc:"Personal/professional website URL") 385 385 + 386 386 + let add_orcid_arg = 387 387 + Arg.(value & opt (some string) None & info ["orcid"] ~docv:"ORCID" 388 388 + ~doc:"ORCID identifier") 389 389 + 390 390 + (* Add-email command arguments *) 391 391 + let email_address_arg = 392 392 + Arg.(required & pos 1 (some string) None & info [] ~docv:"EMAIL" 393 393 + ~doc:"Email address") 394 394 + 395 395 + let email_type_arg = 396 396 + let type_conv = 397 397 + let parse s = match Contact.email_type_of_string s with 398 398 + | Some t -> Ok t 399 399 + | None -> Error (`Msg (Printf.sprintf "Invalid email type: %s" s)) 400 400 + in 401 401 + let print ppf t = Format.pp_print_string ppf (Contact.email_type_to_string t) in 402 402 + Arg.conv (parse, print) 403 403 + in 404 404 + Arg.(value & opt (some type_conv) None & info ["t"; "type"] ~docv:"TYPE" 405 405 + ~doc:"Email type (work, personal, other)") 406 406 + 407 407 + let date_arg name = 408 408 + Arg.(value & opt (some string) None & info [name] ~docv:"DATE" 409 409 + ~doc:"ISO 8601 date (e.g., 2023, 2023-01, 2023-01-15)") 410 410 + 411 411 + let note_arg = 412 412 + Arg.(value & opt (some string) None & info ["note"] ~docv:"NOTE" 413 413 + ~doc:"Contextual note") 414 414 + 415 415 + (* Add-service command arguments *) 416 416 + let service_url_arg = 417 417 + Arg.(required & pos 1 (some string) None & info [] ~docv:"URL" 418 418 + ~doc:"Service URL") 419 419 + 420 420 + let service_kind_arg = 421 421 + let kind_conv = 422 422 + let parse s = match Contact.service_kind_of_string s with 423 423 + | Some k -> Ok k 424 424 + | None -> Error (`Msg (Printf.sprintf "Invalid service kind: %s" s)) 425 425 + in 426 426 + let print ppf k = Format.pp_print_string ppf (Contact.service_kind_to_string k) in 427 427 + Arg.conv (parse, print) 428 428 + in 429 429 + Arg.(value & opt (some kind_conv) None & info ["k"; "kind"] ~docv:"KIND" 430 430 + ~doc:"Service kind (github, git, social, activitypub, photo)") 431 431 + 432 432 + let service_handle_arg = 433 433 + Arg.(value & opt (some string) None & info ["handle"] ~docv:"HANDLE" 434 434 + ~doc:"Service handle/username") 435 435 + 436 436 + let label_arg = 437 437 + Arg.(value & opt (some string) None & info ["l"; "label"] ~docv:"LABEL" 438 438 + ~doc:"Human-readable label") 439 439 + 440 440 + (* Add-org command arguments *) 441 441 + let org_name_arg = 442 442 + Arg.(required & pos 1 (some string) None & info [] ~docv:"ORG" 443 443 + ~doc:"Organization name") 444 444 + 445 445 + let org_title_arg = 446 446 + Arg.(value & opt (some string) None & info ["title"] ~docv:"TITLE" 447 447 + ~doc:"Job title") 448 448 + 449 449 + let org_department_arg = 450 450 + Arg.(value & opt (some string) None & info ["dept"; "department"] ~docv:"DEPT" 451 451 + ~doc:"Department") 452 452 + 453 453 + let org_email_arg = 454 454 + Arg.(value & opt (some string) None & info ["email"] ~docv:"EMAIL" 455 455 + ~doc:"Work email during this period") 456 456 + 457 457 + let org_url_arg = 458 458 + Arg.(value & opt (some string) None & info ["url"] ~docv:"URL" 459 459 + ~doc:"Work homepage during this period") 460 460 + 461 461 + (* URL command arguments *) 462 462 + let url_value_arg = 463 463 + Arg.(required & pos 1 (some string) None & info [] ~docv:"URL" 464 464 + ~doc:"URL")

+235

sortal/lib/core/sortal_cmd.mli

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Cmdliner terms and commands for contact management. 7 7 + 8 8 + This module provides ready-to-use Cmdliner terms for building 9 9 + CLI applications that work with contact metadata. *) 10 10 + 11 11 + module Contact = Sortal_schema.Contact 12 12 + module Temporal = Sortal_schema.Temporal 13 13 + 14 14 + (** {1 Command Implementations} *) 15 15 + 16 16 + (** [list_cmd] is a Cmdliner command that lists all contacts. 17 17 + 18 18 + Returns a function that takes an XDG context and returns an exit code. *) 19 19 + val list_cmd : (Xdge.t -> int) 20 20 + 21 21 + (** [show_cmd handle] creates a command to show detailed contact information. 22 22 + 23 23 + @param handle The contact handle to display *) 24 24 + val show_cmd : string -> (Xdge.t -> int) 25 25 + 26 26 + (** [search_cmd query] creates a command to search contacts by name. 27 27 + 28 28 + @param query The search query string *) 29 29 + val search_cmd : string -> (Xdge.t -> int) 30 30 + 31 31 + (** [stats_cmd] is a command that shows database statistics. *) 32 32 + val stats_cmd : unit -> (Xdge.t -> int) 33 33 + 34 34 + (** [sync_cmd] is a command that synchronizes and normalizes contact data. 35 35 + 36 36 + Currently performs the following operations: 37 37 + - Converts non-JPG thumbnail images to PNG using ImageMagick *) 38 38 + val sync_cmd : unit -> (Xdge.t -> int) 39 39 + 40 40 + (** [git_init_cmd xdg env] initializes a git repository in the data directory. 41 41 + 42 42 + Once initialized, all contact modifications will be automatically committed. 43 43 + @param xdg XDG context 44 44 + @param env Eio environment for process spawning *) 45 45 + val git_init_cmd : Xdge.t -> Eio_unix.Stdenv.base -> int 46 46 + 47 47 + (** [add_cmd handle names kind email github url orcid xdg env] creates a new contact. 48 48 + 49 49 + @param handle Contact handle (unique identifier) 50 50 + @param names List of names (first is primary) 51 51 + @param kind Optional contact kind 52 52 + @param email Optional email address 53 53 + @param github Optional GitHub handle 54 54 + @param url Optional personal/professional website 55 55 + @param orcid Optional ORCID identifier 56 56 + @param xdg XDG context 57 57 + @param env Eio environment for git operations *) 58 58 + val add_cmd : string -> string list -> Contact.contact_kind option -> 59 59 + string option -> string option -> string option -> string option -> 60 60 + Xdge.t -> Eio_unix.Stdenv.base -> int 61 61 + 62 62 + (** [delete_cmd handle xdg env] deletes a contact. 63 63 + 64 64 + @param handle The contact handle to delete 65 65 + @param xdg XDG context 66 66 + @param env Eio environment for git operations *) 67 67 + val delete_cmd : string -> Xdge.t -> Eio_unix.Stdenv.base -> int 68 68 + 69 69 + (** [add_email_cmd handle address type_ from until note xdg env] adds an email to a contact. 70 70 + 71 71 + @param handle Contact handle 72 72 + @param address Email address 73 73 + @param type_ Email type (work, personal, other) 74 74 + @param from Start date of validity 75 75 + @param until End date of validity 76 76 + @param note Contextual note 77 77 + @param xdg XDG context 78 78 + @param env Eio environment for git operations *) 79 79 + val add_email_cmd : string -> string -> Contact.email_type option -> 80 80 + string option -> string option -> string option -> 81 81 + Xdge.t -> Eio_unix.Stdenv.base -> int 82 82 + 83 83 + (** [remove_email_cmd handle address xdg env] removes an email from a contact. *) 84 84 + val remove_email_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int 85 85 + 86 86 + (** [add_service_cmd handle url kind service_handle label xdg env] adds a service to a contact. 87 87 + 88 88 + @param handle Contact handle 89 89 + @param url Service URL 90 90 + @param kind Service kind 91 91 + @param service_handle Service username/handle 92 92 + @param label Human-readable label 93 93 + @param xdg XDG context 94 94 + @param env Eio environment for git operations *) 95 95 + val add_service_cmd : string -> string -> Contact.service_kind option -> 96 96 + string option -> string option -> Xdge.t -> Eio_unix.Stdenv.base -> int 97 97 + 98 98 + (** [remove_service_cmd handle url xdg env] removes a service from a contact. *) 99 99 + val remove_service_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int 100 100 + 101 101 + (** [add_org_cmd handle org_name title department from until org_email org_url xdg env] 102 102 + adds an organization to a contact. *) 103 103 + val add_org_cmd : string -> string -> string option -> string option -> 104 104 + string option -> string option -> string option -> string option -> 105 105 + Xdge.t -> Eio_unix.Stdenv.base -> int 106 106 + 107 107 + (** [remove_org_cmd handle org_name xdg env] removes an organization from a contact. *) 108 108 + val remove_org_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int 109 109 + 110 110 + (** [add_url_cmd handle url label xdg env] adds a URL to a contact. *) 111 111 + val add_url_cmd : string -> string -> string option -> Xdge.t -> Eio_unix.Stdenv.base -> int 112 112 + 113 113 + (** [remove_url_cmd handle url xdg env] removes a URL from a contact. *) 114 114 + val remove_url_cmd : string -> string -> Xdge.t -> Eio_unix.Stdenv.base -> int 115 115 + 116 116 + (** {1 Cmdliner Info Objects} *) 117 117 + 118 118 + (** [list_info] is the command info for the list command. *) 119 119 + val list_info : Cmdliner.Cmd.info 120 120 + 121 121 + (** [show_info] is the command info for the show command. *) 122 122 + val show_info : Cmdliner.Cmd.info 123 123 + 124 124 + (** [search_info] is the command info for the search command. *) 125 125 + val search_info : Cmdliner.Cmd.info 126 126 + 127 127 + (** [stats_info] is the command info for the stats command. *) 128 128 + val stats_info : Cmdliner.Cmd.info 129 129 + 130 130 + (** [sync_info] is the command info for the sync command. *) 131 131 + val sync_info : Cmdliner.Cmd.info 132 132 + 133 133 + (** [git_init_info] is the command info for the git-init command. *) 134 134 + val git_init_info : Cmdliner.Cmd.info 135 135 + 136 136 + (** [add_info] is the command info for the add command. *) 137 137 + val add_info : Cmdliner.Cmd.info 138 138 + 139 139 + (** [delete_info] is the command info for the delete command. *) 140 140 + val delete_info : Cmdliner.Cmd.info 141 141 + 142 142 + (** [add_email_info] is the command info for the add-email command. *) 143 143 + val add_email_info : Cmdliner.Cmd.info 144 144 + 145 145 + (** [remove_email_info] is the command info for the remove-email command. *) 146 146 + val remove_email_info : Cmdliner.Cmd.info 147 147 + 148 148 + (** [add_service_info] is the command info for the add-service command. *) 149 149 + val add_service_info : Cmdliner.Cmd.info 150 150 + 151 151 + (** [remove_service_info] is the command info for the remove-service command. *) 152 152 + val remove_service_info : Cmdliner.Cmd.info 153 153 + 154 154 + (** [add_org_info] is the command info for the add-org command. *) 155 155 + val add_org_info : Cmdliner.Cmd.info 156 156 + 157 157 + (** [remove_org_info] is the command info for the remove-org command. *) 158 158 + val remove_org_info : Cmdliner.Cmd.info 159 159 + 160 160 + (** [add_url_info] is the command info for the add-url command. *) 161 161 + val add_url_info : Cmdliner.Cmd.info 162 162 + 163 163 + (** [remove_url_info] is the command info for the remove-url command. *) 164 164 + val remove_url_info : Cmdliner.Cmd.info 165 165 + 166 166 + (** {1 Cmdliner Argument Definitions} *) 167 167 + 168 168 + (** [handle_arg] is the positional argument for a contact handle. *) 169 169 + val handle_arg : string Cmdliner.Term.t 170 170 + 171 171 + (** [query_arg] is the positional argument for a search query. *) 172 172 + val query_arg : string Cmdliner.Term.t 173 173 + 174 174 + (** [add_handle_arg] is the positional argument for a new contact handle. *) 175 175 + val add_handle_arg : string Cmdliner.Term.t 176 176 + 177 177 + (** [add_names_arg] is the repeatable option for contact names. *) 178 178 + val add_names_arg : string list Cmdliner.Term.t 179 179 + 180 180 + (** [add_kind_arg] is the optional argument for contact kind. *) 181 181 + val add_kind_arg : Contact.contact_kind option Cmdliner.Term.t 182 182 + 183 183 + (** [add_email_arg] is the optional argument for email. *) 184 184 + val add_email_arg : string option Cmdliner.Term.t 185 185 + 186 186 + (** [add_github_arg] is the optional argument for GitHub handle. *) 187 187 + val add_github_arg : string option Cmdliner.Term.t 188 188 + 189 189 + (** [add_url_arg] is the optional argument for URL. *) 190 190 + val add_url_arg : string option Cmdliner.Term.t 191 191 + 192 192 + (** [add_orcid_arg] is the optional argument for ORCID. *) 193 193 + val add_orcid_arg : string option Cmdliner.Term.t 194 194 + 195 195 + (** [email_address_arg] is the positional argument for email address. *) 196 196 + val email_address_arg : string Cmdliner.Term.t 197 197 + 198 198 + (** [email_type_arg] is the optional argument for email type. *) 199 199 + val email_type_arg : Contact.email_type option Cmdliner.Term.t 200 200 + 201 201 + (** [date_arg name] creates a date argument with the given option name. *) 202 202 + val date_arg : string -> string option Cmdliner.Term.t 203 203 + 204 204 + (** [note_arg] is the optional argument for notes. *) 205 205 + val note_arg : string option Cmdliner.Term.t 206 206 + 207 207 + (** [service_url_arg] is the positional argument for service URL. *) 208 208 + val service_url_arg : string Cmdliner.Term.t 209 209 + 210 210 + (** [service_kind_arg] is the optional argument for service kind. *) 211 211 + val service_kind_arg : Contact.service_kind option Cmdliner.Term.t 212 212 + 213 213 + (** [service_handle_arg] is the optional argument for service handle. *) 214 214 + val service_handle_arg : string option Cmdliner.Term.t 215 215 + 216 216 + (** [label_arg] is the optional argument for labels. *) 217 217 + val label_arg : string option Cmdliner.Term.t 218 218 + 219 219 + (** [org_name_arg] is the positional argument for organization name. *) 220 220 + val org_name_arg : string Cmdliner.Term.t 221 221 + 222 222 + (** [org_title_arg] is the optional argument for job title. *) 223 223 + val org_title_arg : string option Cmdliner.Term.t 224 224 + 225 225 + (** [org_department_arg] is the optional argument for department. *) 226 226 + val org_department_arg : string option Cmdliner.Term.t 227 227 + 228 228 + (** [org_email_arg] is the optional argument for work email. *) 229 229 + val org_email_arg : string option Cmdliner.Term.t 230 230 + 231 231 + (** [org_url_arg] is the optional argument for work URL. *) 232 232 + val org_url_arg : string option Cmdliner.Term.t 233 233 + 234 234 + (** [url_value_arg] is the positional argument for URL. *) 235 235 + val url_value_arg : string Cmdliner.Term.t

+233

sortal/lib/core/sortal_git_store.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + module Contact = Sortal_schema.Contact 7 7 + 8 8 + type t = { 9 9 + store : Sortal_store.t; 10 10 + env : Eio_unix.Stdenv.base; 11 11 + } 12 12 + 13 13 + let create store env = { store; env } 14 14 + 15 15 + let store t = t.store 16 16 + 17 17 + (* Helper to check if a string contains a substring *) 18 18 + let contains_substring ~needle haystack = 19 19 + try 20 20 + let _ = Str.search_forward (Str.regexp_string needle) haystack 0 in 21 21 + true 22 22 + with Not_found -> false 23 23 + 24 24 + (* Helper to get the data directory path as a native string *) 25 25 + let data_dir_path t = 26 26 + (* We need to extract the data directory from the store somehow. 27 27 + For now, we'll use the XDG environment to locate it. *) 28 28 + let xdg = Xdge.create t.env#fs "sortal" in 29 29 + let data_path = Xdge.data_dir xdg in 30 30 + Eio.Path.native_exn data_path 31 31 + 32 32 + (* Execute a git command in the data directory *) 33 33 + let run_git t args = 34 34 + let data_dir = data_dir_path t in 35 35 + Eio.Switch.run @@ fun sw -> 36 36 + try 37 37 + let mgr = t.env#process_mgr in 38 38 + let cmd = ["git"; "-C"; data_dir] @ args in 39 39 + let proc = Eio.Process.spawn ~sw mgr cmd in 40 40 + match Eio.Process.await proc with 41 41 + | `Exited 0 -> Ok () 42 42 + | `Exited n -> Error (Printf.sprintf "git %s exited with code %d" (String.concat " " args) n) 43 43 + | `Signaled n -> Error (Printf.sprintf "git killed by signal %d" n) 44 44 + with 45 45 + | exn -> 46 46 + let msg = Printexc.to_string exn in 47 47 + if contains_substring ~needle:"not found" msg || 48 48 + contains_substring ~needle:"No such file" msg then 49 49 + Error "git executable not found - please install git" 50 50 + else 51 51 + Error (Printf.sprintf "git command failed: %s" msg) 52 52 + 53 53 + let is_initialized t = 54 54 + let data_dir = data_dir_path t in 55 55 + let git_dir = Filename.concat data_dir ".git" in 56 56 + Sys.file_exists git_dir && Sys.is_directory git_dir 57 57 + 58 58 + let init t = 59 59 + if is_initialized t then 60 60 + Ok () 61 61 + else begin 62 62 + match run_git t ["init"] with 63 63 + | Error _ as e -> e 64 64 + | Ok () -> 65 65 + (* Create initial commit *) 66 66 + match run_git t ["add"; "."] with 67 67 + | Error _ as e -> e 68 68 + | Ok () -> 69 69 + let msg = "Initialize sortal contact database" in 70 70 + run_git t ["commit"; "--allow-empty"; "-m"; msg] 71 71 + end 72 72 + 73 73 + (* Helper to commit a file with a message *) 74 74 + let commit_file t filename msg = 75 75 + match run_git t ["add"; filename] with 76 76 + | Error _ as e -> e 77 77 + | Ok () -> 78 78 + run_git t ["commit"; "-m"; msg] 79 79 + 80 80 + (* Helper to commit a deletion *) 81 81 + let commit_deletion t filename msg = 82 82 + match run_git t ["rm"; filename] with 83 83 + | Error _ as e -> e 84 84 + | Ok () -> 85 85 + run_git t ["commit"; "-m"; msg] 86 86 + 87 87 + let save t contact = 88 88 + let handle = Contact.handle contact in 89 89 + let name = Contact.name contact in 90 90 + let filename = handle ^ ".yaml" in 91 91 + 92 92 + (* Check if contact already exists *) 93 93 + let is_new = match Sortal_store.lookup t.store handle with 94 94 + | None -> true 95 95 + | Some _ -> false 96 96 + in 97 97 + 98 98 + (* Save to store *) 99 99 + Sortal_store.save t.store contact; 100 100 + 101 101 + (* Commit to git *) 102 102 + if not (is_initialized t) then 103 103 + Ok () 104 104 + else 105 105 + let msg = if is_new then 106 106 + Printf.sprintf "Add contact @%s (%s)" handle name 107 107 + else 108 108 + Printf.sprintf "Update contact @%s (%s)" handle name 109 109 + in 110 110 + commit_file t filename msg 111 111 + 112 112 + let delete t handle = 113 113 + match Sortal_store.lookup t.store handle with 114 114 + | None -> Error (Printf.sprintf "Contact not found: %s" handle) 115 115 + | Some contact -> 116 116 + let name = Contact.name contact in 117 117 + let filename = handle ^ ".yaml" in 118 118 + 119 119 + (* Delete from store *) 120 120 + Sortal_store.delete t.store handle; 121 121 + 122 122 + (* Commit deletion to git *) 123 123 + if not (is_initialized t) then 124 124 + Ok () 125 125 + else 126 126 + let msg = Printf.sprintf "Delete contact @%s (%s)" handle name in 127 127 + commit_deletion t filename msg 128 128 + 129 129 + let update_contact t handle f ~msg = 130 130 + match Sortal_store.update_contact t.store handle f with 131 131 + | Error _ as e -> e 132 132 + | Ok () -> 133 133 + if not (is_initialized t) then 134 134 + Ok () 135 135 + else 136 136 + let filename = handle ^ ".yaml" in 137 137 + commit_file t filename msg 138 138 + 139 139 + let add_email t handle (email : Contact.email) = 140 140 + let msg = Printf.sprintf "Update @%s: add email %s" 141 141 + handle email.address in 142 142 + match Sortal_store.add_email t.store handle email with 143 143 + | Error _ as e -> e 144 144 + | Ok () -> 145 145 + if not (is_initialized t) then 146 146 + Ok () 147 147 + else 148 148 + let filename = handle ^ ".yaml" in 149 149 + commit_file t filename msg 150 150 + 151 151 + let remove_email t handle address = 152 152 + let msg = Printf.sprintf "Update @%s: remove email %s" handle address in 153 153 + match Sortal_store.remove_email t.store handle address with 154 154 + | Error _ as e -> e 155 155 + | Ok () -> 156 156 + if not (is_initialized t) then 157 157 + Ok () 158 158 + else 159 159 + let filename = handle ^ ".yaml" in 160 160 + commit_file t filename msg 161 161 + 162 162 + let add_service t handle (service : Contact.service) = 163 163 + let kind_str = match service.kind with 164 164 + | Some k -> Contact.service_kind_to_string k 165 165 + | None -> "unknown" 166 166 + in 167 167 + let msg = Printf.sprintf "Update @%s: add service %s (%s)" 168 168 + handle kind_str service.url in 169 169 + match Sortal_store.add_service t.store handle service with 170 170 + | Error _ as e -> e 171 171 + | Ok () -> 172 172 + if not (is_initialized t) then 173 173 + Ok () 174 174 + else 175 175 + let filename = handle ^ ".yaml" in 176 176 + commit_file t filename msg 177 177 + 178 178 + let remove_service t handle url = 179 179 + let msg = Printf.sprintf "Update @%s: remove service %s" handle url in 180 180 + match Sortal_store.remove_service t.store handle url with 181 181 + | Error _ as e -> e 182 182 + | Ok () -> 183 183 + if not (is_initialized t) then 184 184 + Ok () 185 185 + else 186 186 + let filename = handle ^ ".yaml" in 187 187 + commit_file t filename msg 188 188 + 189 189 + let add_organization t handle (org : Contact.organization) = 190 190 + let msg = Printf.sprintf "Update @%s: add organization %s" 191 191 + handle org.name in 192 192 + match Sortal_store.add_organization t.store handle org with 193 193 + | Error _ as e -> e 194 194 + | Ok () -> 195 195 + if not (is_initialized t) then 196 196 + Ok () 197 197 + else 198 198 + let filename = handle ^ ".yaml" in 199 199 + commit_file t filename msg 200 200 + 201 201 + let remove_organization t handle name = 202 202 + let msg = Printf.sprintf "Update @%s: remove organization %s" handle name in 203 203 + match Sortal_store.remove_organization t.store handle name with 204 204 + | Error _ as e -> e 205 205 + | Ok () -> 206 206 + if not (is_initialized t) then 207 207 + Ok () 208 208 + else 209 209 + let filename = handle ^ ".yaml" in 210 210 + commit_file t filename msg 211 211 + 212 212 + let add_url t handle (url_entry : Contact.url_entry) = 213 213 + let msg = Printf.sprintf "Update @%s: add URL %s" 214 214 + handle url_entry.url in 215 215 + match Sortal_store.add_url t.store handle url_entry with 216 216 + | Error _ as e -> e 217 217 + | Ok () -> 218 218 + if not (is_initialized t) then 219 219 + Ok () 220 220 + else 221 221 + let filename = handle ^ ".yaml" in 222 222 + commit_file t filename msg 223 223 + 224 224 + let remove_url t handle url = 225 225 + let msg = Printf.sprintf "Update @%s: remove URL %s" handle url in 226 226 + match Sortal_store.remove_url t.store handle url with 227 227 + | Error _ as e -> e 228 228 + | Ok () -> 229 229 + if not (is_initialized t) then 230 230 + Ok () 231 231 + else 232 232 + let filename = handle ^ ".yaml" in 233 233 + commit_file t filename msg

+116

sortal/lib/core/sortal_git_store.mli

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Git-backed contact store with automatic version control. 7 7 + 8 8 + This module wraps {!Sortal_store} to provide automatic git versioning 9 9 + of all contact modifications. Each change (add, update, delete) is 10 10 + automatically committed to a git repository with descriptive commit 11 11 + messages. *) 12 12 + 13 13 + module Contact = Sortal_schema.Contact 14 14 + 15 15 + type t 16 16 + (** A git-backed contact store. *) 17 17 + 18 18 + (** {1 Creation and Initialization} *) 19 19 + 20 20 + val create : Sortal_store.t -> Eio_unix.Stdenv.base -> t 21 21 + (** [create store env] creates a git-backed store wrapping [store]. 22 22 + 23 23 + @param store The underlying contact store 24 24 + @param env The Eio environment for spawning git processes *) 25 25 + 26 26 + val init : t -> (unit, string) result 27 27 + (** [init t] initializes a git repository in the data directory. 28 28 + 29 29 + Creates a new git repository with an initial commit if one doesn't exist. 30 30 + Safe to call multiple times - returns [Ok ()] if already initialized. 31 31 + 32 32 + @return [Ok ()] if initialized successfully or already initialized, 33 33 + [Error msg] if git initialization fails *) 34 34 + 35 35 + val is_initialized : t -> bool 36 36 + (** [is_initialized t] checks if the data directory is a git repository. 37 37 + 38 38 + @return [true] if a .git directory exists, [false] otherwise *) 39 39 + 40 40 + (** {1 Contact Operations} *) 41 41 + 42 42 + val save : t -> Contact.t -> (unit, string) result 43 43 + (** [save t contact] saves a contact and commits the change to git. 44 44 + 45 45 + If the contact is new, commits with message "Add contact @handle (Name)". 46 46 + If updating an existing contact, commits with "Update contact @handle (Name)". 47 47 + 48 48 + @param contact The contact to save *) 49 49 + 50 50 + val delete : t -> string -> (unit, string) result 51 51 + (** [delete t handle] deletes a contact and commits the removal to git. 52 52 + 53 53 + Commits with message "Delete contact @handle (Name)". 54 54 + 55 55 + @param handle The contact handle to delete 56 56 + @return [Error msg] if contact not found *) 57 57 + 58 58 + (** {1 Contact Modification} *) 59 59 + 60 60 + val add_email : t -> string -> Contact.email -> (unit, string) result 61 61 + (** [add_email t handle email] adds an email to a contact and commits. 62 62 + 63 63 + Commits with message "Update @handle: add email address@example.com". *) 64 64 + 65 65 + val remove_email : t -> string -> string -> (unit, string) result 66 66 + (** [remove_email t handle address] removes an email and commits. 67 67 + 68 68 + Commits with message "Update @handle: remove email address@example.com". *) 69 69 + 70 70 + val add_service : t -> string -> Contact.service -> (unit, string) result 71 71 + (** [add_service t handle service] adds a service to a contact and commits. 72 72 + 73 73 + Commits with message "Update @handle: add service Kind (url)". *) 74 74 + 75 75 + val remove_service : t -> string -> string -> (unit, string) result 76 76 + (** [remove_service t handle url] removes a service and commits. 77 77 + 78 78 + Commits with message "Update @handle: remove service url". *) 79 79 + 80 80 + val add_organization : t -> string -> Contact.organization -> (unit, string) result 81 81 + (** [add_organization t handle org] adds an organization and commits. 82 82 + 83 83 + Commits with message "Update @handle: add organization Org Name". *) 84 84 + 85 85 + val remove_organization : t -> string -> string -> (unit, string) result 86 86 + (** [remove_organization t handle name] removes an organization and commits. 87 87 + 88 88 + Commits with message "Update @handle: remove organization Org Name". *) 89 89 + 90 90 + val add_url : t -> string -> Contact.url_entry -> (unit, string) result 91 91 + (** [add_url t handle url_entry] adds a URL and commits. 92 92 + 93 93 + Commits with message "Update @handle: add URL url". *) 94 94 + 95 95 + val remove_url : t -> string -> string -> (unit, string) result 96 96 + (** [remove_url t handle url] removes a URL and commits. 97 97 + 98 98 + Commits with message "Update @handle: remove URL url". *) 99 99 + 100 100 + (** {1 Low-level Operations} *) 101 101 + 102 102 + val update_contact : t -> string -> (Contact.t -> Contact.t) -> 103 103 + msg:string -> (unit, string) result 104 104 + (** [update_contact t handle f ~msg] updates a contact and commits with custom message. 105 105 + 106 106 + This is a low-level function that applies transformation [f] to the contact 107 107 + and commits with the provided commit message. 108 108 + 109 109 + @param handle The contact handle 110 110 + @param f Function to transform the contact 111 111 + @param msg The git commit message *) 112 112 + 113 113 + val store : t -> Sortal_store.t 114 114 + (** [store t] returns the underlying contact store. 115 115 + 116 116 + Use this when you need direct store access without git commits. *)

+370

sortal/lib/core/sortal_store.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + module Contact = Sortal_schema.Contact 7 7 + module Temporal = Sortal_schema.Temporal 8 8 + 9 9 + type t = { 10 10 + xdg : Xdge.t; [@warning "-69"] 11 11 + data_dir : Eio.Fs.dir_ty Eio.Path.t; 12 12 + } 13 13 + 14 14 + let create fs app_name = 15 15 + let xdg = Xdge.create fs app_name in 16 16 + let data_dir = Xdge.data_dir xdg in 17 17 + { xdg; data_dir } 18 18 + 19 19 + let create_from_xdg xdg = 20 20 + let data_dir = Xdge.data_dir xdg in 21 21 + { xdg; data_dir } 22 22 + 23 23 + let contact_file t handle = 24 24 + Eio.Path.(t.data_dir / (handle ^ ".yaml")) 25 25 + 26 26 + let save t contact = 27 27 + let path = contact_file t (Contact.handle contact) in 28 28 + let buf = Buffer.create 4096 in 29 29 + let writer = Bytesrw.Bytes.Writer.of_buffer buf in 30 30 + match Yamlt.encode Contact.json_t contact ~eod:true writer with 31 31 + | Ok () -> Eio.Path.save ~create:(`Or_truncate 0o644) path (Buffer.contents buf) 32 32 + | Error err -> failwith ("Failed to encode contact: " ^ err) 33 33 + 34 34 + let lookup t handle = 35 35 + let path = contact_file t handle in 36 36 + try 37 37 + let yaml_str = Eio.Path.load path in 38 38 + let reader = Bytesrw.Bytes.Reader.of_string yaml_str in 39 39 + match Yamlt.decode Contact.json_t reader with 40 40 + | Ok contact -> Some contact 41 41 + | Error msg -> 42 42 + Logs.warn (fun m -> m "Failed to decode contact %s: %s" handle msg); 43 43 + None 44 44 + with exn -> 45 45 + Logs.warn (fun m -> m "Failed to load contact %s: %s" handle (Printexc.to_string exn)); 46 46 + None 47 47 + 48 48 + let delete t handle = 49 49 + let path = contact_file t handle in 50 50 + try 51 51 + Eio.Path.unlink path 52 52 + with 53 53 + | _ -> () 54 54 + 55 55 + (* Contact modification helpers *) 56 56 + let update_contact t handle f = 57 57 + match lookup t handle with 58 58 + | None -> Error (Printf.sprintf "Contact not found: %s" handle) 59 59 + | Some contact -> 60 60 + let updated = f contact in 61 61 + save t updated; 62 62 + Ok () 63 63 + 64 64 + let add_email t handle (email : Contact.email) = 65 65 + match lookup t handle with 66 66 + | None -> Error (Printf.sprintf "Contact not found: %s" handle) 67 67 + | Some contact -> 68 68 + let emails = Contact.emails contact in 69 69 + (* Check for duplicate email address *) 70 70 + if List.exists (fun (e : Contact.email) -> e.address = email.address) emails then 71 71 + Error (Printf.sprintf "Email %s already exists for contact @%s" email.address handle) 72 72 + else 73 73 + update_contact t handle (fun contact -> 74 74 + let emails = Contact.emails contact in 75 75 + Contact.make 76 76 + ~handle:(Contact.handle contact) 77 77 + ~names:(Contact.names contact) 78 78 + ~kind:(Contact.kind contact) 79 79 + ~emails:(emails @ [email]) 80 80 + ~organizations:(Contact.organizations contact) 81 81 + ~urls:(Contact.urls contact) 82 82 + ~services:(Contact.services contact) 83 83 + ?icon:(Contact.icon contact) 84 84 + ?thumbnail:(Contact.thumbnail contact) 85 85 + ?orcid:(Contact.orcid contact) 86 86 + ?feeds:(Contact.feeds contact) 87 87 + () 88 88 + ) 89 89 + 90 90 + let remove_email t handle address = 91 91 + update_contact t handle (fun contact -> 92 92 + let emails = Contact.emails contact 93 93 + |> List.filter (fun (e : Contact.email) -> e.address <> address) in 94 94 + Contact.make 95 95 + ~handle:(Contact.handle contact) 96 96 + ~names:(Contact.names contact) 97 97 + ~kind:(Contact.kind contact) 98 98 + ~emails 99 99 + ~organizations:(Contact.organizations contact) 100 100 + ~urls:(Contact.urls contact) 101 101 + ~services:(Contact.services contact) 102 102 + ?icon:(Contact.icon contact) 103 103 + ?thumbnail:(Contact.thumbnail contact) 104 104 + ?orcid:(Contact.orcid contact) 105 105 + ?feeds:(Contact.feeds contact) 106 106 + () 107 107 + ) 108 108 + 109 109 + let add_service t handle (service : Contact.service) = 110 110 + match lookup t handle with 111 111 + | None -> Error (Printf.sprintf "Contact not found: %s" handle) 112 112 + | Some contact -> 113 113 + let services = Contact.services contact in 114 114 + (* Check for duplicate service URL *) 115 115 + if List.exists (fun (s : Contact.service) -> s.url = service.url) services then 116 116 + Error (Printf.sprintf "Service URL %s already exists for contact @%s" service.url handle) 117 117 + else 118 118 + update_contact t handle (fun contact -> 119 119 + let services = Contact.services contact in 120 120 + Contact.make 121 121 + ~handle:(Contact.handle contact) 122 122 + ~names:(Contact.names contact) 123 123 + ~kind:(Contact.kind contact) 124 124 + ~emails:(Contact.emails contact) 125 125 + ~organizations:(Contact.organizations contact) 126 126 + ~urls:(Contact.urls contact) 127 127 + ~services:(services @ [service]) 128 128 + ?icon:(Contact.icon contact) 129 129 + ?thumbnail:(Contact.thumbnail contact) 130 130 + ?orcid:(Contact.orcid contact) 131 131 + ?feeds:(Contact.feeds contact) 132 132 + () 133 133 + ) 134 134 + 135 135 + let remove_service t handle url = 136 136 + update_contact t handle (fun contact -> 137 137 + let services = Contact.services contact 138 138 + |> List.filter (fun (s : Contact.service) -> s.url <> url) in 139 139 + Contact.make 140 140 + ~handle:(Contact.handle contact) 141 141 + ~names:(Contact.names contact) 142 142 + ~kind:(Contact.kind contact) 143 143 + ~emails:(Contact.emails contact) 144 144 + ~organizations:(Contact.organizations contact) 145 145 + ~urls:(Contact.urls contact) 146 146 + ~services 147 147 + ?icon:(Contact.icon contact) 148 148 + ?thumbnail:(Contact.thumbnail contact) 149 149 + ?orcid:(Contact.orcid contact) 150 150 + ?feeds:(Contact.feeds contact) 151 151 + () 152 152 + ) 153 153 + 154 154 + let add_organization t handle (org : Contact.organization) = 155 155 + match lookup t handle with 156 156 + | None -> Error (Printf.sprintf "Contact not found: %s" handle) 157 157 + | Some contact -> 158 158 + let orgs = Contact.organizations contact in 159 159 + (* Check for exact duplicate organization (same name, title, and department) *) 160 160 + let is_duplicate = List.exists (fun (o : Contact.organization) -> 161 161 + o.name = org.name && 162 162 + o.title = org.title && 163 163 + o.department = org.department 164 164 + ) orgs in 165 165 + if is_duplicate then 166 166 + Error (Printf.sprintf "Organization %s with the same title/department already exists for contact @%s" org.name handle) 167 167 + else 168 168 + update_contact t handle (fun contact -> 169 169 + let orgs = Contact.organizations contact in 170 170 + Contact.make 171 171 + ~handle:(Contact.handle contact) 172 172 + ~names:(Contact.names contact) 173 173 + ~kind:(Contact.kind contact) 174 174 + ~emails:(Contact.emails contact) 175 175 + ~organizations:(orgs @ [org]) 176 176 + ~urls:(Contact.urls contact) 177 177 + ~services:(Contact.services contact) 178 178 + ?icon:(Contact.icon contact) 179 179 + ?thumbnail:(Contact.thumbnail contact) 180 180 + ?orcid:(Contact.orcid contact) 181 181 + ?feeds:(Contact.feeds contact) 182 182 + () 183 183 + ) 184 184 + 185 185 + let remove_organization t handle name = 186 186 + update_contact t handle (fun contact -> 187 187 + let orgs = Contact.organizations contact 188 188 + |> List.filter (fun (o : Contact.organization) -> o.name <> name) in 189 189 + Contact.make 190 190 + ~handle:(Contact.handle contact) 191 191 + ~names:(Contact.names contact) 192 192 + ~kind:(Contact.kind contact) 193 193 + ~emails:(Contact.emails contact) 194 194 + ~organizations:orgs 195 195 + ~urls:(Contact.urls contact) 196 196 + ~services:(Contact.services contact) 197 197 + ?icon:(Contact.icon contact) 198 198 + ?thumbnail:(Contact.thumbnail contact) 199 199 + ?orcid:(Contact.orcid contact) 200 200 + ?feeds:(Contact.feeds contact) 201 201 + () 202 202 + ) 203 203 + 204 204 + let add_url t handle (url_entry : Contact.url_entry) = 205 205 + match lookup t handle with 206 206 + | None -> Error (Printf.sprintf "Contact not found: %s" handle) 207 207 + | Some contact -> 208 208 + let urls = Contact.urls contact in 209 209 + (* Check for duplicate URL *) 210 210 + if List.exists (fun (u : Contact.url_entry) -> u.url = url_entry.url) urls then 211 211 + Error (Printf.sprintf "URL %s already exists for contact @%s" url_entry.url handle) 212 212 + else 213 213 + update_contact t handle (fun contact -> 214 214 + let urls = Contact.urls contact in 215 215 + Contact.make 216 216 + ~handle:(Contact.handle contact) 217 217 + ~names:(Contact.names contact) 218 218 + ~kind:(Contact.kind contact) 219 219 + ~emails:(Contact.emails contact) 220 220 + ~organizations:(Contact.organizations contact) 221 221 + ~urls:(urls @ [url_entry]) 222 222 + ~services:(Contact.services contact) 223 223 + ?icon:(Contact.icon contact) 224 224 + ?thumbnail:(Contact.thumbnail contact) 225 225 + ?orcid:(Contact.orcid contact) 226 226 + ?feeds:(Contact.feeds contact) 227 227 + () 228 228 + ) 229 229 + 230 230 + let remove_url t handle url = 231 231 + update_contact t handle (fun contact -> 232 232 + let urls = Contact.urls contact 233 233 + |> List.filter (fun (u : Contact.url_entry) -> u.url <> url) in 234 234 + Contact.make 235 235 + ~handle:(Contact.handle contact) 236 236 + ~names:(Contact.names contact) 237 237 + ~kind:(Contact.kind contact) 238 238 + ~emails:(Contact.emails contact) 239 239 + ~organizations:(Contact.organizations contact) 240 240 + ~urls 241 241 + ~services:(Contact.services contact) 242 242 + ?icon:(Contact.icon contact) 243 243 + ?thumbnail:(Contact.thumbnail contact) 244 244 + ?orcid:(Contact.orcid contact) 245 245 + ?feeds:(Contact.feeds contact) 246 246 + () 247 247 + ) 248 248 + 249 249 + let list t = 250 250 + try 251 251 + let entries = Eio.Path.read_dir t.data_dir in 252 252 + List.filter_map (fun entry -> 253 253 + if Filename.check_suffix entry ".yaml" then 254 254 + let handle = Filename.chop_suffix entry ".yaml" in 255 255 + lookup t handle 256 256 + else 257 257 + None 258 258 + ) entries 259 259 + with 260 260 + | _ -> [] 261 261 + 262 262 + let thumbnail_path t contact = 263 263 + Contact.thumbnail contact 264 264 + |> Option.map (fun relative_path -> Eio.Path.(t.data_dir / relative_path)) 265 265 + 266 266 + let png_thumbnail_path t contact = 267 267 + match Contact.thumbnail contact with 268 268 + | None -> None 269 269 + | Some relative_path -> 270 270 + let base = Filename.remove_extension relative_path in 271 271 + let png_path = base ^ ".png" in 272 272 + let full_path = Eio.Path.(t.data_dir / png_path) in 273 273 + try 274 274 + ignore (Eio.Path.load full_path); 275 275 + Some full_path 276 276 + with _ -> None 277 277 + 278 278 + let handle_of_name name = 279 279 + let name = String.lowercase_ascii name in 280 280 + let words = String.split_on_char ' ' name in 281 281 + let initials = String.concat "" (List.map (fun w -> String.sub w 0 1) words) in 282 282 + initials ^ List.hd (List.rev words) 283 283 + 284 284 + let find_by_name t name = 285 285 + let name_lower = String.lowercase_ascii name in 286 286 + let all_contacts = list t in 287 287 + let matches = List.filter (fun c -> 288 288 + List.exists (fun n -> String.lowercase_ascii n = name_lower) 289 289 + (Contact.names c) 290 290 + ) all_contacts in 291 291 + match matches with 292 292 + | [contact] -> contact 293 293 + | [] -> raise Not_found 294 294 + | _ -> raise (Invalid_argument ("Multiple contacts match: " ^ name)) 295 295 + 296 296 + let find_by_name_opt t name = 297 297 + try 298 298 + Some (find_by_name t name) 299 299 + with 300 300 + | Not_found | Invalid_argument _ -> None 301 301 + 302 302 + let contains_substring ~needle haystack = 303 303 + let needle_len = String.length needle in 304 304 + let haystack_len = String.length haystack in 305 305 + if needle_len = 0 then true 306 306 + else if needle_len > haystack_len then false 307 307 + else 308 308 + let rec check i = 309 309 + if i > haystack_len - needle_len then false 310 310 + else if String.sub haystack i needle_len = needle then true 311 311 + else check (i + 1) 312 312 + in 313 313 + check 0 314 314 + 315 315 + let search_all t query = 316 316 + let query_lower = String.lowercase_ascii query in 317 317 + let all = list t in 318 318 + let matches = List.filter (fun c -> 319 319 + List.exists (fun name -> 320 320 + let name_lower = String.lowercase_ascii name in 321 321 + String.equal name_lower query_lower || 322 322 + String.starts_with ~prefix:query_lower name_lower || 323 323 + contains_substring ~needle:query_lower name_lower || 324 324 + (String.contains name_lower ' ' && 325 325 + String.split_on_char ' ' name_lower |> List.exists (fun word -> 326 326 + String.starts_with ~prefix:query_lower word 327 327 + )) 328 328 + ) (Contact.names c) 329 329 + ) all in 330 330 + List.sort Contact.compare matches 331 331 + 332 332 + let find_by_email_at t ~email ~date = 333 333 + let all = list t in 334 334 + List.find_opt (fun c -> 335 335 + let emails_at_date = Contact.emails_at c ~date in 336 336 + List.exists (fun e -> e.Contact.address = email) emails_at_date 337 337 + ) all 338 338 + 339 339 + let find_by_org t ~org ?from ?until () = 340 340 + let org_lower = String.lowercase_ascii org in 341 341 + let all = list t in 342 342 + let matches = List.filter (fun c -> 343 343 + let orgs : Contact.organization list = Contact.organizations c in 344 344 + let filtered_orgs = match from, until with 345 345 + | None, None -> orgs 346 346 + | _, _ -> Temporal.filter ~get:(fun (o : Contact.organization) -> o.range) 347 347 + ~from ~until orgs 348 348 + in 349 349 + List.exists (fun (o : Contact.organization) -> 350 350 + contains_substring ~needle:org_lower 351 351 + (String.lowercase_ascii o.name) 352 352 + ) filtered_orgs 353 353 + ) all in 354 354 + List.sort Contact.compare matches 355 355 + 356 356 + let list_at t ~date = 357 357 + let all = list t in 358 358 + List.filter (fun c -> 359 359 + (* Contact is active if it has any email, org, or URL valid at date *) 360 360 + let has_email = Contact.emails_at c ~date <> [] in 361 361 + let has_org = Contact.organization_at c ~date <> None in 362 362 + let has_url = Contact.url_at c ~date <> None in 363 363 + has_email || has_org || has_url 364 364 + ) all 365 365 + 366 366 + let pp ppf t = 367 367 + let all = list t in 368 368 + Fmt.pf ppf "@[<v>%a: %d contacts stored in XDG data directory@]" 369 369 + (Fmt.styled `Bold Fmt.string) "Sortal Store" 370 370 + (List.length all)

+261

sortal/lib/core/sortal_store.mli

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Contact store with XDG-compliant storage. 7 7 + 8 8 + The contact store manages reading and writing contact metadata 9 9 + using XDG-compliant storage locations. Contacts are stored as 10 10 + YAML files (one per contact) using the handle as the filename. *) 11 11 + 12 12 + module Contact = Sortal_schema.Contact 13 13 + module Temporal = Sortal_schema.Temporal 14 14 + 15 15 + type t 16 16 + 17 17 + (** [create fs app_name] creates a new contact store. 18 18 + 19 19 + The store will use XDG data directories for persistent storage 20 20 + of contact metadata. Each contact is stored as a separate YAML 21 21 + file named after its handle. 22 22 + 23 23 + @param fs Eio filesystem for file operations 24 24 + @param app_name Application name for XDG directory structure *) 25 25 + val create : Eio.Fs.dir_ty Eio.Path.t -> string -> t 26 26 + 27 27 + (** [create_from_xdg xdg] creates a contact store from an XDG context. 28 28 + 29 29 + This is a convenience function for creating a store when you already 30 30 + have an XDG context (e.g., from your own XDG initialization). 31 31 + The store will use the XDG data directory for the application. 32 32 + 33 33 + @param xdg An existing XDG context 34 34 + @return A contact store using the XDG data directory *) 35 35 + val create_from_xdg : Xdge.t -> t 36 36 + 37 37 + (** {1 Storage Operations} *) 38 38 + 39 39 + (** [save t contact] saves a contact to the store. 40 40 + 41 41 + The contact is serialized to YAML and written to a file 42 42 + named "handle.yaml" in the XDG data directory. 43 43 + 44 44 + If a contact with the same handle already exists, it is overwritten. *) 45 45 + val save : t -> Contact.t -> unit 46 46 + 47 47 + (** [lookup t handle] retrieves a contact by handle. 48 48 + 49 49 + Searches for a file named "handle.yaml" in the XDG data directory 50 50 + and deserializes it if found. 51 51 + 52 52 + @return [Some contact] if found, [None] if not found or deserialization fails *) 53 53 + val lookup : t -> string -> Contact.t option 54 54 + 55 55 + (** [delete t handle] removes a contact from the store. 56 56 + 57 57 + Deletes the file "handle.yaml" from the XDG data directory. 58 58 + Does nothing if the contact does not exist. *) 59 59 + val delete : t -> string -> unit 60 60 + 61 61 + (** {1 Contact Modification} *) 62 62 + 63 63 + (** [add_email t handle email] adds an email to an existing contact. 64 64 + 65 65 + @param t The store 66 66 + @param handle The contact handle 67 67 + @param email The email entry to add 68 68 + @return [Ok ()] on success, [Error msg] if contact not found 69 69 + @raise Failure if the contact cannot be saved *) 70 70 + val add_email : t -> string -> Contact.email -> (unit, string) result 71 71 + 72 72 + (** [remove_email t handle address] removes an email from a contact. 73 73 + 74 74 + Removes all email entries with the given address. 75 75 + 76 76 + @param t The store 77 77 + @param handle The contact handle 78 78 + @param address The email address to remove 79 79 + @return [Ok ()] on success, [Error msg] if contact not found *) 80 80 + val remove_email : t -> string -> string -> (unit, string) result 81 81 + 82 82 + (** [add_service t handle service] adds a service to an existing contact. 83 83 + 84 84 + @param t The store 85 85 + @param handle The contact handle 86 86 + @param service The service entry to add 87 87 + @return [Ok ()] on success, [Error msg] if contact not found *) 88 88 + val add_service : t -> string -> Contact.service -> (unit, string) result 89 89 + 90 90 + (** [remove_service t handle url] removes a service from a contact. 91 91 + 92 92 + Removes all service entries with the given URL. 93 93 + 94 94 + @param t The store 95 95 + @param handle The contact handle 96 96 + @param url The service URL to remove 97 97 + @return [Ok ()] on success, [Error msg] if contact not found *) 98 98 + val remove_service : t -> string -> string -> (unit, string) result 99 99 + 100 100 + (** [add_organization t handle org] adds an organization to an existing contact. 101 101 + 102 102 + @param t The store 103 103 + @param handle The contact handle 104 104 + @param org The organization entry to add 105 105 + @return [Ok ()] on success, [Error msg] if contact not found *) 106 106 + val add_organization : t -> string -> Contact.organization -> (unit, string) result 107 107 + 108 108 + (** [remove_organization t handle name] removes an organization from a contact. 109 109 + 110 110 + Removes all organization entries with the given name. 111 111 + 112 112 + @param t The store 113 113 + @param handle The contact handle 114 114 + @param name The organization name to remove 115 115 + @return [Ok ()] on success, [Error msg] if contact not found *) 116 116 + val remove_organization : t -> string -> string -> (unit, string) result 117 117 + 118 118 + (** [add_url t handle url_entry] adds a URL to an existing contact. 119 119 + 120 120 + @param t The store 121 121 + @param handle The contact handle 122 122 + @param url_entry The URL entry to add 123 123 + @return [Ok ()] on success, [Error msg] if contact not found *) 124 124 + val add_url : t -> string -> Contact.url_entry -> (unit, string) result 125 125 + 126 126 + (** [remove_url t handle url] removes a URL from a contact. 127 127 + 128 128 + Removes all URL entries with the given URL. 129 129 + 130 130 + @param t The store 131 131 + @param handle The contact handle 132 132 + @param url The URL to remove 133 133 + @return [Ok ()] on success, [Error msg] if contact not found *) 134 134 + val remove_url : t -> string -> string -> (unit, string) result 135 135 + 136 136 + (** [update_contact t handle f] updates a contact by applying function [f]. 137 137 + 138 138 + Looks up the contact, applies [f] to transform it, and saves the result. 139 139 + 140 140 + @param t The store 141 141 + @param handle The contact handle 142 142 + @param f Function to transform the contact 143 143 + @return [Ok ()] on success, [Error msg] if contact not found *) 144 144 + val update_contact : t -> string -> (Contact.t -> Contact.t) -> (unit, string) result 145 145 + 146 146 + (** [list t] returns all contacts in the store. 147 147 + 148 148 + Scans the XDG data directory for all .yaml files and attempts 149 149 + to deserialize them as contacts. Files that fail to parse are 150 150 + silently skipped. 151 151 + 152 152 + @return A list of all successfully loaded contacts *) 153 153 + val list : t -> Contact.t list 154 154 + 155 155 + (** [thumbnail_path t contact] returns the absolute filesystem path to the contact's thumbnail. 156 156 + 157 157 + Returns [None] if the contact has no thumbnail set, or [Some path] with 158 158 + the full path to the thumbnail file in Sortal's data directory. 159 159 + 160 160 + @param t The Sortal store 161 161 + @param contact The contact whose thumbnail path to retrieve *) 162 162 + val thumbnail_path : t -> Contact.t -> Eio.Fs.dir_ty Eio.Path.t option 163 163 + 164 164 + (** [png_thumbnail_path t contact] returns the path to the PNG version of the contact's thumbnail. 165 165 + 166 166 + Returns [None] if the contact has no thumbnail set or if no PNG version exists. 167 167 + This looks for a .png file with the same base name as the contact's thumbnail. 168 168 + Use this after running [sync] to get the converted PNG thumbnails. 169 169 + 170 170 + @param t The Sortal store 171 171 + @param contact The contact whose PNG thumbnail path to retrieve *) 172 172 + val png_thumbnail_path : t -> Contact.t -> Eio.Fs.dir_ty Eio.Path.t option 173 173 + 174 174 + (** {1 Searching} *) 175 175 + 176 176 + (** [find_by_name t name] searches for contacts by name. 177 177 + 178 178 + Performs a case-insensitive search through all contacts, 179 179 + checking if any of their names match the provided name. 180 180 + 181 181 + @param name The name to search for (case-insensitive) 182 182 + @return The matching contact if exactly one match is found 183 183 + @raise Not_found if no contacts match the name 184 184 + @raise Invalid_argument if multiple contacts match the name *) 185 185 + val find_by_name : t -> string -> Contact.t 186 186 + 187 187 + (** [find_by_name_opt t name] searches for contacts by name, returning an option. 188 188 + 189 189 + Like {!find_by_name} but returns [None] instead of raising exceptions 190 190 + when no match or multiple matches are found. 191 191 + 192 192 + @param name The name to search for (case-insensitive) 193 193 + @return [Some contact] if exactly one match is found, [None] otherwise *) 194 194 + val find_by_name_opt : t -> string -> Contact.t option 195 195 + 196 196 + (** [search_all t query] searches for contacts matching a query string. 197 197 + 198 198 + Performs a flexible search through all contact names, looking for: 199 199 + - Exact matches (case-insensitive) 200 200 + - Names that start with the query 201 201 + - Multi-word names where any word starts with the query 202 202 + 203 203 + This is useful for autocomplete or fuzzy search functionality. 204 204 + 205 205 + @param t The contact store 206 206 + @param query The search query (case-insensitive) 207 207 + @return A list of matching contacts, sorted by handle *) 208 208 + val search_all : t -> string -> Contact.t list 209 209 + 210 210 + (** {1 Temporal Queries} *) 211 211 + 212 212 + (** [find_by_email_at t ~email ~date] finds a contact by email address at a specific date. 213 213 + 214 214 + Searches for a contact that had the given email address valid at [date]. 215 215 + 216 216 + @param email Email address to search for 217 217 + @param date ISO 8601 date string 218 218 + @return The first matching contact, or [None] if not found *) 219 219 + val find_by_email_at : t -> email:string -> date:Temporal.date -> 220 220 + Contact.t option 221 221 + 222 222 + (** [find_by_org t ~org ?from ?until ()] finds contacts who worked at an organization. 223 223 + 224 224 + Searches for contacts whose organization records overlap with the given period. 225 225 + If [from] and [until] are omitted, returns all contacts who ever worked there. 226 226 + 227 227 + @param org Organization name (case-insensitive substring match) 228 228 + @param from Start date of period to check (inclusive, optional) 229 229 + @param until End date of period to check (exclusive, optional) 230 230 + @return List of matching contacts, sorted by handle *) 231 231 + val find_by_org : t -> org:string -> ?from:Temporal.date -> 232 232 + ?until:Temporal.date -> unit -> Contact.t list 233 233 + 234 234 + (** [list_at t ~date] returns contacts that were active at a specific date. 235 235 + 236 236 + A contact is considered active at a date if it has at least one 237 237 + email, organization, or URL valid at that date. 238 238 + 239 239 + @param date ISO 8601 date string 240 240 + @return List of active contacts at that date *) 241 241 + val list_at : t -> date:Temporal.date -> Contact.t list 242 242 + 243 243 + (** {1 Utilities} *) 244 244 + 245 245 + (** [handle_of_name name] generates a handle from a full name. 246 246 + 247 247 + Creates a handle by concatenating the initials of all words 248 248 + in the name with the full last name, all in lowercase. 249 249 + 250 250 + Examples: 251 251 + - "Anil Madhavapeddy" -> "ammadhavapeddy" 252 252 + - "John Smith" -> "jssmith" 253 253 + 254 254 + @param name The full name to convert 255 255 + @return A suggested handle *) 256 256 + val handle_of_name : string -> string 257 257 + 258 258 + (** {1 Pretty Printing} *) 259 259 + 260 260 + (** [pp ppf t] pretty prints the contact store showing statistics. *) 261 261 + val pp : Format.formatter -> t -> unit

+4

sortal/lib/schema/dune

reviewed

··· 1 1 + (library 2 2 + (public_name sortal.schema) 3 3 + (name sortal_schema) 4 4 + (libraries jsont jsont.bytesrw yamlt bytesrw fmt ptime ptime.clock.os))

+14

sortal/lib/schema/sortal_schema.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + module V1 = struct 7 7 + module Temporal = Sortal_schema_temporal 8 8 + module Feed = Sortal_schema_feed 9 9 + module Contact = Sortal_schema_contact_v1 10 10 + end 11 11 + 12 12 + module Temporal = V1.Temporal 13 13 + module Feed = V1.Feed 14 14 + module Contact = V1.Contact

+40

sortal/lib/schema/sortal_schema.mli

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Sortal Schema - Versioned data types and serialization 7 7 + 8 8 + This library provides versioned schema definitions for contact metadata 9 9 + with minimal I/O dependencies. It includes: 10 10 + - Temporal validity support (ISO 8601 dates and ranges) 11 11 + - Feed subscription types 12 12 + - Contact metadata schemas (versioned) 13 13 + 14 14 + The schema library depends on jsont, yamlt, bytesrw, fmt for serialization 15 15 + and formatting, plus ptime and ptime.clock.os for date/time operations. *) 16 16 + 17 17 + (** {1 Schema Version 1} *) 18 18 + 19 19 + module V1 : sig 20 20 + (** Version 1 of the contact schema (current stable version). *) 21 21 + 22 22 + (** Temporal validity support for time-bounded fields. *) 23 23 + module Temporal = Sortal_schema_temporal 24 24 + 25 25 + (** Feed subscription metadata. *) 26 26 + module Feed = Sortal_schema_feed 27 27 + 28 28 + (** Contact metadata with temporal support. *) 29 29 + module Contact = Sortal_schema_contact_v1 30 30 + end 31 31 + 32 32 + (** {1 Current Version Aliases} 33 33 + 34 34 + These aliases point to the current stable schema version (V1). 35 35 + When V2 is introduced, these will continue pointing to V1 for 36 36 + backward compatibility. *) 37 37 + 38 38 + module Temporal = V1.Temporal 39 39 + module Feed = V1.Feed 40 40 + module Contact = V1.Contact

+475

sortal/lib/schema/sortal_schema_contact_v1.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + let version = 1 7 7 + 8 8 + type contact_kind = Person | Organization | Group | Role 9 9 + 10 10 + type service_kind = 11 11 + | ActivityPub 12 12 + | Github 13 13 + | Git 14 14 + | Social 15 15 + | Photo 16 16 + | Custom of string 17 17 + 18 18 + type service = { 19 19 + url: string; 20 20 + kind: service_kind option; 21 21 + handle: string option; 22 22 + label: string option; 23 23 + range: Sortal_schema_temporal.range option; 24 24 + primary: bool; 25 25 + } 26 26 + 27 27 + type email_type = Work | Personal | Other 28 28 + 29 29 + type email = { 30 30 + address: string; 31 31 + type_: email_type option; 32 32 + range: Sortal_schema_temporal.range option; 33 33 + note: string option; 34 34 + } 35 35 + 36 36 + type organization = { 37 37 + name: string; 38 38 + title: string option; 39 39 + department: string option; 40 40 + range: Sortal_schema_temporal.range option; 41 41 + email: string option; 42 42 + url: string option; 43 43 + } 44 44 + 45 45 + type url_entry = { 46 46 + url: string; 47 47 + label: string option; 48 48 + range: Sortal_schema_temporal.range option; 49 49 + } 50 50 + 51 51 + type t = { 52 52 + version: int; 53 53 + kind: contact_kind; 54 54 + handle: string; 55 55 + names: string list; 56 56 + emails: email list; 57 57 + organizations: organization list; 58 58 + urls: url_entry list; 59 59 + services: service list; 60 60 + icon: string option; 61 61 + thumbnail: string option; 62 62 + orcid: string option; 63 63 + feeds: Sortal_schema_feed.t list option; 64 64 + } 65 65 + 66 66 + (* Helpers *) 67 67 + let make_email ?type_ ?from ?until ?note address = 68 68 + let range = match from, until with 69 69 + | None, None -> None 70 70 + | _, _ -> Some (Sortal_schema_temporal.make ?from ?until ()) 71 71 + in 72 72 + { address; type_; range; note } 73 73 + 74 74 + let email_of_string address = 75 75 + { address; type_ = Some Personal; range = None; note = None } 76 76 + 77 77 + let make_org ?title ?department ?from ?until ?email ?url name = 78 78 + let range = match from, until with 79 79 + | None, None -> None 80 80 + | _, _ -> Some (Sortal_schema_temporal.make ?from ?until ()) 81 81 + in 82 82 + { name; title; department; range; email; url } 83 83 + 84 84 + let make_url ?label ?from ?until url = 85 85 + let range = match from, until with 86 86 + | None, None -> None 87 87 + | _, _ -> Some (Sortal_schema_temporal.make ?from ?until ()) 88 88 + in 89 89 + { url; label; range } 90 90 + 91 91 + let url_of_string url = 92 92 + { url; label = None; range = None } 93 93 + 94 94 + let make_service ?kind ?handle ?label ?from ?until ?(primary = false) url = 95 95 + let range = match from, until with 96 96 + | None, None -> None 97 97 + | _, _ -> Some (Sortal_schema_temporal.make ?from ?until ()) 98 98 + in 99 99 + { url; kind; handle; label; range; primary } 100 100 + 101 101 + let service_of_url url = 102 102 + { url; kind = None; handle = None; label = None; range = None; primary = false } 103 103 + 104 104 + let make ~handle ~names ?(kind = Person) ?(emails = []) ?(organizations = []) 105 105 + ?(urls = []) ?(services = []) ?icon ?thumbnail ?orcid ?feeds () = 106 106 + { version; kind; handle; names; emails; organizations; urls; services; 107 107 + icon; thumbnail; orcid; feeds } 108 108 + 109 109 + (* Accessors *) 110 110 + let version_of t = t.version 111 111 + let kind t = t.kind 112 112 + let handle t = t.handle 113 113 + let names t = t.names 114 114 + let name t = List.hd t.names 115 115 + let primary_name = name 116 116 + let emails t = t.emails 117 117 + let organizations t = t.organizations 118 118 + let urls t = t.urls 119 119 + let services t = t.services 120 120 + let icon t = t.icon 121 121 + let thumbnail t = t.thumbnail 122 122 + let orcid t = t.orcid 123 123 + let feeds t = t.feeds 124 124 + 125 125 + (* Temporal queries *) 126 126 + let emails_at t ~date = 127 127 + Sortal_schema_temporal.at_date ~get:(fun (e : email) -> e.range) ~date t.emails 128 128 + 129 129 + let email_at t ~date = 130 130 + match emails_at t ~date with 131 131 + | e :: _ -> Some e.address 132 132 + | [] -> None 133 133 + 134 134 + let current_email t = 135 135 + match Sortal_schema_temporal.current ~get:(fun (e : email) -> e.range) t.emails with 136 136 + | Some e -> Some e.address 137 137 + | None -> None 138 138 + 139 139 + let organization_at t ~date = 140 140 + match Sortal_schema_temporal.at_date ~get:(fun (o : organization) -> o.range) ~date t.organizations with 141 141 + | o :: _ -> Some o 142 142 + | [] -> None 143 143 + 144 144 + let current_organization t = 145 145 + Sortal_schema_temporal.current ~get:(fun (o : organization) -> o.range) t.organizations 146 146 + 147 147 + let url_at t ~date = 148 148 + match Sortal_schema_temporal.at_date ~get:(fun (u : url_entry) -> u.range) ~date t.urls with 149 149 + | u :: _ -> Some u.url 150 150 + | [] -> None 151 151 + 152 152 + let current_url t = 153 153 + match Sortal_schema_temporal.current ~get:(fun (u : url_entry) -> u.range) t.urls with 154 154 + | Some u -> Some u.url 155 155 + | None -> None 156 156 + 157 157 + let all_email_addresses t = 158 158 + List.map (fun e -> e.address) t.emails 159 159 + 160 160 + (* Service queries *) 161 161 + let services_of_kind t (kind : service_kind) = 162 162 + List.filter (fun (s : service) -> 163 163 + match (s.kind : service_kind option) with 164 164 + | Some k when k = kind -> true 165 165 + | _ -> false 166 166 + ) t.services 167 167 + 168 168 + let services_at t ~date = 169 169 + Sortal_schema_temporal.at_date ~get:(fun (s : service) -> s.range) ~date t.services 170 170 + 171 171 + let current_services t = 172 172 + List.filter (fun (s : service) -> Sortal_schema_temporal.is_current s.range) t.services 173 173 + 174 174 + let primary_service t (kind : service_kind) = 175 175 + List.find_opt (fun (s : service) -> 176 176 + match (s.kind : service_kind option) with 177 177 + | Some k when k = kind && s.primary -> true 178 178 + | _ -> false 179 179 + ) t.services 180 180 + 181 181 + let best_url t = 182 182 + current_url t 183 183 + |> Option.fold ~none:( 184 184 + match current_services t with 185 185 + | s :: _ -> Some s.url 186 186 + | [] -> current_email t |> Option.map (fun e -> "mailto:" ^ e) 187 187 + ) ~some:Option.some 188 188 + 189 189 + (* Modification *) 190 190 + let add_feed t feed = 191 191 + { t with feeds = Some (feed :: Option.value t.feeds ~default:[]) } 192 192 + 193 193 + let remove_feed t url = 194 194 + { t with feeds = Option.map (List.filter (fun f -> Sortal_schema_feed.url f <> url)) t.feeds } 195 195 + 196 196 + (* Comparison *) 197 197 + let compare a b = String.compare a.handle b.handle 198 198 + 199 199 + (* Type conversions *) 200 200 + let contact_kind_to_string = function 201 201 + | Person -> "person" 202 202 + | Organization -> "organization" 203 203 + | Group -> "group" 204 204 + | Role -> "role" 205 205 + 206 206 + let contact_kind_of_string = function 207 207 + | "person" -> Some Person 208 208 + | "organization" -> Some Organization 209 209 + | "group" -> Some Group 210 210 + | "role" -> Some Role 211 211 + | _ -> None 212 212 + 213 213 + let service_kind_to_string = function 214 214 + | ActivityPub -> "activitypub" 215 215 + | Github -> "github" 216 216 + | Git -> "git" 217 217 + | Social -> "social" 218 218 + | Photo -> "photo" 219 219 + | Custom s -> s 220 220 + 221 221 + let service_kind_of_string s = 222 222 + match String.lowercase_ascii s with 223 223 + | "activitypub" -> Some ActivityPub 224 224 + | "github" -> Some Github 225 225 + | "git" -> Some Git 226 226 + | "social" -> Some Social 227 227 + | "photo" -> Some Photo 228 228 + | "" | "custom" -> None 229 229 + | _ -> Some (Custom s) 230 230 + 231 231 + let email_type_to_string = function 232 232 + | Work -> "work" 233 233 + | Personal -> "personal" 234 234 + | Other -> "other" 235 235 + 236 236 + let email_type_of_string = function 237 237 + | "work" -> Some Work 238 238 + | "personal" -> Some Personal 239 239 + | "other" -> Some Other 240 240 + | _ -> None 241 241 + 242 242 + (* JSON encoding *) 243 243 + 244 244 + (* Helper: case-insensitive enum decoder *) 245 245 + let case_insensitive_enum ~kind:kind_name cases = 246 246 + let open Jsont in 247 247 + let lowercase_cases = List.map (fun (s, v) -> (String.lowercase_ascii s, v)) cases in 248 248 + let dec s = 249 249 + match List.assoc_opt (String.lowercase_ascii s) lowercase_cases with 250 250 + | Some v -> v 251 251 + | None -> failwith ("unknown " ^ kind_name ^ ": " ^ s) 252 252 + in 253 253 + let enc v = 254 254 + match List.find_opt (fun (_, v') -> v = v') cases with 255 255 + | Some (s, _) -> s 256 256 + | None -> failwith ("invalid " ^ kind_name) 257 257 + in 258 258 + let t = map ~kind:kind_name ~dec ~enc string in 259 259 + t 260 260 + 261 261 + let contact_kind_json = 262 262 + case_insensitive_enum ~kind:"ContactKind" [ 263 263 + "person", Person; 264 264 + "organization", Organization; 265 265 + "group", Group; 266 266 + "role", Role; 267 267 + ] 268 268 + 269 269 + let service_json : service Jsont.t = 270 270 + let open Jsont in 271 271 + let open Jsont.Object in 272 272 + let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in 273 273 + (* Convert string option to/from service_kind option *) 274 274 + let dec_kind_opt kind_str = 275 275 + match kind_str with 276 276 + | None -> None 277 277 + | Some s -> service_kind_of_string s 278 278 + in 279 279 + let enc_kind_opt = Option.map service_kind_to_string in 280 280 + let make url kind_str handle label range primary : service = 281 281 + let kind = dec_kind_opt kind_str in 282 282 + { url; kind; handle; label; range; primary } 283 283 + in 284 284 + map ~kind:"Service" make 285 285 + |> mem "url" string ~enc:(fun (s : service) -> s.url) 286 286 + |> mem_opt "kind" (some string) ~enc:(fun (s : service) -> enc_kind_opt s.kind) 287 287 + |> mem_opt "handle" (some string) ~enc:(fun (s : service) -> s.handle) 288 288 + |> mem_opt "label" (some string) ~enc:(fun (s : service) -> s.label) 289 289 + |> mem_opt "range" (some Sortal_schema_temporal.json_t) ~enc:(fun (s : service) -> s.range) 290 290 + |> mem "primary" bool ~dec_absent:false ~enc:(fun (s : service) -> s.primary) 291 291 + |> finish 292 292 + 293 293 + let email_type_json = 294 294 + case_insensitive_enum ~kind:"EmailType" [ 295 295 + "work", Work; 296 296 + "personal", Personal; 297 297 + "other", Other; 298 298 + ] 299 299 + 300 300 + let email_json : email Jsont.t = 301 301 + let open Jsont in 302 302 + let open Jsont.Object in 303 303 + let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in 304 304 + let make address type_ range note : email = { address; type_; range; note } in 305 305 + map ~kind:"Email" make 306 306 + |> mem "address" string ~enc:(fun (e : email) -> e.address) 307 307 + |> mem_opt "type" (some email_type_json) ~enc:(fun (e : email) -> e.type_) 308 308 + |> mem_opt "range" (some Sortal_schema_temporal.json_t) ~enc:(fun (e : email) -> e.range) 309 309 + |> mem_opt "note" (some string) ~enc:(fun (e : email) -> e.note) 310 310 + |> finish 311 311 + 312 312 + let organization_json : organization Jsont.t = 313 313 + let open Jsont in 314 314 + let open Jsont.Object in 315 315 + let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in 316 316 + let make name title department range email url : organization = 317 317 + { name; title; department; range; email; url } 318 318 + in 319 319 + map ~kind:"Organization" make 320 320 + |> mem "name" string ~enc:(fun (o : organization) -> o.name) 321 321 + |> mem_opt "title" (some string) ~enc:(fun (o : organization) -> o.title) 322 322 + |> mem_opt "department" (some string) ~enc:(fun (o : organization) -> o.department) 323 323 + |> mem_opt "range" (some Sortal_schema_temporal.json_t) ~enc:(fun (o : organization) -> o.range) 324 324 + |> mem_opt "email" (some string) ~enc:(fun (o : organization) -> o.email) 325 325 + |> mem_opt "url" (some string) ~enc:(fun (o : organization) -> o.url) 326 326 + |> finish 327 327 + 328 328 + let url_entry_json : url_entry Jsont.t = 329 329 + let open Jsont in 330 330 + let open Jsont.Object in 331 331 + let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in 332 332 + let make url label range : url_entry = { url; label; range } in 333 333 + map ~kind:"URL" make 334 334 + |> mem "url" string ~enc:(fun (u : url_entry) -> u.url) 335 335 + |> mem_opt "label" (some string) ~enc:(fun (u : url_entry) -> u.label) 336 336 + |> mem_opt "range" (some Sortal_schema_temporal.json_t) ~enc:(fun (u : url_entry) -> u.range) 337 337 + |> finish 338 338 + 339 339 + let json_t = 340 340 + let open Jsont in 341 341 + let open Jsont.Object in 342 342 + let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in 343 343 + let make version kind handle names emails organizations urls services 344 344 + icon thumbnail orcid feeds = 345 345 + if version <> 1 then 346 346 + failwith (Printf.sprintf "Unsupported contact schema version: %d" version); 347 347 + { version; kind; handle; names; emails; organizations; urls; services; 348 348 + icon; thumbnail; orcid; feeds } 349 349 + in 350 350 + map ~kind:"Contact" make 351 351 + |> mem "version" int ~enc:(fun _ -> 1) 352 352 + |> mem "kind" contact_kind_json ~dec_absent:Person ~enc:(fun c -> c.kind) 353 353 + |> mem "handle" string ~enc:(fun c -> c.handle) 354 354 + |> mem "names" (list string) ~dec_absent:[] ~enc:(fun c -> c.names) 355 355 + |> mem "emails" (list email_json) ~dec_absent:[] ~enc:(fun c -> c.emails) 356 356 + |> mem "organizations" (list organization_json) ~dec_absent:[] ~enc:(fun c -> c.organizations) 357 357 + |> mem "urls" (list url_entry_json) ~dec_absent:[] ~enc:(fun c -> c.urls) 358 358 + |> mem "services" (list service_json) ~dec_absent:[] ~enc:(fun c -> c.services) 359 359 + |> mem_opt "icon" (some string) ~enc:(fun c -> c.icon) 360 360 + |> mem_opt "thumbnail" (some string) ~enc:(fun c -> c.thumbnail) 361 361 + |> mem_opt "orcid" (some string) ~enc:(fun c -> c.orcid) 362 362 + |> mem_opt "feeds" (some (list Sortal_schema_feed.json_t)) ~enc:(fun c -> c.feeds) 363 363 + |> finish 364 364 + 365 365 + (* Pretty printing *) 366 366 + let pp ppf t = 367 367 + let open Fmt in 368 368 + let label = styled (`Fg `Cyan) string in 369 369 + let url_style = styled (`Fg `Blue) in 370 370 + let date_style = styled (`Fg `Green) in 371 371 + let field lbl fmt_v = Option.iter (fun v -> pf ppf "%a: %a@," label lbl fmt_v v) in 372 372 + 373 373 + let pp_range ppf = function 374 374 + | None -> () 375 375 + | Some { Sortal_schema_temporal.from; until } -> 376 376 + match from, until with 377 377 + | Some f, Some u -> 378 378 + let fs = Sortal_schema_temporal.format_date f in 379 379 + let us = Sortal_schema_temporal.format_date u in 380 380 + pf ppf " %a" (date_style string) (Printf.sprintf "[%s to %s]" fs us) 381 381 + | Some f, None -> 382 382 + let fs = Sortal_schema_temporal.format_date f in 383 383 + pf ppf " %a" (date_style string) (Printf.sprintf "[from %s]" fs) 384 384 + | None, Some u -> 385 385 + let us = Sortal_schema_temporal.format_date u in 386 386 + pf ppf " %a" (date_style string) (Printf.sprintf "[until %s]" us) 387 387 + | None, None -> () 388 388 + in 389 389 + 390 390 + pf ppf "@[<v>"; 391 391 + pf ppf "%a: %a@," label "Handle" (styled `Bold (fun ppf s -> pf ppf "@%s" s)) t.handle; 392 392 + 393 393 + (* Show kind if not a person *) 394 394 + (match t.kind with 395 395 + | Person -> () 396 396 + | k -> pf ppf "%a: %a@," label "Kind" (styled (`Fg `Magenta) string) (contact_kind_to_string k)); 397 397 + 398 398 + pf ppf "%a: %a@," label "Name" (styled `Bold string) (name t); 399 399 + 400 400 + if List.length (names t) > 1 then 401 401 + pf ppf "%a: @[<h>%a@]@," label "Aliases" 402 402 + (list ~sep:comma string) (List.tl (names t)); 403 403 + 404 404 + (* Emails with temporal info *) 405 405 + if emails t <> [] then begin 406 406 + pf ppf "%a:@," label "Emails"; 407 407 + List.iter (fun e -> 408 408 + pf ppf " %a%s%s%a%a@," 409 409 + (styled (`Fg `Yellow) string) e.address 410 410 + (match e.type_ with Some Work -> " (work)" | Some Personal -> " (personal)" | Some Other -> " (other)" | None -> "") 411 411 + (match e.note with Some n -> " - " ^ n | None -> "") 412 412 + pp_range e.range 413 413 + (fun ppf current -> if current then pf ppf " %a" (styled (`Fg `Magenta) string) "[current]" else ()) 414 414 + (Sortal_schema_temporal.is_current e.range) 415 415 + ) (emails t) 416 416 + end; 417 417 + 418 418 + (* Organizations with temporal info *) 419 419 + if organizations t <> [] then begin 420 420 + pf ppf "%a:@," label "Organizations"; 421 421 + List.iter (fun o -> 422 422 + pf ppf " %a" (styled `Bold string) o.name; 423 423 + Option.iter (fun title -> pf ppf " - %s" title) o.title; 424 424 + Option.iter (fun dept -> pf ppf " (%s)" dept) o.department; 425 425 + pf ppf "%a" pp_range o.range; 426 426 + if Sortal_schema_temporal.is_current o.range then 427 427 + pf ppf " %a" (styled (`Fg `Magenta) string) "[current]"; 428 428 + pf ppf "@,"; 429 429 + Option.iter (fun email -> pf ppf " Email: %a@," (styled (`Fg `Yellow) string) email) o.email; 430 430 + Option.iter (fun url -> pf ppf " URL: %a@," (url_style string) url) o.url; 431 431 + ) (organizations t) 432 432 + end; 433 433 + 434 434 + (* URLs *) 435 435 + if urls t <> [] then begin 436 436 + pf ppf "%a:@," label "URLs"; 437 437 + List.iter (fun u -> 438 438 + pf ppf " %a" (url_style string) u.url; 439 439 + Option.iter (fun lbl -> pf ppf " (%s)" lbl) u.label; 440 440 + pf ppf "%a" pp_range u.range; 441 441 + if Sortal_schema_temporal.is_current u.range then 442 442 + pf ppf " %a" (styled (`Fg `Magenta) string) "[current]"; 443 443 + pf ppf "@," 444 444 + ) (urls t) 445 445 + end; 446 446 + 447 447 + (* Services *) 448 448 + if services t <> [] then begin 449 449 + pf ppf "%a:@," label "Services"; 450 450 + List.iter (fun (s : service) -> 451 451 + pf ppf " %a" (url_style string) s.url; 452 452 + Option.iter (fun k -> pf ppf " (%s)" (service_kind_to_string k)) s.kind; 453 453 + Option.iter (fun h -> pf ppf " [@%s]" h) s.handle; 454 454 + Option.iter (fun lbl -> pf ppf " - %s" lbl) s.label; 455 455 + pf ppf "%a" pp_range s.range; 456 456 + if s.primary then pf ppf " %a" (styled (`Fg `Yellow) string) "[primary]"; 457 457 + if Sortal_schema_temporal.is_current s.range then 458 458 + pf ppf " %a" (styled (`Fg `Magenta) string) "[current]"; 459 459 + pf ppf "@," 460 460 + ) (services t) 461 461 + end; 462 462 + 463 463 + field "ORCID" (url_style (fun ppf o -> pf ppf "https://orcid.org/%s" o)) t.orcid; 464 464 + 465 465 + field "Icon" (url_style string) t.icon; 466 466 + field "Thumbnail" (styled (`Fg `White) string) t.thumbnail; 467 467 + 468 468 + Option.iter (function 469 469 + | [] -> () 470 470 + | feeds -> 471 471 + pf ppf "%a:@," label "Feeds"; 472 472 + List.iter (fun feed -> pf ppf " - %a@," Sortal_schema_feed.pp feed) feeds 473 473 + ) t.feeds; 474 474 + 475 475 + pf ppf "@]"

+277

sortal/lib/schema/sortal_schema_contact_v1.mli

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Contact schema V1 with temporal support. 7 7 + 8 8 + This module defines the V1 contact schema with support for time-bounded 9 9 + information such as emails and organizations that are valid only during 10 10 + specific periods. 11 11 + 12 12 + {b Schema Version Policy:} 13 13 + - New optional fields can be added without bumping the version 14 14 + - The version must be bumped only if the {i meaning} of an existing 15 15 + field changes 16 16 + - This allows forward compatibility: older readers can ignore new fields *) 17 17 + 18 18 + (** {1 Schema Version} *) 19 19 + 20 20 + val version : int 21 21 + (** The schema version number for V1. Currently [1]. *) 22 22 + 23 23 + (** {1 Types} *) 24 24 + 25 25 + (** Contact kind - what type of entity this represents. *) 26 26 + type contact_kind = 27 27 + | Person (** Individual person *) 28 28 + | Organization (** Company, lab, department *) 29 29 + | Group (** Research group, project team *) 30 30 + | Role (** Generic role email like info@, admin@ *) 31 31 + 32 32 + (** Service kind - categorization of online presence. *) 33 33 + type service_kind = 34 34 + | ActivityPub (** Mastodon, Pixelfed, PeerTube, etc *) 35 35 + | Github (** GitHub *) 36 36 + | Git (** GitLab, Gitea, Codeberg, etc *) 37 37 + | Social (** Twitter/X, LinkedIn, etc *) 38 38 + | Photo (** Immich, Flickr, Instagram, etc *) 39 39 + | Custom of string (** Other service types *) 40 40 + 41 41 + (** An online service/identity. *) 42 42 + type service = { 43 43 + url: string; (** Full URL (primary identifier) *) 44 44 + kind: service_kind option; (** Optional service categorization *) 45 45 + handle: string option; (** Optional short handle/username *) 46 46 + label: string option; (** Human description: "Cambridge GitLab", "Work account" *) 47 47 + range: Sortal_schema_temporal.range option; (** Temporal validity *) 48 48 + primary: bool; (** Is this the primary/preferred service of its kind? *) 49 49 + } 50 50 + 51 51 + type email_type = Work | Personal | Other 52 52 + 53 53 + type email = { 54 54 + address: string; 55 55 + type_: email_type option; 56 56 + range: Sortal_schema_temporal.range option; (** Validity period *) 57 57 + note: string option; (** Context note, e.g., "NetApp position" *) 58 58 + } 59 59 + 60 60 + type organization = { 61 61 + name: string; 62 62 + title: string option; 63 63 + department: string option; 64 64 + range: Sortal_schema_temporal.range option; (** Employment period *) 65 65 + email: string option; (** Work email during this period *) 66 66 + url: string option; (** Work homepage during this period *) 67 67 + } 68 68 + 69 69 + type url_entry = { 70 70 + url: string; 71 71 + label: string option; (** Human-readable label *) 72 72 + range: Sortal_schema_temporal.range option; (** Validity period *) 73 73 + } 74 74 + 75 75 + type t = { 76 76 + version: int; (** Schema version (always 1 for V1) *) 77 77 + kind: contact_kind; (** Type of entity (Person, Organization, etc) *) 78 78 + handle: string; (** Unique identifier *) 79 79 + names: string list; (** Names, first is primary *) 80 80 + 81 81 + (* Temporal fields *) 82 82 + emails: email list; (** Email addresses with temporal validity *) 83 83 + organizations: organization list; (** Employment/affiliation history *) 84 84 + urls: url_entry list; (** URLs with optional temporal validity *) 85 85 + services: service list; (** Online services/identities *) 86 86 + 87 87 + (* Simple fields - rarely change over time *) 88 88 + icon: string option; (** Avatar URL *) 89 89 + thumbnail: string option; (** Local thumbnail path *) 90 90 + orcid: string option; (** ORCID identifier *) 91 91 + 92 92 + (* Other *) 93 93 + feeds: Sortal_schema_feed.t list option; (** Feed subscriptions *) 94 94 + } 95 95 + 96 96 + (** {1 Construction} *) 97 97 + 98 98 + (** [make ~handle ~names ?kind ?emails ?organizations ?urls ?services 99 99 + ?icon ?thumbnail ?orcid ?feeds ()] 100 100 + creates a new V1 contact. 101 101 + 102 102 + The [version] field is automatically set to [1]. 103 103 + The [kind] defaults to [Person] if not specified. *) 104 104 + val make : 105 105 + handle:string -> 106 106 + names:string list -> 107 107 + ?kind:contact_kind -> 108 108 + ?emails:email list -> 109 109 + ?organizations:organization list -> 110 110 + ?urls:url_entry list -> 111 111 + ?services:service list -> 112 112 + ?icon:string -> 113 113 + ?thumbnail:string -> 114 114 + ?orcid:string -> 115 115 + ?feeds:Sortal_schema_feed.t list -> 116 116 + unit -> 117 117 + t 118 118 + 119 119 + (** {1 Email Helpers} *) 120 120 + 121 121 + (** [make_email ?type_ ?from ?until ?note address] creates an email entry. 122 122 + 123 123 + @param type_ Email type (Work, Personal, Other) 124 124 + @param from Start date of validity 125 125 + @param until End date of validity (exclusive) 126 126 + @param note Contextual note *) 127 127 + val make_email : 128 128 + ?type_:email_type -> 129 129 + ?from:Sortal_schema_temporal.date -> 130 130 + ?until:Sortal_schema_temporal.date -> 131 131 + ?note:string -> 132 132 + string -> 133 133 + email 134 134 + 135 135 + (** [email_of_string s] creates a simple always-valid personal email. *) 136 136 + val email_of_string : string -> email 137 137 + 138 138 + (** {1 Organization Helpers} *) 139 139 + 140 140 + (** [make_org ?title ?department ?from ?until ?email ?url name] 141 141 + creates an organization entry. *) 142 142 + val make_org : 143 143 + ?title:string -> 144 144 + ?department:string -> 145 145 + ?from:Sortal_schema_temporal.date -> 146 146 + ?until:Sortal_schema_temporal.date -> 147 147 + ?email:string -> 148 148 + ?url:string -> 149 149 + string -> 150 150 + organization 151 151 + 152 152 + (** {1 URL Helpers} *) 153 153 + 154 154 + (** [make_url ?label ?from ?until url] creates a URL entry. *) 155 155 + val make_url : 156 156 + ?label:string -> 157 157 + ?from:Sortal_schema_temporal.date -> 158 158 + ?until:Sortal_schema_temporal.date -> 159 159 + string -> 160 160 + url_entry 161 161 + 162 162 + (** [url_of_string s] creates a simple always-valid URL. *) 163 163 + val url_of_string : string -> url_entry 164 164 + 165 165 + (** {1 Service Helpers} *) 166 166 + 167 167 + (** [make_service ?kind ?handle ?label ?from ?until ?primary url] 168 168 + creates a service entry. 169 169 + 170 170 + @param kind Optional service categorization 171 171 + @param handle Optional short handle/username 172 172 + @param label Optional description (e.g., "Work account", "Cambridge GitLab") 173 173 + @param from Start date of validity 174 174 + @param until End date of validity (exclusive) 175 175 + @param primary Whether this is the primary service of its kind 176 176 + @param url Full URL to the service (required) *) 177 177 + val make_service : 178 178 + ?kind:service_kind -> 179 179 + ?handle:string -> 180 180 + ?label:string -> 181 181 + ?from:Sortal_schema_temporal.date -> 182 182 + ?until:Sortal_schema_temporal.date -> 183 183 + ?primary:bool -> 184 184 + string -> 185 185 + service 186 186 + 187 187 + (** [service_of_url url] creates a simple always-valid service from just a URL. *) 188 188 + val service_of_url : string -> service 189 189 + 190 190 + (** {1 Accessors} *) 191 191 + 192 192 + val version_of : t -> int 193 193 + val kind : t -> contact_kind 194 194 + val handle : t -> string 195 195 + val names : t -> string list 196 196 + val name : t -> string 197 197 + val primary_name : t -> string 198 198 + val emails : t -> email list 199 199 + val organizations : t -> organization list 200 200 + val urls : t -> url_entry list 201 201 + val services : t -> service list 202 202 + val icon : t -> string option 203 203 + val thumbnail : t -> string option 204 204 + val orcid : t -> string option 205 205 + val feeds : t -> Sortal_schema_feed.t list option 206 206 + 207 207 + (** {1 Temporal Queries} *) 208 208 + 209 209 + (** [email_at t ~date] returns the primary email valid at [date]. *) 210 210 + val email_at : t -> date:Sortal_schema_temporal.date -> string option 211 211 + 212 212 + (** [emails_at t ~date] returns all emails valid at [date]. *) 213 213 + val emails_at : t -> date:Sortal_schema_temporal.date -> email list 214 214 + 215 215 + (** [current_email t] returns the current primary email. *) 216 216 + val current_email : t -> string option 217 217 + 218 218 + (** [organization_at t ~date] returns the organization at [date]. *) 219 219 + val organization_at : t -> date:Sortal_schema_temporal.date -> organization option 220 220 + 221 221 + (** [current_organization t] returns the current organization. *) 222 222 + val current_organization : t -> organization option 223 223 + 224 224 + (** [url_at t ~date] returns the primary URL valid at [date]. *) 225 225 + val url_at : t -> date:Sortal_schema_temporal.date -> string option 226 226 + 227 227 + (** [current_url t] returns the current primary URL. *) 228 228 + val current_url : t -> string option 229 229 + 230 230 + (** [all_email_addresses t] returns all email addresses (any period). *) 231 231 + val all_email_addresses : t -> string list 232 232 + 233 233 + (** [best_url t] returns the best available URL (current URL or service fallback). *) 234 234 + val best_url : t -> string option 235 235 + 236 236 + (** {1 Service Queries} *) 237 237 + 238 238 + (** [services_of_kind t kind] returns all services matching the given kind. *) 239 239 + val services_of_kind : t -> service_kind -> service list 240 240 + 241 241 + (** [services_at t ~date] returns all services valid at [date]. *) 242 242 + val services_at : t -> date:Sortal_schema_temporal.date -> service list 243 243 + 244 244 + (** [current_services t] returns all currently valid services. *) 245 245 + val current_services : t -> service list 246 246 + 247 247 + (** [primary_service t kind] returns the primary service of the given kind. *) 248 248 + val primary_service : t -> service_kind -> service option 249 249 + 250 250 + (** {1 Modification} *) 251 251 + 252 252 + val add_feed : t -> Sortal_schema_feed.t -> t 253 253 + val remove_feed : t -> string -> t 254 254 + 255 255 + (** {1 Comparison and Display} *) 256 256 + 257 257 + val compare : t -> t -> int 258 258 + val pp : Format.formatter -> t -> unit 259 259 + 260 260 + (** {1 JSON Encoding} *) 261 261 + 262 262 + (** [json_t] is the jsont encoder/decoder for V1 contacts. 263 263 + 264 264 + The schema includes a [version] field that is always encoded and 265 265 + must equal [1] when decoded. *) 266 266 + val json_t : t Jsont.t 267 267 + 268 268 + (** {1 Type Utilities} *) 269 269 + 270 270 + val contact_kind_to_string : contact_kind -> string 271 271 + val contact_kind_of_string : string -> contact_kind option 272 272 + 273 273 + val service_kind_to_string : service_kind -> string 274 274 + val service_kind_of_string : string -> service_kind option 275 275 + 276 276 + val email_type_to_string : email_type -> string 277 277 + val email_type_of_string : string -> email_type option

+57

sortal/lib/schema/sortal_schema_feed.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + type feed_type = 7 7 + | Atom 8 8 + | Rss 9 9 + | Json 10 10 + 11 11 + type t = { 12 12 + feed_type : feed_type; 13 13 + url : string; 14 14 + name : string option; 15 15 + } 16 16 + 17 17 + let make ~feed_type ~url ?name () = 18 18 + { feed_type; url; name } 19 19 + 20 20 + let feed_type t = t.feed_type 21 21 + let url t = t.url 22 22 + let name t = t.name 23 23 + 24 24 + let set_name t name = { t with name = Some name } 25 25 + 26 26 + let feed_type_to_string = function 27 27 + | Atom -> "atom" 28 28 + | Rss -> "rss" 29 29 + | Json -> "json" 30 30 + 31 31 + let feed_type_of_string s = 32 32 + match String.lowercase_ascii s with 33 33 + | "atom" -> Some Atom 34 34 + | "rss" -> Some Rss 35 35 + | "json" -> Some Json 36 36 + | _ -> None 37 37 + 38 38 + let json_t = 39 39 + let open Jsont in 40 40 + let open Jsont.Object in 41 41 + let make feed_type url name = 42 42 + match feed_type_of_string feed_type with 43 43 + | Some ft -> { feed_type = ft; url; name } 44 44 + | None -> failwith ("Invalid feed type: " ^ feed_type) 45 45 + in 46 46 + map ~kind:"Feed" make 47 47 + |> mem "type" string ~enc:(fun f -> feed_type_to_string f.feed_type) 48 48 + |> mem "url" string ~enc:(fun f -> f.url) 49 49 + |> opt_mem "name" string ~enc:(fun f -> f.name) 50 50 + |> finish 51 51 + 52 52 + let pp ppf t = 53 53 + let open Fmt in 54 54 + pf ppf "%a: %a%a" 55 55 + (styled (`Fg `Green) string) (feed_type_to_string t.feed_type) 56 56 + (styled (`Fg `Blue) string) t.url 57 57 + (option (fun ppf name -> pf ppf " (%a)" (styled `Faint string) name)) t.name

+48

sortal/lib/schema/sortal_schema_feed.mli

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Feed subscription with type and URL. 7 7 + 8 8 + A feed represents a subscription to a content source (Atom, RSS, or JSONFeed). *) 9 9 + 10 10 + type t 11 11 + 12 12 + (** Feed type identifier. *) 13 13 + type feed_type = 14 14 + | Atom (** Atom feed format *) 15 15 + | Rss (** RSS feed format *) 16 16 + | Json (** JSON Feed format *) 17 17 + 18 18 + (** [make ~feed_type ~url ?name ()] creates a new feed. 19 19 + 20 20 + @param feed_type The type of feed (Atom, RSS, or JSON) 21 21 + @param url The feed URL 22 22 + @param name Optional human-readable name/label for the feed *) 23 23 + val make : feed_type:feed_type -> url:string -> ?name:string -> unit -> t 24 24 + 25 25 + (** [feed_type t] returns the feed type. *) 26 26 + val feed_type : t -> feed_type 27 27 + 28 28 + (** [url t] returns the feed URL. *) 29 29 + val url : t -> string 30 30 + 31 31 + (** [name t] returns the feed name if set. *) 32 32 + val name : t -> string option 33 33 + 34 34 + (** [set_name t name] returns a new feed with the name updated. *) 35 35 + val set_name : t -> string -> t 36 36 + 37 37 + (** [feed_type_to_string ft] converts a feed type to a string. *) 38 38 + val feed_type_to_string : feed_type -> string 39 39 + 40 40 + (** [feed_type_of_string s] parses a feed type from a string. 41 41 + Returns [None] if the string is not recognized. *) 42 42 + val feed_type_of_string : string -> feed_type option 43 43 + 44 44 + (** [json_t] is the jsont encoder/decoder for feeds. *) 45 45 + val json_t : t Jsont.t 46 46 + 47 47 + (** [pp ppf t] pretty prints a feed. *) 48 48 + val pp : Format.formatter -> t -> unit

+135

sortal/lib/schema/sortal_schema_temporal.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + type date = Ptime.date 7 7 + 8 8 + type range = { 9 9 + from: date option; 10 10 + until: date option; 11 11 + } 12 12 + 13 13 + let make ?from ?until () = { from; until } 14 14 + 15 15 + let always = { from = None; until = None } 16 16 + 17 17 + (* Compare Ptime dates (year, month, day tuples) *) 18 18 + let date_compare ((y1, m1, d1) : date) ((y2, m2, d2) : date) : int = 19 19 + match compare y1 y2 with 20 20 + | 0 -> ( 21 21 + match compare m1 m2 with 22 22 + | 0 -> compare d1 d2 23 23 + | c -> c) 24 24 + | c -> c 25 25 + 26 26 + let date_gte d1 d2 = date_compare d1 d2 >= 0 27 27 + 28 28 + let valid_at range_opt ~date = 29 29 + match range_opt with 30 30 + | None -> true (* No range = always valid *) 31 31 + | Some { from; until } -> 32 32 + let after_start = match from with 33 33 + | None -> true 34 34 + | Some f -> date_gte date f 35 35 + in 36 36 + let before_end = match until with 37 37 + | None -> true 38 38 + | Some u -> date_compare date u < 0 (* until is exclusive *) 39 39 + in 40 40 + after_start && before_end 41 41 + 42 42 + let overlaps r1 r2 = 43 43 + (* Two ranges overlap if neither ends before the other starts *) 44 44 + let r1_starts_before_r2_ends = match r2.until with 45 45 + | None -> true 46 46 + | Some u2 -> match r1.from with 47 47 + | None -> true 48 48 + | Some f1 -> date_compare f1 u2 < 0 49 49 + in 50 50 + let r2_starts_before_r1_ends = match r1.until with 51 51 + | None -> true 52 52 + | Some u1 -> match r2.from with 53 53 + | None -> true 54 54 + | Some f2 -> date_compare f2 u1 < 0 55 55 + in 56 56 + r1_starts_before_r2_ends && r2_starts_before_r1_ends 57 57 + 58 58 + let today () = 59 59 + Ptime_clock.now () |> Ptime.to_date 60 60 + 61 61 + let is_current range_opt = 62 62 + valid_at range_opt ~date:(today ()) 63 63 + 64 64 + let current ~get list = 65 65 + (* Find first currently valid item, or first item without temporal bounds *) 66 66 + let current_items = List.filter (fun item -> is_current (get item)) list in 67 67 + match current_items with 68 68 + | x :: _ -> Some x 69 69 + | [] -> 70 70 + (* No current items, try to find one without temporal bounds *) 71 71 + List.find_opt (fun item -> get item = None) list 72 72 + 73 73 + let at_date ~get ~date list = 74 74 + List.filter (fun item -> valid_at (get item) ~date) list 75 75 + 76 76 + let filter ~get ~from ~until list = 77 77 + let query_range = { from; until } in 78 78 + List.filter (fun item -> 79 79 + match get item with 80 80 + | None -> true (* Items without range match all queries *) 81 81 + | Some r -> overlaps r query_range 82 82 + ) list 83 83 + 84 84 + (* Parse ISO 8601 date string to Ptime.date, handling partial dates *) 85 85 + let parse_date_string (s : string) : date option = 86 86 + match String.split_on_char '-' s with 87 87 + | [year_s] -> ( 88 88 + try 89 89 + let year = int_of_string year_s in 90 90 + Some (year, 1, 1) (* Year only → January 1st *) 91 91 + with Failure _ -> None) 92 92 + | [year_s; month_s] -> ( 93 93 + try 94 94 + let year = int_of_string year_s in 95 95 + let month = int_of_string month_s in 96 96 + if month >= 1 && month <= 12 then 97 97 + Some (year, month, 1) (* Year-Month → 1st of month *) 98 98 + else None 99 99 + with Failure _ -> None) 100 100 + | [year_s; month_s; day_s] -> ( 101 101 + try 102 102 + let year = int_of_string year_s in 103 103 + let month = int_of_string month_s in 104 104 + let day = int_of_string day_s in 105 105 + if month >= 1 && month <= 12 && day >= 1 && day <= 31 then 106 106 + Some (year, month, day) 107 107 + else None 108 108 + with Failure _ -> None) 109 109 + | _ -> None 110 110 + 111 111 + (* Format Ptime.date as ISO 8601 string YYYY-MM-DD *) 112 112 + let format_date ((year, month, day) : date) : string = 113 113 + Printf.sprintf "%04d-%02d-%02d" year month day 114 114 + 115 115 + let json_t = 116 116 + let open Jsont in 117 117 + let open Jsont.Object in 118 118 + let mem_opt f v ~enc = mem f v ~dec_absent:None ~enc_omit:Option.is_none ~enc in 119 119 + 120 120 + (* Create a jsont type for date that converts between string and Ptime.date *) 121 121 + let date_jsont = 122 122 + let dec meta s = 123 123 + match parse_date_string s with 124 124 + | Some d -> d 125 125 + | None -> Error.msgf meta "TemporalDate: invalid ISO 8601 date: %S" s 126 126 + in 127 127 + let enc = format_date in 128 128 + Base.string (Base.map ~kind:"TemporalDate" ~dec ~enc ()) 129 129 + in 130 130 + 131 131 + let make_range from until = { from; until } in 132 132 + map ~kind:"TemporalRange" make_range 133 133 + |> mem_opt "from" (some date_jsont) ~enc:(fun r -> r.from) 134 134 + |> mem_opt "until" (some date_jsont) ~enc:(fun r -> r.until) 135 135 + |> finish

+98

sortal/lib/schema/sortal_schema_temporal.mli

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Temporal validity support for contact fields. 7 7 + 8 8 + This module provides types and functions for managing time-bounded 9 9 + information in contacts, such as emails valid only during certain 10 10 + employment periods. *) 11 11 + 12 12 + (** Date represented as a Ptime.date tuple (year, month, day). 13 13 + 14 14 + When parsing from strings, partial dates are normalized: 15 15 + - Year: ["2001"] → (2001, 1, 1) 16 16 + - Year-Month: ["2001-01"] → (2001, 1, 1) 17 17 + - Full date: ["2001-01-15"] → (2001, 1, 15) *) 18 18 + type date = Ptime.date 19 19 + 20 20 + (** {1 Date Conversion} *) 21 21 + 22 22 + (** [parse_date_string s] parses an ISO 8601 date string. 23 23 + 24 24 + Accepts various formats with partial date support: 25 25 + - "2001" (year only) → (2001, 1, 1) 26 26 + - "2001-01" (year-month) → (2001, 1, 1) 27 27 + - "2001-01-15" (full date) → (2001, 1, 15) 28 28 + 29 29 + Returns [None] if the string is not a valid date format. *) 30 30 + val parse_date_string : string -> date option 31 31 + 32 32 + (** [format_date date] formats a date as ISO 8601 (YYYY-MM-DD). 33 33 + 34 34 + {b Example:} [format_date (2001, 1, 15)] returns ["2001-01-15"] *) 35 35 + val format_date : date -> string 36 36 + 37 37 + (** {1 Temporal Ranges} *) 38 38 + 39 39 + (** A temporal range indicating validity period. *) 40 40 + type range = { 41 41 + from: date option; (** Start date (inclusive). [None] means from the beginning. *) 42 42 + until: date option; (** End date (exclusive). [None] means continuing/indefinite. *) 43 43 + } 44 44 + 45 45 + (** {1 Range Construction} *) 46 46 + 47 47 + (** [make ?from ?until ()] creates a temporal range. *) 48 48 + val make : ?from:date -> ?until:date -> unit -> range 49 49 + 50 50 + (** [always] is a range that is always valid (no from/until bounds). *) 51 51 + val always : range 52 52 + 53 53 + (** {1 Range Queries} *) 54 54 + 55 55 + (** [valid_at range ~date] checks if [range] is valid at the given [date]. 56 56 + 57 57 + - [None] range means always valid 58 58 + - [None] from means valid from beginning 59 59 + - [None] until means valid continuing *) 60 60 + val valid_at : range option -> date:date -> bool 61 61 + 62 62 + (** [overlaps r1 r2] checks if two ranges overlap in time. *) 63 63 + val overlaps : range -> range -> bool 64 64 + 65 65 + (** [is_current range] checks if range is valid at the current date. 66 66 + Uses today's date for the check. *) 67 67 + val is_current : range option -> bool 68 68 + 69 69 + (** {1 List Filtering} *) 70 70 + 71 71 + (** [current ~get list] returns the first current/valid item from [list]. 72 72 + 73 73 + @param get Function to extract the temporal range from an item. 74 74 + Returns the first item where the range is currently valid, 75 75 + or the first item without temporal bounds if none are current. *) 76 76 + val current : get:('a -> range option) -> 'a list -> 'a option 77 77 + 78 78 + (** [at_date ~get ~date list] filters [list] to items valid at [date]. 79 79 + 80 80 + @param get Function to extract the temporal range from an item. 81 81 + @param date The date to check validity against. *) 82 82 + val at_date : get:('a -> range option) -> date:date -> 'a list -> 'a list 83 83 + 84 84 + (** [filter ~get ~from ~until list] filters [list] to items overlapping the period. 85 85 + 86 86 + Returns items whose temporal range overlaps with the given period. *) 87 87 + val filter : get:('a -> range option) -> from:date option -> until:date option -> 88 88 + 'a list -> 'a list 89 89 + 90 90 + (** {1 JSON Encoding} *) 91 91 + 92 92 + (** [json_t] is the jsont encoder/decoder for temporal ranges. 93 93 + 94 94 + Encodes as a JSON object with optional [from] and [until] fields: 95 95 + {[ { "from": "2001-01", "until": "2003-12" } ]} 96 96 + 97 97 + Empty object [\{\}] or missing field represents [always]. *) 98 98 + val json_t : range Jsont.t

+48

sortal/sortal.opam

reviewed

··· 1 1 + # This file is generated by dune, edit dune-project instead 2 2 + opam-version: "2.0" 3 3 + synopsis: 4 4 + "Contact metadata management with XDG storage and versioned schemas" 5 5 + description: """ 6 6 + Sortal provides contact metadata management with versioned schemas, 7 7 + XDG-compliant storage, git versioning, and CLI tools. 8 8 + 9 9 + The library is split into two components: 10 10 + - sortal.schema: Versioned data types with minimal dependencies 11 11 + - sortal: Core library with storage, git integration, and CLI support""" 12 12 + maintainer: ["Anil Madhavapeddy <anil@recoil.org>"] 13 13 + authors: ["Anil Madhavapeddy"] 14 14 + license: "ISC" 15 15 + homepage: "https://tangled.org/@anil.recoil.org/sortal" 16 16 + bug-reports: "https://tangled.org/anil.recoil.org/sortal/issues" 17 17 + depends: [ 18 18 + "dune" {>= "3.21"} 19 19 + "ocaml" {>= "5.1.0"} 20 20 + "eio" 21 21 + "eio_main" 22 22 + "xdge" 23 23 + "jsont" 24 24 + "ptime" 25 25 + "yamlt" 26 26 + "bytesrw" 27 27 + "fmt" 28 28 + "cmdliner" 29 29 + "logs" 30 30 + "odoc" {with-doc} 31 31 + "alcotest" {with-test & >= "1.7.0"} 32 32 + ] 33 33 + build: [ 34 34 + ["dune" "subst"] {dev} 35 35 + [ 36 36 + "dune" 37 37 + "build" 38 38 + "-p" 39 39 + name 40 40 + "-j" 41 41 + jobs 42 42 + "@install" 43 43 + "@runtest" {with-test} 44 44 + "@doc" {with-doc} 45 45 + ] 46 46 + ] 47 47 + dev-repo: "git+https://tangled.org/anil.recoil.org/sortal" 48 48 + x-maintenance-intent: ["(latest)"]

+7

sortal/test/dune

reviewed

··· 1 1 + (test 2 2 + (name test_sortal) 3 3 + (libraries sortal eio eio_main jsont jsont.bytesrw)) 4 4 + 5 5 + (test 6 6 + (name test_schema) 7 7 + (libraries sortal.schema jsont jsont.bytesrw))

+53

sortal/test/test_schema.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Schema-only tests (no I/O dependencies) *) 7 7 + 8 8 + let test_temporal () = 9 9 + (* Parse dates from strings *) 10 10 + let from_date = Sortal_schema.Temporal.parse_date_string "2020-01" |> Option.get in 11 11 + let until_date = Sortal_schema.Temporal.parse_date_string "2023-12" |> Option.get in 12 12 + let test_date_1 = Sortal_schema.Temporal.parse_date_string "2021-06" |> Option.get in 13 13 + let test_date_2 = Sortal_schema.Temporal.parse_date_string "2024-01" |> Option.get in 14 14 + 15 15 + let r = Sortal_schema.Temporal.make ~from:from_date ~until:until_date () in 16 16 + assert (Sortal_schema.Temporal.valid_at (Some r) ~date:test_date_1); 17 17 + assert (not (Sortal_schema.Temporal.valid_at (Some r) ~date:test_date_2)); 18 18 + print_endline "✓ Temporal ranges work" 19 19 + 20 20 + let test_feed_types () = 21 21 + let feed = Sortal_schema.Feed.make ~feed_type:Atom ~url:"https://example.com/feed" () in 22 22 + assert (Sortal_schema.Feed.url feed = "https://example.com/feed"); 23 23 + print_endline "✓ Feed types work" 24 24 + 25 25 + let test_contact_construction () = 26 26 + let c = Sortal_schema.Contact.make 27 27 + ~handle:"test" 28 28 + ~names:["Test User"] 29 29 + ~emails:[Sortal_schema.Contact.email_of_string "test@example.com"] 30 30 + () in 31 31 + assert (Sortal_schema.Contact.handle c = "test"); 32 32 + assert (Sortal_schema.Contact.name c = "Test User"); 33 33 + print_endline "✓ Contact construction works" 34 34 + 35 35 + let test_json_roundtrip () = 36 36 + let c = Sortal_schema.Contact.make ~handle:"json" ~names:["JSON Test"] () in 37 37 + match Jsont_bytesrw.encode_string Sortal_schema.Contact.json_t c with 38 38 + | Ok json -> 39 39 + (match Jsont_bytesrw.decode_string Sortal_schema.Contact.json_t json with 40 40 + | Ok decoded -> 41 41 + assert (Sortal_schema.Contact.handle decoded = "json"); 42 42 + assert (Sortal_schema.Contact.name decoded = "JSON Test"); 43 43 + print_endline "✓ JSON roundtrip works" 44 44 + | Error e -> failwith ("Decode failed: " ^ e)) 45 45 + | Error e -> failwith ("Encode failed: " ^ e) 46 46 + 47 47 + let () = 48 48 + print_endline "\n=== Schema Tests ===\n"; 49 49 + test_temporal (); 50 50 + test_feed_types (); 51 51 + test_contact_construction (); 52 52 + test_json_roundtrip (); 53 53 + print_endline "\n=== All Schema Tests Passed ===\n"

+205

sortal/test/test_sortal.ml

reviewed

··· 1 1 + (*--------------------------------------------------------------------------- 2 2 + Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved. 3 3 + SPDX-License-Identifier: ISC 4 4 + ---------------------------------------------------------------------------*) 5 5 + 6 6 + (** Tests for the Sortal library *) 7 7 + 8 8 + open Eio.Std 9 9 + 10 10 + let test_contact_creation () = 11 11 + let c = Sortal.Contact.make 12 12 + ~handle:"test" 13 13 + ~names:["Test User"; "T. User"] 14 14 + ~emails:[Sortal.Contact.email_of_string "test@example.com"] 15 15 + ~services:[Sortal.Contact.make_service ~kind:Git ~handle:"testuser" "https://github.com/testuser"] 16 16 + () in 17 17 + assert (Sortal.Contact.handle c = "test"); 18 18 + assert (Sortal.Contact.name c = "Test User"); 19 19 + assert (List.length (Sortal.Contact.names c) = 2); 20 20 + assert (Sortal.Contact.current_email c = Some "test@example.com"); 21 21 + assert (List.length (Sortal.Contact.services c) = 1); 22 22 + assert (List.length (Sortal.Contact.services_of_kind c Git) = 1); 23 23 + traceln "✓ Contact creation works" 24 24 + 25 25 + let test_best_url () = 26 26 + let c1 = Sortal.Contact.make 27 27 + ~handle:"test1" 28 28 + ~names:["Test 1"] 29 29 + ~urls:[Sortal.Contact.url_of_string "https://example.com"] 30 30 + ~services:[Sortal.Contact.service_of_url "https://github.com/test1"] 31 31 + () in 32 32 + assert (Sortal.Contact.best_url c1 = Some "https://example.com"); 33 33 + 34 34 + let c2 = Sortal.Contact.make 35 35 + ~handle:"test2" 36 36 + ~names:["Test 2"] 37 37 + ~services:[Sortal.Contact.service_of_url "https://github.com/test2"] 38 38 + () in 39 39 + assert (Sortal.Contact.best_url c2 = Some "https://github.com/test2"); 40 40 + 41 41 + let c3 = Sortal.Contact.make 42 42 + ~handle:"test3" 43 43 + ~names:["Test 3"] 44 44 + ~emails:[Sortal.Contact.email_of_string "test3@example.com"] 45 45 + () in 46 46 + assert (Sortal.Contact.best_url c3 = Some "mailto:test3@example.com"); 47 47 + 48 48 + let c4 = Sortal.Contact.make 49 49 + ~handle:"test4" 50 50 + ~names:["Test 4"] 51 51 + () in 52 52 + assert (Sortal.Contact.best_url c4 = None); 53 53 + 54 54 + traceln "✓ Best URL selection works" 55 55 + 56 56 + let test_json_encoding () = 57 57 + let c = Sortal.Contact.make 58 58 + ~handle:"json_test" 59 59 + ~names:["JSON Test"] 60 60 + ~emails:[Sortal.Contact.email_of_string "json@example.com"] 61 61 + ~services:[Sortal.Contact.make_service ~kind:Git ~handle:"jsontest" "https://github.com/jsontest"] 62 62 + ~orcid:"0000-0001-2345-6789" 63 63 + () in 64 64 + 65 65 + match Jsont_bytesrw.encode_string Sortal.Contact.json_t c with 66 66 + | Ok json_str -> 67 67 + (match Jsont_bytesrw.decode_string Sortal.Contact.json_t json_str with 68 68 + | Ok decoded -> 69 69 + assert (Sortal.Contact.handle decoded = "json_test"); 70 70 + assert (Sortal.Contact.current_email decoded = Some "json@example.com"); 71 71 + assert (List.length (Sortal.Contact.services_of_kind decoded Git) = 1); 72 72 + assert (Sortal.Contact.orcid decoded = Some "0000-0001-2345-6789"); 73 73 + traceln "✓ JSON encoding/decoding works" 74 74 + | Error err -> 75 75 + failwith ("JSON decode failed: " ^ err)) 76 76 + | Error err -> 77 77 + failwith ("JSON encode failed: " ^ err) 78 78 + 79 79 + let test_handle_generation () = 80 80 + assert (Sortal.handle_of_name "John Smith" = "jssmith"); 81 81 + assert (Sortal.handle_of_name "Alice Barbara Cooper" = "abccooper"); 82 82 + assert (Sortal.handle_of_name "Bob" = "bbob"); 83 83 + traceln "✓ Handle generation works" 84 84 + 85 85 + let test_store_operations () = 86 86 + Eio_main.run @@ fun env -> 87 87 + 88 88 + (* Create a store with a test app name *) 89 89 + let store = Sortal.create env#fs "sortal-test" in 90 90 + 91 91 + (* Create test contacts *) 92 92 + let c1 = Sortal.Contact.make 93 93 + ~handle:"alice" 94 94 + ~names:["Alice Anderson"] 95 95 + ~emails:[Sortal.Contact.email_of_string "alice@example.com"] 96 96 + () in 97 97 + 98 98 + let c2 = Sortal.Contact.make 99 99 + ~handle:"bob" 100 100 + ~names:["Bob Brown"; "Robert Brown"] 101 101 + ~services:[Sortal.Contact.service_of_url "https://github.com/bobbrown"] 102 102 + () in 103 103 + 104 104 + (* Test save *) 105 105 + Sortal.save store c1; 106 106 + Sortal.save store c2; 107 107 + traceln "✓ Saving contacts works"; 108 108 + 109 109 + (* Test lookup *) 110 110 + (match Sortal.lookup store "alice" with 111 111 + | Some c -> 112 112 + assert (Sortal.Contact.name c = "Alice Anderson"); 113 113 + traceln "✓ Lookup works" 114 114 + | None -> failwith "Lookup failed to find saved contact"); 115 115 + 116 116 + (* Test lookup of non-existent contact *) 117 117 + (match Sortal.lookup store "nonexistent" with 118 118 + | None -> traceln "✓ Lookup correctly returns None for missing contact" 119 119 + | Some _ -> failwith "Lookup should return None for non-existent contact"); 120 120 + 121 121 + (* Test list *) 122 122 + let all = Sortal.list store in 123 123 + assert (List.length all >= 2); 124 124 + traceln "✓ List returns saved contacts (%d total)" (List.length all); 125 125 + 126 126 + (* Test find_by_name *) 127 127 + let found = Sortal.find_by_name store "Bob Brown" in 128 128 + assert (Sortal.Contact.handle found = "bob"); 129 129 + traceln "✓ Find by name works"; 130 130 + 131 131 + (* Test find_by_name_opt *) 132 132 + (match Sortal.find_by_name_opt store "Alice Anderson" with 133 133 + | Some c -> 134 134 + assert (Sortal.Contact.handle c = "alice"); 135 135 + traceln "✓ Find by name (optional) works" 136 136 + | None -> failwith "find_by_name_opt failed"); 137 137 + 138 138 + (match Sortal.find_by_name_opt store "Nobody" with 139 139 + | None -> traceln "✓ Find by name (optional) returns None for missing" 140 140 + | Some _ -> failwith "find_by_name_opt should return None"); 141 141 + 142 142 + (* Test delete *) 143 143 + Sortal.delete store "alice"; 144 144 + (match Sortal.lookup store "alice" with 145 145 + | None -> traceln "✓ Delete works" 146 146 + | Some _ -> failwith "Contact should have been deleted"); 147 147 + 148 148 + (* Clean up remaining test contact *) 149 149 + Sortal.delete store "bob"; 150 150 + traceln "✓ Test cleanup complete" 151 151 + 152 152 + let test_contact_compare () = 153 153 + let c1 = Sortal.Contact.make ~handle:"alice" ~names:["Alice"] () in 154 154 + let c2 = Sortal.Contact.make ~handle:"bob" ~names:["Bob"] () in 155 155 + let c3 = Sortal.Contact.make ~handle:"alice" ~names:["Alice2"] () in 156 156 + 157 157 + assert (Sortal.Contact.compare c1 c2 < 0); 158 158 + assert (Sortal.Contact.compare c2 c1 > 0); 159 159 + assert (Sortal.Contact.compare c1 c3 = 0); 160 160 + traceln "✓ Contact comparison works" 161 161 + 162 162 + let test_urls () = 163 163 + (* Test with only url set *) 164 164 + let c1 = Sortal.Contact.make 165 165 + ~handle:"test1" 166 166 + ~names:["Test 1"] 167 167 + ~urls:[Sortal.Contact.url_of_string "https://example.com"] 168 168 + () in 169 169 + assert (Sortal.Contact.current_url c1 = Some "https://example.com"); 170 170 + assert (List.length (Sortal.Contact.urls c1) = 1); 171 171 + 172 172 + (* Test with multiple urls *) 173 173 + let c2 = Sortal.Contact.make 174 174 + ~handle:"test2" 175 175 + ~names:["Test 2"] 176 176 + ~urls:[ 177 177 + Sortal.Contact.url_of_string "https://one.com"; 178 178 + Sortal.Contact.url_of_string "https://two.com" 179 179 + ] 180 180 + () in 181 181 + assert (Sortal.Contact.current_url c2 = Some "https://one.com"); 182 182 + assert (List.length (Sortal.Contact.urls c2) = 2); 183 183 + 184 184 + (* Test with no urls *) 185 185 + let c3 = Sortal.Contact.make 186 186 + ~handle:"test3" 187 187 + ~names:["Test 3"] 188 188 + () in 189 189 + assert (Sortal.Contact.current_url c3 = None); 190 190 + assert (Sortal.Contact.urls c3 = []); 191 191 + 192 192 + traceln "✓ URLs field works correctly" 193 193 + 194 194 + let () = 195 195 + traceln "\n=== Running Sortal Tests ===\n"; 196 196 + 197 197 + test_contact_creation (); 198 198 + test_best_url (); 199 199 + test_json_encoding (); 200 200 + test_handle_generation (); 201 201 + test_contact_compare (); 202 202 + test_urls (); 203 203 + test_store_operations (); 204 204 + 205 205 + traceln "\n=== All Tests Passed ===\n"

-9

sources.toml

reviewed

··· 1 1 - # Sources registry - tracks forked/vendored packages 2 2 - # Keys are subtree directory names (not package names) 3 3 - 4 4 - # Default URL base for subtrees without explicit entries or dune-project source. 5 5 - # URLs are constructed as: {default_url_base}/{subtree-name} 6 1 default_url_base = "git+https://tangled.org/anil.recoil.org" 7 2 8 8 - # Explicit overrides for forks (different URL than default) 9 3 [braid] 10 4 url = "git+https://github.com/avsm/braid" 11 5 upstream = "git+https://github.com/mtelvers/braid" ··· 15 9 url = "git+https://tangled.org/anil.recoil.org/ocaml-mdns" 16 10 upstream = "git+https://tangled.org/gazagnaire.org/ocaml-mdns" 17 11 reason = "Maintenance fork" 18 18 - 19 19 - # Packages like ocaml-bushel, ocaml-init that have no source in dune-project 20 20 - # will use: git+https://tangled.org/anil.recoil.org/{subtree-name}