Commits

Roma Sokolov committed 4286da3

Split library to core package and dbi subpacakge.
Introduce oasis.
Remove unnecessary files.
Add stdfiles.

Comments (0)

Files changed (83)

 ^_build/
 ~$
 \.(byte|native)$
+.ba*
+(* OASIS_START *)
+(* DO NOT EDIT (digest: d7f39f8b1e635092d53da406936a259e) *)
+Authors of amall
+Dmitry Grebeniuk
+(* OASIS_STOP *)
+(* OASIS_START *)
+(* DO NOT EDIT (digest: e6005cca2c7f12171e46992af7d7b996) *)
+This is the INSTALL file for the amall distribution.
+
+This package uses OASIS to generate its build system. See section OASIS for
+full information. 
+
+Dependencies
+============
+
+In order to compile this package, you will need:
+* ocaml
+* findlib
+* monad_io for library amall, executable test_http_service
+* iteratees for library amall, executable test_http_service
+* postgresql for library amall-dbi
+
+Installing
+==========
+
+1. Uncompress the source archive and go to the root of the package
+2. Run 'ocaml setup.ml -configure'
+3. Run 'ocaml setup.ml -build'
+4. Run 'ocaml setup.ml -install'
+
+Uninstalling
+============
+
+1. Go to the root of the package 
+2. Run 'ocaml setup.ml -uninstall'
+
+OASIS
+=====
+
+OASIS is a program that generates a setup.ml file using a simple '_oasis'
+configuration file. The generated setup only depends on the standard OCaml
+installation: no additional library is required.
+
+(* OASIS_STOP *)
+
+Addresses:
+ocaml_monad_io -- https://bitbucket.org/gds/ocaml_monad_io
+iteratees -- https://forge.ocamlcore.org/projects/ocaml-iteratees

META

-name="amall"
-version="0.1"
-description="AmAll"
-requires="unix, postgresql, monad_io, iteratees"
-archive(byte)="amall.cma"
-archive(native)="amall.cmxa"
-PKG=amall
-VERSION=0.1
+# OASIS_START
+# DO NOT EDIT (digest: bc1e05bfc8b39b664f29dae8dbd3ebbb)
 
-all :
-	ocamlbuild \
-	   amall.cma amall.cmxa
+SETUP = ocaml setup.ml
 
-install : all
-	ocamlfind install \
-	  -patch-version $(VERSION) \
-	  $(PKG) META \
-	  _build/amall.cma _build/amall.cmxa _build/amall.a \
-	  _build/am_All.cmi _build/am_Common.cmi _build/am_Ops.cmi \
-	  _build/dbi.cmi _build/dbi_common.cmi _build/dbi_pg.cmi \
-	  _build/extArray.cmi _build/extList.cmi _build/extQueue.cmi \
-	  _build/extStream.cmi _build/extString.cmi _build/extSys.cmi \
-	  _build/filename_new.cmi _build/filew.cmi _build/res.cmi \
-	  _build/sortedArray.cmi _build/sortedArraySet.cmi \
-	  _build/with_comb.cmi _build/amall_http.cmi _build/amall_types.cmi \
-	  _build/uri.cmi _build/uri_type.cmi _build/amall_http_server.cmi
+build: setup.data
+	$(SETUP) -build $(BUILDFLAGS)
 
-deinstall :
-	ocamlfind remove $(PKG)
+doc: setup.data build
+	$(SETUP) -doc $(DOCFLAGS)
 
-uninstall :
-	$(MAKE) deinstall
+test: setup.data build
+	$(SETUP) -test $(TESTFLAGS)
 
