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
2026-03-30 18:35:59 +00:00 · 2021-04-07 22:59:57 +01:00
parent 0fbf406800
commit ad73298936
6 changed files with 110 additions and 46 deletions
--- 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
--- 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
    }
--- 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 ()
--- 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}
--- 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
--- 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