diff options
author | Joe Crayne <joe@jerkface.net> | 2020-01-06 18:58:02 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-07 13:24:59 -0500 |
commit | 09db68d3248f44a751c637713af936502a7e5152 (patch) | |
tree | a5e1facb18ffa4362fb9d80e5f5a7f735f92a209 | |
parent | c7fb8cfe16f821e4e148d1855a18cb81255743bc (diff) |
Updated tests for async search.
-rw-r--r-- | kad/kad.cabal | 7 | ||||
-rw-r--r-- | kad/tests/searchCancel.hs | 23 |
2 files changed, 22 insertions, 8 deletions
diff --git a/kad/kad.cabal b/kad/kad.cabal index 0483ded4..be8ab212 100644 --- a/kad/kad.cabal +++ b/kad/kad.cabal | |||
@@ -94,4 +94,11 @@ executable testSearch | |||
94 | hs-source-dirs: tests | 94 | hs-source-dirs: tests |
95 | build-depends: kad, base, stm, containers, minmax-psq, server | 95 | build-depends: kad, base, stm, containers, minmax-psq, server |
96 | main-is: searchCancel.hs | 96 | main-is: searchCancel.hs |
97 | ghc-options: -rtsopts -threaded | ||
97 | 98 | ||
99 | |||
100 | executable testReset | ||
101 | hs-source-dirs: tests | ||
102 | build-depends: kad, base, stm, containers, minmax-psq, server | ||
103 | main-is: searchReset.hs | ||
104 | ghc-options: -rtsopts -threaded | ||
diff --git a/kad/tests/searchCancel.hs b/kad/tests/searchCancel.hs index e8aa33c7..393f10c1 100644 --- a/kad/tests/searchCancel.hs +++ b/kad/tests/searchCancel.hs | |||
@@ -2,6 +2,7 @@ import Control.Concurrent | |||
2 | import Control.Concurrent.STM | 2 | import Control.Concurrent.STM |
3 | import Control.Monad | 3 | import Control.Monad |
4 | import Data.Bits | 4 | import Data.Bits |
5 | import GHC.Event | ||
5 | 6 | ||
6 | import Network.Kademlia | 7 | import Network.Kademlia |
7 | import Network.Kademlia.Bootstrap | 8 | import Network.Kademlia.Bootstrap |
@@ -14,15 +15,13 @@ import Network.QueryResponse as QR | |||
14 | import qualified Data.MinMaxPSQ as MM | 15 | import qualified Data.MinMaxPSQ as MM |
15 | import qualified Data.Set as Set | 16 | import qualified Data.Set as Set |
16 | 17 | ||
17 | makeSchResults :: TVar (Maybe (SearchState Int Int () Int Int Int)) -> TVar Int -> IO (Maybe ([Int],[Int],Maybe ())) | 18 | makeSchResults :: TVar (Maybe (SearchState Int Int () Int Int Int)) -> TVar Int -> IO ([Int],[Int],Maybe ()) |
18 | makeSchResults mbv var = do | 19 | makeSchResults mbv var = do |
19 | putStrLn "makeSchResults" | ||
20 | threadDelay 200000 | ||
21 | (r,io) <- atomically $ do | 20 | (r,io) <- atomically $ do |
22 | n <- readTVar var | 21 | n <- readTVar var |
23 | let ns = take 4 [n .. ] | 22 | let ns = take 4 [n .. ] |
24 | writeTVar var $! n + 4 | 23 | writeTVar var $! n + 4 |
25 | let r = Just (ns, ns, Just ()) -- Maybe ([ni], [r], Maybe tok) | 24 | let r = (ns, ns, Just ()) -- Maybe ([ni], [r], Maybe tok) |
26 | stmio = if n > 490 | 25 | stmio = if n > 490 |
27 | then do | 26 | then do |
28 | ms <- readTVar mbv | 27 | ms <- readTVar mbv |
@@ -48,10 +47,18 @@ sch :: TVar (Maybe (SearchState Int Int () Int Int Int)) -> TVar Int -> Search I | |||
48 | sch mbv var = Search | 47 | sch mbv var = Search |
49 | { searchSpace = kad | 48 | { searchSpace = kad |
50 | , searchNodeAddress = id | 49 | , searchNodeAddress = id |
51 | , searchQuery = \_ _ f -> do r <- makeSchResults mbv var | 50 | -- searchQuery :: nid -> ni -> (qk -> Result ([ni], [r], Maybe tok) -> IO ()) -> IO qk |
52 | let qk = maybe 0 (\(ns,_,_) -> head ns) r | 51 | , searchQuery = \_ _ f -> do |
53 | f qk $ maybe TimedOut Success r | 52 | val <- atomically $ do |
54 | return qk | 53 | n <- readTVar var |
54 | writeTVar var $! n + 1 | ||
55 | return n | ||
56 | tm <- getSystemTimerManager | ||
57 | k <- registerTimeout tm 200000 $ do | ||
58 | putStrLn $ "makeSchResults " ++ show val | ||
59 | r <- makeSchResults mbv var | ||
60 | f val (Success r) | ||
61 | return val | ||
55 | , searchQueryCancel = \_ _ -> return () | 62 | , searchQueryCancel = \_ _ -> return () |
56 | , searchAlpha = 4 | 63 | , searchAlpha = 4 |
57 | , searchK = 8 | 64 | , searchK = 8 |