Skip to content

Commit

Permalink
Use Lwt.Syntax.
Browse files Browse the repository at this point in the history
  • Loading branch information
Tim-ats-d committed Nov 11, 2022
1 parent 4404f7d commit 2598477
Show file tree
Hide file tree
Showing 2 changed files with 15 additions and 13 deletions.
1 change: 1 addition & 0 deletions .ocamlformat
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
profile = default
27 changes: 14 additions & 13 deletions lib/mehari.ml
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
open Lwt.Syntax

let cert =
X509_lwt.private_of_pems
Expand All @@ -8,47 +9,47 @@ let init_socket addr port =
let sockaddr = Unix.ADDR_INET (addr, port) in
let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true;
let%lwt () = Lwt_unix.bind socket sockaddr in
let* () = Lwt_unix.bind socket sockaddr in
Lwt.return socket

let create_srv_socket addr port =
let%lwt socket = init_socket addr port in
let* socket = init_socket addr port in
Lwt_unix.listen socket 10;
Lwt.return socket

let accept sock =
let%lwt (sock_cl, addr) = Lwt_unix.accept sock in
let* (sock_cl, addr) = Lwt_unix.accept sock in
let ic = Lwt_io.of_fd ~close:(fun () -> Lwt.return_unit) ~mode:Lwt_io.input sock_cl in
let oc = Lwt_io.of_fd ~close:(fun () -> Lwt.return_unit) ~mode:Lwt_io.output sock_cl in
Lwt.return ((ic,oc), addr, sock_cl)

let write oc buff =
let%lwt () = Lwt_io.write oc buff in
let* () = Lwt_io.write oc buff in
Lwt_io.flush oc

let read ic =
let%lwt buff = Lwt_io.read ic ~count:2048 in
let* buff = Lwt_io.read ic ~count:2048 in
Printf.printf "%s%!" buff;
Lwt.return buff

let rec serve handler sock certchain =
let%lwt (_, _, sock_cl) = accept sock in
let%lwt server =
let rec serve handler sock certchain =
let* (_, _, sock_cl) = accept sock in
let* server =
Tls_lwt.Unix.server_of_fd
(Tls.Config.server ~certificates:(`Single certchain) ()) sock_cl
in
let ic, oc = Tls_lwt.of_t server in
let%lwt () = handler ic oc in
let%lwt () = Tls_lwt.Unix.close_tls server in
let* () = handler ic oc in
let* () = Tls_lwt.Unix.close_tls server in
serve handler sock certchain

let start_server callback =
let handle_request ic oc =
let%lwt buff = read ic in
let* buff = read ic in
write oc @@ callback buff
in
let%lwt sock = create_srv_socket Unix.inet_addr_loopback 1965 in
let%lwt certchain = cert in
let* sock = create_srv_socket Unix.inet_addr_loopback 1965 in
let* certchain = cert in
serve handle_request sock certchain

let run callback =
Expand Down

0 comments on commit 2598477

Please sign in to comment.