natpmp: checkpoint while addressing comments

pkg/hs/natpmp-static/hsrc_lib/Network/NatPmp.hsc

@@ -206,20 +206,20 @@ instance Enum Error where
 
 
 initNatPmp :: MonadIO m => m (Either Error NatPmpHandle)
-initNatPmp = do
-  natpmp <- liftIO $ mallocBytes #{size natpmp_t}
-  ret    <- liftIO $ _init_nat_pmp natpmp 0 0
+initNatPmp = liftIO do
+  natpmp <- mallocBytes #{size natpmp_t}
+  ret    <- _init_nat_pmp natpmp 0 0
   case ret of
     0 -> pure $ Right natpmp
     _ -> do
-      liftIO $ free natpmp
+      free natpmp
       pure $ Left $ intToEnum ret
 
 
 closeNatPmp :: MonadIO m => NatPmpHandle -> m (Either Error ())
-closeNatPmp handle = do
-  ret <- liftIO $ _close_nat_pmp handle
-  liftIO $ free handle
+closeNatPmp handle = liftIO do
+  ret <- _close_nat_pmp handle
+  free handle
   case ret of
     0 -> pure $ Right ()
     _ -> pure $ Left $ intToEnum ret
@@ -227,10 +227,10 @@ closeNatPmp handle = do
 
 -- Public interface for getting the public IPv4 address
 getPublicAddress :: MonadIO m => NatPmpHandle -> m (Either Error HostAddress)
-getPublicAddress natpmp = do
-  sendRetcode <- liftIO $ sendPublicAddressRequest natpmp
+getPublicAddress natpmp = liftIO do
+  sendRetcode <- sendPublicAddressRequest natpmp
   case sendRetcode of
-    2 -> liftIO $ alloca $ \(pResponse :: NatPmpResponseHandle) -> do
+    2 -> alloca $ \(pResponse :: NatPmpResponseHandle) -> do
       respRetcode <- readNatResponseSynchronously natpmp pResponse
       case respRetcode of
         0 -> peek pResponse >>= \case
@@ -247,15 +247,15 @@ setPortMapping :: MonadIO m
                -> Port
                -> LifetimeSeconds
                -> m (Either Error ())
-setPortMapping natpmp protocol privatePort publicPort lifetime = do
+setPortMapping natpmp protocol privatePort publicPort lifetime = liftIO do
   let protocolNum = fromEnum protocol
   sendResp <-
-    liftIO $ sendNewPortMappingRequest natpmp
+    sendNewPortMappingRequest natpmp
     (fromIntegral protocolNum) (CUShort privatePort) (CUShort publicPort)
     (CUInt lifetime)
 
   case sendResp of
-    12 -> liftIO $ alloca $ \(pResponse :: NatPmpResponseHandle) -> do
+    12 -> alloca $ \(pResponse :: NatPmpResponseHandle) -> do
       respRetcode <- readNatResponseSynchronously natpmp pResponse
       case respRetcode of
         0 -> peek pResponse >>= \case

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

@@ -141,8 +141,8 @@ class (HasKingEnv a, HasMultiEyreApi a, HasPortControlApi a) =>
 
 data HostEnv = HostEnv
   { _hostEnvKingEnv        :: !KingEnv
-  , _hostEnvMultiEyreApi   :: MultiEyreApi
-  , _hostEnvPortControlApi :: PortControlApi
+  , _hostEnvMultiEyreApi   :: !MultiEyreApi
+  , _hostEnvPortControlApi :: !PortControlApi
   }
 
 makeLenses ''HostEnv
@@ -170,8 +170,8 @@ instance HasPortControlApi HostEnv where
 
 -- Running Running Envs --------------------------------------------------------
 
-runHostEnv :: MultiEyreApi -> PortControlApi -> RIO HostEnv ()
-              -> RIO KingEnv ()
+runHostEnv :: MultiEyreApi -> PortControlApi -> RIO HostEnv a
+           -> RIO KingEnv a
 runHostEnv multi ports action = do
     king <- ask
 

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

@@ -197,11 +197,9 @@ pillFromURL = PillSourceURL <$> strOption
                     <> help "URL to pill file")
 
 enableNAT :: Parser Bool
-enableNAT = (flag' False
+enableNAT = not <$> switch
                ( long "no-port-forwarding"
-              <> help "Disable trying to ask the router to forward ames ports"))
-            <|>
-            (pure True)
+              <> help "Disable trying to ask the router to forward ames ports")
 
 pierPath :: Parser FilePath
 pierPath = strArgument (metavar "PIER" <> help "Path to pier")

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

