{-# 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.Default
import Data.List as L
import Test.Hspec
import Test.QuickCheck

import Network.BitTorrent.Core
import Network.BitTorrent.DHT
import Network.BitTorrent.DHT.Message
import Network.BitTorrent.DHT.Session

import Data.Torrent.InfoHashSpec ()
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) 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 stopNode called" $ do
      node <- newNode [] def myAddr nullLogger
      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
           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    <-  asks thisNodeId
          return (remoteId, thisId)
        rid `shouldBe` tid

    describe "queryParallel" $ do
      it "should handle parallel requests" $ do
        (nid, resps) <- simpleDHT $ (,)
          <$> asks thisNodeId
          <*> queryParallel (L.replicate 100 $ queryNode myAddr Ping)
        resps `shouldSatisfy` L.all (== (nid, Ping))

    describe "(<@>) operator" $ do
      it "" $
         pending