{-# LANGUAGE ScopedTypeVariables #-}
import Prelude hiding            (lookup)
import Control.Concurrent        (threadDelay)
import Control.Exception         (Exception(..), SomeException(..))
import Control.Monad.Except      (runExceptT)
import Control.Monad.Trans.Maybe (runMaybeT)
import Data.Default              (def)
import Data.TTLHashTable
import Test.Hspec

import qualified Data.HashTable.ST.Basic as Basic
import qualified Data.HashTable.ST.Cuckoo as Cuckoo

withUnlimitedTTLHashTable :: IO (TTLHashTable Basic.HashTable Int String)
withUnlimitedTTLHashTable = new

withSizedRenewableTTLHashTable :: IO (TTLHashTable Cuckoo.HashTable Int String)
withSizedRenewableTTLHashTable = newWithSettings def { maxSize = 2,
                                                       defaultTTL = 100,
                                                       gcMaxEntries = 1 }

withIntHashTable :: IO (TTLHashTable Basic.HashTable Int Int)
withIntHashTable = new

main :: IO ()
main = do
  hspec $ do
    before withUnlimitedTTLHashTable $
      describe "TTL Hash Table with default settings" $ do
        it "Checks that entries saved can be retrieved" $
          \ht -> do
            insert ht 1 "foo"
            v <- find ht 1
            v `shouldBe` Just "foo"
        it "Checks that entry expiration is observed" $
          \ht -> do
            insertWithTTL ht 100 1 "foo" -- TTL is 100 milliseconds
            v <- runMaybeT $ lookup ht 1
            v `shouldBe` Just "foo"
            threadDelay 200000 -- wait 200 mS
            v' <- runExceptT $ lookup ht 1
            v' `shouldSatisfy` hashTableError ExpiredEntry
        it "Checks that size is correctly reported" $
           \ht -> do
            insertWithTTL ht 100 1 "foo" -- TTL is 100 milliseconds
            insert ht 2 "bar"
            s <- size ht
            s `shouldBe` 2
            threadDelay 200000 -- wait 200 mS
            s' <- size ht
            s' `shouldBe` 2
            _ <- runExceptT $ lookupAndRenew ht 1
            s'' <- size ht
            s'' `shouldBe` 1
            delete ht 2
            s''' <- size ht
            s''' `shouldBe` 0
        it "Checks that lookup doesn't renew entry" $
          \ht -> do
            insertWithTTL ht 100 1 "foo"
            threadDelay 50000 -- wait 50 mS
            _ <- find ht 1
            threadDelay 50000 -- wait 50 mS
            _ <- find ht 1
            threadDelay 50000 -- wait 50 mS
            _ <- find ht 1
            threadDelay 50000 -- wait 50 mS
            v <- find ht 1
            v `shouldBe` Nothing
        it "Checks garbage collection" $
           \ht -> do
            insertWithTTL ht 100 2 "foo" -- TTL is 100 milliseconds
            threadDelay 200000 -- wait 200 mS
            left <- removeExpired ht
            left `shouldBe` 0
            s <- size ht
            s `shouldBe` 0
        it "Checks mutation" $
           \ht -> do
             mutate ht 1 $ \_ -> (Just "foo", ())
             s <- size ht
             s `shouldBe` 1
             mutate ht 1 $ \(Just "foo") -> (Just "bar", ())
             s' <- size ht
             s' `shouldBe` 1
             v <- find ht 1
             v `shouldBe` Just "bar"
             mutate ht 1 $ \(Just "bar") -> (Nothing, ())
             s'' <- size ht
             s'' `shouldBe` 0
             v' <- find ht 1
             v' `shouldBe` Nothing
    before withSizedRenewableTTLHashTable $
      describe "Renewable TTL Hash Table with max size" $ do
        it "Checks that max size is respected" $
          \ht -> do
            insert ht 1 "foo"
            insert ht 2 "bar"
            r <- runExceptT $ insert ht 3 "baz"
            r `shouldSatisfy` hashTableError HashTableFull
            r' <- runExceptT $ mutate ht 3 $ \Nothing -> (Just "baz", ())
            r' `shouldSatisfy` hashTableError HashTableFull
            s <- size ht
            s `shouldBe` 2
        it "Checks that lookup renews entry" $
          \ht -> do
            insert ht 1 "foo"
            threadDelay 50000 -- wait 50 mS
            _ <- lookupAndRenew ht 1
            threadDelay 50000 -- wait 50 mS
            _ <- lookupAndRenew ht 1
            threadDelay 50000 -- wait 50 mS
            _ <- lookupAndRenew ht 1
            threadDelay 50000 -- wait 50 mS
            v <- lookupAndRenew ht 1
            v `shouldBe` "foo"
        it "Checks that lookup doesn't renew expired entry" $
          \ht -> do
            insert ht 1 "foo"
            threadDelay 200000 -- 200 mS
            v <- runMaybeT $ lookup ht 1
            v `shouldBe` Nothing
        it "Checks that garbage collection works" $
           \ht -> do
             insertWithTTL ht 10000000 1 "foo"
             insert ht 2 "bar"
             threadDelay 200000
             left <- removeExpired ht
             s <- size ht
             s `shouldBe` 1
             left `shouldBe` 0
        it "Checks that maxGCEntries limit is observed" $
           \ht -> do
             insert ht 1 "foo"
             insert ht 2 "bar"
             threadDelay 200000
             left <- removeExpired ht
             s <- size ht
             s `shouldBe` 1
             left `shouldBe` 1
             left' <- removeExpired ht
             s' <- size ht
             s' `shouldBe` 0
             left' `shouldBe` 0
    before withIntHashTable $
      describe "A hash table with integer values" $ do
        it "Checks folding" $
           \ht -> do
             insert ht 1 2
             insert ht 2 3
             r <- foldM (\a -> return . (a +) . snd) 0 ht
             r `shouldBe` 5

hashTableError :: TTLHashTableError -> Either SomeException a -> Bool
hashTableError e (Left e') =
    case fromException e' of
      Just (err::TTLHashTableError) -> err == e
      _      -> False