{-# LINE 1 "src/Hookup/OpenSSL.hsc" #-}
{-# Language CApiFFI #-}
{-|
Module      : Hookup.OpenSSL
Description : Hack into the internals of OpenSSL to add missing functionality
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com
-}






{-# LINE 17 "src/Hookup/OpenSSL.hsc" #-}

module Hookup.OpenSSL (withDefaultPassword, installVerification, getPubKeyDer, contextSetTls13Ciphers) where

import           Control.Exception (bracket, bracket_)
import           Control.Monad (when)
import           Foreign.C (CStringLen, CString(..), CSize(..), CUInt(..), CInt(..), withCString, withCStringLen, CChar(..))
import           Foreign.Ptr (FunPtr, Ptr, castPtr, nullPtr, nullFunPtr)
import           Foreign.StablePtr (StablePtr, deRefStablePtr, castPtrToStablePtr)
import           Foreign.Marshal (with)
import           OpenSSL.Session (SSLContext, SSLContext_, withContext)
import           OpenSSL.X509 (withX509Ptr, X509, X509_)
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Unsafe as Unsafe

------------------------------------------------------------------------
-- Bindings to password callback
------------------------------------------------------------------------

foreign import ccall unsafe "hookup_new_userdata"
  hookup_new_userdata :: CString -> CInt -> IO (Ptr ())

foreign import ccall unsafe "hookup_free_userdata"
  hookup_free_userdata :: Ptr () -> IO ()

foreign import ccall "&hookup_pem_passwd_cb"
  hookup_pem_passwd_cb :: FunPtr PemPasswdCb

-- int pem_passwd_cb(char *buf, int size, int rwflag, void *userdata);
type PemPasswdCb = Ptr CChar -> CInt -> CInt -> Ptr () -> IO CInt

-- void SSL_CTX_set_default_passwd_cb(SSL_CTX *ctx, pem_password_cb *cb);
foreign import ccall unsafe "SSL_CTX_set_default_passwd_cb"
  sslCtxSetDefaultPasswdCb :: Ptr SSLContext_ -> FunPtr PemPasswdCb -> IO ()

-- void SSL_CTX_set_default_passwd_cb_userdata(SSL_CTX *ctx, void *u);
foreign import ccall unsafe "SSL_CTX_set_default_passwd_cb_userdata"
  sslCtxSetDefaultPasswdCbUserdata ::
    Ptr SSLContext_ -> Ptr a -> IO ()

withDefaultPassword :: SSLContext -> Maybe ByteString -> IO a -> IO a
withDefaultPassword :: forall a. SSLContext -> Maybe ByteString -> IO a -> IO a
withDefaultPassword SSLContext
ctx Maybe ByteString
mbBs IO a
m =
  forall {t} {a}.
Num t =>
Maybe ByteString -> (Ptr CChar -> t -> IO a) -> IO a
withCPassword Maybe ByteString
mbBs forall a b. (a -> b) -> a -> b
$ \Ptr CChar
ptr CInt
len ->
  forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (Ptr CChar -> CInt -> IO (Ptr ())
hookup_new_userdata Ptr CChar
ptr CInt
len) Ptr () -> IO ()
hookup_free_userdata forall a b. (a -> b) -> a -> b
$ \Ptr ()
ud ->
  forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (forall {a}. FunPtr PemPasswdCb -> Ptr a -> IO ()
setup FunPtr PemPasswdCb
hookup_pem_passwd_cb Ptr ()
ud) (forall {a}. FunPtr PemPasswdCb -> Ptr a -> IO ()
setup forall a. FunPtr a
nullFunPtr forall a. Ptr a
nullPtr) IO a
m

  where
  withCPassword :: Maybe ByteString -> (Ptr CChar -> t -> IO a) -> IO a
withCPassword Maybe ByteString
Nothing Ptr CChar -> t -> IO a
k = Ptr CChar -> t -> IO a
k forall a. Ptr a
nullPtr (-t
1)
  withCPassword (Just ByteString
bs) Ptr CChar -> t -> IO a
k = forall a. ByteString -> (CStringLen -> IO a) -> IO a
Unsafe.unsafeUseAsCStringLen ByteString
bs forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr, Int
len) -> Ptr CChar -> t -> IO a
k Ptr CChar
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)

  setup :: FunPtr PemPasswdCb -> Ptr a -> IO ()
setup FunPtr PemPasswdCb
cb Ptr a
ud =
    forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
ctx forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctxPtr ->
    do Ptr SSLContext_ -> FunPtr PemPasswdCb -> IO ()
sslCtxSetDefaultPasswdCb         Ptr SSLContext_
ctxPtr FunPtr PemPasswdCb
cb
       forall a. Ptr SSLContext_ -> Ptr a -> IO ()
sslCtxSetDefaultPasswdCbUserdata Ptr SSLContext_
ctxPtr Ptr a
ud

------------------------------------------------------------------------
-- Bindings to hostname verification interface
------------------------------------------------------------------------

data X509_VERIFY_PARAM_
data {-# CTYPE "openssl/ssl.h" "X509_PUBKEY" #-} X509_PUBKEY_
data {-# CTYPE "openssl/ssl.h" "X509" #-} X509__

-- X509_VERIFY_PARAM *SSL_CTX_get0_param(SSL_CTX *ctx);
foreign import ccall unsafe "SSL_CTX_get0_param"
  sslGet0Param ::
    Ptr SSLContext_ {- ^ ctx -} ->
    IO (Ptr X509_VERIFY_PARAM_)

-- void X509_VERIFY_PARAM_set_hostflags(X509_VERIFY_PARAM *param, unsigned int flags);
foreign import ccall unsafe "X509_VERIFY_PARAM_set_hostflags"
  x509VerifyParamSetHostflags ::
    Ptr X509_VERIFY_PARAM_ {- ^ param -} ->
    CUInt                  {- ^ flags -} ->
    IO ()

-- int X509_VERIFY_PARAM_set1_host(X509_VERIFY_PARAM *param, const char *name, size_t namelen);
foreign import ccall unsafe "X509_VERIFY_PARAM_set1_host"
  x509VerifyParamSet1Host ::
    Ptr X509_VERIFY_PARAM_ {- ^ param                -} ->
    CString                {- ^ name                 -} ->
    CSize                  {- ^ namelen              -} ->
    IO CInt                {- ^ 1 success, 0 failure -}

-- int X509_VERIFY_PARAM_set1_ip_asc(X509_VERIFY_PARAM *param, const char *ipasc);
foreign import ccall unsafe "X509_VERIFY_PARAM_set1_ip_asc"
  x509VerifyParamSet1IpAsc ::
    Ptr X509_VERIFY_PARAM_ {- ^ param                -} ->
    CString                {- ^ IP address as string -} ->
    IO CInt                {- ^ 1 success, 0 failure -}

-- X509_PUBKEY *X509_get_X509_PUBKEY(X509 *x);
foreign import capi unsafe "openssl/x509.h X509_get_X509_PUBKEY"
  x509getX509Pubkey ::
    Ptr X509__ -> IO (Ptr X509_PUBKEY_)

-- int i2d_X509_PUBKEY(X509_PUBKEY *p, unsigned char **ppout);
foreign import ccall unsafe "i2d_X509_PUBKEY"
  i2dX509Pubkey ::
    Ptr X509_PUBKEY_ ->
    Ptr CString ->
    IO CInt

getPubKeyDer :: X509 -> IO ByteString
getPubKeyDer :: X509 -> IO ByteString
getPubKeyDer X509
x509 =
  forall a. X509 -> (Ptr X509_ -> IO a) -> IO a
withX509Ptr X509
x509 forall a b. (a -> b) -> a -> b
$ \Ptr X509_
x509ptr ->
  do Ptr X509_PUBKEY_
pubkey <- Ptr X509__ -> IO (Ptr X509_PUBKEY_)
x509getX509Pubkey (forall a b. Ptr a -> Ptr b
castPtr Ptr X509_
x509ptr)
     Int
len    <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr X509_PUBKEY_ -> Ptr (Ptr CChar) -> IO CInt
i2dX509Pubkey Ptr X509_PUBKEY_
pubkey forall a. Ptr a
nullPtr
     Int -> (Ptr Word8 -> IO ()) -> IO ByteString
B.create Int
len forall a b. (a -> b) -> a -> b
$ \Ptr Word8
bsPtr ->
        forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
bsPtr) forall a b. (a -> b) -> a -> b
$ \Ptr (Ptr CChar)
ptrPtr ->
           () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Ptr X509_PUBKEY_ -> Ptr (Ptr CChar) -> IO CInt
i2dX509Pubkey Ptr X509_PUBKEY_
pubkey Ptr (Ptr CChar)
ptrPtr


-- | Add hostname checking to the certificate verification step.
-- Partial wildcards matching is disabled.
installVerification :: SSLContext -> String {- ^ hostname -} -> IO ()
installVerification :: SSLContext -> String -> IO ()
installVerification SSLContext
ctx String
host =
  forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
ctx forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctxPtr ->
    do Ptr X509_VERIFY_PARAM_
param <- Ptr SSLContext_ -> IO (Ptr X509_VERIFY_PARAM_)
sslGet0Param Ptr SSLContext_
ctxPtr
       Ptr X509_VERIFY_PARAM_ -> CUInt -> IO ()
x509VerifyParamSetHostflags Ptr X509_VERIFY_PARAM_
param
         (CUInt
4)
{-# LINE 138 "src/Hookup/OpenSSL.hsc" #-}

       CInt
ip_success <-
         forall a. String -> (Ptr CChar -> IO a) -> IO a
withCString String
host forall a b. (a -> b) -> a -> b
$ \Ptr CChar
ptr ->
           Ptr X509_VERIFY_PARAM_ -> Ptr CChar -> IO CInt
x509VerifyParamSet1IpAsc Ptr X509_VERIFY_PARAM_
param Ptr CChar
ptr

       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
ip_success forall a. Eq a => a -> a -> Bool
== CInt
0) forall a b. (a -> b) -> a -> b
$
         do CInt
success <-
              forall a. String -> (CStringLen -> IO a) -> IO a
withCStringLen String
host forall a b. (a -> b) -> a -> b
$ \(Ptr CChar
ptr,Int
len) ->
                Ptr X509_VERIFY_PARAM_ -> Ptr CChar -> CSize -> IO CInt
x509VerifyParamSet1Host Ptr X509_VERIFY_PARAM_
param Ptr CChar
ptr (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)

            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
success forall a. Eq a => a -> a -> Bool
== CInt
0)
              (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to set verification host")

foreign import ccall unsafe "SSL_CTX_set_ciphersuites"
   sslCtxSetCiphersuites :: Ptr SSLContext_ -> CString -> IO CInt

-- | Set the ciphers to be used by the given context for TLS 1.3
--   https://www.openssl.org/docs/man1.1.1/man3/SSL_CTX_set_cipher_list.html
--
--   Unrecognised ciphers are ignored. If no ciphers from the list are
--   recognised, an exception is raised.
contextSetTls13Ciphers :: SSLContext -> String -> IO ()
contextSetTls13Ciphers :: SSLContext -> String -> IO ()
contextSetTls13Ciphers SSLContext
context String
list =
  forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx ->
  forall a. String -> (Ptr CChar -> IO a) -> IO a
withCString String
list    forall a b. (a -> b) -> a -> b
$ \Ptr CChar
cpath ->
  do CInt
success <- Ptr SSLContext_ -> Ptr CChar -> IO CInt
sslCtxSetCiphersuites Ptr SSLContext_
ctx Ptr CChar
cpath
     forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
success forall a. Eq a => a -> a -> Bool
== CInt
0) (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to set ciphersuites")