An embedded, single-file key-value store for OCaml, inspired by BoltDB and LMDB.
desertthunder.dev
1open Cmdliner
2
3let init_cmd =
4 let doc = "Initialize a new lithos database" in
5 let path_arg =
6 let doc = "Path to the database file" in
7 Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
8 in
9
10 let page_size_arg =
11 let doc = "Page size in bytes" in
12 Arg.(value & opt int 4096 & info [ "page-size" ] ~docv:"SIZE" ~doc)
13 in
14
15 let init_fn path page_size =
16 match Lithos.Io.create_database path page_size with
17 | Ok () ->
18 Printf.printf "Database created at %s with page size %d\n" path page_size;
19 0
20 | Error err ->
21 Printf.eprintf "Error: %s\n" (Lithos.Error.to_string err);
22 1
23 in
24
25 let info = Cmd.info "init" ~doc in
26 Cmd.v info Term.(const init_fn $ path_arg $ page_size_arg)
27;;
28
29let info_cmd =
30 let doc = "Display database information" in
31 let path_arg =
32 let doc = "Path to the database file" in
33 Arg.(required & pos 0 (some string) None & info [] ~docv:"PATH" ~doc)
34 in
35
36 let info_fn path =
37 match Lithos.Io.read_header path with
38 | Ok meta ->
39 Printf.printf "Database: %s\n" path;
40 Printf.printf "Version: %d\n" meta.Lithos.Types.version;
41 Printf.printf "Page size: %d bytes\n" meta.Lithos.Types.page_size;
42 begin match meta.Lithos.Types.root_bucket with
43 | None -> Printf.printf "Root bucket: None\n"
44 | Some id -> Printf.printf "Root bucket: %Ld\n" id
45 end;
46 0
47 | Error err ->
48 Printf.eprintf "Error: %s\n" (Lithos.Error.to_string err);
49 1
50 in
51
52 let cmd_info = Cmd.info "info" ~doc in
53 Cmd.v cmd_info Term.(const info_fn $ path_arg)
54;;
55
56let default_cmd =
57 let doc = "Lithos - An embedded key-value database" in
58 let sdocs = Manpage.s_common_options in
59 let man =
60 [ `S Manpage.s_description
61 ; `P "Lithos is an embedded, transactional key-value database written in OCaml."
62 ; `S Manpage.s_commands
63 ; `S Manpage.s_common_options
64 ; `S Manpage.s_bugs
65 ; `P "Report bugs at https://github.com/desertthunder/lithos/issues"
66 ]
67 in
68
69 let info = Cmd.info "lithos" ~version:"0.1.0" ~doc ~sdocs ~man in
70 Cmd.group info [ init_cmd; info_cmd ]
71;;
72
73let () = exit (Cmd.eval' default_cmd)