shrub/pkg/hs/urbit-king/lib/Urbit/Vere/Eyre/Serv.hs

{-|
  Runs a single HTTP (or HTTPS) server for the eyre driver.

  A server is given:

  - A port, or a range or ports.
  - Opens a socket on one of those ports.
  - If this fails, try again repeatedly.
  - Once a socket is opened, runs an HTTP server on the specified port.
  - Once the server is up, calls a callback with the port that was opened.
  - Once we have chosen a port, we commit to that port (ignoring the
    original range).
  - If the socket ever goes down, keep trying to reopen that port forever.
  - When the server is shutdown, make sure the socket is closed.

  TODO How to detect socket closed during server run?
-}

{-# OPTIONS_GHC -Wno-deprecations #-}

module Urbit.Vere.Eyre.Serv
  ( ServApi(..)
  , TlsConfig(..)
  , MultiTlsConfig(..)
  , ReqApi(..)
  , ServType(..)
  , ServPort(..)
  , ServHost(..)
  , ServConf(..)
  , configCreds
  , serv
  , fakeServ
  )
where

import Urbit.Prelude hiding (Builder)

import Data.Default       (def)
import Data.List.NonEmpty (NonEmpty((:|)))
import Network.TLS        (Credential, Credentials(..), ServerHooks(..))
import Network.TLS        (credentialLoadX509ChainFromMemory)
import RIO.Prelude        (decodeUtf8Lenient)

import qualified Control.Monad.STM           as STM
import qualified Data.Char                   as C
import qualified Network.Socket              as Net
import qualified Network.Wai                 as W
import qualified Network.Wai.Handler.Warp    as W
import qualified Network.Wai.Handler.WarpTLS as W
import qualified Urbit.Ob                    as Ob
import qualified Urbit.Vere.Eyre.Wai         as E


-- Internal Types --------------------------------------------------------------

data ServApi = ServApi
  { saKil :: STM ()
  , saPor :: STM W.Port
  }

data TlsConfig = TlsConfig
  { tcPrKey :: ByteString
  , tcCerti :: ByteString
  , tcChain :: [ByteString]
  }
 deriving (Show)

newtype MultiTlsConfig = MTC (TVar (Map Ship (TlsConfig, Credential)))

instance Show MultiTlsConfig where
  show = const "MultiTlsConfig"

data ReqApi = ReqApi
  { rcReq :: Ship -> Word64 -> E.ReqInfo -> STM ()
  , rcKil :: Ship -> Word64 -> STM ()
  }

instance Show ReqApi where
  show = const "ReqApi"

data ServType
  = STHttp Ship ReqApi
  | STHttps Ship TlsConfig ReqApi
  | STMultiHttp ReqApi
  | STMultiHttps MultiTlsConfig ReqApi
 deriving (Show)

data ServPort
  = SPAnyPort
  | SPChoices (NonEmpty W.Port)
 deriving (Show)

data ServHost
  = SHLocalhost
  | SHAnyHostOk
 deriving (Show)

data ServConf = ServConf
  { scType :: ServType
  , scHost :: ServHost
  , scPort :: ServPort
  , scRedi :: Maybe W.Port
  , scFake :: Bool
  }
 deriving (Show)


-- Opening Sockets -------------------------------------------------------------

getBindAddr :: String -> W.Port -> IO Net.SockAddr
getBindAddr hos por =
  Net.getAddrInfo Nothing (Just hos) (Just (show por)) >>= \case
    []    -> error "this should never happen."
    x : _ -> pure (Net.addrAddress x)

bindListenPort :: String -> W.Port -> Net.Socket -> IO Net.PortNumber
bindListenPort hos por sok = do
  Net.bind sok =<< getBindAddr hos por
  Net.listen sok 1
  Net.socketPort sok

tcpSocket :: IO (Either IOError Net.Socket)
tcpSocket =
  tryIOError (Net.socket Net.AF_INET Net.Stream Net.defaultProtocol)

tryOpen :: String -> W.Port -> IO (Either IOError (W.Port, Net.Socket))
tryOpen hos por =
  tcpSocket >>= \case
    Left  exn -> pure (Left exn)
    Right sok -> tryIOError (bindListenPort hos por sok) >>= \case
      Left  exn -> Net.close sok $> Left exn
      Right por -> pure (Right (fromIntegral por, sok))

openFreePort :: String -> IO (Either IOError (W.Port, Net.Socket))
openFreePort hos = do
  tcpSocket >>= \case
    Left exn -> pure (Left exn)
    Right sok -> tryIOError (doBind sok) >>= \case
      Left exn -> Net.close sok $> Left exn
      Right ps -> pure (Right ps)
 where
  doBind sok = do
    adr <- Net.inet_addr hos
    Net.bind sok (Net.SockAddrInet Net.defaultPort adr)
    Net.listen sok 1
    port <- Net.socketPort sok
    pure (fromIntegral port, sok)

retry :: HasLogFunc e => RIO e (Either IOError a) -> RIO e a
retry act = act >>= \case
  Right res -> pure res
  Left  exn -> do
    logDbg ctx ("Failed to open ports. Waiting 5s, then trying again.", exn)
    threadDelay 5_000_000
    retry act
 where
  ctx = ["EYRE", "SERV", "retry"]

tryOpenChoices
  :: HasLogFunc e
  => String
  -> NonEmpty W.Port
  -> RIO e (Either IOError (W.Port, Net.Socket))
tryOpenChoices hos = go
 where
  go (p :| ps) = do
    logDebug (displayShow ("EYRE", "Trying to open port.", p))
    io (tryOpen hos p) >>= \case
      Left err -> do
        logError (displayShow ("EYRE", "Failed to open port.", p))
        case ps of
          []     -> pure (Left err)
          q : qs -> go (q :| qs)
      Right (p, s) -> do
        pure (Right (p, s))

tryOpenAny
  :: HasLogFunc e => String -> RIO e (Either IOError (W.Port, Net.Socket))
tryOpenAny hos = do
  let ctx = ["EYRE", "SERV", "tryOpenAny"]
  logDbg ctx "Asking the OS for any free port."
  io (openFreePort hos) >>= \case
    Left  exn    -> pure (Left exn)
    Right (p, s) -> do
      pure (Right (p, s))

logDbg :: (HasLogFunc e, Show a) => [Text] -> a -> RIO e ()
logDbg ctx msg = logDebug (prefix <> suffix)
 where
  prefix = display (concat $ fmap (<> ": ") ctx)
  suffix = displayShow msg

forceOpenSocket
  :: forall e
   . HasLogFunc e
  => ServHost
  -> ServPort
  -> RAcquire e (W.Port, Net.Socket)
forceOpenSocket hos por = mkRAcquire opn kil
 where
  kil = io . Net.close . snd

  opn = do
    let ctx = ["EYRE", "SERV", "forceOpenSocket"]
    logDbg ctx (hos, por)
    (p, s) <- retry $ case por of
      SPAnyPort    -> tryOpenAny bind
      SPChoices ps -> tryOpenChoices bind ps
    logDbg ctx ("Opened port.", p)
    pure (p, s)

  bind = case hos of
    SHLocalhost -> "127.0.0.1"
    SHAnyHostOk -> "0.0.0.0"


-- Starting WAI ----------------------------------------------------------------

hostShip :: Maybe ByteString -> IO Ship
hostShip Nothing   = error "Request must contain HOST header."
hostShip (Just bs) = byteShip (hedLabel bs) & \case
  Left  err -> error ("Bad host prefix. Must be a ship name: " <> unpack err)
  Right sp  -> pure sp
 where
  byteShip = fmap (fromIntegral . Ob.fromPatp) . bytePatp
  bytePatp = Ob.parsePatp . decodeUtf8Lenient
  hedLabel = fst . break (== fromIntegral (C.ord '.'))

onSniHdr
  :: HasLogFunc e => e -> MultiTlsConfig -> Maybe String -> IO Credentials
onSniHdr env (MTC mtls) mHos = do
  tabl <- atomically (readTVar mtls)
  runRIO env $ logDbg ctx (tabl, mHos)
  ship <- hostShip (encodeUtf8 . pack <$> mHos)
  runRIO env $ logDbg ctx ship
  tcfg <- lookup ship tabl & maybe (notRunning ship) (pure . snd)
  runRIO env $ logDbg ctx tcfg
  pure (Credentials [tcfg])
 where
  notRunning ship = error ("Ship not running: ~" <> show ship)
  ctx = ["EYRE", "HTTPS", "SNI"]

startServer
  :: HasLogFunc e
  => ServType
  -> ServHost
  -> W.Port
  -> Net.Socket
  -> Maybe W.Port
  -> TVar E.LiveReqs
  -> RIO e ()
startServer typ hos por sok red vLive = do
  envir <- ask

  let host = case hos of
        SHLocalhost -> "127.0.0.1"
        SHAnyHostOk -> "*"

  let opts =
        W.defaultSettings
          & W.setHost host
          & W.setPort (fromIntegral por)
          & W.setTimeout (5 * 60)

  let runAppl who = E.app envir who vLive
      reqShip = hostShip . W.requestHeaderHost

  case typ of
    STHttp who api -> do
      let app = runAppl who (rcReq api who) (rcKil api who)
      io (W.runSettingsSocket opts sok app)

    STHttps who TlsConfig {..} api -> do
      let tls = W.tlsSettingsChainMemory tcCerti tcChain tcPrKey
      let app = runAppl who (rcReq api who) (rcKil api who)
      io (W.runTLSSocket tls opts sok app)

    STMultiHttp api -> do
      let app req resp = do
            who <- reqShip req
            runAppl who (rcReq api who) (rcKil api who) req resp
      io (W.runSettingsSocket opts sok app)

    STMultiHttps mtls api -> do
      TlsConfig {..} <- atomically (getFirstTlsConfig mtls)

      let sni = def { onServerNameIndication = onSniHdr envir mtls }

      let tlsSing = (W.tlsSettingsChainMemory tcCerti tcChain tcPrKey)
      let tlsMany = tlsSing { W.tlsServerHooks = sni }

      let ctx = ["EYRE", "HTTPS", "REQ"]

      let
        app = \req resp -> do
          runRIO envir $ logDbg ctx "Got request"
          who <- reqShip req
          runRIO envir $ logDbg ctx ("Parsed HOST", who)
          runAppl who (rcReq api who) (rcKil api who) req resp

      io (W.runTLSSocket tlsMany opts sok app)


--------------------------------------------------------------------------------

configCreds :: TlsConfig -> Either Text Credential
configCreds TlsConfig {..} =
  credentialLoadX509ChainFromMemory tcCerti tcChain tcPrKey & \case
    Left  str -> Left (pack str)
    Right rs  -> Right rs

fakeServ :: HasLogFunc e => ServConf -> RIO e ServApi
fakeServ conf = do
  let por = fakePort (scPort conf)
  logDebug (displayShow ("EYRE", "SERV", "Running Fake Server", por))
  pure $ ServApi
    { saKil = pure ()
    , saPor = pure por
    }
 where
  fakePort :: ServPort -> W.Port
  fakePort SPAnyPort            = 55555
  fakePort (SPChoices (x :| _)) = x

getFirstTlsConfig :: MultiTlsConfig -> STM TlsConfig
getFirstTlsConfig (MTC var) = do
  map <- readTVar var
  case toList map of
    []  -> STM.retry
    x:_ -> pure (fst x)

realServ :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
realServ vLive conf@ServConf {..} = do
  logDebug (displayShow ("EYRE", "SERV", "Running Real Server"))
  kil <- newEmptyTMVarIO
  por <- newEmptyTMVarIO

  tid <- async (runServ por)
  _   <- async (atomically (takeTMVar kil) >> cancel tid)

  pure $ ServApi
    { saKil = void (tryPutTMVar kil ())
    , saPor = readTMVar por
    }
 where
  runServ vPort = do
    logDebug (displayShow ("EYRE", "SERV", "runServ"))
    rwith (forceOpenSocket scHost scPort) $ \(por, sok) -> do
      atomically (putTMVar vPort por)
      startServer scType scHost por sok scRedi vLive

serv :: HasLogFunc e => TVar E.LiveReqs -> ServConf -> RIO e ServApi
serv vLive conf = do
  if scFake conf
    then fakeServ conf
    else realServ vLive conf