diff options
author | Joe Crayne <joe@jerkface.net> | 2020-01-08 02:03:12 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-08 02:03:12 -0500 |
commit | 4d3122c055cc93a902ac24b8aba1323422519ce7 (patch) | |
tree | 3713d577d03a839851d96b1818c897ed02edf139 | |
parent | 2782cde60ac66c75d1e1ab6993a3075e375c1786 (diff) |
Oops, forgot to commit this.
-rw-r--r-- | kad/tests/searchReset.hs | 120 |
1 files changed, 120 insertions, 0 deletions
diff --git a/kad/tests/searchReset.hs b/kad/tests/searchReset.hs new file mode 100644 index 00000000..a48b5aae --- /dev/null +++ b/kad/tests/searchReset.hs | |||
@@ -0,0 +1,120 @@ | |||
1 | import Control.Concurrent | ||
2 | import Control.Concurrent.STM | ||
3 | import Control.Monad | ||
4 | import Data.Bits | ||
5 | import GHC.Event | ||
6 | |||
7 | import Network.Kademlia | ||
8 | import Network.Kademlia.Bootstrap | ||
9 | import Network.Kademlia.CommonAPI | ||
10 | import Network.Kademlia.Persistence | ||
11 | import Network.Kademlia.Routing | ||
12 | import Network.Kademlia.Search | ||
13 | |||
14 | import Network.QueryResponse as QR | ||
15 | import qualified Data.MinMaxPSQ as MM | ||
16 | import qualified Data.Set as Set | ||
17 | |||
18 | makeSchResults :: TVar (Maybe (SearchState Int Int () Int Int Int)) -> TVar Int -> IO ([Int],[Int],Maybe ()) | ||
19 | makeSchResults mbv var = do | ||
20 | (r,io) <- atomically $ do | ||
21 | n <- readTVar var | ||
22 | let ns = take 4 [n .. ] | ||
23 | writeTVar var $! n + 4 | ||
24 | let r = (ns, ns, Just ()) -- Maybe ([ni], [r], Maybe tok) | ||
25 | stmio = if n > 490 | ||
26 | then do | ||
27 | ms <- readTVar mbv | ||
28 | case ms of | ||
29 | Just s -> do report <- showSearchState s | ||
30 | return $ putStrLn $ "cnt=" ++ show n ++ " " ++ report | ||
31 | _ -> return $ return () | ||
32 | else return $ return () | ||
33 | io <- stmio | ||
34 | return (r,io) | ||
35 | io | ||
36 | return r | ||
37 | |||
38 | kad :: KademliaSpace Int Int | ||
39 | kad = KademliaSpace | ||
40 | { kademliaLocation = id | ||
41 | , kademliaTestBit = \x i -> testBit i x | ||
42 | , kademliaXor = \x y -> abs (x - y) | ||
43 | , kademliaSample = \_ x _ -> pure x | ||
44 | } | ||
45 | |||
46 | sch :: TVar (Maybe (SearchState Int Int () Int Int Int)) -> TVar Int -> Search Int Int () Int Int Int | ||
47 | sch mbv var = Search | ||
48 | { searchSpace = kad | ||
49 | , searchNodeAddress = id | ||
50 | -- searchQuery :: nid -> ni -> (qk -> Result ([ni], [r], Maybe tok) -> IO ()) -> IO qk | ||
51 | , searchQuery = \_ _ f -> do | ||
52 | val <- atomically $ do | ||
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 | ||
62 | -- searchQueryCancel :: (IO () -> STM ()) -> qk -> STM () | ||
63 | , searchQueryCancel = \runio qk -> do | ||
64 | runio $ putStrLn $ "CANCEL " ++ show qk | ||
65 | return () | ||
66 | , searchAlpha = 4 | ||
67 | , searchK = 8 | ||
68 | } | ||
69 | |||
70 | onResult :: Int -> STM Bool | ||
71 | onResult k = return (k < 50000) | ||
72 | |||
73 | showSearchState st = do | ||
74 | pc <- readTVar (searchPendingCount st) | ||
75 | q <- readTVar (searchQueued st) | ||
76 | inf <- readTVar (searchInformant st) | ||
77 | vset <- readTVar (searchVisited st) | ||
78 | return $ unwords | ||
79 | [ "pending=" ++ show pc | ||
80 | , "|q|=" ++ show (maybe 0 MM.size q) | ||
81 | , "|inf|=" ++ show (MM.size inf) | ||
82 | , "|visited|=" ++ show (Set.size vset) | ||
83 | ] | ||
84 | |||
85 | main = do | ||
86 | var <- newTVarIO 5 | ||
87 | fin <- newTVarIO False | ||
88 | mbstvar <- newTVarIO Nothing | ||
89 | s <- atomically $ newSearch (sch mbstvar var) maxBound [1..4] | ||
90 | atomically $ writeTVar mbstvar (Just s) | ||
91 | t <- forkIO $ do searchLoop (sch mbstvar var) maxBound onResult s | ||
92 | atomically $ writeTVar fin True | ||
93 | |||
94 | putStrLn "Waiting on counter." | ||
95 | (done,n) <- atomically $ do | ||
96 | done <- readTVar fin | ||
97 | n <- readTVar var | ||
98 | if (not done && n < 500) | ||
99 | then retry | ||
100 | else return (done,n) | ||
101 | putStrLn $ "(done,n) = " ++ show (done,n) | ||
102 | report <- atomically $ do | ||
103 | report <- showSearchState s | ||
104 | searchCancel s | ||
105 | return report | ||
106 | putStrLn report | ||
107 | putStrLn "Canceled. Awaiting fin. The program should quit shortly without much output after this." | ||
108 | |||
109 | forkIO $ | ||
110 | let loop = do | ||
111 | (x,report) <- atomically $ (,) <$> readTVar var <*> showSearchState s | ||
112 | putStrLn $ "query after cancel! " ++ show x ++ " " ++ report | ||
113 | atomically $ readTVar var >>= \y -> if x == y then retry else return () | ||
114 | loop | ||
115 | in loop | ||
116 | -- atomically $ check =<< readTVar fin | ||
117 | putStrLn $ "Awaiting reset" | ||
118 | let near nid = return [1..4] | ||
119 | reset near (sch mbstvar var) maxBound s | ||
120 | putStrLn $ "Finished." | ||