(* $Id: nethttpd_util.ml 1410 2010-02-14 19:44:28Z gerd $ *) open Nethttpd_types open Printf let std_error_response p = let b = Buffer.create 500 in bprintf b "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.0//EN\" \ \"http://www.w3.org/TR/REC-html40/strict.dtd\">\n"; bprintf b "<html xmlns=\"http://www.w3.org/1999/xhtml\" \ xml:lang=\"en\" lang=\"en\">\010\ <head>\010\ <meta name=\"generator\" \ content=\"OCamlNet \ (http://projects.camlcity.org/projects/ocamlnet)\">\010\ <style>\010\ p.msg { color: black; background-color: #cccccc; padding: 1ex; }\010\ h2 { font-size: large; }\010\ </style>\010\ </head>\010\ <body>\n"; let code = p # response_status_code in let text = try Nethttp.string_of_http_status(Nethttp.http_status_of_int code) with Not_found -> "Non-standard code" in bprintf b "<h1>Error %i - %s</h1>\n" code text; bprintf b "The server could not process your request.\n"; bprintf b "For additional information consult the error log of the\n"; bprintf b "server.\n"; bprintf b "<hr>\n"; bprintf b "%s - Ocamlnet Nethttpd server\n" (Netdate.format "%c" (Netdate.create ~zone:Netdate.localzone (Unix.time()))); bprintf b "</body>\n"; bprintf b "</html>\n"; Buffer.contents b let std_error_log_string p msg = let peeraddr_opt = try Some(p # remote_socket_addr) with Not_found -> None in Printf.sprintf "[%s] [%s] %s" ( match peeraddr_opt with | Some addr -> Netsys.string_of_sockaddr addr | None -> "-" ) ( try let m = p # request_method in let u = p # request_uri in m ^ " " ^ u with Not_found -> "-" ) msg let std_access_log_string p = let code = p # response_status_code in let peerstr = try Netsys.string_of_sockaddr p#remote_socket_addr with Not_found -> "-" in let meth = try p#request_method with Not_found -> "-" in let uri = try p#request_uri with Not_found -> "-" in let user = try List.assoc "REMOTE_USER" p#cgi_properties with Not_found -> "-" in let respsize = p#output_body_size in let referrer = try p#input_header#field "Referer" with Not_found -> "-" in let user_agent = try p#input_header#field "User-agent" with Not_found -> "-" in Printf.sprintf "%s %s %s \"%s\" %d %Ld \"%s\" \"%s\"" peerstr user meth (String.escaped uri) code respsize (String.escaped referrer) (String.escaped user_agent) let std_debug_access_log_string p = let b = Buffer.create 500 in let b_ch = new Netchannels.output_buffer b in Printf.bprintf b "%s\n" (std_access_log_string p); Printf.bprintf b "Request header:\n"; ( try Mimestring.write_header ~soft_eol:"\n" ~eol:"\n" b_ch p#input_header#fields with Not_found -> Printf.bprintf b "(missing)\n"; ); ( try Printf.bprintf b "Request body size: %Ld\n" p#input_body_size with Not_found -> Printf.bprintf b "Request body size: (missing)\n" ); Printf.bprintf b "Request body rejected: %b\n\n" p#request_body_rejected; Printf.bprintf b "CGI properties:\n"; ( try Mimestring.write_header ~soft_eol:"\n" ~eol:"\n" b_ch p#cgi_properties with Not_found -> Printf.bprintf b "(missing)\n"; ); Printf.bprintf b "Response header (code %d):\n" p#response_status_code; Mimestring.write_header ~soft_eol:"\n" ~eol:"\n" b_ch p#output_header#fields; Printf.bprintf b "Response body size: %Ld\n" p#output_body_size; Buffer.contents b