{-# LANGUAGE TypeApplications #-}
module Ssl.Util
(
verifyFingerprint,
rsaFingerprint,
verifyRsaFingerprint,
rsaCiphers,
withVerifiedSslConnection,
)
where
import Control.Exception
import Data.ByteString.Builder
import Data.Byteable (constEqBytes)
import Data.Dynamic (fromDynamic)
import Data.Time.Clock (getCurrentTime)
import Imports
import Network.HTTP.Client.Internal
import OpenSSL.BN (integerToMPI)
import OpenSSL.EVP.Digest (Digest, digestLBS)
import OpenSSL.EVP.PKey (SomePublicKey, toPublicKey)
import OpenSSL.EVP.Verify (VerifyStatus (..))
import OpenSSL.RSA
import OpenSSL.Session as SSL
import OpenSSL.X509 as X509
rsaCiphers :: String
rsaCiphers :: String
rsaCiphers =
String -> ShowS
showString String
"ECDHE-RSA-AES256-GCM-SHA384,"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"ECDHE-RSA-AES128-GCM-SHA256,"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"ECDHE-RSA-CHACHA20-POLY1305,"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"DHE-RSA-AES256-GCM-SHA384,"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"DHE-RSA-AES128-GCM-SHA256,"
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"DHE-RSA-CHACHA20-POLY1305"
ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
""
data PinPubKeyException
=
PinMissingCert
|
PinInvalidCert
|
PinInvalidPubKey
|
PinFingerprintMismatch
deriving (PinPubKeyException -> PinPubKeyException -> Bool
(PinPubKeyException -> PinPubKeyException -> Bool)
-> (PinPubKeyException -> PinPubKeyException -> Bool)
-> Eq PinPubKeyException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PinPubKeyException -> PinPubKeyException -> Bool
== :: PinPubKeyException -> PinPubKeyException -> Bool
$c/= :: PinPubKeyException -> PinPubKeyException -> Bool
/= :: PinPubKeyException -> PinPubKeyException -> Bool
Eq, Int -> PinPubKeyException -> ShowS
[PinPubKeyException] -> ShowS
PinPubKeyException -> String
(Int -> PinPubKeyException -> ShowS)
-> (PinPubKeyException -> String)
-> ([PinPubKeyException] -> ShowS)
-> Show PinPubKeyException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PinPubKeyException -> ShowS
showsPrec :: Int -> PinPubKeyException -> ShowS
$cshow :: PinPubKeyException -> String
show :: PinPubKeyException -> String
$cshowList :: [PinPubKeyException] -> ShowS
showList :: [PinPubKeyException] -> ShowS
Show)
instance Exception PinPubKeyException
verifyFingerprint ::
(SomePublicKey -> IO (Maybe ByteString)) ->
[ByteString] ->
SSL ->
IO ()
verifyFingerprint :: (SomePublicKey -> IO (Maybe ByteString))
-> [ByteString] -> SSL -> IO ()
verifyFingerprint SomePublicKey -> IO (Maybe ByteString)
hash [ByteString]
fprs SSL
ssl = do
X509
cert <- SSL -> IO (Maybe X509)
SSL.getPeerCertificate SSL
ssl IO (Maybe X509) -> (Maybe X509 -> IO X509) -> IO X509
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO X509 -> (X509 -> IO X509) -> Maybe X509 -> IO X509
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PinPubKeyException -> IO X509
forall e a. Exception e => e -> IO a
throwIO PinPubKeyException
PinMissingCert) X509 -> IO X509
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
SomePublicKey
pkey <- X509 -> IO SomePublicKey
X509.getPublicKey X509
cert
Maybe ByteString
mfpr <- SomePublicKey -> IO (Maybe ByteString)
hash SomePublicKey
pkey
case Maybe ByteString
mfpr of
Maybe ByteString
Nothing -> PinPubKeyException -> IO ()
forall e a. Exception e => e -> IO a
throwIO PinPubKeyException
PinInvalidPubKey
Just ByteString
fp -> do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
forall a. Byteable a => a -> a -> Bool
constEqBytes ByteString
fp) [ByteString]
fprs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
PinPubKeyException -> IO ()
forall e a. Exception e => e -> IO a
throwIO PinPubKeyException
PinFingerprintMismatch
Bool
vok <- SSL -> IO Bool
SSL.getVerifyResult SSL
ssl
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
vok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
VerifyStatus
self <- X509 -> SomePublicKey -> IO VerifyStatus
forall key. PublicKey key => X509 -> key -> IO VerifyStatus
verifyX509 X509
cert SomePublicKey
pkey
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (VerifyStatus
self VerifyStatus -> VerifyStatus -> Bool
forall a. Eq a => a -> a -> Bool
== VerifyStatus
VerifySuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
PinPubKeyException -> IO ()
forall e a. Exception e => e -> IO a
throwIO PinPubKeyException
PinInvalidCert
UTCTime
now <- IO UTCTime
getCurrentTime
UTCTime
notBefore <- X509 -> IO UTCTime
X509.getNotBefore X509
cert
UTCTime
notAfter <- X509 -> IO UTCTime
X509.getNotAfter X509
cert
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
notBefore Bool -> Bool -> Bool
&& UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
notAfter) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
PinPubKeyException -> IO ()
forall e a. Exception e => e -> IO a
throwIO PinPubKeyException
PinInvalidCert
rsaFingerprint :: (RSAKey k) => Digest -> k -> IO ByteString
rsaFingerprint :: forall k. RSAKey k => Digest -> k -> IO ByteString
rsaFingerprint Digest
d k
k = (Builder -> ByteString) -> IO Builder -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Digest -> ByteString -> ByteString
digestLBS Digest
d (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString) (IO Builder -> IO ByteString) -> IO Builder -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
let s :: Int
s = k -> Int
forall k. RSAKey k => k -> Int
rsaSize k
k
ByteString
n <- Integer -> IO ByteString
integerToMPI (k -> Integer
forall k. RSAKey k => k -> Integer
rsaN k
k)
ByteString
e <- Integer -> IO ByteString
integerToMPI (k -> Integer
forall k. RSAKey k => k -> Integer
rsaE k
k)
Builder -> IO Builder
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder -> IO Builder) -> Builder -> IO Builder
forall a b. (a -> b) -> a -> b
$! Int -> Builder
intDec Int
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
e
verifyRsaFingerprint :: Digest -> [ByteString] -> SSL -> IO ()
verifyRsaFingerprint :: Digest -> [ByteString] -> SSL -> IO ()
verifyRsaFingerprint Digest
d = (SomePublicKey -> IO (Maybe ByteString))
-> [ByteString] -> SSL -> IO ()
verifyFingerprint ((SomePublicKey -> IO (Maybe ByteString))
-> [ByteString] -> SSL -> IO ())
-> (SomePublicKey -> IO (Maybe ByteString))
-> [ByteString]
-> SSL
-> IO ()
forall a b. (a -> b) -> a -> b
$ \SomePublicKey
pk ->
case SomePublicKey -> Maybe RSAPubKey
forall k. PublicKey k => SomePublicKey -> Maybe k
toPublicKey SomePublicKey
pk of
Maybe RSAPubKey
Nothing -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
Just RSAPubKey
k -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Digest -> RSAPubKey -> IO ByteString
forall k. RSAKey k => Digest -> k -> IO ByteString
rsaFingerprint Digest
d (RSAPubKey
k :: RSAPubKey)
withVerifiedSslConnection ::
(SSL -> IO ()) ->
Manager ->
(Request -> Request) ->
(Request -> IO a) ->
IO a
withVerifiedSslConnection :: forall a.
(SSL -> IO ())
-> Manager -> (Request -> Request) -> (Request -> IO a) -> IO a
withVerifiedSslConnection SSL -> IO ()
verify Manager
man Request -> Request
reqBuilder Request -> IO a
act =
Request -> Manager -> Reuse -> (Managed Connection -> IO a) -> IO a
forall a.
Request -> Manager -> Reuse -> (Managed Connection -> IO a) -> IO a
withConnection' Request
req Manager
man Reuse
Reuse ((Managed Connection -> IO a) -> IO a)
-> (Managed Connection -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Managed Connection
mConn -> do
let conn :: Connection
conn = Managed Connection -> Connection
forall resource. Managed resource -> resource
managedResource Managed Connection
mConn
seen :: Bool
seen = Managed Connection -> Bool
forall resource. Managed resource -> Bool
managedReused Managed Connection
mConn
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
seen (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ case forall a. Typeable a => Dynamic -> Maybe a
fromDynamic @SSL (Connection -> Dynamic
connectionRaw Connection
conn) of
Maybe SSL
Nothing -> String -> IO ()
forall a. HasCallStack => String -> a
error (String
"withVerifiedSslConnection: only SSL allowed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Request -> String
forall a. Show a => a -> String
show Request
req)
Just SSL
ssl -> SSL -> IO ()
verify SSL
ssl
Request -> IO a
act Request
req {connectionOverride = Just mConn}
where
req :: Request
req = Request -> Request
reqBuilder Request
defaultRequest