1. Dmitry Grebeniuk
  2. amall

Commits

Dmitry Grebeniuk  committed abb4d20

.

  • Participants
  • Parent commits 39e5a1f
  • Branches default

Comments (0)

Files changed (1)

File amall_http_service.ml

View file
  • Ignore whitespace
 
     (* segpath contains path from uri, split by '/' and normalized.
        absolute segpath for url "http://host:port/a/b/c?d#e" is
-       ["http://host:port"; "a"; "b"; "c"].  Note that query and
+       [""; "http://host:port"; "a"; "b"; "c"].  Note that query and
        fragment compotents are available in the Uri record.
+       First item is the empty string always, it is introduced to
+       make possible handling of requests to any host by
+       registering service on path [""].
      *)
+
     type segpath = list seg;
 
-    type http_server_func
-     (* = (Http_server(IO)(I)).http_server_func *)
-     = Amall_http.request -> I.iteratee char Amall_http.response
-    ;
-
     (* Service receives path components relative to "mount point".
-       for example, when service is registered on
-       "http://host:port/a/b/c" and when
+       For example, when service is registered on
+       "http://host:port/a/b/c"
+       ( = [""; "http://host:port"; "a"; "b"; "c"]) and when
 
        request uri is:                 segpath is:
        http://host:port/a/b/c          [""]
        http://host:port/a/b/c/d/e      ["d"; "e"]
        http://host:port/a/b/c/d?e#f    ["d"]
      *)
+    
+    type http_service_func =
+      segpath ->
+      Amall_http.request ->
+      I.iteratee char Amall_http.response
+    ;
 
-    type http_service_func =
-      segpath -> http_server_func
-    ;
+    (* Abstract type.  Will be used to control listening and
+       accepting connections. *)
 
     type listener
     ;
     type mount_point
     ;
 
-    value run_listener
-      : Amall_http_server.listen_addr
-        -> (listener * mount_point)
+    (* where to install service/fallback. *)
+
+    type endpoint =
+      (
+        mount_point
+        *
+        [= `Service of (segpath * seg)
+        |  `Fallback of segpath
+        ]
+      )
     ;
 
-(*
+    (* returns listener and mount point for its root *)
+
+    value run_listener
+      : Amall_http_server.listen_addr -> (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_service : mount_point -> http_service_func -> unit
+    value mount : endpoint -> http_service_func -> unit
     ;
 
-    value mount_fallback : mount_point -> http_service_func -> unit
+    value umount : endpoint -> unit
     ;
-*)
 
   end
  =
 
     type disp_level =
       { seg_map : seg_map
-      ; fallback : http_service_func
+      ; fallback : mutable http_service_func
       }
     and disp_handler =
       [ Level of disp_level
 (*
     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;
             { seg_map = new c_seg_map
             ; fallback = fb
             } in
-          ( mount_point.seg_map#add seg (Level lev)
+          ( disp.seg_map#add seg (Level lev)
           ; lev
           )
       | Some (Level lev) -> lev
-      | Some (Service f) -> raise Already_handled
+      | Some (Service _f) -> raise Already_handled
       ]
     ;
 
     ;
 
 
-    value install_handler
-      (~how_where : [= `Service of (segpath * seg) | `Fallback of segpath ])
-      (~mount_point : mount_point)
-      (~what : http_service_func)
+    type endpoint =
+      (
+        mount_point
+        *
+        [= `Service of (segpath * seg)
+        |  `Fallback of segpath
+        ]
+      )
+    ;
+
+
+    value mount_rel mount_point segpath =
+      go_or_create_bigstep
+        ~fb:default_fallback
+        ~disp:mount_point
+        ~segs:segpath
+    ;
+
+
+    value (install_handler
      :
+      ~endpoint : endpoint ->
+      ~what : http_service_func ->
       unit
-    =
+     )
+      ~endpoint
+      ~what
+     =
+      let (mount_point, how_where) = endpoint in
       let segpath =
         match how_where with
         [ `Service (s, _) -> s
         ~disp:mount_point
         ~segs:segpath
       in
-      .
-
-        install_handler how what went_or_created segpath
       match how_where with
-      [ `Service ([], seg) ->
-          inst serv
-      | `Fallback [] ->
-          inst fb
-      | `Service 
-
-          match how with
-          [ `Fallback -> mount_point.fallback := what
-          | `Service -> ... логика разная слегка, рассмотреть корень.
+      [ `Service (_, p) ->
+          match disp_level.seg_map#get_opt p with
+          [ None ->
+              disp_level.seg_map#add p (Service what)
+          | Some _ -> raise Already_handled
           ]
-      | [seg :: segpath] ->
+      | `Fallback _ -> disp_level.fallback := what
       ]
-    type disp_level =
-      { seg_map : seg_map
-      ; fallback : http_service_func
-      }
-    and disp_handler =
-      [ Level of disp_level
-      | Service of http_service_func
-      ]
-    and seg_map = Timp.map_rw seg disp_handler
     ;
 
+    value mount endpoint f =
+      install_handler ~endpoint 
+    ;
 
-          in
+    value umount endpoint =
+      remove_handler ~endpoint
+    ;
 
-      ]
-    ;
+    (**********)
 
 
     value (server_func : disp_level -> http_server_func)