diff options
author | joe <joe@jerkface.net> | 2017-11-05 03:43:02 -0500 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-11-05 03:43:02 -0500 |
commit | 0658b07e68eed370c790f74db7d67f1496134b43 (patch) | |
tree | a459db44ee971c115fe4953929ebf12cf54e2287 /src/Crypto/Tox.hs | |
parent | 8039d812b7ea8ae566f8873452ac34597336ddfc (diff) |
Tox: Shared secrets cache.
Diffstat (limited to 'src/Crypto/Tox.hs')
-rw-r--r-- | src/Crypto/Tox.hs | 89 |
1 files changed, 79 insertions, 10 deletions
diff --git a/src/Crypto/Tox.hs b/src/Crypto/Tox.hs index 37725aea..7cfbd193 100644 --- a/src/Crypto/Tox.hs +++ b/src/Crypto/Tox.hs | |||
@@ -8,6 +8,7 @@ | |||
8 | {-# LANGUAGE ExplicitNamespaces #-} | 8 | {-# LANGUAGE ExplicitNamespaces #-} |
9 | {-# LANGUAGE TypeOperators #-} | 9 | {-# LANGUAGE TypeOperators #-} |
10 | {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-} | 10 | {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-} |
11 | {-# LANGUAGE NamedFieldPuns #-} | ||
11 | module Crypto.Tox | 12 | module Crypto.Tox |
12 | ( PublicKey | 13 | ( PublicKey |
13 | , publicKey | 14 | , publicKey |
@@ -18,6 +19,8 @@ module Crypto.Tox | |||
18 | , toPublic | 19 | , toPublic |
19 | , SymmetricKey(..) | 20 | , SymmetricKey(..) |
20 | , TransportCrypto(..) | 21 | , TransportCrypto(..) |
22 | , SecretsCache | ||
23 | , newSecretsCache | ||
21 | , Encrypted | 24 | , Encrypted |
22 | , Encrypted8(..) | 25 | , Encrypted8(..) |
23 | , type (∘)(..) | 26 | , type (∘)(..) |
@@ -89,6 +92,11 @@ import Network.Socket (SockAddr) | |||
89 | import GHC.Exts (Word(..)) | 92 | import GHC.Exts (Word(..)) |
90 | import GHC.Prim | 93 | import GHC.Prim |
91 | import Data.Word64Map (fitsInInt) | 94 | import Data.Word64Map (fitsInInt) |
95 | import Data.MinMaxPSQ (MinMaxPSQ') | ||
96 | import qualified Data.MinMaxPSQ as MM | ||
97 | import Data.Time.Clock.POSIX | ||
98 | import Data.Hashable | ||
99 | import System.IO.Unsafe (unsafePerformIO) | ||
92 | 100 | ||
93 | -- | A 16-byte mac and an arbitrary-length encrypted stream. | 101 | -- | A 16-byte mac and an arbitrary-length encrypted stream. |
94 | newtype Encrypted a = Encrypted ByteString | 102 | newtype Encrypted a = Encrypted ByteString |
@@ -236,23 +244,73 @@ encrypt (State hash crypt) (Plain m) = Encrypted $ B.append (encode a) c | |||
236 | 244 | ||
237 | -- (Poly1305.State, XSalsa.State) | 245 | -- (Poly1305.State, XSalsa.State) |
238 | computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State | 246 | computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State |
239 | computeSharedSecret sk recipient nonce = State hash crypt | 247 | computeSharedSecret sk recipient = \nonce -> |
248 | let -- cipher state | ||
249 | st0 = XSalsa.initialize 20 k nonce | ||
250 | -- Poly1305 key | ||
251 | (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32 | ||
252 | -- Since rs is 32 bytes, this pattern should never fail... | ||
253 | Cryptonite.CryptoPassed hash = Poly1305.initialize rs | ||
254 | in State hash crypt | ||
240 | where | 255 | where |
241 | -- diffie helman | 256 | -- diffie helman |
242 | shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient | 257 | shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient |
243 | -- shared secret XSalsa key | 258 | -- shared secret XSalsa key |
244 | k = hsalsa20 shared zeros24 | 259 | k = hsalsa20 shared zeros24 |
245 | -- cipher state | 260 | |
246 | st0 = XSalsa.initialize 20 k nonce | 261 | unsafeFirstWord64 :: ByteArrayAccess ba => ba -> Word64 |
247 | -- Poly1305 key | 262 | unsafeFirstWord64 ba = unsafePerformIO $ BA.withByteArray ba peek |
248 | (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32 | 263 | |
249 | -- Since rs is 32 bytes, this pattern should never fail... | 264 | instance Hashable PublicKey where |
250 | Cryptonite.CryptoPassed hash = Poly1305.initialize rs | 265 | hashWithSalt salt pk = hashWithSalt salt (unsafeFirstWord64 pk) |
266 | |||
267 | instance Hashable SecretKey where | ||
268 | hashWithSalt salt sk = hashWithSalt salt (unsafeFirstWord64 sk) | ||
269 | |||
270 | instance Ord PublicKey where compare = unsafeCompare32Bytes | ||
271 | instance Ord SecretKey where compare = unsafeCompare32Bytes | ||
272 | |||
273 | unsafeCompare32Bytes :: (ByteArrayAccess ba, ByteArrayAccess bb) | ||
274 | => ba -> bb -> Ordering | ||
275 | unsafeCompare32Bytes ba bb = | ||
276 | unsafePerformIO $ BA.withByteArray ba | ||
277 | $ \pa -> BA.withByteArray bb | ||
278 | $ \pb -> unsafeCompare32Bytes' 3 pa pb | ||
279 | |||
280 | unsafeCompare32Bytes' :: Int -> Ptr Word64 -> Ptr Word64 -> IO Ordering | ||
281 | unsafeCompare32Bytes' !n !pa !pb = do | ||
282 | a <- peek pa | ||
283 | b <- peek pb | ||
284 | case compare a b of | ||
285 | EQ -> if n == 0 | ||
286 | then return EQ | ||
287 | else unsafeCompare32Bytes' (n - 1) | ||
288 | (pa `plusPtr` 8) | ||
289 | (pb `plusPtr` 8) | ||
290 | result -> return result | ||
291 | |||
292 | |||
251 | 293 | ||
252 | lookupSharedSecret :: TransportCrypto -> SecretKey -> PublicKey -> Nonce24 -> IO State | 294 | lookupSharedSecret :: TransportCrypto -> SecretKey -> PublicKey -> Nonce24 -> IO State |
253 | lookupSharedSecret crypto sk recipient nonce = do | 295 | lookupSharedSecret TransportCrypto{secretsCache} sk recipient nonce = do |
254 | -- TODO | 296 | now <- getPOSIXTime |
255 | return $ computeSharedSecret sk recipient nonce | 297 | atomically $ do |
298 | mm <- readTVar $ sharedSecret secretsCache | ||
299 | case MM.lookup' recipient mm of | ||
300 | Nothing -> do | ||
301 | let miss = computeSharedSecret sk recipient | ||
302 | writeTVar (sharedSecret secretsCache) | ||
303 | (MM.insertTake' 160 recipient (MM.singleton' sk miss (Down now)) (Down now) mm) | ||
304 | return $ miss nonce | ||
305 | Just (stamp,smm) -> do | ||
306 | let (r,v) = case MM.lookup' sk smm of | ||
307 | Nothing | let miss = computeSharedSecret sk recipient | ||
308 | -> (miss, MM.insertTake' 3 sk miss (Down now) smm) | ||
309 | Just (stamp2,hit) -> (hit , MM.insertTake' 3 sk hit (Down now) smm) | ||
310 | writeTVar (sharedSecret secretsCache) | ||
311 | (MM.insertTake' 160 recipient v (Down now) mm) | ||
312 | return $ r nonce | ||
313 | |||
256 | 314 | ||
257 | hsalsa20 :: (ByteArrayAccess t, ByteArrayAccess t1) => t1 -> t -> BA.ScrubbedBytes | 315 | hsalsa20 :: (ByteArrayAccess t, ByteArrayAccess t1) => t1 -> t -> BA.ScrubbedBytes |
258 | hsalsa20 k n = BA.append a b | 316 | hsalsa20 k n = BA.append a b |
@@ -415,6 +473,16 @@ getAliasedAsymm = flip Asymm <$> get <*> getPublicKey <*> get | |||
415 | putAliasedAsymm :: Serialize a => Asymm a -> Put | 473 | putAliasedAsymm :: Serialize a => Asymm a -> Put |
416 | putAliasedAsymm (Asymm key nonce dta) = put nonce >> putPublicKey key >> put dta | 474 | putAliasedAsymm (Asymm key nonce dta) = put nonce >> putPublicKey key >> put dta |
417 | 475 | ||
476 | data SecretsCache = SecretsCache | ||
477 | { sharedSecret :: TVar (MinMaxPSQ' PublicKey | ||
478 | (Down POSIXTime) | ||
479 | (MinMaxPSQ' SecretKey (Down POSIXTime) (Nonce24 -> State))) | ||
480 | } | ||
481 | |||
482 | newSecretsCache :: IO SecretsCache | ||
483 | newSecretsCache = atomically (SecretsCache <$> newTVar MM.empty) | ||
484 | |||
485 | |||
418 | newtype SymmetricKey = SymmetricKey ByteString | 486 | newtype SymmetricKey = SymmetricKey ByteString |
419 | 487 | ||
420 | data TransportCrypto = TransportCrypto | 488 | data TransportCrypto = TransportCrypto |
@@ -428,6 +496,7 @@ data TransportCrypto = TransportCrypto | |||
428 | , transportNewNonce :: STM Nonce24 | 496 | , transportNewNonce :: STM Nonce24 |
429 | , userKeys :: TVar [(SecretKey,PublicKey)] | 497 | , userKeys :: TVar [(SecretKey,PublicKey)] |
430 | , pendingCookies :: TVar [(SockAddr, (Int, PublicKey))] | 498 | , pendingCookies :: TVar [(SockAddr, (Int, PublicKey))] |
499 | , secretsCache :: SecretsCache | ||
431 | } | 500 | } |
432 | 501 | ||
433 | getPublicKey :: S.Get PublicKey | 502 | getPublicKey :: S.Get PublicKey |