Commits

Dmitry Grebeniuk  committed b0e9468

.

  • Participants
  • Parent commits 1823281

Comments (0)

Files changed (4)

File src/amall_http_service.ml

     ;
 
     type listener =
-      { io_server : IO.server
+      { io_server : (* IO.server  *) unit
       ; root_disp_level : disp_level
           (* contains just '"" => root' binding when there exists
              at least one service, empty otherwise; and
       | [seg :: segs] ->
           let () = dbg "S.try_find_handler: %S" seg in
           match disp_level.seg_map#get_opt seg with
-          [ None -> `Seg_not_found (seg, segs, disp_level)
+          [ None ->
+              let () = dbg "S.try_find_handler: .. not found" in
+              `Seg_not_found (seg, segs, disp_level)
           | Some (Level disp_level) -> try_find_handler disp_level segs
           | Some (Service f) -> `Ok (segs, f)
           ]
 
 
     value go_or_create_smallstep ~fb ~disp ~seg : disp_level =
+      let () = dbg "S.go_or_create_smallstep: seg=%S" seg in
       match disp.seg_map#get_opt seg with
       [ None ->
           let lev =
             ; fallback = fb
             } in
           ( disp.seg_map#add seg (Level lev)
-          ; lev
+          ; let () = dbg "S.go_or_create_smallstep: .. created." in
+            lev
           )
-      | Some (Level lev) -> lev
+      | Some (Level lev) ->
+          let () = dbg "S.go_or_create_smallstep: .. found." in
+          lev
       | Some (Service _f) -> raise Already_handled
       ]
     ;
     (**********)
 
     value mount endpoint f =
+      let () = dbg "S.mount" in
       install_handler ~endpoint ~what:f
     ;
 
         ; fallback = host_fallback  (* "ни один хост не сконфигурен" *)
         } in
       let server_func = server_func root_disp_level in
-      let io_server = HS.run addr server_func in
+      let io_server = IO.run_and_ignore_result
+        (let _ = ignore (HS.run addr server_func) in IO.return ()) in
       let listener =
         { io_server = io_server
         ; root_disp_level = root_disp_level

File src/dbi/dbi_common.ml

 value failwith fmt = Printf.ksprintf failwith fmt
 ;
+
+external identity : 'a -> 'a = "%identity"
+;
+
+external apply : ('a -> 'b) -> 'a -> 'b = "%apply"
+;
+
+
+module Af
+ =
+  struct
+    type af 'x 'a = 'x -> 'a;
+    value pure = fun _ -> identity;
+    value ( <*> ) fab fa = fun x -> (fab x) (fa x);
+    value run = apply;
+  end
+;
+
+module Af2
+ =
+  struct
+    open Af;
+    type af2 'x 'y 'a = af 'x (af 'y 'a);
+    value pure x : af2 _ _ _ = fun _ -> fun _ -> x;
+    value (( <*> ) : af2 'x 'y ('a -> 'b) -> af2 'x 'y 'a -> af2 'x 'y 'b)
+      ffab ffa =
+        fun x ->
+          let fab = ffab x
+          and fa = ffa x in
+          fun y ->
+            (fab y) (fa y)
+    ;
+    value (run1 : af2 'x 'y 'a -> 'x -> af 'y 'a) = apply;
+    value (run2 : af2 'x 'y 'a -> 'x -> 'y -> 'a) af2 x y = af2 x y;
+  end
+;
+
+
+type dbtypecomb 'a = Af2.af2 rectype record
+;
+
+type record_type =
+;

File src/dbi/dbi_pg.ml

 ;
 
 
+(* строгий, чоткий, кидает исключения: *)
+module Typer
+ =
+  struct
+
+
+    value do_check_error ~nullable ~want_ftype ~msg =
+      failwith "Dbi_pg.Typer: %s%s expected, %s found"
+          (if nullable then "optional " else "")
+          want_ftype
+    ;
+
+
+    value do_check ~nullable ~check_ftype ~want_ftype =
+      if check_ftype ftype
+      then ()
+      else do_check_error ~nullable ~want_ftype (P.string_of_ftype ftype)
+    ;
+
+    value convert_error ~want_ftype exn =
+      let msg = Printexc.to_string exn in
+      failwith "Dbi_pg.Typer: can't convert to %s: %s"
+        want_ftype
+        msg
+    ;
+
+
+    (* returns (notnull, nullable) *)
+
+    value common ~want_ftype ~check_ftype ~convert =
+      ( fun ftype isnull untyped func ->
+          ( do_check ~nullable:False ~check_ftype ~want_ftype
+          ; if isnull
+            then
+              do_check_error ~nullable:False ~want_ftype
+                ~msg:"NULL"
+            else ()
+          ; try func (convert untyped)
+            with [e -> convert_error ~want_ftype e]
+          )
+      , fun ftype isnull untyped func ->
+          ( do_check ~nullable:True ~check_ftype ~want_ftype
+          ; try
+              func (if isnull then None else Some (convert untyped))
+            with [e -> convert_error ~want_ftype e]
+          )
+      )
+    ;
+
+    value string_check ftype =
+      match ftype with
+      [ P.CHAR | P.TEXT | P.NAME | P.VARCHAR -> True
+      | _ -> False
+      ]
+    ;
+
+    value (string, string_opt) = common
+      ~want_ftype:"string (char, text, name, varchar)"
+      ~check_ftype:string_check
+      ~convert:identity
+    ;
+
+    value (binary, binary_opt) = common
+      ~want_ftype:"bytea"
+      ~check_ftype:((=) P.BYTEA)
+      ~convert:identity
+    ;
+
+  end
+;
+
+
+
 value entype_t ftype ~isnull x : sql_t =
   try
     let () = dbg "entype: %s = %S (is null = %b)"
 ;
 
 
+
+
+
 value detype_t v =
   match v with
   [ (`Binary _) | (`String _) | `Null
 ;
 
 
+type record_signature = 
+  { rs_names : array ident
+  ; rs_types : array ftype
+  }
+;
+
+
 class result
   ['v]
   (entype : P.ftype -> ~isnull:bool -> string -> 'v)
           str_arr
       )
   in
+  let record_signature_lazy = lazy
+    { rs_names = Lazy.force names_lazy
+    ; rs_types = Lazy.force col_ftypes_lazy
+    }
+  in
   object (self)
     inherit Dbi.result ['v];
 
 
     value mutable v_current_nrow = 0;
 
+    method record_signature = Lazy.force record_signature_lazy;
+
     method nrows = Some presult#ntuples;
     method names = Lazy.force names_lazy;
     method ncols = presult#nfields;
   >>= fun line ->
   append_to_pgpass_line line
 ;
+
+
+(***********************************************************)
+
+
+module Record_typing
+ =
+  struct
+    open Af2;
+
+    type record_processor = af2 record_signature record -- видимо sql_u?;
+
+  end
+;

File tests/test_http_service.ml

 module S = Amall_http_service.Service(IO)(I);
 
 
+value () = dbg "point1"
+;
+
 value (_listener, root) = S.run_listener (`Inet_any 12345)
 ;
 
+value () = dbg "point2"
+;
+
 value my_endpoint = (root, `Service ([""; "http://localhost:12345"], "test"))
 ;
 
+value () = dbg "point3"
+;
+
 open Amall_http;
 
+value () = dbg "point4"
+;
+
 open Printf;
 
 value my_func segpath _rq =
   }
 ;
 
-value () = S.mount my_endpoint my_func
+value () = dbg "point5"
+;
+
+value () = (dbg "pre"; S.mount my_endpoint my_func; dbg "post")
 ;
 
 open I.Ops;