Anonymous avatar Anonymous committed 7099a69

moved code from Am_{List,String} to cadastr library, fixed the code to work with new cadastr (rev.28f02aeee953 at least)

Comments (0)

Files changed (8)

 (* OASIS_START *)
-(* DO NOT EDIT (digest: cb6a18c53ae1bf6c468fe8d82084a3bf) *)
+(* DO NOT EDIT (digest: 02cd58645594e24ea3e25af4fcc6240b) *)
 This is the INSTALL file for the amall distribution.
 
 This package uses OASIS to generate its build system. See section OASIS for
 * findlib
 * monad_io for library amall, executable test_http_service
 * iteratees for library amall, executable test_http_service
-* cadastr for library amall, executable test_http_service
+* cadastr for library amall, executable test_http_service,
+  executable test_uri
 * postgresql for library amall_dbi
 
 Installing
   MainIs: test_uri.ml
   NativeOpt:       -w A
   ByteOpt:         -w A
+  BuildDepends: cadastr
 
 Executable test_http_service
   Path: tests
 # OASIS_START
-# DO NOT EDIT (digest: 7fec7433efdaba415e1b10cbd1e8a98a)
+# DO NOT EDIT (digest: 6fa6f94c9472805b773b93f94635469e)
 # Ignore VCS directories, you can use the same kind of rule outside 
 # OASIS_START/STOP if you want to exclude directories that contains 
 # useless stuff for the build process
 <tests/*.ml{,i}>: oasis_executable_test_uri_byte
 <tests/test_uri.{native,byte}>: oasis_executable_test_uri_native
 <tests/*.ml{,i}>: oasis_executable_test_uri_native
+<tests/test_uri.{native,byte}>: pkg_cadastr
 # Executable test_http_service
 <tests/test_http_service.{native,byte}>: oasis_executable_test_http_service_byte
 <tests/*.ml{,i}>: oasis_executable_test_http_service_byte
 (* setup.ml generated for the first time by OASIS v0.2.1~alpha1 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: ae87b5a440a6e509027d066a705a8ef1) *)
+(* DO NOT EDIT (digest: fd46ca522751aed25ada7dbda7a99ec4) *)
 (*
    Regenerated by OASIS v0.2.1~alpha1
    Visit http://oasis.forge.ocamlcore.org for more information and
                       bs_install = [(OASISExpr.EBool true, false)];
                       bs_path = "tests";
                       bs_compiled_object = Best;
-                      bs_build_depends = [];
+                      bs_build_depends = [FindlibPackage ("cadastr", None)];
                       bs_build_tools = [ExternalTool "ocamlbuild"];
                       bs_c_sources = [];
                       bs_data_files = [];
-module List
- =
-  struct
-
-    include List;
-
-    value find_opt pred lst =
-      try
-        Some (List.find pred lst)
-      with
-      [ Not_found -> None ]
-    ;
-
-    value rec drop_while pred lst =
-      match lst with
-      [ [] -> []
-      | [ hd :: tl ] ->
-          if pred hd
-          then drop_while pred tl
-          else lst
-      ]
-    ;
-
-    value last lst =
-      match lst with
-      [ [] -> failwith "Am_List.last"
-      | [h :: t] ->
-          inner h t
-          where rec inner prev lst =
-            match lst with
-            [ [] -> prev
-            | [h :: t] -> inner h t
-            ]
-      ]
-    ;
-
-    value concat_with between lol =
-      match lol with
-      [ [] -> []
-      | [first :: rest] ->
-          inner (List.rev first) rest
-          where rec inner rev_acc lol =
-            match lol with
-            [ [] -> List.rev rev_acc
-            | [h :: t] ->
-                inner
-                  (List.rev_append
-                     h
-                     (List.rev_append between rev_acc)
-                  )
-                  t
-            ]
-      ]
-    ;
-
-
-    (* returns: ([pre], [this], [rest]) or ([pre], [], []) *)
-
-    value split_by_first pred lst =
-      inner [] lst
-      where rec inner rev_acc lst =
-        match lst with
-        [ [] -> (List.rev rev_acc, [], [])
-        | [h :: t] ->
-            if pred h
-            then (List.rev rev_acc, [h], t)
-            else inner [h :: rev_acc] t
-        ]
-    ;
-
-    value split_by pred lst =
-      loop [] lst
-      where rec loop rev_acc lst =
-        if lst = []
-        then List.rev rev_acc
-        else
-          let (pre, _delim, rest) = split_by_first pred lst in
-          loop [pre :: rev_acc] rest
-    ;
-
-
-    value map_filter func lst =
-      inner [] lst
-      where rec inner rev_acc lst =
-        match lst with
-        [ [] -> List.rev rev_acc
-        | [h :: t] ->
-            match func h with
-            [ None -> inner rev_acc t
-            | Some x -> inner [x :: rev_acc] t
-            ]
-        ]
-    ;
-
-
-    value hd_opt = fun
-      [ [] -> None
-      | [x :: _] -> Some x
-      ]
-    ;
-
-
-    value assoc_count ?(cmp=Pervasives.compare) k t =
-      inner 0 t
-      where rec inner n t =
-        match t with
-        [ [] -> n
-        | [(hk,_hv)::t] ->
-            inner (if cmp k hk = 0 then (n+1) else n) t
-        ]
-    ;
-
-    value assoc_opt ?(cmp=Pervasives.compare) k t =
-      inner t
-      where rec inner t =
-        match t with
-        [ [] -> None
-        | [(hk, hv) :: t] ->
-            if cmp k hk = 0
-            then Some hv
-            else inner t
-        ]
-    ;
-
-
-    (* non tail-rec, GC-wise (does not recreate cons cells without need) *)
-
-    value rec assoc_remove ?(cmp=Pervasives.compare) k t =
-      let rec inner left t =
-        if left = 0
-        then t
-        else loop left t
-      and loop left t =
-        match t with
-        [ [] -> assert False
-        | [((hk,_hv) as h) :: t] ->
-            if cmp k hk = 0
-            then inner (left - 1) t
-            else [h :: loop left t]
-        ]
-      in
-        inner (assoc_count ~cmp k t) t
-    ;
-
-
-    value rec assoc_replace ?(cmp=Pervasives.compare) k v t =
-      [(k, v) :: assoc_remove ~cmp k t]
-    ;
-
-
-    value reduce_left mapfunc reducefunc lst =
-      match lst with
-      [ [] -> invalid_arg "Am_List.reduce_left: empty input list"
-      | [h :: t] ->
-          inner ~acc:(mapfunc h) t
-          where rec inner ~acc lst =
-            match lst with
-            [ [] -> acc
-            | [h :: t] ->
-                inner t ~acc:(reducefunc acc (mapfunc h))
-            ]
-      ]
-    ;
-
-    value get_single lst =
-      let fail reason = failwith ("Am_List.get_single: " ^ reason) in
-      match lst with
-      [ [] -> fail "empty list"
-      | [x :: []] -> x
-      | [_ :: [_ :: _]] -> fail "more than one element"
-      ]
-    ;
-
-    value get_pair lst =
-      let fail reason = failwith
-        ("Am_List.get_pair: expected list of two elements, got " ^ reason) in
-      match lst with
-      [ [] -> fail "empty list"
-      | [_ ::[]] -> fail "list of one element"
-      | [x :: [y :: []]] -> (x, y)
-      | _ -> fail "list of more than two elements"
-      ]
-    ;
-
-
-    open Amall_types;
-
-    module Functor
-     =
-      struct
-        type t 'a = list 'a;
-        value fmap = List.map;
-      end
-    ;
-
-  end
-;
+module List = Cd_List.List;
+open Cd_All;
+module String = Strings.Latin1.String;
+
+(*
 module String
  =
   struct
     include String
     ;
 
-    value is_prefix ~string ~prefix =
-      let str_len = String.length string
-      and pref_len = String.length prefix in
-      pref_len <= str_len
-      && String.sub string 0 pref_len = prefix
-    ;
-
-    value chop_prefix ~string ~prefix =
-      let pref_len = String.length prefix in
-      if is_prefix ~string ~prefix
-      then String.sub string pref_len (String.length string - pref_len)
-      else string
-    ;
-
-    value is_suffix ~string ~suffix =
-      let str_len = String.length string
-      and suf_len = String.length suffix in
-      suf_len <= str_len &&
-      String.sub string (str_len - suf_len) suf_len = suffix
-    ;
-
-    value chop_suffix ~string ~suffix =
-      let suf_len = String.length suffix in
-      if is_suffix ~string ~suffix
-      then String.sub string 0 (String.length string - suf_len)
-      else string
-    ;
-
-    value trim_count pred s =
-      let len = String.length s in
-      let first_skipping =
-        inner 0
-        where rec inner i =
-          if i = len || not (pred s.[i])
-          then i
-          else inner (i + 1)
-      in
-        if first_skipping = len
-        then (len, "", 0)
-        else
-          let last_leaving =
-            inner (len - 1)
-            where rec inner i =
-              let () = assert (i >= first_skipping) in
-              if pred s.[i]
-              then inner (i - 1)
-              else i
-          in
-            let new_len = last_leaving - first_skipping + 1 in
-            ( first_skipping
-            , if new_len = len
-              then s
-              else String.sub s first_skipping new_len
-            , len - last_leaving - 1
-            )
-    ;
-
-    value trim pred s =
-      let (_firsts, res, _lasts) = trim_count pred s in
-      res
-    ;
-
-    value split_by_first pred s =
-      let len = String.length s in
-      let i =
-        inner 0
-        where rec inner i =
-          if i = len || pred s.[i]
-          then i
-          else inner (i + 1)
-      in
-        if i = len
-        then (s, "", "")
-        else
-          ( String.sub s 0 i
-          , String.sub s i 1
-          , String.sub s (i + 1) (len - i - 1)
-          )
-    ;
-
-
-    (* [split_exact ((=) '.') ".asd..sdf." = ["";"asd";"";"sdf";""]] *)
-    value split_exact pred s =
-      let len = String.length s in
-
-      let rec rev_delimiters rev_acc i =  (* including -1 and len *)
-        if i = len
-        then [len :: rev_acc]
-        else
-        if pred s.[i]
-        then
-          rev_delimiters [i :: rev_acc] (i + 1)
-        else
-          rev_delimiters rev_acc (i + 1)
-      in
-      let rev_dels = rev_delimiters [-1] 0 in
-      let rec inner acc rev_dels =
-        match rev_dels with
-        [ [] -> assert False
-        | [ _ :: [] ] -> acc
-        | [next :: ([this :: _] as tl)] ->
-            inner
-              [(String.sub s (this+1) (next - this - 1)) :: acc]
-              tl
-        ]
-      in
-        inner [] rev_dels
-    ;
 
 
 (*
 *)
 
 
-    (* todo: more effective implementation. *)
-
-    value split pred s =
-      List.filter ((<>) "") (split_exact pred s)
-    ;
-
-
-    value decode_hex_opt ch =
-      let c = Char.code ch in
-      if ch >= '0' && ch <= '9'
-      then Some (c - (Char.code '0'))
-      else if ch >= 'A' && ch <= 'F'
-      then Some (c - (Char.code 'A') + 10)
-      else if ch >= 'a' && ch <= 'f'
-      then Some (c - (Char.code 'a') + 10)
-      else None
-    ;
-
-
-    value urldecode s =
-      let len = String.length s in
-      let buf = Buffer.create (len / 3) in
-      loop 0
-      where rec loop i =
-        if i = len
-        then Buffer.contents buf
-        else
-          let out ch adv =
-            (Buffer.add_char buf ch; loop (i + adv))
-          in
-          match s.[i] with
-          [ '+' -> out '\x20' 1
-          | '%' as c0 ->
-              if i + 2 >= len
-              then out c0 1
-              else
-                let c1 = s.[i + 1]
-                and c2 = s.[i + 2] in
-                match (decode_hex_opt c1, decode_hex_opt c2) with
-                [ (Some d1, Some d2) ->
-                    out (Char.chr (16*d1 + d2)) 3
-                | _ -> out c0 1
-                ]
-          | c -> out c 1
-          ]
-    ;
-
-
-    (* todo: more effective implementation *)
-
-    value concat_array sep str_arr =
-      String.concat sep (Array.to_list str_arr)
-    ;
-
-
-    value explode str =
-      inner [] (String.length str - 1)
-      where rec inner acc i =
-        if i < 0
-        then acc
-        else inner [str.[i] :: acc] (i - 1)
-    ;
-
-
-    value compare_nocase_latin1 s1 s2 =
-      let len1 = String.length s1 in
-      let len2 = String.length s2 in
-      let bound = min len1 len2 in
-      loop 0
-      where rec loop i =
-        if i = bound
-        then
-          Pervasives.compare len1 len2
-        else
-          match Pervasives.compare
-            (Char.uppercase s1.[i]) (Char.uppercase s2.[i])
-          with
-          [ 0 -> loop (i + 1)
-          | r -> r
-          ]
-    ;
-
-
-    value eq a b =
-      let len = length a in
-      if len <> length b
-      then False
-      else
-        loop 0
-        where rec loop i =
-          if i = len
-          then True
-          else
-            if (unsafe_get a i) = (unsafe_get b i)
-            then loop (i + 1)
-            else False
-    ;
-
-
   end
 ;
+*)

src/amall_http.ml

 open Am_All;
+open Cd_All; open Strings.Latin1;
 
 value max_uri_len = 4096;
 value max_header_len = 4096;
 
 value max_request_method_len =
   List.fold_left
-    (fun acc (text, _meaning) -> max acc (String.length text))
+    (fun acc (text, _meaning) -> max acc (String.length_bytes text))
     0
     request_method_texts
 ;
  *)
 
 value response_headers resp lst =
-  let nocase = String.compare_nocase_latin1 in
+  let nocase = String.eq_nocase_latin1 in
   let headers_with_lengths =
     match resp.rs_body with
     [ No_body ->
-        List.assoc_remove ~cmp:nocase "Content-length" lst
+        List.Assoc.remove ~keq:nocase "Content-length" lst
     | Body_string s ->
-        List.assoc_replace
+        List.Assoc.replace
+          ~keq:nocase
           "Content-length"
-          (s >> String.length >> string_of_int)
+          (s |> String.length |> string_of_int)
           lst
     ]
   in
       ~limit:(max_request_method_len + 1)
       ~break_pred:is_spaces
     >>= fun meth_txt ->
-    match List.assoc_opt meth_txt request_method_texts with
+    match
+      List.Assoc.get_opt
+        ~keq:String.eq_nocase_latin1
+        meth_txt
+        request_method_texts
+    with
     [ None -> fail "method not supported"
     | Some meth -> I.return meth
     ]

src/amall_http_service.ml

 open Amall_types;
 open Printf;
 
-open Cadastr; open Cd_All; open Cdt; open Strings.Utf8;
+open Cadastr; open Cd_All; open Cdt; open Strings.Latin1;
 
 open Amall_http_server
 ;
     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];
+    class c_seg_map = Tr.map_rws_tree [disp_handler] ();
 (*
 *)
 
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.