From ad7329893679e3d2aff2a55be0e080c8cb1cafe9 Mon Sep 17 00:00:00 2001
From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
Date: Wed, 7 Apr 2021 22:59:57 +0100
Subject: [PATCH] Read server keys from files or create if absent (#79)

* move server keys to config

* add server keys from files

* create server keys if key files do not exist

* validate loaded server key pair

* refactor fromString functions

* key files in /etc/opt/simplex
---
 apps/smp-server/Main.hs                 | 62 +++++++++++++++++++++++--
 src/Simplex/Messaging/Crypto.hs         | 50 +++++++++++++++-----
 src/Simplex/Messaging/Server.hs         |  2 +-
 src/Simplex/Messaging/Server/Env/STM.hs | 31 ++-----------
 src/Simplex/Messaging/Transport.hs      |  5 +-
 tests/SMPClient.hs                      |  6 ++-
 6 files changed, 110 insertions(+), 46 deletions(-)

diff --git a/apps/smp-server/Main.hs b/apps/smp-server/Main.hs
index d43c97193..0c873b21c 100644
--- a/apps/smp-server/Main.hs
+++ b/apps/smp-server/Main.hs
@@ -1,7 +1,19 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Main where
 
+import Control.Monad (when)
+import Data.Attoparsec.ByteString.Char8 (Parser)
+import qualified Data.ByteString.Char8 as B
+import Data.Char (toLower)
+import qualified Simplex.Messaging.Crypto as C
+import Simplex.Messaging.Parsers (parseAll)
 import Simplex.Messaging.Server (runSMPServer)
 import Simplex.Messaging.Server.Env.STM
+import System.Directory (createDirectoryIfMissing, doesFileExist)
+import System.Exit (exitFailure)
+import System.FilePath (combine)
+import System.IO (hFlush, stdout)
 
 cfg :: ServerConfig
 cfg =
@@ -9,10 +21,54 @@ cfg =
     { tcpPort = "5223",
       tbqSize = 16,
       queueIdBytes = 12,
-      msgIdBytes = 6
+      msgIdBytes = 6,
+      -- keys are loaded from files server_key.pub and server_key in ~/.simplex directory
+      serverKeyPair = undefined
     }
 
+newKeySize :: Int
+newKeySize = 2048 `div` 8
+
+cfgDir :: FilePath
+cfgDir = "/etc/opt/simplex"
+
 main :: IO ()
 main = do
-  putStrLn $ "Listening on port " ++ tcpPort cfg
-  runSMPServer cfg
+  (k, pk) <- readCreateKeys
+  B.putStrLn $ "SMP transport key hash: " <> publicKeyHash k
+  putStrLn $ "Listening on port " <> tcpPort cfg
+  runSMPServer cfg {serverKeyPair = (k, pk)}
+
+readCreateKeys :: IO C.KeyPair
+readCreateKeys = do
+  createDirectoryIfMissing True cfgDir
+  let kPath = combine cfgDir "server_key.pub"
+      pkPath = combine cfgDir "server_key"
+  -- `||` is here to avoid creating keys and crash if one of two files exists
+  hasKeys <- (||) <$> doesFileExist kPath <*> doesFileExist pkPath
+  (if hasKeys then readKeys else createKeys) kPath pkPath
+  where
+    createKeys :: FilePath -> FilePath -> IO C.KeyPair
+    createKeys kPath pkPath = do
+      confirm
+      (k, pk) <- C.generateKeyPair newKeySize
+      B.writeFile kPath $ C.serializePubKey k
+      B.writeFile pkPath $ C.serializePrivKey pk
+      pure (k, pk)
+    confirm :: IO ()
+    confirm = do
+      putStr "Generate new server key pair (y/N): "
+      hFlush stdout
+      ok <- getLine
+      when (map toLower ok /= "y") exitFailure
+    readKeys :: FilePath -> FilePath -> IO C.KeyPair
+    readKeys kPath pkPath = do
+      ks <- (,) <$> readKey kPath C.pubKeyP <*> readKey pkPath C.privKeyP
+      if C.validKeyPair ks then pure ks else putStrLn "invalid key pair" >> exitFailure
+    readKey :: FilePath -> Parser a -> IO a
+    readKey path parser =
+      let parseError = fail . ((path <> ": ") <>)
+       in B.readFile path >>= either parseError pure . parseAll parser . head . B.lines
+
+publicKeyHash :: C.PublicKey -> B.ByteString
+publicKeyHash = C.serializeKeyHash . C.getKeyHash . C.serializePubKey
diff --git a/src/Simplex/Messaging/Crypto.hs b/src/Simplex/Messaging/Crypto.hs
index f2aeb216c..75f2109c0 100644
--- a/src/Simplex/Messaging/Crypto.hs
+++ b/src/Simplex/Messaging/Crypto.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -15,6 +16,7 @@ module Simplex.Messaging.Crypto
     IV (..),
     KeyHash (..),
     generateKeyPair,
+    validKeyPair,
     publicKeySize,
     sign,
     verify,
@@ -27,6 +29,7 @@ module Simplex.Messaging.Crypto
     serializePrivKey,
     serializePubKey,
     serializeKeyHash,
+    getKeyHash,
     privKeyP,
     pubKeyP,
     keyHashP,
@@ -46,8 +49,9 @@ import Control.Monad.Trans.Except
 import Crypto.Cipher.AES (AES256)
 import qualified Crypto.Cipher.Types as AES
 import qualified Crypto.Error as CE
-import Crypto.Hash (Digest, SHA256 (..), digestFromByteString)
+import Crypto.Hash (Digest, SHA256 (..), digestFromByteString, hash)
 import Crypto.Number.Generate (generateMax)
+import Crypto.Number.ModArithmetic (expFast)
 import Crypto.Number.Prime (findPrimeFrom)
 import Crypto.Number.Serialize (i2osp, os2ip)
 import qualified Crypto.PubKey.RSA as R
@@ -81,6 +85,15 @@ data PrivateKey = PrivateKey
   }
   deriving (Eq, Show)
 
