open Effect open Effect.Deep type _ Effect.t += Recv : Unix.file_descr -> string Effect.t let parse_request s = let tokens = String.split_on_char ' ' s in match tokens with | _::url::_ -> (try let urltokens = String.split_on_char '/' url in Some (List.nth urltokens (List.length urltokens - 1)) with Failure _ -> None ) | _ -> None let format_date tm = let open Unix in Printf.sprintf "%s, %d %s %d %02d:%02d:%02d" (match tm.tm_wday with | 0 -> "Sun" | 1 -> "Mon" | 2 -> "Tue" | 3 -> "Wed" | 4 -> "Thur" | 5 -> "Fri" | 6 -> "Sat" | _ -> raise (Invalid_argument "format_date") ) tm.tm_mday (match tm.tm_mon with | 0 -> "January" | 1 -> "February" | 2 -> "March" | 3 -> "April" | 4 -> "May" | 5 -> "June" | 6 -> "July" | 7 -> "August" | 8 -> "September" | 9 -> "October" | 10 -> "November" | 11 -> "December" | _ -> raise (Invalid_argument "format_date") ) (tm.tm_year + 1900) tm.tm_hour tm.tm_min tm.tm_sec let build_success s = "HTTP/1.0 200 OK\r\n" ^ "Date: " ^ (format_date (Unix.gmtime (Unix.time ()))) ^ "\r\n" ^ "Content-Type: text/html\r\n" ^ "Content-Length: " ^ (string_of_int (String.length s)) ^ "\r\n" ^ "Connection: Keep-Alive\r\n" ^ "\r\n" ^ s let build_400 () = "HTTP/1.0 400 Bad Request" let build_404 () = "HTTP/1.0 404 Not Found" let make_page n = build_success (Printf.sprintf "Hi! You've visited %d times" n ) let open_conn _ = let open Unix in let sock = socket PF_INET SOCK_STREAM 0 in setsockopt sock SO_REUSEADDR true; bind sock (ADDR_INET (inet_addr_loopback, 8000)); listen sock 1; set_nonblock sock; sock let string_of_file f = let chan = open_in f in let rec readloop s = try readloop s ^ (input_line chan) with End_of_file -> s in let s = readloop "" in close_in chan; s let rec handle_conn sock n = let open Unix in let recv sock = perform (Recv sock) in let page = parse_request (recv sock) in let rsp = match page with | Some "stats.html" -> make_page n | Some page -> (try build_success (string_of_file page) with _ -> build_404 () ) | None -> build_400 () in let _ = send sock (Bytes.of_string rsp) 0 (String.length rsp) [] in handle_conn sock (n + 1) let handle_conn sock = handle_conn sock 1 type connection = { sock: Unix.file_descr; buf: Bytes.t; cont: (string, unit) continuation } let conns = ref [] let pop_conn () = match !conns with | [] -> None | h::t -> (conns := t; Some h) let push_conn c = conns := (!conns) @ [c] let rec loop sock = let do_loop () = try let (conn, _) = Unix.accept sock in Unix.set_nonblock conn; handle_conn conn with Unix.Unix_error (EWOULDBLOCK, _, _) | Unix.Unix_error (EAGAIN, _, _) -> (match pop_conn () with | Some c -> (* let _ = Printf.printf "receiving\n%!" in *) (try let size = Unix.recv c.sock c.buf 0 1024 [] in if size > 0 then continue c.cont (Bytes.to_string c.buf) else (push_conn c; loop sock) with Unix.Unix_error _ -> (push_conn c; loop sock) | e -> raise e ) | None -> loop sock ) in match_with do_loop () { retc = (fun _ -> ()); exnc = (fun e -> print_string (Printexc.to_string e)); effc = fun (type a) (e: a Effect.t) -> match e with | Recv conn_sock -> let buf = Bytes.create 1024 in Some (fun (k: (a, unit) continuation) -> push_conn {sock = conn_sock; buf = buf; cont = k}; loop sock ) | _ -> None } ;; let _ = let sock = open_conn () in loop sock