diff --git a/pkg/king/test/AmesTests.hs b/pkg/king/test/AmesTests.hs index a9c4e781e3..9fbd3955e6 100644 --- a/pkg/king/test/AmesTests.hs +++ b/pkg/king/test/AmesTests.hs @@ -1,7 +1,6 @@ module AmesTests (tests) where import Arvo -import Data.Acquire import Data.Conduit import Data.Conduit.List hiding (take) import Data.Ord.Unicode @@ -16,9 +15,10 @@ import Vere.Ames import Vere.Log import Vere.Pier.Types -import Control.Concurrent (runInBoundThread, threadDelay) +import Control.Concurrent (runInBoundThread) import Data.LargeWord (LargeKey(..)) import GHC.Natural (Natural) +import KingApp (runApp) import Network.Socket (tupleToHostAddress) import qualified Vere.Log as Log @@ -35,11 +35,12 @@ turfEf = NewtEfTurf (0, ()) [] sendEf :: Galaxy -> Wen -> Bytes -> NewtEf 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 - q <- liftIO newTQueueIO - cb <- snd $ ames pid (fromIntegral point) Nothing (writeTQueue q) - liftIO $ cb turfEf + q <- newTQueueIO + let (_, runAmes) = ames pid (fromIntegral point) Nothing (writeTQueue q) + cb ← liftAcquire runAmes + rio $ cb turfEf pure (q, cb) waitForPacket :: TQueue Ev -> Bytes -> IO Bool @@ -51,37 +52,37 @@ waitForPacket q val = go EvBlip (BlipEvAmes (AmesEvHear () _ bs)) -> pure (bs == val) _ -> pure False -runAcquire :: Acquire a -> IO a -runAcquire acq = with acq pure +runRAcquire :: RAcquire e a -> RIO e a +runRAcquire acq = rwith acq pure -sendThread :: EffCb NewtEf -> (Galaxy, Bytes) -> Acquire () -sendThread cb (to, val) = void $ mkAcquire start cancel +sendThread :: EffCb e NewtEf -> (Galaxy, Bytes) -> RAcquire e () +sendThread cb (to, val) = void $ mkRAcquire start cancel where start = async $ forever $ do threadDelay 1_000 - wen <- now + wen <- io $ now cb (sendEf to wen val) threadDelay 10_000 zodSelfMsg :: Property -zodSelfMsg = forAll arbitrary (ioProperty . runTest) +zodSelfMsg = forAll arbitrary (ioProperty . runApp . runTest) where - runTest :: Bytes -> IO Bool - runTest val = runAcquire $ do + runTest :: Bytes -> RIO e Bool + runTest val = runRAcquire $ do (zodQ, zod) <- runGala 0 () <- sendThread zod (0, val) liftIO (waitForPacket zodQ val) twoTalk :: Property -twoTalk = forAll arbitrary (ioProperty . runTest) +twoTalk = forAll arbitrary (ioProperty . runApp . runTest) where - runTest :: (Word8, Word8, Bytes) -> IO Bool + runTest :: (Word8, Word8, Bytes) -> RIO e Bool runTest (aliceShip, bobShip, val) = if aliceShip == bobShip then pure True else go aliceShip bobShip val - go :: Word8 -> Word8 -> Bytes -> IO Bool - go aliceShip bobShip val = runAcquire $ do + go :: Word8 -> Word8 -> Bytes -> RIO e Bool + go aliceShip bobShip val = runRAcquire $ do (aliceQ, alice) <- runGala aliceShip (bobQ, bob) <- runGala bobShip sendThread alice (Galaxy bobShip, val) @@ -129,6 +130,15 @@ genIpv4 = do then genIpv4 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 arbitrary = oneof [ ADGala <$> arb <*> arb , ADIpv4 <$> arb <*> arb <*> genIpv4 diff --git a/pkg/king/test/ArvoTests.hs b/pkg/king/test/ArvoTests.hs index 850c6cbfa3..e51c9b8f54 100644 --- a/pkg/king/test/ArvoTests.hs +++ b/pkg/king/test/ArvoTests.hs @@ -155,6 +155,10 @@ instance Arbitrary StdMethod where instance Arbitrary Header where arbitrary = Header <$> arb <*> arb +instance Arbitrary BigCord where + arbitrary = BigCord <$> arb + + instance Arbitrary ServId where arbitrary = ServId <$> arb instance Arbitrary UD where arbitrary = UD <$> arb diff --git a/pkg/king/test/BehnTests.hs b/pkg/king/test/BehnTests.hs index ee1d427087..8970a710f5 100644 --- a/pkg/king/test/BehnTests.hs +++ b/pkg/king/test/BehnTests.hs @@ -19,6 +19,7 @@ import Vere.Pier.Types import Control.Concurrent (runInBoundThread, threadDelay) import Data.LargeWord (LargeKey(..)) import GHC.Natural (Natural) +import KingApp (runApp) import Network.Socket (tupleToHostAddress) import qualified Urbit.Time as Time @@ -32,12 +33,12 @@ king = KingId 0 -- TODO Timers always fire immediatly. Something is wrong! timerFires :: Property -timerFires = forAll arbitrary (ioProperty . runTest) +timerFires = forAll arbitrary (ioProperty . runApp . runTest) where - runTest :: () -> IO Bool + runTest :: () -> RIO e Bool runTest () = do 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))) t <- atomically $ readTQueue q print t diff --git a/pkg/king/test/LogTests.hs b/pkg/king/test/LogTests.hs index 3c717e2b1a..7e4eaed67c 100644 --- a/pkg/king/test/LogTests.hs +++ b/pkg/king/test/LogTests.hs @@ -11,16 +11,17 @@ import Vere.Pier.Types import Data.Conduit import Data.Conduit.List hiding (filter) -import Control.Concurrent (threadDelay, runInBoundThread) +import Control.Concurrent (runInBoundThread, threadDelay) import Data.LargeWord (LargeKey(..)) import GHC.Natural (Natural) +import KingApp (runApp, App) import qualified Vere.Log as Log -- Utils ----------------------------------------------------------------------- -withTestDir :: (FilePath -> IO a) -> IO a +withTestDir :: (FilePath -> RIO e a) -> RIO e a withTestDir = withTempDirectory "./" ".testlog." data NotEqual = NotEqual String String @@ -28,10 +29,9 @@ data NotEqual = NotEqual String String 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 - unless (x == y) $ - throwIO (NotEqual (show x) (show y)) + unless (x == y) $ io $ throwIO $ NotEqual (show x) (show y) -- Database Operations --------------------------------------------------------- @@ -42,15 +42,15 @@ data Db = Db LogIdentity [ByteString] (Map Word64 ByteString) addEvents :: Db -> [ByteString] -> Db addEvents (Db id evs efs) new = Db id (evs <> new) efs -readDb :: EventLog -> IO Db +readDb :: EventLog -> RIO App Db readDb log = do events <- runConduit (streamEvents log 1 .| consume) effects <- runConduit (streamEffectsRows log 0 .| consume) 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 - with (Log.new dir dId) $ \log -> do + rwith (Log.new dir dId) $ \log -> do Log.appendEvents log (fromList dEvs) for_ (mapToList dFx) $ \(k,v) -> Log.writeEffectsRow log k v @@ -59,70 +59,75 @@ withDb dir (Db dId dEvs dFx) act = do -------------------------------------------------------------------------------- tryReadIdentity :: Property -tryReadIdentity = forAll arbitrary (ioProperty . runTest) +tryReadIdentity = forAll arbitrary (ioProperty . runApp . runTest) where - runTest :: LogIdentity -> IO Bool + runTest :: LogIdentity -> RIO App Bool runTest ident = do - runInBoundThread $ + env <- ask + io $ runInBoundThread $ runRIO env $ withTestDir $ \dir -> do - with (Log.new dir ident) $ \log -> + rwith (Log.new dir ident) $ \log -> assertEqual ident (Log.identity log) - with (Log.existing dir) $ \log -> + rwith (Log.existing dir) $ \log -> assertEqual ident (Log.identity log) - with (Log.existing dir) $ \log -> + rwith (Log.existing dir) $ \log -> assertEqual ident (Log.identity log) pure True tryReadDatabase :: Property -tryReadDatabase = forAll arbitrary (ioProperty . runTest) +tryReadDatabase = forAll arbitrary (ioProperty . runApp . runTest) where - runTest :: Db -> IO Bool + runTest :: Db -> RIO App Bool runTest db = do - runInBoundThread $ + env <- ask + io $ runInBoundThread $ runRIO env $ withTestDir $ \dir -> do withDb dir db $ \log -> do readDb log >>= assertEqual db pure True tryReadDatabaseFuzz :: Property -tryReadDatabaseFuzz = forAll arbitrary (ioProperty . runTest) +tryReadDatabaseFuzz = forAll arbitrary (ioProperty . runApp . runTest) where - runTest :: Db -> IO Bool + runTest :: Db -> RIO App Bool runTest db = do - runInBoundThread $ + env <- ask + io $ runInBoundThread $ runRIO env $ withTestDir $ \dir -> do withDb dir db $ \log -> do readDb log >>= assertEqual db - with (Log.existing dir) $ \log -> do + rwith (Log.existing dir) $ \log -> do 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 tryAppend :: Property -tryAppend = forAll arbitrary (ioProperty . runTest) +tryAppend = forAll arbitrary (ioProperty . runApp . runTest) where - runTest :: ([ByteString], Db) -> IO Bool + runTest :: ([ByteString], Db) -> RIO App Bool runTest (extra, db) = do - runInBoundThread $ + env <- ask + io $ runInBoundThread $ runRIO env $ withTestDir $ \dir -> do db' <- pure (addEvents db extra) withDb dir db $ \log -> do readDb log >>= assertEqual db Log.appendEvents log (fromList extra) readDb log >>= assertEqual db' - with (Log.existing dir) $ \log -> do + rwith (Log.existing dir) $ \log -> do readDb log >>= assertEqual db' pure True tryAppendHuge :: Property -tryAppendHuge = forAll arbitrary (ioProperty . runTest) +tryAppendHuge = forAll arbitrary (ioProperty . runApp . runTest) where - runTest :: ([ByteString], Db) -> IO Bool + runTest :: ([ByteString], Db) -> RIO App Bool runTest (extra, db) = do - runInBoundThread $ do - extra <- do b <- readFile "/home/benajmin/r/urbit/bin/brass.pill" + env <- ask + io $ runInBoundThread $ runRIO env $ do + extra <- do b <- readFile "./bin/brass.pill" pure (extra <> [b] <> extra) withTestDir $ \dir -> do db' <- pure (addEvents db extra) @@ -130,7 +135,7 @@ tryAppendHuge = forAll arbitrary (ioProperty . runTest) readDb log >>= assertEqual db Log.appendEvents log (fromList extra) readDb log >>= assertEqual db' - with (Log.existing dir) $ \log -> do + rwith (Log.existing dir) $ \log -> do readDb log >>= assertEqual db' pure True diff --git a/pkg/king/test/Main.hs b/pkg/king/test/Main.hs index e5f656213d..e729eef930 100644 --- a/pkg/king/test/Main.hs +++ b/pkg/king/test/Main.hs @@ -6,6 +6,7 @@ import Test.QuickCheck hiding ((.&.)) import Test.Tasty import Test.Tasty.QuickCheck import Test.Tasty.TH +import RIO.Directory import System.Environment (setEnv) import Control.Concurrent (runInBoundThread) @@ -18,11 +19,12 @@ import qualified BehnTests main :: IO () main = do - setEnv "TASTY_NUM_THREADS" "1" - runInBoundThread $ defaultMain $ testGroup "Urbit" - [ DeriveNounTests.tests - , ArvoTests.tests - , AmesTests.tests - , LogTests.tests - , BehnTests.tests - ] + makeAbsolute "../.." >>= setCurrentDirectory + setEnv "TASTY_NUM_THREADS" "1" + runInBoundThread $ defaultMain $ testGroup "Urbit" + [ DeriveNounTests.tests + , ArvoTests.tests + , AmesTests.tests + , LogTests.tests + , BehnTests.tests + ]