2020-08-06 18:37:04 +03:00
|
|
|
module Urbit.Vere.Ports (HasPortControlApi(..),
|
2020-08-13 18:49:38 +03:00
|
|
|
PortControlApi,
|
2020-08-06 18:37:04 +03:00
|
|
|
buildInactivePorts,
|
|
|
|
buildNATPorts,
|
|
|
|
requestPortAccess) where
|
2020-08-05 22:33:37 +03:00
|
|
|
|
|
|
|
import Control.Monad.STM (check)
|
|
|
|
import Urbit.Prelude
|
2020-08-13 17:08:02 +03:00
|
|
|
import Network.NatPmp
|
2020-08-05 22:33:37 +03:00
|
|
|
import Data.Time.Clock.POSIX
|
|
|
|
import Data.Heap
|
2020-08-10 20:02:13 +03:00
|
|
|
import Network.Socket
|
2020-08-05 22:33:37 +03:00
|
|
|
|
|
|
|
-- This module deals with ports and port requests. When a component wants to
|
|
|
|
-- ensure that it is externally reachable, possibly from outside a NAT, it
|
|
|
|
-- makes a request to this module to hole-punch.
|
|
|
|
|
|
|
|
class HasPortControlApi a where
|
|
|
|
portControlApiL :: Lens' a PortControlApi
|
|
|
|
|
|
|
|
data PortControlApi = PortControlApi
|
|
|
|
{ pAddPortRequest :: Word16 -> IO ()
|
|
|
|
, pRemovePortRequest :: Word16 -> IO ()
|
|
|
|
}
|
|
|
|
|
2020-08-13 18:12:26 +03:00
|
|
|
-- | Builds a PortControlApi struct which does nothing when called.
|
2020-08-07 20:04:57 +03:00
|
|
|
buildInactivePorts :: PortControlApi
|
|
|
|
buildInactivePorts = PortControlApi noop noop
|
2020-08-13 18:12:26 +03:00
|
|
|
where
|
|
|
|
noop x = pure ()
|
2020-08-05 22:33:37 +03:00
|
|
|
|
2020-08-13 18:12:26 +03:00
|
|
|
-- | Builds a PortControlApi struct which tries to hole-punch by talking to the
|
|
|
|
-- NAT gateway over NAT-PMP.
|
2020-08-10 20:02:13 +03:00
|
|
|
buildNATPorts :: (HasLogFunc e)
|
|
|
|
=> (Text -> RIO e ())
|
|
|
|
-> RIO e PortControlApi
|
|
|
|
buildNATPorts stderr = do
|
2020-08-05 22:33:37 +03:00
|
|
|
q <- newTQueueIO
|
2020-08-10 20:02:13 +03:00
|
|
|
async $ portThread q stderr
|
2020-08-13 18:12:26 +03:00
|
|
|
|
|
|
|
let addRequest port = do
|
|
|
|
resp <- newEmptyTMVarIO
|
|
|
|
atomically $
|
2020-08-13 20:36:20 +03:00
|
|
|
writeTQueue q (PTMRequestOpen port (putTMVar resp True))
|
2020-08-13 18:12:26 +03:00
|
|
|
atomically $ takeTMVar resp
|
|
|
|
pure ()
|
|
|
|
|
|
|
|
let removeRequest port = atomically $ writeTQueue q (PTMRequestClose port)
|
|
|
|
|
|
|
|
pure $ PortControlApi addRequest removeRequest
|
2020-08-05 22:33:37 +03:00
|
|
|
|
|
|
|
portLeaseLifetime :: Word32
|
|
|
|
portLeaseLifetime = 15 * 60
|
|
|
|
|
|
|
|
-- Be paranoid and renew leases a full minute before they would naturally expire.
|
|
|
|
portRenewalTime :: Word32
|
|
|
|
portRenewalTime = portLeaseLifetime - 60
|
|
|
|
|
|
|
|
-- Messages sent from the main thread to the port mapping communication thread.
|
|
|
|
data PortThreadMsg
|
2020-08-13 20:36:20 +03:00
|
|
|
= PTMRequestOpen Word16 (STM ())
|
2020-08-05 22:33:37 +03:00
|
|
|
-- ^ Does the open request, and then calls the passed in stm action to
|
|
|
|
-- singal completion to the main thread. We want to block on the initial
|
|
|
|
-- setting opening because we want the forwarding set up before we actually
|
|
|
|
-- start using the port.
|
|
|
|
|
|
|
|
| PTMRequestClose Word16
|
|
|
|
-- ^ Close command. No synchronization because there's nothing we can do if
|
|
|
|
-- it fails.
|
|
|
|
|
2020-08-13 20:36:20 +03:00
|
|
|
-- We get requests to acquire a port as an RAII condition, but the actual APIs
|
|
|
|
-- are timeout based, so we have to maintain a heap of the next timer to
|
|
|
|
-- rerequest port access.
|
|
|
|
data RenewAction = RenewAction Word16
|
|
|
|
|
2020-08-05 22:33:37 +03:00
|
|
|
-- The port thread is an async which reads commands from an STM queue and then
|
|
|
|
-- executes them. This thread is here to bind the semantics that we want to how
|
|
|
|
-- NAT-PMP sees the world. We want for an RAcquire to be able to start a
|
|
|
|
-- request for port forwarding and then to release it when it goes out of
|
|
|
|
-- 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.
|
2020-08-06 18:37:04 +03:00
|
|
|
portThread :: forall e. (HasLogFunc e)
|
|
|
|
=> TQueue PortThreadMsg
|
2020-08-10 20:02:13 +03:00
|
|
|
-> (Text -> RIO e ())
|
2020-08-06 18:37:04 +03:00
|
|
|
-> RIO e ()
|
2020-08-10 20:02:13 +03:00
|
|
|
portThread q stderr = do
|
2020-08-13 18:49:38 +03:00
|
|
|
initNatPmp >>= \case
|
2020-08-05 22:33:37 +03:00
|
|
|
Left err -> do
|
2020-08-13 18:49:38 +03:00
|
|
|
likelyIPAddress >>= \case
|
2020-08-10 20:02:13 +03:00
|
|
|
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 " ++
|
|
|
|
"we could not request port forwarding (NAT-PMP error: " ++
|
|
|
|
(tshow err) ++ ")"
|
|
|
|
stderr $ "port: urbit performance will be degregaded unless you " ++
|
|
|
|
"manually forward your ames port."
|
|
|
|
loopErr q
|
|
|
|
_ -> do
|
|
|
|
stderr $ "port: couldn't find router; assuming on public internet"
|
|
|
|
loopErr q
|
|
|
|
Right pmp -> foundRouter pmp
|
2020-08-13 18:12:26 +03:00
|
|
|
where
|
|
|
|
foundRouter :: NatPmpHandle -> RIO e ()
|
|
|
|
foundRouter pmp = do
|
2020-08-13 18:49:38 +03:00
|
|
|
getPublicAddress pmp >>= \case
|
2020-08-13 18:12:26 +03:00
|
|
|
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
|
|
|
|
|
2020-08-13 20:36:20 +03:00
|
|
|
loop :: NatPmpHandle -> MinPrioHeap POSIXTime RenewAction -> RIO e ()
|
2020-08-13 18:49:38 +03:00
|
|
|
loop pmp nextRenew = do
|
2020-08-13 18:12:26 +03:00
|
|
|
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
|
2020-08-13 20:36:20 +03:00
|
|
|
Left () -> handleRenew pmp nextRenew
|
2020-08-13 18:12:26 +03:00
|
|
|
Right msg -> handlePTM pmp msg nextRenew
|
|
|
|
|
|
|
|
handlePTM :: NatPmpHandle
|
|
|
|
-> PortThreadMsg
|
2020-08-13 20:36:20 +03:00
|
|
|
-> MinPrioHeap POSIXTime RenewAction
|
2020-08-13 18:12:26 +03:00
|
|
|
-> RIO e ()
|
|
|
|
handlePTM pmp msg nextRenew = case msg of
|
2020-08-13 20:36:20 +03:00
|
|
|
PTMRequestOpen p notifyComplete -> do
|
2020-08-13 18:12:26 +03:00
|
|
|
logInfo $
|
|
|
|
displayShow ("port: sending initial request to NAT-PMP for port ", p)
|
2020-08-13 18:49:38 +03:00
|
|
|
setPortMapping pmp PTUdp p p portLeaseLifetime >>= \case
|
2020-08-13 18:12:26 +03:00
|
|
|
Left err -> do
|
|
|
|
logError $
|
|
|
|
displayShow ("port: failed to request NAT-PMP for port ", p,
|
|
|
|
":", err, ", disabling NAT-PMP")
|
|
|
|
loopErr q
|
|
|
|
Right _ -> do
|
2020-08-13 20:36:20 +03:00
|
|
|
-- Filter any existing references to this port on the heap to ensure
|
|
|
|
-- we don't double up on tasks.
|
2020-08-13 18:49:38 +03:00
|
|
|
let filteredHeap = filterPort p nextRenew
|
2020-08-13 18:12:26 +03:00
|
|
|
now <- io $ getPOSIXTime
|
|
|
|
let withRenew =
|
2020-08-13 20:36:20 +03:00
|
|
|
insert (now + fromIntegral portRenewalTime, RenewAction p)
|
2020-08-13 18:49:38 +03:00
|
|
|
filteredHeap
|
2020-08-13 18:12:26 +03:00
|
|
|
atomically notifyComplete
|
|
|
|
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
|
|
|
|
|
2020-08-13 20:36:20 +03:00
|
|
|
handleRenew :: NatPmpHandle
|
|
|
|
-> MinPrioHeap POSIXTime RenewAction
|
|
|
|
-> RIO e ()
|
|
|
|
handleRenew pmp nextRenew = do
|
|
|
|
case (Data.Heap.view nextRenew) of
|
|
|
|
Nothing -> error "Internal heap managing error."
|
|
|
|
Just ((_, RenewAction p), rest) -> do
|
|
|
|
logInfo $
|
|
|
|
displayShow ("port: sending renewing request to NAT-PMP for port ",
|
|
|
|
p)
|
|
|
|
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
|
|
|
|
-- We don't need to filter the port because we just did.
|
|
|
|
now <- io $ getPOSIXTime
|
|
|
|
let withRenew =
|
|
|
|
insert (now + (fromIntegral portRenewalTime), RenewAction p)
|
|
|
|
rest
|
|
|
|
loop pmp withRenew
|
|
|
|
|
2020-08-13 18:12:26 +03:00
|
|
|
filterPort :: Word16
|
2020-08-13 20:36:20 +03:00
|
|
|
-> MinPrioHeap POSIXTime RenewAction
|
|
|
|
-> MinPrioHeap POSIXTime RenewAction
|
2020-08-13 18:12:26 +03:00
|
|
|
filterPort p = Data.Heap.filter okPort
|
|
|
|
where
|
2020-08-13 20:36:20 +03:00
|
|
|
okPort (_, RenewAction x) = p /= x
|
2020-08-13 18:12:26 +03:00
|
|
|
|
|
|
|
-- 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
|
2020-08-13 18:49:38 +03:00
|
|
|
-- the main thread that blocking actions are complete.
|
2020-08-13 18:12:26 +03:00
|
|
|
loopErr q = forever $ do
|
2020-08-13 20:36:20 +03:00
|
|
|
(atomically $ readTQueue q) >>= \case
|
|
|
|
PTMRequestOpen _ onComplete -> atomically onComplete
|
2020-08-13 18:12:26 +03:00
|
|
|
PTMRequestClose _ -> pure ()
|
2020-08-05 22:33:37 +03:00
|
|
|
|
2020-08-10 20:02:13 +03:00
|
|
|
-- When we were unable to connect to a router, get the ip address on the
|
2020-08-13 18:49:38 +03:00
|
|
|
-- default ipv4 interface to check if we look like we're on an internal network
|
|
|
|
-- or not.
|
2020-08-13 18:12:26 +03:00
|
|
|
likelyIPAddress :: MonadIO m => m (Maybe (Word8, Word8, Word8, Word8))
|
|
|
|
likelyIPAddress = liftIO do
|
2020-08-10 20:02:13 +03:00
|
|
|
-- 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.
|
2020-08-13 18:12:26 +03:00
|
|
|
sock <- socket AF_INET Datagram 0
|
2020-08-13 18:49:38 +03:00
|
|
|
connect sock (SockAddrInet 53 (tupleToHostAddress (1, 1, 1, 1)))
|
2020-08-13 18:12:26 +03:00
|
|
|
sockAddr <- getSocketName sock
|
2020-08-10 20:02:13 +03:00
|
|
|
case sockAddr of
|
|
|
|
SockAddrInet _ addr -> pure $ Just $ hostAddressToTuple addr
|
|
|
|
_ -> pure $ Nothing
|
|
|
|
|
2020-08-05 22:33:37 +03:00
|
|
|
-- Acquire a port for the duration of the RAcquire.
|
|
|
|
requestPortAccess :: forall e. (HasPortControlApi e) => Word16 -> RAcquire e ()
|
|
|
|
requestPortAccess port = do
|
|
|
|
mkRAcquire request release
|
2020-08-13 18:12:26 +03:00
|
|
|
where
|
|
|
|
request :: RIO e ()
|
|
|
|
request = do
|
|
|
|
api <- asks (^. portControlApiL)
|
|
|
|
io $ pAddPortRequest api port
|
|
|
|
|
|
|
|
release :: () -> RIO e ()
|
|
|
|
release _ = do
|
|
|
|
api <- asks (^. portControlApiL)
|
|
|
|
io $ pRemovePortRequest api port
|
2020-08-05 22:33:37 +03:00
|
|
|
|