Commits

Anonymous committed 0bd438d

Amall_http_server works

Comments (0)

Files changed (6)

 	  _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/uri.cmi _build/uri_type.cmi _build/amall_http_server.cmi
 
 deinstall :
 	ocamlfind remove $(PKG)
-<*.ml> | <*.mli> : camlp4r, warn_A
+<*.ml> | <*.mli> : camlp4r, warn_A, pkg_unix
 <am_Ops.*> | <filename_new.*> | <urilex.ml> : -camlp4r, camlp4o
 <dbi_pg.*> : pkg_postgresql, pkg_threads
-<amall_http.*> : pkg_monad_io, pkg_iteratees
+<amall_http.*> | <amall_http_server.*> : pkg_monad_io, pkg_iteratees
 SortedArraySet
 With_comb
 Amall_http
+Amall_http_server
 Amall_types
 Uri_type
 Uri
-module Amall_http (IO : Amall_types.IO_Type)
-=
-struct
+open Am_All;
 
 value max_uri_len = 4096;
 value max_header_len = 4096;
 value max_headers_size = 10240;
 
-
-open Am_All;
-
-module I = Iteratees.Make(IO);
-
-value ( >>= ) = I.( >>= )
-  and ( >>% ) = I.( >>% )
-;
-
 type request_method = [= `GET | `POST | `HEAD ]
 ;
 
 ;
 
 
-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 is_spaces = fun
 
 (************************************************************)
 
+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#all
+    )
+;
+
+(************************************************************)
+
+
+
+module Make (IO : Amall_types.IO_Type)
+=
+struct
+
+module I = Iteratees.Make(IO);
+
+value ( >>= ) = I.( >>= )
+  and ( >>% ) = I.( >>% )
+;
+
+
+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 request_has_message_body rq =
-  let h = rq.rq_headers in
-     h#transfer_encoding <> []
-  || h#content_length <> None
-  || h#transfer_length <> None
-;
-
 (************************************************************)
 
 value (it_http :
 (***************************************************************)
 
 
-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 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_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#all
-    )
-;
-
-
 value output_body outch rs_body =
   match rs_body with
   [ No_body -> IO.return ()

amall_http_server.ml

+open Amall_types;
+open Am_Ops;
+open Printf;
+open Amall_http;
+
+module Http_server (IO : IO_Type)
+=
+struct
+
+module H = Amall_http.Make(IO);
+open H;
+
+
+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
+  [ Iteratees.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
+  [ Iteratees.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
+  | Iteratees.Chunk c ->
+      IO.printf "dump_chars_chunks: %s: Chunk: %S\n"
+        title (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, uri: %s.\n\
+            headers:\n%s\n===\n%!"
+       (Uri.dump_uri request.rq_uri)
+       (String.concat "\n" & List.map (fun (k,v) -> sprintf "%S = %S" k v)
+         request.rq_headers#all
+       )
+  >>= fun () ->
+(*
+  dump_chars_chunks "header"
+*)
+  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;
+
+(**********************************************************)
+
+type userfunc = request -> I.iteratee char response;
+
+
+(* гарантируется, что всё мероприятие начнётся с вызова it_proc_req,
+   затем будет дано хоть что-то итерату, возвращённому функцией
+   (возможно ошибка или просто конец потока; в случае наличия тела
+   запроса будет дано тело).
+ *)
+
+value io_http_server_func (it_proc_req : userfunc) 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" &
+              Printexc.to_string e
+          ; IO.return ()
+          )
+        )
+     )
+;
+
+
+value run listen_addr userfunc =
+  IO.establish_server listen_addr (http_server_func userfunc)
+;
+
+
+end;
 
     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 :
+      Unix.sockaddr ->
+      ((input_channel * output_channel) -> unit) ->
+      server
+    ;
+
+    value shutdown_server : server -> unit
+    ;
+
   end
 ;