6 files changed, 600 insertions, 0 deletions

diff --git a/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs
new file mode 100644
index 00000000..6f3c7489
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/MessageSpec.hs
@@ -0,0 +1,221 @@
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent.DHT.MessageSpec (spec) where
+import Control.Monad.Reader
+import Control.Monad.Logger
+import Control.Concurrent
+import Data.BEncode as BE
+import Data.ByteString.Lazy as BL
+import Data.Default
+import Data.List as L
+import Data.Maybe
+import Network.BitTorrent.Address
+import Network.BitTorrent.DHT.Message
+import qualified Network.KRPC as KRPC (def)
+import Network.KRPC hiding (def)
+import Network.Socket (PortNumber)
+import Test.Hspec
+import Test.QuickCheck
+import System.Timeout
+
+import Data.TorrentSpec                 ()
+import Network.BitTorrent.CoreSpec      ()
+import Network.BitTorrent.DHT.TokenSpec ()
+
+-- Arbitrary queries and responses.
+instance Arbitrary Ping where arbitrary = pure Ping
+instance Arbitrary FindNode where arbitrary = FindNode <$> arbitrary
+instance Arbitrary ip => Arbitrary (NodeFound ip) where arbitrary = NodeFound <$> arbitrary
+instance Arbitrary GetPeers where arbitrary = GetPeers <$> arbitrary
+instance Arbitrary ip => Arbitrary (GotPeers ip) where arbitrary =  GotPeers <$> arbitrary <*> arbitrary
+instance Arbitrary Announce where arbitrary = Announce <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
+instance Arbitrary Announced where arbitrary = pure Announced
+instance Arbitrary x => Arbitrary (Query x) where arbitrary = Query <$> arbitrary <*> arbitrary <*> arbitrary
+instance Arbitrary x => Arbitrary (Response x) where arbitrary = Response <$> arbitrary <*> arbitrary
+
+instance MonadLogger IO where
+  monadLoggerLog _ _ _ _ = return ()
+
+remoteAddr :: SockAddr
+remoteAddr = SockAddrInet 6881 (256 * 256 * 256 + 127)
+
+thisAddr :: SockAddr
+thisAddr = SockAddrInet 60000 (256 * 256 * 256 + 127)
+
+thisPort :: PortNumber
+thisPort = 60001
+
+rpc :: ReaderT (Manager IO) IO a -> IO a
+rpc action = do
+  withManager KRPC.def thisAddr [] $ runReaderT $ do
+    listen
+    action
+
+isQueryError :: QueryFailure -> Bool
+isQueryError _ = True
+
+prop_bencode :: Eq a => Show a => BEncode a => a -> Expectation
+prop_bencode x = BE.decode (BL.toStrict (BE.encode x)) `shouldBe` Right x
+
+retry :: Int -> IO (Maybe a) -> IO (Maybe a)
+retry 0 _ = return Nothing
+retry n a = do
+  res <- a
+  case res of
+    Just _ -> return res
+    Nothing -> threadDelay (100 * 1000) >> retry (n-1) a
+
+spec :: Spec
+spec = do
+ context ("you need running DHT node at " ++ show remoteAddr) $ do
+  it "is running" $ do
+         running <- retry 5 $ timeout (100 * 1000) $ do
+                      nid <- genNodeId
+                      Response _remoteAddr Ping <-
+                          rpc (query remoteAddr (Query nid False Ping))
+                      return ()
+         running `shouldSatisfy` isJust
+
+  describe "ping" $ do
+    it "properly bencoded" $ do
+      BE.decode "d2:id20:abcdefghij0123456789e"
+        `shouldBe` Right (Query "abcdefghij0123456789" False Ping)
+
+      BE.encode (Query "abcdefghij0123456789" False Ping)
+        `shouldBe` "d2:id20:abcdefghij0123456789e"
+
+      BE.decode "d2:id20:mnopqrstuvwxyz123456e"
+        `shouldBe` Right (Response "mnopqrstuvwxyz123456" Ping)
+
+      BE.encode (Response "mnopqrstuvwxyz123456" Ping)
+        `shouldBe` "d2:id20:mnopqrstuvwxyz123456e"
+
+    it "properly bencoded (iso)" $ property $ \ nid -> do
+      prop_bencode (Query    nid False Ping)
+      prop_bencode (Response nid Ping)
+
+    it "does compatible with existing DHT" $ do
+      nid <- genNodeId
+      Response _remoteAddr Ping <- rpc (query remoteAddr (Query nid False Ping))
+      return ()
+
+  describe "find_node" $ do
+    it "properly bencoded" $ do
+      BE.decode "d2:id20:abcdefghij0123456789\
+                 \6:target20:mnopqrstuvwxyz123456e"
+        `shouldBe` Right (Query "abcdefghij0123456789" False
+                      (FindNode "mnopqrstuvwxyz123456"))
+
+      BE.encode (Query "abcdefghij0123456789" False
+                 (FindNode "mnopqrstuvwxyz123456"))
+        `shouldBe`
+         "d2:id20:abcdefghij01234567896:target20:mnopqrstuvwxyz123456e"
+
+      let naddr = "127.0.0.1:258" :: NodeAddr IPv4
+      let nid  = "0123456789abcdefghij"
+      let nid' = "mnopqrstuvwxyz123456"
+      BE.decode "d2:id20:0123456789abcdefghij\
+                 \5:nodes26:mnopqrstuvwxyz123456\127\0\0\1\1\2\
+                \e"
+       `shouldBe` Right (Response nid (NodeFound [NodeInfo nid' naddr]))
+
+    it "properly bencoded (iso)" $ property $ \ nid x xs -> do
+      prop_bencode (Query    nid False (FindNode  x))
+      prop_bencode (Response nid (NodeFound (xs :: [NodeInfo IPv4] )))
+
+    it "does compatible with existing DHT" $ do
+      nid <- genNodeId
+      Response _remoteAddr (NodeFound xs) <- rpc $ do
+        query remoteAddr (Query nid False (FindNode nid))
+      L.length (xs :: [NodeInfo IPv4]) `shouldSatisfy` (> 0)
+
+  describe "get_peers" $ do
+    it "properly bencoded" $ do
+       BE.decode "d2:id20:abcdefghij0123456789\
+                  \9:info_hash20:mnopqrstuvwxyz123456\
+                  \e"
+         `shouldBe` Right (Query "abcdefghij0123456789" False
+                           (GetPeers "mnopqrstuvwxyz123456"))
+
+       BE.decode "d2:id20:abcdefghij0123456789\
+                  \5:token8:aoeusnth\
+                  \6:valuesl6:\127\0\0\1\1\2\&6:\192\168\1\100\1\2e\
+                 \e"
+         `shouldBe` Right (Response "abcdefghij0123456789"
+             (GotPeers (Right [ "127.0.0.1:258" :: PeerAddr IPv4
+                              , "192.168.1.100:258"
+                              ]) "aoeusnth"))
+
+       BE.decode "d2:id20:abcdefghij0123456789\
+                  \5:nodes26:mnopqrstuvwxyz123456\127\0\0\1\1\2\
+                  \5:token8:aoeusnth\
+                 \e"
+         `shouldBe` Right (Response "abcdefghij0123456789"
+            (GotPeers
+             { peers = Left [NodeInfo "mnopqrstuvwxyz123456" "127.0.0.1:258"
+                                 :: NodeInfo IPv4]
+             , grantedToken = "aoeusnth"
+             }))
+
+    it "properly bencoded (iso)" $ property $ \ nid topic exs token -> do
+      prop_bencode (Query    nid False (GetPeers topic))
+      let _ = exs :: Either [NodeInfo IPv4] [PeerAddr IPv4]
+      let nullPeerId paddr = paddr {peerId = Nothing}
+      let nullPeerIds      = either Left (Right . L.map nullPeerId)
+      prop_bencode (Response nid (GotPeers (nullPeerIds exs) token))
+
+    it "does compatible with existing DHT" $ do
+      nid <- genNodeId
+      Response _remoteId (GotPeers {..})
+        <- rpc $ query remoteAddr (Query nid False (GetPeers def))
+      let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4]
+      either L.length L.length peers `shouldSatisfy` (> 0)
+
+  describe "announce" $ do
+    it "properly bencoded" $ do
+      BE.decode "d2:id20:abcdefghij0123456789\
+                 \9:info_hash20:mnopqrstuvwxyz123456\
+                 \4:porti6881e\
+                 \5:token8:aoeusnth\
+                \e" `shouldBe` Right
+        (Query "abcdefghij0123456789" False
+                   (Announce False "mnopqrstuvwxyz123456" Nothing 6881 "aoeusnth"))
+
+      BE.decode "d2:id20:abcdefghij0123456789\
+                 \12:implied_porti1e\
+                 \9:info_hash20:mnopqrstuvwxyz123456\
+                 \4:porti6881e\
+                 \5:token8:aoeusnth\
+                \e" `shouldBe` Right
+        (Query "abcdefghij0123456789" False
+                   (Announce True "mnopqrstuvwxyz123456" Nothing 6881 "aoeusnth"))
+
+
+      BE.decode "d2:id20:mnopqrstuvwxyz123456e"
+        `shouldBe` Right
+        (Response "mnopqrstuvwxyz123456" Announced)
+
+    it "properly bencoded (iso)" $ property $ \ nid flag topic port token -> do
+      prop_bencode (Query    nid False (Announce flag topic Nothing port token))
+      prop_bencode (Response nid (Announced))
+
+
+    it "does compatible with existing DHT" $ do
+      nid <- genNodeId
+      Response _remoteId Announced <- rpc $ do
+        Response _ GotPeers {..} <- query remoteAddr (Query nid False (GetPeers def))
+        let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4]
+        query remoteAddr (Query nid False (Announce False def Nothing thisPort grantedToken))
+      return ()
+
+    it "does fail on invalid token" $ do
+      nid <- genNodeId
+      (rpc $ do
+        Response _ GotPeers {..} <- query remoteAddr (Query nid False (GetPeers def))
+        let _ = peers :: Either [NodeInfo IPv4] [PeerAddr IPv4]
+        let invalidToken = ""
+        let q :: MonadKRPC h m => SockAddr -> Query Announce
+              -> m (Response Announced)
+            q = query
+        q remoteAddr (Query nid False (Announce False def Nothing thisPort invalidToken)))
+          `shouldThrow` isQueryError
+      return ()
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs
new file mode 100644
index 00000000..93f78263
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/QuerySpec.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE RecordWildCards #-}
+module Network.BitTorrent.DHT.QuerySpec (spec) where
+import Control.Applicative
+import Control.Exception
+import Control.Monad.Reader
+import Data.Conduit as C
+import Data.Conduit.List as CL
+import Data.Default
+import Data.List as L
+import Test.Hspec
+
+import Network.BitTorrent.Address
+import Network.BitTorrent.DHT
+import Network.BitTorrent.DHT.Session
+import Network.BitTorrent.DHT.Query
+
+import Network.BitTorrent.DHT.TestData
+
+
+myAddr :: NodeAddr IPv4
+myAddr = "0.0.0.0:0"
+
+nullLogger :: LogFun
+nullLogger _ _ _ _ = return ()
+
+--simpleLogger :: LogFun
+--simpleLogger _ t _ _ = print t
+
+simpleDHT :: [NodeHandler IPv4] -> DHT IPv4 a -> IO a
+simpleDHT hs m =
+  bracket (newNode hs def myAddr nullLogger Nothing) closeNode $ \ node ->
+    runDHT node m
+
+getBootInfo :: IO (NodeInfo IPv4)
+getBootInfo = do
+  startAddr <- resolveHostName (L.head defaultBootstrapNodes)
+  simpleDHT [] $ fmap fst (pingQ startAddr)
+
+spec :: Spec
+spec = parallel $ do
+  describe "environment" $ do
+    describe "test node" $ do
+      it "is alive" $ do
+         _ <- getBootInfo
+         return ()
+
+  describe "handlers" $ do
+    it "" $ pendingWith "need to setup 2 DHT locally"
+
+  describe "basic queries" $ do
+    it "ping" $ do
+      _ <- getBootInfo
+      return ()
+
+    it "findNode" $ do
+      startInfo <- getBootInfo
+      _ <- simpleDHT [] $ do
+        nid <- myNodeIdAccordingTo (read "8.8.8.8:6881")
+        findNodeQ nid startInfo
+      return ()
+
+    it "getPeers" $ do
+      startInfo <- getBootInfo
+      peers <- simpleDHT [] $ do
+        nid <- myNodeIdAccordingTo (read "8.8.8.8:6881")
+
+        -- we should not run getPeers query on boot node, because
+        -- it may not support it
+        Right infos <- findNodeQ nid startInfo
+
+        when (L.null infos) $
+          error "boot node malfunction"
+
+        -- at least one node should reply
+        queryParallel $ do
+          getPeersQ (entryHash (L.head testTorrents)) <$> infos
+
+      peers `shouldSatisfy` (not . L.null)
+
+    it "announce" $ do
+      bootNode <- getBootInfo
+      _ <- simpleDHT [] $ do
+        let ih = entryHash (L.head testTorrents)
+        Right nodes <- findNodeQ ih bootNode
+
+        when (L.null nodes) $
+          error "boot node malfunction"
+
+        queryParallel $ do
+          announceQ ih (nodePort myAddr) <$> nodes
+
+      return ()
+
+  describe "iterative queries" $ do
+    forM_ testTorrents $ \ TestEntry {..} -> do
+      context entryName $ do
+
+        it "get at least 10 unique peers for each infohash" $ do
+          bootNode <- getBootInfo
+          peers <- simpleDHT [] $ do
+            Right startNodes <- findNodeQ entryHash bootNode
+            sourceList [startNodes] $=
+              search entryHash (getPeersQ entryHash) $=
+                CL.concat $$ CL.take 10
+          L.length peers `shouldBe` 10
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs
new file mode 100644
index 00000000..07a906ba
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/RoutingSpec.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts    #-}
+module Network.BitTorrent.DHT.RoutingSpec (spec) where
+import Control.Applicative
+import Control.Monad.State
+import Data.Default
+import Data.List as L
+import Data.Maybe
+import Test.Hspec
+import Test.QuickCheck
+
+import Network.BitTorrent.Address
+import Network.BitTorrent.DHT.Routing as T
+
+import Network.BitTorrent.CoreSpec hiding (spec)
+
+
+type Network ip = [NodeAddr ip]
+
+data Env ip = Env
+  { currentTime :: Timestamp
+  , network     :: Network ip
+  } deriving Show
+
+type Simulation ip = State (Env ip)
+
+runSimulation :: Eq ip => Env ip -> Routing ip a -> Maybe a
+runSimulation e m = evalState (runRouting ping closest timestamp m) e
+  where
+    ping    addr = gets (L.elem addr . network)
+    closest nid  = error "runSimulation"
+    timestamp    = gets currentTime
+
+instance Arbitrary ip => Arbitrary (Env ip) where
+  arbitrary = Env <$> arbitrary <*> (vector nodeCount)
+    where
+      nodeCount = 1000
+
+instance (Arbitrary ip, Eq ip) => Arbitrary (Table ip) where
+  arbitrary = do
+    thisId  <- arbitrary
+    bucketN <- choose (1, 20)
+    let table = nullTable thisId bucketN
+
+--    nodeN   <- (`mod` bucketN) <$> arbitrary
+--    nodes   <- vector nodeN
+
+    node    <- arbitrary
+    mt <- do
+        env <- arbitrary
+        return $ runSimulation env $ do
+            (_,t') <- T.insert (currentTime env) (TryInsert node) table
+            return t' :: Routing ip (Table ip)
+          --(foldM (flip fillTable) table nodes)
+    return (fromJust mt)
+--    where
+--     fillTable x t = do
+--       t' <- T.insert x t
+--       return $ if T.full t' then t else t'
+
+spec :: Spec
+spec = do
+  describe "size" $ do
+    it "null table is empty" $ do
+      T.size (nullTable def 2 :: Table IPv4) `shouldBe` 0
+
+    it "the same node never appear in different buckets" $ property $ \ t -> do
+      let xss = T.toList (t :: Table Int)
+      let justOnce x = L.length (L.filter (L.elem x) xss) == 1
+      L.all justOnce (L.concat xss)
+
+    it "insert is idemponent" $ property $ \ (e :: Env Int) n t -> do
+      let ins :: NodeInfo Int -> Table Int -> Routing Int (Table Int)
+          ins n t = snd <$> T.insert (currentTime e) (TryInsert n) t
+      let t1 = runSimulation e (ins n t)
+      let t2 = runSimulation e (ins n t >>= ins n)
+      t1 `shouldBe` t2
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs
new file mode 100644
index 00000000..32e4c158
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/SessionSpec.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Network.BitTorrent.DHT.SessionSpec (spec) where
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Control.Monad.Reader
+import Control.Monad.Trans.Resource
+import Data.Conduit.Lazy
+import Data.Default
+import Data.List as L
+import Test.Hspec
+import Test.QuickCheck
+
+import Network.BitTorrent.Address
+import Network.BitTorrent.DHT
+import Network.BitTorrent.DHT.Message
+import Network.BitTorrent.DHT.Session
+import Network.BitTorrent.DHT.Query
+
+import Data.TorrentSpec ()
+import Network.BitTorrent.CoreSpec ()
+import Network.BitTorrent.DHT.TokenSpec ()
+
+
+myAddr :: NodeAddr IPv4
+myAddr = "127.0.0.1:60000"
+
+simpleDHT :: DHT IPv4 a -> IO a
+simpleDHT m =
+  bracket (newNode defaultHandlers def myAddr nullLogger Nothing) closeNode $ \ node ->
+    runDHT node m
+
+isRight :: Either a b -> Bool
+isRight (Left  _) = False
+isRight (Right _) = True
+
+isLeft :: Either a b -> Bool
+isLeft = not . isRight
+
+nullLogger :: LogFun
+nullLogger _ _ _ _ = return ()
+
+spec :: Spec
+spec = do
+  describe "session" $ do
+    it "is active until closeNode called" $ do
+      node <- newNode [] def myAddr nullLogger Nothing
+      runDHT node monadActive `shouldReturn` True
+      runDHT node monadActive `shouldReturn` True
+      closeNode node
+      runDHT node monadActive `shouldReturn` False
+
+  describe "tokens" $ do
+    it "should not complain about valid token" $
+      property $ \ (addrs :: [NodeAddr IPv4]) -> do
+        isOks <- simpleDHT $ do
+          forM addrs $ \ addr -> do
+            token <- grantToken addr
+            checkToken addr token
+        L.and isOks `shouldBe` True
+
+    it "should complain about invalid token" $
+      property $ \ (addr :: NodeAddr IPv4) token -> do
+        isOk <- simpleDHT (checkToken addr token)
+        isOk `shouldBe` False
+
+  describe "routing table" $
+    it "accept any node entry when table is empty" $
+      property $ \ (nid :: NodeId) -> do
+        let info = NodeInfo nid myAddr
+        closest <- simpleDHT $ do
+           _ <- insertNode info Nothing
+           liftIO $ yield
+           getClosest nid
+        closest `shouldSatisfy` L.elem info
+
+  describe "peer storage" $ do
+    it "should return nodes, if there are no peers" $ property $ \ ih -> do
+      res <- simpleDHT $ do getPeerList ih
+      res `shouldSatisfy` isLeft
+
+    it "should return peers, if any" $ property $ \ ih addr -> do
+      res <- simpleDHT $ do
+                 insertPeer ih addr
+                 getPeerList ih
+      res `shouldSatisfy` isRight
+
+  describe "topic storage" $ do
+    it "should not grow indefinitely" $ do
+      pending
+
+  describe "messaging" $ do
+    describe "queryNode" $ do
+      it "should always ping this node" $ do
+        (rid, tid) <- simpleDHT $ do
+          (remoteId, Ping) <- queryNode myAddr Ping
+          thisId <- myNodeIdAccordingTo (read "8.8.8.8:6881")
+          return (remoteId, thisId)
+        rid `shouldBe` tid
+
+    describe "queryParallel" $ do
+      it "should handle parallel requests" $ do
+        (nid, resps) <- simpleDHT $ do
+          me <- myNodeIdAccordingTo (read "8.8.8.8:6881")
+          ( (,) me ) <$> queryParallel (L.replicate 100 $ queryNode myAddr Ping)
+        resps `shouldSatisfy` L.all (== (nid, Ping))
+
+    describe "(<@>) operator" $ do
+      it "" $
+         pending
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs b/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs
new file mode 100644
index 00000000..e9473cbb
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/TestData.hs
@@ -0,0 +1,45 @@
+module Network.BitTorrent.DHT.TestData
+       ( TestEntry (..)
+       , testTorrents
+       ) where
+
+import Data.Torrent
+
+data TestEntry = TestEntry
+  { entryName  :: String
+  , entryHash  :: InfoHash
+  , entryPeers :: Int -- ^ approximate number of peers, may change with time
+  }
+
+testTorrents :: [TestEntry]
+testTorrents =
+  [ TestEntry
+    { entryName  = "Automate with Arduino, Android..."
+    , entryHash  = "8c0433e541dc5d1cfc095799cef171cd4eb586f7"
+    , entryPeers = 300
+    }
+
+  , TestEntry
+    { entryName  = "Beginning Programming with Java For Dummies"
+    , entryHash  = "fd8967721731cc16c8b203a03e49ce839cecf184"
+    , entryPeers = 200
+    }
+
+  , TestEntry
+    { entryName  = "The C Programming Language"
+    , entryHash  = "146d13f090e50e97091dbbe5b37678dd1471cfad"
+    , entryPeers = 100
+    }
+
+  , TestEntry
+    { entryName  = "The C++ Programming Language"
+    , entryHash  = "8e8e8e6319031a22cff26d895afe050085c84a7f"
+    , entryPeers = 50
+    }
+
+  , TestEntry
+    { entryName  = "Game and Graphics Programming for iOS..."
+    , entryHash  = "703d0595b727fccbfaa3d03be25f57347ccfd6de"
+    , entryPeers = 30
+    }
+  ]
diff --git a/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs b/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs
new file mode 100644
index 00000000..a45d2212
--- /dev/null
+++ b/bittorrent/tests/Network/BitTorrent/DHT/TokenSpec.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Network.BitTorrent.DHT.TokenSpec (spec) where
+import Control.Applicative
+import Data.List as L
+import Data.String
+import Test.Hspec
+import Test.QuickCheck
+
+import Network.BitTorrent.Address
+import Network.BitTorrent.CoreSpec ()
+import Network.BitTorrent.DHT.Token as T
+
+
+instance Arbitrary Token where
+  arbitrary = fromString <$> arbitrary
+
+instance Arbitrary TokenMap where
+  arbitrary = tokens <$> arbitrary
+
+repeatN :: Int -> (a -> a) -> (a -> a)
+repeatN n f = L.foldr (.) id $ L.replicate n f
+
+spec :: Spec
+spec = do
+  describe "Token" $ do
+    return ()
+
+  describe "TokenMap" $ do
+    it "is keeping any granted token in current session" $
+      property $ \ (addr :: NodeAddr IPv4) m ->
+        T.member addr (T.lookup addr m) m
+
+    it "is keeping any granted token in next session" $
+      property $ \ (addr :: NodeAddr IPv4) m ->
+        T.member addr (T.lookup addr m) (T.update m)
+
+    -- can fail with some small probability
+    it "is rejecting any outdated tokens" $
+      property $ \ (addr :: NodeAddr IPv4) m k -> not $
+        let n = min 100 (abs k + 2) in
+        T.member addr (T.lookup addr m) (repeatN n T.update m)
\ No newline at end of file