diff --git a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs index a85d604c4f..9ea53916c8 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs @@ -475,7 +475,7 @@ newShip CLI.New{..} opts = do -- TODO: We hit the same problem as above: we need the running options to -- determine how to configure the ports - ports <- buildInactivePorts + let ports = buildInactivePorts -- here we are with a king env, and we now need a multi env. runRunningEnv multi ports go @@ -591,7 +591,7 @@ runShip (CLI.Run pierPath) opts daemon = do buildPortHandler :: (HasLogFunc e) => Bool -> RIO e PortControlApi -buildPortHandler False = buildInactivePorts +buildPortHandler False = pure $ buildInactivePorts buildPortHandler True = buildNATPorts startBrowser :: HasLogFunc e => FilePath -> RIO e () diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs index 0a352d716a..fd8ab1a633 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs @@ -23,8 +23,8 @@ data PortControlApi = PortControlApi } -- Builds a Ports struct which does nothing when called. -buildInactivePorts :: RIO e PortControlApi -buildInactivePorts = pure $ PortControlApi noop noop +buildInactivePorts :: PortControlApi +buildInactivePorts = PortControlApi noop noop where noop x = pure () diff --git a/pkg/hs/urbit-king/test/AmesTests.hs b/pkg/hs/urbit-king/test/AmesTests.hs index 6be3e5c8c9..6356a7148c 100644 --- a/pkg/hs/urbit-king/test/AmesTests.hs +++ b/pkg/hs/urbit-king/test/AmesTests.hs @@ -15,6 +15,7 @@ import Urbit.Noun.Time import Urbit.Prelude import Urbit.Vere.Ames import Urbit.Vere.Pier.Types +import Urbit.Vere.Ports import Control.Concurrent (runInBoundThread) import Data.LargeWord (LargeKey(..)) @@ -27,7 +28,8 @@ import qualified Urbit.EventLog.LMDB as Log -------------------------------------------------------------------------------- -type HasAmes e = (HasLogFunc e, HasNetworkConfig e, HasKingId e) +type HasAmes e = (HasLogFunc e, HasNetworkConfig e, HasKingId e, + HasPortControlApi e) -- Utils ----------------------------------------------------------------------- @@ -41,9 +43,10 @@ sendEf :: Galaxy -> Wen -> Bytes -> NewtEf sendEf g w bs = NewtEfSend (0, ()) (EachYes g) bs data NetworkTestApp = NetworkTestApp - { _ntaLogFunc :: !LogFunc - , _ntaNetworkConfig :: !NetworkConfig - , _ntaKingId :: !Word16 + { _ntaLogFunc :: !LogFunc + , _ntaNetworkConfig :: !NetworkConfig + , _ntaPortControlApi :: PortControlApi + , _ntaKingId :: !Word16 } makeLenses ''NetworkTestApp @@ -57,20 +60,25 @@ instance HasNetworkConfig NetworkTestApp where instance HasKingId NetworkTestApp where kingIdL = ntaKingId +instance HasPortControlApi NetworkTestApp where + portControlApiL = ntaPortControlApi + runNetworkApp :: RIO NetworkTestApp a -> IO a -runNetworkApp = runRIO NetworkTestApp - { _ntaLogFunc = mkLogFunc (\_ _ _ _ -> pure ()) - , _ntaKingId = 34 - , _ntaNetworkConfig = NetworkConfig { _ncNetMode = NMNormal - , _ncAmesPort = Nothing - , _ncNoAmes = False - , _ncNoHttp = False - , _ncNoHttps = False - , _ncHttpPort = Nothing - , _ncHttpsPort = Nothing - , _ncLocalPort = Nothing - } - } +runNetworkApp = + runRIO NetworkTestApp + { _ntaLogFunc = mkLogFunc (\_ _ _ _ -> pure ()) + , _ntaKingId = 34 + , _ntaPortControlApi = buildInactivePorts + , _ntaNetworkConfig = NetworkConfig { _ncNetMode = NMNormal + , _ncAmesPort = Nothing + , _ncNoAmes = False + , _ncNoHttp = False + , _ncNoHttps = False + , _ncHttpPort = Nothing + , _ncHttpsPort = Nothing + , _ncLocalPort = Nothing + } + } runGala :: forall e @@ -110,8 +118,7 @@ sendThread cb (to, val) = void $ mkRAcquire start cancel zodSelfMsg :: Property zodSelfMsg = forAll arbitrary (ioProperty . runNetworkApp . runTest) where - runTest - :: (HasLogFunc e, HasNetworkConfig e, HasKingId e) => Bytes -> RIO e Bool + runTest :: (HasAmes e) => Bytes -> RIO e Bool runTest val = runRAcquire $ do env <- ask (zodQ, zod) <- runGala 0 @@ -121,15 +128,13 @@ zodSelfMsg = forAll arbitrary (ioProperty . runNetworkApp . runTest) twoTalk :: Property twoTalk = forAll arbitrary (ioProperty . runNetworkApp . runTest) where - runTest :: (HasLogFunc e, HasNetworkConfig e, HasKingId e) - => (Word8, Word8, Bytes) -> RIO e Bool + runTest :: (HasAmes e) => (Word8, Word8, Bytes) -> RIO e Bool runTest (aliceShip, bobShip, val) = if aliceShip == bobShip then pure True else go aliceShip bobShip val - go :: (HasLogFunc e, HasNetworkConfig e, HasKingId e) - => Word8 -> Word8 -> Bytes -> RIO e Bool + go :: (HasAmes e) => Word8 -> Word8 -> Bytes -> RIO e Bool go aliceShip bobShip val = runRAcquire $ do (aliceQ, alice) <- runGala aliceShip (bobQ, bob) <- runGala bobShip