(* A test daemon, only using the kernel *) open Printf let generate resp = printf "Generating response\n"; flush stdout; let h = new Netmime.basic_mime_header [ "Content-type", "text/html" ] in let data = "<html>\n" ^ " <head><title>Easy Daemon</title></head>\n" ^ " <body>\n" ^ " <a href='foo'>GET something</a><br>\n" ^ " <form method=POST encoding='form-data'>\n" ^ " <input type=hidden name=sample value='sample'>\n" ^ " <input type=submit value='POST something'>\n" ^ " </form>\n" ^ " </body>\n" ^ "</html>" in resp # send (`Resp_status_line (200, "OK")); resp # send (`Resp_header h); resp # send (`Resp_body (data, 0, String.length data)); resp # send `Resp_end ;; let generate_error resp = printf "Generating error response\n"; flush stdout; let h = new Netmime.basic_mime_header [ "Content-type", "text/html" ] in let data = "<html>\n" ^ " <head><title>Bad Request from Easy Daemon</title></head>\n" ^ " <body>\n" ^ " Bad Request!\n" ^ " </body>\n" ^ "</html>" in resp # send (`Resp_status_line (400, "Bad Request")); resp # send (`Resp_header h); resp # send (`Resp_body (data, 0, String.length data)); resp # send `Resp_end; ;; let serve fd = let config = Nethttpd_kernel.default_http_protocol_config in let proto = new Nethttpd_kernel.http_protocol config fd in let rec next_token () = if proto # recv_queue_len = 0 then ( proto # cycle ~block:(-1.0) (); (* block forever *) next_token() ) else proto # receive() in let cur_tok = ref ( next_token() ) in let cur_resp = ref None in while !cur_tok <> `Eof do ( match !cur_tok with | `Req_header (((meth, uri), v), hdr, resp) -> printf "Request: method = %s, uri = %s\n" meth uri; flush stdout; cur_resp := Some resp | `Req_expect_100_continue -> ( match !cur_resp with | Some resp -> resp # send Nethttpd_kernel.resp_100_continue | None -> assert false ) | `Req_end -> printf "Pipeline length: %d\n" proto#pipeline_len; ( match !cur_resp with | Some resp -> generate resp | None -> assert false ); cur_resp := None | `Fatal_error e -> let name = Nethttpd_kernel.string_of_fatal_error e in printf "Fatal_error: %s\n" name; flush stdout; | `Bad_request_error (e, resp) -> let name = Nethttpd_kernel.string_of_bad_request_error e in printf "Bad_request_error: %s\n" name; flush stdout; generate_error resp | `Timeout -> printf "Timeout\n"; flush stdout; | _ -> () ); cur_tok := next_token() done; (* Send the remaining responses:*) while proto # resp_queue_len > 0 do proto # cycle ~block:(-1.0) (); done; proto # shutdown(); if proto # need_linger then ( printf "Lingering close!\n"; flush stdout; let lc = new Nethttpd_kernel.lingering_close fd in while lc # lingering do lc # cycle ~block:true () done ) else Unix.close fd ;; let start() = let master_sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in Unix.setsockopt master_sock Unix.SO_REUSEADDR true; Unix.bind master_sock (Unix.ADDR_INET(Unix.inet_addr_any, 8765)); Unix.listen master_sock 100; printf "Listening on port 8765\n"; flush stdout; while true do try let conn_sock, _ = Unix.accept master_sock in Unix.set_nonblock conn_sock; serve conn_sock with Unix.Unix_error(Unix.EINTR,_,_) -> () (* ignore *) done ;; let conf_debug() = (* Set the environment variable DEBUG to either: - a list of Netlog module names - the keyword "ALL" to output all messages - the keyword "LIST" to output a list of modules By setting DEBUG_WIN32 additional debugging for Win32 is enabled. *) let debug = try Sys.getenv "DEBUG" with Not_found -> "" in if debug = "ALL" then Netlog.Debug.enable_all() else if debug = "LIST" then ( List.iter print_endline (Netlog.Debug.names()); exit 0 ) else ( let l = Netstring_str.split (Netstring_str.regexp "[ \t\r\n]+") debug in List.iter (fun m -> Netlog.Debug.enable_module m) l ); if (try ignore(Sys.getenv "DEBUG_WIN32"); true with Not_found -> false) then Netsys_win32.Debug.debug_c_wrapper true ;; Netsys_signal.init(); conf_debug(); start();;