diff options
author | Joe Crayne <joe@jerkface.net> | 2019-12-28 15:23:39 -0500 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 23:28:00 -0500 |
commit | cad7670b1f62ea03627e8cff009f598bb76ca067 (patch) | |
tree | 332ad72779435258dc08f55850ac404a3b366532 /kad | |
parent | 3ea58661542e7677371a7947e311a1def442b959 (diff) |
Added test program.
Diffstat (limited to 'kad')
-rw-r--r-- | kad/kad.cabal | 6 | ||||
-rw-r--r-- | kad/tests/searchCancel.hs | 67 |
2 files changed, 73 insertions, 0 deletions
diff --git a/kad/kad.cabal b/kad/kad.cabal index d709059c..ee3754b1 100644 --- a/kad/kad.cabal +++ b/kad/kad.cabal | |||
@@ -88,3 +88,9 @@ library | |||
88 | , tasks | 88 | , tasks |
89 | hs-source-dirs: src | 89 | hs-source-dirs: src |
90 | default-language: Haskell2010 | 90 | default-language: Haskell2010 |
91 | |||
92 | executable testSearch | ||
93 | hs-source-dirs: tests | ||
94 | build-depends: kad, base, stm | ||
95 | main-is: searchCancel.hs | ||
96 | |||
diff --git a/kad/tests/searchCancel.hs b/kad/tests/searchCancel.hs new file mode 100644 index 00000000..3458ab37 --- /dev/null +++ b/kad/tests/searchCancel.hs | |||
@@ -0,0 +1,67 @@ | |||
1 | import Control.Concurrent | ||
2 | import Control.Concurrent.STM | ||
3 | import Control.Monad | ||
4 | import Data.Bits | ||
5 | |||
6 | import Network.Kademlia | ||
7 | import Network.Kademlia.Bootstrap | ||
8 | import Network.Kademlia.CommonAPI | ||
9 | import Network.Kademlia.Persistence | ||
10 | import Network.Kademlia.Routing | ||
11 | import Network.Kademlia.Search | ||
12 | |||
13 | makeSchResults :: TVar Int -> IO (Maybe ([Int],[Int],Maybe ())) | ||
14 | makeSchResults var = do | ||
15 | threadDelay 100000 | ||
16 | atomically $ do | ||
17 | n <- readTVar var | ||
18 | let ns = take 4 [n .. ] | ||
19 | writeTVar var $! n + 4 | ||
20 | return $ Just (ns, ns, Just ()) -- Maybe ([ni], [r], Maybe tok) | ||
21 | |||
22 | kad :: KademliaSpace Int Int | ||
23 | kad = KademliaSpace | ||
24 | { kademliaLocation = id | ||
25 | , kademliaTestBit = \x i -> testBit i x | ||
26 | , kademliaXor = \x y -> abs (x - y) | ||
27 | , kademliaSample = \_ x _ -> pure x | ||
28 | } | ||
29 | |||
30 | sch :: TVar Int -> Search Int Int () Int Int | ||
31 | sch var = Search | ||
32 | { searchSpace = kad | ||
33 | , searchNodeAddress = id | ||
34 | , searchQuery = \_ _ -> makeSchResults var | ||
35 | , searchAlpha = 4 | ||
36 | , searchK = 8 | ||
37 | } | ||
38 | |||
39 | onResult :: Int -> STM Bool | ||
40 | onResult k = return (k < 50000) | ||
41 | |||
42 | main = do | ||
43 | var <- newTVarIO 0 | ||
44 | fin <- newTVarIO False | ||
45 | s <- atomically $ newSearch (sch var) maxBound [1..4] | ||
46 | t <- forkIO $ do searchLoop (sch var) maxBound onResult s | ||
47 | atomically $ writeTVar fin True | ||
48 | |||
49 | putStrLn "Waiting on counter." | ||
50 | (done,n) <- atomically $ do | ||
51 | done <- readTVar fin | ||
52 | n <- readTVar var | ||
53 | if (not done && n < 500) | ||
54 | then retry | ||
55 | else return (done,n) | ||
56 | putStrLn $ "(done,n) = " ++ show (done,n) | ||
57 | atomically $ searchCancel s | ||
58 | putStrLn "Canceled. Awaiting fin. The program should quit shortly without much output after this." | ||
59 | |||
60 | forkIO $ | ||
61 | let loop = do | ||
62 | x <- atomically $ readTVar var | ||
63 | putStrLn $ "query after cancel! " ++ show x | ||
64 | atomically $ readTVar var >>= \y -> if x == y then retry else return () | ||
65 | loop | ||
66 | in loop | ||
67 | atomically $ check =<< readTVar fin | ||