2019-08-01 03:27:13 +03:00
|
|
|
module BehnTests (tests) where
|
|
|
|
|
|
|
|
import Data.Acquire
|
|
|
|
import Data.Conduit
|
|
|
|
import Data.Conduit.List hiding (take)
|
|
|
|
import Data.Ord.Unicode
|
|
|
|
import Test.QuickCheck hiding ((.&.))
|
|
|
|
import Test.Tasty
|
|
|
|
import Test.Tasty.QuickCheck
|
|
|
|
import Test.Tasty.TH
|
2020-01-24 08:28:38 +03:00
|
|
|
import Urbit.Arvo
|
|
|
|
import Urbit.Noun
|
|
|
|
import Urbit.Prelude
|
|
|
|
import Urbit.Time
|
|
|
|
import Urbit.Vere.Behn
|
|
|
|
import Urbit.Vere.Log
|
|
|
|
import Urbit.Vere.Pier.Types
|
2019-08-01 03:27:13 +03:00
|
|
|
|
|
|
|
import Control.Concurrent (runInBoundThread, threadDelay)
|
|
|
|
import Data.LargeWord (LargeKey(..))
|
|
|
|
import GHC.Natural (Natural)
|
|
|
|
import Network.Socket (tupleToHostAddress)
|
2020-05-30 03:23:10 +03:00
|
|
|
import Urbit.King.App (runKingEnvNoLog, HasKingId(..))
|
2019-08-01 03:27:13 +03:00
|
|
|
|
2020-01-24 08:28:38 +03:00
|
|
|
import qualified Urbit.Time as Time
|
|
|
|
import qualified Urbit.Vere.Log as Log
|
2019-08-01 03:27:13 +03:00
|
|
|
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
|
|
|
|
-- TODO Timers always fire immediatly. Something is wrong!
|
|
|
|
timerFires :: Property
|
2020-05-30 03:23:10 +03:00
|
|
|
timerFires = forAll arbitrary (ioProperty . runKingEnvNoLog . runTest)
|
2019-08-01 03:27:13 +03:00
|
|
|
where
|
2020-05-30 01:57:35 +03:00
|
|
|
runTest :: HasKingId e => () -> RIO e Bool
|
2019-08-01 03:27:13 +03:00
|
|
|
runTest () = do
|
2020-05-30 01:57:35 +03:00
|
|
|
envr <- ask
|
|
|
|
king <- fromIntegral <$> view kingIdL
|
2019-08-01 03:27:13 +03:00
|
|
|
q <- newTQueueIO
|
2020-05-30 01:57:35 +03:00
|
|
|
rwith (liftAcquire $ snd $ behn envr (writeTQueue q)) $ \cb -> do
|
2019-08-08 01:24:02 +03:00
|
|
|
cb (BehnEfDoze (king, ()) (Just (2^20)))
|
2019-08-01 03:27:13 +03:00
|
|
|
t <- atomically $ readTQueue q
|
2019-08-01 05:34:14 +03:00
|
|
|
pure True
|
2019-08-01 03:27:13 +03:00
|
|
|
|
|
|
|
|
|
|
|
-- Utils -----------------------------------------------------------------------
|
|
|
|
|
|
|
|
tests :: TestTree
|
|
|
|
tests =
|
|
|
|
testGroup "Behn"
|
|
|
|
[ localOption (QuickCheckTests 10) $
|
|
|
|
testProperty "Behn Timers Fire" $
|
|
|
|
timerFires
|
|
|
|
]
|