diff --git a/pkg/hs/urbit-king/lib/Urbit/King/App.hs b/pkg/hs/urbit-king/lib/Urbit/King/App.hs index 5c263748ce..9f152c6f2b 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/App.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/App.hs @@ -127,10 +127,8 @@ killKingActionL = -- HostEnv ------------------------------------------------------------------ --- The running environment is everything in King, eyre configuration shared --- across ships, and IP information shared across ships. --- --- TODO: Implement that IP information for real. +-- The host environment is everything in King, eyre configuration shared +-- across ships, and nat punching data. class HasMultiEyreApi a where multiEyreApiL :: Lens' a MultiEyreApi @@ -189,7 +187,7 @@ class (HasKingEnv a, HasHostEnv a, HasPierConfig a, HasNetworkConfig a) => pierEnvL :: Lens' a PierEnv data PierEnv = PierEnv - { _pierEnvHostEnv :: !HostEnv + { _pierEnvHostEnv :: !HostEnv , _pierEnvPierConfig :: !PierConfig , _pierEnvNetworkConfig :: !NetworkConfig , _pierEnvKillSignal :: !(TMVar ()) @@ -252,9 +250,9 @@ killPierActionL = runPierEnv :: PierConfig -> NetworkConfig -> TMVar () -> RIO PierEnv a -> RIO HostEnv a runPierEnv pierConfig networkConfig vKill action = do - running <- ask + host <- ask - let pierEnv = PierEnv { _pierEnvHostEnv = running + let pierEnv = PierEnv { _pierEnvHostEnv = host , _pierEnvPierConfig = pierConfig , _pierEnvNetworkConfig = networkConfig , _pierEnvKillSignal = vKill diff --git a/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs b/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs index c0e72369df..8494f9e21b 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/CLI.hs @@ -196,8 +196,8 @@ pillFromURL = PillSourceURL <$> strOption <> value defaultPillURL <> help "URL to pill file") -enableNAT :: Parser Bool -enableNAT = not <$> switch +enableNat :: Parser Bool +enableNat = not <$> switch ( long "no-port-forwarding" <> help "Disable trying to ask the router to forward ames ports") @@ -353,7 +353,7 @@ runOneShip = (,,) <$> fmap Run pierPath <*> opts <*> df kingOpts :: Parser KingOpts kingOpts = do - koUseNatPmp <- enableNAT + koUseNatPmp <- enableNat koSharedHttpPort <- optional diff --git a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs index 7ee35b5445..7e77bd894f 100644 --- a/pkg/hs/urbit-king/lib/Urbit/King/Main.hs +++ b/pkg/hs/urbit-king/lib/Urbit/King/Main.hs @@ -550,7 +550,7 @@ newShip CLI.New{..} opts = do -> LegacyBootEvent -> RIO HostEnv () runTryBootFromPill pill name ship bootEvent = do - vKill <- asks (^. kingEnvL . kingEnvKillSignal) + vKill <- view (kingEnvL . kingEnvKillSignal) let pierConfig = toPierConfig (pierPath name) opts let networkConfig = toNetworkConfig opts runPierEnv pierConfig networkConfig vKill $ @@ -595,7 +595,7 @@ buildPortHandler False = pure buildInactivePorts -- TODO: Figure out what to do about logging here. The "port: " messages are -- the sort of thing that should be put on the muxed terminal log, but we don't -- have that at this layer. -buildPortHandler True = buildNATPorts (io . hPutStrLn stderr . unpack) +buildPortHandler True = buildNatPorts (io . hPutStrLn stderr . unpack) startBrowser :: HasLogFunc e => FilePath -> RIO e () startBrowser pierPath = runRAcquire $ do @@ -724,7 +724,7 @@ runShipNoRestart :: CLI.Run -> CLI.Opts -> Bool -> RIO HostEnv () runShipNoRestart r o d = do -- killing ship same as killing king - vKill <- asks (^. kingEnvL . kingEnvKillSignal) + vKill <- view (kingEnvL . kingEnvKillSignal) tid <- asyncBound (runShipEnv r o vKill $ runShip r o d) onKill <- view onKillKingSigL diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs index 641b7061a3..aec3d0473c 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs @@ -179,7 +179,7 @@ startServ startServ who isFake conf plan = do logDebug (displayShow ("EYRE", "startServ")) - multi <- asks (^. multiEyreApiL) + multi <- view multiEyreApiL let vLive = meaLive multi diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs index 873d7e1d30..40e06b7b1b 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs @@ -1,16 +1,17 @@ module Urbit.Vere.Ports (HasPortControlApi(..), PortControlApi, buildInactivePorts, - buildNATPorts, + buildNatPorts, requestPortAccess) where import Control.Monad.STM (check) import Urbit.Prelude import Network.NatPmp import Data.Time.Clock.POSIX -import Data.Heap import Network.Socket +import qualified Data.Heap as DH + -- This module deals with ports and port requests. When a component wants to -- ensure that it is externally reachable, possibly from outside a NAT, it -- makes a request to this module to hole-punch. @@ -31,21 +32,21 @@ buildInactivePorts = PortControlApi noop noop -- | Builds a PortControlApi struct which tries to hole-punch by talking to the -- NAT gateway over NAT-PMP. -buildNATPorts :: (HasLogFunc e) +buildNatPorts :: (HasLogFunc e) => (Text -> RIO e ()) -> RIO e PortControlApi -buildNATPorts stderr = do +buildNatPorts stderr = do q <- newTQueueIO async $ portThread q stderr let addRequest port = do resp <- newEmptyTMVarIO atomically $ - writeTQueue q (PTMRequestOpen port (putTMVar resp True)) + writeTQueue q (PTMOpen port (putTMVar resp True)) atomically $ takeTMVar resp pure () - let removeRequest port = atomically $ writeTQueue q (PTMRequestClose port) + let removeRequest port = atomically $ writeTQueue q (PTMClose port) pure $ PortControlApi addRequest removeRequest @@ -58,13 +59,13 @@ portRenewalTime = portLeaseLifetime - 60 -- Messages sent from the main thread to the port mapping communication thread. data PortThreadMsg - = PTMRequestOpen Word16 (STM ()) + = PTMOpen Word16 (STM ()) -- ^ Does the open request, and then calls the passed in stm action to -- singal completion to the main thread. We want to block on the initial -- setting opening because we want the forwarding set up before we actually -- start using the port. - | PTMRequestClose Word16 + | PTMClose Word16 -- ^ Close command. No synchronization because there's nothing we can do if -- it fails. @@ -88,19 +89,25 @@ portThread q stderr = do initNatPmp >>= \case Left err -> do likelyIPAddress >>= \case - Just (192, 168, c, d) -> do - stderr $ "port: you appear to be behind a router since your ip " ++ - "is 192.168." ++ (tshow c) ++ "." ++ (tshow d) ++ ", but " ++ - "we could not request port forwarding (NAT-PMP error: " ++ - (tshow err) ++ ")" - stderr $ "port: urbit performance will be degregaded unless you " ++ - "manually forward your ames port." - loopErr q - _ -> do - stderr $ "port: couldn't find router; assuming on public internet" - loopErr q + Just ip@(192, 168, c, d) -> warnBehindRouterAndErr ip err + Just ip@(10, _, _, _) -> warnBehindRouterAndErr ip err + _ -> assumeOnPublicInternet Right pmp -> foundRouter pmp where + warnBehindRouterAndErr (a, b, c, d) err = do + stderr $ "port: you appear to be behind a router since your ip " ++ + "is " ++ (tshow a) ++ "." ++ (tshow b) ++ "." ++ (tshow c) ++ + "." ++ (tshow d) ++ ", but " ++ + "we could not request port forwarding (NAT-PMP error: " ++ + (tshow err) ++ ")" + stderr $ "port: urbit performance will be degregaded unless you " ++ + "manually forward your ames port." + loopErr q + + assumeOnPublicInternet = do + stderr $ "port: couldn't find router; assuming on public internet" + loopErr q + foundRouter :: NatPmpHandle -> RIO e () foundRouter pmp = do getPublicAddress pmp >>= \case @@ -111,10 +118,10 @@ portThread q stderr = do "." ++ (tshow b) ++ "." ++ (tshow c) ++ "." ++ (tshow d) loop pmp mempty - loop :: NatPmpHandle -> MinPrioHeap POSIXTime RenewAction -> RIO e () + loop :: NatPmpHandle -> DH.MinPrioHeap POSIXTime RenewAction -> RIO e () loop pmp nextRenew = do now <- io $ getPOSIXTime - delay <- case viewHead nextRenew of + delay <- case DH.viewHead nextRenew of Nothing -> newTVarIO False Just (fireTime, _) -> do let timeTo = fireTime - now @@ -123,15 +130,15 @@ portThread q stderr = do command <- atomically $ (Left <$> fini delay) <|> (Right <$> readTQueue q) case command of - Left () -> handleRenew pmp nextRenew + Left () -> handleRenew pmp nextRenew Right msg -> handlePTM pmp msg nextRenew handlePTM :: NatPmpHandle -> PortThreadMsg - -> MinPrioHeap POSIXTime RenewAction + -> DH.MinPrioHeap POSIXTime RenewAction -> RIO e () handlePTM pmp msg nextRenew = case msg of - PTMRequestOpen p notifyComplete -> do + PTMOpen p notifyComplete -> do logInfo $ displayShow ("port: sending initial request to NAT-PMP for port ", p) setPortMapping pmp PTUdp p p portLeaseLifetime >>= \case @@ -146,12 +153,12 @@ portThread q stderr = do let filteredHeap = filterPort p nextRenew now <- io $ getPOSIXTime let withRenew = - insert (now + fromIntegral portRenewalTime, RenewAction p) - filteredHeap + DH.insert (now + fromIntegral portRenewalTime, RenewAction p) + filteredHeap atomically notifyComplete loop pmp withRenew - PTMRequestClose p -> do + PTMClose p -> do logInfo $ displayShow ("port: releasing lease for ", p) setPortMapping pmp PTUdp p p 0 @@ -159,10 +166,10 @@ portThread q stderr = do loop pmp removed handleRenew :: NatPmpHandle - -> MinPrioHeap POSIXTime RenewAction + -> DH.MinPrioHeap POSIXTime RenewAction -> RIO e () handleRenew pmp nextRenew = do - case (Data.Heap.view nextRenew) of + case (DH.view nextRenew) of Nothing -> error "Internal heap managing error." Just ((_, RenewAction p), rest) -> do logInfo $ @@ -178,16 +185,16 @@ portThread q stderr = do -- We don't need to filter the port because we just did. now <- io $ getPOSIXTime let withRenew = - insert (now + (fromIntegral portRenewalTime), RenewAction p) - rest + DH.insert (now + fromIntegral portRenewalTime, RenewAction p) + rest loop pmp withRenew filterPort :: Word16 - -> MinPrioHeap POSIXTime RenewAction - -> MinPrioHeap POSIXTime RenewAction - filterPort p = Data.Heap.filter okPort - where - okPort (_, RenewAction x) = p /= x + -> DH.MinPrioHeap POSIXTime RenewAction + -> DH.MinPrioHeap POSIXTime RenewAction + filterPort p = DH.filter okPort + where + okPort (_, RenewAction x) = p /= x -- block (retry) until the delay TVar is set to True fini :: TVar Bool -> STM () @@ -197,8 +204,8 @@ portThread q stderr = do -- the main thread that blocking actions are complete. loopErr q = forever $ do (atomically $ readTQueue q) >>= \case - PTMRequestOpen _ onComplete -> atomically onComplete - PTMRequestClose _ -> pure () + PTMOpen _ onComplete -> atomically onComplete + PTMClose _ -> pure () -- When we were unable to connect to a router, get the ip address on the -- default ipv4 interface to check if we look like we're on an internal network @@ -222,11 +229,11 @@ requestPortAccess port = do where request :: RIO e () request = do - api <- asks (^. portControlApiL) + api <- view portControlApiL io $ pAddPortRequest api port release :: () -> RIO e () release _ = do - api <- asks (^. portControlApiL) + api <- view portControlApiL io $ pRemovePortRequest api port