@@ -474,15 +474,12 @@ newShip CLI.New{..} opts = do
   -}
   multi <- multiEyre (MultiEyreConf Nothing Nothing True)
 
-  -- TODO: We hit the same problem as above: we need the running options to
-  -- determine how to configure the ports
+  -- TODO: We hit the same problem as above: we need a host env to boot a ship
+  -- because it may autostart the ship, so build an inactive port configuration.
   let ports = buildInactivePorts
 
   -- here we are with a king env, and we now need a multi env.
-  runHostEnv multi ports go
-  where
-    go :: RIO HostEnv ()
-    go = case nBootType of
+  runHostEnv multi ports $ case nBootType of
     CLI.BootComet -> do
       pill <- pillFrom nPillSource
       putStrLn "boot: retrieving list of stars currently accepting comets"
@@ -515,6 +512,7 @@ newShip CLI.New{..} opts = do
 
       bootFromSeed pill seed
 
+  where
     shipFrom :: Text -> RIO HostEnv Ship
     shipFrom name = case Ob.parsePatp name of
       Left x  -> error "Invalid ship name"
@@ -525,7 +523,7 @@ newShip CLI.New{..} opts = do
       Just x  -> x
       Nothing -> "./" <> unpack name
 
-    nameFromShip :: Ship -> RIO HostEnv Text
+    nameFromShip :: HasKingEnv e => Ship -> RIO e Text
     nameFromShip s = name
       where
         nameWithSig = Ob.renderPatp $ Ob.patp $ fromIntegral s
@@ -546,16 +544,17 @@ newShip CLI.New{..} opts = do
 
     -- Now that we have all the information for running an application with a
     -- PierConfig, do so.
-    runTryBootFromPill :: Pill -> Text -> Ship -> LegacyBootEvent
+    runTryBootFromPill :: Pill
+                       -> Text
+                       -> Ship
+                       -> LegacyBootEvent
                        -> RIO HostEnv ()
     runTryBootFromPill pill name ship bootEvent = do
-      env <- ask
-      let vKill = (env ^. kingEnvL) ^. kingEnvKillSignal
+      vKill <- asks (^. kingEnvL . kingEnvKillSignal)
       let pierConfig = toPierConfig (pierPath name) opts
       let networkConfig = toNetworkConfig opts
       runPierEnv pierConfig networkConfig vKill $
         tryBootFromPill True pill nLite ship bootEvent
-------  tryBootFromPill (CLI.oExit opts) pill nLite flags ship bootEvent
 
 runShipEnv :: CLI.Run -> CLI.Opts -> TMVar () -> RIO PierEnv a -> RIO HostEnv a
 runShipEnv (CLI.Run pierPath) opts vKill act = do
@@ -591,8 +590,8 @@ runShip (CLI.Run pierPath) opts daemon = do
         mStart
 
 
-buildPortHandler :: (HasLogFunc e) => Bool -> RIO e PortControlApi
-buildPortHandler False  = pure $ buildInactivePorts
+buildPortHandler :: HasLogFunc e => Bool -> RIO e PortControlApi
+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.
@@ -725,8 +724,7 @@ runShipNoRestart
   :: CLI.Run -> CLI.Opts -> Bool -> RIO HostEnv ()
 runShipNoRestart r o d = do
   -- killing ship same as killing king
-  env <- ask
-  let vKill = (env ^. kingEnvL) ^. kingEnvKillSignal
+  vKill  <- asks (^. kingEnvL . kingEnvKillSignal)
   tid    <- asyncBound (runShipEnv r o vKill $ runShip r o d)
   onKill <- view onKillKingSigL
 

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

@@ -152,7 +152,8 @@ fakeUdpServ = do
   Real UDP server.  See module-level docs.
 -}
 realUdpServ
-  :: forall e . (HasLogFunc e, HasPortControlApi e)
+  :: forall e
+   . (HasLogFunc e, HasPortControlApi e)
   => PortNumber
   -> HostAddress
   -> RIO e UdpServ

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

@@ -179,8 +179,7 @@ startServ
 startServ who isFake conf plan = do
   logDebug (displayShow ("EYRE", "startServ"))
 
