summaryrefslogblamecommitdiff
path: root/gemini/tlsUtils.ml
blob: 0a3f59d5bc99092cf77cbab3527b63cb5e840256 (plain) (tree)
1
2
3
4
5
6
7
8
9

                       
                                             
                                                 
                                     


                               
                                                  



                                            
 


                                                                   



                             
                                             
                                                 
                                     
 
                                   






                                               











                                                                    
 

                                                                             


                                        
                                        

                                                            
                                                                    
   
module type TLS_UTILS =
sig
  type authenticator = X509_lwt.authenticator
  type ciphers = Tls.Ciphersuite.ciphersuite list
  type own_cert = Tls.Config.own_cert

  val null_auth : authenticator

  val ca : Lwt_io.file_name -> authenticator Lwt.t

  val self_sign : ?bits:int -> ?days:int
    -> X509.Distinguished_name.t
    -> (Tls.Config.certchain, string) result

  val connect : authenticator:authenticator -> ?peer_name:string ->
    ?ciphers:ciphers -> ?own_cert:own_cert -> string * int
    -> (Lwt_io.input_channel * Lwt_io.output_channel) Lwt.t
end

module TlsUtils : TLS_UTILS =
struct
  type authenticator = X509_lwt.authenticator
  type ciphers = Tls.Ciphersuite.ciphersuite list
  type own_cert = Tls.Config.own_cert

  let null_auth ~host:_ _ = Ok None

  let ca path = if Sys.is_directory path then
      X509_lwt.authenticator (`Ca_dir path)
    else
      X509_lwt.authenticator (`Ca_file path)

  let self_sign ?(bits=2048) ?(days=1) dnames =
    let priv = Mirage_crypto_pk.Rsa.generate ~bits:bits () in
    let csr = X509.Signing_request.create dnames (`RSA priv) in
    let valid_from : Ptime.t = Ptime_clock.now () in
    let valid_span = Ptime.Span.of_int_s (days * 24 * 60 * 60) in
    let open Base in
    let open Result.Monad_infix in
     Result.of_option (Ptime.add_span valid_from valid_span)
       ~error:"exceeds posix time range" >>= (fun valid_until ->
        match X509.Signing_request.sign csr ~valid_from ~valid_until
                (`RSA priv) dnames with
        | Ok cert -> Ok ([cert], priv)
        | Error _ -> Error "Unable to sign")

  let connect ~authenticator ?peer_name ?(ciphers=Tls.Config.Ciphers.default)
      ?(own_cert=`None) (host, port) =
    let peer_name = match peer_name with
      | Some name -> name
      | None -> host in
    let authenticator = authenticator in
      Tls_lwt.connect_ext
      Tls.Config.(client ~peer_name:peer_name ~authenticator
                    ~ciphers ~certificates:own_cert ()) (host, port)
end