Mirage 2.3.0

mirage/example/unikernel.ml

@@ -21,20 +21,14 @@ 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)
 
   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
 

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

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 ]
 

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"]