mirror of
https://github.com/ilyakooo0/urbit.git
synced 2024-12-14 17:41:33 +03:00
Got tests working again.
This commit is contained in:
parent
da7190008c
commit
1523241b82
@ -1,7 +1,6 @@
|
|||||||
module AmesTests (tests) where
|
module AmesTests (tests) where
|
||||||
|
|
||||||
import Arvo
|
import Arvo
|
||||||
import Data.Acquire
|
|
||||||
import Data.Conduit
|
import Data.Conduit
|
||||||
import Data.Conduit.List hiding (take)
|
import Data.Conduit.List hiding (take)
|
||||||
import Data.Ord.Unicode
|
import Data.Ord.Unicode
|
||||||
@ -16,9 +15,10 @@ import Vere.Ames
|
|||||||
import Vere.Log
|
import Vere.Log
|
||||||
import Vere.Pier.Types
|
import Vere.Pier.Types
|
||||||
|
|
||||||
import Control.Concurrent (runInBoundThread, threadDelay)
|
import Control.Concurrent (runInBoundThread)
|
||||||
import Data.LargeWord (LargeKey(..))
|
import Data.LargeWord (LargeKey(..))
|
||||||
import GHC.Natural (Natural)
|
import GHC.Natural (Natural)
|
||||||
|
import KingApp (runApp)
|
||||||
import Network.Socket (tupleToHostAddress)
|
import Network.Socket (tupleToHostAddress)
|
||||||
|
|
||||||
import qualified Vere.Log as Log
|
import qualified Vere.Log as Log
|
||||||
@ -35,11 +35,12 @@ turfEf = NewtEfTurf (0, ()) []
|
|||||||
sendEf :: Galaxy -> Wen -> Bytes -> NewtEf
|
sendEf :: Galaxy -> Wen -> Bytes -> NewtEf
|
||||||
sendEf g w bs = NewtEfSend (0, ()) (ADGala w g) bs
|
sendEf g w bs = NewtEfSend (0, ()) (ADGala w g) bs
|
||||||
|
|
||||||
runGala :: Word8 -> Acquire (TQueue Ev, EffCb NewtEf)
|
runGala :: Word8 -> RAcquire e (TQueue Ev, EffCb e NewtEf)
|
||||||
runGala point = do
|
runGala point = do
|
||||||
q <- liftIO newTQueueIO
|
q <- newTQueueIO
|
||||||
cb <- snd $ ames pid (fromIntegral point) Nothing (writeTQueue q)
|
let (_, runAmes) = ames pid (fromIntegral point) Nothing (writeTQueue q)
|
||||||
liftIO $ cb turfEf
|
cb ← liftAcquire runAmes
|
||||||
|
rio $ cb turfEf
|
||||||
pure (q, cb)
|
pure (q, cb)
|
||||||
|
|
||||||
waitForPacket :: TQueue Ev -> Bytes -> IO Bool
|
waitForPacket :: TQueue Ev -> Bytes -> IO Bool
|
||||||
@ -51,37 +52,37 @@ waitForPacket q val = go
|
|||||||
EvBlip (BlipEvAmes (AmesEvHear () _ bs)) -> pure (bs == val)
|
EvBlip (BlipEvAmes (AmesEvHear () _ bs)) -> pure (bs == val)
|
||||||
_ -> pure False
|
_ -> pure False
|
||||||
|
|
||||||
runAcquire :: Acquire a -> IO a
|
runRAcquire :: RAcquire e a -> RIO e a
|
||||||
runAcquire acq = with acq pure
|
runRAcquire acq = rwith acq pure
|
||||||
|
|
||||||
sendThread :: EffCb NewtEf -> (Galaxy, Bytes) -> Acquire ()
|
sendThread :: EffCb e NewtEf -> (Galaxy, Bytes) -> RAcquire e ()
|
||||||
sendThread cb (to, val) = void $ mkAcquire start cancel
|
sendThread cb (to, val) = void $ mkRAcquire start cancel
|
||||||
where
|
where
|
||||||
start = async $ forever $ do threadDelay 1_000
|
start = async $ forever $ do threadDelay 1_000
|
||||||
wen <- now
|
wen <- io $ now
|
||||||
cb (sendEf to wen val)
|
cb (sendEf to wen val)
|
||||||
threadDelay 10_000
|
threadDelay 10_000
|
||||||
|
|
||||||
zodSelfMsg :: Property
|
zodSelfMsg :: Property
|
||||||
zodSelfMsg = forAll arbitrary (ioProperty . runTest)
|
zodSelfMsg = forAll arbitrary (ioProperty . runApp . runTest)
|
||||||
where
|
where
|
||||||
runTest :: Bytes -> IO Bool
|
runTest :: Bytes -> RIO e Bool
|
||||||
runTest val = runAcquire $ do
|
runTest val = runRAcquire $ do
|
||||||
(zodQ, zod) <- runGala 0
|
(zodQ, zod) <- runGala 0
|
||||||
() <- sendThread zod (0, val)
|
() <- sendThread zod (0, val)
|
||||||
liftIO (waitForPacket zodQ val)
|
liftIO (waitForPacket zodQ val)
|
||||||
|
|
||||||
twoTalk :: Property
|
twoTalk :: Property
|
||||||
twoTalk = forAll arbitrary (ioProperty . runTest)
|
twoTalk = forAll arbitrary (ioProperty . runApp . runTest)
|
||||||
where
|
where
|
||||||
runTest :: (Word8, Word8, Bytes) -> IO Bool
|
runTest :: (Word8, Word8, Bytes) -> RIO e Bool
|
||||||
runTest (aliceShip, bobShip, val) =
|
runTest (aliceShip, bobShip, val) =
|
||||||
if aliceShip == bobShip
|
if aliceShip == bobShip
|
||||||
then pure True
|
then pure True
|
||||||
else go aliceShip bobShip val
|
else go aliceShip bobShip val
|
||||||
|
|
||||||
go :: Word8 -> Word8 -> Bytes -> IO Bool
|
go :: Word8 -> Word8 -> Bytes -> RIO e Bool
|
||||||
go aliceShip bobShip val = runAcquire $ do
|
go aliceShip bobShip val = runRAcquire $ do
|
||||||
(aliceQ, alice) <- runGala aliceShip
|
(aliceQ, alice) <- runGala aliceShip
|
||||||
(bobQ, bob) <- runGala bobShip
|
(bobQ, bob) <- runGala bobShip
|
||||||
sendThread alice (Galaxy bobShip, val)
|
sendThread alice (Galaxy bobShip, val)
|
||||||
@ -129,6 +130,15 @@ genIpv4 = do
|
|||||||
then genIpv4
|
then genIpv4
|
||||||
else pure (Ipv4 x)
|
else pure (Ipv4 x)
|
||||||
|
|
||||||
|
instance Arbitrary Text where
|
||||||
|
arbitrary = pack <$> arb
|
||||||
|
|
||||||
|
instance Arbitrary Cord where
|
||||||
|
arbitrary = Cord <$> arb
|
||||||
|
|
||||||
|
instance Arbitrary BigCord where
|
||||||
|
arbitrary = BigCord <$> arb
|
||||||
|
|
||||||
instance Arbitrary AmesDest where
|
instance Arbitrary AmesDest where
|
||||||
arbitrary = oneof [ ADGala <$> arb <*> arb
|
arbitrary = oneof [ ADGala <$> arb <*> arb
|
||||||
, ADIpv4 <$> arb <*> arb <*> genIpv4
|
, ADIpv4 <$> arb <*> arb <*> genIpv4
|
||||||
|
@ -155,6 +155,10 @@ instance Arbitrary StdMethod where
|
|||||||
instance Arbitrary Header where
|
instance Arbitrary Header where
|
||||||
arbitrary = Header <$> arb <*> arb
|
arbitrary = Header <$> arb <*> arb
|
||||||
|
|
||||||
|
instance Arbitrary BigCord where
|
||||||
|
arbitrary = BigCord <$> arb
|
||||||
|
|
||||||
|
|
||||||
instance Arbitrary ServId where arbitrary = ServId <$> arb
|
instance Arbitrary ServId where arbitrary = ServId <$> arb
|
||||||
|
|
||||||
instance Arbitrary UD where arbitrary = UD <$> arb
|
instance Arbitrary UD where arbitrary = UD <$> arb
|
||||||
|
@ -19,6 +19,7 @@ import Vere.Pier.Types
|
|||||||
import Control.Concurrent (runInBoundThread, threadDelay)
|
import Control.Concurrent (runInBoundThread, threadDelay)
|
||||||
import Data.LargeWord (LargeKey(..))
|
import Data.LargeWord (LargeKey(..))
|
||||||
import GHC.Natural (Natural)
|
import GHC.Natural (Natural)
|
||||||
|
import KingApp (runApp)
|
||||||
import Network.Socket (tupleToHostAddress)
|
import Network.Socket (tupleToHostAddress)
|
||||||
|
|
||||||
import qualified Urbit.Time as Time
|
import qualified Urbit.Time as Time
|
||||||
@ -32,12 +33,12 @@ king = KingId 0
|
|||||||
|
|
||||||
-- TODO Timers always fire immediatly. Something is wrong!
|
-- TODO Timers always fire immediatly. Something is wrong!
|
||||||
timerFires :: Property
|
timerFires :: Property
|
||||||
timerFires = forAll arbitrary (ioProperty . runTest)
|
timerFires = forAll arbitrary (ioProperty . runApp . runTest)
|
||||||
where
|
where
|
||||||
runTest :: () -> IO Bool
|
runTest :: () -> RIO e Bool
|
||||||
runTest () = do
|
runTest () = do
|
||||||
q <- newTQueueIO
|
q <- newTQueueIO
|
||||||
with (snd $ behn king (writeTQueue q)) $ \cb -> do
|
rwith (liftAcquire $ snd $ behn king (writeTQueue q)) $ \cb -> do
|
||||||
cb (BehnEfDoze (king, ()) (Just (2^20)))
|
cb (BehnEfDoze (king, ()) (Just (2^20)))
|
||||||
t <- atomically $ readTQueue q
|
t <- atomically $ readTQueue q
|
||||||
print t
|
print t
|
||||||
|
@ -11,16 +11,17 @@ import Vere.Pier.Types
|
|||||||
import Data.Conduit
|
import Data.Conduit
|
||||||
import Data.Conduit.List hiding (filter)
|
import Data.Conduit.List hiding (filter)
|
||||||
|
|
||||||
import Control.Concurrent (threadDelay, runInBoundThread)
|
import Control.Concurrent (runInBoundThread, threadDelay)
|
||||||
import Data.LargeWord (LargeKey(..))
|
import Data.LargeWord (LargeKey(..))
|
||||||
import GHC.Natural (Natural)
|
import GHC.Natural (Natural)
|
||||||
|
import KingApp (runApp, App)
|
||||||
|
|
||||||
import qualified Vere.Log as Log
|
import qualified Vere.Log as Log
|
||||||
|
|
||||||
|
|
||||||
-- Utils -----------------------------------------------------------------------
|
-- Utils -----------------------------------------------------------------------
|
||||||
|
|
||||||
withTestDir :: (FilePath -> IO a) -> IO a
|
withTestDir :: (FilePath -> RIO e a) -> RIO e a
|
||||||
withTestDir = withTempDirectory "./" ".testlog."
|
withTestDir = withTempDirectory "./" ".testlog."
|
||||||
|
|
||||||
data NotEqual = NotEqual String String
|
data NotEqual = NotEqual String String
|
||||||
@ -28,10 +29,9 @@ data NotEqual = NotEqual String String
|
|||||||
|
|
||||||
instance Exception NotEqual where
|
instance Exception NotEqual where
|
||||||
|
|
||||||
assertEqual :: (Show a, Eq a) => a -> a -> IO ()
|
assertEqual :: MonadIO m => (Show a, Eq a) => a -> a -> m ()
|
||||||
assertEqual x y = do
|
assertEqual x y = do
|
||||||
unless (x == y) $
|
unless (x == y) $ io $ throwIO $ NotEqual (show x) (show y)
|
||||||
throwIO (NotEqual (show x) (show y))
|
|
||||||
|
|
||||||
|
|
||||||
-- Database Operations ---------------------------------------------------------
|
-- Database Operations ---------------------------------------------------------
|
||||||
@ -42,15 +42,15 @@ data Db = Db LogIdentity [ByteString] (Map Word64 ByteString)
|
|||||||
addEvents :: Db -> [ByteString] -> Db
|
addEvents :: Db -> [ByteString] -> Db
|
||||||
addEvents (Db id evs efs) new = Db id (evs <> new) efs
|
addEvents (Db id evs efs) new = Db id (evs <> new) efs
|
||||||
|
|
||||||
readDb :: EventLog -> IO Db
|
readDb :: EventLog -> RIO App Db
|
||||||
readDb log = do
|
readDb log = do
|
||||||
events <- runConduit (streamEvents log 1 .| consume)
|
events <- runConduit (streamEvents log 1 .| consume)
|
||||||
effects <- runConduit (streamEffectsRows log 0 .| consume)
|
effects <- runConduit (streamEffectsRows log 0 .| consume)
|
||||||
pure $ Db (Log.identity log) events (mapFromList effects)
|
pure $ Db (Log.identity log) events (mapFromList effects)
|
||||||
|
|
||||||
withDb :: FilePath -> Db -> (EventLog -> IO a) -> IO a
|
withDb :: FilePath -> Db -> (EventLog -> RIO App a) -> RIO App a
|
||||||
withDb dir (Db dId dEvs dFx) act = do
|
withDb dir (Db dId dEvs dFx) act = do
|
||||||
with (Log.new dir dId) $ \log -> do
|
rwith (Log.new dir dId) $ \log -> do
|
||||||
Log.appendEvents log (fromList dEvs)
|
Log.appendEvents log (fromList dEvs)
|
||||||
for_ (mapToList dFx) $ \(k,v) ->
|
for_ (mapToList dFx) $ \(k,v) ->
|
||||||
Log.writeEffectsRow log k v
|
Log.writeEffectsRow log k v
|
||||||
@ -59,70 +59,75 @@ withDb dir (Db dId dEvs dFx) act = do
|
|||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
tryReadIdentity :: Property
|
tryReadIdentity :: Property
|
||||||
tryReadIdentity = forAll arbitrary (ioProperty . runTest)
|
tryReadIdentity = forAll arbitrary (ioProperty . runApp . runTest)
|
||||||
where
|
where
|
||||||
runTest :: LogIdentity -> IO Bool
|
runTest :: LogIdentity -> RIO App Bool
|
||||||
runTest ident = do
|
runTest ident = do
|
||||||
runInBoundThread $
|
env <- ask
|
||||||
|
io $ runInBoundThread $ runRIO env $
|
||||||
withTestDir $ \dir -> do
|
withTestDir $ \dir -> do
|
||||||
with (Log.new dir ident) $ \log ->
|
rwith (Log.new dir ident) $ \log ->
|
||||||
assertEqual ident (Log.identity log)
|
assertEqual ident (Log.identity log)
|
||||||
with (Log.existing dir) $ \log ->
|
rwith (Log.existing dir) $ \log ->
|
||||||
assertEqual ident (Log.identity log)
|
assertEqual ident (Log.identity log)
|
||||||
with (Log.existing dir) $ \log ->
|
rwith (Log.existing dir) $ \log ->
|
||||||
assertEqual ident (Log.identity log)
|
assertEqual ident (Log.identity log)
|
||||||
pure True
|
pure True
|
||||||
|
|
||||||
tryReadDatabase :: Property
|
tryReadDatabase :: Property
|
||||||
tryReadDatabase = forAll arbitrary (ioProperty . runTest)
|
tryReadDatabase = forAll arbitrary (ioProperty . runApp . runTest)
|
||||||
where
|
where
|
||||||
runTest :: Db -> IO Bool
|
runTest :: Db -> RIO App Bool
|
||||||
runTest db = do
|
runTest db = do
|
||||||
runInBoundThread $
|
env <- ask
|
||||||
|
io $ runInBoundThread $ runRIO env $
|
||||||
withTestDir $ \dir -> do
|
withTestDir $ \dir -> do
|
||||||
withDb dir db $ \log -> do
|
withDb dir db $ \log -> do
|
||||||
readDb log >>= assertEqual db
|
readDb log >>= assertEqual db
|
||||||
pure True
|
pure True
|
||||||
|
|
||||||
tryReadDatabaseFuzz :: Property
|
tryReadDatabaseFuzz :: Property
|
||||||
tryReadDatabaseFuzz = forAll arbitrary (ioProperty . runTest)
|
tryReadDatabaseFuzz = forAll arbitrary (ioProperty . runApp . runTest)
|
||||||
where
|
where
|
||||||
runTest :: Db -> IO Bool
|
runTest :: Db -> RIO App Bool
|
||||||
runTest db = do
|
runTest db = do
|
||||||
runInBoundThread $
|
env <- ask
|
||||||
|
io $ runInBoundThread $ runRIO env $
|
||||||
withTestDir $ \dir -> do
|
withTestDir $ \dir -> do
|
||||||
withDb dir db $ \log -> do
|
withDb dir db $ \log -> do
|
||||||
readDb log >>= assertEqual db
|
readDb log >>= assertEqual db
|
||||||
with (Log.existing dir) $ \log -> do
|
rwith (Log.existing dir) $ \log -> do
|
||||||
readDb log >>= assertEqual db
|
readDb log >>= assertEqual db
|
||||||
with (Log.existing dir) $ \log -> do
|
rwith (Log.existing dir) $ \log -> do
|
||||||
readDb log >>= assertEqual db
|
readDb log >>= assertEqual db
|
||||||
readDb log >>= assertEqual db
|
readDb log >>= assertEqual db
|
||||||
pure True
|
pure True
|
||||||
|
|
||||||
tryAppend :: Property
|
tryAppend :: Property
|
||||||
tryAppend = forAll arbitrary (ioProperty . runTest)
|
tryAppend = forAll arbitrary (ioProperty . runApp . runTest)
|
||||||
where
|
where
|
||||||
runTest :: ([ByteString], Db) -> IO Bool
|
runTest :: ([ByteString], Db) -> RIO App Bool
|
||||||
runTest (extra, db) = do
|
runTest (extra, db) = do
|
||||||
runInBoundThread $
|
env <- ask
|
||||||
|
io $ runInBoundThread $ runRIO env $
|
||||||
withTestDir $ \dir -> do
|
withTestDir $ \dir -> do
|
||||||
db' <- pure (addEvents db extra)
|
db' <- pure (addEvents db extra)
|
||||||
withDb dir db $ \log -> do
|
withDb dir db $ \log -> do
|
||||||
readDb log >>= assertEqual db
|
readDb log >>= assertEqual db
|
||||||
Log.appendEvents log (fromList extra)
|
Log.appendEvents log (fromList extra)
|
||||||
readDb log >>= assertEqual db'
|
readDb log >>= assertEqual db'
|
||||||
with (Log.existing dir) $ \log -> do
|
rwith (Log.existing dir) $ \log -> do
|
||||||
readDb log >>= assertEqual db'
|
readDb log >>= assertEqual db'
|
||||||
pure True
|
pure True
|
||||||
|
|
||||||
tryAppendHuge :: Property
|
tryAppendHuge :: Property
|
||||||
tryAppendHuge = forAll arbitrary (ioProperty . runTest)
|
tryAppendHuge = forAll arbitrary (ioProperty . runApp . runTest)
|
||||||
where
|
where
|
||||||
runTest :: ([ByteString], Db) -> IO Bool
|
runTest :: ([ByteString], Db) -> RIO App Bool
|
||||||
runTest (extra, db) = do
|
runTest (extra, db) = do
|
||||||
runInBoundThread $ do
|
env <- ask
|
||||||
extra <- do b <- readFile "/home/benajmin/r/urbit/bin/brass.pill"
|
io $ runInBoundThread $ runRIO env $ do
|
||||||
|
extra <- do b <- readFile "./bin/brass.pill"
|
||||||
pure (extra <> [b] <> extra)
|
pure (extra <> [b] <> extra)
|
||||||
withTestDir $ \dir -> do
|
withTestDir $ \dir -> do
|
||||||
db' <- pure (addEvents db extra)
|
db' <- pure (addEvents db extra)
|
||||||
@ -130,7 +135,7 @@ tryAppendHuge = forAll arbitrary (ioProperty . runTest)
|
|||||||
readDb log >>= assertEqual db
|
readDb log >>= assertEqual db
|
||||||
Log.appendEvents log (fromList extra)
|
Log.appendEvents log (fromList extra)
|
||||||
readDb log >>= assertEqual db'
|
readDb log >>= assertEqual db'
|
||||||
with (Log.existing dir) $ \log -> do
|
rwith (Log.existing dir) $ \log -> do
|
||||||
readDb log >>= assertEqual db'
|
readDb log >>= assertEqual db'
|
||||||
pure True
|
pure True
|
||||||
|
|
||||||
|
@ -6,6 +6,7 @@ import Test.QuickCheck hiding ((.&.))
|
|||||||
import Test.Tasty
|
import Test.Tasty
|
||||||
import Test.Tasty.QuickCheck
|
import Test.Tasty.QuickCheck
|
||||||
import Test.Tasty.TH
|
import Test.Tasty.TH
|
||||||
|
import RIO.Directory
|
||||||
|
|
||||||
import System.Environment (setEnv)
|
import System.Environment (setEnv)
|
||||||
import Control.Concurrent (runInBoundThread)
|
import Control.Concurrent (runInBoundThread)
|
||||||
@ -18,11 +19,12 @@ import qualified BehnTests
|
|||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
setEnv "TASTY_NUM_THREADS" "1"
|
makeAbsolute "../.." >>= setCurrentDirectory
|
||||||
runInBoundThread $ defaultMain $ testGroup "Urbit"
|
setEnv "TASTY_NUM_THREADS" "1"
|
||||||
[ DeriveNounTests.tests
|
runInBoundThread $ defaultMain $ testGroup "Urbit"
|
||||||
, ArvoTests.tests
|
[ DeriveNounTests.tests
|
||||||
, AmesTests.tests
|
, ArvoTests.tests
|
||||||
, LogTests.tests
|
, AmesTests.tests
|
||||||
, BehnTests.tests
|
, LogTests.tests
|
||||||
]
|
, BehnTests.tests
|
||||||
|
]
|
||||||
|
Loading…
Reference in New Issue
Block a user