albatross/src/vmm_tls.ml

60 lines
2.1 KiB
OCaml
Raw Normal View History

2017-05-26 14:30:34 +00:00
(* (c) 2017 Hannes Mehnert, all rights reserved *)
open Lwt.Infix
let read_tls t =
let rec r_n buf off tot =
let l = tot - off in
if l = 0 then
Lwt.return (Ok ())
2017-05-26 14:30:34 +00:00
else
Lwt.catch (fun () ->
Tls_lwt.Unix.read t (Cstruct.shift buf off) >>= function
| 0 ->
Logs.err (fun m -> m "TLS: end of file") ;
Lwt.return (Error `Eof)
| x when x == l -> Lwt.return (Ok ())
| x when x < l -> r_n buf (off + x) tot
| _ ->
Logs.err (fun m -> m "TLS: read too much, shouldn't happen") ;
Lwt.return (Error `Toomuch))
(function
| Tls_lwt.Tls_failure a ->
Logs.err (fun m -> m "TLS read failure: %s" (Tls.Engine.string_of_failure a)) ;
Lwt.return (Error `Exception)
| e ->
Logs.err (fun m -> m "TLS read exception %s" (Printexc.to_string e)) ;
Lwt.return (Error `Exception))
2017-05-26 14:30:34 +00:00
in
let buf = Cstruct.create 8 in
r_n buf 0 8 >>= function
| Error e -> Lwt.return (Error e)
| Ok () ->
match Vmm_wire.parse_header (Cstruct.to_string buf) with
| Error (`Msg m) -> Lwt.return (Error (`Msg m))
| Ok hdr ->
let l = hdr.Vmm_wire.length in
if l > 0 then
let b = Cstruct.create l in
r_n b 0 l >|= function
| Error e -> Error e
| Ok () ->
(* Logs.debug (fun m -> m "TLS read id %d %a tag %d data %a"
hdr.Vmm_wire.id Vmm_wire.pp_version hdr.Vmm_wire.version hdr.Vmm_wire.tag
Cstruct.hexdump_pp b) ; *)
Ok (hdr, Cstruct.to_string b)
else
Lwt.return (Ok (hdr, ""))
2017-05-26 14:30:34 +00:00
let write_tls s buf =
(* Logs.debug (fun m -> m "TLS write %a" Cstruct.hexdump_pp (Cstruct.of_string buf)) ; *)
Lwt.catch
(fun () -> Tls_lwt.Unix.write s (Cstruct.of_string buf) >|= fun () -> Ok ())
(function
| Tls_lwt.Tls_failure a ->
Logs.err (fun m -> m "tls failure: %s" (Tls.Engine.string_of_failure a)) ;
Lwt.return (Error `Exception)
| e ->
Logs.err (fun m -> m "TLS write exception %s" (Printexc.to_string e)) ;
Lwt.return (Error `Exception))