1 files changed, 75 insertions, 72 deletions

diff --git a/dht/src/Data/Tox/Onion.hs b/dht/src/Data/Tox/Onion.hs
index faff3cdf..1cf89bae 100644
--- a/dht/src/Data/Tox/Onion.hs
+++ b/dht/src/Data/Tox/Onion.hs
@@ -66,8 +66,6 @@ import Util (sameAddress)
 import Text.XXD
 import qualified Data.ByteArray as BA
 
-type HandleLo a = Arrival String SockAddr ByteString -> IO a
-
 type UDPTransport = Transport String SockAddr ByteString
 
 
@@ -186,10 +184,10 @@ onion bs saddr getf = do (f,(asymm,ret3)) <- runGet ((,) <$> getf <*> getOnionRe
                          oaddr <- onionToOwner asymm ret3 saddr
                          return (f asymm, oaddr)
 
-parseOnionAddr :: (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination r)))
+parseOnionAddr :: (SockAddr -> Nonce8 -> STM (Maybe (OnionDestination r)))
                   -> (ByteString, SockAddr)
-                  -> IO (Either (OnionMessage Encrypted,OnionDestination r)
-                                (ByteString,SockAddr))
+                  -> STM (Either (OnionMessage Encrypted,OnionDestination r)
+                                 (ByteString,SockAddr))
 parseOnionAddr lookupSender (msg,saddr)
     | Just (typ,bs) <- B.uncons msg
     , let right = Right (msg,saddr)
@@ -271,24 +269,25 @@ forwardOnions crypto baddr udp sendTCP = udp { awaitMessage = forwardAwait crypt
 
 forwardAwait :: TransportCrypto
                 -> UDPTransport
-                -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> HandleLo a -> STM (IO a)
-forwardAwait crypto udp sendTCP kont = do
-    fix $ \another0 -> do
-      let another = join $ atomically another0
-      awaitMessage udp $ \case
-        m@(Arrival saddr bs) -> case B.head bs of
-            0x80 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N0) crypto (Addressed saddr) udp another
-            0x81 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N1) crypto (Addressed saddr) udp another
-            0x82 -> forward kont bs $ handleOnionRequest (Proxy :: Proxy  N2) crypto (Addressed saddr) udp another
-            0x8c -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP another
-            0x8d -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP another
-            0x8e -> forward kont bs $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP another
-            _    -> kont m
-        m -> kont m
-
-forward :: (Serialize b, Show b) =>
-              HandleLo a -> ByteString -> (b -> IO a) -> IO a
-forward kont bs f = either (kont . ParseError) f $ decode $ B.tail bs
+                -> (Int -> OnionMessage Encrypted -> IO ()) {- ^ TCP relay send -} -> STM (Arrival String SockAddr ByteString,IO())
+forwardAwait crypto udp sendTCP = do
+    (m,io) <- awaitMessage udp
+    let pass = return (m, io)
+    case m of
+        Arrival saddr bs ->
+          let forward :: Serialize b => (b -> STM (Arrival String SockAddr ByteString, IO ()))
+                                        -> STM (Arrival String SockAddr ByteString, IO ())
+              forward f = either (\e -> return (ParseError e,io)) (fmap (second (io >>)) . f) $ decode $ B.tail bs
+          in case B.head bs of
+            0x80 -> forward $ handleOnionRequest (Proxy :: Proxy  N0) crypto (Addressed saddr) udp
+            0x81 -> forward $ handleOnionRequest (Proxy :: Proxy  N1) crypto (Addressed saddr) udp
+            0x82 -> forward $ handleOnionRequest (Proxy :: Proxy  N2) crypto (Addressed saddr) udp
+            0x8c -> forward $ handleOnionResponse (Proxy :: Proxy N3) crypto saddr udp sendTCP
+            0x8d -> forward $ handleOnionResponse (Proxy :: Proxy N2) crypto saddr udp sendTCP
+            0x8e -> forward $ handleOnionResponse (Proxy :: Proxy N1) crypto saddr udp sendTCP
+            _    -> pass
+        _ -> pass
+
 
 class SumToThree a b
 
@@ -586,28 +585,29 @@ handleOnionRequest :: forall a proxy n.
                       , Sized (ReturnPath n)
                       , Typeable n
                       , Typeable (ThreeMinus (S n))
-                      ) => proxy n -> TransportCrypto -> (forall x. x -> Addressed x) -> UDPTransport -> IO a -> OnionRequest n -> IO a
-handleOnionRequest proxy crypto saddr udp kont (OnionRequest nonce msg rpath) = do
+                      ) => proxy n -> TransportCrypto
+                                   -> (forall x. x -> Addressed x)
+                                   -> UDPTransport
+                                   -> OnionRequest n
+                                   -> STM (Arrival String SockAddr ByteString, IO ())
+handleOnionRequest proxy crypto saddr udp (OnionRequest nonce msg rpath) = do
     let n = peanoVal rpath
