Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
irmin: split main.ml into per-subcommand files (E524)
Move each Cmd.v subcommand out of bin/main.ml into the matching
cmd_<name>.ml, which now exposes a `val cmd : unit Cmd.t`. Shared
Cmdliner terms (setup/repo/branch/output/message) live in a new
bin/terms.ml. main.ml is reduced to the top-level Cmd.group.
Also refactor long functions (E005):
- cmd_serve.admin_page: extract admin_identity_rows, admin_allow_rows,
admin_branch_rows, admin_denied_response, admin_allowed_response
- cmd_serve.upload: extract check_upload_auth, files_of_parts,
target_dir_of_parts, find_invalid_filename, apply_upload_files,
commit_upload
- cmd_tree.run: extract list_entries, print_leaf, print_node, walk,
start_path, resolve_start
- ui/drop_zone.v: extract label_tw, submit_on_change, file_input,
prompt constants
+792
-786
+9
bin/cmd_branches.ml
+9
bin/cmd_branches.ml
···
13
13
| `Human -> List.iter (Fmt.pr " %s@.") bs
14
14
| `Json -> Fmt.pr "[%a]@." Fmt.(list ~sep:comma (fmt "%S")) bs);
15
15
0
16
+
17
+
open Cmdliner
18
+
19
+
let cmd : unit Cmd.t =
20
+
let doc = "List branches." in
21
+
Cmd.v (Cmd.info "branches" ~doc)
22
+
Term.(
23
+
const (fun () repo output -> ignore (run ~repo ~output ()))
24
+
$ Terms.setup $ Terms.repo $ Terms.output)
+25
bin/cmd_checkout.ml
+25
bin/cmd_checkout.ml
···
26
26
(match head with Some h -> S.set_head heap ~branch h | None -> ());
27
27
Common.success "Created branch %a" Common.styled_cyan branch;
28
28
0
29
+
30
+
open Cmdliner
31
+
32
+
let checkout_branch =
33
+
let doc = "Branch to checkout or create." in
34
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"BRANCH" ~doc)
35
+
36
+
let create_flag =
37
+
let doc = "Create a new branch." in
38
+
Arg.(value & flag & info [ "c"; "create" ] ~doc)
39
+
40
+
let cmd : unit Cmd.t =
41
+
let doc = "Switch to a branch." in
42
+
let man =
43
+
[
44
+
`S Manpage.s_examples;
45
+
`Pre " irmin checkout main";
46
+
`Pre " irmin checkout -c feature";
47
+
]
48
+
in
49
+
Cmd.v
50
+
(Cmd.info "checkout" ~doc ~man)
51
+
Term.(
52
+
const (fun () repo create branch -> ignore (run ~repo ~create branch))
53
+
$ Terms.setup $ Terms.repo $ create_flag $ checkout_branch)
+15
bin/cmd_del.ml
+15
bin/cmd_del.ml
···
37
37
Common.success "%a" Common.styled_faint
38
38
(Fmt.str "%a" Irmin.Hash.pp_short commit_hash);
39
39
0)
40
+
41
+
open Cmdliner
42
+
43
+
let del_path =
44
+
let doc = "Path to delete." in
45
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
46
+
47
+
let cmd : unit Cmd.t =
48
+
let doc = "Delete a path." in
49
+
let man = [ `S Manpage.s_examples; `Pre " irmin del old-file.txt" ] in
50
+
Cmd.v (Cmd.info "del" ~doc ~man)
51
+
Term.(
52
+
const (fun () repo branch message path ->
53
+
ignore (run ~repo ~branch ~message path))
54
+
$ Terms.setup $ Terms.repo $ Terms.branch $ Terms.message $ del_path)
+24
bin/cmd_export.ml
+24
bin/cmd_export.ml
···
4
4
ignore (repo, branch, output);
5
5
Common.error "export: not yet implemented with new Schema API";
6
6
1
7
+
8
+
open Cmdliner
9
+
10
+
let export_output =
11
+
let doc = "Output file path." in
12
+
Arg.(
13
+
required & opt (some string) None & info [ "o"; "output" ] ~docv:"FILE" ~doc)
14
+
15
+
let cmd : unit Cmd.t =
16
+
let doc = "Export store to file." in
17
+
let man =
18
+
[
19
+
`S Manpage.s_description;
20
+
`P "Export store contents. Format determined by extension:";
21
+
`I ("$(b,.car)", "CAR file (ATProto format)");
22
+
`S Manpage.s_examples;
23
+
`Pre " irmin export -o backup.car";
24
+
]
25
+
in
26
+
Cmd.v
27
+
(Cmd.info "export" ~doc ~man)
28
+
Term.(
29
+
const (fun () repo branch output -> ignore (run ~repo ~branch ~output ()))
30
+
$ Terms.setup $ Terms.repo $ Terms.branch $ export_output)
+21
bin/cmd_get.ml
+21
bin/cmd_get.ml
···
20
20
| `Human -> print_string content
21
21
| `Json -> Fmt.pr {|{"path":%S,"content":%S}@.|} path content);
22
22
0)
23
+
24
+
open Cmdliner
25
+
26
+
let path =
27
+
let doc = "Path to read." in
28
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
29
+
30
+
let cmd : unit Cmd.t =
31
+
let doc = "Read content at a path." in
32
+
let man =
33
+
[
34
+
`S Manpage.s_examples;
35
+
`Pre " irmin get README.md";
36
+
`Pre " irmin get src/main.ml -b feature";
37
+
]
38
+
in
39
+
Cmd.v (Cmd.info "get" ~doc ~man)
40
+
Term.(
41
+
const (fun () repo branch output path ->
42
+
ignore (run ~repo ~branch ~output path))
43
+
$ Terms.setup $ Terms.repo $ Terms.branch $ Terms.output $ path)
+25
bin/cmd_import.ml
+25
bin/cmd_import.ml
···
32
32
"import: plain file import not yet implemented with new Schema API";
33
33
1
34
34
end
35
+
36
+
open Cmdliner
37
+
38
+
let import_file =
39
+
let doc = "File to import (CAR or plain content)." in
40
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc)
41
+
42
+
let cmd : unit Cmd.t =
43
+
let doc = "Import data from file." in
44
+
let man =
45
+
[
46
+
`S Manpage.s_description;
47
+
`P "Import data from external files. Format is auto-detected:";
48
+
`I ("$(b,.car)", "CAR file (ATProto blocks)");
49
+
`I ("$(b,other)", "Plain content added at path");
50
+
`S Manpage.s_examples;
51
+
`Pre " irmin import repo.car";
52
+
`Pre " irmin import data.json";
53
+
]
54
+
in
55
+
Cmd.v
56
+
(Cmd.info "import" ~doc ~man)
57
+
Term.(
58
+
const (fun () repo branch file -> ignore (run ~repo ~branch file))
59
+
$ Terms.setup $ Terms.repo $ Terms.branch $ import_file)
+23
bin/cmd_info.ml
+23
bin/cmd_info.ml
···
58
58
59
59
let run ~repo file =
60
60
match file with Some f -> run_file f | None -> run_store ~repo ()
61
+
62
+
open Cmdliner
63
+
64
+
let info_file =
65
+
let doc = "File to inspect (optional, defaults to store info)." in
66
+
Arg.(value & pos 0 (some string) None & info [] ~docv:"FILE" ~doc)
67
+
68
+
let cmd : unit Cmd.t =
69
+
let doc = "Show store or file information." in
70
+
let man =
71
+
[
72
+
`S Manpage.s_description;
73
+
`P "Display information about the store or a specific file.";
74
+
`S Manpage.s_examples;
75
+
`Pre " irmin info";
76
+
`Pre " irmin info repo.car";
77
+
]
78
+
in
79
+
Cmd.v
80
+
(Cmd.info "info" ~doc ~man)
81
+
Term.(
82
+
const (fun () repo file -> ignore (run ~repo file))
83
+
$ Terms.setup $ Terms.repo $ info_file)
+36
bin/cmd_init.ml
+36
bin/cmd_init.ml
···
20
20
| `Disk ->
21
21
Common.error "Disk backend initialisation not yet implemented";
22
22
()
23
+
24
+
open Cmdliner
25
+
26
+
let init_path =
27
+
let doc = "Path for new repository." in
28
+
Arg.(value & pos 0 string "." & info [] ~docv:"PATH" ~doc)
29
+
30
+
let init_backend =
31
+
let doc =
32
+
"Backend type: $(b,git) for Git-compatible, $(b,pds) for \
33
+
ATProto-compatible (SQLite-backed)."
34
+
in
35
+
Arg.(
36
+
value
37
+
& opt
38
+
(enum
39
+
[
40
+
("git", `Git); ("pds", `Pds); ("memory", `Memory); ("disk", `Disk);
41
+
])
42
+
`Git
43
+
& info [ "backend" ] ~docv:"TYPE" ~doc)
44
+
45
+
let cmd : unit Cmd.t =
46
+
let doc = "Initialise a new repository." in
47
+
let man =
48
+
[
49
+
`S Manpage.s_examples;
50
+
`Pre " irmin init myrepo";
51
+
`Pre " irmin init --backend mst atproto-store";
52
+
]
53
+
in
54
+
Cmd.v
55
+
(Cmd.info "init" ~doc ~man)
56
+
Term.(
57
+
const (fun () backend path -> run ~backend path)
58
+
$ Terms.setup $ init_backend $ init_path)
+18
bin/cmd_list.ml
+18
bin/cmd_list.ml
···
32
32
in
33
33
Fmt.pr "[%s]@." (String.concat "," json_entries));
34
34
0
35
+
36
+
open Cmdliner
37
+
38
+
let list_prefix =
39
+
let doc = "Path prefix to list." in
40
+
Arg.(value & pos 0 (some string) None & info [] ~docv:"PREFIX" ~doc)
41
+
42
+
let cmd : unit Cmd.t =
43
+
let doc = "List paths." in
44
+
let man =
45
+
[ `S Manpage.s_examples; `Pre " irmin list"; `Pre " irmin list src/" ]
46
+
in
47
+
Cmd.v
48
+
(Cmd.info "list" ~doc ~man)
49
+
Term.(
50
+
const (fun () repo branch output prefix ->
51
+
ignore (run ~repo ~branch ~output prefix))
52
+
$ Terms.setup $ Terms.repo $ Terms.branch $ Terms.output $ list_prefix)
+19
bin/cmd_log.ml
+19
bin/cmd_log.ml
···
54
54
in
55
55
Fmt.pr "[%s]@." (String.concat "," items));
56
56
0
57
+
58
+
open Cmdliner
59
+
60
+
let log_limit =
61
+
let doc = "Maximum commits to show." in
62
+
Arg.(value & opt (some int) None & info [ "n" ] ~docv:"N" ~doc)
63
+
64
+
let cmd : unit Cmd.t =
65
+
let doc = "Show commit history." in
66
+
let man =
67
+
[
68
+
`S Manpage.s_examples; `Pre " irmin log"; `Pre " irmin log -n 5 -o json";
69
+
]
70
+
in
71
+
Cmd.v (Cmd.info "log" ~doc ~man)
72
+
Term.(
73
+
const (fun () repo branch output limit ->
74
+
ignore (run ~repo ~branch ~output ~limit ()))
75
+
$ Terms.setup $ Terms.repo $ Terms.branch $ Terms.output $ log_limit)
+37
bin/cmd_merge.ml
+37
bin/cmd_merge.ml
···
43
43
in
44
44
Common.success "merged %a into %a (%d conflict(s) resolved with %s)"
45
45
Common.styled_bold theirs Common.styled_bold branch n strategy
46
+
47
+
open Cmdliner
48
+
49
+
let merge_theirs =
50
+
let doc = "Branch to merge from." in
51
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"BRANCH" ~doc)
52
+
53
+
let merge_resolver =
54
+
let doc =
55
+
"Conflict resolution: $(b,fail) to abort, $(b,ours) to keep ours, \
56
+
$(b,theirs) to keep theirs."
57
+
in
58
+
Arg.(
59
+
value
60
+
& opt (enum [ ("fail", `Fail); ("ours", `Ours); ("theirs", `Theirs) ]) `Fail
61
+
& info [ "resolver" ] ~docv:"STRATEGY" ~doc)
62
+
63
+
let cmd : unit Cmd.t =
64
+
let doc = "3-way merge between branches." in
65
+
let man =
66
+
[
67
+
`S Manpage.s_description;
68
+
`P
69
+
"Two-phase merge: phase 1 resolves automatically (structural merge for \
70
+
trees, typed merge for leaves). Phase 2 handles conflicts via the \
71
+
--resolver strategy.";
72
+
`S Manpage.s_examples;
73
+
`Pre " irmin merge feature";
74
+
`Pre " irmin merge feature --resolver ours";
75
+
]
76
+
in
77
+
Cmd.v
78
+
(Cmd.info "merge" ~doc ~man)
79
+
Term.(
80
+
const (fun () repo branch theirs resolver ->
81
+
run ~repo ~branch ~theirs ~resolver ())
82
+
$ Terms.setup $ Terms.repo $ Terms.branch $ merge_theirs $ merge_resolver)
+60
bin/cmd_proof.ml
+60
bin/cmd_proof.ml
···
168
168
| `Human -> Common.error "Invalid: %s" msg
169
169
| `Json -> Fmt.pr {|{"verified":false,"error":%S}@.|} msg);
170
170
1
171
+
172
+
open Cmdliner
173
+
174
+
let proof_key =
175
+
let doc = "Key to produce/verify proof for." in
176
+
Arg.(required & opt (some string) None & info [ "k"; "key" ] ~docv:"KEY" ~doc)
177
+
178
+
let proof_data =
179
+
let doc = "Data entries as KEY=VALUE." in
180
+
Arg.(value & pos_all string [] & info [] ~docv:"KEY=VALUE" ~doc)
181
+
182
+
let produce_cmd : unit Cmd.t =
183
+
let doc = "Produce a Merkle proof for a key." in
184
+
let man =
185
+
[
186
+
`S Manpage.s_description;
187
+
`P
188
+
"Produces a Merkle proof for reading a key from an MST (Merkle Search \
189
+
Tree). The proof contains only the data needed to verify the read.";
190
+
`S Manpage.s_examples;
191
+
`Pre " irmin proof produce -k mykey foo=bar baz=qux";
192
+
`Pre " irmin proof produce -k post/123 -o json 'post/123=Hello'";
193
+
]
194
+
in
195
+
Cmd.v
196
+
(Cmd.info "produce" ~doc ~man)
197
+
Term.(
198
+
const (fun () output key data -> ignore (produce ~output ~key data))
199
+
$ Terms.setup $ Terms.output $ proof_key $ proof_data)
200
+
201
+
let verify_cmd : unit Cmd.t =
202
+
let doc = "Verify a Merkle proof for a key." in
203
+
let man =
204
+
[
205
+
`S Manpage.s_description;
206
+
`P
207
+
"Verifies that a Merkle proof correctly proves a read operation. \
208
+
Returns exit code 0 if valid, 1 if invalid.";
209
+
`S Manpage.s_examples;
210
+
`Pre " irmin proof verify -k mykey foo=bar baz=qux";
211
+
]
212
+
in
213
+
Cmd.v
214
+
(Cmd.info "verify" ~doc ~man)
215
+
Term.(
216
+
const (fun () output key data -> ignore (verify ~output ~key data))
217
+
$ Terms.setup $ Terms.output $ proof_key $ proof_data)
218
+
219
+
let cmd : unit Cmd.t =
220
+
let doc = "MST Merkle proofs (ATProto-compatible)." in
221
+
let man =
222
+
[
223
+
`S Manpage.s_description;
224
+
`P
225
+
"Commands for working with Merkle proofs using the MST (Merkle Search \
226
+
Tree) format, compatible with ATProto's repository sync protocol.";
227
+
`P "Proofs allow verifying tree operations without full data access.";
228
+
]
229
+
in
230
+
Cmd.group (Cmd.info "proof" ~doc ~man) [ produce_cmd; verify_cmd ]
+23
bin/cmd_pull.ml
+23
bin/cmd_pull.ml
···
47
47
Common.resolve_and_commit heap branch merged conflicts resolver
48
48
in
49
49
Common.success "pulled from %s (%d conflict(s) auto-resolved)" remote n
50
+
51
+
open Cmdliner
52
+
53
+
let pull_remote =
54
+
let doc = "Remote repository path." in
55
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"REMOTE" ~doc)
56
+
57
+
let cmd : unit Cmd.t =
58
+
let doc = "Pull and merge from a remote store." in
59
+
let man =
60
+
[
61
+
`S Manpage.s_examples;
62
+
`Pre " irmin pull /path/to/remote";
63
+
`Pre " irmin pull /path/to/remote --resolver theirs";
64
+
]
65
+
in
66
+
Cmd.v
67
+
(Cmd.info "pull" ~doc ~man)
68
+
Term.(
69
+
const (fun () repo branch remote resolver ->
70
+
run ~repo ~branch ~remote ~resolver ())
71
+
$ Terms.setup $ Terms.repo $ Terms.branch $ pull_remote
72
+
$ Cmd_merge.merge_resolver)
+15
bin/cmd_push.ml
+15
bin/cmd_push.ml
···
29
29
else (
30
30
Common.error "push rejected (remote branch changed, pull first)";
31
31
exit 1)
32
+
33
+
open Cmdliner
34
+
35
+
let push_remote =
36
+
let doc = "Remote repository path." in
37
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"REMOTE" ~doc)
38
+
39
+
let cmd : unit Cmd.t =
40
+
let doc = "Push to a remote store (fast-forward only)." in
41
+
let man = [ `S Manpage.s_examples; `Pre " irmin push /path/to/remote" ] in
42
+
Cmd.v
43
+
(Cmd.info "push" ~doc ~man)
44
+
Term.(
45
+
const (fun () repo branch remote -> run ~repo ~branch ~remote ())
46
+
$ Terms.setup $ Terms.repo $ Terms.branch $ push_remote)
+260
-206
bin/cmd_serve.ml
+260
-206
bin/cmd_serve.ml
···
394
394
let name = List.nth path (List.length path - 1) in
395
395
render_leaf ~name c))
396
396
397
+
let admin_identity_rows ~auth_enabled ~(allow : Irmin_admin.config) user =
398
+
match user with
399
+
| None ->
400
+
[
401
+
kv_row ~label:"Signed in as" ~value:(H.txt "(anonymous)");
402
+
kv_row ~label:"Auth"
403
+
~value:
404
+
(if auth_enabled then Tag.v ~tone:Tag.Primary "enabled"
405
+
else Tag.v ~tone:Tag.Muted "disabled");
406
+
]
407
+
| Some (u : Auth.user) ->
408
+
[
409
+
kv_row ~label:"Signed in as" ~value:(H.txt u.name);
410
+
kv_row ~label:"Email" ~value:(H.txt u.email);
411
+
kv_row ~label:"Status"
412
+
~value:
413
+
(if is_allowed allow u then Tag.v ~tone:Tag.Primary "allowed"
414
+
else Tag.v ~tone:Tag.Danger "not allowed");
415
+
]
416
+
417
+
let admin_allow_rows (allow : Irmin_admin.config) =
418
+
match allow.allow_emails with
419
+
| [] ->
420
+
[
421
+
Table.row
422
+
[
423
+
Table.cell
424
+
~tw:Tw.[ text ~shade:500 gray ]
425
+
[
426
+
H.txt
427
+
"No one. Commit an admin.toml to refs/meta/config to grant \
428
+
upload access.";
429
+
];
430
+
];
431
+
]
432
+
| emails -> List.map (fun e -> Table.row [ Table.cell [ H.txt e ] ]) emails
433
+
434
+
let admin_branch_row name hash =
435
+
Table.row
436
+
[
437
+
Table.cell
438
+
[
439
+
H.a
440
+
~at:[ Tw_html.At.href (Fmt.str "/%s/" (url_escape name)) ]
441
+
~tw:
442
+
Tw.
443
+
[
444
+
text Brand.primary;
445
+
font_medium;
446
+
hover [ text ~opacity:80 Brand.primary ];
447
+
]
448
+
[ H.txt name ];
449
+
];
450
+
Table.mono_cell hash;
451
+
]
452
+
453
+
let admin_branch_rows heap branches =
454
+
List.map
455
+
(fun name ->
456
+
let hash =
457
+
match S.head heap ~branch:name with
458
+
| None -> "-"
459
+
| Some h ->
460
+
let hex = Irmin.Hash.to_hex h in
461
+
if String.length hex <= 7 then hex else String.sub hex 0 7
462
+
in
463
+
admin_branch_row name hash)
464
+
branches
465
+
466
+
let admin_denied_response ~auth_state =
467
+
let body =
468
+
[
469
+
h1_title "Admin";
470
+
summary_p
471
+
"Access restricted. Sign in with an email on the allowlist to view \
472
+
this page.";
473
+
H.p
474
+
~tw:Tw.[ mt 4 ]
475
+
[
476
+
Button.link_primary
477
+
~at:[ Tw_html.At.href "/auth/github" ]
478
+
[ H.txt "Sign in with GitHub" ];
479
+
];
480
+
]
481
+
in
482
+
Respond.Response.v ~status:403 ~content_type:"text/html"
483
+
(Tw_html.html (Layout.page ~title:"Admin" ~auth:auth_state body))
484
+
485
+
let admin_summary ~branches ~(allow : Irmin_admin.config) =
486
+
Fmt.str "%d branch%s, %d email%s on the upload allowlist."
487
+
(List.length branches)
488
+
(if List.length branches = 1 then "" else "es")
489
+
(List.length allow.allow_emails)
490
+
(if List.length allow.allow_emails = 1 then "" else "s")
491
+
492
+
let admin_allowed_response heap ~auth_enabled ~(allow : Irmin_admin.config)
493
+
~user ~auth_state =
494
+
let identity_rows = admin_identity_rows ~auth_enabled ~allow user in
495
+
let identity_section =
496
+
section ~title:"Identity"
497
+
(Table.wrap
498
+
~head:(Table.head [ ("Field", Table.Left); ("Value", Table.Left) ])
499
+
identity_rows)
500
+
in
501
+
let allow_section =
502
+
section ~title:"Upload allowlist"
503
+
(Table.wrap
504
+
~head:(Table.head [ ("Email", Table.Left) ])
505
+
(admin_allow_rows allow))
506
+
in
507
+
let branches = S.branches heap in
508
+
let branch_section =
509
+
section ~title:"Branches"
510
+
(Table.wrap
511
+
~head:(Table.head [ ("Name", Table.Left); ("Head", Table.Right) ])
512
+
(admin_branch_rows heap branches))
513
+
in
514
+
let body =
515
+
[
516
+
h1_title "Admin";
517
+
summary_p (admin_summary ~branches ~allow);
518
+
breadcrumb ~branch:None ~path:[];
519
+
identity_section;
520
+
allow_section;
521
+
branch_section;
522
+
]
523
+
in
524
+
Respond.Response.html (page ~title:"Admin" ~auth_state body)
525
+
397
526
let admin_page ?auth heap (req : Respond.get_request) =
398
527
let user = Option.bind auth (fun ctx -> current_user_get ctx req) in
399
528
let allow = upload_allowlist heap in
···
404
533
| true, None -> false
405
534
| true, Some u -> is_allowed allow u
406
535
in
407
-
if auth_enabled && not allowed_here then
408
-
let body =
409
-
[
410
-
h1_title "Admin";
411
-
summary_p
412
-
"Access restricted. Sign in with an email on the allowlist to view \
413
-
this page.";
414
-
H.p
415
-
~tw:Tw.[ mt 4 ]
416
-
[
417
-
Button.link_primary
418
-
~at:[ Tw_html.At.href "/auth/github" ]
419
-
[ H.txt "Sign in with GitHub" ];
420
-
];
421
-
]
422
-
in
423
-
let auth_state = auth_state ~auth_enabled ~user in
424
-
Respond.Response.v ~status:403 ~content_type:"text/html"
425
-
(Tw_html.html (Layout.page ~title:"Admin" ~auth:auth_state body))
426
-
else
427
-
let identity_rows =
428
-
match user with
429
-
| None ->
430
-
[
431
-
kv_row ~label:"Signed in as" ~value:(H.txt "(anonymous)");
432
-
kv_row ~label:"Auth"
433
-
~value:
434
-
(if auth_enabled then Tag.v ~tone:Tag.Primary "enabled"
435
-
else Tag.v ~tone:Tag.Muted "disabled");
436
-
]
437
-
| Some (u : Auth.user) ->
438
-
[
439
-
kv_row ~label:"Signed in as" ~value:(H.txt u.name);
440
-
kv_row ~label:"Email" ~value:(H.txt u.email);
441
-
kv_row ~label:"Status"
442
-
~value:
443
-
(if is_allowed allow u then Tag.v ~tone:Tag.Primary "allowed"
444
-
else Tag.v ~tone:Tag.Danger "not allowed");
445
-
]
446
-
in
447
-
let identity_section =
448
-
section ~title:"Identity"
449
-
(Table.wrap
450
-
~head:(Table.head [ ("Field", Table.Left); ("Value", Table.Left) ])
451
-
identity_rows)
452
-
in
453
-
let allow_rows =
454
-
match allow.allow_emails with
455
-
| [] ->
456
-
[
457
-
Table.row
458
-
[
459
-
Table.cell
460
-
~tw:Tw.[ text ~shade:500 gray ]
461
-
[
462
-
H.txt
463
-
"No one. Commit an admin.toml to refs/meta/config to \
464
-
grant upload access.";
465
-
];
466
-
];
467
-
]
468
-
| emails ->
469
-
List.map (fun e -> Table.row [ Table.cell [ H.txt e ] ]) emails
470
-
in
471
-
let allow_section =
472
-
section ~title:"Upload allowlist"
473
-
(Table.wrap ~head:(Table.head [ ("Email", Table.Left) ]) allow_rows)
474
-
in
475
-
let branches = S.branches heap in
476
-
let branch_rows =
477
-
List.map
478
-
(fun name ->
479
-
let hash =
480
-
match S.head heap ~branch:name with
481
-
| None -> "-"
482
-
| Some h ->
483
-
let hex = Irmin.Hash.to_hex h in
484
-
if String.length hex <= 7 then hex else String.sub hex 0 7
485
-
in
486
-
Table.row
487
-
[
488
-
Table.cell
489
-
[
490
-
H.a
491
-
~at:[ Tw_html.At.href (Fmt.str "/%s/" (url_escape name)) ]
492
-
~tw:
493
-
Tw.
494
-
[
495
-
text Brand.primary;
496
-
font_medium;
497
-
hover [ text ~opacity:80 Brand.primary ];
498
-
]
499
-
[ H.txt name ];
500
-
];
501
-
Table.mono_cell hash;
502
-
])
503
-
branches
504
-
in
505
-
let branch_section =
506
-
section ~title:"Branches"
507
-
(Table.wrap
508
-
~head:(Table.head [ ("Name", Table.Left); ("Head", Table.Right) ])
509
-
branch_rows)
510
-
in
511
-
let body =
512
-
[
513
-
h1_title "Admin";
514
-
summary_p
515
-
(Fmt.str "%d branch%s, %d email%s on the upload allowlist."
516
-
(List.length branches)
517
-
(if List.length branches = 1 then "" else "es")
518
-
(List.length allow.allow_emails)
519
-
(if List.length allow.allow_emails = 1 then "" else "s"));
520
-
breadcrumb ~branch:None ~path:[];
521
-
identity_section;
522
-
allow_section;
523
-
branch_section;
524
-
]
525
-
in
526
-
let auth_state = auth_state ~auth_enabled ~user in
527
-
Respond.Response.html (page ~title:"Admin" ~auth_state body)
536
+
let auth_state = auth_state ~auth_enabled ~user in
537
+
if auth_enabled && not allowed_here then admin_denied_response ~auth_state
538
+
else admin_allowed_response heap ~auth_enabled ~allow ~user ~auth_state
528
539
529
540
let raw_block heap (req : Respond.get_request) =
530
541
let hex = List.assoc "hash" req.path_params in
···
550
561
in
551
562
if bad then err_unsafe_filename name else Ok name
552
563
564
+
let check_upload_auth ?auth heap req =
565
+
match auth with
566
+
| None -> Ok ()
567
+
| Some ctx -> (
568
+
match require_user ctx req with
569
+
| Error r -> Error (`Redirect r)
570
+
| Ok user ->
571
+
let allow = upload_allowlist heap in
572
+
if is_allowed allow user then Ok ()
573
+
else
574
+
Error
575
+
(`Forbidden
576
+
(Fmt.str "%s is not on the upload allowlist" user.email)))
577
+
578
+
let files_of_parts parts =
579
+
List.filter_map
580
+
(fun (p : Http.Multipart.part) ->
581
+
match p.filename with
582
+
| Some fn when fn <> "" -> Some (fn, p.body)
583
+
| _ -> None)
584
+
parts
585
+
586
+
let target_dir_of_parts parts =
587
+
match
588
+
List.find_map
589
+
(fun (p : Http.Multipart.part) ->
590
+
if p.name = "dir" then Some p.body else None)
591
+
parts
592
+
with
593
+
| Some s -> Common.path_of_string s
594
+
| None -> []
595
+
596
+
let find_invalid_filename files =
597
+
List.find_map
598
+
(fun (fn, _) ->
599
+
match sanitize_filename fn with Ok _ -> None | Error m -> Some m)
600
+
files
601
+
602
+
let apply_upload_files heap ~root_c ~target_dir files =
603
+
let steps_for name = target_dir @ [ name ] in
604
+
(* Apply each file sequentially, re-opening a cursor on the latest tree
605
+
hash each time so writes accumulate. *)
606
+
List.fold_left
607
+
(fun acc_hash (name, bytes) ->
608
+
let c = S.at heap Irmin_git.tree acc_hash in
609
+
Common.set_path heap c (steps_for name) bytes)
610
+
(S.flush root_c heap) files
611
+
612
+
let upload_commit_message = function
613
+
| [ (fn, _) ] -> Fmt.str "Upload %s" fn
614
+
| files -> Fmt.str "Upload %d files" (List.length files)
615
+
616
+
let upload_redirect_target ~branch ~target_dir files =
617
+
match files with
618
+
| [ (fn, _) ] ->
619
+
Fmt.str "/%s%s/%s" (url_escape branch)
620
+
(if target_dir = [] then ""
621
+
else "/" ^ String.concat "/" (List.map url_escape target_dir))
622
+
(url_escape fn)
623
+
| _ ->
624
+
Fmt.str "/%s/%s" (url_escape branch)
625
+
(String.concat "/" (List.map url_escape target_dir))
626
+
627
+
let commit_upload heap ~branch parts =
628
+
let files = files_of_parts parts in
629
+
let target_dir = target_dir_of_parts parts in
630
+
if files = [] then Respond.Response.bad_request "no file part in upload"
631
+
else
632
+
match find_invalid_filename files with
633
+
| Some m -> Respond.Response.bad_request m
634
+
| None ->
635
+
let root_c =
636
+
match Common.checkout heap ~branch with
637
+
| Some c -> c
638
+
| None -> S.empty heap Irmin_git.tree
639
+
in
640
+
let final_tree = apply_upload_files heap ~root_c ~target_dir files in
641
+
let msg = upload_commit_message files in
642
+
let _commit = Common.commit ~heap ~branch ~message:msg final_tree in
643
+
Respond.Response.redirect
644
+
(upload_redirect_target ~branch ~target_dir files)
645
+
553
646
let upload ?auth heap (req : Respond.post_request) =
554
-
let authorized =
555
-
match auth with
556
-
| None -> Ok ()
557
-
| Some ctx -> (
558
-
match require_user ctx req with
559
-
| Error r -> Error (`Redirect r)
560
-
| Ok user ->
561
-
let allow = upload_allowlist heap in
562
-
if is_allowed allow user then Ok ()
563
-
else
564
-
Error
565
-
(`Forbidden
566
-
(Fmt.str "%s is not on the upload allowlist" user.email)))
567
-
in
568
-
match authorized with
647
+
match check_upload_auth ?auth heap req with
569
648
| Error (`Redirect r) -> Respond.Response.redirect r
570
649
| Error (`Forbidden m) ->
571
650
Respond.Response.v ~status:403 ~content_type:"text/plain" m
···
574
653
match Http.Multipart.parse req.headers req.body with
575
654
| Error (`Msg m) ->
576
655
Respond.Response.bad_request (Fmt.str "multipart parse error: %s" m)
577
-
| Ok parts -> (
578
-
let files =
579
-
List.filter_map
580
-
(fun (p : Http.Multipart.part) ->
581
-
match p.filename with
582
-
| Some fn when fn <> "" -> Some (fn, p.body)
583
-
| _ -> None)
584
-
parts
585
-
in
586
-
let target_dir =
587
-
match
588
-
List.find_map
589
-
(fun (p : Http.Multipart.part) ->
590
-
if p.name = "dir" then Some p.body else None)
591
-
parts
592
-
with
593
-
| Some s -> Common.path_of_string s
594
-
| None -> []
595
-
in
596
-
if files = [] then
597
-
Respond.Response.bad_request "no file part in upload"
598
-
else
599
-
let invalid =
600
-
List.find_map
601
-
(fun (fn, _) ->
602
-
match sanitize_filename fn with
603
-
| Ok _ -> None
604
-
| Error m -> Some m)
605
-
files
606
-
in
607
-
match invalid with
608
-
| Some m -> Respond.Response.bad_request m
609
-
| None ->
610
-
let root_c =
611
-
match Common.checkout heap ~branch with
612
-
| Some c -> c
613
-
| None -> S.empty heap Irmin_git.tree
614
-
in
615
-
let steps_for name = target_dir @ [ name ] in
616
-
(* Apply each file sequentially, re-opening a cursor on the
617
-
latest tree hash each time so writes accumulate. *)
618
-
let final_tree =
619
-
List.fold_left
620
-
(fun acc_hash (name, bytes) ->
621
-
let c = S.at heap Irmin_git.tree acc_hash in
622
-
Common.set_path heap c (steps_for name) bytes)
623
-
(S.flush root_c heap) files
624
-
in
625
-
let msg =
626
-
match files with
627
-
| [ (fn, _) ] -> Fmt.str "Upload %s" fn
628
-
| _ -> Fmt.str "Upload %d files" (List.length files)
629
-
in
630
-
let _commit =
631
-
Common.commit ~heap ~branch ~message:msg final_tree
632
-
in
633
-
let target =
634
-
match files with
635
-
| [ (fn, _) ] ->
636
-
Fmt.str "/%s%s/%s" (url_escape branch)
637
-
(if target_dir = [] then ""
638
-
else
639
-
"/"
640
-
^ String.concat "/" (List.map url_escape target_dir))
641
-
(url_escape fn)
642
-
| _ ->
643
-
Fmt.str "/%s/%s" (url_escape branch)
644
-
(String.concat "/" (List.map url_escape target_dir))
645
-
in
646
-
Respond.Response.redirect target))
656
+
| Ok parts -> commit_upload heap ~branch parts)
647
657
648
658
(* ── Entry point ──────────────────────────────────────────────────── *)
649
659
···
683
693
Log.info (fun m -> m "listening on http://localhost:%d" port);
684
694
Common.success "serving on http://localhost:%d" port;
685
695
Respond.run ~net ~port ~root:fs routes
696
+
697
+
open Cmdliner
698
+
699
+
let serve_port =
700
+
let doc = "Port to listen on." in
701
+
Arg.(value & opt int 2583 & info [ "p"; "port" ] ~docv:"PORT" ~doc)
702
+
703
+
let serve_did =
704
+
let doc = "DID for the server. Auto-detected from PDS metadata if omitted." in
705
+
Arg.(value & opt (some string) None & info [ "did" ] ~docv:"DID" ~doc)
706
+
707
+
let serve_format =
708
+
let doc = "Server format: $(b,xrpc) for AT Protocol XRPC." in
709
+
Arg.(
710
+
value
711
+
& opt (enum [ ("xrpc", `Xrpc) ]) `Xrpc
712
+
& info [ "format" ] ~docv:"FORMAT" ~doc)
713
+
714
+
let cmd : unit Cmd.t =
715
+
let doc = "Serve store over XRPC as a read-only ATProto PDS." in
716
+
let man =
717
+
[
718
+
`S Manpage.s_description;
719
+
`P
720
+
"Start an HTTP server that exposes the Irmin store as a read-only AT \
721
+
Protocol PDS. Works with any backend (Git, MST, PDS).";
722
+
`P
723
+
"Supported XRPC methods: com.atproto.server.describeServer, \
724
+
com.atproto.repo.describeRepo, com.atproto.repo.getRecord, \
725
+
com.atproto.repo.listRecords, com.atproto.sync.getRepo, \
726
+
com.atproto.sync.getBlob.";
727
+
`S Manpage.s_examples;
728
+
`Pre " irmin serve";
729
+
`Pre " irmin serve -p 8080 --did did:plc:abc123";
730
+
`Pre " irmin --repo /path/to/pds serve";
731
+
]
732
+
in
733
+
Cmd.v
734
+
(Cmd.info "serve" ~doc ~man)
735
+
Term.(
736
+
const (fun () repo branch port did format ->
737
+
run ~repo ~branch ~port ~did ~format)
738
+
$ Terms.setup $ Terms.repo $ Terms.branch $ serve_port $ serve_did
739
+
$ serve_format)
+27
bin/cmd_set.ml
+27
bin/cmd_set.ml
···
22
22
let commit_hash = Common.commit ~heap ~branch ~message new_tree_hash in
23
23
Common.success "%a" Common.styled_faint
24
24
(Fmt.str "%a" Irmin.Hash.pp_short commit_hash)
25
+
26
+
open Cmdliner
27
+
28
+
let set_path =
29
+
let doc = "Path to write." in
30
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
31
+
32
+
let set_content =
33
+
let doc = "Content to write. Reads from stdin if omitted." in
34
+
Arg.(value & pos 1 (some string) None & info [] ~docv:"CONTENT" ~doc)
35
+
36
+
let cmd : unit Cmd.t =
37
+
let doc = "Write content at a path." in
38
+
let man =
39
+
[
40
+
`S Manpage.s_examples;
41
+
`Pre " irmin set README.md '# Hello'";
42
+
`Pre " echo 'data' | irmin set config.txt";
43
+
`Pre " irmin set -m 'Add docs' README.md '# Project'";
44
+
]
45
+
in
46
+
Cmd.v (Cmd.info "set" ~doc ~man)
47
+
Term.(
48
+
const (fun () repo branch message path content ->
49
+
run ~repo ~branch ~message path content)
50
+
$ Terms.setup $ Terms.repo $ Terms.branch $ Terms.message $ set_path
51
+
$ set_content)
+60
-44
bin/cmd_tree.ml
+60
-44
bin/cmd_tree.ml
···
2
2
3
3
module S = Common.S
4
4
5
+
let entry_kind c name =
6
+
match Common.classify_child c name with
7
+
| `Missing -> `Leaf
8
+
| (`Leaf | `Node) as k -> k
9
+
10
+
let list_entries c =
11
+
List.map (fun (name, _) -> (name, entry_kind c name)) (S.list c)
12
+
13
+
let print_leaf ~output ~indent ~full_path name =
14
+
match output with
15
+
| `Human -> Fmt.pr "%s%s@." indent name
16
+
| `Json ->
17
+
Fmt.pr {|{"path":%S,"type":"file"}@.|} (String.concat "/" full_path)
18
+
19
+
let print_node ~output ~indent ~full_path name =
20
+
match output with
21
+
| `Human -> Fmt.pr "%s%a/@." indent Common.styled_blue name
22
+
| `Json -> Fmt.pr {|{"path":%S,"type":"dir"}@.|} (String.concat "/" full_path)
23
+
24
+
let rec walk ~output indent prefix (S.Step (sc, c)) =
25
+
List.iter
26
+
(fun (name, kind) ->
27
+
let full_path = prefix @ [ name ] in
28
+
match kind with
29
+
| `Leaf -> print_leaf ~output ~indent ~full_path name
30
+
| `Node -> (
31
+
print_node ~output ~indent ~full_path name;
32
+
match Common.navigate (S.Step (sc, c)) [ name ] with
33
+
| Some child -> walk ~output (indent ^ " ") full_path child
34
+
| None -> ()))
35
+
(list_entries c)
36
+
37
+
let start_path = function None -> [] | Some p -> Common.path_of_string p
38
+
39
+
let resolve_start root_c start =
40
+
match start with
41
+
| [] -> Some (S.Step (Irmin_git.tree, root_c))
42
+
| _ -> Common.navigate (S.Step (Irmin_git.tree, root_c)) start
43
+
5
44
let run ~repo ~branch ~output path =
6
45
let config = Config.load ~repo () in
7
46
Eio_main.run @@ fun env ->
···
13
52
Common.error "Branch %a not found" Common.styled_cyan branch;
14
53
1
15
54
| Some root_c -> (
16
-
let start =
17
-
match path with None -> [] | Some p -> Common.path_of_string p
18
-
in
19
-
(* Navigate to the start path *)
20
-
let start_c =
21
-
match start with
22
-
| [] -> Some (S.Step (Irmin_git.tree, root_c))
23
-
| _ -> Common.navigate (S.Step (Irmin_git.tree, root_c)) start
24
-
in
25
-
match start_c with
55
+
let start = start_path path in
56
+
match resolve_start root_c start with
26
57
| None ->
27
58
Common.error "Path %a not found" Common.styled_cyan
28
59
(Option.value ~default:"/" path);
29
60
1
30
61
| Some s ->
31
-
let rec walk indent prefix (S.Step (sc, c)) =
32
-
let entries =
33
-
List.map
34
-
(fun (name, _) ->
35
-
let k =
36
-
match Common.classify_child c name with
37
-
| `Missing -> `Leaf
38
-
| (`Leaf | `Node) as k -> k
39
-
in
40
-
(name, k))
41
-
(S.list c)
42
-
in
43
-
List.iter
44
-
(fun (name, kind) ->
45
-
let full_path = prefix @ [ name ] in
46
-
match kind with
47
-
| `Leaf -> (
48
-
match output with
49
-
| `Human -> Fmt.pr "%s%s@." indent name
50
-
| `Json ->
51
-
Fmt.pr {|{"path":%S,"type":"file"}@.|}
52
-
(String.concat "/" full_path))
53
-
| `Node -> (
54
-
(match output with
55
-
| `Human -> Fmt.pr "%s%a/@." indent Common.styled_blue name
56
-
| `Json ->
57
-
Fmt.pr {|{"path":%S,"type":"dir"}@.|}
58
-
(String.concat "/" full_path));
59
-
match Common.navigate (S.Step (sc, c)) [ name ] with
60
-
| Some child -> walk (indent ^ " ") full_path child
61
-
| None -> ()))
62
-
entries
63
-
in
64
-
walk "" start s;
62
+
walk ~output "" start s;
65
63
0)
64
+
65
+
open Cmdliner
66
+
67
+
let tree_path =
68
+
let doc = "Path to show tree from." in
69
+
Arg.(value & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
70
+
71
+
let cmd : unit Cmd.t =
72
+
let doc = "Show tree structure." in
73
+
let man =
74
+
[ `S Manpage.s_examples; `Pre " irmin tree"; `Pre " irmin tree src/" ]
75
+
in
76
+
Cmd.v
77
+
(Cmd.info "tree" ~doc ~man)
78
+
Term.(
79
+
const (fun () repo branch output path ->
80
+
ignore (run ~repo ~branch ~output path))
81
+
$ Terms.setup $ Terms.repo $ Terms.branch $ Terms.output $ tree_path)
+17
-488
bin/main.ml
+17
-488
bin/main.ml
···
2
2
3
3
open Cmdliner
4
4
5
-
(* === Logging setup via vlog === *)
6
-
7
-
let setup = Vlog.setup "irmin"
8
-
9
-
(* === Common arguments === *)
10
-
11
-
let repo =
12
-
let doc = "Repository directory." in
13
-
Arg.(value & opt string "." & info [ "r"; "repo" ] ~docv:"DIR" ~doc)
14
-
15
-
let branch =
16
-
let doc = "Branch name." in
17
-
Arg.(value & opt string "main" & info [ "b"; "branch" ] ~docv:"NAME" ~doc)
18
-
19
-
let output =
20
-
let doc = "Output format: $(b,human) for terminal, $(b,json) for scripts." in
21
-
Arg.(
22
-
value
23
-
& opt (enum [ ("human", `Human); ("json", `Json) ]) `Human
24
-
& info [ "o"; "output" ] ~docv:"FORMAT" ~doc)
25
-
26
-
let message =
27
-
let doc = "Commit message." in
28
-
Arg.(
29
-
value & opt (some string) None & info [ "m"; "message" ] ~docv:"MSG" ~doc)
30
-
31
-
(* === init === *)
32
-
33
-
let init_path =
34
-
let doc = "Path for new repository." in
35
-
Arg.(value & pos 0 string "." & info [] ~docv:"PATH" ~doc)
36
-
37
-
let init_backend =
38
-
let doc =
39
-
"Backend type: $(b,git) for Git-compatible, $(b,pds) for \
40
-
ATProto-compatible (SQLite-backed)."
41
-
in
42
-
Arg.(
43
-
value
44
-
& opt
45
-
(enum
46
-
[
47
-
("git", `Git); ("pds", `Pds); ("memory", `Memory); ("disk", `Disk);
48
-
])
49
-
`Git
50
-
& info [ "backend" ] ~docv:"TYPE" ~doc)
51
-
52
-
let init_cmd =
53
-
let doc = "Initialise a new repository." in
54
-
let man =
55
-
[
56
-
`S Manpage.s_examples;
57
-
`Pre " irmin init myrepo";
58
-
`Pre " irmin init --backend mst atproto-store";
59
-
]
60
-
in
61
-
Cmd.v
62
-
(Cmd.info "init" ~doc ~man)
63
-
Term.(
64
-
const (fun () backend path -> Cmd_init.run ~backend path)
65
-
$ setup $ init_backend $ init_path)
66
-
67
-
(* === get === *)
68
-
69
-
let path =
70
-
let doc = "Path to read." in
71
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
72
-
73
-
let read_cmd =
74
-
let doc = "Read content at a path." in
75
-
let man =
76
-
[
77
-
`S Manpage.s_examples;
78
-
`Pre " irmin get README.md";
79
-
`Pre " irmin get src/main.ml -b feature";
80
-
]
81
-
in
82
-
Cmd.v (Cmd.info "get" ~doc ~man)
83
-
Term.(
84
-
const (fun () repo branch output path ->
85
-
exit (Cmd_get.run ~repo ~branch ~output path))
86
-
$ setup $ repo $ branch $ output $ path)
87
-
88
-
(* === set === *)
89
-
90
-
let set_path =
91
-
let doc = "Path to write." in
92
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
93
-
94
-
let set_content =
95
-
let doc = "Content to write. Reads from stdin if omitted." in
96
-
Arg.(value & pos 1 (some string) None & info [] ~docv:"CONTENT" ~doc)
97
-
98
-
let set_cmd =
99
-
let doc = "Write content at a path." in
100
-
let man =
101
-
[
102
-
`S Manpage.s_examples;
103
-
`Pre " irmin set README.md '# Hello'";
104
-
`Pre " echo 'data' | irmin set config.txt";
105
-
`Pre " irmin set -m 'Add docs' README.md '# Project'";
106
-
]
107
-
in
108
-
Cmd.v (Cmd.info "set" ~doc ~man)
109
-
Term.(
110
-
const (fun () repo branch message path content ->
111
-
Cmd_set.run ~repo ~branch ~message path content)
112
-
$ setup $ repo $ branch $ message $ set_path $ set_content)
113
-
114
-
(* === del === *)
115
-
116
-
let del_path =
117
-
let doc = "Path to delete." in
118
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
119
-
120
-
let del_cmd =
121
-
let doc = "Delete a path." in
122
-
let man = [ `S Manpage.s_examples; `Pre " irmin del old-file.txt" ] in
123
-
Cmd.v (Cmd.info "del" ~doc ~man)
124
-
Term.(
125
-
const (fun () repo branch message path ->
126
-
exit (Cmd_del.run ~repo ~branch ~message path))
127
-
$ setup $ repo $ branch $ message $ del_path)
128
-
129
-
(* === list === *)
130
-
131
-
let list_prefix =
132
-
let doc = "Path prefix to list." in
133
-
Arg.(value & pos 0 (some string) None & info [] ~docv:"PREFIX" ~doc)
134
-
135
-
let list_cmd =
136
-
let doc = "List paths." in
137
-
let man =
138
-
[ `S Manpage.s_examples; `Pre " irmin list"; `Pre " irmin list src/" ]
139
-
in
140
-
Cmd.v
141
-
(Cmd.info "list" ~doc ~man)
142
-
Term.(
143
-
const (fun () repo branch output prefix ->
144
-
exit (Cmd_list.run ~repo ~branch ~output prefix))
145
-
$ setup $ repo $ branch $ output $ list_prefix)
146
-
147
-
(* === tree === *)
148
-
149
-
let tree_path =
150
-
let doc = "Path to show tree from." in
151
-
Arg.(value & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
152
-
153
-
let tree_cmd =
154
-
let doc = "Show tree structure." in
155
-
let man =
156
-
[ `S Manpage.s_examples; `Pre " irmin tree"; `Pre " irmin tree src/" ]
157
-
in
158
-
Cmd.v
159
-
(Cmd.info "tree" ~doc ~man)
160
-
Term.(
161
-
const (fun () repo branch output path ->
162
-
exit (Cmd_tree.run ~repo ~branch ~output path))
163
-
$ setup $ repo $ branch $ output $ tree_path)
164
-
165
-
(* === log === *)
166
-
167
-
let log_limit =
168
-
let doc = "Maximum commits to show." in
169
-
Arg.(value & opt (some int) None & info [ "n" ] ~docv:"N" ~doc)
170
-
171
-
let log_cmd =
172
-
let doc = "Show commit history." in
173
-
let man =
174
-
[
175
-
`S Manpage.s_examples; `Pre " irmin log"; `Pre " irmin log -n 5 -o json";
176
-
]
177
-
in
178
-
Cmd.v (Cmd.info "log" ~doc ~man)
179
-
Term.(
180
-
const (fun () repo branch output limit ->
181
-
exit (Cmd_log.run ~repo ~branch ~output ~limit ()))
182
-
$ setup $ repo $ branch $ output $ log_limit)
183
-
184
-
(* === branches === *)
185
-
186
-
let branches_cmd =
187
-
let doc = "List branches." in
188
-
Cmd.v (Cmd.info "branches" ~doc)
189
-
Term.(
190
-
const (fun () repo output -> exit (Cmd_branches.run ~repo ~output ()))
191
-
$ setup $ repo $ output)
192
-
193
-
(* === checkout === *)
194
-
195
-
let checkout_branch =
196
-
let doc = "Branch to checkout or create." in
197
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"BRANCH" ~doc)
198
-
199
-
let flag =
200
-
let doc = "Create a new branch." in
201
-
Arg.(value & flag & info [ "c"; "create" ] ~doc)
202
-
203
-
let checkout_cmd =
204
-
let doc = "Switch to a branch." in
205
-
let man =
206
-
[
207
-
`S Manpage.s_examples;
208
-
`Pre " irmin checkout main";
209
-
`Pre " irmin checkout -c feature";
210
-
]
211
-
in
212
-
Cmd.v
213
-
(Cmd.info "checkout" ~doc ~man)
214
-
Term.(
215
-
const (fun () repo create branch ->
216
-
exit (Cmd_checkout.run ~repo ~create branch))
217
-
$ setup $ repo $ flag $ checkout_branch)
218
-
219
-
(* === proof === *)
220
-
221
-
let proof_key =
222
-
let doc = "Key to produce/verify proof for." in
223
-
Arg.(required & opt (some string) None & info [ "k"; "key" ] ~docv:"KEY" ~doc)
224
-
225
-
let proof_data =
226
-
let doc = "Data entries as KEY=VALUE." in
227
-
Arg.(value & pos_all string [] & info [] ~docv:"KEY=VALUE" ~doc)
228
-
229
-
let proof_produce_cmd =
230
-
let doc = "Produce a Merkle proof for a key." in
231
-
let man =
232
-
[
233
-
`S Manpage.s_description;
234
-
`P
235
-
"Produces a Merkle proof for reading a key from an MST (Merkle Search\n\
236
-
\ Tree). The proof contains only the data needed to verify the \
237
-
read.";
238
-
`S Manpage.s_examples;
239
-
`Pre " irmin proof produce -k mykey foo=bar baz=qux";
240
-
`Pre " irmin proof produce -k post/123 -o json 'post/123=Hello'";
241
-
]
242
-
in
243
-
Cmd.v
244
-
(Cmd.info "produce" ~doc ~man)
245
-
Term.(
246
-
const (fun () output key data ->
247
-
exit (Cmd_proof.produce ~output ~key data))
248
-
$ setup $ output $ proof_key $ proof_data)
249
-
250
-
let proof_verify_cmd =
251
-
let doc = "Verify a Merkle proof for a key." in
252
-
let man =
253
-
[
254
-
`S Manpage.s_description;
255
-
`P
256
-
"Verifies that a Merkle proof correctly proves a read operation.\n\
257
-
\ Returns exit code 0 if valid, 1 if invalid.";
258
-
`S Manpage.s_examples;
259
-
`Pre " irmin proof verify -k mykey foo=bar baz=qux";
260
-
]
261
-
in
262
-
Cmd.v
263
-
(Cmd.info "verify" ~doc ~man)
264
-
Term.(
265
-
const (fun () output key data ->
266
-
exit (Cmd_proof.verify ~output ~key data))
267
-
$ setup $ output $ proof_key $ proof_data)
268
-
269
-
let proof_cmd =
270
-
let doc = "MST Merkle proofs (ATProto-compatible)." in
271
-
let man =
272
-
[
273
-
`S Manpage.s_description;
274
-
`P
275
-
"Commands for working with Merkle proofs using the MST (Merkle Search\n\
276
-
\ Tree) format, compatible with ATProto's repository sync \
277
-
protocol.";
278
-
`P "Proofs allow verifying tree operations without full data access.";
279
-
]
280
-
in
281
-
Cmd.group (Cmd.info "proof" ~doc ~man) [ proof_produce_cmd; proof_verify_cmd ]
282
-
283
-
(* === import === *)
284
-
285
-
let import_file =
286
-
let doc = "File to import (CAR or plain content)." in
287
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"FILE" ~doc)
288
-
289
-
let import_cmd =
290
-
let doc = "Import data from file." in
291
-
let man =
292
-
[
293
-
`S Manpage.s_description;
294
-
`P "Import data from external files. Format is auto-detected:";
295
-
`I ("$(b,.car)", "CAR file (ATProto blocks)");
296
-
`I ("$(b,other)", "Plain content added at path");
297
-
`S Manpage.s_examples;
298
-
`Pre " irmin import repo.car";
299
-
`Pre " irmin import data.json";
300
-
]
301
-
in
302
-
Cmd.v
303
-
(Cmd.info "import" ~doc ~man)
304
-
Term.(
305
-
const (fun () repo branch file ->
306
-
exit (Cmd_import.run ~repo ~branch file))
307
-
$ setup $ repo $ branch $ import_file)
308
-
309
-
(* === export === *)
310
-
311
-
let export_output =
312
-
let doc = "Output file path." in
313
-
Arg.(
314
-
required & opt (some string) None & info [ "o"; "output" ] ~docv:"FILE" ~doc)
315
-
316
-
let export_cmd =
317
-
let doc = "Export store to file." in
318
-
let man =
319
-
[
320
-
`S Manpage.s_description;
321
-
`P "Export store contents. Format determined by extension:";
322
-
`I ("$(b,.car)", "CAR file (ATProto format)");
323
-
`S Manpage.s_examples;
324
-
`Pre " irmin export -o backup.car";
325
-
]
326
-
in
327
-
Cmd.v
328
-
(Cmd.info "export" ~doc ~man)
329
-
Term.(
330
-
const (fun () repo branch output ->
331
-
exit (Cmd_export.run ~repo ~branch ~output ()))
332
-
$ setup $ repo $ branch $ export_output)
333
-
334
-
(* === info === *)
335
-
336
-
let info_file =
337
-
let doc = "File to inspect (optional, defaults to store info)." in
338
-
Arg.(value & pos 0 (some string) None & info [] ~docv:"FILE" ~doc)
339
-
340
-
let info_cmd =
341
-
let doc = "Show store or file information." in
342
-
let man =
343
-
[
344
-
`S Manpage.s_description;
345
-
`P "Display information about the store or a specific file.";
346
-
`S Manpage.s_examples;
347
-
`Pre " irmin info";
348
-
`Pre " irmin info repo.car";
349
-
]
350
-
in
351
-
Cmd.v
352
-
(Cmd.info "info" ~doc ~man)
353
-
Term.(
354
-
const (fun () repo file -> exit (Cmd_info.run ~repo file))
355
-
$ setup $ repo $ info_file)
356
-
357
-
(* === serve === *)
358
-
359
-
let serve_port =
360
-
let doc = "Port to listen on." in
361
-
Arg.(value & opt int 2583 & info [ "p"; "port" ] ~docv:"PORT" ~doc)
362
-
363
-
let serve_did =
364
-
let doc = "DID for the server. Auto-detected from PDS metadata if omitted." in
365
-
Arg.(value & opt (some string) None & info [ "did" ] ~docv:"DID" ~doc)
366
-
367
-
let serve_format =
368
-
let doc = "Server format: $(b,xrpc) for AT Protocol XRPC." in
369
-
Arg.(
370
-
value
371
-
& opt (enum [ ("xrpc", `Xrpc) ]) `Xrpc
372
-
& info [ "format" ] ~docv:"FORMAT" ~doc)
373
-
374
-
let serve_cmd =
375
-
let doc = "Serve store over XRPC as a read-only ATProto PDS." in
376
-
let man =
377
-
[
378
-
`S Manpage.s_description;
379
-
`P
380
-
"Start an HTTP server that exposes the Irmin store as a read-only AT \
381
-
Protocol PDS. Works with any backend (Git, MST, PDS).";
382
-
`P
383
-
"Supported XRPC methods: com.atproto.server.describeServer, \
384
-
com.atproto.repo.describeRepo, com.atproto.repo.getRecord, \
385
-
com.atproto.repo.listRecords, com.atproto.sync.getRepo, \
386
-
com.atproto.sync.getBlob.";
387
-
`S Manpage.s_examples;
388
-
`Pre " irmin serve";
389
-
`Pre " irmin serve -p 8080 --did did:plc:abc123";
390
-
`Pre " irmin --repo /path/to/pds serve";
391
-
]
392
-
in
393
-
Cmd.v
394
-
(Cmd.info "serve" ~doc ~man)
395
-
Term.(
396
-
const (fun () repo branch port did format ->
397
-
Cmd_serve.run ~repo ~branch ~port ~did ~format)
398
-
$ setup $ repo $ branch $ serve_port $ serve_did $ serve_format)
399
-
400
-
(* === merge === *)
401
-
402
-
let merge_theirs =
403
-
let doc = "Branch to merge from." in
404
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"BRANCH" ~doc)
405
-
406
-
let merge_resolver =
407
-
let doc =
408
-
"Conflict resolution: $(b,fail) to abort, $(b,ours) to keep ours, \
409
-
$(b,theirs) to keep theirs."
410
-
in
411
-
Arg.(
412
-
value
413
-
& opt (enum [ ("fail", `Fail); ("ours", `Ours); ("theirs", `Theirs) ]) `Fail
414
-
& info [ "resolver" ] ~docv:"STRATEGY" ~doc)
415
-
416
-
let merge_cmd =
417
-
let doc = "3-way merge between branches." in
418
-
let man =
419
-
[
420
-
`S Manpage.s_description;
421
-
`P
422
-
"Two-phase merge: phase 1 resolves automatically (structural merge for \
423
-
trees, typed merge for leaves). Phase 2 handles conflicts via the \
424
-
--resolver strategy.";
425
-
`S Manpage.s_examples;
426
-
`Pre " irmin merge feature";
427
-
`Pre " irmin merge feature --resolver ours";
428
-
]
429
-
in
430
-
Cmd.v
431
-
(Cmd.info "merge" ~doc ~man)
432
-
Term.(
433
-
const (fun () repo branch theirs resolver ->
434
-
Cmd_merge.run ~repo ~branch ~theirs ~resolver ())
435
-
$ setup $ repo $ branch $ merge_theirs $ merge_resolver)
436
-
437
-
(* === pull === *)
438
-
439
-
let pull_remote =
440
-
let doc = "Remote repository path." in
441
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"REMOTE" ~doc)
442
-
443
-
let pull_cmd =
444
-
let doc = "Pull and merge from a remote store." in
445
-
let man =
446
-
[
447
-
`S Manpage.s_examples;
448
-
`Pre " irmin pull /path/to/remote";
449
-
`Pre " irmin pull /path/to/remote --resolver theirs";
450
-
]
451
-
in
452
-
Cmd.v
453
-
(Cmd.info "pull" ~doc ~man)
454
-
Term.(
455
-
const (fun () repo branch remote resolver ->
456
-
Cmd_pull.run ~repo ~branch ~remote ~resolver ())
457
-
$ setup $ repo $ branch $ pull_remote $ merge_resolver)
458
-
459
-
(* === push === *)
460
-
461
-
let push_remote =
462
-
let doc = "Remote repository path." in
463
-
Arg.(required & pos 0 (some string) None & info [] ~docv:"REMOTE" ~doc)
464
-
465
-
let push_cmd =
466
-
let doc = "Push to a remote store (fast-forward only)." in
467
-
let man = [ `S Manpage.s_examples; `Pre " irmin push /path/to/remote" ] in
468
-
Cmd.v
469
-
(Cmd.info "push" ~doc ~man)
470
-
Term.(
471
-
const (fun () repo branch remote -> Cmd_push.run ~repo ~branch ~remote ())
472
-
$ setup $ repo $ branch $ push_remote)
473
-
474
-
(* === Main === *)
475
-
476
5
let cmd =
477
6
let doc = "Content-addressed storage" in
478
7
let man =
···
490
19
let info = Cmd.info "irmin" ~version:Monopam_info.version ~doc ~man in
491
20
Cmd.group info
492
21
[
493
-
init_cmd;
494
-
read_cmd;
495
-
set_cmd;
496
-
del_cmd;
497
-
list_cmd;
498
-
tree_cmd;
499
-
log_cmd;
500
-
branches_cmd;
501
-
checkout_cmd;
502
-
import_cmd;
503
-
export_cmd;
504
-
info_cmd;
505
-
proof_cmd;
506
-
merge_cmd;
507
-
pull_cmd;
508
-
push_cmd;
509
-
serve_cmd;
22
+
Cmd_init.cmd;
23
+
Cmd_get.cmd;
24
+
Cmd_set.cmd;
25
+
Cmd_del.cmd;
26
+
Cmd_list.cmd;
27
+
Cmd_tree.cmd;
28
+
Cmd_log.cmd;
29
+
Cmd_branches.cmd;
30
+
Cmd_checkout.cmd;
31
+
Cmd_import.cmd;
32
+
Cmd_export.cmd;
33
+
Cmd_info.cmd;
34
+
Cmd_proof.cmd;
35
+
Cmd_merge.cmd;
36
+
Cmd_pull.cmd;
37
+
Cmd_push.cmd;
38
+
Cmd_serve.cmd;
510
39
]
511
40
512
41
let () = exit (Cmd.eval cmd)
+25
bin/terms.ml
+25
bin/terms.ml
···
1
+
(** Shared Cmdliner terms for the irmin CLI. *)
2
+
3
+
open Cmdliner
4
+
5
+
let setup = Vlog.setup "irmin"
6
+
7
+
let repo =
8
+
let doc = "Repository directory." in
9
+
Arg.(value & opt string "." & info [ "r"; "repo" ] ~docv:"DIR" ~doc)
10
+
11
+
let branch =
12
+
let doc = "Branch name." in
13
+
Arg.(value & opt string "main" & info [ "b"; "branch" ] ~docv:"NAME" ~doc)
14
+
15
+
let output =
16
+
let doc = "Output format: $(b,human) for terminal, $(b,json) for scripts." in
17
+
Arg.(
18
+
value
19
+
& opt (enum [ ("human", `Human); ("json", `Json) ]) `Human
20
+
& info [ "o"; "output" ] ~docv:"FORMAT" ~doc)
21
+
22
+
let message =
23
+
let doc = "Commit message." in
24
+
Arg.(
25
+
value & opt (some string) None & info [ "m"; "message" ] ~docv:"MSG" ~doc)
+53
-48
lib/ui/drop_zone.ml
+53
-48
lib/ui/drop_zone.ml
···
3
3
module H = Tw_html
4
4
module A = Tw_html.At
5
5
6
+
let label_tw =
7
+
Tw.
8
+
[
9
+
block;
10
+
px 6;
11
+
py 8;
12
+
border_md;
13
+
border_dashed;
14
+
border_color ~shade:300 gray;
15
+
rounded_xl;
16
+
text_center;
17
+
text_sm;
18
+
text ~shade:600 gray;
19
+
bg white;
20
+
cursor_pointer;
21
+
transition;
22
+
hover
23
+
[
24
+
border_color Brand.primary;
25
+
text Brand.primary;
26
+
bg ~opacity:5 Brand.primary;
27
+
];
28
+
]
29
+
30
+
let submit_on_change =
31
+
"this.form.dispatchEvent(new Event('submit',{cancelable:true,bubbles:true}))"
32
+
33
+
let file_input =
34
+
H.input
35
+
~at:
36
+
[
37
+
A.type' "file";
38
+
A.name "file";
39
+
A.v "multiple" "";
40
+
A.onchange submit_on_change;
41
+
]
42
+
~tw:Tw.[ hidden ]
43
+
()
44
+
45
+
let prompt =
46
+
[
47
+
H.div ~tw:Tw.[ mb 2; text_2xl; text ~shade:400 gray ] [ H.raw "↥" ];
48
+
H.div
49
+
[
50
+
H.txt "Drop files here or ";
51
+
H.span
52
+
~tw:Tw.[ text Brand.primary; font_medium; underline ]
53
+
[ H.txt "click to browse" ];
54
+
];
55
+
file_input;
56
+
]
57
+
6
58
let v ~upload_url ~target_dir =
7
59
H.form
8
60
~at:
···
14
66
~tw:Tw.[ mt 6 ]
15
67
[
16
68
H.input ~at:[ A.type' "hidden"; A.name "dir"; A.value target_dir ] ();
17
-
H.label
18
-
~tw:
19
-
Tw.
20
-
[
21
-
block;
22
-
px 6;
23
-
py 8;
24
-
border_md;
25
-
border_dashed;
26
-
border_color ~shade:300 gray;
27
-
rounded_xl;
28
-
text_center;
29
-
text_sm;
30
-
text ~shade:600 gray;
31
-
bg white;
32
-
cursor_pointer;
33
-
transition;
34
-
hover
35
-
[
36
-
border_color Brand.primary;
37
-
text Brand.primary;
38
-
bg ~opacity:5 Brand.primary;
39
-
];
40
-
]
41
-
[
42
-
H.div
43
-
~tw:Tw.[ mb 2; text_2xl; text ~shade:400 gray ]
44
-
[ H.raw "↥" ];
45
-
H.div
46
-
[
47
-
H.txt "Drop files here or ";
48
-
H.span
49
-
~tw:Tw.[ text Brand.primary; font_medium; underline ]
50
-
[ H.txt "click to browse" ];
51
-
];
52
-
H.input
53
-
~at:
54
-
[
55
-
A.type' "file";
56
-
A.name "file";
57
-
A.v "multiple" "";
58
-
A.onchange
59
-
"this.form.dispatchEvent(new \
60
-
Event('submit',{cancelable:true,bubbles:true}))";
61
-
]
62
-
~tw:Tw.[ hidden ]
63
-
();
64
-
];
69
+
H.label ~tw:label_tw prompt;
65
70
]