diff options
| author | Marcos Magueta <maguetamarcos@gmail.com> | 2026-09-25 21:51:33 -0300 |
|---|---|---|
| committer | Marcos Magueta <maguetamarcos@gmail.com> | 2026-09-25 21:51:33 -0300 |
| commit | 584fbca6d920e9a9f91d451667f9380714ac2175 (patch) | |
| tree | a163b916a6f8cb550c8b38ceb01ab01558687a40 /lib/concepts/Encoding.ml | |
| parent | c7b754e96714eeeb9d315ee3de402d73a27d47db (diff) | |
| download | RNT-584fbca6d920e9a9f91d451667f9380714ac2175.tar.gz RNT-584fbca6d920e9a9f91d451667f9380714ac2175.zip | |
dune fmt
Diffstat (limited to 'lib/concepts/Encoding.ml')
| -rw-r--r-- | lib/concepts/Encoding.ml | 127 |
1 files changed, 54 insertions, 73 deletions
diff --git a/lib/concepts/Encoding.ml b/lib/concepts/Encoding.ml index 5bb9b16..733ff67 100644 --- a/lib/concepts/Encoding.ml +++ b/lib/concepts/Encoding.ml @@ -28,7 +28,7 @@ let value_of_blob (b : Blob.t) = Value.Integer (Int64.to_int (Blob.get_int64_be b 1)) | c -> invalid_arg (Printf.sprintf "value_of_blob: unknown tag %C" c) - module Error = struct +module Error = struct open Condition let unexpected_end = @@ -46,21 +46,19 @@ let value_of_blob (b : Blob.t) = condition "codec-string-out-of-bounds" "A string length runs past the end of input" ("length" |=| Value.Integer length) - let trailing_bytes = - condition "codec-trailing-bytes" "Bytes remain after a complete value" empty + let trailing_bytes = condition "codec-trailing-bytes" "Bytes remain after a complete value" empty let tag_mismatch ~expected ~actual = condition "codec-tag-mismatch" "A value with a different tag was expected" - ("expected" |=| Value.String (String.make 1 expected) & - "actual" |=| Value.String (String.make 1 actual)) + ( "expected" |=| Value.String (String.make 1 expected) + & "actual" |=| Value.String (String.make 1 actual) ) let type_mismatch ~expected = condition "codec-type-mismatch" "A Bencode value of a different shape was expected" ("expected" |=| Value.String expected) let missing_field key = - condition "codec-missing-field" "A required field is absent" - ("field" |=| Value.String key) + condition "codec-missing-field" "A required field is absent" ("field" |=| Value.String key) let unexpected_object ~expected = condition "codec-unexpected-object" "The decoded object is not of the expected kind" @@ -79,38 +77,37 @@ end - List "l" <element>* "e" - Dict "d" (<String key> <value>)* "e" keys sorted on encode *) module Bencode = struct - type t = Tagged of char * t | Int of int | String of string | List of t list | Dict of (string * t) list + type t = + | Tagged of char * t + | Int of int + | String of string + | List of t list + | Dict of (string * t) list let rec encode buf = function - | Tagged (tag, value) -> - Buffer.add_char buf 't'; - Buffer.add_char buf tag; - encode buf value + | Tagged (tag, value) -> Buffer.add_char buf 't'; Buffer.add_char buf tag; encode buf value | Int n -> - Buffer.add_char buf 'i'; - Buffer.add_string buf (string_of_int n); - Buffer.add_char buf 'e' + Buffer.add_char buf 'i'; + Buffer.add_string buf (string_of_int n); + Buffer.add_char buf 'e' | String s -> - Buffer.add_string buf (string_of_int (String.length s)); - Buffer.add_char buf ':'; - Buffer.add_string buf s + Buffer.add_string buf (string_of_int (String.length s)); + Buffer.add_char buf ':'; + Buffer.add_string buf s | List xs -> - Buffer.add_char buf 'l'; - List.iter (encode buf) xs; - Buffer.add_char buf 'e' + Buffer.add_char buf 'l'; + List.iter (encode buf) xs; + Buffer.add_char buf 'e' | Dict kvs -> - Buffer.add_char buf 'd'; - List.iter - (fun (k, v) -> - encode buf (String k); - encode buf v ) - (List.sort (fun (a, _) (b, _) -> String.compare a b) kvs); - Buffer.add_char buf 'e' + Buffer.add_char buf 'd'; + List.iter + (fun (k, v) -> encode buf (String k); encode buf v) + (List.sort (fun (a, _) (b, _) -> String.compare a b) kvs); + Buffer.add_char buf 'e' let to_bytes (value : t) : bytes = let buf = Buffer.create 256 in - encode buf value; - Buffer.to_bytes buf + encode buf value; Buffer.to_bytes buf let as_string = function String s -> Ok s | _ -> Error (Error.type_mismatch ~expected:"string") let as_int = function Int n -> Ok n | _ -> Error (Error.type_mismatch ~expected:"integer") @@ -122,7 +119,7 @@ module Bencode = struct let s = Bytes.to_string bytes in let n = String.length s in let pos = ref 0 in - let peek () = if !pos >= n then Error (Error.unexpected_end) else Ok (s.[!pos]) in + let peek () = if !pos >= n then Error Error.unexpected_end else Ok s.[!pos] in let advance () = incr pos in (* Read the decimal run up to (and consuming) [term]. *) let read_int_from start term = @@ -136,8 +133,7 @@ module Bencode = struct | None -> Error (Error.malformed_integer digits) end else begin - advance (); - scan () + advance (); scan () end in scan () @@ -145,43 +141,44 @@ module Bencode = struct let read_int term = read_int_from !pos term in let read_char () = let* c = peek () in - advance (); - Ok c + advance (); Ok c in let rec parse () = let* c = peek () in advance (); match c with | 't' -> - let* tag = read_char () in - let* data = parse () in - Ok (Tagged (tag, data)) + let* tag = read_char () in + let* data = parse () in + Ok (Tagged (tag, data)) | 'i' -> - let* n = read_int 'e' in - Ok (Int n) + let* n = read_int 'e' in + Ok (Int n) | 'l' -> parse_list [] | 'd' -> parse_dict [] | c when c >= '0' && c <= '9' -> parse_string_from (!pos - 1) | c -> Error (Error.unexpected_byte c) - and parse_string () = - parse_string_from !pos + and parse_string () = parse_string_from !pos and parse_string_from start = let* len = read_int_from start ':' in - if len < 0 || !pos + len > n then - Error (Error.string_out_of_bounds len) + if len < 0 || !pos + len > n then Error (Error.string_out_of_bounds len) else let str = String.sub s !pos len in pos := !pos + len; Ok (String str) and parse_list acc = let* c = peek () in - if c = 'e' then (advance (); Ok (List (List.rev acc))) + if c = 'e' then ( + advance (); + Ok (List (List.rev acc)) ) else let* result = parse () in parse_list (result :: acc) and parse_dict acc = let* c = peek () in - if c = 'e' then (advance (); Ok (Dict (List.rev acc))) + if c = 'e' then ( + advance (); + Ok (Dict (List.rev acc)) ) else let* key = parse_string () in let* key = as_string key in @@ -189,55 +186,43 @@ module Bencode = struct parse_dict ((key, value) :: acc) in let* value = parse () in - if !pos <> n then Error Error.trailing_bytes else - Ok value + if !pos <> n then Error Error.trailing_bytes else Ok value let to_blob x = to_bytes x |> Blob.blob_of_bytes let of_blob b = Blob.bytes_of_blob b |> of_bytes let with_tag t = function - | Tagged (t', v) -> - if t = t' then - Ok v - else - Error (Error.tag_mismatch ~expected:t ~actual:t') + | Tagged (t', v) -> if t = t' then Ok v else Error (Error.tag_mismatch ~expected:t ~actual:t') | _ -> Error (Error.type_mismatch ~expected:"tagged") let field key = function | Dict kvs -> ( - match List.assoc_opt key kvs with - | Some v -> Ok v - | None -> Error (Error.missing_field key) ) + match List.assoc_opt key kvs with Some v -> Ok v | None -> Error (Error.missing_field key) ) | _ -> Error (Error.type_mismatch ~expected:"dict") end module Value = struct let bencode_of_hash hash = Bencode.Tagged ('h', Bencode.String (Hash.to_raw_string hash)) + let hash_of_bencode value = let open Utilities.Result in - Bencode.with_tag 'h' value - |> fmap Bencode.as_string - |> Result.map Hash.of_raw_string + Bencode.with_tag 'h' value |> fmap Bencode.as_string |> Result.map Hash.of_raw_string + + let bencode_of_option f option = + Bencode.Tagged ('?', Option.map f option |> Option.to_list |> fun x -> Bencode.List x) - let bencode_of_option f option = Bencode.Tagged ('?', Option.map f option - |> Option.to_list - |> (fun x -> Bencode.List x)) let option_of_bencode f value = let open Utilities.Result in Bencode.with_tag '?' value |> fmap Bencode.as_list |> Result.map Utilities.List.hd_opt - |> fmap (function - | None -> Ok None - | Some v -> f v |> Result.map Option.some) + |> fmap (function None -> Ok None | Some v -> f v |> Result.map Option.some) end module Field = struct let string value = Bencode.String value let address address = Bencode.String (Hash.to_raw_string address) - - let require_string key data = - Bencode.field key data |> Utilities.Result.fmap Bencode.as_string + let require_string key data = Bencode.field key data |> Utilities.Result.fmap Bencode.as_string let require_address ~malformed key data = let open Utilities.Result in @@ -252,10 +237,8 @@ module Record = struct val to_bencode : t -> Bencode.t val of_bencode : Bencode.t -> (t, Condition.condition) result - val to_blob : t -> Blob.t val of_blob : Blob.t -> (t, Condition.condition) result - val to_bytes : t -> bytes val of_bytes : bytes -> (t, Condition.condition) result end @@ -275,13 +258,11 @@ module Record = struct let to_bencode object_ = Bencode.Tagged (B.tag, Bencode.Dict (B.fields object_)) let of_bencode = function - | Bencode.Tagged (tag, (Bencode.Dict _ as data)) when Char.equal tag B.tag -> - B.of_fields data + | Bencode.Tagged (tag, (Bencode.Dict _ as data)) when Char.equal tag B.tag -> B.of_fields data | _ -> Error (B.malformed ()) let to_blob object_ = to_bencode object_ |> Bencode.to_blob let of_blob blob = Bencode.of_blob blob |> Utilities.Result.fmap of_bencode - let to_bytes object_ = to_blob object_ |> Blob.bytes_of_blob let of_bytes bytes = Bencode.of_bytes bytes |> Utilities.Result.fmap of_bencode end |