-    dput XOnion $ "handleOnionRequest " ++ show n
-    (sym, snonce) <- atomically ( (,) <$> transportSymmetric crypto
-                                      <*> transportNewNonce crypto )
+        io1 = dput XOnion $ "handleOnionRequest " ++ show n
+    (sym, snonce) <- ( (,) <$> transportSymmetric crypto
+                           <*> transportNewNonce crypto )
     peeled <- peelOnion crypto nonce msg
     let showDestination = case saddr () of
             Addressed a _ -> either show show $ either4or6 a
             TCPIndex  i _ -> "TCP" ++ show [i]
 
-    case peeled of
-        Left e -> do
+    fmap (second (io1 >>)) $ case peeled of
+        Left e -> return $ (ParseError e,) $ do
             dput XOnion $ unwords [ "peelOnion:", show n, showDestination, e]
-            kont
-        Right (Addressed dst msg') -> do
+        Right (Addressed dst msg') -> return $ (Discarded,) $ do
             dput XOnion $ unwords [ "peelOnion:", show n, showDestination, "-->", either show show (either4or6 dst), "SUCCESS"]
             sendMessage udp dst (runPut $ putRequest $ OnionRequest nonce msg' $ wrapSymmetric sym snonce saddr rpath)
-            kont
-        Right (TCPIndex {}) -> do
+        Right (TCPIndex {}) -> return $ (,) (ParseError "handleOnionRequest: Onion forward to TCP client?") $ do
             dput XUnexpected "handleOnionRequest: Onion forward to TCP client?"
-            kont
 
 wrapSymmetric :: Serialize (ReturnPath n) =>
                  SymmetricKey -> Nonce24 -> (forall x. x -> Addressed x) -> ReturnPath n -> ReturnPath (S n)
@@ -622,7 +622,7 @@ peelOnion :: ( Typeable n, Typeable t, Serialize (Addressed (Forwarding n t)))
               => TransportCrypto
               -> Nonce24
               -> Forwarding (S n) t
-              -> IO (Either String (Addressed (Forwarding n t)))
+              -> STM (Either String (Addressed (Forwarding n t)))
 peelOnion crypto nonce (Forwarding k fwd) = do
     fmap runIdentity . uncomposed <$> decryptMessage crypto (dhtKey crypto) nonce (Right $ Asymm k nonce fwd)
 
@@ -632,25 +632,22 @@ handleOnionResponse :: (KnownPeanoNat n, Sized (ReturnPath n), Serialize (Return
                         -> SockAddr
                         -> UDPTransport
                         -> (Int -> OnionMessage Encrypted -> IO ()) -- ^ TCP-relay onion send.
-                        -> IO a
                         -> OnionResponse (S n)
-                        -> IO a
-handleOnionResponse proxy crypto saddr udp sendTCP kont (OnionResponse path msg) = do
-    sym <- atomically $ transportSymmetric crypto
+                        -> STM (Arrival String SockAddr ByteString, IO ())
+handleOnionResponse proxy crypto saddr udp sendTCP (OnionResponse path msg) = do
+    sym <- transportSymmetric crypto
     case peelSymmetric sym path of
-        Left e -> do
+        Left e -> return $ (ParseError e,) $ do
             -- todo report encryption error
             let n = peanoVal path
             dput XMisc $ unwords [ "peelSymmetric:", show n, either show show (either4or6 saddr), e]
-            kont
-        Right (Addressed dst path') -> do
+        Right (Addressed dst path') -> return $ (Discarded,) $ do
             sendMessage udp dst (runPut $ putResponse $ OnionResponse path' msg)
-            kont
         Right (TCPIndex dst path') -> do
             case peanoVal path' of
-                0 -> sendTCP dst msg
-                n -> dput XUnexpected $ "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported."
-            kont
+                0 -> return (Discarded, sendTCP dst msg)
+                n -> let e = "handleOnionResponse: TCP-bound OnionResponse" ++ show n ++ " not supported."
+                     in return (ParseError e, dput XUnexpected e)
 
 
 data AnnounceRequest = AnnounceRequest
@@ -787,7 +784,7 @@ instance Serialize OnionData where
     put (OnionDHTPublicKey dpk) = put (0x9c :: Word8) >> put dpk
     put (OnionFriendRequest fr) = put (0x20 :: Word8) >> put fr
 
-selectKey :: TransportCrypto -> OnionMessage f -> OnionDestination r -> IO (SecretKey, PublicKey)
+selectKey :: Monad m => TransportCrypto -> OnionMessage f -> OnionDestination r -> m (SecretKey, PublicKey)
 selectKey crypto _ rpath@(OnionDestination (AnnouncingAlias skey pkey) _ _)
                            = return (skey, pkey)
 selectKey crypto msg rpath = return $ aliasKey crypto rpath
@@ -808,32 +805,36 @@ encrypt crypto msg rpath = do
     m <- sequenceMessage $ transcode encipher msg
     return (m, rpath)
 
-decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO (Either String (OnionMessage Identity, OnionDestination r))
+decrypt :: TransportCrypto
+            -> OnionMessage Encrypted
+            -> OnionDestination r
+            -> STM (Either String (OnionMessage Identity, OnionDestination r))
 decrypt crypto msg addr = do
     (skey,pkey) <- selectKey crypto msg addr
     let decipher1 :: Serialize a =>
                      TransportCrypto -> SecretKey -> Nonce24
                      -> Either (PublicKey,Encrypted a) (Asymm (Encrypted a))
-                     -> (IO ∘ Either String ∘ Identity) a
+                     -> (STM ∘ Either String ∘ Identity) a
         decipher1 crypto k n arg = Composed $ do
             let (sender,e) = either id (senderKey &&& asymmData) arg
-            secret <- lookupSharedSecret crypto k sender n
+            secret <- lookupSharedSecretSTM crypto k sender n
             return $ Composed $ do
                 plain <- ToxCrypto.decrypt secret e
                 Identity <$> decodePlain plain
         decipher :: Serialize a
             => Nonce24 -> Either (Encrypted a) (Asymm (Encrypted a))
-                       -> (IO ∘ Either String ∘ Identity) a
+                       -> (STM ∘ Either String ∘ Identity) a
         decipher = (\n -> decipher1 crypto skey n . left (senderkey addr))
     foo <- sequenceMessage $ transcode decipher msg
     let result = do
             msg <- sequenceMessage foo
             Right (msg, addr)
-    case msg of
-        OnionToRouteResponse {} -> case result of
-            Left e  -> dput XMan $ "Error decrypting data-to-route response: " ++ e
-            Right m -> dput XMan $ "Decrypted data-to-route response: " ++ show (fst m)
-        _ -> return ()
+    -- -- TODO runio
+    -- case msg of
+    --     OnionToRouteResponse {} -> case result of
+    --         Left e  -> dput XMan $ "Error decrypting data-to-route response: " ++ e
+    --         Right m -> dput XMan $ "Decrypted data-to-route response: " ++ show (fst m)
+    --     _ -> return ()
     return result
 
 senderkey :: OnionDestination r -> t -> (PublicKey, t)
@@ -857,11 +858,11 @@ decryptMessage :: (Typeable x, Serialize x) =>
                   -> Nonce24
                   -> Either (PublicKey, Encrypted x)
                             (Asymm (Encrypted x))
-                  -> IO ((Either String ∘ Identity) x)
+                  -> STM ((Either String ∘ Identity) x)
 decryptMessage crypto (sk,pk) n arg = do
     let (sender,e) = either id (senderKey &&& asymmData) arg
         plain      = Composed . fmap Identity . (>>= decodePlainVerbose)
-    secret <- lookupSharedSecret crypto sk sender n
+    secret <- lookupSharedSecretSTM crypto sk sender n
     return $ plain $ ToxCrypto.decrypt secret e
 
 sequenceMessage :: Applicative m => OnionMessage (m ∘ f) -> m (OnionMessage f)
@@ -1002,9 +1003,9 @@ selectAlias crypto pkey = do
 parseDataToRoute
     :: TransportCrypto
          -> (OnionMessage Encrypted,OnionDestination r)
-         -> IO (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r))
+         -> STM (Either ((PublicKey,OnionData),AnnouncedRendezvous) (OnionMessage Encrypted, OnionDestination r))
 parseDataToRoute crypto (OnionToRouteResponse dta, od) = do
-  ks <- atomically $ userKeys crypto
+  ks <- userKeys crypto
 
   omsg0 <- decryptMessage crypto (rendezvousSecret crypto,rendezvousPublic crypto)
                                 (asymmNonce dta)
@@ -1035,17 +1036,19 @@ parseDataToRoute crypto (OnionToRouteResponse dta, od) = do
                     (dataFromKey dtr)
                     $ Rendezvous (rendezvousPublic crypto) $ onionNodeInfo od )
       r = either (const $ Right (OnionToRouteResponse dta,od)) Left e
-  -- parseDataToRoute OnionToRouteResponse decipherAndAuth: auth fail
-  case e of
-    Left _  -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks)
-    Right _ -> return ()
-  dput XMisc $ unlines
-        [ "parseDataToRoute " ++ either id (const "Right") e
-        , "       crypto inner.me   = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner
-        , "              inner.them = " ++ either id (show . key2id . dataFromKey) eOuter
-        , "              outer.me   = " ++ show (key2id $ rendezvousPublic crypto)
-        , "              outer.them = " ++ show (key2id $ senderKey dta)
-        ]
+      io :: IO ()
+      io = do
+          case e of
+            Left _  -> dput XMisc $ "Failed keys: " ++ show (map (key2id . snd) ks)
+            Right _ -> return ()
+          dput XMisc $ unlines
+                [ "parseDataToRoute " ++ either id (const "Right") e
+                , "       crypto inner.me   = " ++ either id (\(pk,_,_) -> show $ key2id pk) eInner
+                , "              inner.them = " ++ either id (show . key2id . dataFromKey) eOuter
+                , "              outer.me   = " ++ show (key2id $ rendezvousPublic crypto)
+                , "              outer.them = " ++ show (key2id $ senderKey dta)
+                ]
+  -- TODO: run io
   return r
 parseDataToRoute _ msg = return $ Right msg