diff --git a/pkg/hs/natpmp-static/hsrc_lib/Network/NatPmp.hsc b/pkg/hs/natpmp-static/hsrc_lib/Network/NatPmp.hsc index e349d0a20a..f410625d62 100644 --- a/pkg/hs/natpmp-static/hsrc_lib/Network/NatPmp.hsc +++ b/pkg/hs/natpmp-static/hsrc_lib/Network/NatPmp.hsc @@ -91,8 +91,7 @@ intToEnum = toEnum . fromIntegral getDefaultGateway :: IO (Maybe HostAddress) getDefaultGateway = alloca $ \(pReturnAddr :: Ptr CUInt) -> do - ret <- _get_default_gateway pReturnAddr - case ret of + _get_default_gateway pReturnAddr >>= \case 0 -> (Just . fromIntegral) <$> _peekCUInt pReturnAddr _ -> pure Nothing @@ -151,7 +150,7 @@ data Error | ErrOutOfResources -- | ErrTryAgain - | ErrHaskellBindingsErr + | ErrHaskellBindings deriving (Eq, Show) instance Enum Error where @@ -177,7 +176,7 @@ instance Enum Error where fromEnum ErrOutOfResources = -53 -- fromEnum ErrTryAgain = -100 - fromEnum ErrHaskellBindingsErr = -200 + fromEnum ErrHaskellBindings = -200 toEnum (-1) = ErrInvalidArgs toEnum (-2) = ErrSocketError @@ -201,7 +200,7 @@ instance Enum Error where toEnum (-53) = ErrOutOfResources -- toEnum (-100) = ErrTryAgain - toEnum (-200) = ErrHaskellBindingsErr + toEnum (-200) = ErrHaskellBindings toEnum unmatched = error ("Error.toEnum: Cannot match " ++ show unmatched) @@ -225,7 +224,7 @@ closeNatPmp handle = liftIO do _ -> pure $ Left $ intToEnum ret --- Public interface for getting the public IPv4 address +-- | Public interface for getting the public IPv4 address getPublicAddress :: MonadIO m => NatPmpHandle -> m (Either Error HostAddress) getPublicAddress natpmp = liftIO do sendRetcode <- sendPublicAddressRequest natpmp @@ -235,11 +234,12 @@ getPublicAddress natpmp = liftIO do case respRetcode of 0 -> peek pResponse >>= \case NatPmpResponsePublicAddress addr -> pure $ Right addr - _ -> pure $ Left ErrHaskellBindingsErr + _ -> pure $ Left ErrHaskellBindings _ -> pure $ Left $ intToEnum respRetcode _ -> pure $ Left $ intToEnum sendRetcode - +-- | Requests that the router maps the privatePort on our local computer in our +-- private network to publicPort on the public internet. setPortMapping :: MonadIO m => NatPmpHandle -> ProtocolType @@ -251,8 +251,8 @@ setPortMapping natpmp protocol privatePort publicPort lifetime = liftIO do let protocolNum = fromEnum protocol sendResp <- sendNewPortMappingRequest natpmp - (fromIntegral protocolNum) (CUShort privatePort) (CUShort publicPort) - (CUInt lifetime) + (fromIntegral protocolNum) (CUShort privatePort) (CUShort publicPort) + (CUInt lifetime) case sendResp of 12 -> alloca $ \(pResponse :: NatPmpResponseHandle) -> do @@ -261,6 +261,6 @@ setPortMapping natpmp protocol privatePort publicPort lifetime = liftIO do 0 -> peek pResponse >>= \case NatPmpResponseUdpPortMapping _ _ _ -> pure $ Right () NatPmpResponseTcpPortMapping _ _ _ -> pure $ Right () - _ -> pure $ Left ErrHaskellBindingsErr + _ -> pure $ Left ErrHaskellBindings _ -> pure $ Left $ intToEnum respRetcode x -> pure $ Left $ intToEnum x diff --git a/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs b/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs index f02659427f..588cf74fe3 100644 --- a/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs +++ b/pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs @@ -1,5 +1,5 @@ module Urbit.Vere.Ports (HasPortControlApi(..), - PortControlApi(..), + PortControlApi, buildInactivePorts, buildNATPorts, requestPortAccess) where @@ -83,12 +83,9 @@ portThread :: forall e. (HasLogFunc e) -> (Text -> RIO e ()) -> RIO e () portThread q stderr = do - pmp <- initNatPmp - --pmp <- pure $ Left ErrNoGatewaySupport - case pmp of + initNatPmp >>= \case Left err -> do - ip <- likelyIPAddress - case ip of + 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 " ++ @@ -104,8 +101,7 @@ portThread q stderr = do where foundRouter :: NatPmpHandle -> RIO e () foundRouter pmp = do - pubAddr <- getPublicAddress pmp - case pubAddr of + getPublicAddress pmp >>= \case Left _ -> pure () Right addr -> do let (a, b, c, d) = hostAddressToTuple addr @@ -114,7 +110,7 @@ portThread q stderr = do loop pmp mempty loop :: NatPmpHandle -> MinPrioHeap POSIXTime PortThreadMsg -> RIO e () - loop pmp nextRenew = forever $ do + loop pmp nextRenew = do now <- io $ getPOSIXTime delay <- case viewHead nextRenew of Nothing -> newTVarIO False @@ -141,20 +137,19 @@ portThread q stderr = do PTMInitialRequestOpen p notifyComplete -> do logInfo $ displayShow ("port: sending initial request to NAT-PMP for port ", p) - ret <- setPortMapping pmp PTUdp p p portLeaseLifetime - case ret of + setPortMapping pmp PTUdp p p portLeaseLifetime >>= \case Left err -> do logError $ displayShow ("port: failed to request NAT-PMP for port ", p, ":", err, ", disabling NAT-PMP") loopErr q Right _ -> do - let filteredPort = filterPort p nextRenew + let filteredHeap = filterPort p nextRenew now <- io $ getPOSIXTime let repeatMsg = PTMRequestOpen p let withRenew = insert (now + fromIntegral portRenewalTime, repeatMsg) - filteredPort + filteredHeap atomically notifyComplete loop pmp withRenew @@ -170,10 +165,10 @@ portThread q stderr = do ":", err, ", disabling NAT-PMP") loopErr q Right _ -> do - let filteredPort = filterPort p nextRenew + let filteredHeap = filterPort p nextRenew now <- io $ getPOSIXTime let withRenew = - insert (now + (fromIntegral portRenewalTime), msg) filteredPort + insert (now + (fromIntegral portRenewalTime), msg) filteredHeap loop pmp withRenew PTMRequestClose p -> do @@ -198,22 +193,23 @@ portThread q stderr = do fini = check <=< readTVar -- The NAT system is considered "off" but we still need to signal back to - -- the main thread that blocking actions are copmlete + -- the main thread that blocking actions are complete. loopErr q = forever $ do - (atomically $ readTQueue q) >>= \case + readTQueueIO q >>= \case PTMInitialRequestOpen _ onComplete -> atomically onComplete PTMRequestOpen _ -> pure () PTMRequestClose _ -> pure () -- When we were unable to connect to a router, get the ip address on the --- default ipv4 interface to check if it +-- default ipv4 interface to check if we look like we're on an internal network +-- or not. 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 <- socket AF_INET Datagram 0 - connect sock (SockAddrInet 53 (tupleToHostAddress (8, 8, 8, 8))) + connect sock (SockAddrInet 53 (tupleToHostAddress (1, 1, 1, 1))) sockAddr <- getSocketName sock case sockAddr of SockAddrInet _ addr -> pure $ Just $ hostAddressToTuple addr diff --git a/pkg/hs/urbit-king/test/AmesTests.hs b/pkg/hs/urbit-king/test/AmesTests.hs index 334acccd16..41080dd145 100644 --- a/pkg/hs/urbit-king/test/AmesTests.hs +++ b/pkg/hs/urbit-king/test/AmesTests.hs @@ -48,7 +48,7 @@ sendEf g w bs = NewtEfSend (0, ()) (EachYes g) bs data NetworkTestApp = NetworkTestApp { _ntaLogFunc :: !LogFunc , _ntaNetworkConfig :: !NetworkConfig - , _ntaPortControlApi :: PortControlApi + , _ntaPortControlApi :: !PortControlApi , _ntaKingId :: !Word16 }