reynir/albatross
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

fix warnings

Browse source
This commit is contained in:
Hannes Mehnert 2018-10-21 00:29:25 +02:00
parent 2239aafdb7
commit 51a0344477
5 changed files with 6 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
app/vmm_client.ml
View file

@ -2,8 +2,6 @@
open Lwt.Infix open Lwt.Infix
open Vmm_core
let rec read_tls_write_cons t = let rec read_tls_write_cons t =
Vmm_tls.read_tls t >>= function Vmm_tls.read_tls t >>= function
| Error (`Msg msg) -> | Error (`Msg msg) ->
@ -28,9 +26,6 @@ let client cas host port cert priv_key =
Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ -> Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ ->
X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert -> X509_lwt.private_of_pems ~cert ~priv_key >>= fun cert ->
(match fst cert with
| [] -> Lwt.fail_with "certificate is empty"
| hd::_ -> Lwt.return hd) >>= fun leaf ->
let certificates = `Single cert in let certificates = `Single cert in
let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in
Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t -> Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t ->
@ -40,7 +35,7 @@ let client cas host port cert priv_key =
(Printexc.to_string exn)) ; (Printexc.to_string exn)) ;
Lwt.return_unit) Lwt.return_unit)
let run_client _ cas cert key (host, port) db = let run_client _ cas cert key (host, port) =
Printexc.register_printer (function Printexc.register_printer (function
| Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x) | Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x)
| Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f) | Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f)
@ -92,17 +87,13 @@ let destination =
Arg.(required & pos 3 (some host_port) None & info [] ~docv:"destination" Arg.(required & pos 3 (some host_port) None & info [] ~docv:"destination"
~doc:"the destination hostname:port to connect to") ~doc:"the destination hostname:port to connect to")
let db =
let doc = "Certificate database" in
Arg.(value & opt (some file) None & info [ "db" ] ~doc)
let cmd = let cmd =
let doc = "VMM TLS client" in let doc = "VMM TLS client" in
let man = [ let man = [
`S "DESCRIPTION" ; `S "DESCRIPTION" ;
`P "$(tname) connects to a server and initiates a TLS handshake" ] `P "$(tname) connects to a server and initiates a TLS handshake" ]
in in
Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination $ db), Term.(pure run_client $ setup_log $ cas $ client_cert $ client_key $ destination),
Term.info "vmm_client" ~version:"%%VERSION_NUM%%" ~doc ~man Term.info "vmm_client" ~version:"%%VERSION_NUM%%" ~doc ~man
let () = let () =

2
app/vmm_log.ml
View file

@ -12,8 +12,6 @@
open Lwt.Infix open Lwt.Infix
open Astring
let my_version = `WV2 let my_version = `WV2
let broadcast prefix data t = let broadcast prefix data t =

4
src/vmm_commands.ml
View file

@ -53,8 +53,8 @@ let handle = function
let cmd = Vmm_wire.Log.subscribe c ver name in let cmd = Vmm_wire.Log.subscribe c ver name in
`Log, `Read, cmd `Log, `Read, cmd
| `Crl -> assert false | `Crl -> assert false
| `Create_block (name, size) -> assert false | `Create_block (_name, _size) -> assert false
| `Destroy_block name -> assert false | `Destroy_block _name -> assert false
let handle_reply (hdr, data) = let handle_reply (hdr, data) =
if not (Vmm_wire.version_eq hdr.Vmm_wire.version ver) then if not (Vmm_wire.version_eq hdr.Vmm_wire.version ver) then

2
src/vmm_wire.ml
View file

@ -538,7 +538,7 @@ module Log = struct
let log id version hdr event = let log id version hdr event =
let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event) in let body = Cstruct.append (encode_ptime hdr.Log.ts) (encode_event event) in
encode ~name:hdr.name ~body version id (op_to_int Log) encode ~name:hdr.Log.name ~body version id (op_to_int Log)
end end
module Vm = struct module Vm = struct

3
src/vmm_x509.ml
View file

@ -1,4 +1,3 @@
open Astring
open Rresult.R.Infix open Rresult.R.Infix
open Vmm_core open Vmm_core
@ -18,7 +17,7 @@ let asn_version = `AV1
check_policies vm_config (List.map snd policies) >>= fun () -> check_policies vm_config (List.map snd policies) >>= fun () ->
*) *)
let handle addr chain = let handle _addr chain =
separate_chain chain >>= fun (leaf, chain) -> separate_chain chain >>= fun (leaf, chain) ->
let prefix = List.map name chain in let prefix = List.map name chain in
let name = prefix @ [ name leaf ] in let name = prefix @ [ name leaf ] in