Commits

Dmitry Grebeniuk  committed 066f0ae

.

  • Participants
  • Parent commits 332231d

Comments (0)

Files changed (1)

File amall_http_service.ml

               with [ Not_found -> None ]
             ;
 
+            method mem k =
+              try (ignore (self#get_exn k); True) with [Not_found -> False]
+            ;
+
           end
         ;
 
      =
       struct
 
+(*
+        class virtual map_w ['k, 'v] =
+          object (_self)
+
+            method virtual add : 'k -> 'v -> map_w 'k 'v;
+
+            method virtual remove : 'k -> map_w 'k 'v;
+
+            method virtual replace : 'k -> 'v -> map_w 'k 'v;
+
+          end
+        ;
+*)
+
         class virtual map_rw ['k, 'v] =
           object (self)
 
 
             method virtual add : 'k -> 'v -> map_rw 'k 'v;
 
-            method virtual mem : 'k -> bool;
-
             method virtual remove : 'k -> map_rw 'k 'v;
 
             method replace (k : 'k) (v : 'v) =
-              (if self#mem k then self#remove k else (self :> map_rw _ _))
+              (if self#mem k then self#remove k else (self :> map_rw 'k 'v))
               # add k v
             ;
 
           end
         ;
 
+        class type t_map_rw ['k, 'v] =
+          object
+            method get_exn : 'k -> 'v;
+            method get_opt : 'k -> option 'v;
+            method mem : 'k -> bool;
+
+            method add : 'k -> 'v -> map_rw 'k 'v;
+            method remove : 'k -> map_rw 'k 'v;
+            method replace : 'k -> 'v -> map_rw 'k 'v;
+          end
+        ;
+
       end
     ;
 
           end
         ;
 
+        class type t_map_rw ['k, 'v] =
+          object
+            method get_exn : 'k -> 'v;
+            method get_opt : 'k -> option 'v;
+            method mem : 'k -> bool;
+
+            method add : 'k -> 'v -> unit;
+            method remove : 'k -> unit;
+            method replace : 'k -> 'v -> unit;
+          end
+        ;
+
       end
     ;
 
 
+    (* functional/immutable structures (implementations) *)
+
     module Sfun
      =
       struct
         ;
 
 
-        class map_rw_assoc ['k, 'v] ~keq cur
+        class map_ro_assoc ['k, 'v] ~keq cur
         =
-          object (self : #Tfun.map_rw 'k 'v)
-            inherit Tfun.map_rw ['k, 'v];
-            method add k v = new map_rw_assoc ~keq [(k, v) :: cur];
-            method mem k =
+          object (_self : #T.map_ro 'k 'v)
+
+            inherit T.map_ro ['k, 'v];
+
+            method! get_exn k =
+              loop cur
+              where rec loop lst =
+                match lst with
+                [ [] -> raise Not_found
+                | [(hk, hv) :: tl] ->
+                    if keq k hk
+                    then hv
+                    else loop tl
+                ]
+            ;
+            
+            method! mem k =
               let rec loop lst =
                 match lst with
                 [ [] -> False
                 loop cur
             ;
 
+          end
+        ;
+
+        value map_rw_assoc_add k v cur =
+          [(k, v) :: cur]
+        ;
+
+        value map_rw_assoc_remove ~keq k cur =
+          match list_assoc_index_opt ~keq cur k with
+          [ None -> cur
+          | Some i ->
+              let res_list =
+                if i < map_rw_assoc_stack_limit
+                then list_remove_nth_fast cur i
+                else list_remove_nth_tailrec cur i
+              in
+                res_list
+          ]
+        ;
+
+        class map_rw_assoc ['k, 'v] ~keq cur
+        =
+          object (self : #Tfun.map_rw 'k 'v)
+
+            inherit map_ro_assoc ['k, 'v] ~keq cur;
+
+            method add k v = new map_rw_assoc ~keq (map_rw_assoc_add k v cur);
+
             method remove k =
-              match list_assoc_index_opt ~keq cur k with
-              [ None -> (self :> map_rw_assoc _ _)
-              | Some i ->
-                  let res_list =
-                    if i < map_rw_assoc_stack_limit
-                    then list_remove_nth_fast cur i
-                    else list_remove_nth_tailrec cur i
-                  in
-                    new map_rw_assoc ~keq res_list
-              ]
+              let new_cur = map_rw_assoc_remove ~keq k cur in
+              if cur == new_cur
+              then (self :> map_rw_assoc 'k 'v)
+              else new map_rw_assoc ~keq new_cur
+            ;
+
+            method replace k v =
+              let removed = map_rw_assoc_remove ~keq k cur in
+              let added = map_rw_assoc_add k v removed in
+              new map_rw_assoc ~keq added
+            ;
+
+          end
+        ;
+
+
+        module Tree
+          (T : Map.OrderedType)
+         :
+          sig
+            class map_rw_tree ['v] : Tfun.t_map_rw [T.t, 'v];
+          end
+         =
+          struct
+
+            module M = Map.Make(T);
+
+            class map_rw_tree_cur ['v] cur
+            =
+              object (_self : #Tfun.map_rw 'k 'v)
+                inherit Tfun.map_rw ['k, 'v];
+                method! get_exn k = M.find k cur;
+                method add k v =
+                  new map_rw_tree_cur (M.add k v cur)
+                ;
+                method remove k =
+                  new map_rw_tree_cur (M.remove k cur)
+                ;
+              end
+            ;
+
+            class map_rw_tree ['v]
+            =
+              map_rw_tree_cur ['v] M.empty
             ;
 
           end
       end
     ;
 
+
+    (* imperative/mutable structures (implementations) *)
+
     module Simp
      =
       struct
           map_rw_of_Sfun ['k, 'v] (new Sfun.map_rw_assoc ~keq [])
         ;
 
+
+        module Tree
+          (T : Map.OrderedType)
+         :
+          sig
+            class map_rw_tree ['v] : Timp.t_map_rw [T.t, 'v];
+          end
+         =
+          struct
+
+            module F = Sfun.Tree(T);
+
+            class map_rw_tree ['v]
+            =
+              map_rw_of_Sfun [T.t, 'v] (new F.map_rw_tree)
+            ;
+
+          end
+        ;
+
+
       end
     ;
 
         -> (listener * mount_point)
     ;
 
+(*
     (* creates mount point in the specified segpath below the
        original mount point. *)
     value mount_rel : mount_point -> segpath -> mount_point
 
     value mount_fallback : mount_point -> http_service_func -> unit
     ;
+*)
 
   end
  =
     type mount_point = disp_level
     ;
 
-    class c_seg_map = Simp.map_rw_assoc [seg, disp_handler] ~keq:String.eq
-    ;
 
-    value segpath_of_uri _ = failwith "kva"
+(*
+    class c_seg_map = Simp.map_rw_assoc [seg, disp_handler] ~keq:String.eq;
+*)
+
+    module Tr = Simp.Tree(String);
+    class c_seg_map = Tr.map_rw_tree [disp_handler];
+
+
+    open Uri_type;
+
+    value segpath_of_uri uri =
+      let scheme_txt =
+        match uri.scheme with
+        [ None -> ""
+        | Some s -> s
+        ] in
+      let host_port_txt =
+        match uri.authority with
+        [ None -> ""
+        | Some au ->
+            let port_txt =
+              match au.port with
+              [ None -> ""
+              | Some i -> string_of_int i
+              ] in
+            sprintf "%s:%s" au.host port_txt
+        ] in
+      let pre = sprintf "%s://%s" scheme_txt host_port_txt in
+
+      let path = Uri.normseg_of_uri uri in
+
       (* из http://host:port/a/b/c?d#e делать
          [""; "http://host:port"; "a"; "b"; "c"],
          первая пустая строка -- чтобы можно было
          сделать сервис, слушающий [""], то есть,
          все протоколы-хосты-порты.
        *)
+
+       [""; pre :: path]
     ;
 
-(*
-    value run_listener : Amall_http_server.listen_addr -> mount_point
+
+    value find_handler disp_level segpath : (segpath * http_service_func) =
+      (ignore disp_level; ignore segpath; failwith "kva")
     ;
-*)
 
     value (server_func : disp_level -> http_server_func)
-      _root_disp_level _rq
-    =
-      failwith "kva"
+      root_disp_level
+    = fun rq ->
+      let uri = rq.Amall_http.rq_uri in
+      let segpath = segpath_of_uri uri in
+      let (segpath, func) = find_handler root_disp_level segpath in
+      ((func segpath) : http_server_func) rq
     ;
 
     value run_listener addr =
         } in
       let server_func = server_func root_disp_level in
       let io_server = HS.run addr server_func in
-      { io_server = io_server
-      ; root_disp_level = root_disp_level
-      }
+      let listener =
+        { io_server = io_server
+        ; root_disp_level = root_disp_level
+        }
+      in (listener, root_disp_level)
     ;
 
   end