├── .gitignore ├── .merlin ├── .travis-test.sh ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── README.md ├── _tags ├── opam ├── pkg ├── META └── pkg.ml └── tlsclient.ml /.gitignore: -------------------------------------------------------------------------------- 1 | # ocamlbuild working directory 2 | _build/ 3 | 4 | # ocamlbuild targets 5 | *.byte 6 | *.native 7 | *.install 8 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | B _build/** 2 | 3 | PKG tls x509 nocrypto lwt hex cmdliner sexplib lwt.unix tls.lwt nocrypto.lwt ptime 4 | 5 | -------------------------------------------------------------------------------- /.travis-test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh -x 2 | 3 | eval `opam config env` 4 | tlsclient -z www.ccc.de:443 5 | tlsclient -z mirage.io:443 6 | tlsclient -z --starttls xmpp jabber.ccc.de:5222 7 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 3 | script: bash -ex .travis-opam.sh 4 | sudo: required 5 | env: 6 | global: 7 | - TESTS=false 8 | - PACKAGE="tlsclient" 9 | - POST_INSTALL_HOOK="./.travis-test.sh" 10 | matrix: 11 | - OCAML_VERSION=4.08 12 | - OCAML_VERSION=4.09 13 | - OCAML_VERSION=4.10 14 | notifications: 15 | email: false 16 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hannesm/tlsclient/781e2f7a0467fa68cc103fa3b9c3e8e26be467e5/CHANGES.md -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Hannes Mehnert 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright notice, 11 | this list of conditions and the following disclaimer in the documentation 12 | and/or other materials provided with the distribution. 13 | 14 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 15 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 17 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 18 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 20 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 21 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 22 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 23 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 24 | 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://travis-ci.org/hannesm/tlsclient.svg?branch=master)](https://travis-ci.org/hannesm/tlsclient) 2 | 3 | A command-line tls client, similar to `openssl -s_client` 4 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : color(always), bin_annot, safe_string, principal 2 | true : warn(+A-44-58) 3 | 4 | : package(tls x509 mirage-crypto-pk lwt hex cmdliner sexplib lwt.unix tls.lwt mirage-crypto-rng.lwt ptime ptime.clock.os fmt domain-name logs.fmt logs.cli fmt.cli fmt.tty), thread 5 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "tlsclient" 3 | maintainer: "Hannes Mehnert " 4 | authors: "Hannes Mehnert " 5 | license: "BSD2" 6 | homepage: "https://github.com/hannesm/tlsclient" 7 | bug-reports: "https://github.com/hannesm/tlsclient/issues" 8 | depends: [ 9 | "ocaml" {>= "4.04.2"} 10 | "ocamlfind" {build} 11 | "ocamlbuild" {build} 12 | "topkg" {build} 13 | "tls" {>= "0.9.0"} 14 | "x509" {>= "0.7.0"} 15 | "lwt" 16 | "sexplib" 17 | "cmdliner" 18 | "hex" {>= "0.2.0"} 19 | "ptime" 20 | "fmt" 21 | "domain-name" {>= "0.3.0"} 22 | "mirage-crypto-rng" {>= "0.7.0"} 23 | "mirage-crypto-pk" 24 | "logs" 25 | ] 26 | build: ["ocaml" "pkg/pkg.ml" "build" "--pinned" "%{pinned}%"] 27 | dev-repo: "git+https://github.com/hannesm/tlsclient.git" 28 | synopsis: "A command-line TLS client" 29 | description: """ 30 | A command-line TLS client, similar to `openssl -s_client` using the TLS 31 | implementation native to OCaml. 32 | """ 33 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | description = "A TLS client using OCaml-TLS" 2 | version = "%%VERSION_NUM%%" 3 | requires = "tls x509 nocrypto lwt hex cmdliner sexplib lwt.unix tls.lwt nocrypto.lwt ptime" 4 | -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let () = 7 | Pkg.describe "tlsclient" @@ fun _c -> 8 | Ok [ Pkg.bin "tlsclient" ] 9 | -------------------------------------------------------------------------------- /tlsclient.ml: -------------------------------------------------------------------------------- 1 | 2 | open Lwt.Infix 3 | 4 | let indent s n = 5 | let padl = max 0 (n - String.length s) in 6 | let pad = String.make padl ' ' in 7 | s ^ pad 8 | 9 | let tls_info t = 10 | let epoch = 11 | match Tls_lwt.Unix.epoch t with 12 | | `Ok data -> data 13 | | `Error -> assert false 14 | in 15 | let hex x = Hex.of_cstruct x in 16 | let version = Sexplib.Sexp.to_string_hum (Tls.Core.sexp_of_tls_version epoch.Tls.Core.protocol_version) 17 | and cipher = Sexplib.Sexp.to_string_hum (Tls.Ciphersuite.sexp_of_ciphersuite epoch.Tls.Core.ciphersuite) 18 | and `Hex master = hex epoch.Tls.Core.master_secret 19 | and pp_certs certs = List.flatten (List.map (fun x -> 20 | let hash = `SHA256 in 21 | let `Hex cert_fp = hex (X509.Certificate.fingerprint hash x) 22 | and `Hex key_fp = hex X509.(Public_key.fingerprint ~hash (Certificate.public_key x)) in 23 | [ "subject=" ^ Fmt.to_to_string X509.Distinguished_name.pp (X509.Certificate.subject x) ; 24 | "issuer=" ^ Fmt.to_to_string X509.Distinguished_name.pp (X509.Certificate.issuer x) ; 25 | "certificate sha256 fingerprint: " ^ cert_fp ; 26 | "public key sha256 fingerprint: " ^ key_fp ^ "\n" 27 | ]) certs) 28 | and trust = 29 | match epoch.Tls.Core.trust_anchor with 30 | | None -> "NONE" 31 | | Some x -> Fmt.to_to_string X509.Distinguished_name.pp (X509.Certificate.subject x) 32 | and pubkeysize = string_of_int (match epoch.Tls.Core.peer_certificate with 33 | | None -> 0 34 | | Some x -> match X509.Certificate.public_key x with 35 | | `RSA p -> Mirage_crypto_pk.Rsa.pub_bits p 36 | | _ -> 0) 37 | and server_time = 38 | let peer_random = epoch.Tls.Core.peer_random in 39 | let time = Cstruct.BE.get_uint32 peer_random 0 in 40 | let str = "raw: " ^ (Int32.to_string time) in 41 | match Ptime.of_float_s (Int32.to_float time) with 42 | | None -> str 43 | | Some t -> (Ptime.to_rfc3339 t) ^ " (" ^ str ^ ")" 44 | in 45 | let cert = match epoch.Tls.Core.peer_certificate with None -> [] | Some x -> [x] in 46 | let chain, certs = match epoch.Tls.Core.trust_anchor with 47 | | None -> "received", epoch.Tls.Core.received_certificates 48 | | Some _ -> "chain", epoch.Tls.Core.peer_certificate_chain 49 | in 50 | String.concat "\n" (List.map (fun (k, v) -> 51 | (indent k 9) ^ ": " ^ String.concat (indent "\n" 12) v) 52 | [ ("protocol", [version]) ; 53 | ("timestamp", [server_time]); 54 | ("cipher", [cipher]) ; 55 | ("master", [master]) ; 56 | ("keysize", [pubkeysize]) ; 57 | (chain, pp_certs certs) ; 58 | ("server", pp_certs cert) ; 59 | ("anchor", [trust]) ]) 60 | 61 | let rec read_write buf ic oc = 62 | Lwt.catch (fun () -> 63 | Lwt_io.read_into ic buf 0 4096 >>= fun l -> 64 | if l > 0 then 65 | let s = Bytes.sub buf 0 l in 66 | Lwt_io.write_from oc s 0 l >>= fun _n -> 67 | read_write buf ic oc 68 | else 69 | Lwt.return_unit) 70 | (fun _ -> Lwt.return_unit) 71 | 72 | 73 | let client zero_io cas cfingerprint pfingerprint starttls hostname port cert key = 74 | begin match starttls with 75 | | Some "xmpp" | None -> () 76 | | Some s -> failwith ("Invalid argument to --starttls: " ^ s) 77 | end ; 78 | Mirage_crypto_rng_lwt.initialize () >>= fun () -> 79 | let domain_name = Domain_name.(of_string_exn hostname |> host_exn) in 80 | (match cas, cfingerprint, pfingerprint with 81 | | None, None, None -> 82 | Printf.printf "WARNING: Unauthenticated TLS connection\n" ; 83 | Lwt.return (fun ~host:_ _ -> Ok None) 84 | | Some _ , Some _, _ 85 | | Some _ , _, Some _ 86 | | _ , Some _, Some _ -> 87 | failwith "Error; multiple authentication methods were supplied, I cannot handle this" 88 | | None, Some hex_fp, None -> 89 | let time () = Some (Ptime_clock.now ()) in 90 | let fp = 91 | Cstruct.of_hex (String.map (function ':' -> ' ' | x -> x) hex_fp) 92 | in 93 | let fingerprints = [ domain_name, fp ] 94 | and hash = `SHA256 95 | in 96 | Lwt.return (X509.Authenticator.server_cert_fingerprint ~time ~hash ~fingerprints) 97 | | None, None, Some hex_fp -> X509_lwt.authenticator (`Hex_key_fingerprints (`SHA256 , [ domain_name, hex_fp ])) 98 | | Some ca, None, None -> 99 | let auth = if Sys.is_directory ca then `Ca_dir ca else `Ca_file ca in 100 | X509_lwt.authenticator auth) >>= fun authenticator -> 101 | Lwt.catch (fun () -> 102 | Lwt_unix.gethostbyname hostname >>= fun host_entry -> 103 | let host_inet_addr = Array.get host_entry.Lwt_unix.h_addr_list 0 in 104 | let fd = Lwt_unix.socket host_entry.Lwt_unix.h_addrtype Lwt_unix.SOCK_STREAM 0 in 105 | Lwt_unix.connect fd (Lwt_unix.ADDR_INET (host_inet_addr, port)) >>= fun _ -> 106 | (match starttls with 107 | | Some "xmpp" -> 108 | let send_lwt buf = Lwt_unix.send fd buf 0 Bytes.(length buf) [] in 109 | let rec recv_lwt buf offset = 110 | Lwt_unix.recv fd buf offset Bytes.((length buf)-offset) [] >>= fun i -> 111 | if i <> 50 then recv_lwt buf (offset + i) else Lwt.return 0 112 | (* looking for "" *) 113 | in 114 | let read_buffer = Bytes.make 4096 '\x00' 115 | and starttls_buf_1 = String.concat "" [ 116 | "" ] 118 | in 119 | send_lwt (Bytes.of_string starttls_buf_1) >>= fun _ -> 120 | send_lwt (Bytes.of_string "") >>= fun _ -> 121 | recv_lwt read_buffer 0 122 | | None | _ -> Lwt.return 0) >>= fun _ -> 123 | (match cert, key with 124 | | None, _ | _, None -> Lwt.return `None 125 | | Some cert, Some priv_key -> X509_lwt.private_of_pems ~cert ~priv_key >|= fun x -> `Single x) >>= fun certificates -> 126 | let client = Tls.Config.client ~certificates ~authenticator () in 127 | Tls_lwt.Unix.client_of_fd client ~host:hostname fd >>= fun t -> 128 | let tls_info = tls_info t in 129 | Printf.printf "%s\n%!" tls_info ; 130 | 131 | if zero_io then 132 | Lwt.return_unit 133 | else 134 | let ic, oc = Tls_lwt.of_t t in 135 | (* do reading and writing of stuff! *) 136 | let pic = Lwt_io.stdin 137 | and poc = Lwt_io.stdout 138 | in 139 | Lwt.join [ 140 | read_write (Bytes.create 4096) ic poc ; 141 | read_write (Bytes.create 4096) pic oc 142 | ] 143 | ) 144 | (fun exn -> 145 | Printf.printf "failed to establish TLS connection: %s\n" (Printexc.to_string exn) ; 146 | Lwt.return_unit) 147 | 148 | let run_client _ zero_io cas cfingerprint pfingerprint starttls (host, port) cert key = 149 | Printexc.register_printer (function 150 | | Tls_lwt.Tls_alert x -> Some ("TLS alert: " ^ Tls.Packet.alert_type_to_string x) 151 | | Tls_lwt.Tls_failure f -> Some ("TLS failure: " ^ Tls.Engine.string_of_failure f) 152 | | _ -> None) ; 153 | Sys.(set_signal sigpipe Signal_ignore) ; 154 | Lwt_main.run (client zero_io cas cfingerprint pfingerprint starttls host port cert key) 155 | 156 | let setup_log style_renderer level = 157 | Fmt_tty.setup_std_outputs ?style_renderer (); 158 | Logs.set_level level; 159 | Logs.set_reporter (Logs_fmt.reporter ~dst:Format.std_formatter ()) 160 | 161 | open Cmdliner 162 | 163 | let setup_log = 164 | Term.(const setup_log 165 | $ Fmt_cli.style_renderer () 166 | $ Logs_cli.level ()) 167 | 168 | let host_port : (string * int) Arg.converter = 169 | let parse s = 170 | try 171 | let open String in 172 | let colon = index s ':' in 173 | let hostname = sub s 0 colon 174 | and port = 175 | let csucc = succ colon in 176 | sub s csucc (length s - csucc) 177 | in 178 | `Ok (hostname, int_of_string port) 179 | with 180 | Not_found -> `Error "broken" 181 | in 182 | parse, fun ppf (h, p) -> Format.fprintf ppf "%s:%d" h p 183 | 184 | let destination = 185 | Arg.(required & pos 0 (some host_port) None & info [] ~docv:"destination" 186 | ~doc:"the destination hostname:port to connect to") 187 | 188 | let cas = 189 | Arg.(value & opt (some string) None & info ["ca"] ~docv:"FILE" 190 | ~doc:"The full path to PEM encoded certificate authorities. Can either be a FILE or a DIRECTORY.") 191 | 192 | let zero_io = 193 | let doc = "zero-I/O mode [terminate after printing session info]" in 194 | Arg.(value & flag & info ["z"; "zero-io"] ~doc) 195 | 196 | let cfingerprint = 197 | let doc = "Authenticate the host's certificate using a user-supplied SHA256 fingerprint" in 198 | Arg.(value & opt (some string) None & info ["cert-fingerprint"] ~docv:"SHA256_HEX" ~doc) 199 | 200 | let pfingerprint = 201 | let doc = "Authenticate the host's public key using a user-supplied SHA256 fingerprint" in 202 | Arg.(value & opt (some string) None & info ["key-fingerprint"] ~docv:"SHA256_HEX" ~doc) 203 | 204 | let starttls = 205 | let doc = "Initiate connection using STARTTLS. Currently supported protocols: [xmpp]" in 206 | Arg.(value & opt (some string) None & info ["starttls"] ~docv:"[xmpp]" ~doc) 207 | 208 | let client_cert = 209 | let doc = "Use a client certificate chain" in 210 | Arg.(value & opt (some file) None & info ["cert"] ~doc) 211 | 212 | let client_key = 213 | let doc = "Use a client key" in 214 | Arg.(value & opt (some file) None & info ["key"] ~doc) 215 | 216 | let cmd = 217 | let doc = "TLS client" in 218 | let man = [ 219 | `S "DESCRIPTION" ; 220 | `P "$(tname) connects to a server and initiates a TLS handshake" ; 221 | `P "Information about the TLS session is printed, including trust anchor and chain of trust (if applicable), otherwise list of received certificates."; 222 | `S "BUGS" ; 223 | `P "Please report bugs on the issue tracker at " ; 224 | `S "SEE ALSO" ; 225 | `P "$(b,s_client)(1)" ] 226 | in 227 | Term.(pure run_client $ setup_log $ zero_io $ cas $ cfingerprint $ pfingerprint $ starttls $ destination $ client_cert $ client_key), 228 | Term.info "tlsclient" ~version:"%%VERSION_NUM%%" ~doc ~man 229 | 230 | let () = 231 | match Term.eval cmd 232 | with `Error _ -> exit 1 | _ -> exit 0 233 | --------------------------------------------------------------------------------