GADTs for cryptographic keys (#208)

* GADTs for cryptographic keys

* update tests (signature timing tests still fail)

* fix signature verification timing tests

* configurable algorithm to sign commands to SMP queues (Ed448 by default)

* add dummy Ed keys, add timing tests for Ed keys

* re-enable Connection subscriptions tests
This commit is contained in:
Evgeny Poberezkin authored and GitHub committed 2021-11-28 11:44:22 +00:00
1 parent 99b3749890
commit e1002d5ac0
17 files changed
+938 -338

No files matched your search

+8 -8
View File
@@ -82,7 +82,7 @@ data SMPClient = SMPClient
tcpTimeout :: Int,
clientCorrId :: TVar Natural,
sentCommands :: TVar (Map CorrId Request),
sndQ :: TBQueue SignedRawTransmission,
sndQ :: TBQueue SentRawTransmission,
rcvQ :: TBQueue SignedTransmissionOrError,
msgQ :: TBQueue SMPServerTransmission,
blockSize :: Int
@@ -333,14 +333,14 @@ suspendSMPQueue = okSMPCommand $ Cmd SRecipient OFF
deleteSMPQueue :: SMPClient -> RecipientPrivateKey -> QueueId -> ExceptT SMPClientError IO ()
deleteSMPQueue = okSMPCommand $ Cmd SRecipient DEL
okSMPCommand :: Cmd -> SMPClient -> C.PrivateKey -> QueueId -> ExceptT SMPClientError IO ()
okSMPCommand :: Cmd -> SMPClient -> C.APrivateSignKey -> QueueId -> ExceptT SMPClientError IO ()
okSMPCommand cmd c pKey qId =
sendSMPCommand c (Just pKey) qId cmd >>= \case
Cmd _ OK -> return ()
_ -> throwE SMPUnexpectedResponse
-- | Send any SMP command ('Cmd' type).
sendSMPCommand :: SMPClient -> Maybe C.PrivateKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd
sendSMPCommand :: SMPClient -> Maybe C.APrivateSignKey -> QueueId -> Cmd -> ExceptT SMPClientError IO Cmd
sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId cmd = do
corrId <- lift_ getNextCorrId
t <- signTransmission $ serializeTransmission (corrId, qId, cmd)
@@ -354,20 +354,20 @@ sendSMPCommand SMPClient {sndQ, sentCommands, clientCorrId, tcpTimeout} pKey qId
i <- stateTVar clientCorrId $ \i -> (i, i + 1)
pure . CorrId $ bshow i
signTransmission :: ByteString -> ExceptT SMPClientError IO SignedRawTransmission
signTransmission :: ByteString -> ExceptT SMPClientError IO SentRawTransmission
signTransmission t = case pKey of
Nothing -> return ("", t)
Nothing -> return (Nothing, t)
Just pk -> do
sig <- liftError SMPSignatureError $ C.sign pk t
return (sig, t)
return (Just sig, t)
-- two separate "atomically" needed to avoid blocking
sendRecv :: CorrId -> SignedRawTransmission -> IO Response
sendRecv :: CorrId -> SentRawTransmission -> IO Response
sendRecv corrId t = atomically (send corrId t) >>= withTimeout . atomically . takeTMVar
where
withTimeout a = fromMaybe (Left SMPResponseTimeout) <$> timeout tcpTimeout a
send :: CorrId -> SignedRawTransmission -> STM (TMVar Response)
send :: CorrId -> SentRawTransmission -> STM (TMVar Response)
send corrId t = do
r <- newEmptyTMVar
modifyTVar sentCommands . M.insert corrId $ Request qId r