mirror of
https://github.com/urbit/shrub.git
synced 2024-12-20 17:32:11 +03:00
d39d7246d1
There was a TODO in runShips about how the different layers of the RIO environment had to be changed, so that there was a layer between KingEnv and PierEnv for things shared between individual Piers, but which weren't used outside of any PierEnv. This addresses those TODOs by creating RunningEnv, which for now just owns MultiEyreApi and makes it so we don't have to pass the entire thing around explicitly. The IP handling stuff will go in RunningEnv in a following patch.
366 lines
11 KiB
Haskell
366 lines
11 KiB
Haskell
{-|
|
|
Eyre: Http Server Driver
|
|
-}
|
|
|
|
module Urbit.Vere.Eyre
|
|
( eyre
|
|
, eyre'
|
|
)
|
|
where
|
|
|
|
import Urbit.Prelude hiding (Builder)
|
|
|
|
import Urbit.Arvo hiding (ServerId, reqUrl, secure)
|
|
import Urbit.King.App (HasKingId(..), HasMultiEyreApi(..), HasPierEnv(..))
|
|
import Urbit.King.Config
|
|
import Urbit.Vere.Eyre.Multi
|
|
import Urbit.Vere.Eyre.PortsFile
|
|
import Urbit.Vere.Eyre.Serv
|
|
import Urbit.Vere.Eyre.Service
|
|
import Urbit.Vere.Eyre.Wai
|
|
import Urbit.Vere.Pier.Types
|
|
|
|
import Data.List.NonEmpty (NonEmpty((:|)))
|
|
import Data.PEM (pemParseBS, pemWriteBS)
|
|
import RIO.Prelude (decodeUtf8Lenient)
|
|
import System.Random (randomIO)
|
|
import Urbit.Vere.Http (convertHeaders, unconvertHeaders)
|
|
|
|
import qualified Network.HTTP.Types as H
|
|
|
|
|
|
-- Types -----------------------------------------------------------------------
|
|
|
|
type HasShipEnv e = (HasLogFunc e, HasNetworkConfig e, HasPierConfig e)
|
|
|
|
type ReqId = UD
|
|
|
|
newtype Drv = Drv (MVar (Maybe Serv))
|
|
|
|
data SockOpts = SockOpts
|
|
{ soLocalhost :: Bool
|
|
, soWhich :: ServPort
|
|
}
|
|
|
|
data PortsToTry = PortsToTry
|
|
{ pttSec :: SockOpts
|
|
, pttIns :: SockOpts
|
|
, pttLop :: SockOpts
|
|
}
|
|
|
|
data Serv = Serv
|
|
{ sServId :: ServId
|
|
, sConfig :: HttpServerConf
|
|
, sLop :: ServApi
|
|
, sIns :: ServApi
|
|
, sSec :: Maybe ServApi
|
|
, sPorts :: Ports
|
|
, sPortsFile :: FilePath
|
|
, sLiveReqs :: TVar LiveReqs
|
|
}
|
|
|
|
|
|
-- Utilities for Constructing Events -------------------------------------------
|
|
|
|
servEv :: HttpServerEv -> Ev
|
|
servEv = EvBlip . BlipEvHttpServer
|
|
|
|
bornEv :: KingId -> Ev
|
|
bornEv king = servEv $ HttpServerEvBorn (king, ()) ()
|
|
|
|
liveEv :: ServId -> Ports -> Ev
|
|
liveEv sId Ports {..} = servEv $ HttpServerEvLive (sId, ()) pHttp pHttps
|
|
|
|
cancelEv :: ServId -> ReqId -> EvErr
|
|
cancelEv sId reqId =
|
|
EvErr (servEv (HttpServerEvCancelRequest (sId, reqId, 1, ()) ())) cancelFailed
|
|
|
|
cancelFailed :: WorkError -> IO ()
|
|
cancelFailed _ = pure ()
|
|
|
|
reqEv :: ServId -> ReqId -> WhichServer -> Address -> HttpRequest -> Ev
|
|
reqEv sId reqId which addr req = case which of
|
|
Loopback -> servEv $ HttpServerEvRequestLocal (sId, reqId, 1, ())
|
|
$ HttpServerReq False addr req
|
|
_ -> servEv $ HttpServerEvRequest (sId, reqId, 1, ())
|
|
$ HttpServerReq (which == Secure) addr req
|
|
|
|
|
|
-- Based on Pier+Config, which ports should each server run? -------------------
|
|
|
|
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 (SPChoices $ singleton p)
|
|
(Nothing, False) -> SockOpts local (SPChoices (443 :| [8443 .. 8453]))
|
|
(Nothing, True ) -> SockOpts local (SPChoices (8443 :| [8444 .. 8453]))
|
|
|
|
let pttIns = case (ins, fak) of
|
|
(Just p , _ ) -> SockOpts local (SPChoices $ singleton p)
|
|
(Nothing, False) -> SockOpts local (SPChoices (80 :| [8080 .. 8090]))
|
|
(Nothing, True ) -> SockOpts local (SPChoices (8080 :| [8081 .. 8090]))
|
|
|
|
let pttLop = case (lop, fak) of
|
|
(Just p , _) -> SockOpts local (SPChoices $ singleton p)
|
|
(Nothing, _) -> SockOpts local SPAnyPort
|
|
|
|
pure (PortsToTry { .. })
|
|
|
|
|
|
-- Convert Between Urbit and WAI types. ----------------------------------------
|
|
|
|
parseTlsConfig :: (Key, Cert) -> Maybe TlsConfig
|
|
parseTlsConfig (PEM key, PEM certs) = do
|
|
let (cerByt, keyByt) = (wainBytes certs, wainBytes key)
|
|
pems <- pemParseBS cerByt & either (const Nothing) Just
|
|
(cert, chain) <- case pems of
|
|
[] -> Nothing
|
|
p : ps -> pure (pemWriteBS p, pemWriteBS <$> ps)
|
|
pure $ TlsConfig keyByt cert chain
|
|
where
|
|
wainBytes :: Wain -> ByteString
|
|
wainBytes = encodeUtf8 . unWain
|
|
|
|
parseHttpEvent :: HttpEvent -> [RespAct]
|
|
parseHttpEvent = \case
|
|
Start h b True -> [RAFull (hSta h) (hHdr h) (fByt $ fromMaybe "" b)]
|
|
Start h b False -> [RAHead (hSta h) (hHdr h) (fByt $ fromMaybe "" b)]
|
|
Cancel () -> [RADone]
|
|
Continue b done -> toList (RABloc . fByt <$> b)
|
|
<> if done then [RADone] else []
|
|
where
|
|
hHdr :: ResponseHeader -> [H.Header]
|
|
hHdr = unconvertHeaders . headers
|
|
|
|
hSta :: ResponseHeader -> H.Status
|
|
hSta = toEnum . fromIntegral . statusCode
|
|
|
|
fByt :: File -> ByteString
|
|
fByt = unOcts . unFile
|
|
|
|
requestEvent :: ServId -> WhichServer -> Word64 -> ReqInfo -> Ev
|
|
requestEvent srvId which reqId ReqInfo{..} = reqEv srvId reqUd which riAdr evReq
|
|
where
|
|
evBod = bodFile riBod
|
|
evHdr = convertHeaders riHdr
|
|
evUrl = Cord (decodeUtf8Lenient riUrl)
|
|
evReq = HttpRequest riMet evUrl evHdr evBod
|
|
reqUd = fromIntegral reqId
|
|
|
|
bodFile :: ByteString -> Maybe File
|
|
bodFile "" = Nothing
|
|
bodFile bs = Just $ File $ Octs bs
|
|
|
|
|
|
-- Running Servers -------------------------------------------------------------
|
|
|
|
execRespActs :: HasLogFunc e => Drv -> Ship -> Word64 -> HttpEvent -> RIO e ()
|
|
execRespActs (Drv v) who reqId ev = readMVar v >>= \case
|
|
Nothing -> logError "Got a response to a request that does not exist."
|
|
Just sv -> do
|
|
logDebug $ displayShow ev
|
|
for_ (parseHttpEvent ev) $ \act -> do
|
|
atomically (routeRespAct who (sLiveReqs sv) reqId act)
|
|
|
|
startServ
|
|
:: (HasPierConfig e, HasLogFunc e, HasMultiEyreApi e, HasNetworkConfig e)
|
|
=> Ship
|
|
-> Bool
|
|
-> HttpServerConf
|
|
-> (EvErr -> STM ())
|
|
-> RIO e Serv
|
|
startServ who isFake conf plan = do
|
|
logDebug (displayShow ("EYRE", "startServ"))
|
|
|
|
env <- ask
|
|
let multi = env ^. multiEyreApiL
|
|
|
|
let vLive = meaLive multi
|
|
|
|
srvId <- io $ ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
|
|
|
|
let mTls = hscSecure conf >>= parseTlsConfig
|
|
|
|
mCre <- mTls & \case
|
|
Nothing -> pure Nothing
|
|
Just tc -> configCreds tc & \case
|
|
Right rs -> pure (Just (tc, rs))
|
|
Left err -> do
|
|
logError "Couldn't Load TLS Credentials."
|
|
pure Nothing
|
|
|
|
ptt <- httpServerPorts isFake
|
|
|
|
{-
|
|
TODO If configuration requests a redirect, get the HTTPS port (if
|
|
configuration specifies a specific port, use that. Otherwise, wait
|
|
for the HTTPS server to start and then use the port that it chose).
|
|
and run an HTTP server that simply redirects to the HTTPS server.
|
|
-}
|
|
let secRedi = Nothing
|
|
|
|
let soHost :: SockOpts -> ServHost
|
|
soHost so = if soLocalhost so then SHLocalhost else SHAnyHostOk
|
|
|
|
noHttp <- view (networkConfigL . ncNoHttp)
|
|
noHttps <- view (networkConfigL . ncNoHttps)
|
|
|
|
let reqEvFailed _ = pure ()
|
|
|
|
let onReq :: WhichServer -> Ship -> Word64 -> ReqInfo -> STM ()
|
|
onReq which _ship reqId reqInfo =
|
|
plan $ EvErr (requestEvent srvId which reqId reqInfo) reqEvFailed
|
|
|
|
let onKilReq :: Ship -> Word64 -> STM ()
|
|
onKilReq _ship = plan . cancelEv srvId . fromIntegral
|
|
|
|
logDebug (displayShow ("EYRE", "joinMultiEyre", who, mTls, mCre))
|
|
|
|
atomically (joinMultiEyre multi who mCre onReq onKilReq)
|
|
|
|
logDebug $ displayShow ("EYRE", "Starting loopback server")
|
|
lop <- serv vLive $ ServConf
|
|
{ scHost = soHost (pttLop ptt)
|
|
, scPort = soWhich (pttLop ptt)
|
|
, scRedi = Nothing
|
|
, scFake = False
|
|
, scType = STHttp who $ ReqApi
|
|
{ rcReq = onReq Loopback
|
|
, rcKil = onKilReq
|
|
}
|
|
}
|
|
|
|
logDebug $ displayShow ("EYRE", "Starting insecure server")
|
|
ins <- serv vLive $ ServConf
|
|
{ scHost = soHost (pttIns ptt)
|
|
, scPort = soWhich (pttIns ptt)
|
|
, scRedi = secRedi
|
|
, scFake = noHttp
|
|
, scType = STHttp who $ ReqApi
|
|
{ rcReq = onReq Insecure
|
|
, rcKil = onKilReq
|
|
}
|
|
}
|
|
|
|
mSec <- for mTls $ \tls -> do
|
|
logDebug "Starting secure server"
|
|
serv vLive $ ServConf
|
|
{ scHost = soHost (pttSec ptt)
|
|
, scPort = soWhich (pttSec ptt)
|
|
, scRedi = Nothing
|
|
, scFake = noHttps
|
|
, scType = STHttps who tls $ ReqApi
|
|
{ rcReq = onReq Secure
|
|
, rcKil = onKilReq
|
|
}
|
|
}
|
|
|
|
pierPath <- view pierPathL
|
|
|
|
lopPor <- atomically (fmap fromIntegral $ saPor lop)
|
|
insPor <- atomically (fmap fromIntegral $ saPor ins)
|
|
secPor <- for mSec (fmap fromIntegral . atomically . saPor)
|
|
|
|
let por = Ports secPor insPor lopPor
|
|
fil = pierPath <> "/.http.ports"
|
|
|
|
logDebug $ displayShow ("EYRE", "All Servers Started.", srvId, por, fil)
|
|
|
|
pure (Serv srvId conf lop ins mSec por fil vLive)
|
|
|
|
|
|
-- Eyre Driver -----------------------------------------------------------------
|
|
|
|
_bornFailed :: e -> WorkError -> IO ()
|
|
_bornFailed env _ = runRIO env $ do
|
|
pure () -- TODO What should this do?
|
|
|
|
eyre'
|
|
:: (HasPierEnv e, HasMultiEyreApi e)
|
|
=> Ship
|
|
-> Bool
|
|
-> RIO e ([Ev], RAcquire e (DriverApi HttpServerEf))
|
|
eyre' who isFake = do
|
|
ventQ :: TQueue EvErr <- newTQueueIO
|
|
env <- ask
|
|
|
|
let (bornEvs, startDriver) = eyre env who (writeTQueue ventQ) isFake
|
|
|
|
let runDriver = do
|
|
diOnEffect <- startDriver
|
|
let diEventSource = fmap RRWork <$> tryReadTQueue ventQ
|
|
pure (DriverApi {..})
|
|
|
|
pure (bornEvs, runDriver)
|
|
|
|
{-|
|
|
Eyre -- HTTP Server Driver
|
|
|
|
Inject born events.
|
|
Until born events succeeds, ignore effects.
|
|
Wait until born event callbacks invoked.
|
|
If success, signal success.
|
|
If failure, try again several times.
|
|
If still failure, bring down ship.
|
|
Once born event succeeds:
|
|
- Begin normal operation (start accepting requests)
|
|
-}
|
|
eyre
|
|
:: forall e
|
|
. (HasPierEnv e)
|
|
=> e
|
|
-> Ship
|
|
-> (EvErr -> STM ())
|
|
-> Bool
|
|
-> ([Ev], RAcquire e (HttpServerEf -> IO ()))
|
|
eyre env who plan isFake = (initialEvents, runHttpServer)
|
|
where
|
|
king = fromIntegral (env ^. kingIdL)
|
|
multi = env ^. multiEyreApiL
|
|
|
|
initialEvents :: [Ev]
|
|
initialEvents = [bornEv king]
|
|
|
|
runHttpServer :: RAcquire e (HttpServerEf -> IO ())
|
|
runHttpServer = handleEf <$> mkRAcquire
|
|
(Drv <$> newMVar Nothing)
|
|
(\(Drv v) -> stopService v kill >>= fromEither)
|
|
|
|
kill :: HasLogFunc e => Serv -> RIO e ()
|
|
kill Serv{..} = do
|
|
atomically (leaveMultiEyre multi who)
|
|
atomically (saKil sLop)
|
|
atomically (saKil sIns)
|
|
for_ sSec (\sec -> atomically (saKil sec))
|
|
io (removePortsFile sPortsFile)
|
|
|
|
restart :: Drv -> HttpServerConf -> RIO e Serv
|
|
restart (Drv var) conf = do
|
|
logDebug "Restarting http server"
|
|
let startAct = startServ who isFake conf plan
|
|
res <- fromEither =<< restartService var startAct kill
|
|
logDebug "Done restating http server"
|
|
pure res
|
|
|
|
liveFailed _ = pure ()
|
|
|
|
handleEf :: Drv -> HttpServerEf -> IO ()
|
|
handleEf drv = runRIO env . \case
|
|
HSESetConfig (i, ()) conf -> do
|
|
logDebug (displayShow ("EYRE", "%set-config"))
|
|
Serv {..} <- restart drv conf
|
|
logDebug (displayShow ("EYRE", "%set-config", "Sending %live"))
|
|
atomically $ plan (EvErr (liveEv sServId sPorts) liveFailed)
|
|
logDebug "Write ports file"
|
|
io (writePortsFile sPortsFile sPorts)
|
|
HSEResponse (i, req, _seq, ()) ev -> do
|
|
logDebug (displayShow ("EYRE", "%response"))
|
|
execRespActs drv who (fromIntegral req) ev
|