desertthunder.dev
+38
README.md
+38
README.md
···
3
3
An embedded, single-file key-value store for OCaml, inspired by BoltDB and LMDB.
4
4
It offers ACID transactions, B-tree–backed pages, and copy-on-write MVCC with a minimal API.
5
5
6
+
## CLI Usage
7
+
8
+
### Initialize a Database
9
+
10
+
Create a new lithos database with default 4KB page size:
11
+
12
+
```sh
13
+
lithos init mydata.db
14
+
# Or specify a custom page size:
15
+
lithos init mydata.db --page-size 8192
16
+
```
17
+
18
+
### Display Database Information
19
+
20
+
View metadata about an existing database:
21
+
22
+
```sh
23
+
$ lithos info mydata.db
24
+
Database: mydata.db
25
+
Version: 1
26
+
Page size: 4096 bytes
27
+
Root bucket: None
28
+
```
29
+
6
30
## Development
7
31
32
+
### Setup
33
+
8
34
```sh
9
35
opam switch create lithos 5.3.0
10
36
eval $(opam env)
11
37
12
38
opam install dune alcotest checkseum fmt logs cmdliner
13
39
```
40
+
41
+
### Commands
42
+
43
+
```sh
44
+
dune build
45
+
46
+
# Test
47
+
dune test
48
+
49
+
# Run CLI
50
+
dune exec lithos -- <command> [args]
51
+
```
+1
-1
bin/dune
+1
-1
bin/dune
+73
-1
bin/main.ml
+73
-1
bin/main.ml
···
1
-
let () = print_endline "Hello, World!"
1
+
open Cmdliner
2
+
3
+
let 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
+
29
+
let 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
+
56
+
let 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
+
73
+
let () = exit (Cmd.eval' default_cmd)
+15
lib/bucket.ml
+15
lib/bucket.ml
···
1
+
(** Bucket operations for key-value storage *)
2
+
3
+
type 'mode t = unit
4
+
5
+
let get _ _ = Ok None
6
+
7
+
let put _ _ _ = Ok ()
8
+
9
+
let delete _ _ = Ok ()
10
+
11
+
let create_bucket _ _ = Ok ()
12
+
13
+
let bucket _ _ = Ok None
14
+
15
+
let cursor (_ : 'mode t) : 'mode Cursor.t = Obj.magic ()
+22
lib/bucket.mli
+22
lib/bucket.mli
···
1
+
(** Bucket operations for key-value storage *)
2
+
3
+
(** Bucket handle parameterized by transaction mode *)
4
+
type 'mode t
5
+
6
+
(** Get a value by key *)
7
+
val get : 'mode t -> string -> (string option, Error.t) result
8
+
9
+
(** Put a key-value pair (only in read-write mode) *)
10
+
val put : Types.rw t -> string -> string -> (unit, Error.t) result
11
+
12
+
(** Delete a key (only in read-write mode) *)
13
+
val delete : Types.rw t -> string -> (unit, Error.t) result
14
+
15
+
(** Create or open a nested bucket (only in read-write mode) *)
16
+
val create_bucket : Types.rw t -> string -> (Types.rw t, Error.t) result
17
+
18
+
(** Open a nested bucket *)
19
+
val bucket : 'mode t -> string -> ('mode t option, Error.t) result
20
+
21
+
(** Create a cursor for iteration *)
22
+
val cursor : 'mode t -> 'mode Cursor.t
+15
lib/cursor.ml
+15
lib/cursor.ml
+22
lib/cursor.mli
+22
lib/cursor.mli
···
1
+
(** Cursor for iterating over key-value pairs *)
2
+
3
+
(** Cursor handle parameterized by transaction mode *)
4
+
type 'mode t
5
+
6
+
(** Convert cursor to a sequence of key-value pairs *)
7
+
val to_seq : 'mode t -> (string * string) Seq.t
8
+
9
+
(** Seek to a specific key *)
10
+
val seek : 'mode t -> string -> unit
11
+
12
+
(** Move to first key *)
13
+
val first : 'mode t -> (string * string) option
14
+
15
+
(** Move to last key *)
16
+
val last : 'mode t -> (string * string) option
17
+
18
+
(** Move to next key *)
19
+
val next : 'mode t -> (string * string) option
20
+
21
+
(** Move to previous key *)
22
+
val prev : 'mode t -> (string * string) option
+29
lib/db.ml
+29
lib/db.ml
···
1
+
(** Database handle and operations *)
2
+
3
+
type t =
4
+
{ path : string [@warning "-69"]
5
+
; meta : Types.metadata
6
+
}
7
+
8
+
let open_db path =
9
+
match Io.read_header path with
10
+
| Ok meta -> Ok { path; meta }
11
+
| Error (Error.IO_error _) ->
12
+
Result.bind (Io.create_database path 4096) (fun () ->
13
+
Result.map (fun meta -> { path; meta }) (Io.read_header path))
14
+
| Error err -> Error err
15
+
;;
16
+
17
+
let close _ = Ok ()
18
+
19
+
let metadata db = db.meta
20
+
21
+
let view _ f =
22
+
let txn : Types.ro Txn.t = Obj.magic () in
23
+
f txn
24
+
;;
25
+
26
+
let update _ f =
27
+
let txn : Types.rw Txn.t = Obj.magic () in
28
+
f txn
29
+
;;
+19
lib/db.mli
+19
lib/db.mli
···
1
+
(** Database handle and operations *)
2
+
3
+
(** Opaque database handle *)
4
+
type t
5
+
6
+
(** Open or create a database file *)
7
+
val open_db : string -> (t, Error.t) result
8
+
9
+
(** Close the database *)
10
+
val close : t -> (unit, Error.t) result
11
+
12
+
(** Get database metadata *)
13
+
val metadata : t -> Types.metadata
14
+
15
+
(** Execute a read-only transaction *)
16
+
val view : t -> (Types.ro Txn.t -> ('a, Error.t) result) -> ('a, Error.t) result
17
+
18
+
(** Execute a read-write transaction *)
19
+
val update : t -> (Types.rw Txn.t -> ('a, Error.t) result) -> ('a, Error.t) result
+69
lib/io.ml
+69
lib/io.ml
···
1
+
(** Low-level I/O operations for database files *)
2
+
3
+
let magic = "LITHOS\x00\x00"
4
+
let version = 1
5
+
6
+
let create_database path page_size =
7
+
try
8
+
let fd = Unix.openfile path [ Unix.O_RDWR; Unix.O_CREAT; Unix.O_EXCL ] 0o644 in
9
+
let buf = Bytes.create page_size in
10
+
Bytes.blit_string magic 0 buf 0 (String.length magic);
11
+
12
+
Bytes.set_int32_le buf 8 (Int32.of_int version);
13
+
Bytes.set_int32_le buf 12 (Int32.of_int page_size);
14
+
Bytes.set_int64_le buf 16 Int64.zero;
15
+
16
+
let written = Unix.write fd buf 0 page_size in
17
+
Unix.close fd;
18
+
19
+
if written = page_size then Ok () else Error (Error.IO_error "Failed to write complete header")
20
+
with
21
+
| Unix.Unix_error (err, _, _) -> Error (Error.of_unix_error err path)
22
+
;;
23
+
24
+
let read_header path =
25
+
try
26
+
let fd = Unix.openfile path [ Unix.O_RDONLY ] 0o644 in
27
+
let buf = Bytes.create 256 in
28
+
let read_bytes = Unix.read fd buf 0 256 in
29
+
Unix.close fd;
30
+
31
+
if read_bytes < 24
32
+
then Error (Error.Invalid_database "File too small")
33
+
else (
34
+
let magic_read = Bytes.sub_string buf 0 8 in
35
+
if magic_read <> magic
36
+
then Error (Error.Invalid_database "Invalid magic number")
37
+
else (
38
+
let ver = Int32.to_int (Bytes.get_int32_le buf 8) in
39
+
let page_size = Int32.to_int (Bytes.get_int32_le buf 12) in
40
+
let root = Bytes.get_int64_le buf 16 in
41
+
let root_bucket = if root = Int64.zero then None else Some root in
42
+
Ok { Types.version = ver; page_size; root_bucket }))
43
+
with
44
+
| Unix.Unix_error (err, _, _) -> Error (Error.of_unix_error err path)
45
+
;;
46
+
47
+
let write_header path metadata =
48
+
try
49
+
let fd = Unix.openfile path [ Unix.O_RDWR ] 0o644 in
50
+
let buf = Bytes.create 256 in
51
+
52
+
Bytes.blit_string magic 0 buf 0 (String.length magic);
53
+
Bytes.set_int32_le buf 8 (Int32.of_int metadata.Types.version);
54
+
Bytes.set_int32_le buf 12 (Int32.of_int metadata.Types.page_size);
55
+
56
+
let root =
57
+
match metadata.Types.root_bucket with
58
+
| None -> Int64.zero
59
+
| Some id -> id
60
+
in
61
+
Bytes.set_int64_le buf 16 root;
62
+
63
+
let written = Unix.write fd buf 0 256 in
64
+
Unix.close fd;
65
+
66
+
if written = 256 then Ok () else Error (Error.IO_error "Failed to write header")
67
+
with
68
+
| Unix.Unix_error (err, _, _) -> Error (Error.of_unix_error err path)
69
+
;;
+10
lib/io.mli
+10
lib/io.mli
···
1
+
(** Low-level I/O operations for database files *)
2
+
3
+
(** Create a new database file with the specified page size *)
4
+
val create_database : string -> int -> (unit, Error.t) result
5
+
6
+
(** Read and parse the database header *)
7
+
val read_header : string -> (Types.metadata, Error.t) result
8
+
9
+
(** Write metadata to database header *)
10
+
val write_header : string -> Types.metadata -> (unit, Error.t) result
+14
lib/txn.ml
+14
lib/txn.ml
···
1
+
(** Transaction operations with phantom types for mode safety *)
2
+
3
+
type 'mode t = { mutable state : Types.txn_state }
4
+
5
+
let root (_ : 'mode t) : ('mode Bucket.t, Error.t) result = Ok (Obj.magic ())
6
+
7
+
let state txn = txn.state
8
+
9
+
let commit txn =
10
+
txn.state <- Types.Committed;
11
+
Ok ()
12
+
;;
13
+
14
+
let rollback txn = txn.state <- Types.Rolled_back
+16
lib/txn.mli
+16
lib/txn.mli
···
1
+
(** Transaction operations with phantom types for mode safety *)
2
+
3
+
(** Transaction handle parameterized by mode ('mode = ro | rw) *)
4
+
type 'mode t
5
+
6
+
(** Get the root bucket *)
7
+
val root : 'mode t -> ('mode Bucket.t, Error.t) result
8
+
9
+
(** Get transaction state *)
10
+
val state : 'mode t -> Types.txn_state
11
+
12
+
(** Commit a read-write transaction *)
13
+
val commit : Types.rw t -> (unit, Error.t) result
14
+
15
+
(** Rollback a transaction *)
16
+
val rollback : 'mode t -> unit
+18
lib/types.ml
+18
lib/types.ml
+20
lib/types.mli
+20
lib/types.mli
···
1
+
(** Core types for Lithos *)
2
+
3
+
(** Phantom type for read-only transactions *)
4
+
type ro
5
+
6
+
(** Phantom type for read-write transactions *)
7
+
type rw
8
+
9
+
type page_id = int64
10
+
11
+
type metadata = {
12
+
version : int;
13
+
page_size : int;
14
+
root_bucket : page_id option;
15
+
}
16
+
17
+
type txn_state =
18
+
| Active
19
+
| Committed
20
+
| Rolled_back
+72
test/test_io.ml
+72
test/test_io.ml
···
1
+
(** Tests for I/O module *)
2
+
3
+
let test_create_database () =
4
+
let path = Filename.temp_file "lithos_test" ".db" in
5
+
Unix.unlink path;
6
+
let cleanup () =
7
+
try Unix.unlink path with
8
+
| _ -> ()
9
+
in
10
+
11
+
let open Lithos.Io in
12
+
match create_database path 4096 with
13
+
| Ok () ->
14
+
Alcotest.(check bool) "File exists" true (Sys.file_exists path);
15
+
cleanup ()
16
+
| Error err ->
17
+
cleanup ();
18
+
Alcotest.fail (Lithos.Error.to_string err)
19
+
;;
20
+
21
+
let test_read_header () =
22
+
let path = Filename.temp_file "lithos_test" ".db" in
23
+
Unix.unlink path;
24
+
let cleanup () =
25
+
try Unix.unlink path with
26
+
| _ -> ()
27
+
in
28
+
29
+
let open Lithos.Io in
30
+
match create_database path 4096 with
31
+
| Error err ->
32
+
cleanup ();
33
+
Alcotest.fail (Lithos.Error.to_string err)
34
+
| Ok () ->
35
+
(match read_header path with
36
+
| Ok meta ->
37
+
Alcotest.(check int) "Page size" 4096 meta.Lithos.Types.page_size;
38
+
Alcotest.(check int) "Version" 1 meta.Lithos.Types.version;
39
+
cleanup ()
40
+
| Error err ->
41
+
cleanup ();
42
+
Alcotest.fail (Lithos.Error.to_string err))
43
+
;;
44
+
45
+
let test_invalid_database () =
46
+
let path = Filename.temp_file "lithos_test" ".txt" in
47
+
let cleanup () =
48
+
try Unix.unlink path with
49
+
| _ -> ()
50
+
in
51
+
52
+
let oc = open_out path in
53
+
output_string oc "not a database file";
54
+
close_out oc;
55
+
56
+
let open Lithos.Io in
57
+
match read_header path with
58
+
| Ok _ ->
59
+
cleanup ();
60
+
Alcotest.fail "Should have failed on invalid database"
61
+
| Error (Invalid_database _) -> cleanup ()
62
+
| Error err ->
63
+
cleanup ();
64
+
Alcotest.fail ("Wrong error: " ^ Lithos.Error.to_string err)
65
+
;;
66
+
67
+
let suite =
68
+
[ "create_database", `Quick, test_create_database
69
+
; "read_header", `Quick, test_read_header
70
+
; "invalid_database", `Quick, test_invalid_database
71
+
]
72
+
;;