shrub/pkg/hs-urbit/lib/Vere/Http/Server.hs

{-
    TODO Implement ports file.

    TODO What is this abount?

        //  if we don't explicitly set this field, h2o will send with
        //  transfer-encoding: chunked
        //
        if ( 1 == has_len_i ) {
          rec_u->res.content_length = ( 0 == gen_u->bod_u ) ?
                                      0 : gen_u->bod_u->len_w;
        }

    TODO Does this matter, is is using WAI's default behavior ok.

        rec_u->res.reason = (status < 200) ? "weird" :
                            (status < 300) ? "ok" :
                            (status < 400) ? "moved" :
                            (status < 500) ? "missing" :
                            "hosed";
-}

module Vere.Http.Server where

import Arvo            hiding (ServerId, reqBody, reqUrl, secure)
import Data.Conduit
import Noun
import UrbitPrelude    hiding (Builder)
import Vere.Pier.Types

import Data.Binary.Builder (Builder, fromByteString)
import Data.Bits           (shiftL, (.|.))
import Network.Socket      (SockAddr(..))
import System.Random       (randomIO)
import Vere.Http           (convertHeaders, unconvertHeaders)

import qualified Network.HTTP.Types          as H
import qualified Network.Wai                 as W
import qualified Network.Wai.Conduit         as W
import qualified Network.Wai.Handler.Warp    as W
import qualified Network.Wai.Handler.WarpTLS as W


-- RespAction -- Reorganized HttpEvent for Cleaner Processing ------------------

{-
    The sequence of actions on a given request *should* be:

        [%head .] [%bloc .]* %done

    But we will actually accept anything, and mostly do the right
    thing. There are two situations where we ignore ignore the data from
    some actions.

    - If you send something *after* a %done action, it will be ignored.
    - If you send a %done before a %head, we will produce "444 No
      Response" with an empty response body.
-}
data RespAction
    = RAHead ResponseHeader
    | RABloc File
    | RADone

reorgHttpEvent :: HttpEvent -> [RespAction]
reorgHttpEvent = \case
    Start head mBlk isDone -> [RAHead head]
                           <> toList (RABloc <$> mBlk)
                           <> if isDone then [RADone] else []
    Cancel ()              -> [RADone]
    Continue mBlk isDone   -> toList (RABloc <$> mBlk)
                           <> if isDone then [RADone] else []


-- Generic Service Stop/Restart -- Using an MVar for Atomicity -----------------

{-
    Restart a running service.

    This can probably be made simpler, but it

    - Sets the MVar to Nothing if there was an exception whil starting
      or stopping the service.

    - Keeps the MVar lock until the restart process finishes.
-}
restartService :: forall s r
                . MVar (Maybe s)
               -> IO (s, r)
               -> (s -> IO ())
               -> IO (Either SomeException r)
restartService vServ sstart kkill = do
    modifyMVar vServ $ \case
        Nothing -> doStart
        Just sv -> doRestart sv
  where
    doRestart :: s -> IO (Maybe s, Either SomeException r)
    doRestart serv =
        try (kkill serv) >>= \case
            Left exn -> pure (Nothing, Left exn)
            Right () -> doStart

    doStart :: IO (Maybe s, Either SomeException r)
    doStart =
        try sstart <&> \case
            Right (s,r) -> (Just s,  Right r)
            Left exn    -> (Nothing, Left exn)


stopService :: forall s
             . MVar (Maybe s)
            -> (s -> IO ())
            -> IO (Either SomeException ())
stopService vServ kkill = do
    modifyMVar vServ $ \case
        Nothing -> pure (Nothing, Right ())
        Just sv -> do res <- try (kkill sv)
                      pure (Nothing, res)


-- Live Requests Table -- All Requests Still Waiting for Responses -------------

type ReqId = Decimal
type SeqId = Decimal -- TODO Unused. Why is this a thing?

data LiveReqs = LiveReqs
    { nextReqId  :: ReqId
    , activeReqs :: Map ReqId (TMVar RespAction)
    }

emptyLiveReqs :: LiveReqs
emptyLiveReqs = LiveReqs 1 mempty

respondToLiveReq :: TVar LiveReqs -> ReqId -> RespAction -> STM ()
respondToLiveReq var req ev = do
    mVar <- lookup req . activeReqs <$> readTVar var
    case mVar of
        Nothing -> pure ()
        Just tv -> putTMVar tv ev

rmLiveReq :: TVar LiveReqs -> ReqId -> STM ()
rmLiveReq var reqId = do
    liv <- readTVar var
    writeTVar var (liv { activeReqs = deleteMap reqId (activeReqs liv) })

