diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/abstract/Storage.ml | 3 | ||||
| -rw-r--r-- | lib/backend/storage/LMDB.ml | 26 | ||||
| -rw-r--r-- | lib/concepts/Condition.ml | 2 | ||||
| -rw-r--r-- | lib/concepts/Condition.mli | 3 | ||||
| -rw-r--r-- | lib/concepts/Configuration.ml | 71 | ||||
| -rw-r--r-- | lib/concepts/Configuration.mli | 15 | ||||
| -rw-r--r-- | lib/concepts/Hash.ml | 10 | ||||
| -rw-r--r-- | lib/concepts/Representation.ml | 38 | ||||
| -rw-r--r-- | lib/concepts/Value.ml | 3 | ||||
| -rw-r--r-- | lib/concepts/Value.mli | 3 | ||||
| -rw-r--r-- | lib/dune | 3 | ||||
| -rw-r--r-- | lib/rnt.ml | 3 |
12 files changed, 153 insertions, 27 deletions
diff --git a/lib/abstract/Storage.ml b/lib/abstract/Storage.ml index f456567..2358c67 100644 --- a/lib/abstract/Storage.ml +++ b/lib/abstract/Storage.ml @@ -2,8 +2,7 @@ module type STORAGE = sig type connection type transaction - val connect : - Concepts.Configuration.configuration -> (connection, Concepts.Condition.condition) result + val connect : Concepts.Configuration.term -> (connection, Concepts.Condition.condition) result (** begin a transaction within `connection` *) val start : connection -> (transaction, Concepts.Condition.condition) result diff --git a/lib/backend/storage/LMDB.ml b/lib/backend/storage/LMDB.ml index f4fcea1..0d7f8d0 100644 --- a/lib/backend/storage/LMDB.ml +++ b/lib/backend/storage/LMDB.ml @@ -55,11 +55,8 @@ module C = struct foreign "mdb_txn_begin" (ptr mdb_env @-> ptr mdb_txn @-> uint @-> ptr (ptr mdb_txn) @-> returning mdb_result) - let mdb_txn_begin' env parent flags = with_output_pointer - (ptr mdb_txn) - (from_voidp mdb_txn null) - (mdb_txn_begin env parent flags) - [@@ocamlformat "disable"] + let mdb_txn_begin' env parent flags = + with_output_pointer (ptr mdb_txn) (from_voidp mdb_txn null) (mdb_txn_begin env parent flags) let mdb_txn_commit = foreign "mdb_txn_commit" (ptr mdb_txn @-> returning mdb_result) let mdb_txn_abort = foreign "mdb_txn_abort" (ptr mdb_txn @-> returning mdb_result) @@ -125,12 +122,20 @@ end type connection = {env: C.mdb_env_ptr; dbi: C.mdb_dbi} type transaction = {tx: C.mdb_txn_ptr; dbi: C.mdb_dbi} -let connect (_ : Concepts.Configuration.configuration) = +let parse (c : Concepts.Configuration.term) = + let open Concepts.Configuration in + let open Utilities.Result in + let* config = as_dictionary c "lmdb" in + let* path = value_for "path" config |> fmap as_string in + let* mode = value_for "mode" config |> fmap as_int in + Ok (path, mode) + +let connect (c : Concepts.Configuration.term) = + let open Utilities.Result in + let* path, mode = parse c in begin - let open Utilities.Result in let* env = C.mdb_env_create' () in - (* TODO: make the path, POSIX mode a config parameter *) - match C.mdb_env_open env "/tmp/sakura.db" Unsigned.UInt.zero (PosixTypes.Mode.of_int 420) with + match C.mdb_env_open env path Unsigned.UInt.zero (PosixTypes.Mode.of_int mode) with | Error x -> C.mdb_env_close env; Error x | Ok () -> let* tx = C.mdb_txn_begin' env C.null_txn Unsigned.UInt.zero in @@ -139,6 +144,9 @@ let connect (_ : Concepts.Configuration.configuration) = Ok {env; dbi} end |> Result.map_error Error.lmdb_error + |> Result.map_error + Concepts.Condition.( + complement ("path" |=| Concepts.Value.String path & "mode" |=| Concepts.Value.Integer mode) ) let start ({env; dbi} : connection) = C.mdb_txn_begin' env C.null_txn Unsigned.UInt.zero diff --git a/lib/concepts/Condition.ml b/lib/concepts/Condition.ml index cc0f7a7..16f02d0 100644 --- a/lib/concepts/Condition.ml +++ b/lib/concepts/Condition.ml @@ -18,6 +18,8 @@ let condition name message ?parent props = |> Option.value ~default:BatMap.empty |> props } +let complement props ({properties; _} as condition) = {condition with properties= props properties} + let to_string_hum {name; message; properties; backtrace} = let properties' = properties diff --git a/lib/concepts/Condition.mli b/lib/concepts/Condition.mli index fba43e6..86c86fa 100644 --- a/lib/concepts/Condition.mli +++ b/lib/concepts/Condition.mli @@ -10,5 +10,8 @@ val empty : ps (** construct a condition out of a name, a message, a set of properties and an optional parent *) val condition : string -> string -> ?parent:condition -> ps -> condition +(** complement a condition with an extra set of properties *) +val complement : ps -> condition -> condition + (** print a condition to a human-readable string *) val to_string_hum : condition -> string diff --git a/lib/concepts/Configuration.ml b/lib/concepts/Configuration.ml index 06434c2..5ca95d5 100644 --- a/lib/concepts/Configuration.ml +++ b/lib/concepts/Configuration.ml @@ -1 +1,70 @@ -type configuration = unit +open Sexplib.Sexp + +type term = Sexplib.Sexp.t + +module Error = struct + open Condition + + let missing_key key = + condition "missing-key" "An expected key was not found" ("key" |=| Value.String key) + + let mismatched_tag expected actual = + condition "mismatched-tag" "A tag did not match what was expected" + ("expected" |=| Value.String expected & "actual" |=| Value.String actual) + + let syntax_error form = + condition "syntax-error" "Syntax error" + ("form" |=| Value.String (Sexplib.Sexp.to_string_hum form)) + + let tagless_form form = + condition "tagless-form" "Cannot take tag of an atom or an empty list" + ~parent:(syntax_error form) empty + + let bodyless_form form = + condition "bodyless-form" "Cannot take body of an atom or an empty list" + ~parent:(syntax_error form) empty + + let malformed_pair form = + condition "malformed-pair" "Expected a pair of key and value" ~parent:(syntax_error form) empty + + let expected_atom form = + condition "expected-atom" "Expected atom but got list structure" ~parent:(syntax_error form) + empty + + let not_a_number form = + condition "not-a-number" "Could not parse value as number" ~parent:(syntax_error form) empty +end + +let term_of_sexp t = t +let tag_of = function List (Atom tag :: _) -> Ok tag | form -> Error (Error.tagless_form form) +let body_of = function List (_ :: body) -> Ok body | form -> Error (Error.bodyless_form form) + +type dictionary = (string, term) BatMap.t + +let value_for k ?default d = + let default = Option.to_result ~none:(Error.missing_key k) default in + BatMap.find_opt k d |> Option.map (fun x -> Ok x) |> Option.value ~default + +let as_dictionary t tag : (dictionary, Condition.condition) result = + let open Utilities.Result in + let strip_tag (tag : string) (t : term) = + let* tag' = tag_of t in + if tag' = tag then body_of t else Error (Error.mismatched_tag tag tag') + in + let as_dictionary' pairs = + List.fold_right + (fun term dict -> + let* dict = dict in + match term with + | List [Atom k; v] -> Ok (BatMap.add k v dict) + | p -> Error (Error.malformed_pair p) ) + pairs (Ok BatMap.empty) + in + strip_tag tag t |> fmap as_dictionary' + +let as_string = function Atom s -> Ok s | form -> Error (Error.expected_atom form) + +let as_int f = + let open Utilities.Result in + let* s = as_string f in + int_of_string_opt s |> Option.to_result ~none:(Error.not_a_number f) diff --git a/lib/concepts/Configuration.mli b/lib/concepts/Configuration.mli index 5e16ff9..d633f5c 100644 --- a/lib/concepts/Configuration.mli +++ b/lib/concepts/Configuration.mli @@ -1,2 +1,13 @@ -(** an abstract representation for a system configuration *) -type configuration +(** an abstract representation of a system configuration expression *) +type term + +val term_of_sexp : Sexplib.Sexp.t -> term +val tag_of : term -> (string, Condition.condition) result + +(** an abstract type associating strings to configuration values *) +type dictionary + +val value_for : string -> ?default:term -> dictionary -> (term, Condition.condition) result +val as_dictionary : term -> string -> (dictionary, Condition.condition) result +val as_int : term -> (int, Condition.condition) result +val as_string : term -> (string, Condition.condition) result diff --git a/lib/concepts/Hash.ml b/lib/concepts/Hash.ml index 681ec4a..106e731 100644 --- a/lib/concepts/Hash.ml +++ b/lib/concepts/Hash.ml @@ -1,5 +1,7 @@ -type hash = bytes +type hash = Digestif.SHA256.t -let hash_of_value (_ : Value.value) = failwith "TODO" -let hash_equals (_ : hash) (_ : hash) = failwith "TODO" -let bytes_of_hash (h : hash) = h +let hash_of_value (v : Value.value) = + Representation.(blob_of_value v |> bytes_of_blob) |> Digestif.SHA256.digest_bytes + +let hash_equals = Digestif.SHA256.equal +let bytes_of_hash (h : hash) = Bytes.of_string (Digestif.SHA256.to_raw_string h) diff --git a/lib/concepts/Representation.ml b/lib/concepts/Representation.ml index d353a38..856ae11 100644 --- a/lib/concepts/Representation.ml +++ b/lib/concepts/Representation.ml @@ -1,6 +1,34 @@ -type blob = unit +type blob = bytes -let blob_of_value (_ : Value.value) = failwith "TODO" -let value_of_blob (_ : blob) = failwith "TODO" -let blob_of_bytes (_ : bytes) = failwith "TODO" -let bytes_of_blob (_ : blob) = failwith "TODO" +let blob_of_bytes (b : bytes) = b +let bytes_of_blob (b : blob) = b + +(* A blob is a one-byte constructor tag followed by its payload. The + tag makes the encoding self-describing so [value_of_blob] can + recover the constructor: + - String ['\000'] ++ raw utf-8 bytes + - Integer ['\001'] ++ 8-byte big-endian int64 *) +let tag_string = '\000' +let tag_integer = '\001' + +let blob_of_value = function + | Value.String s -> + let b = Bytes.create (1 + String.length s) in + Bytes.set b 0 tag_string; + Bytes.blit_string s 0 b 1 (String.length s); + b + | Value.Integer n -> + let b = Bytes.create 9 in + Bytes.set b 0 tag_integer; + Bytes.set_int64_be b 1 (Int64.of_int n); + b + +let value_of_blob (b : blob) = + let n = Bytes.length b in + if n = 0 then invalid_arg "value_of_blob: empty blob"; + match Bytes.get b 0 with + | c when c = tag_string -> Value.String (Bytes.sub_string b 1 (n - 1)) + | c when c = tag_integer -> + if n <> 9 then invalid_arg "value_of_blob: malformed integer payload"; + Value.Integer (Int64.to_int (Bytes.get_int64_be b 1)) + | c -> invalid_arg (Printf.sprintf "value_of_blob: unknown tag %C" c) diff --git a/lib/concepts/Value.ml b/lib/concepts/Value.ml index 65a0439..75b0e88 100644 --- a/lib/concepts/Value.ml +++ b/lib/concepts/Value.ml @@ -1,3 +1,6 @@ type value = String of string | Integer of int let to_string = function String s -> s | Integer n -> Int.to_string n + +let equal x y = + match x, y with String x, String y -> x = y | Integer x, Integer y -> x = y | _, _ -> false diff --git a/lib/concepts/Value.mli b/lib/concepts/Value.mli index 9644443..c1a9f18 100644 --- a/lib/concepts/Value.mli +++ b/lib/concepts/Value.mli @@ -3,3 +3,6 @@ type value = String of string | Integer of int (** given a value, return a string representation of it *) val to_string : value -> string + +(** given two values, are they the same? *) +val equal : value -> value -> bool @@ -3,4 +3,5 @@ (library (name rnt) (public_name rnt) - (libraries batteries ctypes ctypes-foreign)) + (libraries batteries ctypes ctypes-foreign sexplib digestif) + (flags :standard -cclib -llmdb)) diff --git a/lib/rnt.ml b/lib/rnt.ml deleted file mode 100644 index 7192e6b..0000000 --- a/lib/rnt.ml +++ /dev/null @@ -1,3 +0,0 @@ -(** RNT: Relations, Not Tables. *) - -let version = "0.1.0" |