urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2025-01-03 10:02:32 +03:00
Code Issues Packages Projects Releases Wiki Activity

natpmp: checkpoint while addressing comments

Browse Source
This commit is contained in:
Elliot Glaysher 2020-08-13 11:12:26 -04:00
parent ac4b5a99e5
commit 1183ac0b22
8 changed files with 196 additions and 200 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
pkg/hs/natpmp-static/hsrc_lib/Network/NatPmp.hsc
View File

@ -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

8
pkg/hs/urbit-king/lib/Urbit/King/App.hs
View File

@ -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

6
pkg/hs/urbit-king/lib/Urbit/King/CLI.hs
View File

@ -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")

90
pkg/hs/urbit-king/lib/Urbit/King/Main.hs
View File

@ -474,47 +474,45 @@ 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
runHostEnv multi ports $ case nBootType of
CLI.BootComet -> do
pill <- pillFrom nPillSource
putStrLn "boot: retrieving list of stars currently accepting comets"
starList <- dawnCometList
putStrLn ("boot: " ++ (tshow $ length starList) ++
" star(s) currently accepting comets")
putStrLn "boot: mining a comet"
eny <- io $ Sys.randomIO
let seed = mineComet (Set.fromList starList) eny
putStrLn ("boot: found comet " ++ renderShip (sShip seed))
bootFromSeed pill seed
CLI.BootFake name -> do
pill <- pillFrom nPillSource
ship <- shipFrom name
runTryBootFromPill pill name ship (Fake ship)
CLI.BootFromKeyfile keyFile -> do
text <- readFileUtf8 keyFile
asAtom <- case cordToUW (Cord $ T.strip text) of
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
Just (UW a) -> pure a
asNoun <- cueExn asAtom
seed :: Seed <- case fromNoun asNoun of
Nothing -> error "Keyfile does not seem to contain a seed."
Just s -> pure s
pill <- pillFrom nPillSource
bootFromSeed pill seed
where
go :: RIO HostEnv ()
go = case nBootType of
CLI.BootComet -> do
pill <- pillFrom nPillSource
putStrLn "boot: retrieving list of stars currently accepting comets"
starList <- dawnCometList
putStrLn ("boot: " ++ (tshow $ length starList) ++
" star(s) currently accepting comets")
putStrLn "boot: mining a comet"
eny <- io $ Sys.randomIO
let seed = mineComet (Set.fromList starList) eny
putStrLn ("boot: found comet " ++ renderShip (sShip seed))
bootFromSeed pill seed
CLI.BootFake name -> do
pill <- pillFrom nPillSource
ship <- shipFrom name
runTryBootFromPill pill name ship (Fake ship)
CLI.BootFromKeyfile keyFile -> do
text <- readFileUtf8 keyFile
asAtom <- case cordToUW (Cord $ T.strip text) of
Nothing -> error "Couldn't parse keyfile. Hint: keyfiles start with 0w?"
Just (UW a) -> pure a
asNoun <- cueExn asAtom
seed :: Seed <- case fromNoun asNoun of
Nothing -> error "Keyfile does not seem to contain a seed."
Just s -> pure s
pill <- pillFrom nPillSource
bootFromSeed pill seed
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

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

@ -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

3
pkg/hs/urbit-king/lib/Urbit/Vere/Eyre.hs
View File

@ -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

253
pkg/hs/urbit-king/lib/Urbit/Vere/Ports.hs
View File