newLiveReq :: TVar LiveReqs -> STM (ReqId, TMVar RespAction)
newLiveReq var = do
    liv <- readTVar var
    tmv <- newEmptyTMVar

    let (nex, act) = (nextReqId liv, activeReqs liv)

    writeTVar var (LiveReqs (nex+1) (insertMap nex tmv act))

    pure (nex, tmv)


-- Random Helpers --------------------------------------------------------------

cordBytes :: Cord -> ByteString
cordBytes = encodeUtf8 . unCord

pass :: Monad m => m ()
pass = pure ()

whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Nothing  act = pure ()
whenJust (Just a) act = act a

cookMeth :: W.Request -> Maybe Method
cookMeth = H.parseMethod . W.requestMethod >>> \case
             Left _  -> Nothing
             Right m -> Just m

reqIdCord :: ReqId -> Cord
reqIdCord = Cord . tshow

reqBody :: W.Request -> IO (Maybe File)
reqBody req = do
    bodyLbs <- W.strictRequestBody req
    if length bodyLbs == 0
      then pure $ Nothing
      else pure $ Just $ File $ Octs (toStrict bodyLbs)

reqAddr :: W.Request -> Address
reqAddr = W.remoteHost >>> \case
    SockAddrInet  _ a     -> AIpv4 (Ipv4 a)
    SockAddrInet6 _ _ a _ -> AIpv6 (mkIpv6 a)
    _                     -> error "invalid sock addr"

mkIpv6 :: (Word32, Word32, Word32, Word32) -> Ipv6
mkIpv6 (p, q, r, s) = Ipv6 (pBits .|. qBits .|. rBits .|. sBits)
  where
    pBits = shiftL (fromIntegral p) 0
    qBits = shiftL (fromIntegral q) 32
    rBits = shiftL (fromIntegral r) 64
    sBits = shiftL (fromIntegral s) 96

reqUrl :: W.Request -> Cord
reqUrl = Cord . decodeUtf8 . W.rawPathInfo


-- Utilities for Constructing Events -------------------------------------------

data WhichServer = Secure | Insecure | Loopback
  deriving (Eq)

servEv :: HttpServerEv -> Ev
servEv = EvBlip . BlipEvHttpServer

bornEv :: KingId -> Ev
bornEv king =
    servEv $ HttpServerEvBorn (king, ()) ()

liveEv :: ServId -> Port -> Maybe Port -> Ev
liveEv sId non sec =
    servEv $ HttpServerEvLive (sId, ()) non sec

cancelEv :: ServId -> ReqId -> Ev
cancelEv sId reqId =
    servEv $ HttpServerEvCancelRequest (sId, reqId, 1, ()) ()

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



-- Http Server Flows -----------------------------------------------------------

{-
    This accepts all action orderings so that there are no edge-cases
    to be handled:

    - If %bloc before %head, collect it and wait for %head.
    - If %done before %head, ignore all chunks and produce Nothing.
-}
getHead :: TMVar RespAction -> IO (Maybe (ResponseHeader, [File]))
getHead tmv = go []
  where
    go çunks = atomically (readTMVar tmv) >>= \case
                 RAHead head -> pure $ Just (head, reverse çunks)
                 RABloc çunk -> go (çunk : çunks)
                 RADone      -> pure Nothing

{-
    - Immediatly yield all of the initial chunks
    - Yield the data from %bloc action.
    - Close the stream when we hit a %done action.
-}
streamBlocks :: [File] -> TMVar RespAction -> ConduitT () (Flush Builder) IO ()
streamBlocks init tmv =
    for_ init yieldÇunk >> go
  where
    yieldFlush = \x -> yield (Chunk x) >> yield Flush
    yieldÇunk  = yieldFlush . fromByteString . unOcts . unFile
    logDupHead = putStrLn "Multiple %head actions on one request"

    go = atomically (readTMVar tmv) >>= \case
           RAHead head -> logDupHead >> go
           RABloc çunk -> yieldÇunk çunk
           RADone      -> pure ()

sendResponse :: (W.Response -> IO W.ResponseReceived)
            -> TMVar RespAction
            -> IO W.ResponseReceived
sendResponse cb tmv = do
    getHead tmv >>= \case
      Nothing    -> do cb $ W.responseLBS (H.mkStatus 444 "No Response") [] ""
      Just (h,i) -> do let çunks = streamBlocks i tmv
                       cb $ W.responseSource (hdrStatus h) (hdrHeaders h) çunks
  where
    hdrHeaders :: ResponseHeader -> [H.Header]
    hdrHeaders = unconvertHeaders . headers

    hdrStatus :: ResponseHeader -> H.Status
    hdrStatus = toEnum . fromIntegral . statusCode

