QueryResponse: Use three-way sum to distinguish Canceled and Timedout.

5 files changed, 22 insertions, 21 deletions

diff --git a/dht/src/Network/BitTorrent/MainlineDHT.hs b/dht/src/Network/BitTorrent/MainlineDHT.hs
index bb556bc6..e604f5e5 100644
--- a/dht/src/Network/BitTorrent/MainlineDHT.hs
+++ b/dht/src/Network/BitTorrent/MainlineDHT.hs
@@ -1033,21 +1033,22 @@ announceH (SwarmsDatabase peers toks _) naddr announcement = do
 isReadonlyClient :: MainlineClient -> Bool
 isReadonlyClient client = False -- TODO
 
-mainlineSend :: ( BEncode a
-                , BEncode a2
+mainlineSend :: ( BEncode xqry
+                , BEncode xrsp
                 ) => Method
-                  -> (a2 -> b)
-                  -> (t -> a)
+                  -> (xrsp -> rsp)
+                  -> (qry -> xqry)
                   -> MainlineClient
-                  -> t
+                  -> qry
                   -> NodeInfo
-                  -> IO (Maybe b)
+                  -> IO (Maybe rsp)
 mainlineSend meth unwrap msg client nid addr = do
     reply <- sendQuery client serializer (msg nid) addr
-    -- sendQuery will return (Just (Left _)) on a parse error.  We're going to
-    -- blow it away with the join-either sequence.
-    -- TODO: Do something with parse errors.
-    return $ join $ either (const Nothing) Just <$> reply
+    return $ case reply of
+        Success (Right x) -> Just x
+        Success (Left e)  -> Nothing -- TODO: Do something with parse errors.
+        Canceled          -> Nothing
+        TimedOut          -> Nothing
  where
     serializer = MethodSerializer
         { methodTimeout  = \ni -> return (ni, 5000000)
diff --git a/dht/src/Network/Tox/DHT/Handlers.hs b/dht/src/Network/Tox/DHT/Handlers.hs
index 7806da78..dc4ca5fa 100644
--- a/dht/src/Network/Tox/DHT/Handlers.hs
+++ b/dht/src/Network/Tox/DHT/Handlers.hs
@@ -353,7 +353,7 @@ ping client addr = do
     dput XPing $ show addr ++ " <-- ping"
     reply <- QR.sendQuery client (serializer PingType DHTPing unpong) Ping addr
     dput XPing $ show addr ++ " -pong-> " ++ show reply
-    maybe (return False) (\Pong -> return True) $ join reply
+    maybe (return False) (\Pong -> return True) $ join $ resultToMaybe reply
 
 
 saveCookieKey :: TVar [(SockAddr, (Int, PublicKey))] -> SockAddr -> PublicKey -> STM ()
@@ -396,7 +396,7 @@ cookieRequest crypto client localUserKey addr = do
     reply <- QR.sendQuery client cookieSerializer cookieRequest addr
     runlast
     dput XNetCrypto $ show addr ++ " -cookieResponse-> " ++ show reply
-    return $ join reply
+    return $ join $ resultToMaybe reply
 
 unCookie :: DHTMessage t -> Maybe (t (Cookie Encrypted))
 unCookie (DHTCookie n24 fcookie) = Just fcookie
@@ -415,7 +415,7 @@ getNodes client cbvar nid addr = do
     -- dput XMisc $ show addr ++ " <-- getnodes " ++ show nid
     reply <- QR.sendQuery client (serializer GetNodesType DHTGetNodes unsendNodes) (GetNodes nid) addr
     -- dput XMisc $ show addr ++ " -sendnodes-> " ++ show reply
-    forM_ (join reply) $ \(SendNodes ns) ->
+    forM_ (join $ resultToMaybe reply) $ \(SendNodes ns) ->
         forM_ ns $ \n -> do
             now <- getPOSIXTime
             atomically $ do
@@ -423,7 +423,7 @@ getNodes client cbvar nid addr = do
                 forM_ mcbs $ \cbs -> do
                     forM_ cbs $ \cb -> do
                         rumoredAddress cb now addr (udpNodeInfo n)
-    return $ fmap unwrapNodes $ join reply
+    return $ fmap unwrapNodes $ join $ resultToMaybe reply
 
 getNodesUDP :: Client -> TVar (HashMap NodeId [NodeInfoCallback]) -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
 getNodesUDP client cbvar nid addr = getNodes client cbvar nid (Multi.UDP ==> addr)
diff --git a/dht/src/Network/Tox/Onion/Handlers.hs b/dht/src/Network/Tox/Onion/Handlers.hs
index 65ec846c..fa7bc83c 100644
--- a/dht/src/Network/Tox/Onion/Handlers.hs
+++ b/dht/src/Network/Tox/Onion/Handlers.hs
@@ -285,7 +285,7 @@ sendOnion getTimeout client req oaddr unwrap =
     forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r
     maybe (if n>0 then loop $! n - 1 else return Nothing)
           (return . Just . unwrap (onionNodeInfo oaddr))
-          $ join mb
+          $ join $ resultToMaybe mb
 
 
 -- | Lookup the secret counterpart for a given alias key.
diff --git a/dht/src/Network/Tox/Onion/Routes.hs b/dht/src/Network/Tox/Onion/Routes.hs
index b20ad7dd..7c11227a 100644
--- a/dht/src/Network/Tox/Onion/Routes.hs
+++ b/dht/src/Network/Tox/Onion/Routes.hs
@@ -171,7 +171,7 @@ newOnionRouter crypto perror tcp_enabled = do
     ((tbl,(tcptbl,tcpcons,relaynet,onionnet)),tcp) <- do
         (tcptbl, client) <- TCP.newClient crypto
                                     id
-                                    (. (Just . (,) False))
+                                    (. (Success . (,) False))
                                     (lookupSender' pq rlog)
                                     (\_ (RouteId rid) -> atomically $ fmap storedRoute <$> readArray rm rid)
 
diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index 9f0af976..0850ce51 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -46,7 +46,7 @@ import DPut
 import Network.Address (setPort,PortNumber,localhost4,fromSockAddr,nullAddress4)
 import Network.Kademlia.Routing
 import Network.Kademlia.Search hiding (sendQuery)
-import Network.QueryResponse
+import Network.QueryResponse as QR
 import Network.QueryResponse.TCP
 import Network.Tox.TCP.NodeId ()
 import Network.Tox.DHT.Transport (toxSpace)
@@ -226,7 +226,7 @@ getUDPNodes tcp seeking dst = fmap fst <$> getUDPNodes' tcp seeking dst
 getUDPNodes' :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo))
 getUDPNodes' tcp seeking dst0 = do
     mgateway <- atomically $ tcpGetGateway tcp dst0
-    fmap join $ forM mgateway $ \gateway -> do
+    fmap (join . fmap resultToMaybe) $ forM mgateway $ \gateway -> do
         (b,c,n24) <- atomically $ do
             b <- transportNewKey (tcpCrypto tcp)
             c <- transportNewKey (tcpCrypto tcp)
@@ -284,7 +284,7 @@ handle2route o src dst = do
 tcpPing :: Show addr => Client err PacketNumber Nonce8 addr (Bool,RelayPacket) -> addr -> IO (Maybe ())
 tcpPing client dst = do
     dput XTCP $ "tcpPing " ++ show dst
-    sendQuery client meth () dst
+    resultToMaybe <$> sendQuery client meth () dst
  where meth = MethodSerializer
                 { wrapQuery      = \n8 src dst () -> (True,RelayPing n8)
                 , unwrapResponse = \_ -> ()
@@ -295,7 +295,7 @@ tcpPing client dst = do
 tcpConnectionRequest_ :: Client err PacketNumber tid addr (Bool, RelayPacket)
                         -> PublicKey -> addr -> IO (Maybe ConId)
 tcpConnectionRequest_ client pubkey ni = do
-    sendQuery client meth pubkey ni
+    resultToMaybe <$> sendQuery client meth pubkey ni
  where
     meth = MethodSerializer
         { wrapQuery      = \n8 src dst pubkey -> (True,RoutingRequest pubkey)
@@ -319,7 +319,7 @@ type RelayCache = TCPCache (SessionProtocol (SessionData,RelayPacket) RelayPacke
 -- defaults are 'id' and 'tryPutMVar'.  The resulting customized table state
 -- will be returned to the caller along with the new client.
 newClient :: TransportCrypto
-               -> ((Maybe (Bool,RelayPacket) -> IO ()) -> a)                    -- ^ store mvar for relay query
+               -> ((QR.Result (Bool,RelayPacket) -> IO ()) -> a)                -- ^ store mvar for relay query
                -> (a -> RelayPacket -> IO void)                                 -- ^ load mvar for relay query
                -> (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination RouteId))) -- ^ lookup sender of onion query
                -> (UDP.NodeInfo -> RouteId -> IO (Maybe OnionRoute))            -- ^ lookup OnionRoute by id