certificate validation on client side; check stored fingerprint on server start-up; non-optional fingerprint parsing (#234, closes #155)

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

src/Simplex/Messaging/Agent/Protocol.hs

@@ -351,11 +351,11 @@ agentMessageP =
 
 -- | SMP server location parser.
 smpServerP :: Parser SMPServer
-smpServerP = SMPServer <$> server <*> optional port <*> optional kHash
+smpServerP = SMPServer <$> server <*> optional port <*> kHash
   where
     server = B.unpack <$> A.takeWhile1 (A.notInClass ":#,; ")
     port = A.char ':' *> (B.unpack <$> A.takeWhile1 A.isDigit)
-    kHash = C.KeyHash <$> (A.char '#' *> base64P)
+    kHash = Just . C.KeyHash <$> (A.char '#' *> base64P)
 
 serializeAgentMessage :: AMessage -> ByteString
 serializeAgentMessage = \case
@@ -443,10 +443,10 @@ serializeServerUri SMPServer {host, port, keyHash} = "smp://" <> kh <> B.pack ho
 smpServerUriP :: Parser SMPServer
 smpServerUriP = do
   _ <- "smp://"
-  keyHash <- optional $ C.KeyHash <$> (U.decode <$?> A.takeTill (== '@') <* A.char '@')
+  keyHash <- C.KeyHash <$> (U.decode <$?> A.takeTill (== '@') <* A.char '@')
   host <- B.unpack <$> A.takeWhile1 (A.notInClass ":#,;/ ")
   port <- optional $ B.unpack <$> (A.char ':' *> A.takeWhile1 A.isDigit)
-  pure SMPServer {host, port, keyHash}
+  pure SMPServer {host, port, keyHash = Just keyHash}
 
 serializeConnMode :: AConnectionMode -> ByteString
 serializeConnMode (ACM cMode) = serializeConnMode' $ connMode cMode
@@ -472,7 +472,7 @@ connModeT = \case
 data SMPServer = SMPServer
   { host :: HostName,
     port :: Maybe ServiceName,
-    keyHash :: Maybe C.KeyHash
+    keyHash :: Maybe C.KeyHash -- TODO make non optional
   }
   deriving (Eq, Ord, Show)
 

src/Simplex/Messaging/Client.hs

@@ -164,7 +164,7 @@ getSMPClient smpServer cfg@SMPClientConfig {qSize, tcpTimeout, smpPing, smpBlock
       thVar <- newEmptyTMVarIO
       action <-
         async $
-          runTransportClient (host smpServer) port' (client t c thVar)
+          runTransportClient (host smpServer) port' (keyHash smpServer) (client t c thVar)
             `finally` atomically (putTMVar thVar $ Left SMPNetworkError)
       bSize <- tcpTimeout `timeout` atomically (takeTMVar thVar)
       pure $ case bSize of

src/Simplex/Messaging/Crypto.hs

@@ -98,9 +98,6 @@ module Simplex.Messaging.Crypto
     cbDecrypt,
     cbNonce,
 
-    -- * Encoding of RSA keys
-    publicKeyHash,
-
     -- * SHA256 hash
     sha256Hash,
 
@@ -493,7 +490,7 @@ instance forall a. AlgorithmI a => CryptoKey (PublicKey a) where
     _ -> True
   serializeKey k = algorithmPrefix k <> ":" <> encode (encodeKey k)
   serializeKeyUri k = algorithmPrefix k <> ":" <> U.encode (encodeKey k)
-  encodeKey = encodeASNKey . publicToX509
+  encodeKey = encodeASNObj . publicToX509
   strKeyP = pubKey' <$?> strKeyP
   strKeyUriP = pubKey' <$?> strKeyUriP
   binaryKeyP = pubKey' <$?> binaryKeyP
@@ -552,7 +549,7 @@ instance AlgorithmI a => CryptoKey (PrivateKey a) where
     _ -> True
   serializeKey k = algorithmPrefix k <> ":" <> encode (encodeKey k)
   serializeKeyUri k = algorithmPrefix k <> ":" <> U.encode (encodeKey k)
-  encodeKey = encodeASNKey . privateToX509
+  encodeKey = encodeASNObj . privateToX509
   strKeyP = privKey' <$?> strKeyP
   strKeyUriP = privKey' <$?> strKeyUriP
   binaryKeyP = privKey' <$?> binaryKeyP
@@ -812,7 +809,9 @@ newtype Key = Key {unKey :: ByteString}
 -- | IV bytes newtype.
 newtype IV = IV {unIV :: ByteString}
 
--- | Key hash newtype.
+-- | Certificate fingerpint newtype.
+--
+-- Previously was used for server's public key hash in ad-hoc transport scheme, kept as is for compatibility.
 newtype KeyHash = KeyHash {unKeyHash :: ByteString} deriving (Eq, Ord, Show)
 
 instance IsString KeyHash where
@@ -822,10 +821,6 @@ instance ToField KeyHash where toField = toField . encode . unKeyHash
 
 instance FromField KeyHash where fromField = blobFieldParser $ KeyHash <$> base64P
 
--- | Digest (hash) of binary X509 encoding of RSA public key.
-publicKeyHash :: PublicKey RSA -> KeyHash
-publicKeyHash = KeyHash . sha256Hash . encodeKey
-
 -- | SHA256 digest.
 sha256Hash :: ByteString -> ByteString
 sha256Hash = BA.convert . (hash :: ByteString -> Digest SHA256)
@@ -1075,8 +1070,8 @@ privateToX509 = \case
   PrivateKeyX25519 k -> PrivKeyX25519 k
   PrivateKeyX448 k -> PrivKeyX448 k
 
-encodeASNKey :: ASN1Object a => a -> ByteString
-encodeASNKey k = toStrict . encodeASN1 DER $ toASN1 k []
+encodeASNObj :: ASN1Object a => a -> ByteString
+encodeASNObj k = toStrict . encodeASN1 DER $ toASN1 k []
 
 -- Decoding of binary X509 'PublicKey'.
 decodePubKey :: ByteString -> Either String APublicKey

src/Simplex/Messaging/Transport.hs

@@ -35,11 +35,13 @@ module Simplex.Messaging.Transport
     runTransportServer,
     runTransportClient,
     loadTLSServerParams,
-    withTlsUnique,
+    loadFingerprint,
+    encodeFingerprint,
 
     -- * TLS 1.2 Transport
     TLS (..),
     closeTLS,
+    withTlsUnique,
 
     -- * SMP transport
     THandle (..),
@@ -61,6 +63,7 @@ import Control.Applicative ((<|>))
 import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Except (throwE)
+import qualified Crypto.Store.X509 as SX
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
@@ -73,6 +76,9 @@ import Data.Functor (($>))
 import Data.Set (Set)
 import qualified Data.Set as S
 import Data.String
+import qualified Data.X509 as X
+import qualified Data.X509.CertificateStore as XS
+import qualified Data.X509.Validation as XV
 import GHC.Generics (Generic)
 import GHC.IO.Exception (IOErrorType (..))
 import GHC.IO.Handle.Internals (ioe_EOF)
@@ -80,6 +86,7 @@ import Generic.Random (genericArbitraryU)
 import Network.Socket
 import qualified Network.TLS as T
 import qualified Network.TLS.Extra as TE
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Parsers (parseAll, parseRead1, parseString)
 import Simplex.Messaging.Util (bshow)
 import System.Exit (exitFailure)
@@ -158,7 +165,7 @@ runTransportServer started port serverParams server = do
     acceptConnection :: Socket -> IO c
     acceptConnection sock = do
       (newSock, _) <- accept sock
-      ctx <- connectTLS "server" serverParams newSock
+      ctx <- connectTLS serverParams newSock
       getServerConnection ctx
 
 startTCPServer :: TMVar Bool -> ServiceName -> IO Socket
@@ -177,13 +184,14 @@ startTCPServer started port = withSocketsDo $ resolve >>= open >>= setStarted
     setStarted sock = atomically (tryPutTMVar started True) >> pure sock
 
 -- | Connect to passed TCP host:port and pass handle to the client.
-runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> (c -> m a) -> m a
-runTransportClient host port client = do
-  c <- liftIO $ startTCPClient host port
+runTransportClient :: Transport c => MonadUnliftIO m => HostName -> ServiceName -> Maybe C.KeyHash -> (c -> m a) -> m a
+runTransportClient host port keyHash client = do
+  let clientParams = mkTLSClientParams host port keyHash
+  c <- liftIO $ startTCPClient host port clientParams
   client c `E.finally` liftIO (closeConnection c)
 
-startTCPClient :: forall c. Transport c => HostName -> ServiceName -> IO c
-startTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
+startTCPClient :: forall c. Transport c => HostName -> ServiceName -> T.ClientParams -> IO c
+startTCPClient host port clientParams = withSocketsDo $ resolve >>= tryOpen err
   where
     err :: IOException
     err = mkIOError NoSuchThing "no address" Nothing Nothing
@@ -202,7 +210,7 @@ startTCPClient host port = withSocketsDo $ resolve >>= tryOpen err
     open addr = do
       sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
       connect sock $ addrAddress addr
-      ctx <- connectTLS "client" clientParams sock
+      ctx <- connectTLS clientParams sock
       getClientConnection ctx
 
 loadTLSServerParams :: FilePath -> FilePath -> IO T.ServerParams
@@ -223,6 +231,14 @@ loadTLSServerParams certificateFile privateKeyFile =
           T.serverSupported = supportedParameters
         }
 
+loadFingerprint :: FilePath -> IO XV.Fingerprint
+loadFingerprint certificateFile = do
+  (cert : _) <- SX.readSignedObject certificateFile
+  pure $ XV.getFingerprint (cert :: X.SignedExact X.Certificate) X.HashSHA256
+
+encodeFingerprint :: XV.Fingerprint -> ByteString
+encodeFingerprint (XV.Fingerprint bs) = encode bs
+
 -- * TLS 1.2 Transport
 
 data TLS = TLS
@@ -233,11 +249,11 @@ data TLS = TLS
     getLock :: TMVar ()
   }
 
