Merge pull request #3350 from urbit/king-nat-on-private-networks-only

natpmp: change nat-pmp startup behaviour.

pkg/hs/natpmp-static/cbits/binding.c

@@ -55,22 +55,22 @@ int readNatResponseSynchronously(natpmp_t* natpmp, natpmpresp_t * response)
 		r = select(FD_SETSIZE, &fds, NULL, NULL, &timeout);
 		sav_errno = errno;
 		if(r<0) {
-			fprintf(stderr, "select():  errno=%d '%s'\n",
-			        sav_errno, strerror(sav_errno));
+			/* fprintf(stderr, "select():  errno=%d '%s'\n", */
+			/*         sav_errno, strerror(sav_errno)); */
 			return 1;
 		}
 		r = readnatpmpresponseorretry(natpmp, response);
 		sav_errno = errno;
 		/* printf("readnatpmpresponseorretry returned %d (%s)\n", */
 		/*        r, r==0?"OK":(r==NATPMP_TRYAGAIN?"TRY AGAIN":"FAILED")); */
-		if(r<0 && r!=NATPMP_TRYAGAIN) {
-#ifdef ENABLE_STRNATPMPERR
-			fprintf(stderr, "readnatpmpresponseorretry() failed : %s\n",
-			        strnatpmperr(r));
-#endif
-			fprintf(stderr, "  errno=%d '%s'\n",
-			        sav_errno, strerror(sav_errno));
-		}
+/* 		if(r<0 && r!=NATPMP_TRYAGAIN) { */
+/* #ifdef ENABLE_STRNATPMPERR */
+/* 			fprintf(stderr, "readnatpmpresponseorretry() failed : %s\n", */
+/* 			        strnatpmperr(r)); */
+/* #endif */
+/* 			fprintf(stderr, "  errno=%d '%s'\n", */
+/* 			        sav_errno, strerror(sav_errno)); */
+/* 		} */
 	} while(r==NATPMP_TRYAGAIN);
 
     return r;

pkg/hs/natpmp-static/cbits/natpmp.c

