From e3981f013a2f41734c30f5c679ba409700dc2bce Mon Sep 17 00:00:00 2001 From: ygrek Date: Wed, 24 Jun 2020 01:33:32 -0400 Subject: [PATCH 1/3] print_pkey: show number of packets --- keyMerge.ml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/keyMerge.ml b/keyMerge.ml index 4c9f88e..d2fd14f 100644 --- a/keyMerge.ml +++ b/keyMerge.ml @@ -99,12 +99,21 @@ let flatten key = (************************************************************) +let nr_packets l = List.fold_left ~f:(fun acc (_,l) -> acc + List.length l) ~init:0 l + let print_pkey key = - printf "%d selfsigs, %d uids, %d subkeys\n" + let uid = + match List.filter ~f:(fun (p,_) -> p.packet_type = User_ID_Packet) key.uids with + | [] -> "" + | (h,_)::_ -> h.packet_body + in + printf "%S : %d selfsigs, %d uids (%d packets), %d subkeys (%d packets)\n" + uid (List.length key.selfsigs) (List.length key.uids) + (nr_packets key.uids) (List.length key.subkeys) - + (nr_packets key.subkeys) (*******************************************************************) From ca98434fdfa0c3427a0a2727af82b81f2a968e13 Mon Sep 17 00:00:00 2001 From: ygrek Date: Wed, 24 Jun 2020 01:34:52 -0400 Subject: [PATCH 2/3] KeyMerge: get rid of Stream.of_list which is not tail-recursive and also reducing allocations ref #78 --- keyMerge.ml | 74 +++++++++++++++++++---------------------------------- 1 file changed, 26 insertions(+), 48 deletions(-) diff --git a/keyMerge.ml b/keyMerge.ml index d2fd14f..c9d999b 100644 --- a/keyMerge.ml +++ b/keyMerge.ml @@ -123,13 +123,6 @@ let get_version packet = | Signature_Packet -> int_of_char packet.packet_body.[0] | _ -> raise Not_found -let key_to_stream key = - let ptype_list = List.map ~f:(fun pack -> (pack.packet_type,pack)) key in - Stream.of_list ptype_list - - - - (*******************************************************************) (*** Key Parsing ***************************************************) (*******************************************************************) @@ -137,28 +130,24 @@ let key_to_stream key = let parse_list parser strm = let rec loop parser strm accum = match parser strm with - | Some elt -> loop parser strm (elt :: accum) - | None -> List.rev accum + | Some (elt, strm) -> loop parser strm (elt :: accum) + | None -> List.rev accum, strm in loop parser strm [] let parse_sig strm = - match Stream.peek strm with - | Some (Signature_Packet, p) -> - Stream.junk strm; - Some p + match strm with + | { packet_type = Signature_Packet; _ } as p :: strm -> Some (p,strm) | _ -> None let parse_uid strm = - match Stream.peek strm with - | Some (User_ID_Packet, p) -> - Stream.junk strm; - let sigs = parse_list parse_sig strm in - Some (p, sigs) - | Some ((User_Attribute_Packet, p)) -> - Stream.junk strm; - let sigs = parse_list parse_sig strm in - Some (p, sigs) + match strm with + | { packet_type = User_ID_Packet; _ } as p :: strm -> + let sigs, strm = parse_list parse_sig strm in + Some ((p, sigs), strm) + | { packet_type = User_Attribute_Packet; _ } as p :: strm -> + let sigs, strm = parse_list parse_sig strm in + Some ((p, sigs), strm) | _ -> (* (p,sigs)::(match s with parser @@ -169,31 +158,31 @@ let parse_uid strm = None let parse_subkey strm = - match Stream.peek strm with - | Some (Public_Subkey_Packet, p) -> - Stream.junk strm; - let sigs = parse_list parse_sig strm in - Some (p, sigs) + match strm with + | { packet_type = Public_Subkey_Packet; _ } as p :: strm -> + let sigs, strm = parse_list parse_sig strm in + Some ((p, sigs), strm) | _ -> None -let parse_keystr strm = - match Stream.peek strm with - | Some (Public_Key_Packet, key) -> - Stream.junk strm; +let key_to_pkey strm = + match strm with + | { packet_type = Public_Key_Packet; _ } as key :: strm -> begin match get_version key with | 4 -> - let selfsigs = parse_list parse_sig strm in - let uids = parse_list parse_uid strm in - let subkeys = parse_list parse_subkey strm in + let selfsigs, strm = parse_list parse_sig strm in + let uids, strm = parse_list parse_uid strm in + let subkeys, strm = parse_list parse_subkey strm in + if strm <> [] then raise Unparseable_packet_sequence; { key; selfsigs; uids; subkeys; } | 2 | 3 -> - let revocations = parse_list parse_sig strm in - let uids = parse_list parse_uid strm in + let revocations, strm = parse_list parse_sig strm in + let uids, strm = parse_list parse_uid strm in + if strm <> [] then raise Unparseable_packet_sequence; { key; selfsigs = revocations; uids; subkeys = []; } | _ -> failwith "Unexpected key packet version number" end - | _ -> raise Stream.Failure + | _ -> raise Unparseable_packet_sequence (*******************************************************************) (*** Key Merging Code *********************************************) @@ -240,17 +229,6 @@ let merge_pkeys key1 key2 = (*******************************************************************) (*******************************************************************) -let key_to_pkey key = - try - let keystream = key_to_stream key in - let pkey = parse_keystr keystream in - Stream.empty keystream; - pkey - with - Stream.Failure | Stream.Error _ -> - raise Unparseable_packet_sequence - - let merge key1 key2 = try let pkey1 = key_to_pkey key1 From 8af4cfc0c8f4086ddedb5915ce17b575cf9833ac Mon Sep 17 00:00:00 2001 From: ygrek Date: Wed, 24 Jun 2020 01:37:22 -0400 Subject: [PATCH 3/3] KeyMerge: tail-recursive flatten ref #78 --- keyMerge.ml | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/keyMerge.ml b/keyMerge.ml index c9d999b..c8ee5a1 100644 --- a/keyMerge.ml +++ b/keyMerge.ml @@ -87,16 +87,22 @@ let packets_equal p1 p2 = p1 = p2 (*******************************************************************) (** Code for flattening out the above structure back to the original key *) -let rec flatten_sigpair_list list = match list with - [] -> [] - | (pack,sigs)::tl -> pack :: (sigs @ flatten_sigpair_list tl) +let rec flatten_sigpair_list list = + match list with + | [] -> [] + | (pack,sigs)::tl -> pack :: (List.rev_append sigs (flatten_sigpair_list tl)) (* order of sigs doesn't matter *) + +(* stack proportional to [List.length l] which is constant in our case *) +let rec list_concat l = + match l with + | [] -> [] + | h::tl -> List.rev_append (List.rev h) (list_concat tl) let flatten key = - key.key :: List.concat [ key.selfsigs; + key.key :: list_concat [ key.selfsigs; flatten_sigpair_list key.uids; flatten_sigpair_list key.subkeys ] - (************************************************************) let nr_packets l = List.fold_left ~f:(fun acc (_,l) -> acc + List.length l) ~init:0 l