-connectTLS :: T.TLSParams p => String -> p -> Socket -> IO T.Context
-connectTLS party params sock =
+connectTLS :: T.TLSParams p => p -> Socket -> IO T.Context
+connectTLS params sock =
   E.bracketOnError (T.contextNew sock params) closeTLS $ \ctx -> do
     T.handshake ctx
-      `E.catch` \(e :: E.SomeException) -> putStrLn (party <> " exception: " <> show e) >> E.throwIO e
+      `E.catch` \(e :: E.SomeException) -> putStrLn ("exception: " <> show e) >> E.throwIO e
     pure ctx
 
 getTLS :: TransportPeer -> T.Context -> IO TLS
@@ -261,14 +277,34 @@ closeTLS ctx =
   (T.bye ctx >> T.contextClose ctx) -- sometimes socket was closed before 'TLS.bye'
     `E.catch` (\(_ :: E.SomeException) -> pure ()) -- so we catch the 'Broken pipe' error here
 
-clientParams :: T.ClientParams
-clientParams =
-  (T.defaultParamsClient "localhost" "5223")
+mkTLSClientParams :: HostName -> ServiceName -> Maybe C.KeyHash -> T.ClientParams
+mkTLSClientParams host port keyHash = do
+  let p = B.pack port
+  (T.defaultParamsClient host p)
     { T.clientShared = def,
-      T.clientHooks = def {T.onServerCertificate = \_ _ _ _ -> pure []},
+      T.clientHooks = def {T.onServerCertificate = \_ _ _ -> validateCertificateChain keyHash host p},
       T.clientSupported = supportedParameters
     }
 
