diff --git a/mirage/example/unikernel.ml b/mirage/example/unikernel.ml index 5579ffb6..a81e4e4b 100644 --- a/mirage/example/unikernel.ml +++ b/mirage/example/unikernel.ml @@ -21,12 +21,6 @@ module Color = struct end -let string_of_err = function - | `Flow `Timeout -> "TIMEOUT" - | `Flow `Refused -> "REFUSED" - | `Flow (`Unknown msg) - | `Tls msg -> msg - module Log (C: CONSOLE) = struct let log_trace c str = C.log_s c (Color.green "+ %s" str) @@ -34,7 +28,7 @@ module Log (C: CONSOLE) = struct and log_data c str buf = let repr = String.escaped (Cstruct.to_string buf) in C.log_s c (Color.blue " %s: " str ^ repr) - and log_error c e = C.log_s c (Color.red "+ err: %s" (string_of_err e)) + and log_error c e = C.log_s c (Color.red "+ err: %s" e) end @@ -73,7 +67,7 @@ struct >>== (fun tls -> L.log_trace c "shook hands" >> k c flush_trace tls) >>= function | `Ok _ -> assert false - | `Error e -> L.log_error c e + | `Error e -> L.log_error c (TLS.error_message e) | `Eof -> L.log_trace c "eof." let start c stack e kv = @@ -119,12 +113,12 @@ struct let conf = Tls.Config.client ~authenticator () in S.TCPV4.create_connection (S.tcpv4 stack) (fst peer) >>= function - | `Error e -> L.log_error c (`Flow e) + | `Error e -> L.log_error c (S.TCPV4.error_message e) | `Ok tcp -> TLS.client_of_flow conf (snd peer) tcp >>== chat c >>= function - | `Error e -> L.log_error c e + | `Error e -> L.log_error c (TLS.error_message e) | `Eof -> L.log_trace c "eof." | `Ok _ -> assert false diff --git a/mirage/tls_mirage.ml b/mirage/tls_mirage.ml index c8bc95d5..c3c2d60f 100644 --- a/mirage/tls_mirage.ml +++ b/mirage/tls_mirage.ml @@ -5,10 +5,17 @@ module Make (F : V1_LWT.FLOW) (E : V1_LWT.ENTROPY) = struct module FLOW = F - type error = [ `Tls of string | `Flow of FLOW.error ] + type error = [ `Tls_alert of Tls.Packet.alert_type + | `Tls_failure of Tls.Engine.failure + | `Flow of FLOW.error ] type buffer = Cstruct.t type +'a io = 'a Lwt.t + let error_message = function + | `Tls_failure f -> Tls.Engine.string_of_failure f + | `Tls_alert a -> Tls.Packet.alert_type_to_string a + | `Flow err -> F.error_message err + module ENTROPY = E (* * XXX 1: Would be nice if this happened behind the scenes. @@ -29,12 +36,10 @@ module Make (F : V1_LWT.FLOW) (E : V1_LWT.ENTROPY) = struct mutable linger : Cstruct.t list ; } - let tls_error e = `Error (`Tls e) - let tls_alert a = `Error (`Tls (Tls.Packet.alert_type_to_string a)) - let tls_fail f = `Error (`Tls (Tls.Engine.string_of_failure f)) + let tls_alert a = `Error (`Tls_alert a) + let tls_fail f = `Error (`Tls_failure f) let return_error e = return (`Error e) - let return_tls_error e = return (tls_error e) let return_ok = return (`Ok ()) let list_of_option = function None -> [] | Some x -> [x] @@ -109,7 +114,7 @@ module Make (F : V1_LWT.FLOW) (E : V1_LWT.ENTROPY) = struct FLOW.write flow.flow answer >>= check_write flow | None -> (* "Impossible" due to handhake draining. *) - return_tls_error "write: flow not ready to send" + assert false let write flow buf = writev flow [buf] @@ -131,14 +136,16 @@ module Make (F : V1_LWT.FLOW) (E : V1_LWT.ENTROPY) = struct flow.linger <- list_of_option mbuf @ flow.linger ; drain_handshake flow | `Error e -> return_error e - | `Eof -> return_tls_error "tls: end_of_file in handshake" + | `Eof -> return `Eof let reneg flow = match flow.state with | `Eof | `Error _ as e -> return e | `Active tls -> match tracing flow @@ fun () -> Tls.Engine.reneg tls with - | None -> return_tls_error "renegotiation in progress" + | None -> + (* XXX make this impossible to reach *) + invalid_arg "Renegotiation already in progress" | Some (tls', buf) -> flow.state <- `Active tls' ; FLOW.write flow.flow buf >|= lift_result diff --git a/mirage/tls_mirage.mli b/mirage/tls_mirage.mli index 7face8d8..0fb592b6 100644 --- a/mirage/tls_mirage.mli +++ b/mirage/tls_mirage.mli @@ -4,7 +4,9 @@ module Make (F : V1_LWT.FLOW) (E : V1_LWT.ENTROPY) : sig module FLOW : V1_LWT.FLOW module ENTROPY : V1_LWT.ENTROPY - type error = [ `Tls of string | `Flow of FLOW.error ] + type error = [ `Tls_alert of Tls.Packet.alert_type + | `Tls_failure of Tls.Engine.failure + | `Flow of FLOW.error ] type buffer = Cstruct.t type +'a io = 'a Lwt.t @@ -21,11 +23,11 @@ module Make (F : V1_LWT.FLOW) (E : V1_LWT.ENTROPY) : sig val client_of_flow : ?trace:tracer -> Tls.Config.client -> string -> FLOW.flow -> - [> `Ok of flow | `Error of error ] Lwt.t + [> `Ok of flow | `Error of error | `Eof ] Lwt.t val server_of_flow : ?trace:tracer -> Tls.Config.server -> FLOW.flow -> - [> `Ok of flow | `Error of error ] Lwt.t + [> `Ok of flow | `Error of error | `Eof ] Lwt.t val epoch : flow -> [ `Ok of Tls.Engine.epoch_data | `Error ] diff --git a/opam b/opam index de100f7c..fd8497ec 100644 --- a/opam +++ b/opam @@ -31,6 +31,8 @@ depopts: [ "mirage-types-lwt" ] conflicts: [ - "mirage-types-lwt" {<"2.2.0"} + "mirage-types-lwt" {<"2.3.0"} "mirage-net-xen" {<"1.3.0"} + "mirage-entropy-xen" {<"0.2.0"} ] +ocaml-version: [>="4.01.0"]