diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/disk.ml | 55 | ||||
| -rw-r--r-- | lib/planner.ml | 41 | ||||
| -rw-r--r-- | lib/protocol.ml | 5 | ||||
| -rw-r--r-- | lib/relation.ml | 29 | ||||
| -rw-r--r-- | lib/server.ml | 6 |
5 files changed, 80 insertions, 56 deletions
diff --git a/lib/disk.ml b/lib/disk.ml index 503eda3..7d53f77 100644 --- a/lib/disk.ml +++ b/lib/disk.ml @@ -31,7 +31,8 @@ module FileSystem (C : Configuration) : FileSystem = struct | Storage -> C.storage ^ "storage.re" | Transaction -> C.transactions ^ "transaction.re" - (** [append target content] writes content to file in append only format, returning [content_length * offset_written] *) + (** [append target content] writes content to file in append only format, + returning [content_length * offset_written] *) let append target content = let register channel = let offset_written = @@ -92,12 +93,14 @@ module Executor = struct type history = t list [@@deriving show] end - type relational_type = - | Text - | Integer32 - | Integer64 - | Boolean - | DiscriminatedUnion of (string * relational_type option) list * string (* [("MemberA", None); ("MemberB", Some Integer32)], "NameOfDU" *) + type relational_type = + | Text + | Integer32 + | Integer64 + | Boolean + | DiscriminatedUnion of (string * relational_type option) list * string + (* [("MemberA", None); ("MemberB", Some Integer32)], "NameOfDU" *) + | Relation of string type schema = (string * relational_type) list StringMap.t type references = string list IntMap.t StringMap.t @@ -106,7 +109,7 @@ module Executor = struct state : string; files : Hashes.history StringMap.t; references : references; - schema : schema + schema : schema; } type history = commit list @@ -242,10 +245,13 @@ module Executor = struct Ok ((commit, locations), Some computed_hash) | None -> Ok ((commit, locations), None)) - let read ({ files; _ } as _commit : commit) (locations : locations) ~filename = + let read ({ files; _ } as _commit : commit) (locations : locations) ~filename + = let open Extensions.Option in let+ history : Hashes.history = StringMap.find_opt filename files in - let+ { values = location_hashes; _ } : Hashes.t = match history with [] -> None | history -> Some(List.hd history) in + let+ { values = location_hashes; _ } : Hashes.t = + match history with [] -> None | history -> Some (List.hd history) + in let physical_locations = List.map (fun hash -> StringMap.find hash locations) location_hashes in @@ -263,11 +269,10 @@ module Executor = struct let read_location ~hash (locations : locations) = match StringMap.find_opt hash locations with - | Some ({ offset; size; _ } : Location.t) -> - begin match FS.read FS.Storage offset size with - | Ok x -> x - | Error err -> failwith err - end + | Some ({ offset; size; _ } : Location.t) -> ( + match FS.read FS.Storage offset size with + | Ok x -> x + | Error err -> failwith err) | None -> failwith "Location could not be found." end @@ -318,7 +323,7 @@ module Command = struct (fun (kind, timestamp, hash, filename, entity_id, content) -> { kind; timestamp; hash; filename; entity_id; content }) Data_encoding.( - tup6 command_kind_encoding float string string (option int64) string) + tup6 command_kind_encoding float string string (option int64) string) let parse_command ~data = let contract_encoding = @@ -337,8 +342,9 @@ module Command = struct | Nothing [@@deriving show] - (** TODO: This does not write atomically. If the system crashes while it attempts to write, it will corrupt. - Solve this with a temporary file and move later. *) + (** TODO: This does not write atomically. If the system crashes while it + attempts to write, it will corrupt. Solve this with a temporary file and + move later. *) let commit_and_perform (commit : Executor.commit) (locations : Executor.locations) command = let open Extensions.Result in @@ -396,12 +402,13 @@ module Command = struct let entities : string list Executor.IntMap.t = print_endline command.filename; Executor.StringMap.find_opt command.filename commit.references - |> function Some entities -> - print_endline "-----> A"; - entities - | None -> - print_endline "-----> B"; - Executor.IntMap.empty + |> function + | Some entities -> + print_endline "-----> A"; + entities + | None -> + print_endline "-----> B"; + Executor.IntMap.empty in let content = Executor.IntMap.fold diff --git a/lib/planner.ml b/lib/planner.ml index 0d333f1..0470092 100644 --- a/lib/planner.ml +++ b/lib/planner.ml @@ -1,28 +1,33 @@ module type Action = sig (* Names of the attributes & The tuples *) type tuples = string list * bytes list list - val execute: tuples -> int + + val execute : tuples -> int end module Scan = struct open Disk - let execute commit locations (entity: string) = - Executor.read commit locations ~filename:("schema~" ^ entity) - |> function - | Some binary -> - begin - let relation = - Result.map_error (fun _ -> "Failed to deserialize relation from binary format.") - @@ Data_encoding.Binary.of_bytes Schema.Protocol.relation_encoding (Bytes.concat Bytes.empty binary) in - match relation with - | Ok relation -> - begin - let _attrs = List.map (fun (a: Schema.Protocol.attribute) -> relation.name ^ "/" ^ a.name) relation.attributes in - Executor.read commit locations ~filename:("schema~" ^ entity) - end - | Error err -> failwith err - end - | None -> failwith "" + + let execute commit locations (entity : string) = + Executor.read commit locations ~filename:("schema~" ^ entity) |> function + | Some binary -> ( + let relation = + Result.map_error (fun _ -> + "Failed to deserialize relation from binary format.") + @@ Data_encoding.Binary.of_bytes Schema.Protocol.relation_encoding + (Bytes.concat Bytes.empty binary) + in + match relation with + | Ok relation -> + let _attrs = + List.map + (fun (a : Schema.Protocol.attribute) -> + relation.name ^ "/" ^ a.name) + relation.attributes + in + Executor.read commit locations ~filename:("schema~" ^ entity) + | Error err -> failwith err) + | None -> failwith "" end module Join = struct diff --git a/lib/protocol.ml b/lib/protocol.ml index 9dea3ce..79ed8d0 100644 --- a/lib/protocol.ml +++ b/lib/protocol.ml @@ -1,8 +1,7 @@ open Protocol_conv_xml open Sexplib0.Sexp_conv -type tuple = string list -[@@deriving sexp, protocol ~driver:(module Xml_light)] +type tuple = string list [@@deriving sexp, protocol ~driver:(module Xml_light)] type relation = { attribute_name : string; @@ -12,4 +11,4 @@ type relation = { [@@deriving sexp, protocol ~driver:(module Xml_light)] type facts = relation list -[@@deriving sexp, protocol ~driver:(module Xml_light)]
\ No newline at end of file +[@@deriving sexp, protocol ~driver:(module Xml_light)] diff --git a/lib/relation.ml b/lib/relation.ml index 798a082..275bd10 100644 --- a/lib/relation.ml +++ b/lib/relation.ml @@ -1,12 +1,22 @@ let write_and_retrieve () = let open Disk in - let schema = Executor.StringMap.empty |> Executor.StringMap.add "user" [("first_name", Executor.Text); ("last_name", Executor.Text)] in + let schema = + Executor.StringMap.empty + |> Executor.StringMap.add "user" + [ + ("first_name", Executor.Text); + ("last_name", Executor.Text); + ("address", Executor.Relation "address"); + ] + |> Executor.StringMap.add "address" + [ ("street", Executor.Text); ("number", Executor.Integer32) ] + in let commit : Executor.commit = { state = Executor._EMPTY_SHA_HASH_; files = Executor.StringMap.empty; references = Executor.StringMap.empty; - schema + schema; } in let locations : Executor.locations = Executor.StringMap.empty in @@ -112,11 +122,16 @@ let write_and_retrieve () = let+ _, (Command.Read content as response) = Command.commit_and_perform commit locations command_read in - Executor.StringMap.iter (fun k v -> print_endline ("→ " ^ k ^ ": "); - Executor.IntMap.iter (fun k v -> - print_endline (" ↳ " ^ (Int64.to_string k)); - List.iter (fun v -> print_endline (" → " ^ v)) v) v; - print_newline()) references; + Executor.StringMap.iter + (fun k v -> + print_endline ("→ " ^ k ^ ": "); + Executor.IntMap.iter + (fun k v -> + print_endline (" ↳ " ^ Int64.to_string k); + List.iter (fun v -> print_endline (" → " ^ v)) v) + v; + print_newline ()) + references; print_endline (Command.show_return response); Ok (commit, locations) [@@warning "-8-27-26"] diff --git a/lib/server.ml b/lib/server.ml index 46ef85d..4a99b29 100644 --- a/lib/server.ml +++ b/lib/server.ml @@ -46,8 +46,7 @@ let client_read sock maxlen = }; ] in - return - @@ Xml.to_string (Protocol.facts_to_xml_light relation_result) + return @@ Xml.to_string (Protocol.facts_to_xml_light relation_result) | Error err -> return err [@@warning "-27"] @@ -56,8 +55,7 @@ let rec socket_read sock = Lwt_unix.accept sock >>= fun (client, _) -> client_read client 512 (* >>= fun results -> Lwt_unix.send client (Data_encoding.Binary.to_bytes_exn Data_encoding.Encoding.int32 5l) 0 1 [] *) - >>= - fun results -> + >>= fun results -> Lwt_unix.send client (Bytes.of_string results) 0 (String.length results) [] >>= fun _ -> Lwt_unix.wait_write client >>= fun () -> |