+validateCertificateChain :: Maybe C.KeyHash -> HostName -> ByteString -> X.CertificateChain -> IO [XV.FailedReason]
+validateCertificateChain _ _ _ (X.CertificateChain []) = pure [XV.EmptyChain]
+validateCertificateChain keyHash host port cc@(X.CertificateChain sc@[cert]) =
+  let fp = XV.getFingerprint cert X.HashSHA256
+   in if maybe True (sameFingerprint fp) keyHash
+        then x509validate
+        else pure [XV.UnknownCA]
+  where
+    sameFingerprint (XV.Fingerprint s) (C.KeyHash s') = s == s'
+    x509validate :: IO [XV.FailedReason]
+    x509validate = XV.validate X.HashSHA256 hooks checks certStore cache serviceID cc
+      where
+        hooks = XV.defaultHooks
+        checks = XV.defaultChecks {XV.checkLeafV3 = False} -- TODO create v3 certificates? https://stackoverflow.com/a/18242720
+        certStore = XS.makeCertificateStore sc
+        cache = XV.exceptionValidationCache [] -- we manually check fingerprint only of the offline certificate (TODO 2 certificates)
+        serviceID = (host, port)
+validateCertificateChain _ _ _ (X.CertificateChain (_ : _)) = pure [XV.AuthorityTooDeep]
+
 supportedParameters :: T.Supported
 supportedParameters =
   def
@@ -333,7 +369,7 @@ trimCR :: ByteString -> ByteString
 trimCR "" = ""
 trimCR s = if B.last s == '\r' then B.init s else s
 
--- * SMP encrypted transport
+-- * SMP transport
 
 data SMPVersion = SMPVersion Int Int Int
   deriving (Eq, Ord)