liveReq :: TVar LiveReqs -> Acquire (ReqId, TMVar RespAction)
liveReq vLiv = mkAcquire ins del
  where
    ins = atomically (newLiveReq vLiv)
    del = atomically . rmLiveReq vLiv . fst

app :: ServId -> TVar LiveReqs -> (Ev -> STM ()) -> WhichServer -> W.Application
app sId liv plan which req respond = do
   with (liveReq liv) $ \(reqId, respVar) -> do
        body <- reqBody req
        meth <- maybe (error "bad method") pure (cookMeth req)

        let addr  = reqAddr req
            hdrs  = convertHeaders $ W.requestHeaders req
            evReq = HttpRequest meth (reqUrl req) hdrs body

        atomically $ plan (reqEv sId reqId which addr evReq)

        try (sendResponse respond respVar) >>= \case
          Right rr -> pure rr
          Left exn -> do atomically $ plan (cancelEv sId reqId)
                         throwIO (exn :: SomeException)


-- Top-Level Driver Interface --------------------------------------------------

newtype Drv = Drv { unDrv :: MVar (Maybe Serv) }

data Serv = Serv
    { sServId   :: ServId
    , sConfig   :: HttpServerConf
    , sLoopTid  :: Async ()
    , sHttpTid  :: Async ()
    , sHttpsTid :: Async ()
    , sLiveReqs :: TVar LiveReqs
    }

{-
    TODO Need to find an open port.
-}
startServ :: HttpServerConf -> (Ev -> STM ())
            -> IO (Serv, (ServId, Port, Maybe Port))
startServ conf plan = do
  tls <- case (hscSecure conf) of
      Nothing -> error "HACK: Implement support for missing PEMs"
      Just (PEM key, PEM cert) ->
        pure (W.tlsSettingsMemory (cordBytes cert) (cordBytes key))

  sId <- ServId . UV . fromIntegral <$> (randomIO :: IO Word32)
  liv <- newTVarIO emptyLiveReqs

  let httpPort  = 8080  -- 80 if real ship
      httpsPort = 8443  -- 443 if real ship
      loopPort  = 12321 -- 443 if real ship

      loopOpts  = W.defaultSettings & W.setPort (fromIntegral loopPort)
                                    & W.setHost "127.0.0.1"
                                    & W.setTimeout (5 * 60)
      httpOpts  = W.defaultSettings & W.setPort (fromIntegral httpPort)
      httpsOpts = W.defaultSettings & W.setPort (fromIntegral httpsPort)

  loopTid  <- async $ W.runSettings loopOpts $ app sId liv plan Loopback
  httpTid  <- async $ W.runSettings httpOpts $ app sId liv plan Insecure
  httpsTid <- async $ W.runTLS tls httpsOpts $ app sId liv plan Secure

  let res = (sId, Port httpPort, Just $ Port httpsPort)

  pure (Serv sId conf loopTid httpTid httpsTid liv, res)


killServ :: Serv -> IO ()
killServ Serv{sLoopTid, sHttpTid, sHttpsTid} = do
    cancel sLoopTid
    cancel sHttpTid
    cancel sHttpsTid
    wait sLoopTid
    wait sHttpTid
    wait sHttpsTid

kill :: Drv -> IO ()
kill (Drv v) = stopService v killServ >>= fromEither

respond :: Drv -> ReqId -> HttpEvent -> IO ()
respond (Drv v) reqId ev = do
    readMVar v >>= \case
        Nothing -> pure ()
        Just sv -> atomically $ for_ (reorgHttpEvent ev) $
                                    respondToLiveReq (sLiveReqs sv) reqId

serv :: KingId -> QueueEv -> ([Ev], Acquire (EffCb HttpServerEf))
serv king plan =
    (initialEvents, runHttpServer)
  where
    initialEvents :: [Ev]
    initialEvents = [bornEv king]

    runHttpServer :: Acquire (EffCb HttpServerEf)
    runHttpServer = handleEf <$> mkAcquire (Drv <$> newMVar Nothing) kill

    restart :: Drv -> HttpServerConf -> IO (ServId, Port, Maybe Port)
    restart (Drv var) conf = do
        fromEither =<< restartService var (startServ conf plan) killServ

    handleEf :: Drv -> HttpServerEf -> IO ()
    handleEf drv = \case
        HSESetConfig (i, ()) conf ->
            when (i == fromIntegral king) $ do
                (sId, insecurePort, securePort) <- restart drv conf
                atomically $ plan (liveEv sId insecurePort securePort)
        HSEResponse (i, req, _seq, ()) ev ->
            when (i == fromIntegral king) $
                respond drv (fromIntegral req) ev