Anonymous avatar Anonymous committed cb9cde4

Amall_http.rs_body: + File_contents

Comments (0)

Files changed (3)

src/amall_http.ml

   }
 ;
 
+type file_size = int64
+;
+
 type rs_body =
   [ No_body
   | Body_string of string
+  | File_contents of string and file_size
   ]
 ;
 
   || h.transfer_length <> None
 ;
 
+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 response_headers resp lst =
   let nocase = String.eq_nocase_latin1 in
   let headers_with_lengths =
-    match resp.rs_body with
-    [ No_body ->
-        List.Assoc.remove ~keq:nocase "Content-length" lst
-    | Body_string s ->
+    let set_cl len_str =
         List.Assoc.replace
           ~keq:nocase
           "Content-length"
-          (s |> String.length |> string_of_int)
+          len_str
           lst
+    in
+    match resp.rs_body with
+    [ No_body ->
+        IO.return & List.Assoc.remove ~keq:nocase "Content-length" lst
+    | Body_string s ->
+        s |> String.length |> string_of_int |> set_cl |> IO.return
+    | File_contents _fn sz ->
+        sz |> Int64.to_string |> set_cl |> IO.return
     ]
   in
     headers_with_lengths
 ;
 
 
-value string_of_response_headers rs =
-  let err msg = invalid_arg "http response: %s" msg in
+value string_of_response_headers rs : IO.m string =
+  let err msg = IO.error
+    (Invalid_argument (sprintf "http response: %s" 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
   if String.contains reas '\n' || String.contains reas '\r'
   then err "reason phrase must not contain CR or LF"
   else
+  response_headers rs rs.rs_headers.rs_all >>% fun processed_headers ->
+  IO.return &
   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
+     processed_headers
     )
 ;
 
 
-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 ->
 (***************************************************************)
 
 
+value output_file_buffer_size = ref 16384
+;
+
+value output_body_file outch fn sz =
+  IO.open_in fn >>% fun inch ->
+  let finally () = IO.close_in inch in
+  IO.catch
+    (fun () ->
+       let bufsz = Int64.to_int &
+         min (Int64.of_int output_file_buffer_size.val) sz in
+       let buf = String.make bufsz '\x00' in
+       read_loop sz
+       where rec read_loop left =
+         if left = 0L
+         then
+           IO.return ()
+         else
+           let to_read = Int64.to_int & min (Int64.of_int bufsz) left in
+           IO.read_into inch buf 0 to_read >>% fun have_read ->
+           if have_read = 0
+           then IO.error (Failure "file is shorter than expected")
+           else
+             ( write_loop 0 have_read >>% fun () ->
+               read_loop (Int64.sub left (Int64.of_int have_read))
+             )
+             where rec write_loop ofs to_write =
+               let () = assert (to_write >= 0) in
+               if to_write = 0
+               then
+                 IO.return ()
+               else
+                 IO.write_from outch buf ofs to_write >>% fun written ->
+                 write_loop (ofs + written) (to_write - written)
+    )
+    (fun e ->
+       finally () >>% fun () ->
+       IO.error e
+    )
+;
+
+
 value output_body outch rs_body =
   match rs_body with
   [ No_body -> IO.return ()
   | Body_string s -> IO.write outch s
+  | File_contents fn sz ->
+      output_body_file outch fn sz
   ]
 ;
 
 
-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
+value rec output_response ~is_head outch rs : IO.m unit =
+  IO.catch
+    (fun () ->
+      string_of_response_headers rs >>% fun hstr -> IO.return & `Ok hstr
+    )
+    (fun e ->
+        let msg = Printexc.to_string e in
+        IO.return & `Error
+          { rs_status_code = 500
+          ; rs_reason_phrase = "Internal server error"
+          ; rs_headers = { rs_all = [] }
+          ; rs_body = Body_string msg
+          }
+    )
+  >>% fun res_hstr ->
+  match res_hstr with
+  [ `Error rs -> output_response ~is_head outch rs
+  | `Ok hstr ->
+      IO.write outch hstr >>% fun () ->
+      (if is_head
+       then IO.return ()
+       else output_body outch rs.rs_body
+       ) >>% fun () ->
+      IO.flush outch
+  ]
 ;
 
 

src/amall_types.ml

     type output_channel;
     value stdout : output_channel;
     value write : output_channel -> string -> m unit;
+    value write_from : output_channel -> string -> int -> int -> m int;
 
     type input_channel;
     value open_in : string -> m input_channel;
         type output_channel;
         value stdout : output_channel;
         value write : output_channel -> string -> m unit;
+(*
+        value write_from : output_channel -> string -> int -> int -> m int;
+*)
         type input_channel;
         value open_in : string -> m input_channel;
         value close_in : input_channel -> m unit;
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.