diff --git a/_tags b/_tags index 5080875..c992ea9 100644 --- a/_tags +++ b/_tags @@ -16,6 +16,7 @@ true : package(rresult logs ipaddr bos hex ptime astring duration cstruct decomp : link_vmm_stats, package(asn1-combinators) : package(nocrypto tls.lwt nocrypto.lwt) +: package(nocrypto tls.lwt nocrypto.lwt) : package(nocrypto.unix ptime.clock.os x509) : package(nocrypto.unix ptime.clock.os x509) diff --git a/app/vmm_provision.ml b/app/vmm_provision.ml index 100ad6a..c079c15 100644 --- a/app/vmm_provision.ml +++ b/app/vmm_provision.ml @@ -2,20 +2,6 @@ let asn_version = `AV2 -let setup_log style_renderer level = - Fmt_tty.setup_std_outputs ?style_renderer (); - Logs.set_level level; - Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) - -let l_exts = - [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ]) - ; (true, `Basic_constraints (false, None)) - ; (true, `Ext_key_usage [`Client_auth]) ] - -let d_exts ?len () = - [ (true, (`Basic_constraints (true, len))) - ; (true, (`Key_usage [ `Key_cert_sign ; `CRL_sign ; `Digital_signature ; `Content_commitment ])) ] - let timestamps validity = let now = Ptime_clock.now () in match Ptime.add_span now (Ptime.Span.of_int_s (Duration.to_sec validity)) with @@ -93,11 +79,6 @@ let priv_key ?(bits = 2048) fn name = open Cmdliner -let setup_log = - Term.(const setup_log - $ Fmt_cli.style_renderer () - $ Logs_cli.level ()) - let nam = let doc = "Name to provision" in Arg.(required & pos 0 (some string) None & info [] ~doc) diff --git a/app/vmmc_bistro.ml b/app/vmmc_bistro.ml index e69de29..ecda976 100644 --- a/app/vmmc_bistro.ml +++ b/app/vmmc_bistro.ml @@ -0,0 +1,333 @@ +(* (c) 2018 Hannes Mehnert, all rights reserved *) + +open Lwt.Infix + +open Astring + +open Vmm_core + +let version = `AV2 + +let process fd = + Vmm_tls_lwt.read_tls fd >|= function + | Error _ -> + Error (`Msg "read or parse error") + | Ok (header, reply) -> + if Vmm_commands.version_eq header.Vmm_commands.version version then begin + Logs.app (fun m -> m "%a" Vmm_commands.pp_wire (header, reply)) ; + Ok () + end else begin + Logs.err (fun m -> m "version not equal") ; + Error (`Msg "version not equal") + end + +let connect socket_path = + let c = Lwt_unix.(socket PF_UNIX SOCK_STREAM 0) in + Lwt_unix.set_close_on_exec c ; + Lwt_unix.connect c (Lwt_unix.ADDR_UNIX socket_path) >|= fun () -> + c + +let read fd = + (* now we busy read and process output *) + let rec loop () = + process fd >>= function + | Error e -> Lwt.return (Error e) + | Ok () -> loop () + in + loop () + +let key_ids pub issuer = + let auth = (Some (X509.key_id issuer), [], None) in + [ (false, `Subject_key_id (X509.key_id pub)) ; (false, `Authority_key_id auth) ] + +let timestamps validity = + let now = Ptime_clock.now () in + match Ptime.add_span now (Ptime.Span.of_int_s validity) with + | None -> invalid_arg "span too big - reached end of ptime" + | Some exp -> (now, exp) + +let handle (host, port) cert key ca id (cmd : Vmm_commands.t) = + Vmm_lwt.read_from_file cert >>= fun cert_cs -> + let cert = X509.Encoding.Pem.Certificate.of_pem_cstruct1 cert_cs in + Vmm_lwt.read_from_file key >>= fun key_cs -> + let key = X509.Encoding.Pem.Private_key.of_pem_cstruct1 key_cs in + let tmpkey = Nocrypto.Rsa.generate 4096 in + let name = string_of_id id in + let extensions = + [ (true, `Key_usage [ `Digital_signature ; `Key_encipherment ]) + ; (true, `Basic_constraints (false, None)) + ; (true, `Ext_key_usage [`Client_auth]) ; + (false, `Unsupported (Vmm_asn.oid, Vmm_asn.cert_extension_to_cstruct (version, cmd))) ] in + let csr = + let name = [ `CN name ] in + X509.CA.request name ~extensions:[`Extensions extensions] (`RSA tmpkey) + in + let mycert = + let valid_from, valid_until = timestamps 300 in + let extensions = + let capub = match key with `RSA key -> Nocrypto.Rsa.pub_of_priv key in + extensions @ key_ids (X509.CA.info csr).X509.CA.public_key (`RSA capub) + in + let issuer = X509.subject cert in + X509.CA.sign csr ~valid_from ~valid_until ~extensions key issuer + in + let certificates = `Single ([ mycert ; cert ], tmpkey) in + X509_lwt.authenticator (`Ca_file ca) >>= fun authenticator -> + Lwt_unix.gethostbyname host >>= fun host_entry -> + let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in + let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in + Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ -> + let client = Tls.Config.client ~reneg:true ~certificates ~authenticator () in + Tls_lwt.Unix.client_of_fd client (* ~host *) fd >>= fun t -> + read t + +let jump endp cert key ca name cmd = + match + Lwt_main.run (handle endp cert key ca name cmd) + with + | Ok () -> `Ok () + | Error (`Msg m) -> `Error (false, m) + +let info_ _ endp cert key ca name = jump endp cert key ca name (`Vm_cmd `Vm_info) + +let policy _ endp cert key ca name = jump endp cert key ca name (`Policy_cmd `Policy_info) + +let remove_policy _ endp cert key ca name = + jump endp cert key ca name (`Policy_cmd `Policy_remove) + +let add_policy _ endp cert key ca name vms memory cpus block bridges = + let bridges = match bridges with + | xs -> + let add m v = + let n = match v with `Internal n -> n | `External (n, _, _, _, _) -> n in + String.Map.add n v m + in + List.fold_left add String.Map.empty xs + and cpuids = IS.of_list cpus + in + let policy = { vms ; cpuids ; memory ; block ; bridges } in + jump endp cert key ca name (`Policy_cmd (`Policy_add policy)) + +let destroy _ endp cert key ca name = + jump endp cert key ca name (`Vm_cmd `Vm_destroy) + +let create _ endp cert key ca force name image cpuid requested_memory boot_params block_device network = + let image' = match Bos.OS.File.read (Fpath.v image) with + | Ok data -> data + | Error (`Msg s) -> invalid_arg s + in + let argv = match boot_params with + | [] -> None + | xs -> Some xs + (* TODO we could do the compression btw *) + and vmimage = `Hvt_amd64, Cstruct.of_string image' + in + let vm_config = { cpuid ; requested_memory ; block_device ; network ; vmimage ; argv } in + let cmd = + if force then + `Vm_force_create vm_config + else + `Vm_create vm_config + in + jump endp cert key ca name (`Vm_cmd cmd) + +let console _ endp cert key ca name since = + jump endp cert key ca name (`Console_cmd (`Console_subscribe since)) + +let stats _ endp cert key ca name = + jump endp cert key ca name (`Stats_cmd `Stats_subscribe) + +let event_log _ endp cert key ca name since = + jump endp cert key ca name (`Log_cmd (`Log_subscribe since)) + +let help _ _ man_format cmds = function + | None -> `Help (`Pager, None) + | Some t when List.mem t cmds -> `Help (man_format, Some t) + | Some _ -> List.iter print_endline cmds; `Ok () + +open Cmdliner +open Vmm_cli + +let server_ca = + let doc = "The certificate authority used to verify the remote server." in + Arg.(value & opt string "cacert.pem" & info [ "server-ca" ] ~doc) + +let ca_cert = + let doc = "The certificate authority used to issue the certificate" in + Arg.(value & opt string "ca.pem" & info [ "ca" ] ~doc) + +let ca_key = + let doc = "The private key of the signing certificate authority" in + Arg.(value & opt string "ca.key" & info [ "ca-key" ] ~doc) + +let destination = + Arg.(required & pos 0 (some host_port) None & info [] ~docv:"destination" + ~doc:"the destination hostname:port to connect to") + +let force = + let doc = "force VM creation." in + Arg.(value & flag & info [ "f" ; "force" ] ~doc) + +let image = + let doc = "File of virtual machine image." in + Arg.(required & pos 2 (some file) None & info [] ~doc) + +let vm_name = + let doc = "Name virtual machine." in + Arg.(required & pos 1 (some vm_c) None & info [] ~doc) + +let destroy_cmd = + let doc = "destroys a virtual machine" in + let man = + [`S "DESCRIPTION"; + `P "Destroy a virtual machine."] + in + Term.(ret (const destroy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name)), + Term.info "destroy" ~doc ~man + +let remove_policy_cmd = + let doc = "removes a policy" in + let man = + [`S "DESCRIPTION"; + `P "Removes a policy."] + in + Term.(ret (const remove_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), + Term.info "remove_policy" ~doc ~man + +let info_cmd = + let doc = "information about VMs" in + let man = + [`S "DESCRIPTION"; + `P "Shows information about VMs."] + in + Term.(ret (const info_ $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), + Term.info "info" ~doc ~man + +let policy_cmd = + let doc = "active policies" in + let man = + [`S "DESCRIPTION"; + `P "Shows information about policies."] + in + Term.(ret (const policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), + Term.info "policy" ~doc ~man + +let cpus = + let doc = "CPUs to allow" in + Arg.(value & opt_all int [] & info [ "cpu" ] ~doc) + +let vms = + let doc = "Number of VMs to allow" in + Arg.(required & pos 0 (some int) None & info [] ~doc) + +let block = + let doc = "Block storage to allow" in + Arg.(value & opt (some int) None & info [ "block" ] ~doc) + +let mem = + let doc = "Memory to allow" in + Arg.(value & opt int 512 & info [ "mem" ] ~doc) + +let bridge = + let doc = "Bridge to allow" in + Arg.(value & opt_all bridge [] & info [ "bridge" ] ~doc) + +let add_policy_cmd = + let doc = "Add a policy" in + let man = + [`S "DESCRIPTION"; + `P "Adds a policy."] + in + Term.(ret (const add_policy $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ vms $ mem $ cpus $ block $ bridge)), + Term.info "add_policy" ~doc ~man + +let cpu = + let doc = "CPUid" in + Arg.(value & opt int 0 & info [ "cpu" ] ~doc) + +let args = + let doc = "Boot arguments" in + Arg.(value & opt_all string [] & info [ "arg" ] ~doc) + +let block = + let doc = "Block device name" in + Arg.(value & opt (some string) None & info [ "block" ] ~doc) + +let net = + let doc = "Network device" in + Arg.(value & opt_all string [] & info [ "net" ] ~doc) + +let create_cmd = + let doc = "creates a virtual machine" in + let man = + [`S "DESCRIPTION"; + `P "Creates a virtual machine."] + in + Term.(ret (const create $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ force $ vm_name $ image $ cpu $ mem $ args $ block $ net)), + Term.info "create" ~doc ~man + +let timestamp_c = + let parse s = match Ptime.of_rfc3339 s with + | Ok (t, _, _) -> `Ok t + | Error _ -> `Error "couldn't parse timestamp" + in + (parse, Ptime.pp_rfc3339 ()) + +let since = + let doc = "Since" in + Arg.(value & opt (some timestamp_c) None & info [ "since" ] ~doc) + +let console_cmd = + let doc = "console of a VM" in + let man = + [`S "DESCRIPTION"; + `P "Shows console output of a VM."] + in + Term.(ret (const console $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ vm_name $ since)), + Term.info "console" ~doc ~man + +let stats_cmd = + let doc = "statistics of VMs" in + let man = + [`S "DESCRIPTION"; + `P "Shows statistics of VMs."] + in + Term.(ret (const stats $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name)), + Term.info "stats" ~doc ~man + +let log_cmd = + let doc = "Event log" in + let man = + [`S "DESCRIPTION"; + `P "Shows event log of VM."] + in + Term.(ret (const event_log $ setup_log $ destination $ ca_cert $ ca_key $ server_ca $ opt_vm_name $ since)), + Term.info "log" ~doc ~man + +let help_cmd = + let topic = + let doc = "The topic to get help on. `topics' lists the topics." in + Arg.(value & pos 0 (some string) None & info [] ~docv:"TOPIC" ~doc) + in + let doc = "display help about vmmc" in + let man = + [`S "DESCRIPTION"; + `P "Prints help about conex commands and subcommands"] + in + Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ topic)), + Term.info "help" ~doc ~man + +let default_cmd = + let doc = "VMM client and go to bistro" in + let man = [ + `S "DESCRIPTION" ; + `P "$(tname) executes the provided subcommand on a remote albatross" ] + in + Term.(ret (const help $ setup_log $ destination $ Term.man_format $ Term.choice_names $ Term.pure None)), + Term.info "vmmc_bistro" ~version:"%%VERSION_NUM%%" ~doc ~man + +let cmds = [ help_cmd ; info_cmd ; policy_cmd ; remove_policy_cmd ; add_policy_cmd ; destroy_cmd ; create_cmd ; console_cmd ; stats_cmd ; log_cmd ] + +let () = + match Term.eval_choice default_cmd cmds + with `Ok () -> exit 0 | _ -> exit 1 diff --git a/app/vmmd_log.ml b/app/vmmd_log.ml index 969b688..d668c11 100644 --- a/app/vmmd_log.ml +++ b/app/vmmd_log.ml @@ -30,20 +30,8 @@ let write_complete s cs = w 0 let read_from_file file = - Lwt_unix.stat file >>= fun stat -> - let size = stat.Lwt_unix.st_size in - Lwt_unix.openfile file Lwt_unix.[O_RDONLY] 0 >>= fun fd -> - let buf = Bytes.create size in - let rec read off = - Lwt_unix.read fd buf off (size - off) >>= fun bytes -> - if bytes + off = size then - Lwt.return_unit - else - read (bytes + off) - in - read 0 >>= fun () -> - let logs = Vmm_asn.logs_of_disk my_version (Cstruct.of_bytes buf) in - Vmm_lwt.safe_close fd >|= fun () -> + Vmm_lwt.read_from_file file >|= fun data -> + let logs = Vmm_asn.logs_of_disk my_version data in List.rev logs let write_to_file file = diff --git a/app/vmmp_request.ml b/app/vmmp_request.ml index 8bb98c6..92765d8 100644 --- a/app/vmmp_request.ml +++ b/app/vmmp_request.ml @@ -36,43 +36,8 @@ let jump _ name key image mem cpu args block net force compression = | Ok () -> `Ok () | Error (`Msg m) -> `Error (false, m) -open Cmdliner - -let cpu = - let doc = "CPUid" in - Arg.(required & pos 3 (some int) None & info [] ~doc) - -let image = - let doc = "Image file to provision" in - Arg.(required & pos 1 (some file) None & info [] ~doc) - -let args = - let doc = "Boot arguments" in - Arg.(value & opt_all string [] & info [ "arg" ] ~doc) - -let block = - let doc = "Block device name" in - Arg.(value & opt (some string) None & info [ "block" ] ~doc) - -let net = - let doc = "Network device" in - Arg.(value & opt_all string [] & info [ "net" ] ~doc) - -let force = - let doc = "Force creation (destroy VM with same name if it exists)" in - Arg.(value & flag & info [ "force" ] ~doc) - -let compress_level = - let doc = "Compression level (0 for no compression)" in - Arg.(value & opt int 4 & info [ "compression-level" ] ~doc) - -let cmd = - Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)), - Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" - -let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 (* (c) 2017 Hannes Mehnert, all rights reserved *) - +(* open Vmm_provision open Vmm_asn @@ -129,4 +94,41 @@ let cmd = Term.(ret (const jump $ setup_log $ nam $ key $ vms $ mem $ cpus $ block $ bridge)), Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" +let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 + *) +open Cmdliner +open Vmm_cli + +let cpu = + let doc = "CPUid" in + Arg.(required & pos 3 (some int) None & info [] ~doc) + +let image = + let doc = "Image file to provision" in + Arg.(required & pos 1 (some file) None & info [] ~doc) + +let args = + let doc = "Boot arguments" in + Arg.(value & opt_all string [] & info [ "arg" ] ~doc) + +let block = + let doc = "Block device name" in + Arg.(value & opt (some string) None & info [ "block" ] ~doc) + +let net = + let doc = "Network device" in + Arg.(value & opt_all string [] & info [ "net" ] ~doc) + +let force = + let doc = "Force creation (destroy VM with same name if it exists)" in + Arg.(value & flag & info [ "force" ] ~doc) + +let compress_level = + let doc = "Compression level (0 for no compression)" in + Arg.(value & opt int 4 & info [ "compression-level" ] ~doc) + +let cmd = + Term.(ret (const jump $ setup_log $ nam $ key $ image $ mem $ cpu $ args $ block $ net $ force $ compress_level)), + Term.info "vmmp_csr" ~version:"%%VERSION_NUM%%" + let () = match Term.eval cmd with `Ok () -> exit 0 | _ -> exit 1 diff --git a/app/vmmp_sign.ml b/app/vmmp_sign.ml index 0a509eb..525d4e3 100644 --- a/app/vmmp_sign.ml +++ b/app/vmmp_sign.ml @@ -71,6 +71,7 @@ let jump _ db cacert cakey csrname days = | Error (`Msg e) -> `Error (false, e) open Cmdliner +open Vmm_cli let csr = let doc = "signing request" in diff --git a/src/vmm_lwt.ml b/src/vmm_lwt.ml index fc59ec8..d8ab4bc 100644 --- a/src/vmm_lwt.ml +++ b/src/vmm_lwt.ml @@ -105,3 +105,28 @@ let safe_close fd = Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit) + +let read_from_file file = + Lwt.catch (fun () -> + Lwt_unix.stat file >>= fun stat -> + let size = stat.Lwt_unix.st_size in + Lwt_unix.openfile file Lwt_unix.[O_RDONLY] 0 >>= fun fd -> + Lwt.catch (fun () -> + let buf = Bytes.create size in + let rec read off = + Lwt_unix.read fd buf off (size - off) >>= fun bytes -> + if bytes + off = size then + Lwt.return_unit + else + read (bytes + off) + in + read 0 >>= fun () -> + safe_close fd >|= fun () -> + Cstruct.of_bytes buf) + (fun e -> + Logs.err (fun m -> m "exception %s while reading %s" (Printexc.to_string e) file) ; + safe_close fd >|= fun () -> + Cstruct.empty)) + (fun e -> + Logs.err (fun m -> m "exception %s while reading %s" (Printexc.to_string e) file) ; + Lwt.return Cstruct.empty) diff --git a/src/vmm_lwt.mli b/src/vmm_lwt.mli index ae7445e..c4a9416 100644 --- a/src/vmm_lwt.mli +++ b/src/vmm_lwt.mli @@ -20,3 +20,5 @@ val write_wire : Lwt_unix.file_descr -> Vmm_commands.wire -> (unit, [> `Exception ]) result Lwt.t val safe_close : Lwt_unix.file_descr -> unit Lwt.t + +val read_from_file : string -> Cstruct.t Lwt.t diff --git a/src/vmm_tls.ml b/src/vmm_tls.ml index 2000cb7..581ba25 100644 --- a/src/vmm_tls.ml +++ b/src/vmm_tls.ml @@ -3,7 +3,13 @@ open Rresult open Rresult.R.Infix -let name cert = X509.common_name_to_string cert +(* we skip all non-albatross certificates *) +let name chain = + List.fold_left (fun acc cert -> + match X509.Extension.unsupported cert Vmm_asn.oid with + | None -> acc + | Some _ -> X509.common_name_to_string cert :: acc) + [] chain (* this separates the leaf and top-level certificate from the chain, and also reverses the intermediates (to be (leaf, CA -> subCA -> subCA') @@ -39,13 +45,12 @@ let wire_command_of_cert version cert = *) let handle _addr version chain = - separate_chain chain >>= fun (leaf, chain) -> - let prefix = List.map name chain in - let name = prefix @ [ name leaf ] in + separate_chain chain >>= fun (leaf, rest) -> + let name = name chain in Logs.debug (fun m -> m "leaf is %s, chain %a" (X509.common_name_to_string leaf) Fmt.(list ~sep:(unit " -> ") string) - (List.map X509.common_name_to_string chain)) ; + (List.map X509.common_name_to_string rest)) ; (* TODO: inspect top-level-cert of chain. *) (* TODO: logging let login_hdr, login_ev = Log.hdr name, `Login addr in *) (* TODO: update policies (parse chain for policy, and apply them)! *)