shrub/pkg/hs/urbit-king/test/AmesTests.hs

210 lines
6.1 KiB
Haskell
Raw Normal View History

module AmesTests (tests) where
2019-08-01 03:27:13 +03:00
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
import Urbit.Arvo
import Urbit.EventLog.LMDB
import Urbit.King.Config
import Urbit.Noun
import Urbit.Noun.Time
import Urbit.Prelude
import Urbit.Vere.Ames
import Urbit.Vere.Pier.Types
2019-09-18 06:33:38 +03:00
import Control.Concurrent (runInBoundThread)
import Data.LargeWord (LargeKey(..))
import GHC.Natural (Natural)
2019-08-01 03:27:13 +03:00
import Network.Socket (tupleToHostAddress)
2020-05-30 01:57:35 +03:00
import Urbit.King.App (HasKingId(..))
import qualified Urbit.EventLog.LMDB as Log
2020-05-30 01:57:35 +03:00
--------------------------------------------------------------------------------
type HasAmes e = (HasLogFunc e, HasNetworkConfig e, HasKingId e)
-- Utils -----------------------------------------------------------------------
pid :: KingId
pid = KingId 0
turfEf :: NewtEf
turfEf = NewtEfTurf (0, ()) []
sendEf :: Galaxy -> Wen -> Bytes -> NewtEf
2019-12-17 13:14:34 +03:00
sendEf g w bs = NewtEfSend (0, ()) (EachYes g) bs
data NetworkTestApp = NetworkTestApp
{ _ntaLogFunc :: !LogFunc
, _ntaNetworkConfig :: !NetworkConfig
2020-05-30 01:57:35 +03:00
, _ntaKingId :: !Word16
}
makeLenses ''NetworkTestApp
instance HasLogFunc NetworkTestApp where
logFuncL = ntaLogFunc
instance HasNetworkConfig NetworkTestApp where
networkConfigL = ntaNetworkConfig
2020-05-30 01:57:35 +03:00
instance HasKingId NetworkTestApp where
kingIdL = ntaKingId
runNetworkApp :: RIO NetworkTestApp a -> IO a
runNetworkApp = runRIO NetworkTestApp
2020-05-30 01:57:35 +03:00
{ _ntaLogFunc = mkLogFunc (\_ _ _ _ -> pure ())
, _ntaKingId = 34
, _ntaNetworkConfig = NetworkConfig { _ncNetMode = NMNormal
, _ncAmesPort = Nothing
, _ncNoAmes = False
, _ncNoHttp = False
, _ncNoHttps = False
, _ncHttpPort = Nothing
, _ncHttpsPort = Nothing
, _ncLocalPort = Nothing
}
}
2020-05-30 01:57:35 +03:00
runGala
:: forall e
. HasAmes e
=> Word8
-> RAcquire e (TQueue EvErr, NewtEf -> IO ())
2020-05-30 01:57:35 +03:00
runGala point = do
env <- ask
que <- newTQueueIO
let (_, runAmes) =
2020-05-30 01:57:35 +03:00
ames env (fromIntegral point) True (writeTQueue que) noStderr
cb <- runAmes
io (cb turfEf)
2020-05-30 01:57:35 +03:00
pure (que, cb)
where
noStderr _ = pure ()
waitForPacket :: TQueue EvErr -> Bytes -> IO Bool
waitForPacket q val = go
where
go = atomically (readTQueue q) >>= \case
EvErr (EvBlip (BlipEvNewt (NewtEvBorn (_, ()) ()))) _ -> go
EvErr (EvBlip (BlipEvAmes (AmesEvHear () _ bs))) _ -> pure (bs == val)
_ -> pure False
2019-09-18 06:33:38 +03:00
runRAcquire :: RAcquire e a -> RIO e a
runRAcquire acq = rwith acq pure
sendThread :: (NewtEf -> IO ()) -> (Galaxy, Bytes) -> RAcquire e ()
2019-09-18 06:33:38 +03:00
sendThread cb (to, val) = void $ mkRAcquire start cancel
where
start = async $ forever $ do threadDelay 1_000
2019-09-18 06:33:38 +03:00
wen <- io $ now
io $ cb (sendEf to wen val)
threadDelay 10_000
zodSelfMsg :: Property
zodSelfMsg = forAll arbitrary (ioProperty . runNetworkApp . runTest)
2020-05-30 01:57:35 +03:00
where
runTest
:: (HasLogFunc e, HasNetworkConfig e, HasKingId e) => Bytes -> RIO e Bool
runTest val = runRAcquire $ do
env <- ask
(zodQ, zod) <- runGala 0
() <- sendThread zod (0, val)
liftIO (waitForPacket zodQ val)
twoTalk :: Property
twoTalk = forAll arbitrary (ioProperty . runNetworkApp . runTest)
where
2020-05-30 01:57:35 +03:00
runTest :: (HasLogFunc e, HasNetworkConfig e, HasKingId e)
=> (Word8, Word8, Bytes) -> RIO e Bool
runTest (aliceShip, bobShip, val) =
if aliceShip == bobShip
then pure True
else go aliceShip bobShip val
2020-05-30 01:57:35 +03:00
go :: (HasLogFunc e, HasNetworkConfig e, HasKingId e)
=> Word8 -> Word8 -> Bytes -> RIO e Bool
2019-09-18 06:33:38 +03:00
go aliceShip bobShip val = runRAcquire $ do
(aliceQ, alice) <- runGala aliceShip
(bobQ, bob) <- runGala bobShip
2019-12-19 17:13:20 +03:00
sendThread alice (Patp bobShip, val)
sendThread bob (Patp aliceShip, val)
liftIO (waitForPacket aliceQ val >> waitForPacket bobQ val)
tests :: TestTree
tests =
testGroup "Ames"
[ localOption (QuickCheckTests 10) $
testProperty "Zod can send a message to itself" $
zodSelfMsg
2019-12-11 10:14:51 +03:00
-- TODO Why doesn't this work in CI?
-- , localOption (QuickCheckTests 10) $
-- testProperty "Two galaxies can talk" $
-- twoTalk
]
-- Generate Arbitrary Values ---------------------------------------------------
arb :: Arbitrary a => Gen a
arb = arbitrary
instance Arbitrary Ipv4 where arbitrary = Ipv4 <$> arb
instance Arbitrary Port where arbitrary = Port <$> arb
instance Arbitrary Wen where arbitrary = Wen <$> arb
instance Arbitrary Gap where arbitrary = Gap . abs <$> arb
instance Arbitrary Bytes where arbitrary = pure (MkBytes "wtfbbq")
-- MkBytes . take 100 <$> arb
2019-12-19 17:13:20 +03:00
instance Arbitrary a => Arbitrary (Patp a) where
arbitrary = Patp <$> arb
instance Arbitrary ByteString where
arbitrary = pack <$> arbitrary
instance Arbitrary Natural where
arbitrary = fromIntegral . abs <$> (arbitrary :: Gen Integer)
instance (Arbitrary a, Arbitrary b) => Arbitrary (LargeKey a b) where
arbitrary = LargeKey <$> arb <*> arb
genIpv4 :: Gen Ipv4
genIpv4 = do
x <- arbitrary
if (x == 0 || (x256 && x512))
then genIpv4
else pure (Ipv4 x)
2019-09-18 06:33:38 +03:00
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
2019-12-17 13:14:34 +03:00
arbitrary = oneof [ EachYes <$> arb
, EachNo <$> arb
]
2019-12-17 13:14:34 +03:00
instance Arbitrary a => Arbitrary (Jammed a) where
arbitrary = Jammed <$> arbitrary
instance Arbitrary AmesAddress where
arbitrary = AAIpv4 <$> arb <*> arb
instance Arbitrary Ship where
arbitrary = Ship <$> arb
instance Arbitrary LogIdentity where
arbitrary = LogIdentity <$> arb <*> arb <*> arb