Handle pattern fail.

1 files changed, 38 insertions, 28 deletions

diff --git a/tox-crypto/src/Crypto/Tox.hs b/tox-crypto/src/Crypto/Tox.hs
index ea276045..04b55d94 100644
--- a/tox-crypto/src/Crypto/Tox.hs
+++ b/tox-crypto/src/Crypto/Tox.hs
@@ -294,29 +294,27 @@ encryptPayload st g =
                              g
 
 -- (Poly1305.State, XSalsa.State)
-computeSharedSecret :: SecretKey -> PublicKey -> Nonce24 -> State
-computeSharedSecret sk recipient = k `seq` \nonce ->
-    let -- cipher state
-        st0 = XSalsa.initialize 20 k nonce
-        -- Poly1305 key
-        (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32
-        -- Since rs is 32 bytes, this pattern should never fail...
-        Cryptonite.CryptoPassed hash = Poly1305.initialize rs
-    in State hash crypt
+computeSharedSecret :: SecretKey -> PublicKey -> Maybe (Nonce24 -> State)
+computeSharedSecret sk recipient = case mk of
+    Just k -> Just $ \nonce ->
+        let -- cipher state
+            st0 = XSalsa.initialize 20 k nonce
+            -- Poly1305 key
+            (rs, crypt) = XSalsa.combine st0 zs where Nonce32 zs = zeros32
+            -- Since rs is 32 bytes, this pattern should never fail...
+            Cryptonite.CryptoPassed hash = Poly1305.initialize rs
+        in State hash crypt
+    Nothing -> Nothing
  where
     -- diffie helman
 #if MIN_VERSION_cryptonite(0,24,0)
-    -- TODO: Handle failure.
-    -- Failure was observed...
-    --  Reproduce by issuing tox command "ping 192.168.10.1:33446" without specifying
-    --  the public key portion of the node id.
-    --  "Irrefutable pattern failed for pattern CryptoPassed shared"
-    Cryptonite.CryptoPassed shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient
+    -- Note This *does* fail.
+    shared = Cryptonite.maybeCryptoError $ ecdh (Proxy :: Proxy Curve_X25519) sk recipient
 #else
-    shared = ecdh (Proxy :: Proxy Curve_X25519) sk recipient
+    shared = Just $ ecdh (Proxy :: Proxy Curve_X25519) sk recipient
 #endif
     -- shared secret XSalsa key
-    k = hsalsa20 shared zeros24
+    mk = fmap (`hsalsa20` zeros24) shared
 
 unsafeFirstWord64 :: ByteArrayAccess ba => ba -> Word64
 unsafeFirstWord64 ba = unsafeDupablePerformIO $ BA.withByteArray ba peek
@@ -366,6 +364,15 @@ lookupNonceFunction c@(TransportCrypto{secretsCache}) sk recipient = do
     now <- getPOSIXTime
     atomically $ lookupNonceFunctionSTM now c sk recipient
 
+-- | Dummy, used to indicate computeSharedSecret failure.  This is a way to provide
+-- the old non-failing interface compatibly.
+dummyState :: State
+dummyState = State hash xsalsa
+ where
+    xsalsa = XSalsa.initialize 20 zeros32 zeros24
+    -- Since zeros32 is 32 bytes, this pattern should never fail...
+    Cryptonite.CryptoPassed hash = Poly1305.initialize zeros32
+
 {-# INLINE lookupNonceFunctionSTM #-}
 -- | This version of 'lookupNonceFunction' is STM instead of IO, this means if some later part of
 --   of the transaction fails, we may end up forgoing a computation that could have been cached.
@@ -375,18 +382,21 @@ lookupNonceFunctionSTM :: POSIXTime -> TransportCrypto -> SecretKey -> PublicKey
 lookupNonceFunctionSTM now TransportCrypto{secretsCache} sk recipient = do
     mm <- readTVar $ sharedSecret secretsCache
     case MM.lookup' recipient mm of
-        Nothing -> do
-            let miss = computeSharedSecret sk recipient
-            writeTVar (sharedSecret secretsCache)
-                      (MM.insertTake' 160 recipient (MM.singleton' sk miss (Down now)) (Down now) mm)
-            return miss
+        Nothing -> case computeSharedSecret sk recipient of
+            Just miss -> do
+                writeTVar (sharedSecret secretsCache)
+                          (MM.insertTake' 160 recipient (MM.singleton' sk miss (Down now)) (Down now) mm)
+                return miss
+            Nothing -> return $ const dummyState
         Just (stamp,smm) -> do
-            let (r,v) = case MM.lookup' sk smm of
-                    Nothing | let miss = computeSharedSecret sk recipient
-                                      -> (miss, MM.insertTake' 3 sk miss (Down now) smm)
-                    Just (stamp2,hit) -> (hit , MM.insert' sk hit (Down now) smm)
-            writeTVar (sharedSecret secretsCache)
-                      (MM.insertTake' 160 recipient v (Down now) mm)
+            let (r,mv) = case MM.lookup' sk smm of
+                    Nothing | Just miss <- computeSharedSecret sk recipient
+                                      -> (miss, Just $ MM.insertTake' 3 sk miss (Down now) smm)
+                    Nothing           -> (const dummyState, Nothing)
+                    Just (stamp2,hit) -> (hit , Just $ MM.insert' sk hit (Down now) smm)
+            forM_ mv $ \v -> do
+                writeTVar (sharedSecret secretsCache)
+                          (MM.insertTake' 160 recipient v (Down now) mm)
             return r