diff --git a/miou/dune b/miou/dune new file mode 100644 index 00000000..e277a776 --- /dev/null +++ b/miou/dune @@ -0,0 +1,6 @@ +(library + (name tls_miou) + (public_name tls-miou) + (libraries miou.unix tls) + (instrumentation + (backend bisect_ppx))) diff --git a/miou/tests/dune b/miou/tests/dune new file mode 100644 index 00000000..25781b2d --- /dev/null +++ b/miou/tests/dune @@ -0,0 +1,12 @@ +(test + (name fuzz) + (libraries + mirage-crypto-rng.unix + ohex + rresult + ptime + ptime.clock.os + crowbar + tls-miou) + (instrumentation + (backend bisect_ppx))) diff --git a/miou/tests/fuzz.ml b/miou/tests/fuzz.ml new file mode 100644 index 00000000..2cb91690 --- /dev/null +++ b/miou/tests/fuzz.ml @@ -0,0 +1,335 @@ +let rec random_path ?(tries = 10) fmt = + if tries <= 0 then failwith "Impossible to generate an available random path"; + let res = Bytes.create 6 in + for i = 0 to Bytes.length res - 1 do + let chr = + match Random.int (10 + 26 + 26) with + | n when n < 10 -> Char.chr (Char.code '0' + n) + | n when n < 10 + 26 -> Char.chr (Char.code 'a' + n - 10) + | n -> Char.chr (Char.code 'A' + n - 10 - 26) + in + Bytes.set res i chr + done; + let path = Fmt.str fmt (Bytes.unsafe_to_string res) in + if Sys.file_exists path then random_path ~tries:(pred tries) fmt else path + +let unlink_if_exists path = + try Unix.unlink path with Unix.Unix_error (Unix.ENOENT, _, _) -> () + +let bind_and_listen ?(backlog = 16) () = + let tmp = random_path "socket-%s.socket" in + unlink_if_exists tmp; + let socket = Unix.socket ~cloexec:true Unix.PF_UNIX Unix.SOCK_STREAM 0 in + let addr = Unix.ADDR_UNIX tmp in + Unix.bind socket addr; + Unix.listen socket backlog; + (Miou_unix.of_file_descr ~non_blocking:true socket, addr, tmp) + +module Ca = struct + open Rresult + + let prefix = + X509.Distinguished_name. + [ Relative_distinguished_name.singleton (CN "Fuzzer") ] + + let cacert_dn = + X509.Distinguished_name.( + prefix + @ [ Relative_distinguished_name.singleton (CN "Ephemeral CA for fuzzer") ]) + + let cacert_lifetime = Ptime.Span.v (365, 0L) + let cacert_serial_number = Z.zero + + let make domain_name seed = + Domain_name.of_string domain_name >>= Domain_name.host + >>= fun domain_name -> + let private_key = + let seed = Cstruct.of_string (Base64.decode_exn ~pad:false seed) in + let g = Mirage_crypto_rng.(create ~seed (module Fortuna)) in + Mirage_crypto_pk.Rsa.generate ~g ~bits:2048 () + in + let valid_from = Ptime.v (Ptime_clock.now_d_ps ()) in + Ptime.add_span valid_from cacert_lifetime + |> Option.to_result ~none:(R.msgf "End time out of range") + >>= fun valid_until -> + X509.Signing_request.create cacert_dn (`RSA private_key) >>= fun ca_csr -> + let extensions = + let open X509.Extension in + let key_id = + X509.Public_key.id X509.Signing_request.((info ca_csr).public_key) + in + let authority_key_id = + ( Some key_id, + X509.General_name.(singleton Directory [ cacert_dn ]), + Some cacert_serial_number ) + in + empty + |> add Subject_alt_name + ( true, + X509.General_name.( + singleton DNS [ Domain_name.to_string domain_name ]) ) + |> add Basic_constraints (true, (false, None)) + |> add Key_usage + (true, [ `Digital_signature; `Content_commitment; `Key_encipherment ]) + |> add Subject_key_id (false, key_id) + |> add Authority_key_id (false, authority_key_id) + in + X509.Signing_request.sign ~valid_from ~valid_until ~extensions + ~serial:cacert_serial_number ca_csr (`RSA private_key) cacert_dn + |> R.reword_error (R.msgf "%a" X509.Validation.pp_signature_error) + >>= fun certificate -> + let fingerprint = X509.Certificate.fingerprint `SHA256 certificate in + let time () = Some (Ptime_clock.now ()) in + let authenticator = + X509.Authenticator.server_cert_fingerprint ~time ~hash:`SHA256 + ~fingerprint + in + Ok (certificate, `RSA private_key, authenticator) +end + +let fuzz_coop = "fuzz.coop" +let mutex = Miou.Mutex.create () +let epr fmt = Miou.Mutex.protect mutex @@ fun () -> Fmt.epr fmt + +type operation = + | Send of string + | Recv of int + | Shutdown of [ `read | `write ] + | Close + | Noop + +module Stop = struct + type t = { + mutex : Miou.Mutex.t; + condition : Miou.Condition.t; + mutable stop : bool; + } + + let create () = + let mutex = Miou.Mutex.create () in + let condition = Miou.Condition.create () in + { mutex; condition; stop = false } + + let stop t = + Miou.Mutex.protect t.mutex @@ fun () -> + t.stop <- true; + Miou.Condition.broadcast t.condition + + let wait t = + Miou.Mutex.protect t.mutex @@ fun () -> + while t.stop = false do + Miou.Condition.wait t.condition t.mutex + done +end + +let inhibit fn = try fn () with _exn -> () + +let run ~role:_ actions tls = + let rec go buf tls = function + | [] -> Buffer.contents buf + | Noop :: actions -> + Miou.yield (); + go buf tls actions + | Send str :: actions -> + Tls_miou.write tls str; + go buf tls actions + | Close :: actions -> + Tls_miou.close tls; + go buf tls actions + | Shutdown cmd :: actions -> + Tls_miou.shutdown tls (cmd :> [ `read | `write | `read_write ]); + go buf tls actions + | Recv len :: actions -> + let tmp = Bytes.make len '\000' in + Tls_miou.really_read tls tmp; + Buffer.add_subbytes buf tmp 0 len; + go buf tls actions + in + let buf = Buffer.create 0x100 in + try go buf tls actions with + | End_of_file | Tls_miou.Closed_by_peer | Tls_miou.Tls_alert _ + | Tls_miou.Tls_failure _ -> + inhibit (fun () -> Miou_unix.close (Tls_miou.file_descr tls)); + Buffer.contents buf + | exn -> + inhibit (fun () -> Miou_unix.close (Tls_miou.file_descr tls)); + raise exn + +let run_client ~to_client:actions cfg addr = + let domain = Unix.domain_of_sockaddr addr in + let socket = Unix.socket ~cloexec:true domain Unix.SOCK_STREAM 0 in + Unix.connect socket addr; + let fd = Miou_unix.of_file_descr ~non_blocking:true socket in + let tls = Tls_miou.client_of_fd cfg fd in + let finally () = + inhibit (fun () -> Miou_unix.close (Tls_miou.file_descr tls)) + in + Fun.protect ~finally @@ fun () -> run ~role:"client" actions tls + +let rec cleanup orphans clients = + match Miou.care orphans with + | None | Some None -> clients + | Some (Some prm) -> + let clients = Miou.await prm :: clients in + cleanup orphans clients + +let rec terminate orphans clients = + match Miou.care orphans with + | None -> List.rev clients + | Some None -> + Miou.yield (); + terminate orphans clients + | Some (Some prm) -> + let clients = Miou.await prm :: clients in + terminate orphans clients + +exception Stop + +let run_server ~to_server:actions ~stop fd cfg = + let rec go orphans clients = + let clients = cleanup orphans clients in + let accept = Miou.call_cc @@ fun () -> Miou_unix.accept ~cloexec:true fd in + let stop = + Miou.call_cc @@ fun () -> + Stop.wait stop; + raise Stop + in + match Miou.await_first [ accept; stop ] with + | Error _ -> + inhibit (fun () -> Miou_unix.close fd); + terminate orphans clients + | Ok (fd, _) -> + ignore + ( Miou.call_cc ~orphans @@ fun () -> + match Tls_miou.server_of_fd cfg fd with + | tls -> run ~role:"server" actions tls + | exception _ -> + Miou_unix.close fd; + String.empty ); + go orphans clients + in + go (Miou.orphans ()) [] + +let compile to_client to_server = + let close_client close = function + | Close -> close lor 0b1100 + | Shutdown `read -> close lor 0b1000 + | Shutdown `write -> close lor 0b0100 + | _ -> close + in + let close_server close = function + | Close -> close lor 0b0011 + | Shutdown `read -> close lor 0b0010 + | Shutdown `write -> close lor 0b0001 + | _ -> close + in + let client = Buffer.create 0x100 in + let server = Buffer.create 0x100 in + let rec go close to_client to_server = + match (close, to_client, to_server) with + | _, [], _ | _, _, [] -> () + | close, ((Shutdown _ | Close) as operation) :: to_client, _ -> + go (close_client close operation) to_client to_server + | close, _, ((Shutdown _ | Close) as operation) :: to_server -> + go (close_server close operation) to_client to_server + | close, Noop :: to_client, to_server | close, to_client, Noop :: to_server + -> + go close to_client to_server + | close, Send str :: to_client, Recv n :: to_server -> + assert (String.length str = n); + if close land 0b0100 = 0 && close land 0b0010 = 0 then + Buffer.add_string server str; + if close land 0b0100 = 0 && close land 0b0010 = 0 then + go close to_client to_server + | close, Recv n :: to_client, Send str :: to_server -> + assert (String.length str = n); + if close land 0b1000 = 0 && close land 0b0001 = 0 then + Buffer.add_string client str; + if close land 0b1000 = 0 && close land 0b0001 = 0 then + go close to_client to_server + | _, Send _ :: _, Send _ :: _ | _, Recv _ :: _, Recv _ :: _ -> + assert false (* GADT? *) + in + go 0x0 to_client to_server; + (Buffer.contents client, Buffer.contents server) + +let run seed operations = + Miou_unix.run ~domains:1 @@ fun () -> + let fd, addr, path = bind_and_listen () in + let finally () = Unix.unlink path in + Fun.protect ~finally @@ fun () -> + let cert, pk, authenticator = + Rresult.R.failwith_error_msg (Ca.make fuzz_coop seed) + in + let cfg_server = + Tls.Config.server ~certificates:(`Single ([ cert ], pk)) () + in + let cfg_client = Tls.Config.client ~authenticator () in + let to_client, to_server = List.split operations in + let stop = Stop.create () in + let prm0 = Miou.call_cc @@ fun () -> run_server ~to_server ~stop fd cfg_server in + let prm1 = + Miou.call_cc @@ fun () -> + let finally () = Stop.stop stop in + Fun.protect ~finally @@ fun () -> run_client ~to_client cfg_client addr + in + let send_to_client, send_to_server = compile to_client to_server in + match (Miou.await prm0, Miou.await prm1) with + | Ok [ Ok send_to_server' ], Ok send_to_client' -> + Crowbar.check (String.equal send_to_client send_to_client'); + Crowbar.check (String.equal send_to_server send_to_server'); + let n = String.length send_to_client in + let m = String.length send_to_server in + epr "[%a] %db %db transmitted\n%!" Fmt.(styled `Green string) "OK" n m + | _ -> + Crowbar.failf "[%a] Unexpected result\n%!" Fmt.(styled `Red string) "ERROR" + +let label name gen = Crowbar.with_printer Fmt.(const string name) gen + +let direction = + let open Crowbar in + choose + [ + label "server-to-client" (const `To_client); + label "client-to-server" (const `To_server); + ] + +let shutdown = + let open Crowbar in + choose + [ + label "close" (const Close); + label "shutdown-recv" (const (Shutdown `read)); + label "shutdown-send" (const (Shutdown `write)); + label "noop" (const Noop); + ] + +let operation = + let open Crowbar in + map [ direction; bytes ] @@ fun direction str -> + match (direction, str) with + | _, "" -> (Noop, Noop) + | `To_server, str -> (Send str, Recv (String.length str)) + | `To_client, str -> (Recv (String.length str), Send str) + +let counter = Atomic.make 0 + +let operations = + let open Crowbar in + fix @@ fun m -> + let continue (to_client, to_server) = + if Atomic.fetch_and_add counter 1 >= 4 then const [ (Close, Close) ] + else map [ m ] @@ fun ops -> (to_client, to_server) :: ops + in + map + [ list1 operation; dynamic_bind (pair shutdown shutdown) continue ] + List.rev_append + +let seed = Crowbar.(map [ bytes ] Base64.encode_exn) + +let () = + Sys.set_signal Sys.sigpipe Sys.Signal_ignore; + Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna); + Crowbar.add_test ~name:"run" Crowbar.[ seed; operations ] @@ fun seed operations -> + run seed operations; + Atomic.set counter 0 diff --git a/miou/tls_miou.ml b/miou/tls_miou.ml new file mode 100644 index 00000000..437ea79c --- /dev/null +++ b/miou/tls_miou.ml @@ -0,0 +1,335 @@ +let src = Logs.Src.create "tls-miou" + +module Log = (val Logs.src_log src : Logs.LOG) + +external reraise : exn -> 'a = "%reraise" + +let ( $ ) f x = f x + +exception Tls_alert of Tls.Packet.alert_type +exception Tls_failure of Tls.Engine.failure +exception Closed_by_peer + +let () = + Printexc.register_printer @@ function + | Closed_by_peer -> Some "Connection closed by peer" + | Tls_alert alert -> Some (Tls.Packet.alert_type_to_string alert) + | Tls_failure failure -> Some (Tls.Engine.string_of_failure failure) + | _ -> None + +type state = + [ `Active of Tls.Engine.state + | `Read_closed of Tls.Engine.state + | `Write_closed of Tls.Engine.state + | `Closed + | `Error of exn ] + +type t = { + role : [ `Server | `Client ]; + fd : Miou_unix.file_descr; + mutable state : state; + mutable linger : Cstruct.t option; + read_buffer_size : int; + buf : bytes; + mutable rd_closed : bool; +} + +let file_descr { fd; _ } = fd + +let half_close state mode = + match (state, mode) with + | `Active tls, `read -> `Read_closed tls + | `Active tls, `write -> `Write_closed tls + | `Active _, `read_write -> `Closed + | `Read_closed tls, `read -> `Read_closed tls + | `Read_closed _, (`write | `read_write) -> `Closed + | `Write_closed tls, `write -> `Write_closed tls + | `Write_closed _, (`read | `read_write) -> `Closed + | ((`Closed | `Error _) as e), (`read | `write | `read_write) -> e + +let inject_state tls = function + | `Active _ -> `Active tls + | `Read_closed _ -> `Read_closed tls + | `Write_closed _ -> `Write_closed tls + | (`Closed | `Error _) as e -> e + +let tls_alert a = Tls_alert a +let tls_fail f = Tls_failure f +let inhibit fn v = try fn v with _ -> () + +let full_write fd ({ Cstruct.len; _ } as cs) = + let str = Cstruct.to_string cs in + Miou_unix.write fd str ~off:0 ~len + +let writev fd css = + let cs = Cstruct.concat css in + full_write fd cs + +let write_flow flow buf = + try writev flow.fd [ buf ] with + | Unix.Unix_error (Unix.EPIPE, _, _) -> + flow.state <- half_close flow.state `write; + raise Closed_by_peer + | Unix.Unix_error (_, _, _) as exn -> + flow.state <- `Error exn; + reraise exn + +let handle flow tls buf = + match Tls.Engine.handle_tls tls buf with + | Ok (state, eof, `Response resp, `Data data) -> + let state = inject_state state flow.state in + let state = Option.(value ~default:state (map (fun `Eof -> half_close state `read) eof)) in + flow.state <- state; + Option.iter (inhibit $ write_flow flow) resp; + data + | Error (fail, `Response resp) -> + let exn = match fail with + | `Alert a -> tls_alert a | f -> tls_fail f in + flow.state <- `Error exn; + let _ = inhibit (writev flow.fd) [resp] in + raise exn + +let read flow = + match Miou_unix.read flow.fd flow.buf ~off:0 ~len:(Bytes.length flow.buf) with + | 0 -> Ok 0 + | len -> Ok len + | exception Unix.Unix_error (Unix.ECONNRESET, _, _) -> Ok 0 + | exception exn -> Error exn + +let not_errored = function `Error _ -> false | _ -> true + +let garbage flow = + Option.fold ~none:false ~some:(Fun.negate Cstruct.is_empty) flow.linger + +let read_react flow = + match flow.state with + | `Error exn -> raise exn + | `Read_closed _ | `Closed when garbage flow -> + (* XXX(dinosaure): [`Closed] can appear "at the same time" than some + application-data. In that case, we stored them into [t.linger]. Depending + on who closed the connection, [read_react] gives this /garbage/ in any + situation (even if the user closed the connection). + + An extra layer with [read] below check if [`Read_closed]/[`Close] comes + from the network (the peer closed the connection) or the user. In the + first case, we must give pending application-data. In the second case, + we must return [0] (or raise [End_of_file]). *) + let mbuf = flow.linger in + flow.linger <- None; + mbuf + | `Read_closed _ | `Closed -> + (* XXX(dinosaure): the goal of [read_react] is to read some encrypted bytes + and try to decrypt them with [handle]. If the linger is empty, this means + that we're trying to get more data (to decrypt) when we can't get any + more. From this point of view, it's an error that needs to be notified. + However, this error can be interpreted in 2 ways: + - we want to have more data decrypted. In this case, this error is + expected and may result in the user being told that there is nothing + left to read (for example, returning 0). + - we attempt a handshake. In this case, we are dealing with an unexpected + error. *) + raise End_of_file + | `Active _ | `Write_closed _ -> + match read flow with + | Error exn -> + if not_errored flow.state then flow.state <- `Error exn; + raise exn + | Ok 0 -> + (* XXX(dinosaure): see [`Read_closed _ | `Closed] case. *) + raise End_of_file + | Ok len -> + match flow.state with + | `Active tls | `Read_closed tls | `Write_closed tls -> + let buf = Cstruct.of_bytes flow.buf ~off:0 ~len in + handle flow tls buf + | `Closed -> raise End_of_file + | `Error exn -> raise exn +[@@ocamlformat "disable"] + +let rec read_in flow buf = + let write_in res = + let rlen = Cstruct.length res in + let n = min (Cstruct.length buf) rlen in + Cstruct.blit res 0 buf 0 n; + let linger = if n < rlen + then Some (Cstruct.sub res n (rlen - n)) else None in + flow.linger <- linger; n + in + match flow.linger with + | Some res -> write_in res + | None -> ( + match read_react flow with + | None -> read_in flow buf + | Some res -> write_in res) + +let writev flow bufs = + match flow.state with + | `Closed | `Write_closed _ -> raise Closed_by_peer + | `Error exn -> reraise exn + | `Active tls | `Read_closed tls -> ( + match Tls.Engine.send_application_data tls bufs with + | Some (tls, answer) -> + flow.state <- `Active tls; + write_flow flow answer + | None -> assert false) + +let unsafe_write flow off len str = + writev flow [ Cstruct.of_string ~off ~len str ] + +let write flow ?(off = 0) ?len str = + let len = Option.value ~default:(String.length str - off) len in + if off < 0 || len < 0 || off > String.length str - len + then invalid_arg "Tls_miou.write"; + if len > 0 then unsafe_write flow off len str + +let rec drain_handshake flow = + let push_linger flow mcs = + match (mcs, flow.linger) with + | None, _ -> () + | scs, None -> flow.linger <- scs + | Some cs, Some l -> flow.linger <- Some (Cstruct.append l cs) + in + match flow.state with + | `Active tls when not (Tls.Engine.handshake_in_progress tls) -> flow + | (`Read_closed _ | `Closed) when garbage flow -> flow + | _ -> + let mcs = read_react flow in + push_linger flow mcs; + drain_handshake flow + +let close flow = + match flow.state with + | `Active tls | `Read_closed tls -> + let tls, buf = Tls.Engine.send_close_notify tls in + flow.rd_closed <- true; + flow.state <- inject_state tls flow.state; + flow.state <- `Closed; + inhibit (write_flow flow) buf; + Miou_unix.close flow.fd + | `Write_closed _ -> + flow.rd_closed <- true; + flow.state <- `Closed; + Miou_unix.close flow.fd + | `Closed -> flow.rd_closed <- true; + | `Error _ -> + flow.rd_closed <- true; + Miou_unix.close flow.fd + +let closed_by_user flow = function + | `read | `read_write -> flow.rd_closed <- true + | `write -> () + +let shutdown flow mode = + closed_by_user flow mode; + match (flow.state, mode) with + | `Active tls, `read -> + flow.state <- inject_state tls (half_close flow.state mode) + | (`Active tls | `Read_closed tls), (`write | `read_write) -> + let tls, buf = Tls.Engine.send_close_notify tls in + if mode = `read_write then flow.rd_closed <- true; + flow.state <- inject_state tls (half_close flow.state mode); + inhibit (write_flow flow) buf; + if flow.state = `Closed then Miou_unix.close flow.fd + | `Write_closed tls, (`read | `read_write) -> + flow.state <- inject_state tls (half_close flow.state mode); + if flow.state = `Closed then Miou_unix.close flow.fd + | `Error _, _ -> Miou_unix.close flow.fd + | `Read_closed _, `read -> () + | `Write_closed _, `write -> () + | `Closed, _ -> () + +let client_of_fd conf ?(read_buffer_size = 0x1000) ?host fd = + let conf' = + match host with None -> conf | Some host -> Tls.Config.peer conf host + in + let tls, init = Tls.Engine.client conf' in + let tls_flow = + { + role = `Client; + fd; + state = `Active tls; + linger = None; + read_buffer_size; + buf = Bytes.create read_buffer_size; + rd_closed = false; + } + in + write_flow tls_flow init; + drain_handshake tls_flow + +let server_of_fd conf ?(read_buffer_size = 0x1000) fd = + let tls = Tls.Engine.server conf in + let tls_flow = + { + role = `Server; + fd; + state = `Active tls; + linger = None; + read_buffer_size; + buf = Bytes.create read_buffer_size; + rd_closed = false; + } + in + drain_handshake tls_flow + +let unsafe_read t off len buf = + let cs = Cstruct.create len in + try + let len = read_in t cs in + Cstruct.blit_to_bytes cs 0 buf off len; + len + with End_of_file -> 0 + (* XXX(dinosaure): [End_of_file] means that the connection was closed by peer + and the actual state of [t] is [`Read_closed] or [`Closed] with an empty + [t.linger]. For [read_in]/[read_react], it's an error because we expect + encrypted bytes to decrypt them. However, for [read], it just means that + the connection was closed by peer and we should, as [Unix.read], just + returns [0]. *) + +let read t ?(off= 0) ?len buf = + let len = Option.value ~default:(Bytes.length buf - off) len in + if off < 0 || len < 0 || off > Bytes.length buf - len + then invalid_arg "Tls_miou.read"; + if t.rd_closed then 0 else unsafe_read t off len buf + +let rec really_read_go t off len buf = + let len' = read t buf ~off ~len in + if len' == 0 then raise End_of_file + else if len - len' > 0 + then really_read_go t (off + len') (len - len') buf + +let really_read t ?(off= 0) ?len buf = + let len = Option.value ~default:(Bytes.length buf - off) len in + if off < 0 || len < 0 || off > Bytes.length buf - len + then invalid_arg "Tls_miou.really_read"; + if len > 0 then really_read_go t off len buf + +let resolve host service = + let tcp = Unix.getprotobyname "tcp" in + match Unix.getaddrinfo host service [ AI_PROTOCOL tcp.p_proto ] with + | [] -> Fmt.invalid_arg "No address for %s:%s" host service + | ai :: _ -> ai.ai_addr + +let connect authenticator (v, port) = + let conf = Tls.Config.client ~authenticator () in + let addr = resolve v (string_of_int port) in + let fd = + match addr with + | Unix.ADDR_UNIX _ -> invalid_arg "Tls_miou.connect: Invalid UNIX socket" + | Unix.ADDR_INET (inet_addr, _) -> + if Unix.is_inet6_addr inet_addr then Miou_unix.tcpv6 () + else Miou_unix.tcpv4 () + in + let host = Result.to_option Domain_name.(Result.bind (of_string v) host) in + match Miou_unix.connect fd addr with + | () -> client_of_fd conf ?host fd + | exception exn -> + Miou_unix.close fd; + raise exn + +let epoch flow = match flow.state with + | `Active tls | `Read_closed tls | `Write_closed tls -> + ( match Tls.Engine.epoch tls with + | Error () -> assert false + | Ok data -> Some data ) + | _ -> None diff --git a/miou/tls_miou.mli b/miou/tls_miou.mli new file mode 100644 index 00000000..c02d77ad --- /dev/null +++ b/miou/tls_miou.mli @@ -0,0 +1,96 @@ +(** Effectful operations using Miou for pure TLS. + + The pure TLS is state and buffer in, state and buffer out. This module uses + Miou (and its Unix layer) for communication over the network. *) + +exception Tls_alert of Tls.Packet.alert_type +exception Tls_failure of Tls.Engine.failure +exception Closed_by_peer + +type t +(** Abstract type of a session. *) + +val file_descr : t -> Miou_unix.file_descr +(** [file_descr] returns the underlying file-descriptor used by the given + TLS {i socket}. *) + +val read : t -> ?off:int -> ?len:int -> bytes -> int +(** [read fd buf ~off ~len] reads up to [len] bytes (defaults to + [Bytes.length buf - off] from the given TLS {i socket} [fd], storing them in + byte sequence [buf], starting at position [off] in [buf] (defaults to [0]). + It returns the actual number of characters read, between 0 and [len] + (inclusive). + + @raise Unix_error raised by the system call {!val:Unix.read}. The function + handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} + exceptions and redo the system call. + + @raise Invalid_argument if [off] and [len] do not designate a valid range of + [buf]. *) + +val really_read : t -> ?off:int -> ?len:int -> bytes -> unit +(** [really_read fd buf ~off ~len] reads [len] bytes (defaults to + [Bytes.length buf - off]) from the given TLS {i socket} [fd], storing them + in byte sequence [buf], starting at position [off] in [buf] (defaults to + [0]). If [len = 0], [really_read] does nothing. + + @raise Unix_error raised by the system call {!val:Unix.read}. The function + handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} + exceptions and redo the system call. + + @raise End_of_file if {!val:Unix.read} returns [0] before [len] characters + have been read. + + @raise Invalid_argument if [off] and [len] do not designate a valid range of + [buf]. *) + +val write : t -> ?off:int -> ?len:int -> string -> unit +(** [write t str ~off ~len] writes [len] bytes (defaults to + [String.length str - off]) from byte sequence [str], starting at offset + [off] (defaults to [0]), to the given TLS {i socket} [fd]. + + @raise Unix_error raised by the syscall call {!val:Unix.write}. The function + handles {!val:Unix.EINTR}, {!val:Unix.EAGAIN} and {!val:Unix.EWOULDBLOCK} + exceptions and redo the system call. + + @raise Closed_by_peer if [t] is connected to a peer whose reading end is + closed. Similar to the {!val:EPIPE} error for pipe/socket connected. + + @raise Invalid_argument if [off] and [len] do not designate a valid range of + [buf]. *) + +val close : t -> unit +(** [close flow] closes the TLS session and the underlying file-descriptor. *) + +val shutdown : t -> [ `read | `write | `read_write ] -> unit +(** [shutdown t direction] closes the direction of the TLS session [t]. If + [`read_write] or [`write] is closed, a TLS close-notify is sent to the other + endpoint. If this results in a fully-closed session (or an errorneous + session), the underlying file descriptor is closed. *) + +val client_of_fd : + Tls.Config.client -> + ?read_buffer_size:int -> + ?host:[ `host ] Domain_name.t -> + Miou_unix.file_descr -> + t +(** [client_of_flow client ~host fd] is [t], after client-side TLS handshake of + [fd] using [client] configuration and [host]. + + @raise End_of_file if we are not able to complete the handshake. *) + +val server_of_fd : + Tls.Config.server -> ?read_buffer_size:int -> Miou_unix.file_descr -> t +(** [server_of_fd server fd] is [t], after server-side TLS handshake of [fd] + using [server] configuration. + + @raise End_of_file if we are not able to complete the handshake. *) + +val connect : X509.Authenticator.t -> string * int -> t +(** [connect authenticator (host, port)] is [t], a connected TLS connection + to [host] on [port] using the default configuration and the + [authenticator]. *) + +val epoch : t -> Tls.Core.epoch_data option +(** [epoch t] returns [epoch], which contains information of the active + session. *) diff --git a/tls-miou.opam b/tls-miou.opam new file mode 100644 index 00000000..67c3ac71 --- /dev/null +++ b/tls-miou.opam @@ -0,0 +1,36 @@ +opam-version: "2.0" +homepage: "https://github.com/mirleft/ocaml-tls" +dev-repo: "git+https://github.com/mirleft/ocaml-tls.git" +bug-reports: "https://github.com/mirleft/ocaml-tls/issues" +doc: "https://mirleft.github.io/ocaml-tls/" +author: ["Romain Calascibetta "] +maintainer: ["Romain Calascibetta "] +license: "BSD-2-Clause" + +build: [ + ["dune" "subst"] {dev} + ["dune" "build" "-p" name "-j" jobs] + ["dune" "runtest" "-p" name "-j" jobs] {with-test} +] + +depends: [ + "ocaml" {>= "4.08.0"} + "dune" {>= "3.0"} + "tls" {= version} + "mirage-crypto-rng" {>= "0.11.0"} + "x509" {>= "0.15.0"} + "miou" + "crowbar" {with-test} + "rresult" {with-test} + "ohex" {with-test} + "ptime" {with-test} +] +tags: [ "org:mirage"] +synopsis: "Transport Layer Security purely in OCaml, Miou layer" +description: """ +Tls-miou provides an effectful Tls_miou module to be used with Miou. +""" + +pin-depends: [ + [ "miou.dev" "git+https://github.com/robur-coop/miou.git#8e3cd3649759c01ea37661cc544626efd167b998" ] +]