Merge pull request #79 from m-harrison/refactor/verification

Changes verification so it is O(P+C) rather than O(P*C)

src/Api.ml

@@ -131,11 +131,23 @@ let read_from_cache peer service files s =
 
 open Coding
 
+let path_subsumed vpath rpath =
+  let vpath' = Core.Std.String.split vpath ~on:'/' in
+  let rpath' = Core.Std.String.split rpath ~on:'/' in
+  let rec walker v r =
+    match v with 
+    | []    -> true
+    | x::xs -> 
+      match r with
+      | []    -> false
+      | y::ys -> x=y && (walker xs ys)
+  in walker vpath' rpath'
+
 let write_to_cache peer service file_content requests s =
   let write_backs = Core.Std.List.filter requests ~f:(fun rf -> rf.write_back) in
   let files_to_write_back = 
     Core.Std.List.filter file_content 
-      ~f:(fun (p,c) -> Core.Std.List.exists write_backs (fun rf -> rf.path = p)) in
+      ~f:(fun (p,c) -> Core.Std.List.exists write_backs (fun rf -> path_subsumed rf.path p)) in
   Silo.write ~client:s#get_silo_client ~peer ~service ~contents:(`Assoc files_to_write_back)
 
 let get_remote_file_list plaintext =
@@ -165,9 +177,11 @@ let invalidate_paths_at_peer peer paths service s =
   send_retry peer (Printf.sprintf "/peer/inv/%s/%s" (Peer.host s#get_address) service) body false s
 
 let invalidate_paths_at_peers paths access_log service s =
-  let path_peers = Core.Std.List.map paths ~f:(fun path -> path, 
-    (Peer_access_log.find s#get_peer_access_log 
-      ~host:s#get_address ~service ~path)) in
+  let path_peers,pal = Core.Std.List.fold ~init:([],s#get_peer_access_log) paths 
+    ~f:(fun (pp,pal') -> fun path -> 
+      let peers,pal'' = (Peer_access_log.delog pal' ~host:s#get_address ~service ~path)
+      in (path,peers)::pp,pal'') in
+  s#set_peer_access_log pal;
   let peers = 
     path_peers
     |> Core.Std.List.fold ~init:[] ~f:(fun acc -> fun (_,ps) -> Core.Std.List.append acc ps)
@@ -177,9 +191,6 @@ let invalidate_paths_at_peers paths access_log service s =
       (Core.Std.List.fold path_peers ~init:[] ~f:(fun acc -> fun (path,ps) -> 
         Core.Std.List.append (if List.exists ps (fun p -> Peer.compare p peer = 0) then [path] else []) acc))) in 
   Lwt_list.iter_s (fun (peer,paths) -> invalidate_paths_at_peer peer paths service s >|= fun _ -> ()) peer_paths
-  >|= fun () -> s#set_peer_access_log 
-    (Core.Std.List.fold paths ~init:s#get_peer_access_log 
-      ~f:(fun pal -> fun path -> Peer_access_log.unlog pal ~host:s#get_address ~service ~path))
 
 module Client = struct
   let decrypt_message_from_client ciphertext iv s =

src/Auth.ml

@@ -174,15 +174,22 @@ let find_permissions capability_service requests =
 let request_under_verified_path vpaths rpath =
   Core.Std.List.fold vpaths ~init:false ~f:(fun acc -> fun vpath -> acc || (vpath_subsumes_request vpath rpath))
 
-(* Because of the API definition a collection of requests is always all reads or all writes *)
 let authorise requests capabilities tok key target service =
   let key' = Coding.encode_cstruct key in
   let verified_capabilities = Core.Std.List.filter capabilities ~f:(verify tok key') in
-  let locations = Core.Std.List.map verified_capabilities ~f:(M.location) in 
-  let verified_paths = (* The paths below which it is verified the requester has access of at least [tok] *)
-    (Core.Std.List.map locations ~f:(verify_location target service))
-    |> Core.Std.List.filter ~f:(fun s -> not(s="")) in 
-  Core.Std.List.filter requests ~f:(request_under_verified_path verified_paths)
+  let authorised_locations  = Core.Std.List.map verified_capabilities ~f:(M.location) in 
+  let path_tree = Core.Std.List.fold ~init:File_tree.empty 
+        ~f:(fun tree -> fun element -> 
+          File_tree.insert ~element ~tree 
+          ~location:(fun path -> Core.Std.String.split 
+            (Printf.sprintf "%s/%s/%s" (Peer.host target) service path) ~on:'/')
+          ~select:(fun p -> fun _ -> p)
+          ~terminate:(fun o -> fun _ -> match o with | Some e -> true | None -> false)) requests in
+  let (authorised_paths,_) = 
+    Core.Std.List.fold ~init:([],path_tree) ~f:(fun (paths,tree) -> fun loc ->
+      let content,tree' = File_tree.trim ~tree ~location:(Core.Std.String.split loc ~on:'/')
+      in (Core.Std.List.unordered_append content paths),tree') authorised_locations in
+  authorised_paths
 
 let serialise_presented_capabilities capabilities =
   `Assoc (Core.Std.List.map capabilities ~f:(fun (p,c) -> (p, `String (M.serialize c))))

src/File_tree.ml

@@ -45,35 +45,6 @@ let shortest_path_match ~tree ~location ~satisfies =
               | Some el' as e-> if satisfies el' then e else find ys sub)
   in find location tree
 
-let flatten_under ~tree ~location =
-  let rec flatten tree' =
-    match tree' with
-    | Leaf -> []
-    | Node (name, el, sub, l, r) -> 
-      (match el with 
-      | None   -> (flatten sub) @ (flatten l) @ (flatten r)
-      | Some x -> x :: ((flatten sub) @ (flatten l) @ (flatten r)))
-  in let rec find path tree' = 
-    match path with 
-      | []    -> []
-      | x::[] ->
-          (match tree' with
-          | Leaf -> []
-          | Node (name, el, sub, l, r) -> 
-              if name > x then find path l else
-              if name < x then find path r else
-              (match el with
-              | None -> flatten sub
-              | Some x -> x :: (flatten sub)))
-      | y::ys ->
-          match tree' with 
-          | Leaf -> []
-          | Node (name,el,sub,l,r) -> 
-              if name > y then find path l else
-              if name < y then find path r else
-              find ys sub
-  in find location tree
-
 let rec get_min tree = 
   match tree with
   | Leaf -> Leaf
@@ -83,26 +54,50 @@ let rec get_min tree =
 exception Trim_failed
 
 let trim ~tree ~location =
+  let rec flatten tree' =
+    match tree' with
+    | Leaf -> []
+    | Node (name, el, sub, l, r) -> 
+      (match el with 
+      | None   -> (flatten sub) @ (flatten l) @ (flatten r)
+      | Some x -> x :: ((flatten sub) @ (flatten l) @ (flatten r))) in
+  let flat el tree =
+    match el with
+      | None   ->       flatten tree
+      | Some x -> x :: (flatten tree) in
+  let rec delete_no_flatten path tree =
+    match tree with
+    | Leaf -> Leaf
+    | Node (name, el, sub, l, r) -> 
+        if name > path then delete_no_flatten path l else
+        if name < path then delete_no_flatten path r else
+        if l = Leaf then r else
+        if r = Leaf then l else
+        let m = get_min r in
+        (match m with
+         | Node (n', e', s', Leaf, _) -> Node (n', e', s', l, delete_no_flatten n' r)
+         | _ -> raise Trim_failed) in
   let rec delete path tree' =
     match path with 
-    | []    -> tree'
+    | []    -> [],tree'
     | x::[] ->
         (match tree' with
-        | Leaf -> Leaf
+        | Leaf -> [],Leaf
         | Node (name, el, sub, l, r) -> 
-            if name > x then Node (name, el, sub, delete path l, r) else
-            if name < x then Node (name, el, sub, l, delete path r) else
-            if l = Leaf then r else
-            if r = Leaf then l else
+            if name > x then let f,l' = delete path l in f,Node (name, el, sub, l', r) else
+            if name < x then let f,r' = delete path r in f,Node (name, el, sub, l, r') else
+            if l = Leaf then flat el sub,r else
+            if r = Leaf then flat el sub,l else
             let m = get_min r in
             (match m with
-            | Node (n', e', s', Leaf, _) -> Node (n', e', s', l, delete [n'] r)
+            | Node (n', e', s', Leaf, _) -> flat el sub,Node (n', e', s', l, delete_no_flatten n' r)
             | _ -> raise Trim_failed))
     | y::ys -> 
       match tree' with 
-      | Leaf -> Leaf
+      | Leaf -> [],Leaf
       | Node (name,el,sub,l,r) -> 
-          if name > y then Node (name, el, sub, delete path l, r) else
-          if name < y then Node (name, el, sub, l, delete path r) else
-          Node (name, el, delete ys sub, l, r)
+          if name > y then let f,l' = delete path l in f,Node (name, el, sub, l', r) else
+          if name < y then let f,r' = delete path r in f,Node (name, el, sub, l, r') else
+          let f,sub' = delete ys sub in
+          f,Node (name, el, sub', l, r)
   in delete location tree

src/File_tree.mli

@@ -20,24 +20,19 @@ location, if this already exists, [select] compares [element] and the element cu
 it then gives back the element which should be at the position. *)
 
 val shortest_path_match :
-  tree:       'a t        ->
+  tree:       'a t            ->
   location:       string list ->
-  satisfies: ('a -> bool) -> 'a option
+  satisfies: ('a -> bool)     -> 'a option
 (** [shortest_path_match ~tree ~location ~satisfies] starts at the root of [tree] and walks down 
 towards [location] until an element along [location] in [tree] satisfies the predicate [satisfies], it then
 returns this element. If it reaches a leaf before finding a satisfying element [None] is returned. *)
 
-val flatten_under :
-  tree: 'a t        ->
-  location: string list -> 'a list
-(** [flatten_under ~tree ~location] walks down [tree] until it hits [location] and then returns an in order
-list of all of the elements at and below [location] in the [tree]. *)
-
 exception Trim_failed
 (** Raised if [get_min] behaves unexpectadly during deletion. *)
 
 val trim :
-  tree: 'a t            ->
-  location: string list -> 'a t
+  tree:    'a t         ->
+  location: string list -> 'a list * 'a t
 (** Walks down to the node at [location] in [tree] and returns the new tree with this node and it's 
-sub tree removed, but any left and right nodes still remaining. *)
+sub tree removed, but any left and right nodes still remaining. The contents of the subtree is flattened
+and passed back in a pair. *)

src/Peer_access_log.ml

@@ -15,9 +15,7 @@ let log l ~host ~peer ~service ~path =
   File_tree.insert ~element:[peer] ~tree:l ~location:(build_loc host service path) ~select:build_el
     ~terminate:(fun _ -> fun _ -> false)
 
-let unlog l ~host ~service ~path =
-  File_tree.trim ~tree:l ~location:(build_loc host service path ())
-
-let find l ~host ~service ~path = 
-  File_tree.flatten_under ~tree:l ~location:(String.split (Printf.sprintf "%s/%s/%s" (Peer.host host) service path) ~on:'/')
-  |> List.fold ~init:[] ~f:List.append 
+let delog (l:t) ~host ~service ~path =
+  let peerses,pal = File_tree.trim ~tree:l ~location:(build_loc host service path ()) in
+  (Core.Std.List.fold ~init:[] ~f:(fun acc -> fun peers -> Core.Std.List.unordered_append peers acc) peerses
+  |> Core.Std.List.dedup ~compare:Peer.compare),pal

src/Peer_access_log.mli

@@ -6,10 +6,6 @@ val log : t -> host:Peer.t -> peer:Peer.t -> service:string -> path:string -> t
 (** [log l ~host ~peer ~service ~path] takes the current peer access log and gives back another where it 
 has been recorded that [peer] requested [path] from [host]'s' [service]. *)
 
-val unlog : t -> host:Peer.t -> service:string -> path:string -> t
+val delog : t -> host:Peer.t -> service:string -> path:string -> (Peer.t list * t)
 (** [unlog l ~host ~service ~path] is used to remove all log entries at and below [host/service/path] 
-in the log [l].*)
-
-val find : t -> host:Peer.t -> service:string -> path:string -> Peer.t list
-(** [find l ~host ~service ~path] returns a list of [Peer.t] which have accessed [path] or any file below
-[path] in [host]'s [service]. *)
+in the log [l], returned in a pair with the flattened peers at and below [host/service/path].*)

tests/test_src.ml

@@ -340,18 +340,18 @@ module File_tree_tests = struct
       Core.Std.List.fold paths ~init:pal 
         ~f:(fun p -> fun path -> Peer_access_log.log p ~host ~service ~peer ~path) in
     Alcotest.(check int) "Checks can get peer back out for path we delete"
-    (Core.Std.List.length (Peer_access_log.find pal' ~host ~service ~path:"bar2")) 1;
+    (Core.Std.List.length (Peer_access_log.delog pal' ~host ~service ~path:"bar2" |> fun (ps,log') -> ps)) 1;
     Alcotest.(check int) "Checks can get peer back out for left path"
-    (Core.Std.List.length (Peer_access_log.find pal' ~host ~service ~path:"bar1")) 1;
+    (Core.Std.List.length (Peer_access_log.delog pal' ~host ~service ~path:"bar1" |> fun (ps,log') -> ps)) 1;
     Alcotest.(check int) "Checks can get peer back out for right path"
-    (Core.Std.List.length (Peer_access_log.find pal' ~host ~service ~path:"bar3")) 1;
-    let pal'' = Peer_access_log.unlog pal' ~host ~service ~path:"bar2" in
+    (Core.Std.List.length (Peer_access_log.delog pal' ~host ~service ~path:"bar3" |> fun (ps,log') -> ps)) 1;
+    let _,pal'' = Peer_access_log.delog pal' ~host ~service ~path:"bar2" in
     Alcotest.(check int) "Checks cannot get peer back out for path we deleted"
-    (Core.Std.List.length (Peer_access_log.find pal'' ~host ~service ~path:"bar2")) 0;
+    (Core.Std.List.length (Peer_access_log.delog pal'' ~host ~service ~path:"bar2" |> fun (ps,log') -> ps)) 0;
     Alcotest.(check int) "Checks can get peer back out for what is still left path"
-    (Core.Std.List.length (Peer_access_log.find pal'' ~host ~service ~path:"bar1")) 1;
+    (Core.Std.List.length (Peer_access_log.delog pal'' ~host ~service ~path:"bar1" |> fun (ps,log') -> ps)) 1;
     Alcotest.(check int) "Checks can get peer back out for what is now root"
-    (Core.Std.List.length (Peer_access_log.find pal'' ~host ~service ~path:"bar3")) 1
+    (Core.Std.List.length (Peer_access_log.delog pal'' ~host ~service ~path:"bar3" |> fun (ps,log') -> ps)) 1
 
   let tests = [
     ("Can add Macaroon to Capabilities Service and get it out again", `Quick, read_macaroon_inserted_into_service_can_be_retrieved);
@@ -369,17 +369,17 @@ module Peer_access_log_tests = struct
   let access_inserted_into_log_can_be_retrieved () =
     let pal  = Peer_access_log.empty in
     let pal' = Peer_access_log.log pal ~host ~peer ~service ~path in
-    match Peer_access_log.find pal' ~host ~service ~path with
-    | p::[] ->
+    match Peer_access_log.delog pal' ~host ~service ~path with
+    | p::[],_ ->
         Alcotest.(check string) "Checks the logged peer is the one inserted."
         (Peer.host peer) (Peer.host p);
     | _ -> Alcotest.fail "One single peer access should be logged."
 
   let access_inserted_into_log_can_be_retrieved_from_node_above () =
     let pal  = Peer_access_log.empty in
     let pal' = Peer_access_log.log pal ~host ~peer ~service ~path in
-    match Peer_access_log.find pal' ~host ~service ~path:"dir" with
-    | p::[] ->
+    match Peer_access_log.delog pal' ~host ~service ~path:"dir" with
+    | p::[],_ ->
         Alcotest.(check string) "Checks the logged peer is the one inserted."
         (Peer.host peer) (Peer.host p);
     | _ -> Alcotest.fail "One single peer access should be logged."