urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-11-28 13:54:20 +03:00
Code Issues Packages Projects Releases Wiki Activity

king: Add command-line flags to configure HTTP and HTTPS ports.

Browse Source
This commit is contained in:
Benjamin Summers 2020-03-02 15:24:28 -08:00
parent d72bddd66d
commit 2dc97293cc
6 changed files with 179 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -16,18 +16,21 @@ import System.Environment (getProgName)
--------------------------------------------------------------------------------
data Opts = Opts
{ oQuiet :: Bool
, oHashless :: Bool
, oExit :: Bool
, oDryRun :: Bool
, oDryFrom :: Maybe Word64
, oVerbose :: Bool
, oAmesPort :: Maybe Word16
, oTrace :: Bool
, oCollectFx :: Bool
, oLocalhost :: Bool
, oOffline :: Bool
, oFullReplay :: Bool
{ oQuiet :: Bool
, oHashless :: Bool
, oExit :: Bool
, oDryRun :: Bool
, oDryFrom :: Maybe Word64
, oVerbose :: Bool
, oAmesPort :: Maybe Word16
, oTrace :: Bool
, oCollectFx :: Bool
, oLocalhost :: Bool
, oOffline :: Bool
, oFullReplay :: Bool
, oHttpPort :: Maybe Word16
, oHttpsPort :: Maybe Word16
, oLoopbackPort :: Maybe Word16
}
deriving (Show)
@ -212,8 +215,28 @@ opts = do
oAmesPort <- optional $ option auto $ metavar "PORT"
<> short 'p'
<> long "ames"
<> help "Ames port number"
<> hidden
<> help "Ames port"
oHttpPort <-
optional
$ option auto
$ metavar "PORT"
<> long "http-port"
<> help "HTTP Server port"
oHttpsPort <-
optional
$ option auto
$ metavar "PORT"
<> long "https-port"
<> help "HTTPS server port"
oLoopbackPort <-
optional
$ option auto
$ metavar "PORT"
<> long "loopback-port"
<> help "Localhost-only HTTP server port"
-- Always disable hashboard. Right now, urbit is almost unusable with this
-- flag enabled and it is disabled in vere.

30
pkg/hs/urbit-king/lib/Urbit/King/Config.hs
View File

@ -27,27 +27,21 @@ dryRunL = pierConfigL . pcDryRun
-------------------------------------------------------------------------------
data NetworkingType
= NetworkNone
| NetworkNormal
| NetworkLocalhost
deriving (Show)
data NetMode
= NMNone
| NMLocalhost
| NMNormal
deriving (Eq, Ord, Show)
data NetworkConfig = NetworkConfig
{ ncNetworking :: NetworkingType
, ncAmesPort :: Maybe Word16
{ _ncNetMode :: NetMode
, _ncAmesPort :: Maybe Word16
, _ncHttpPort :: Maybe Word16
, _ncHttpsPort :: Maybe Word16
, _ncLocalPort :: Maybe Word16
} deriving (Show)
makeLenses ''NetworkConfig
class HasNetworkConfig env where
networkConfigL :: Lens' env NetworkConfig
getNetworkingType :: (MonadReader env m, HasNetworkConfig env)
=> m NetworkingType
getNetworkingType = do
NetworkConfig{..} <- view networkConfigL
pure ncNetworking
getAmesPort :: (MonadReader env m, HasNetworkConfig env) => m (Maybe Word16)
getAmesPort = do
NetworkConfig{..} <- view networkConfigL
pure ncAmesPort

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

@ -121,19 +121,28 @@ toSerfFlags CLI.Opts{..} = catMaybes m
toPierConfig :: FilePath -> CLI.Opts -> PierConfig
toPierConfig pierPath CLI.Opts{..} = PierConfig
{ _pcPierPath = pierPath
, _pcDryRun = (oDryRun || isJust oDryFrom)
}
toPierConfig pierPath CLI.Opts {..} = PierConfig { .. }
where
_pcPierPath = pierPath
_pcDryRun = oDryRun || isJust oDryFrom
toNetworkConfig :: CLI.Opts -> NetworkConfig
toNetworkConfig CLI.Opts{..} = NetworkConfig
{ ncNetworking = if (oDryRun || isJust oDryFrom) then NetworkNone
else if oOffline then NetworkNone
else if oLocalhost then NetworkLocalhost
else NetworkNormal
, ncAmesPort = oAmesPort
}
toNetworkConfig CLI.Opts {..} = NetworkConfig { .. }
where
dryRun = oDryRun || isJust oDryFrom
offline = dryRun || oOffline
mode = case (dryRun, offline, oLocalhost) of
(True, _ , _ ) -> NMNone
(_ , True, _ ) -> NMNone
(_ , _ , True) -> NMLocalhost
(_ , _ , _ ) -> NMNormal
_ncNetMode = mode
_ncAmesPort = oAmesPort
_ncHttpPort = oHttpPort
_ncHttpsPort = oHttpsPort
_ncLocalPort = oLoopbackPort
tryBootFromPill :: ( HasLogFunc e, HasNetworkConfig e, HasPierConfig e
, HasConfigDir e, HasStderrLogFunc e

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

@ -124,10 +124,10 @@ ames inst who isFake enqueueEv stderr =
netMode = do
if isFake
then pure Fake
else getNetworkingType >>= \case
NetworkNormal -> pure Real
NetworkLocalhost -> pure Localhost
NetworkNone -> pure NoNetwork
else view (networkConfigL . ncNetMode) >>= \case
NMNormal -> pure Real
NMLocalhost -> pure Localhost
NMNone -> pure NoNetwork
stop :: AmesDrv -> RIO e ()
stop AmesDrv{..} = do
@ -151,7 +151,7 @@ ames inst who isFake enqueueEv stderr =
doBindSocket Nothing = pure Nothing
doBindSocket (Just bindAddr) = do
mode <- netMode
mPort <- getAmesPort
mPort <- view (networkConfigL . ncAmesPort)
let ourPort = maybe (listenPort mode who) fromIntegral mPort
s <- io $ socket AF_INET Datagram defaultProtocol

140
pkg/hs/urbit-king/lib/Urbit/Vere/Http/Server.hs
View File

@ -48,6 +48,8 @@ import qualified Network.Wai.Handler.WarpTLS as W
-- Internal Types --------------------------------------------------------------
type HasShipEnv e = (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
type ReqId = UD
type SeqId = UD -- Unused, always 1
@ -387,6 +389,24 @@ app env sId liv plan which req respond =
-- Top-Level Driver Interface --------------------------------------------------
data CantOpenPort = CantOpenPort W.Port
deriving (Eq, Ord, Show, Exception)
data WhichPort
= WPSpecific W.Port
| WPChoices [W.Port]
data SockOpts = SockOpts
{ soLocalhost :: Bool
, soWhich :: WhichPort
}
data PortsToTry = PortsToTry
{ pttSec :: SockOpts
, pttIns :: SockOpts
, pttLop :: SockOpts
}
{-|
Opens a socket on some port, accepting connections from `127.0.0.1`
if fake and `0.0.0.0` if real.
@ -396,41 +416,90 @@ app env sId liv plan which req respond =
us an open socket on *any* open port. If that fails, it will throw
an exception.
-}
openPort :: HasLogFunc e => Bool -> [W.Port] -> RIO e (W.Port, Net.Socket)
openPort isFake = go
where
go = \case
[] -> io W.openFreePort
x:xs -> io (tryOpen x) >>= \case
Left (err∷IOError) -> do
logWarn (display ("Failed to open port " <> tshow x))
logWarn (display (tshow err))
go xs
Right ps -> do
logTrace (display ("Opening port " <> tshow (fst ps)))
pure ps
openPort :: forall e . HasLogFunc e => SockOpts -> RIO e (W.Port, Net.Socket)
openPort SockOpts {..} = case soWhich of
WPSpecific x -> insist (fromIntegral x)
WPChoices xs -> loop (fromIntegral <$> xs)
bindTo = if isFake then "127.0.0.1" else "0.0.0.0"
where
loop :: [W.Port] -> RIO e (W.Port, Net.Socket)
loop = \case
[] -> do
logTrace "Fallback: asking the OS to give us some free port."
ps <- io W.openFreePort
logTrace (display ("Opened port " <> tshow (fst ps)))
pure ps
x : xs -> do
logTrace (display ("Trying to open port " <> tshow x))
io (tryOpen x) >>= \case
Left (err :: IOError) -> do
logWarn (display ("Failed to open port " <> tshow x))
logWarn (display (tshow err))
loop xs
Right ps -> do
logTrace (display ("Opened port " <> tshow (fst ps)))
pure ps
bindListenPort ∷ W.Port → Net.Socket → IO Net.PortNumber
bindListenPort por sok = do
bindAddr <- Net.getAddrInfo Nothing (Just bindTo) Nothing >>= \case
[] -> error "this should never happen."
x:_ -> pure (Net.addrAddress x)
insist :: W.Port -> RIO e (W.Port, Net.Socket)
insist p = do
logTrace (display ("Opening configured port " <> tshow p))
io (tryOpen p) >>= \case
Left (err :: IOError) -> do
logWarn (display ("Failed to open port " <> tshow p))
logWarn (display (tshow err))
throwIO (CantOpenPort p)
Right ps -> do
logTrace (display ("Opened port " <> tshow (fst ps)))
pure ps
Net.bind sok bindAddr
Net.listen sok 1
Net.socketPort sok
bindTo = if soLocalhost then "127.0.0.1" else "0.0.0.0"
-- `inet_addr`, `bind`, and `listen` all throw `IOError` if they fail.
tryOpen ∷ W.Port → IO (Either IOError (W.Port, Net.Socket))
tryOpen por = do
sok <- Net.socket Net.AF_INET Net.Stream Net.defaultProtocol
try (bindListenPort por sok) >>= \case
Left exn -> Net.close sok $> Left exn
Right por -> pure (Right (fromIntegral por, sok))
getBindAddr :: W.Port -> IO SockAddr
getBindAddr por =
Net.getAddrInfo Nothing (Just bindTo) (Just (show por)) >>= \case
[] -> error "this should never happen."
x : _ -> pure (Net.addrAddress x)
startServ :: (HasPierConfig e, HasLogFunc e)
bindListenPort :: W.Port -> Net.Socket -> IO Net.PortNumber
bindListenPort por sok = do
Net.bind sok =<< getBindAddr por
Net.listen sok 1
Net.socketPort sok
-- `inet_addr`, `bind`, and `listen` all throw `IOError` if they fail.
tryOpen :: W.Port -> IO (Either IOError (W.Port, Net.Socket))
tryOpen por = do
sok <- Net.socket Net.AF_INET Net.Stream Net.defaultProtocol
try (bindListenPort por sok) >>= \case
Left exn -> Net.close sok $> Left exn
Right por -> pure (Right (fromIntegral por, sok))
httpServerPorts :: HasShipEnv e => Bool -> RIO e PortsToTry
httpServerPorts fak = do
ins <- view (networkConfigL . ncHttpPort . to (fmap fromIntegral))
sec <- view (networkConfigL . ncHttpsPort . to (fmap fromIntegral))
lop <- view (networkConfigL . ncLocalPort . to (fmap fromIntegral))
localMode <- view (networkConfigL . ncNetMode . to (== NMLocalhost))
let local = localMode || fak
let pttSec = case (sec, fak) of
(Just p , _ ) -> SockOpts local (WPSpecific p)
(Nothing, False) -> SockOpts local (WPChoices (443 : [8443 .. 8448]))
(Nothing, True ) -> SockOpts local (WPChoices ([8443 .. 8448]))
let pttIns = case (ins, fak) of
(Just p , _ ) -> SockOpts local (WPSpecific p)
(Nothing, False) -> SockOpts local (WPChoices (80 : [8080 .. 8085]))
(Nothing, True ) -> SockOpts local (WPChoices [8080 .. 8085])
let pttLop = case (lop, fak) of
(Just p , _) -> SockOpts local (WPSpecific p)
(Nothing, _) -> SockOpts local (WPChoices [12321 .. 12326])
pure (PortsToTry { .. })
startServ :: (HasPierConfig e, HasLogFunc e, HasNetworkConfig e)
=> Bool -> HttpServerConf -> (Ev -> STM ())
-> RIO e Serv
startServ isFake conf plan = do
@ -442,12 +511,11 @@ startServ isFake conf plan = do
sId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
liv <- newTVarIO emptyLiveReqs
let insPor = if isFake then [8080..8085] else (80 : [8080..8085])
secPor = if isFake then [8443..8448] else (443 : [8443..8448])
ptt <- httpServerPorts isFake
(httpPortInt, httpSock) <- openPort isFake insPor
(httpsPortInt, httpsSock) <- openPort isFake secPor
(loopPortInt, loopSock) <- openPort isFake [12321..12326]
(httpPortInt, httpSock) <- openPort (pttIns ptt)
(httpsPortInt, httpsSock) <- openPort (pttSec ptt)
(loopPortInt, loopSock) <- openPort (pttLop ptt)
let httpPort = Port (fromIntegral httpPortInt)
httpsPort = Port (fromIntegral httpsPortInt)
@ -517,7 +585,7 @@ respond (Drv v) reqId ev = do
for_ (reorgHttpEvent ev) $
atomically . respondToLiveReq (sLiveReqs sv) reqId
serv :: ∀e. (HasPierConfig e, HasLogFunc e)
serv :: ∀e. HasShipEnv e
=> KingId -> QueueEv -> Bool
-> ([Ev], RAcquire e (EffCb e HttpServerEf))
serv king plan isFake =

1
pkg/hs/urbit-king/package.yaml
View File

@ -113,6 +113,7 @@ default-extensions:
- ApplicativeDo
- BangPatterns
- BlockArguments
- ConstraintKinds
- DataKinds
- DefaultSignatures
- DeriveAnyClass