@ -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 ()
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
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 addRequest port = do
resp <- newEmptyTMVarIO
atomically $
writeTQueue q (PTMInitialRequestOpen port (putTMVar resp True))
atomically $ takeTMVar resp
pure ()
let removeRequest port = atomically $ writeTQueue q (PTMRequestClose port)
pure $ PortControlApi addRequest removeRequest
portLeaseLifetime :: Word32
portLeaseLifetime = 15 * 60
@ -102,120 +101,120 @@ portThread q stderr = do
stderr $ "port: couldn't find router; assuming on public internet"
loopErr q
Right pmp -> foundRouter pmp
where
foundRouter :: NatPmpHandle -> RIO e ()
foundRouter pmp = do
pubAddr <- getPublicAddress pmp
case pubAddr of
Left _ -> pure ()
Right addr -> do
let (a, b, c, d) = hostAddressToTuple addr
stderr $ "port: router reports that our public IP is " ++ (tshow a) ++
"." ++ (tshow b) ++ "." ++ (tshow c) ++ "." ++ (tshow d)
loop pmp mempty
where
foundRouter :: NatPmpHandle -> RIO e ()
foundRouter pmp = do
pubAddr <- getPublicAddress pmp
case pubAddr of
Left _ -> pure ()
Right addr -> do
let (a, b, c, d) = hostAddressToTuple addr
stderr $ "port: router reports that our public IP is " ++ (tshow a) ++
"." ++ (tshow b) ++ "." ++ (tshow c) ++ "." ++ (tshow d)
loop pmp mempty
loop :: NatPmpHandle -> MinPrioHeap POSIXTime PortThreadMsg -> RIO e ()
loop pmp nextRenew = forever $ do
now <- io $ getPOSIXTime
delay <- case viewHead nextRenew of
Nothing -> newTVarIO False
Just (fireTime, _) -> do
let timeTo = fireTime - now
let ms = round $ timeTo * 1000000
registerDelay ms
command <- atomically $
(Left <$> fini delay) <|> (Right <$> readTQueue q)
case command of
Left () -> do
-- the timeout has fired, meaning the top of the heap should be
-- popped and rerun.
case (Data.Heap.view nextRenew) of
Nothing -> error "Internal heap managing error."
Just ((_, msg), rest) -> handlePTM pmp msg rest
Right msg -> handlePTM pmp msg nextRenew
loop :: NatPmpHandle -> MinPrioHeap POSIXTime PortThreadMsg -> RIO e ()
loop pmp nextRenew = forever $ do
now <- io $ getPOSIXTime
delay <- case viewHead nextRenew of
Nothing -> newTVarIO False
Just (fireTime, _) -> do
let timeTo = fireTime - now
let ms = round $ timeTo * 1000000
registerDelay ms
command <- atomically $
(Left <$> fini delay) <|> (Right <$> readTQueue q)
case command of
Left () -> do
-- the timeout has fired, meaning the top of the heap should be
-- popped and rerun.
case (Data.Heap.view nextRenew) of
Nothing -> error "Internal heap managing error."
Just ((_, msg), rest) -> handlePTM pmp msg rest
Right msg -> handlePTM pmp msg nextRenew
handlePTM :: NatPmpHandle
-> PortThreadMsg
-> MinPrioHeap POSIXTime PortThreadMsg
-> RIO e ()
handlePTM pmp msg nextRenew = case msg of
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
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
now <- io $ getPOSIXTime
let repeatMsg = PTMRequestOpen p
let withRenew =
insert (now + (fromIntegral portRenewalTime), repeatMsg)
filteredPort
atomically notifyComplete
loop pmp withRenew
handlePTM :: NatPmpHandle
-> PortThreadMsg
-> MinPrioHeap POSIXTime PortThreadMsg
-> RIO e ()
handlePTM pmp msg nextRenew = case msg of
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
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
now <- io $ getPOSIXTime
let repeatMsg = PTMRequestOpen p
let withRenew =
insert (now + fromIntegral portRenewalTime, repeatMsg)
filteredPort
atomically notifyComplete
loop pmp withRenew
PTMRequestOpen p -> do
logInfo $
displayShow ("port: sending renewing request to NAT-PMP for port ",
p)
ret <- setPortMapping pmp PTUdp p p portLeaseLifetime
case ret of
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
now <- io $ getPOSIXTime
let withRenew =
insert (now + (fromIntegral portRenewalTime), msg) filteredPort
loop pmp withRenew
PTMRequestOpen p -> do
logInfo $
displayShow ("port: sending renewing request to NAT-PMP for port ",
p)
ret <- setPortMapping pmp PTUdp p p portLeaseLifetime
case ret of
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
now <- io $ getPOSIXTime
let withRenew =
insert (now + (fromIntegral portRenewalTime), msg) filteredPort
loop pmp withRenew
PTMRequestClose p -> do
logInfo $
displayShow ("port: releasing lease for ", p)
setPortMapping pmp PTUdp p p 0
let removed = filterPort p nextRenew
loop pmp removed
PTMRequestClose p -> do
logInfo $
displayShow ("port: releasing lease for ", p)
setPortMapping pmp PTUdp p p 0
let removed = filterPort p nextRenew
loop pmp removed
filterPort :: Word16
-> MinPrioHeap POSIXTime PortThreadMsg
-> MinPrioHeap POSIXTime PortThreadMsg
filterPort p = Data.Heap.filter okPort
where
-- initial requests should never be in the heap
okPort (_, PTMInitialRequestOpen _ _) = False
okPort (_, PTMRequestOpen x) = p /= x
okPort (_, PTMRequestClose x) = p /= x
filterPort :: Word16
-> MinPrioHeap POSIXTime PortThreadMsg
-> MinPrioHeap POSIXTime PortThreadMsg
filterPort p = Data.Heap.filter okPort
where
-- initial requests should never be in the heap
okPort (_, PTMInitialRequestOpen _ _) = False
okPort (_, PTMRequestOpen x) = p /= x
okPort (_, PTMRequestClose x) = p /= x
-- block (retry) until the delay TVar is set to True
fini :: TVar Bool -> STM ()
fini = check <=< readTVar
-- block (retry) until the delay TVar is set to True
fini :: TVar Bool -> STM ()
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
loopErr q = forever $ do
(atomically $ readTQueue q) >>= \case
PTMInitialRequestOpen _ onComplete -> atomically onComplete
PTMRequestOpen _ -> pure ()
PTMRequestClose _ -> pure ()
-- The NAT system is considered "off" but we still need to signal back to
-- the main thread that blocking actions are copmlete
loopErr q = forever $ do
(atomically $ readTQueue 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
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
@ -224,16 +223,14 @@ likelyIPAddress = do
requestPortAccess :: forall e. (HasPortControlApi e) => Word16 -> RAcquire e ()
requestPortAccess port = do
mkRAcquire request release
where
request :: RIO e ()
request = do
env <- ask
let api = env ^. portControlApiL
io $ (pAddPortRequest api) port
where
request :: RIO e ()
request = do
api <- asks (^. portControlApiL)
io $ pAddPortRequest api port
release :: () -> RIO e ()
release _ = do
env <- ask
let api = env ^. portControlApiL
io $ (pRemovePortRequest api) port
release :: () -> RIO e ()
release _ = do
api <- asks (^. portControlApiL)
io $ pRemovePortRequest api port

7
pkg/hs/urbit-king/test/AmesTests.hs
View File

@ -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 -----------------------------------------------------------------------