-
Notifications
You must be signed in to change notification settings - Fork 4
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
3 changed files
with
140 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,3 @@ | ||
(executables | ||
(names wscat echo_server) | ||
(libraries websocketaf websocketaf-lwt lwt lwt.unix)) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,71 @@ | ||
let connection_handler : Unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t = | ||
let module Body = Httpaf.Body in | ||
let module Headers = Httpaf.Headers in | ||
let module Reqd = Httpaf.Reqd in | ||
let module Response = Httpaf.Response in | ||
let module Status = Httpaf.Status in | ||
|
||
let websocket_handler _ wsd = | ||
let frame ~opcode ~is_fin:_ bs ~off ~len = | ||
match opcode with | ||
| `Continuation | ||
| `Text | ||
| `Binary -> | ||
Websocketaf.Wsd.schedule wsd bs ~kind:`Text ~off ~len | ||
| `Connection_close -> | ||
Websocketaf.Wsd.close wsd | ||
| `Ping -> | ||
Websocketaf.Wsd.send_ping wsd | ||
| `Pong | ||
| `Other _ -> | ||
() | ||
in | ||
let eof () = () | ||
in | ||
{ Websocketaf.Server_connection.frame | ||
; eof | ||
} | ||
in | ||
|
||
let error_handler _client_address ?request:_ error start_response = | ||
let response_body = start_response Headers.empty in | ||
|
||
begin match error with | ||
| `Exn exn -> | ||
Body.write_string response_body (Printexc.to_string exn); | ||
Body.write_string response_body "\n"; | ||
|
||
| #Status.standard as error -> | ||
Body.write_string response_body (Status.default_reason_phrase error) | ||
end; | ||
in | ||
|
||
Websocketaf_lwt.Server.create_connection_handler | ||
?config:None | ||
~websocket_handler | ||
~error_handler | ||
|
||
|
||
|
||
let () = | ||
let open Lwt.Infix in | ||
|
||
let port = ref 8080 in | ||
Arg.parse | ||
["-p", Arg.Set_int port, " Listening port number (8080 by default)"] | ||
ignore | ||
"Echoes websocket messages. Runs forever."; | ||
|
||
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, !port)) in | ||
|
||
Lwt.async begin fun () -> | ||
Lwt_io.establish_server_with_client_socket | ||
listen_address connection_handler | ||
>>= fun _server -> | ||
Printf.printf "Listening on port %i and echoing websocket messages.\n" !port; | ||
flush stdout; | ||
Lwt.return_unit | ||
end; | ||
|
||
let forever, _ = Lwt.wait () in | ||
Lwt_main.run forever |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,66 @@ | ||
open Lwt.Infix | ||
|
||
let websocket_handler wsd = | ||
let rec input_loop wsd () = | ||
Lwt_io.(read_line stdin) >>= fun line -> | ||
let payload = Bytes.of_string line in | ||
Websocketaf.Wsd.send_bytes wsd ~kind:`Text payload ~off:0 ~len:(Bytes.length payload); | ||
input_loop wsd () | ||
in | ||
Lwt.async (input_loop wsd); | ||
let frame ~opcode:_ ~is_fin:_ bs ~off ~len = | ||
let payload = Bytes.create len in | ||
Lwt_bytes.blit_to_bytes | ||
bs off | ||
payload 0 | ||
len; | ||
Printf.printf "%s\n" (Bytes.unsafe_to_string payload); | ||
flush stdout | ||
in | ||
let eof () = | ||
Printf.printf "[EOF]\n" | ||
in | ||
{ Websocketaf.Client_connection.frame | ||
; eof | ||
} | ||
|
||
let error_handler = function | ||
| `Handshake_failure (rsp, _body) -> | ||
Format.printf "Handshake failure: %a" Httpaf.Response.pp_hum rsp | ||
| _ -> assert false | ||
|
||
let () = | ||
let host = ref None in | ||
let port = ref 80 in | ||
|
||
Arg.parse | ||
["-p", Set_int port, " Port number (80 by default)"] | ||
(fun host_argument -> host := Some host_argument) | ||
"wscat.exe [-p N] HOST"; | ||
|
||
let host = | ||
match !host with | ||
| None -> failwith "No hostname provided" | ||
| Some host -> host | ||
in | ||
|
||
Lwt_main.run begin | ||
Lwt_unix.getaddrinfo host (string_of_int !port) [Unix.(AI_FAMILY PF_INET)] | ||
>>= fun addresses -> | ||
|
||
let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in | ||
Lwt_unix.connect socket (List.hd addresses).Unix.ai_addr | ||
>>= fun () -> | ||
|
||
let nonce = "0123456789ABCDEF" in | ||
let resource = "/" in | ||
let port = !port in | ||
Websocketaf_lwt.Client.connect | ||
socket | ||
~nonce | ||
~host | ||
~port | ||
~resource | ||
~error_handler | ||
~websocket_handler | ||
end |