Added test program.

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
         , tasks
   hs-source-dirs:      src
   default-language:    Haskell2010
+
+executable testSearch
+  hs-source-dirs:      tests
+  build-depends: kad, base, stm
+  main-is: searchCancel.hs
+
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 @@
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Data.Bits
+
+import Network.Kademlia
+import Network.Kademlia.Bootstrap
+import Network.Kademlia.CommonAPI
+import Network.Kademlia.Persistence
+import Network.Kademlia.Routing
+import Network.Kademlia.Search
+
+makeSchResults :: TVar Int -> IO (Maybe ([Int],[Int],Maybe ()))
+makeSchResults var = do
+    threadDelay 100000
+    atomically $ do
+        n <- readTVar var
+        let ns = take 4 [n .. ]
+        writeTVar var $! n + 4
+        return $ Just (ns, ns, Just ()) -- Maybe ([ni], [r], Maybe tok)
+
+kad :: KademliaSpace Int Int
+kad = KademliaSpace
+    { kademliaLocation = id
+    , kademliaTestBit  = \x i -> testBit i x
+    , kademliaXor      = \x y -> abs (x - y)
+    , kademliaSample   = \_ x _ -> pure x
+    }
+
+sch :: TVar Int -> Search Int Int () Int Int
+sch var = Search
+    { searchSpace       = kad
+    , searchNodeAddress = id
+    , searchQuery       = \_ _ -> makeSchResults var
+    , searchAlpha       = 4
+    , searchK           = 8
+    }
+
+onResult :: Int -> STM Bool
+onResult k = return (k < 50000)
+
+main = do
+    var <- newTVarIO 0
+    fin <- newTVarIO False
+    s <- atomically $ newSearch (sch var) maxBound [1..4]
+    t <- forkIO $ do searchLoop (sch var) maxBound onResult s
+                     atomically $ writeTVar fin True
+
+    putStrLn "Waiting on counter."
+    (done,n) <- atomically $ do
+        done <- readTVar fin
+        n <- readTVar var
+        if (not done && n < 500)
+            then retry
+            else return (done,n)
+    putStrLn $ "(done,n) = " ++ show (done,n)
+    atomically $ searchCancel s
+    putStrLn "Canceled.  Awaiting fin.  The program should quit shortly without much output after this."
+
+    forkIO $
+        let loop = do
+                x <- atomically $ readTVar var
+                putStrLn $ "query after cancel! " ++ show x
+                atomically $ readTVar var >>= \y -> if x == y then retry else return ()
+                loop
+        in loop
+    atomically $ check =<< readTVar fin