-  env <- ask
-  let multi = env ^. multiEyreApiL
+  multi <- asks (^. multiEyreApiL)
 
   let vLive = meaLive multi
 

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

@@ -23,32 +23,31 @@ data PortControlApi = PortControlApi
   , pRemovePortRequest :: Word16 -> IO ()
   }
 
--- Builds a Ports struct which does nothing when called.
+-- | Builds a PortControlApi struct which does nothing when called.
 buildInactivePorts :: PortControlApi
 buildInactivePorts = PortControlApi noop noop
  where
   noop x = pure ()
 
--- Builds a Ports struct which tries to hole-punch by talking to the NAT
--- gateway over NAT-PMP.
+-- | Builds a PortControlApi struct which tries to hole-punch by talking to the
+-- NAT gateway over NAT-PMP.
 buildNATPorts :: (HasLogFunc e)
               => (Text -> RIO e ())
               -> RIO e PortControlApi
 buildNATPorts stderr = do
   q <- newTQueueIO
   async $ portThread q stderr
-  pure $ PortControlApi (addRequest q) (removeRequest q)
-  where
-    addRequest :: TQueue PortThreadMsg -> Word16 -> IO ()
-    addRequest q port = do
+
+  let addRequest port = do
         resp <- newEmptyTMVarIO
         atomically $
           writeTQueue q (PTMInitialRequestOpen port (putTMVar resp True))
         atomically $ takeTMVar resp
         pure ()
 
-    removeRequest :: TQueue PortThreadMsg -> Word16 -> IO ()
-    removeRequest q port = atomically $ writeTQueue q (PTMRequestClose port)
+  let removeRequest port = atomically $ writeTQueue q (PTMRequestClose port)
+
+  pure $ PortControlApi addRequest removeRequest
 
 portLeaseLifetime :: Word32
 portLeaseLifetime = 15 * 60
@@ -154,7 +153,7 @@ portThread q stderr = do
           now <- io $ getPOSIXTime
           let repeatMsg = PTMRequestOpen p
           let withRenew =
-                  insert (now + (fromIntegral portRenewalTime), repeatMsg)
+                insert (now + fromIntegral portRenewalTime, repeatMsg)
                 filteredPort
           atomically notifyComplete
           loop pmp withRenew
@@ -208,14 +207,14 @@ portThread q stderr = do
 
 -- When we were unable to connect to a router, get the ip address on the
 -- default ipv4 interface to check if it
-likelyIPAddress :: RIO e (Maybe (Word8, Word8, Word8, Word8))
-likelyIPAddress = do
+likelyIPAddress :: MonadIO m => m (Maybe (Word8, Word8, Word8, Word8))
+likelyIPAddress = liftIO do
   -- Try opening a socket to 1.1.1.1 to get our own IP address. Since UDP is
   -- stateless and we aren't sending anything, we aren't actually contacting
   -- them in any way.
-  sock <- io $ socket AF_INET Datagram 0
-  io $ connect sock (SockAddrInet 53 (tupleToHostAddress (8, 8, 8, 8)))
-  sockAddr <- io $ getSocketName sock
+  sock <- socket AF_INET Datagram 0
+  connect sock (SockAddrInet 53 (tupleToHostAddress (8, 8, 8, 8)))
+  sockAddr <- getSocketName sock
   case sockAddr of
     SockAddrInet _ addr -> pure $ Just $ hostAddressToTuple addr
     _                   -> pure $ Nothing
@@ -227,13 +226,11 @@ requestPortAccess port = do
  where
   request :: RIO e ()
   request = do
-      env <- ask
-      let api = env ^. portControlApiL
-      io $ (pAddPortRequest api) port
+    api <- asks (^. portControlApiL)
+    io $ pAddPortRequest api port
 
   release :: () -> RIO e ()
   release _ = do
-      env <- ask
-      let api = env ^. portControlApiL
-      io $ (pRemovePortRequest api) port
+    api <- asks (^. portControlApiL)
+    io $ pRemovePortRequest api port
 

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

@@ -28,8 +28,11 @@ import qualified Urbit.EventLog.LMDB as Log
 
 --------------------------------------------------------------------------------
 
-type HasAmes e = (HasLogFunc e, HasNetworkConfig e, HasKingId e,
-                   HasPortControlApi e)
+type HasAmes e =
+  ( HasLogFunc e
+  , HasNetworkConfig e
+  , HasKingId e
+  , HasPortControlApi e)
 
 -- Utils -----------------------------------------------------------------------