+instance IsString PrivateKey where
+  fromString = parseString privKeyP
+
+instance IsString PublicKey where
+  fromString = parseString pubKeyP
+
+parseString :: Parser a -> (String -> a)
+parseString parser = either error id . parseAll parser . fromString
+
 instance ToField PrivateKey where toField = toField . serializePrivKey
 
 instance ToField PublicKey where toField = toField . serializePubKey
@@ -140,6 +153,16 @@ generateKeyPair size = loop
             then loop
             else return (PublicKey pub, privateKey s n d)
 
+validKeyPair :: KeyPair -> Bool
+validKeyPair
+  ( PublicKey R.PublicKey {public_size, public_n = n, public_e = e},
+    PrivateKey {private_size, private_n, private_d = d}
+    ) =
+    let m = 30577
+     in public_size == private_size
+          && n == private_n
+          && m == expFast (expFast m d n) e n
+
 publicKeySize :: PublicKey -> Int
 publicKeySize = R.public_size . rsaPublicKey
 
@@ -157,7 +180,7 @@ newtype IV = IV {unIV :: ByteString}
 newtype KeyHash = KeyHash {unKeyHash :: Digest SHA256} deriving (Eq, Ord, Show)
 
 instance IsString KeyHash where
-  fromString = either error id . parseAll keyHashP . fromString
+  fromString = parseString keyHashP
 
 instance ToField KeyHash where toField = toField . serializeKeyHash
 
@@ -178,6 +201,9 @@ keyHashP = do
     Just d -> pure $ KeyHash d
     _ -> fail "invalid digest"
 
+getKeyHash :: ByteString -> KeyHash
+getKeyHash = KeyHash . hash
+
 serializeHeader :: Header -> ByteString
 serializeHeader Header {aesKey, ivBytes, authTag, msgSize} =
   unKey aesKey <> unIV ivBytes <> authTagToBS authTag <> (encodeWord32 . fromIntegral) msgSize
@@ -314,16 +340,16 @@ keyParser_ = (,,) <$> (A.decimal <* ",") <*> (intP <* ",") <*> intP
 rsaPrivateKey :: PrivateKey -> R.PrivateKey
 rsaPrivateKey pk =
   R.PrivateKey