@@ -282,11 +282,19 @@ int readnatpmpresponseorretry(natpmp_t * p, natpmpresp_t * response)
 			gettimeofday(&now, NULL);	// check errors !
 			if(timercmp(&now, &p->retry_time, >=)) {
 				int delay, r;
-				if(p->try_number >= 9) {
+                // NOTE: This used to be 9, and was changed for the haskell
+                // bindings to be 5.
+				if(p->try_number >= 5) {
 					return NATPMP_ERR_NOGATEWAYSUPPORT;
 				}
 				/*printf("retry! %d\n", p->try_number);*/
-				delay = 250 * (1<<p->try_number);	// ms
+
+                // NOTE: Changed how delays are calculated. Waiting up to four
+                // minutes for a packet that might never get a response is not
+                // a good user experience. Instead, retry up to 2 seconds.
+                //
+				// delay = 250 * (1<<p->try_number);	// ms
+                delay = 250 * p->try_number;	// ms
 				/*for(i=0; i<p->try_number; i++)
 					delay += delay;*/
 				p->retry_time.tv_sec += (delay / 1000);

pkg/hs/urbit-king/lib/Urbit/King/CLI.hs

@@ -19,7 +19,7 @@ import System.Environment (getProgName)
 data Host = Host
   { hSharedHttpPort  :: Maybe Word16
   , hSharedHttpsPort :: Maybe Word16
-  , hUseNatPmp       :: Bool
+  , hUseNatPmp       :: Nat
   }
  deriving (Show)
 
@@ -71,6 +71,12 @@ data PillSource
   | PillSourceURL String
   deriving (Show)
 
+data Nat
+  = NatAlways
+  | NatWhenPrivateNetwork
+  | NatNever
+  deriving (Show)
+
 data New = New
     { nPillSource :: PillSource
     , nPierPath   :: Maybe FilePath -- Derived from ship name if not specified.
@@ -427,11 +433,23 @@ host = do
     <> hidden
 
   hUseNatPmp <-
-    fmap not
-    $  switch
+     ( flag' NatAlways
+     $ long "port-forwarding"
+    <> help "Always try to search for a router to forward ames ports"
+    <> hidden
+     ) <|>
+     ( flag' NatNever
      $ long "no-port-forwarding"
     <> help "Disable trying to ask the router to forward ames ports"
     <> hidden
+     ) <|>
+     ( flag' NatWhenPrivateNetwork
+     $ long "port-forwarding-when-internal"
+    <> help ("Try asking the router to forward when ip is 192.168.0.0/16, " <>
+             "172.16.0.0/12 or 10.0.0.0/8 (default).")
+    <> hidden
+     ) <|>
+     (pure $ NatWhenPrivateNetwork)
 
   pure (Host{..})
 

pkg/hs/urbit-king/lib/Urbit/King/Main.hs

@@ -590,12 +590,14 @@ runShip (CLI.Run pierPath) opts daemon = do
         mStart
 
 
-buildPortHandler :: HasLogFunc e => Bool -> RIO e PortControlApi
-buildPortHandler False  = pure buildInactivePorts
+buildPortHandler :: HasLogFunc e => CLI.Nat -> RIO e PortControlApi
+buildPortHandler CLI.NatNever  = 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 CLI.NatAlways = buildNatPorts (io . hPutStrLn stderr . unpack)
+buildPortHandler CLI.NatWhenPrivateNetwork =
+  buildNatPortsWhenPrivate (io . hPutStrLn stderr . unpack)
 
 startBrowser :: HasLogFunc e => FilePath -> RIO e ()
 startBrowser pierPath = runRAcquire $ do

pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs

@@ -1,6 +1,7 @@
 module Urbit.Vere.Ports (HasPortControlApi(..),
                          PortControlApi,
                          buildInactivePorts,
+                         buildNatPortsWhenPrivate,
                          buildNatPorts,
                          requestPortAccess) where
 
@@ -30,6 +31,17 @@ buildInactivePorts = PortControlApi noop noop
  where
   noop x = pure ()
 
+-- | Builds a PortControlApi struct which tries to hole-punch by talking to the
+-- NAT gateway over NAT-PMP iff we are on a private network ip.
+buildNatPortsWhenPrivate :: (HasLogFunc e)
+                         => (Text -> RIO e ())
+                         -> RIO e PortControlApi
+buildNatPortsWhenPrivate stderr = do
+  behind <- likelyBehindRouter
+  if behind
+    then buildNatPorts stderr
+    else pure buildInactivePorts
+
 -- | Builds a PortControlApi struct which tries to hole-punch by talking to the
 -- NAT gateway over NAT-PMP.
 buildNatPorts :: (HasLogFunc e)
@@ -87,9 +99,13 @@ portThread :: forall e. (HasLogFunc e)
            -> RIO e ()
 portThread q stderr = do
   initNatPmp >>= \case
+    Left ErrCannotGetGateway -> do
+      assumeOnPublicInternet
     Left err -> do
       likelyIPAddress >>= \case
         Just ip@(192, 168, _, _) -> warnBehindRouterAndErr ip err
+        Just ip@(172, x, _, _)
+          | (x >= 16 && x <= 31) -> warnBehindRouterAndErr ip err
         Just ip@(10, _, _, _)    -> warnBehindRouterAndErr ip err
         _                        -> assumeOnPublicInternet
     Right pmp -> foundRouter pmp
@@ -111,7 +127,12 @@ portThread q stderr = do
   foundRouter :: NatPmpHandle -> RIO e ()
   foundRouter pmp = do
     getPublicAddress pmp >>= \case
-      Left _ -> pure ()
+      Left ErrCannotGetGateway -> assumeOnPublicInternet
+      Left ErrNoGatewaySupport -> assumeOnPublicInternet
+      Left err -> do
+        stderr $ "port: received error when asking router for public ip: " ++
+          (tshow err)
+        loopErr q
       Right addr -> do
         let (a, b, c, d) = hostAddressToTuple addr
         stderr $ "port: router reports that our public IP is " ++ (tshow a) ++
@@ -222,6 +243,16 @@ likelyIPAddress = liftIO do
     SockAddrInet _ addr -> pure $ Just $ hostAddressToTuple addr
     _                   -> pure $ Nothing
 
+likelyBehindRouter :: MonadIO m => m Bool
+likelyBehindRouter = do
+  likelyIPAddress >>= \case
+    Just ip@(192, 168, _, _) -> pure True
+    Just ip@(172, x, _, _)
+      | (x >= 16 && x <= 31) -> pure True
+    Just ip@(10, _, _, _)    -> pure True
+    _                        -> pure False
+
+
 -- Acquire a port for the duration of the RAcquire.
 requestPortAccess :: forall e. (HasPortControlApi e) => Word16 -> RAcquire e ()
 requestPortAccess port = do