king: port forward ames traffic behind a NAT.

Tested with a comet trying to receive traffic from a planet in the
cloud. (h/t ~master-morzod)

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

@@ -32,6 +32,8 @@ POSSIBILITY OF SUCH DAMAGE.
 /* NAT-PMP Port as defined by the NAT-PMP draft */
 #define NATPMP_PORT (5351)
 
+#define ENABLE_STRNATPMPERR
+
 #include <time.h>
 #if !defined(_MSC_VER)
 #include <sys/time.h>

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

@@ -10,6 +10,7 @@ import Network.Socket              hiding (recvFrom, sendTo)
 import Urbit.Arvo                  hiding (Fake)
 import Urbit.King.Config
 import Urbit.Vere.Pier.Types
+import Urbit.Vere.Ports
 
 import Urbit.King.App      (HasKingId(..), HasPierEnv(..))
 import Urbit.Vere.Ames.DNS (NetworkMode(..), ResolvServ(..))
@@ -105,7 +106,10 @@ udpPort isFake who = do
   mPort <- view (networkConfigL . ncAmesPort)
   pure $ maybe (listenPort mode who) fromIntegral mPort
 
-udpServ :: (HasLogFunc e, HasNetworkConfig e) => Bool -> Ship -> RIO e UdpServ
+udpServ :: (HasLogFunc e, HasNetworkConfig e, HasPortControlApi e)
+        => Bool
+        -> Ship
+        -> RIO e UdpServ
 udpServ isFake who = do
   mode <- netMode isFake
   port <- udpPort isFake who
@@ -170,7 +174,7 @@ ames' who isFake stderr = do
 -}
 ames
   :: forall e
-   . (HasLogFunc e, HasNetworkConfig e, HasKingId e)
+   . (HasLogFunc e, HasNetworkConfig e, HasPortControlApi e, HasKingId e)
   => e
   -> Ship
   -> Bool

pkg/hs/urbit-king/lib/Urbit/Vere/Ames/UDP.hs

@@ -33,6 +33,7 @@ module Urbit.Vere.Ames.UDP
 where
 
 import Urbit.Prelude
+import Urbit.Vere.Ports
 
 import Network.Socket hiding (recvFrom, sendTo)
 
@@ -151,7 +152,10 @@ fakeUdpServ = do
   Real UDP server.  See module-level docs.
 -}
 realUdpServ
-  :: forall e . HasLogFunc e => PortNumber -> HostAddress -> RIO e UdpServ
+  :: forall e . (HasLogFunc e, HasPortControlApi e)
+  => PortNumber
+  -> HostAddress
+  -> RIO e UdpServ
 realUdpServ por hos = do
   logDebug $ displayShow ("AMES", "UDP", "Starting real UDP server.")
 
@@ -197,11 +201,21 @@ realUdpServ por hos = do
           logWarn "AMES: UDP: Dropping outbound packet because queue is full."
 
   tOpen <- async $ forever $ do
-    sk <- forceBind por hos
-    atomically (writeTVar vSock (Just sk))
-    broken <- atomically (takeTMVar vFail)
-    logWarn "AMES: UDP: Closing broken socket."
-    io (close broken)
+     sk <- forceBind por hos
+     sn <- io $ getSocketName sk
+
+     let waitForRelease = do
+           atomically (writeTVar vSock (Just sk))
+           broken <- atomically (takeTMVar vFail)
+           logWarn "AMES: UDP: Closing broken socket."
+           io (close broken)
+
+     case sn of
+       (SockAddrInet boundPort _) ->
+         -- When we're on IPv4, maybe port forward at the NAT.
+         rwith (requestPortAccess $ fromIntegral boundPort) $
+             \() -> waitForRelease
+       _ -> waitForRelease
 
   tSend <- async $ forever $ join $ atomically $ do
     (adr, byt) <- readTBQueue qSend

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

@@ -1,7 +1,9 @@
-module Urbit.Vere.Ports where
+module Urbit.Vere.Ports (HasPortControlApi(..),
+                         PortControlApi(..),
+                         buildInactivePorts,
+                         buildNATPorts,
+                         requestPortAccess) where
 
--- (PortControlApi,
---                          buildInactivePorts) 
 import Control.Monad.STM (check)
 import Urbit.Prelude
 import Network.NATPMP
@@ -74,12 +76,14 @@ data PortThreadMsg
 -- scope. OTOH, NAT-PMP is all timeout based, and we want that timeout to be
 -- fairly short, such as 15 minutes, so the portThread needs to keep track of
 -- the time of the next port request.
-portThread :: (HasLogFunc e) => TQueue PortThreadMsg -> RIO e ()
+portThread :: forall e. (HasLogFunc e)
+           => TQueue PortThreadMsg
+           -> RIO e ()
 portThread q = do
   pmp <- io $ initNatPmp
   case pmp of
     Left err -> do
-      logError "error initializing NatPmp"
+      logError "ports: error initializing NAT-PMP. Falling back to null."
       loopErr q
     Right pmp -> loop pmp mempty
   where
@@ -90,7 +94,7 @@ portThread q = do
             Nothing -> newTVarIO False
             Just (fireTime, _) -> do
               let timeTo = fireTime - now
-              let ms = round $ timeTo * 1000
+              let ms = round $ timeTo * 1000000
               registerDelay ms
       command <- atomically $
         (Left <$> fini delay) <|> (Right <$> readTQueue q)
@@ -109,6 +113,9 @@ portThread q = do
               -> RIO e ()
     handlePTM pmp msg nextRenew = case msg of
       PTMInitialRequestOpen p notifyComplete -> do
+        logInfo $
+          displayShow ("ports: sending initial request to NAT-PMP for port ", p)
+        -- TODO: Some error checking would be nice.
         io $ setPortMapping pmp PTUDP p p portLeaseLifetime
         let filteredPort = filterPort p nextRenew
         now <- io $ getPOSIXTime
@@ -120,6 +127,9 @@ portThread q = do
         loop pmp withRenew
 
       PTMRequestOpen p -> do
+        logInfo $
+          displayShow ("ports: sending renewing request to NAT-PMP for port ",
+                       p)
         io $ setPortMapping pmp PTUDP p p portLeaseLifetime
         let filteredPort = filterPort p nextRenew
         now <- io $ getPOSIXTime
@@ -128,6 +138,8 @@ portThread q = do
         loop pmp withRenew
 
       PTMRequestClose p -> do
+        logInfo $
+          displayShow ("ports: releasing lease for ", p)
         io $ setPortMapping pmp PTUDP p p 0
         let removed = filterPort p nextRenew
         loop pmp removed