-    { R.private_pub =
+    { private_pub =
         R.PublicKey
-          { R.public_size = private_size pk,
-            R.public_n = private_n pk,
-            R.public_e = undefined
+          { public_size = private_size pk,
+            public_n = private_n pk,
+            public_e = undefined
           },
-      R.private_d = private_d pk,
-      R.private_p = 0,
-      R.private_q = 0,
-      R.private_dP = undefined,
-      R.private_dQ = undefined,
-      R.private_qinv = undefined
+      private_d = private_d pk,
+      private_p = 0,
+      private_q = 0,
+      private_dP = undefined,
+      private_dQ = undefined,
+      private_qinv = undefined
     }
diff --git a/src/Simplex/Messaging/Server.hs b/src/Simplex/Messaging/Server.hs
index 130ff2190..69e3a0eec 100644
--- a/src/Simplex/Messaging/Server.hs
+++ b/src/Simplex/Messaging/Server.hs
@@ -60,7 +60,7 @@ runSMPServer cfg@ServerConfig {tcpPort} = do
 
 runClient :: (MonadUnliftIO m, MonadReader Env m) => Handle -> m ()
 runClient h = do
-  keyPair <- asks serverKeyPair
+  keyPair <- asks $ serverKeyPair . config
   liftIO (runExceptT $ serverHandshake h keyPair) >>= \case
     Right th -> runClientTransport th
     Left _ -> pure ()
diff --git a/src/Simplex/Messaging/Server/Env/STM.hs b/src/Simplex/Messaging/Server/Env/STM.hs
index 126f00238..cbfec9f3c 100644
--- a/src/Simplex/Messaging/Server/Env/STM.hs
+++ b/src/Simplex/Messaging/Server/Env/STM.hs
@@ -5,7 +5,6 @@ module Simplex.Messaging.Server.Env.STM where
 
 import Control.Concurrent (ThreadId)
 import Control.Monad.IO.Unlift
-import qualified Crypto.PubKey.RSA as R
 import Crypto.Random
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as M
@@ -21,7 +20,9 @@ data ServerConfig = ServerConfig
   { tcpPort :: ServiceName,
     tbqSize :: Natural,
     queueIdBytes :: Int,
-    msgIdBytes :: Int
+    msgIdBytes :: Int,
+    serverKeyPair :: C.KeyPair
+    -- serverId :: ByteString
   }
 
 data Env = Env
@@ -29,9 +30,7 @@ data Env = Env
     server :: Server,
     queueStore :: QueueStore,
     msgStore :: STMMsgStore,
-    idsDrg :: TVar ChaChaDRG,
-    serverKeyPair :: C.KeyPair
-    -- serverId :: ByteString
+    idsDrg :: TVar ChaChaDRG
   }
 
 data Server = Server
@@ -76,24 +75,4 @@ newEnv config = do
   queueStore <- atomically newQueueStore
   msgStore <- atomically newMsgStore
   idsDrg <- drgNew >>= newTVarIO
-  -- TODO these keys should be set in the environment, not in the code
-  return Env {config, server, queueStore, msgStore, idsDrg, serverKeyPair}
-  where
-    serverKeyPair =
-      ( C.PublicKey
-          { rsaPublicKey =
-              R.PublicKey
-                { public_size = 256,
-                  public_n = 24491401566218566997383105010202223087300892576089255259580984651333137614713737618097624532507176450266480395052797332730303098565954279378701980313049999952643146946493842983667770915603693980339519205455913124235423278419181501399080069195664300809453039371169996023512911587381435574254546266774756319955237750224266282550919563293672568339958353047135257914364920805066749904289452712976534358633568668875150094910205741579097517675339029147403213185924413178887675432745168542469043448659751499651038006514754218441022754807971535895895877162103157702709155894482782232155817331812261258282431796597840952464257,
-                  public_e = 8750208418393523480444709183090020123776537336553019181250117771363000810675051423462439348759073000328325050011503730211252469588880505946970399702607609166796825215104414212088697348613726705621594590369250976359268097976909710311654938358716518878047036682173044667792903503207106314854901036618348367397
-                }
-          },
-        C.PrivateKey
-          { private_size = 256,
-            private_n = 24491401566218566997383105010202223087300892576089255259580984651333137614713737618097624532507176450266480395052797332730303098565954279378701980313049999952643146946493842983667770915603693980339519205455913124235423278419181501399080069195664300809453039371169996023512911587381435574254546266774756319955237750224266282550919563293672568339958353047135257914364920805066749904289452712976534358633568668875150094910205741579097517675339029147403213185924413178887675432745168542469043448659751499651038006514754218441022754807971535895895877162103157702709155894482782232155817331812261258282431796597840952464257,
-            private_d = 7597313014691047671352664508683652467940113991200105893460705315744177757772923044415828427601194535604492873282390112577565179730319668643740113323630387082584239892956534048712048059175569855278723311295064858148623887611800385925820852572241607131360121661598015161261779381845187797044113149447495567589968956065009916550602209418325870594974390014927949966324558614396231902374868077411836997835082564279358230227298823445650053370542685308691044175390251929540772677009245507450972026595993054141350350385685400540681305852935721245601287301749047921282924410369389293829570448007237832101875085500166095784749
-          }
-      )
-
--- public key hash:
--- "8Cvd+AYVxLpSsB/glEhVxkKuEzMNBFdAL5yr7p9DGGk="
+  return Env {config, server, queueStore, msgStore, idsDrg}
diff --git a/src/Simplex/Messaging/Transport.hs b/src/Simplex/Messaging/Transport.hs
index 994366b02..46f95e050 100644
--- a/src/Simplex/Messaging/Transport.hs
+++ b/src/Simplex/Messaging/Transport.hs
@@ -15,7 +15,6 @@ import Control.Monad.Except
 import Control.Monad.IO.Unlift
 import Control.Monad.Trans.Except (throwE)
 import Crypto.Cipher.Types (AuthTag)
-import Crypto.Hash (hash)
 import Data.Attoparsec.ByteString.Char8 (Parser)
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.Bifunctor (first)
@@ -235,8 +234,8 @@ clientHandshake h keyHash = do
     parseKey :: ByteString -> Either TransportError C.PublicKey
     parseKey = first TransportHandshakeError . parseAll C.pubKeyP
     validateKeyHash_2 :: ByteString -> C.KeyHash -> ExceptT TransportError IO ()
-    validateKeyHash_2 k (C.KeyHash kHash)
-      | hash k == kHash = pure ()
+    validateKeyHash_2 k kHash
+      | C.getKeyHash k == kHash = pure ()
       | otherwise = throwE $ TransportHandshakeError "wrong key hash"
     generateKeys_3 :: IO HandshakeKeys
     generateKeys_3 = HandshakeKeys <$> generateKey <*> generateKey
diff --git a/tests/SMPClient.hs b/tests/SMPClient.hs
index 4c36c2db9..85902cf57 100644
--- a/tests/SMPClient.hs
+++ b/tests/SMPClient.hs
@@ -48,7 +48,11 @@ cfg =
     { tcpPort = testPort,
       tbqSize = 1,
       queueIdBytes = 12,
-      msgIdBytes = 6
+      msgIdBytes = 6,
+      serverKeyPair =
+        ( "256,wgJfm+EgMI3MeGdZlNs+KEoMlO0bpvZ2sa7bK4zWGtWGWXoCq1m89gaMk+f+HZavNJbJmflqrviBAoCFtDrA5+xC4+mwGlU6mLWiWtpvxgRBtNBsuHg3l+oJv0giFNCxoscne3P6n4kaCQEbA1T6KdrsdvxcaqyqzbpI7SozLIzhy45gsVywJfzpu6GYHlYNizdBJtoX2r66v6jDQFX7/MVDG4Z84RRa8PzjzT0wXSY+nirwIy5uwD0V5jrwaB0S5re6UnL7aLp51zHLUHPI/C9okBIkjY9kyQg3mAYXOPxb0OlGf3ENWnVdPKG6WqYnC3SBMIEVd4rqqxoH4myTgQ==,DHXxHfufuxfbuReISV9tCNttWXm/EVXTTN//hHkW/1wPLppbpY6aOqW+SZWwGCodIdGvdPSmaY9W8kfftWQY9xCOOcpkrzZwYHppT995xBIoB30vXG01dyruebFr3HjurT+uUbRGnxNYGwZg3AjkcyQtMKmq1pANvOGsOUgeDiU=",
+          "256,wgJfm+EgMI3MeGdZlNs+KEoMlO0bpvZ2sa7bK4zWGtWGWXoCq1m89gaMk+f+HZavNJbJmflqrviBAoCFtDrA5+xC4+mwGlU6mLWiWtpvxgRBtNBsuHg3l+oJv0giFNCxoscne3P6n4kaCQEbA1T6KdrsdvxcaqyqzbpI7SozLIzhy45gsVywJfzpu6GYHlYNizdBJtoX2r66v6jDQFX7/MVDG4Z84RRa8PzjzT0wXSY+nirwIy5uwD0V5jrwaB0S5re6UnL7aLp51zHLUHPI/C9okBIkjY9kyQg3mAYXOPxb0OlGf3ENWnVdPKG6WqYnC3SBMIEVd4rqqxoH4myTgQ==,PC6r+lZm5vyVpOl6dS9SXv09iE1PZoav6yeUbqsK+FScwHiOMEOkTY2mUyTHZ99nA4l7grAo4RPS6UOQS07QtgD2siZyj6F6Z3qAiBGesiG3+tb59pQ/prhs+5Q7RBlRMulz5KEwFINUb4Wy9ft4oIL/JJT9iSnYtTuGGirUEjB6YGzLKQeTyhkWA0iN89C5Vx6drB/pHyu3Mu+uc0Rax0UPD47gsNmxPNWUM6xLlkpNAWnSOHcSJZ3SN4QDLLCeBfqkgDLYkE3vbwvz8drt+H2eLi8OzFErEdkkrXg/0VwNjfhpBTt8D4TX00I7XsVksh3b2BRHzLfHTbLGdExLLQ=="
+        )
     }
 
 withSmpServerThreadOn :: (MonadUnliftIO m, MonadRandom m) => ServiceName -> (ThreadId -> m a) -> m a