-reinstall :
-	-$(MAKE) deinstall
-	$(MAKE) install
+all: 
+	$(SETUP) -all $(ALLFLAGS)
+
+install: setup.data
+	$(SETUP) -install $(INSTALLFLAGS)
+
+uninstall: setup.data
+	$(SETUP) -uninstall $(UNINSTALLFLAGS)
+
+reinstall: setup.data
+	$(SETUP) -reinstall $(REINSTALLFLAGS)
+
+clean: 
+	$(SETUP) -clean $(CLEANFLAGS)
+
+distclean: 
+	$(SETUP) -distclean $(DISTCLEANFLAGS)
+
+setup.data:
+	$(SETUP) -configure $(CONFIGUREFLAGS)
+
+.PHONY: build doc test all install uninstall reinstall clean distclean configure
+
+# OASIS_STOP
+(* OASIS_START *)
+(* DO NOT EDIT (digest: f7a66760511e809123c5ea6837cb8669) *)
+This is the README file for the amall distribution.
+
+Amatei OCaml library.
+
+Amatei OCaml library with stdlib extensions, database interface, http 
+protocol implementation, with-combinators, module for files (Filew) and so
+on. Commits made by Dmitry Grebeniuk are sponsored by Amatei.
+
+See the files INSTALL.txt for building and installation instructions. See the
+file LICENSE for copying conditions. 
+
+
+(* OASIS_STOP *)
+OASISFormat: 0.2
+Name: amall
+Version: 0.0.1
+Synopsis: Amatei OCaml library.
+Authors: Dmitry Grebeniuk
+License: LGPL-2.1 with OCaml linking exception
+LicenseFile: LICENSE
+Plugins: DevFiles (0.2), META (0.2), StdFiles (0.2)
+BuildTools: ocamlbuild
+Description:
+  Amatei OCaml library with stdlib extensions, database interface,
+  http  protocol implementation, with-combinators, module for
+  files (Filew) and so on.
+  Commits made by Dmitry Grebeniuk are sponsored by Amatei.
+
+Flag dbi
+  Description: DBI support
+  Default: true
+
+Library "amall"
+  Path: src
+  Modules:
+    Am_All,
+    Am_Ops,
+    Amall_types,
+    Amall_http,
+    Amall_http_server,
+    Amall_http_service,
+    Uri,
+    Uri_type,
+    Res,
+    Filew,
+    SortedArray,
+    SortedArraySet,
+    With_comb
+  InternalModules:
+    Am_Common,
+    ExtStream,
+    ExtString,
+    ExtList,
+    ExtArray,
+    ExtQueue,
+    ExtSys,
+    Filename_new,
+    Urilex
+  BuildDepends: unix, monad_io, monad_io.lwt, iteratees
+  NativeOpt:       -w A
+  ByteOpt:         -w A
+  XMETADescription: Amall library (core)
+
+Library "amall-dbi"
+  Build$: flag(dbi)
+  Install$: flag(dbi)
+  FindlibName: dbi
+  FindlibParent: amall
+  Path: src/dbi
+  Modules:
+    Dbi,
+    Dbi_common,
+    Dbi_pg
+  BuildDepends: amall, unix, postgresql, threads
+  NativeOpt:       -w A
+  ByteOpt:         -w A
+  XMETADescription: Amall dbi
+
+Executable test_uri
+  Path: tests/
+  Install: false
+  CompiledObject: best
+  MainIs: test_uri.ml
+  NativeOpt:       -w A
+  ByteOpt:         -w A
+
+Executable test_http_service
+  Path: tests/
+  Install: false
+  CompiledObject: best
+  MainIs: test_http_service.ml
+  BuildDepends: iteratees, monad_io.lwt
+  NativeOpt:       -w A
+  ByteOpt:         -w A
+
+
+SourceRepository head
+  Type: hg
+  Location: https://bitbucket.org/gds/amall
+  Browser: https://bitbucket.org/gds/amall
-<*.ml> | <*.mli> : camlp4r, warn_A, pkg_unix
-<am_Ops.*> | <filename_new.*> | <urilex.ml> : -camlp4r, camlp4o
-<dbi_pg.*> : pkg_postgresql, pkg_threads
-<amall_http.*> | <amall_http_server.*> : pkg_monad_io, pkg_iteratees
+# OASIS_START
+# DO NOT EDIT (digest: 71b38f81f46bc017a6b7fbd9816f5fa0)
+# 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
+<**/.svn>: -traverse
+<**/.svn>: not_hygienic
+".bzr": -traverse
+".bzr": not_hygienic
+".hg": -traverse
+".hg": not_hygienic
+".git": -traverse
+".git": not_hygienic
+"_darcs": -traverse
+"_darcs": not_hygienic
+# Library amall
+"src": include
+<src/amall.{cma,cmxa}>: oasis_library_amall_byte
+<src/*.ml{,i}>: oasis_library_amall_byte
+<src/amall.{cma,cmxa}>: oasis_library_amall_native
+<src/*.ml{,i}>: oasis_library_amall_native
+<src/*.ml{,i}>: pkg_unix
+<src/*.ml{,i}>: pkg_monad_io.lwt
+<src/*.ml{,i}>: pkg_monad_io
+<src/*.ml{,i}>: pkg_iteratees
+# Library amall-dbi
+"src/dbi": include
+<src/dbi/amall-dbi.{cma,cmxa}>: oasis_library_amall_dbi_byte
+<src/dbi/*.ml{,i}>: oasis_library_amall_dbi_byte
+<src/dbi/amall-dbi.{cma,cmxa}>: oasis_library_amall_dbi_native
+<src/dbi/*.ml{,i}>: oasis_library_amall_dbi_native
+<src/dbi/*.ml{,i}>: use_amall
+<src/dbi/*.ml{,i}>: pkg_unix
+<src/dbi/*.ml{,i}>: pkg_threads
+<src/dbi/*.ml{,i}>: pkg_postgresql
+<src/dbi/*.ml{,i}>: pkg_monad_io.lwt
+<src/dbi/*.ml{,i}>: pkg_monad_io
+<src/dbi/*.ml{,i}>: pkg_iteratees
+# Executable test_uri
+<tests/test_uri.{native,byte}>: oasis_executable_test_uri_byte
+<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
+# 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
+<tests/test_http_service.{native,byte}>: oasis_executable_test_http_service_native
+<tests/*.ml{,i}>: oasis_executable_test_http_service_native
+<tests/test_http_service.{native,byte}>: pkg_monad_io.lwt
+<tests/test_http_service.{native,byte}>: pkg_iteratees
+<tests/*.ml{,i}>: pkg_monad_io.lwt
+<tests/*.ml{,i}>: pkg_iteratees
+# OASIS_STOP
 
-<it_type.*> : pkg_iteratees
+<src/*.ml{,i}> : camlp4r
+<src/dbi/*.ml{,i}> : camlp4r
+<tests/*.ml> : camlp4r
+<src/am_Ops.*> | <src/filename_new.*> | <src/urilex.ml> : -camlp4r, camlp4o
 
-<test_http_service.*> : pkg_iteratees, pkg_monad_io.lwt
-
-<*> : debug

am_All.ml

-include Am_Ops;
-module Array = ExtArray.Array;
-module List = ExtList.List;
-module Queue = ExtQueue.Queue;
-module Stream = ExtStream.Stream;
-module String = ExtString.String;
-module Sys = ExtSys.Sys;
-module Filename = Filename_new;
-include Am_Common;
-module Dbi = Dbi.Dbi;
-include Printf;

am_Common.ml

-open Printf
-;
-
-open Am_Ops
-;
-
-value dbg fmt = Printf.ksprintf (Printf.eprintf "DBG: %s\n%!") fmt
-;
-
-value failwith fmt = Printf.ksprintf failwith fmt
-;
-
-exception Not_implemented of string
-;
-
-value not_impl func = raise (Not_implemented func)
-;
-
-value () = Printexc.register_printer & fun
-  [ Not_implemented func ->
-      some & sprintf "Function %S is not implemented." func
-  | _ -> None
-  ]
-;

am_Ops.ml

-(* not really operations, but.. *)
-let forA arr func = Array.iter func arr
-let forL lst func = List.iter func lst
-let forStream strm func = Stream.iter func strm
-
-
-external extern_identity : 'a -> 'a = "%identity"
-
-let identity = extern_identity
-
-let some x = Some x
-
-(** пропустить значение последовательно через функции:
-    123 >> string_of_int >> print_string
-*)
-let ( >> ) x f = f x
-
-(** применить значение к функции:
-    print_string & string_of_int & 123
-
-    NB: оператор "&" является ключевым словом в jocaml
-
-    Если попробовать объявить "let ( $ ) f x = f x",
-    то полученный оператор будет левоассоциативным,
-    что нежелательно в данном случае.
-*)
-let ( & ) f x = f x
-
-(** композиция функций:
-    let print_int = print_string % string_of_int
-    let print_int = print_string $ string_of_int
-    let print_int_sum = print_string % string_of_int %% ( + )
-    let print_int_sum = print_string %% (string_of_int %% ( + ) )
-    let for_all pred = not % List.exists (not % pred)
-    let for_all2 pred = not %% List.exists2 (not %% pred)
-
-    Операторы левоассоциативны, у оператора ($) приоритет ниже,
-    чем у (%), и ниже, чем у арифметических операторов.
-*)
-let ( % ) f g = fun x -> f (g x)
-let ( $ ) = ( % )
-let ( %% ) f g = fun x y -> f (g x y)
-let ( %%% ) f g = fun x y z -> f (g x y z)
-
-(** применить инфиксную функцию:
-    123L /* Int64.add */ 234L
-*)
-let ( /* ) x y = y x
-let ( */ ) x y = x y
-
-
-(* Для удобного использования инфиксных операторов
-   существует отличное решение: pa_do
-   ( http://pa-do.forge.ocamlcore.org/ )
-   Если использовать его не можете, то в качестве
-   слабого подобия можно взять нижеследующие модули.
-   Их названия имеют вид "Тип1_as_тип2", и при открытии
-   такого модуля со значениями типа1 можно будет работать
-   теми операторами, которыми обычно работают со значениями
-   типа2.
-   Например,
-   let my_int64 =
-     let module M =
-       struct
-         open Int32_as_int
-         open Int64_as_float
-         let x = (Int64.of_int32 (123l + 234l)) +. 345L
-       end
-     in
-       M.x
-*)
-
-(* Замечание: для консистентности модули "Тип1_as_тип2"
-   всегда должны переопределять одни и те же операторы.
-*)
-
-(* todo: добавить в Int* операции mod, rem, битовые *)
-
-module Int_as_int =
-  struct
-    let ( + ) = Pervasives.( + )
-    let ( - ) = Pervasives.( - )
-    let ( * ) = Pervasives.( * )
-    let ( / ) = Pervasives.( / )
-    let ( ~- ) = Pervasives.( ~- )
-  end
-
-module Float_as_float =
-  struct
-    let ( +. ) = Pervasives.( +. )
-    let ( -. ) = Pervasives.( -. )
-    let ( *. ) = Pervasives.( *. )
-    let ( /. ) = Pervasives.( /. )
-    let ( ~-. ) = Pervasives.( ~-. )
-  end
-
-
-(** TODO core, pa_do, pa_openin *)
-
-module Int32_as_int =
-  struct
-    let ( + ) = Int32.add
-    let ( - ) = Int32.sub
-    let ( * ) = Int32.mul
-    let ( / ) = Int32.div
-    let ( ~- ) = Int32.neg
-  end
-
-module Int64_as_int =
-  struct
-    let ( + ) = Int64.add
-    let ( - ) = Int64.sub
-    let ( * ) = Int64.mul
-    let ( / ) = Int64.div
-    let ( ~- ) = Int64.neg
-  end
-
-module Int_as_float =
-  struct
-    let ( +. ) = Pervasives.( + )
-    let ( -. ) = Pervasives.( - )
-    let ( *. ) = Pervasives.( * )
-    let ( /. ) = Pervasives.( / )
-    let ( ~-. ) = Pervasives.( ~- )
-  end
-
-module Float_as_int =
-  struct
-    let ( + ) = Pervasives.( +. )
-    let ( - ) = Pervasives.( -. )
-    let ( * ) = Pervasives.( *. )
-    let ( / ) = Pervasives.( /. )
-    let ( ~- ) = Pervasives.( ~-. )
-  end
-
-module Int32_as_float =
-  struct
-    let ( +. ) = Int32.add
-    let ( -. ) = Int32.sub
-    let ( *. ) = Int32.mul
-    let ( /. ) = Int32.div
-    let ( ~-. ) = Int32.neg
-  end
-
-module Int64_as_float =
-  struct
-    let ( +. ) = Int64.add
-    let ( -. ) = Int64.sub
-    let ( *. ) = Int64.mul
-    let ( /. ) = Int64.div
-    let ( ~-. ) = Int64.neg
-  end
-
-module Int_as_int_overflow =
-  (* from http://alan.petitepomme.net/cwn/2004.06.22.html *)
-  struct
-    exception Overflow
-
-    let ( + ) a b =
-      let c = a + b in
-      if (a lxor b) lor (a lxor (lnot c)) < 0 then c else raise Overflow
-
-    let ( - ) a b =
-      let c = a - b in
-      if (a lxor (lnot b)) lor (b lxor c) < 0 then c else raise Overflow
-
-    let ( * ) a b =
-      let c = a * b in
-      if Int64.of_int c = Int64.mul (Int64.of_int a) (Int64.of_int b)
-      then c else raise Overflow
-
-    let ( / ) a b =
-      if a = min_int && b = -1 then raise Overflow else a / b
-
-    let ( ~- ) x =
-      if x <> min_int then -x else raise Overflow
-
-  end

amall.mllib

-Am_All
-Am_Common
-Am_Ops
-Dbi_common
-Dbi
-Dbi_pg
-ExtArray
-ExtList
-ExtQueue
-ExtStream
-ExtString
-ExtSys
-Filename_new
-Filew
-Res
-SortedArray
-SortedArraySet
-With_comb
-Amall_http
-Amall_http_server
-Amall_http_service
-Amall_types
-Uri_type
-Uri
-Urilex

amall_http.ml

-open Am_All;
-
-value max_uri_len = 4096;
-value max_header_len = 4096;
-value max_headers_size = 10240;
-value default_uri_scheme = "http";
-
-(**********)
-
-type request_method = [= `GET | `POST | `HEAD ]
-;
-
-type transfer_encoding =
-  [= `Identity
-  |  `Chunked
-  |  `Gzip
-  |  `Other of string
-  ]
-;
-
-type connection_header_val =
-  [= `Close
-  |  `Other of string
-  ]
-;
-
-open Uri_type
-;
-
-type rq_headers =
-  { connection : list connection_header_val
-  ; content_length : option int
-  ; transfer_length : option int
-  ; transfer_encoding : list transfer_encoding
-  ; rqh_host : option (host_kind * string * option int)
-  ; rq_all : list (string * string);
-  }
-;
-
-value empty_rq_headers : rq_headers =
-  { connection = []
-  ; content_length = None
-  ; transfer_encoding = []
-  ; transfer_length = None
-  ; rqh_host = None
-  ; rq_all = []
-  }
-;
-
-
-type request =
-  { rq_method : request_method
-  ; rq_uri : uri
-  ; rq_request_uri__ : uri  (* uri from "GET ... HTTP/*" line, not useful *)
-  ; rq_version : (int * int)
-  ; rq_headers : rq_headers
-  }
-;
-
-exception Bad_request of string
-;
-
-type rs_headers =
-  { rs_all : list (string * string)
-  }
-;
-
-type rs_body =
-  [ No_body
-  | Body_string of string
-  ]
-;
-
-type response =
-  { rs_status_code : int
-  ; rs_reason_phrase : string
-  ; rs_headers : rs_headers
-  ; rs_body : rs_body
-  }
-;
-
-value request_method_texts =
-  [ ("GET", `GET)
-  ; ("POST", `POST)
-  ; ("HEAD", `HEAD)
-  ]
-;
-
-value max_request_method_len =
-  List.fold_left
-    (fun acc (text, _meaning) -> max acc (String.length text))
-    0
-    request_method_texts
-;
-
-
-value (make_headers : list (string * string) -> rq_headers) lst =
-  let connection = ref []
-  and content_length = ref None
-  and transfer_length = ref None
-  and transfer_encoding = ref []
-  and host = ref None
-  in
-  let () = List.iter
-    (fun (hk, hv) ->
-       let _add r = r.val := [hv :: r.val]
-       and set_opt_int r =
-         try r.val := some & int_of_string hv
-         with [Failure _ -> ()]
-       and addmap f r = r.val := List.append (f hv) r.val in
-       let parse_connection hv =
-         (* todo: tokenize *)
-         [if hv = "close" then `Close else `Other hv]
-       and parse_t_e hv =
-         (* todo: tokenize *)
-         match hv with
-         [ "identity" -> []
-         | "chunked" -> [`Chunked]
-         | "gzip" -> [`Gzip]
-         | x -> [`Other x]
-         ]
-       in
-       match String.lowercase hk with
-       [ "connection" -> addmap parse_connection connection
-       | "content-length" -> set_opt_int content_length
-       | "transfer-length" -> set_opt_int transfer_length
-       | "transfer-encoding" -> addmap parse_t_e transfer_encoding
-       | "host" ->
-           match (host.val, Uri.parse_host_portopt hv) with
-           [ (None, ((Some _) as some_h)) -> host.val := some_h
-           | _ -> ()
-           ]
-       | _ -> ()
-       ]
-    )
-    lst
-  in
-    { connection = connection.val
-    ; content_length = content_length.val
-    ; transfer_length = transfer_length.val
-    ; transfer_encoding = transfer_encoding.val
-    ; rqh_host = host.val
-    ; rq_all = lst
-    }
-;
-
-
-(************************************************************)
-
-value is_spaces = fun
-  [ '\x20' | '\x0A' | '\x0D' | '\x09' -> True
-  | _ -> False
-  ]
-;
-
-value is_line_term = fun
-  [ '\x0A' | '\x0D' -> True
-  | _ -> False
-  ]
-;
-
-value is_whitespace = fun
-  [ '\x20' | '\x09' -> True
-  | _ -> False
-  ]
-;
-
-(************************************************************)
-
-value request_has_message_body rq =
-  let h = rq.rq_headers in
-     h.transfer_encoding <> []
-  || h.content_length <> None
-  || h.transfer_length <> None
-;
-
-(* добавляет заголовки, которые нужно вычислить на основании
-   других частей ответа.
- *)
-
-value response_headers resp lst =
-  let nocase = String.compare_nocase_latin1 in
-  let headers_with_lengths =
-    match resp.rs_body with
-    [ No_body ->
-        List.assoc_remove ~cmp:nocase "Content-length" lst
-    | Body_string s ->
-        List.assoc_replace
-          "Content-length"
-          (s >> String.length >> string_of_int)
-          lst
-    ]
-  in
-    headers_with_lengths
-;
-
-
-value string_of_header (k, v) =
-  let ch c =
-    if String.contains k c
-    then invalid_arg & sprintf
-      "http response header: header name should not contain char %C"
-      c
-    else
-      ()
-  in
-    ( ch '\r'; ch '\n'; ch ':'; ch '\x20'; ch '\x00'
-    ; sprintf "%s: %s\r\n" k v
-    )
-;
-
-
-value string_of_response_headers rs =
-  let err msg = invalid_arg ("http response: " ^ msg) in
-  let code = rs.rs_status_code in
-  if code < 100 || code >= 1000
-  then err & sprintf "status code must be 3-digit (now: %i)" code
-  else
-  let reas = rs.rs_reason_phrase in
-  if String.contains reas '\n' || String.contains reas '\r'
-  then err "reason phrase must not contain CR or LF"
-  else
-  sprintf "HTTP/1.1 %i %s\r\n%s\r\n"
-    code
-    reas
-    (String.concat "" &
-     List.map string_of_header &
-     response_headers rs rs.rs_headers.rs_all
-    )
-;
-
-
-value some_default_uri_scheme = Some default_uri_scheme
-;
-
-(************************************************************)
-
-
-
-module Make
-  (IO : Amall_types.IO_Type)
-  (I : It_type.IT with type It_IO.m 'a = IO.m 'a)
-=
-struct
-
-open I.Ops;
-
-value read_the_string str err =
-  let charlist = String.explode str in
-  I.heads charlist >>= fun matched ->
-  if matched = String.length str
-  then I.return ()
-  else I.throw_err err
-;
-
-
-(************************************************************)
-
-value (it_eof : I.iteratee 'el1 'a -> I.iteratee 'el2 'a) it =
-  I.lift (I.run it)
-;
-
-value (it_eof_ignore : I.iteratee 'el1 'a -> I.iteratee 'el2 unit) it =
-  I.lift
-    ( IO.catch
-        (fun () ->
-           I.run it >>% fun a ->
-           let () = ignore a in
-           IO.return ()
-        )
-        (fun _ -> IO.return ())
-    )
-;
-
-value list_map_all func lst =
-  inner [] lst
-  where rec inner rev_acc lst =
-    match lst with
-    [ [] -> I.return & List.rev rev_acc
-    | [h :: t] ->
-        func h >>= fun fh -> inner [fh :: rev_acc] t
-    ]
-;
-
-(************************************************************)
-
-value (it_http :
-  (request -> I.iteratee char 'a) ->
-  (I.iteratee char (request * 'a))
-)
-process_request =
-  let fail r = I.throw_err & Bad_request r in
-  let read_the_char c =
-    (I.catch
-      (fun () -> I.mapI some I.head)
-      (fun [ End_of_file -> I.return None
-           | x -> I.throw_err x])
-    )
-    >>= fun
-    [ None -> fail & sprintf "expected %C, got eof" c
-    | Some c' when c = c' -> I.return ()
-    | Some c' -> fail & sprintf "expected %C, got %C" c c'
-    ]
-  in
-  let read_component ~limit ~name ~break_pred =
-    I.break_limit ~pred:break_pred ~limit >>= fun (status, s) ->
-    match status with
-    [ `Hit_limit -> fail & sprintf "bad %s (too big)" name
-    | `Hit_eof -> fail & sprintf "eof reading %s" name
-    | `Found -> I.return & I.Subarray.to_string s
-    ]
-  in
-  let read_line_terminators =
-    ( I.heads ['\r'; '\n'] >>= fun n ->
-      if n = 0
-      then I.heads ['\n']
-      else I.return n
-    ) >>= fun n ->
-    I.return (n <> 0)
-  in
-  let read_method =
-    read_component
-      ~name:"method"
-      ~limit:(max_request_method_len + 1)
-      ~break_pred:is_spaces
-    >>= fun meth_txt ->
-    match List.assoc_opt meth_txt request_method_texts with
-    [ None -> fail "method not supported"
-    | Some meth -> I.return meth
-    ]
-  and read_uri =
-    read_component
-      ~name:"URI"
-      ~limit:max_uri_len
-      ~break_pred:is_spaces
-    >>= fun uri_txt ->
-    match Uri.parse uri_txt with
-    [ None -> fail "bad uri"
-    | Some u -> I.return u
-    ]
-  and read_version =
-    let read_uint name =
-      let max_digits = 9 in
-      let not_digit c = (c > '9' || c < '0') in
-      (* ignore_zeroes >>= fun () -> *)
-      read_component
-        ~limit:(max_digits + 1)
-        ~name
-        ~break_pred:not_digit
-      >>= fun uint_txt ->
-      try I.return & int_of_string uint_txt
-      with [ _ -> fail "internal error" ]
-    in
-    read_the_string "HTTP/" (Bad_request "expected \"HTTP/\" string")
-    >>= fun () ->
-    read_uint "http major version" >>= fun ver_maj ->
-    read_the_char '.' >>= fun () ->
-    read_uint "http minor version" >>= fun ver_min ->
-    I.return (ver_maj, ver_min)
-  and read_eol =
-    read_line_terminators >>= fun t ->
-    if t
-    then I.return ()
-    else fail "end-of-line not found"
-  and read_headers =
-    let rec read_headers acc =
-      read_component ~limit:max_header_len ~name:"header"
-        ~break_pred:is_line_term >>= fun header_line ->
-      read_line_terminators >>= fun t ->
-      match (t, header_line) with
-      [ (True, "") -> I.return & List.rev acc
-      | (True, _) ->
-          let _ () = dbg "header_line = %S" header_line in
-          (* process the header *)
-          let (first_spaces, header_line, _last_spaces) =
-            String.trim_count is_whitespace header_line in
-          if first_spaces > 0
-          then
-            match acc with
-            [ [] -> fail "first header starts with whitespace"
-            | [last :: others] ->
-                read_headers [(last ^ " " ^ header_line) :: others]
-            ]
-          else
-            read_headers [header_line :: acc]
-      | (False, _) -> fail "premature end of headers"
-      ]
-    in
-      read_headers []
-  in
-    read_method >>= fun meth ->
-    read_the_char '\x20' >>= fun () ->
-    read_uri >>= fun request_uri__ ->
-    read_the_char '\x20' >>= fun () ->
-    read_version >>= fun version ->
-    read_eol >>= fun () ->
-    I.limit max_headers_size read_headers >>= fun rh_it ->
-    match rh_it with
-    [ I.IE_cont (Some e) _k -> I.throw_err e
-    | I.IE_cont None _ ->
-        it_eof_ignore rh_it >>= fun () ->
-        fail & sprintf "headers too large (max %i bytes allowed)"
-          max_headers_size
-    | I.IE_done headers -> I.return headers
-    ] >>= fun header_lines ->
-    list_map_all
-      (  fun line ->
-           let (hname, sep, hval_sp) =
-             String.split_by_first ( (=) ':' ) line in
-           if sep = "" then fail "header without ':'"
-           else
-             let hval = String.trim is_whitespace hval_sp in
-             I.return (hname, hval)
-      )
-      header_lines
-    >>= fun header_lines ->
-    let rq_headers = make_headers header_lines in
-    let rq_uri =
-      match (request_uri__.authority, rq_headers.rqh_host) with
-      [ (None, Some (host_kind, host, port_opt)) ->
-          (* let () = dbg "it_http: host=%S port=%s" host
-            (match port_opt with [None -> "-" | Some i -> string_of_int i]) in
-          *)
-           { (request_uri__) with
-             authority = Some
-               { host_kind = host_kind
-               ; host = host
-               ; port = port_opt
-               ; userinfo = None
-               }
-           }
-      | _ -> request_uri__
-      ]
-    in
-    let rq_uri =
-      match rq_uri.scheme with
-      [ None -> { (rq_uri) with scheme = some_default_uri_scheme }
-      | Some _ -> rq_uri
-      ]
-    in
-    let () = dbg "it_http: rq_uri: %s" (Uri.dump_uri rq_uri) in
-    I.return
-    { rq_method = meth
-    ; rq_request_uri__ = request_uri__
-    ; rq_version = version
-    ; rq_headers = rq_headers
-    ; rq_uri = rq_uri
-    }
-    >>= fun request ->
-    let ret = I.mapI (fun res -> (request, res)) in
-    let user_it = process_request request in
-    if not & request_has_message_body request
-    then
-      let () = dbg "request has no body, sending EOF to user's iteratee" in
-      ret & it_eof user_it
-    else
-      let () = dbg "request has body" in
-      (
-        (* todo: chunked t.e. *)
-        let h = request.rq_headers in
-        if List.exists ((=) `Close) h.connection
-        then
-          I.return `Till_eof
-        else
-        if h.transfer_encoding <> []
-        then
-          fail "non-identity transfer encodings are not implemented"
-        else
-          match h.content_length with
-          [ None -> fail "411 Length required"
-          | Some len -> I.return & `Content_length len
-          ]
-      ) >>= fun bounds ->
-      match bounds with
-      [ `Till_eof ->
-          let () = dbg "bounds: till eof" in
-          ret & user_it
-      | `Content_length len ->
-          let () = dbg "bounds: Content_length %i" len in
-          ret & I.joinI & I.take len user_it
-      ]
-;
-
-
-value (request_with_post_vars
-: request -> I.iteratee char (request * list (string * string))
-)
-request
- =
-  I.gather_to_string >>= fun s ->
-  let vars =
-    s
-    >> String.split_exact ((=) '&')
-    >> List.map
-         (fun binding ->
-            let (var_key, eq_sign, var_val) =
-              String.split_by_first ((=) '=') binding
-            in
-              if eq_sign = ""
-              then
-                (* решение "хоть как-то" *)
-                (var_key, "")
-              else
-                (var_key, String.urldecode var_val)
-         )
-  in
-  let () =
-    List.iter
-      (fun (k, v) ->
-         dbg "body: %s = %S" k v
-      )
-      vars
-  in
-  I.return (request, vars)
-;
-
-
-
-(***************************************************************)
-
-
-value output_body outch rs_body =
-  match rs_body with
-  [ No_body -> IO.return ()
-  | Body_string s -> IO.write outch s
-  ]
-;
-
-
-value output_response ?(is_head=False) outch rs : IO.m unit =
-  IO.write outch (string_of_response_headers rs) >>% fun () ->
-  (if is_head
-   then IO.return ()
-   else output_body outch rs.rs_body
-   ) >>% fun () ->
-  IO.flush outch
-;
-
-
-end;

amall_http_server.ml

-open Amall_types;
-open Am_Ops;
-open Printf;
-open Amall_http;
-
-type port = int;
-type addr_string = string;
-
-type listen_addr =
-  [= `Inet_any of port
-  |  `Inet_loopback of port
-  |  `Inet_str of (addr_string * port)
-  |  `Inet_addr of (Unix.inet_addr * port)
-  ]
-;
-
-module Http_server
-  (IO : IO_Type)
-  (I : It_type.IT with
-        type It_IO.m 'a = IO.m 'a
-    and type It_IO.input_channel = IO.input_channel
-  )
- :
-  sig
-
-    type http_server_func = request -> I.iteratee char response
-    ;
-
-    value post_form : request ->
-      I.iteratee char (request * list (string * string))
-    ;
-
-    value run : listen_addr -> http_server_func -> IO.server
-    ;
-
-  end
-=
-struct
-
-module H = Amall_http.Make(IO)(I);
-
-open I.Ops;
-
-type http_server_func = request -> I.iteratee char response
-;
-
-value (runA : IO.m (I.iteratee 'el 'a) -> It_Types.res 'a) i =
-  IO.runIO (i >>% I.run)
-;
-
-value rec printexc e =
-  match e with
-  [ I.Iteratees_err_msg e -> printexc e
-  | _ -> Printexc.to_string e
-  ]
-;
-
-value rec dump_chars_chunks title =
-  I.ie_cont step
-  where rec step s =
-  match s with
-  [ I.EOF oe ->
-      let err =
-        match oe with
-        [ None -> "eof"
-        | Some e -> printexc e
-        ]
-      in
-        IO.printf "dump_chars_chunks: %s: EOF: %s.\n" title err >>% fun () ->
-        I.ie_doneM () s
-  | I.Chunk c ->
-      IO.printf "dump_chars_chunks: %s: Chunk: %S\n"
-        title (I.Subarray.to_string c) >>% fun () ->
-      I.ie_contM step
-  ]
-;
-
-
-
-value (post_form : request ->
-  I.iteratee char (request * list (string * string))
-) request =
-  I.printf "request headers was read ok, request_uri: %S, uri: %S.\n\
-            headers:\n%s\n===\n%!"
-       (Uri.dump_uri request.rq_request_uri__)
-       ( (* Uri.dump_uri request.rq_uri *) "<todo>")
-       (String.concat "\n" & List.map (fun (k,v) -> sprintf "%S = %S" k v)
-         request.rq_headers.rq_all
-       )
-  >>= fun () ->
-(*
-  dump_chars_chunks "header"
-*)
-  H.request_with_post_vars request
-;
-
-
-
-value _ () =
-  let fn = "post-req" in
-  match
-    runA & I.enum_file fn &
-      ((H.it_http & post_form)
-       >>= fun r -> dump_chars_chunks "after body" >>= fun () ->
-       I.return r
-      )
-  with
-  [ `Ok _ -> ()
-  | `Error e -> eprintf "exception: %s\n%!" & printexc e
-  ]
-;
-
-
-value () = ignore & I.limit;
-
-(**********************************************************)
-
-(* гарантируется, что всё мероприятие начнётся с вызова it_proc_req,
-   затем будет дано хоть что-то итерату, возвращённому функцией
-   (возможно ошибка или просто конец потока; в случае наличия тела
-   запроса будет дано тело).
- *)
-
-value io_http_server_func (it_proc_req : http_server_func) inch
-: IO.m (request * response) =
-
-  I.enum_fd inch (H.it_http it_proc_req) >>% fun it ->
-  I.run it
-;
-
-
-(*
-        >>= fun (request, response) ->
-      dump_chars_chunks "after body" >>= fun () ->
-      I.return r
-    )
-  )
-;
-*)
-
-
-value http_server_func userfunc (inch, outch) =
-  IO.run_and_ignore_result
-     (IO.catch
-        (fun () ->
-           io_http_server_func userfunc inch >>% fun (request, resp) ->
-
-           let is_head = (request.rq_method = `HEAD) in
-           H.output_response ~is_head outch resp >>% fun () ->
-           (* IO.flush outch -- если не будет close *)
-
-           IO.close_in inch >>% fun () ->
-           IO.close_out outch
-        )
-        (fun e ->
-          ( Printf.eprintf "amall http: exception: %s\n%!" &
-              Printexc.to_string e
-          ; IO.return ()
-          )
-        )
-     )
-;
-
-
-value run_addr listen_addr userfunc =
-  IO.establish_server listen_addr (http_server_func userfunc)
-;
-
-
-value run listen_addr userfunc =
-  let a =
-    match listen_addr with
-    [ `Inet_any port -> Unix.ADDR_INET (Unix.inet_addr_any, port)
-    | `Inet_loopback port -> Unix.ADDR_INET (Unix.inet_addr_loopback, port)
-    | `Inet_str str port -> Unix.ADDR_INET (Unix.inet_addr_of_string str, port)
-    | `Inet_addr a p -> Unix.ADDR_INET (a, p)
-    ]
-  in
-    run_addr a userfunc
-;
-
-
-end;

amall_http_service.ml

-(* Services to process http requests to specific pages
-   from Amall_http_server. *)
-
-open Am_All;
-open Amall_types;
-open Printf;
-
-open Cadastr
-;
-
-open Amall_http_server
-;
-
-
-module Service
-  (IO : IO_Type)
-  (I : It_type.IT with
-         type It_IO.m 'a = IO.m 'a
-     and type It_IO.input_channel = IO.input_channel
-  )
- :
-  sig
-
-    type seg = string;
-
-    (* 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
-       fragment components 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 a service on path [""].
-     *)
-
-    type segpath = list seg;
-
-    (* Service receives path components relative to "mount point".
-       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/         [""]
-       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
-    ;
-
-    (* Abstract type.  Will be used to control listening and
-       accepting connections. *)
-
-    type listener
-    ;
-
-    type 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 a destination mount point in the specified segpath
-       below the source mount point. *)
-    value mount_rel : mount_point -> segpath -> mount_point
-    ;
-
-    value mount : endpoint -> http_service_func -> unit
-    ;
-
-(*
-  todo:
-    value umount : endpoint -> unit
-    ;
-*)
-
-  end
- =
-  struct
-
-    open Uri_type;
-    open Amall_http;
-
-    module HS = Http_server(IO)(I);
-
-    type http_server_func = HS.http_server_func
-    ;
-
-    type seg = string
-    ;
-
-    type segpath = list string
-    ;
-
-    type http_service_func =
-      segpath -> http_server_func
-    ;
-
-
-    value default_fallback _segpath rq =
-      (* todo: escape chars for html *)
-      let uri = rq.rq_uri in
-      let au_opt = uri.authority in
-      let (host, port_opt) =
-        match au_opt with
-        [ None -> ("", "")
-        | Some au ->
-            ( au.host
-            , match au.port with
-              [ None -> "" | Some x -> sprintf ":%i" x
-              ]
-            )
-        ] in
-      let txt = sprintf "Can't find path \"%s\" on server \"%s%s\". \
-                         URI dump follows:<br/>%s"
-        uri.path host port_opt
-        (Uri.dump_uri uri)
-      in
-      I.return
-        { rs_status_code = 404
-        ; rs_reason_phrase = "Not found"
-        ; rs_headers = { rs_all = [] }
-        ; rs_body = Body_string
-           ("<html><body><p>" ^ txt ^ "</p></body></html>\n")
-        }
-    ;
-
-    value host_fallback = default_fallback
-    ;
-
-    type disp_level =
-      { seg_map : seg_map
-      ; fallback : mutable http_service_func
-      }
-    and disp_handler =
-      [ Level of disp_level
-      | Service of http_service_func
-      ]
-    and seg_map = Timp.map_rw seg disp_handler
-    ;
-
-    type listener =
-      { io_server : IO.server
-      ; root_disp_level : disp_level
-          (* contains just '"" => root' binding when there exists
-             at least one service, empty otherwise; and
-             fallback with error "no such proto://host:port".
-           *)
-      }
-    ;
-
-    type mount_point = 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];
-(*
-*)
-
-
-    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 rec try_find_handler disp_level segpath
-     : [= `Ok of (segpath * http_service_func)
-       |  `Segpath_finished of disp_level
-       |  `Seg_not_found of (seg * segpath * disp_level)
-       ]
-     =
-      match segpath with
-      [ [] -> `Segpath_finished disp_level
-      | [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)
-          | Some (Level disp_level) -> try_find_handler disp_level segs
-          | Some (Service f) -> `Ok (segs, f)
-          ]
-      ]
-    ;
-
-
-    value find_handler disp_level segpath : (segpath * http_service_func) =
-      match try_find_handler disp_level segpath with
-      [ `Ok ((_p, _f) as pf) -> pf
-      | `Segpath_finished dl -> ([], dl.fallback)
-      | `Seg_not_found (seg, segs, disp_level) ->
-           ([seg :: segs], disp_level.fallback)
-      ]
-    ;
-
-
-    exception Already_handled
-    ;
-
-
-    value go_or_create_smallstep ~fb ~disp ~seg : disp_level =
-      match disp.seg_map#get_opt seg with
-      [ None ->
-          let lev =
-            { seg_map = new c_seg_map
-            ; fallback = fb
-            } in
-          ( disp.seg_map#add seg (Level lev)
-          ; lev
-          )
-      | Some (Level lev) -> lev
-      | Some (Service _f) -> raise Already_handled
-      ]
-    ;
-
-
-    value rec go_or_create_bigstep ~fb ~disp ~segs : disp_level =
-      match segs with
-      [ [] -> disp
-      | [seg :: segs] ->
-          go_or_create_bigstep
-            ~fb
-            ~disp:(go_or_create_smallstep ~fb ~disp ~seg)
-            ~segs
-      ]
-    ;
-
-
-    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
-        | `Fallback s -> s
-        ]
-      in
-      let disp_level = go_or_create_bigstep
-        ~fb:default_fallback
-        ~disp:mount_point
-        ~segs:segpath
-      in
-      match how_where with
-      [ `Service (_, p) ->
-          match disp_level.seg_map#get_opt p with
-          [ None ->
-              disp_level.seg_map#add p (Service what)
-          | Some _ -> raise Already_handled
-          ]
-      | `Fallback _ -> disp_level.fallback := what
-      ]
-    ;
-
-
-(*
-    value remove_handler ~endpoint =
-      (ignore endpoint; raise Exit)
-    ;
-*)
-
-    (**********)
-
-    value mount endpoint f =
-      install_handler ~endpoint ~what:f
-    ;
-
-(*
-    value umount endpoint =
-      remove_handler ~endpoint
-    ;
-*)
-
-    (**********)
-
-
-    value (server_func : disp_level -> http_server_func)
-      root_disp_level
-    = fun rq ->
-      let uri = rq.Amall_http.rq_uri in
-      let segpath = segpath_of_uri uri in
-      let () = dbg "S.server_func: segpath=[%s]"
-        (String.concat ";" & List.map (sprintf "%S") segpath) in
-      let (segpath, func) = find_handler root_disp_level segpath in
-      ((func segpath) : http_server_func) rq
-    ;
-
-    value run_listener addr =
-      let root_seg_map = new c_seg_map in
-      let root_disp_level =
-        { seg_map = root_seg_map
-        ; fallback = host_fallback  (* "ни один хост не сконфигурен" *)
-        } in
-      let server_func = server_func root_disp_level in
-      let io_server = HS.run addr server_func in
-      let listener =
-        { io_server = io_server
-        ; root_disp_level = root_disp_level
-        }
-      in (listener, root_disp_level)
-    ;
-
-  end
-;

amall_types.ml

-type res 'a = [= `Ok of 'a | `Error of exn ]
-;
-
-module type IO_Type =
-  sig
-    type m +'a;
-    value return : 'a -> m 'a;
-    value bind : ('a -> m 'b) -> m 'a -> m 'b;
-    value bind_rev : m 'a -> ('a -> m 'b) -> m 'b;
-
-    value error : exn -> m 'a;
-    value catch : (unit -> m 'a) -> (exn -> m 'a) -> m 'a;
-
-    type output_channel;
-    value stdout : output_channel;
-    value write : output_channel -> string -> m unit;
-
-    type input_channel;
-    value open_in : string -> m input_channel;
-    value close_in : input_channel -> m unit;  (* Lwt_io.close inch *)
-    value read_into : input_channel -> string -> int -> int -> m int;
-       (* in lwt: read_into ic buffer offset length *)
-
-    value runIO : m 'a -> res 'a;
-
-
-    value flush : output_channel -> m unit;
-
-    value printf : format4 'a unit string (m unit) -> 'a;
-
-    value close_out : output_channel -> m unit;
-
-
-    value run_and_ignore_result : m unit -> unit;
-
-
-    type server;
-
-    value establish_server :
-      ?buffer_size:int ->
-      ?backlog:int ->
-      Unix.sockaddr ->
-      ((input_channel * output_channel) -> unit) ->
-      server
-    ;
-
-    value shutdown_server : server -> unit
-    ;
-
-  end
-;
-
-
-(*
-value stdin = Lwt_io.stdin;
-
-value printf fmt = Printf.ksprintf (write stdout) fmt;
-
-value flush = Lwt_io.flush;
-
-value close_out = Lwt_io.close;
-
-*)
-
-(*
-module Test = (IO_Lwt : IO_Type)
-;
-*)
-
-
-module type FUNCTOR
- =
-  sig
-    type t 'a;
-    value fmap : ('a -> 'b) -> t 'a -> t 'b;
-  end
-;

cadastr.ml

-value eq_of_cmp cmp = fun a b -> (0 = cmp a b)
-;
-
-(* non-specific types *)
-
-module T
- =
-  struct
-
-    class type map_ro ['k, 'v] =
-      object
-        method get_exn : 'k -> 'v;
-        method get_opt : 'k -> option 'v;
-        method mem : 'k -> bool;
-      end
-    ;
-
-  end
-;
-
-(* types of functional/pure structures *)
-
-module Tfun
- =
-  struct
-
-    class type map_rw ['k, 'v] =
-      object
-        inherit T.map_ro ['k, 'v];
-(*
-       get_exn : 'k -> 'v
-      ; get_opt : 'k -> option 'v
-      ; 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
-;
-
-
-(* types of imperative/mutable structures *)
-
-module Timp
- =
-  struct
-
-    class type 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
-;
-
-(* implementations *)
-
-module Cd_list
- =
-  struct
-
-    value map_rw_assoc_stack_limit = 1000
-    ;
-
-    value list_assoc_index_opt ~keq lst k =
-      loop 0 lst
-      where rec loop i lst =
-        match lst with
-        [ [] -> None
-        | [(hk, _hv) :: tl] ->
-            if keq k hk
-            then Some i
-            else loop (i + 1) tl
-        ]
-    ;
-
-    value list_remove_nth_fast lst i =
-      if i < 0
-      then invalid_arg "list_remove_nth_fast: i<0"
-      else
-        inner lst i
-        where rec inner lst i =
-          match (i, lst) with
-          [ (_, []) -> invalid_arg "list_remove_nth_fast: i>=len"
-          | (0, [_h :: t]) -> t
-          | (i, [h :: t]) -> [h :: inner t (i - 1)]
-          ]
-    ;
-
-    value list_remove_nth_tailrec lst i =
-      let rec inner ~rev_acc lst i =
-        match (i, lst) with
-        [ (_, []) -> invalid_arg "list_remove_nth_tailrec: i>=len"
-        | (0, [_h :: t]) -> (rev_acc, t)
-        | (i, [h :: t]) -> inner ~rev_acc:[h :: rev_acc] t (i - 1)
-        ]
-      in
-      if i < 0
-      then invalid_arg "list_remove_nth_tailrec: i<0"
-      else
-        let (rev_heads, tail) = inner ~rev_acc:[] lst i in
-        List.rev_append rev_heads tail
-    ;
-
-    value get_exn ~keq cur k =
-      let rec loop lst =
-        match lst with
-        [ [] -> raise Not_found
-        | [(hk, hv) :: tl] ->
-            if keq k hk
-            then hv
-            else loop tl
-        ]
-      in
-        loop cur
-    ;
-
-    value get_opt ~keq cur k =
-      try Some (get_exn ~keq cur k)
-      with [Not_found -> None]
-    ;
-
-    value mem ~keq cur k =
-          let rec loop lst =
-            match lst with
-            [ [] -> False
-            | [(hk, _hv) :: tl] ->
-                if keq k hk then True else loop tl
-            ]
-          in
-            loop cur
-    ;
-
-    value map_rw_assoc_add cur k v =
-      [(k, v) :: cur]
-    ;
-
-    value map_rw_assoc_remove ~keq cur k =
-      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
-      ]
-    ;
-
-  end
-;
-
-
-(* functional/immutable structures (classes/objects, what is exported) *)
-
-module Sfun
- =
-  struct
-
-    class map_ro_assoc ['k, 'v] ~keq cur : T.map_ro ['k, 'v]
-    =
-      object (_self)
-        method get_exn k = Cd_list.get_exn ~keq cur k;
-        method get_opt k = Cd_list.get_opt ~keq cur k;
-        method mem k = Cd_list.mem ~keq cur k;
-      end
-    ;
-
-    class map_rw_assoc ['k, 'v] ~keq cur : Tfun.map_rw ['k, 'v]
-    =
-      object (self)
-        inherit map_ro_assoc ['k, 'v] ~keq cur;
-        method add k v = new map_rw_assoc ~keq
-          (Cd_list.map_rw_assoc_add cur k v);
-        method remove k =
-          let new_cur = Cd_list.map_rw_assoc_remove ~keq cur k 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 = Cd_list.map_rw_assoc_remove ~keq cur k in
-          let added = Cd_list.map_rw_assoc_add removed k v in
-          new map_rw_assoc ~keq added
-        ;
-      end
-    ;
-
-
-    module Tree
-      (Key : Map.OrderedType)
-     :
-      sig
-        class map_ro_tree ['v] : T.map_ro [Key.t, 'v];
-        class map_rw_tree ['v] : Tfun.map_rw [Key.t, 'v];
-      end
-     =
-      struct
-
-        module M = Map.Make(Key);
-
-        module Cd_tree
-         =
-           struct
-             value get_exn cur k = M.find k cur;
-             value get_opt cur k =
-               try Some (get_exn cur k)
-               with [Not_found -> None];
-             value mem cur k = M.mem k cur;
-             value add cur k v = M.add k v cur;
-             value remove cur k = M.remove k cur;
-           end
-        ;
-
-
-        class map_ro_tree_cur ['v] cur : T.map_ro [Key.t, 'v]
-        =
-          object (_self)
-            method get_exn k = Cd_tree.get_exn cur k;
-            method get_opt k = Cd_tree.get_opt cur k;
-            method mem k = Cd_tree.mem cur k;
-          end
-        ;
-
-        class map_rw_tree_cur ['v] cur : Tfun.map_rw [Key.t, 'v]
-        =
-          object (_self)
-            inherit map_ro_tree_cur ['v] cur;
-            method add k v = new map_rw_tree_cur (Cd_tree.add cur k v);
-            method remove k =
-              new map_rw_tree_cur (Cd_tree.remove cur k)
-            ;
-            method replace k v =
-              let removed = Cd_tree.remove cur k in
-              let added = Cd_tree.add removed k v in
-              new map_rw_tree_cur added
-            ;
-          end
-        ;
-
-        class map_ro_tree ['v]
-        =
-          map_ro_tree_cur ['v] M.empty
-        ;
-
-        class map_rw_tree ['v]
-        =
-          map_rw_tree_cur ['v] M.empty
-        ;
-
-      end
-    ;
-
-  end
-;
-
-
-
-(* imperative/mutable structures (classes/objects, what is exported) *)
-
-module Simp
- =
-  struct
-
-    class map_rw_of_Sfun ['k, 'v] (fu : Tfun.map_rw 'k 'v)
-    : Timp.map_rw ['k, 'v]
-    =
-      object (_self)
-
-        value mutable cur = fu;
-
-        method get_exn k = cur#get_exn k;
-        method get_opt k = cur#get_opt k;
-        method mem k = cur#mem k;
-
-        method add k v = cur := cur#add k v;
-
-        method remove k =
-          let new_cur = cur#remove k in
-          if new_cur == cur
-          then ()
-          else cur := new_cur
-        ;
-
-        method replace (k : 'k) (v : 'v) =
-          cur := cur#replace k v
-        ;
-
-      end
-    ;
-
-    class map_rw_assoc ['k, 'v] ~keq
-    =
-      map_rw_of_Sfun ['k, 'v] (new Sfun.map_rw_assoc ~keq [])
-    ;
-
-
-    module Tree
-      (T : Map.OrderedType)
-     :
-      sig
-        class map_rw_tree ['v] : Timp.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
-;
+#!/bin/sh
+
+# OASIS_START
+# DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7)
+set -e
+
+FST=true
+for i in "$@"; do 
+  if $FST; then
+    set --
+    FST=false
+  fi
+
+  case $i in
+    --*=*)
+      ARG=${i%%=*}
+      VAL=${i##*=}
+      set -- "$@" "$ARG" "$VAL"
+      ;;
+    *)
+      set -- "$@" "$i"
+      ;;
+  esac
+done
+
+ocaml setup.ml -configure "$@"
+# OASIS_STOP

dbi.ml

-module Dbi
- =
-  struct
-
-    open Am_Ops
-    ;
-
-    type sql_t =
-      [= `Null
-      |  `String of string
-      |  `Binary of string
-      ]
-    ;
-
-    type dbd_error = exn
-    ;
-
-    type dbi_error = (dbd_error * (dbd_error -> string))
-    ;
-
-    exception Edbi of dbi_error
-    ;
-
-    exception EGeneric of string
-    ;
-
-    exception Ecolumn of string
-    ;
-
-    exception Econnection_closed of string
-    ;
-
-    value (string_of_dbi_error : dbi_error -> string) (dbd_error, to_string) =
-      to_string dbd_error
-    ;
-
-    exception End_of_result
-    ;
-
-    open Printf
-    ;
-
-    value string_of_exn = fun
-      [ Edbi e -> sprintf "database error: %s" &
-          string_of_dbi_error e
-      | e -> sprintf "non-database error: %s" &
-          Printexc.to_string e
-      ]
-    ;
-
-    value (error : dbi_error -> 'a) e =
-      raise & Edbi e
-    ;
-
-    value error_gen msg =
-      error &
-      ( EGeneric msg
-      , fun [ EGeneric msg -> msg | _ -> assert False ]
-      )
-    ;
-
-    value error_eor () =
-      error &
-      ( End_of_result
-      , fun [ End_of_result -> "end of result set" | _ -> assert False ]
-      )
-    ;
-
-    value error_column msg =
-      error &
-      ( Ecolumn msg