Basic HTTPServer driver skeleton

pkg/hs-urbit/lib/Arvo/Common.hs

@@ -1,9 +1,10 @@
 module Arvo.Common
-  ( NounTree(..), NounMap, NounSet
+  ( KingId(..)
+  , NounTree(..), NounMap, NounSet
   , Json, JsonNode(..)
   , Desk(..), Mime(..)
   , Lane(..), Port(..), Turf(..)
-  , HttpServerConf(..), HttpEvent(..), PEM, Method, Header
+  , HttpServerConf(..), HttpEvent(..), PEM(..), Key, Cert, Method, Header
   , ReOrg(..), reorgThroughNoun
   , AmesDest(..), Ipv4(..), Ipv6(..), Galaxy(..)
   ) where
@@ -25,6 +26,9 @@ import qualified Network.HTTP.Types.Method as H
 newtype Turf = Turf { unTurf :: [Cord] }
   deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
 
+newtype KingId = KingId { unKingId :: Word32}
+  deriving newtype (Eq, Ord, Show, Num, Real, Enum, Integral, FromNoun, ToNoun)
+
 
 -- Http Common -----------------------------------------------------------------
 
@@ -69,7 +73,7 @@ instance FromNoun H.StdMethod where
 
 -- Http Server Configuration ---------------------------------------------------
 
-newtype PEM = PEM Cord
+newtype PEM = PEM { unPEM :: Cord }
   deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
 
 type Key  = PEM

pkg/hs-urbit/lib/Arvo/Event.hs

@@ -2,10 +2,10 @@ module Arvo.Event where
 
 import UrbitPrelude hiding (Term)
 
+import Arvo.Common (KingId(..))
 import Arvo.Common (NounMap, NounSet)
 import Arvo.Common (Desk, Mime)
-import Arvo.Common (Ipv4, Ipv6, AmesDest, Turf)
-import Arvo.Common (HttpEvent, HttpServerConf)
+import Arvo.Common (Ipv4, Ipv6, Port, Turf, AmesDest, HttpEvent)
 import Arvo.Common (ReOrg(..), reorgThroughNoun)
 
 
@@ -114,17 +114,16 @@ data HttpServerReq = HttpServerReq
   deriving (Eq, Ord, Show)
 
 data HttpClientEv
-    = HttpClientEvReceive (Atom, ()) ServerId HttpEvent
-    | HttpClientEvBorn    (Atom, ()) ()
+    = HttpClientEvReceive (KingId, ()) ServerId HttpEvent
+    | HttpClientEvBorn    (KingId, ()) ()
     | HttpClientEvCrud    Path       Cord Tang
   deriving (Eq, Ord, Show)
 
 data HttpServerEv
-    = HttpServerEvRequest      (Atom, Word, Word, ()) HttpServerReq
-    | HttpServerEvRequestLocal Path                   HttpServerReq
-    | HttpServerEvLive         (Atom, ())             Atom (Maybe Word)
-    | HttpServerEvBorn         (Atom, ())             ()
-    | HttpServerEvSetConfig    (Atom, ())             HttpServerConf
+    = HttpServerEvRequest      (KingId, Word, Word, ()) HttpServerReq
+    | HttpServerEvRequestLocal (KingId, Path)           HttpServerReq
+    | HttpServerEvLive         (KingId, ())             Port (Maybe Port)
+    | HttpServerEvBorn         (KingId, ())             ()
   deriving (Eq, Ord, Show)
 
 deriveNoun ''Address

pkg/hs-urbit/lib/Noun/Conversions.hs

@@ -83,7 +83,7 @@ instance FromNoun Cord where
 -- Decimal Cords ---------------------------------------------------------------
 
 newtype Decimal = Decimal { unDecimal :: Word }
-  deriving newtype (Eq, Ord, Show)
+  deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num)
 
 instance ToNoun Decimal where
   toNoun = toNoun . Cord . tshow . unDecimal

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

@@ -1,11 +1,12 @@
--- +http-server ----------------------------------------------------------------
+{-# OPTIONS_GHC -Wwarn #-}
 
 module Vere.Http.Server where
 
-import ClassyPrelude
-
+import Arvo            hiding (ServerId, secure)
 import Noun
-import Vere.Http
+import UrbitPrelude
+import Vere.Http       hiding (Method)
+import Vere.Pier.Types
 
 import Control.Concurrent (ThreadId, forkIO, killThread)
 
@@ -14,82 +15,164 @@ import qualified Network.Wai                 as W
 import qualified Network.Wai.Handler.Warp    as W
 import qualified Network.Wai.Handler.WarpTLS as W
 
+
 -- Types -----------------------------------------------------------------------
 
-type ServerId     = Word
-type ConnectionId = Word
-type RequestId    = Word
+type ReqId = Word
+type SeqId = Word
 
--- Note: We need to parse PEM-encoded RSA private keys and cert or cert chain
--- from Wain
-type Key = PEM
-type Cert = PEM
-newtype Wain = Wain [Cord]
-  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
+newtype Drv = Drv { unDrv :: MVar (Maybe Serv) }
 
-newtype PEM = PEM Cord
-  deriving newtype (Eq, Ord, Show, ToNoun, FromNoun)
+data Serv = Serv
+    { sConfig   :: HttpServerConf
+    , sThread   :: Async ()
+    , sLiveReqs :: TVar (Map ReqId (TMVar (SeqId, HttpEvent)))
+    }
+
+
+-- Generic Service Restart and Stop Logic --------------------------------------
+
+{-
+    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)
+
+
+-- Utilities -------------------------------------------------------------------
+
+servEv :: HttpServerEv -> Ev
+servEv = EvBlip . BlipEvHttpServer
+
+bornEv :: KingId -> Ev
+bornEv inst = servEv $ HttpServerEvBorn (fromIntegral inst, ()) ()
+
+liveEv :: KingId -> Port -> Maybe Port -> Ev
+liveEv inst non sec = servEv $ HttpServerEvLive (inst, ()) non sec
 
 
 --------------------------------------------------------------------------------
 
-data Eff = Eff ServerId ConnectionId RequestId ServerRequest
-  deriving (Eq, Ord, Show)
+startServ :: HttpServerConf -> IO (Serv, (Port, Maybe Port))
+startServ conf = do
+    (insecurePort, securePort) <- undefined
+    serv <- Serv conf <$> async undefined <*> newTVarIO mempty
+    pure (insecurePort, securePort)
 
--- | An http server effect is configuration, or it sends an outbound response
-data ServerRequest
-  = SetConfig Config
-  | Response Event
-  deriving (Eq, Ord, Show)
+killServ :: Serv -> IO ()
+killServ Serv{sThread} = cancel sThread >> wait sThread
 
-data Config = Config
-    { secure   :: Maybe (Key, Cert)
-    , proxy    :: Bool
-    , log      :: Bool
-    , redirect :: Bool
-    }
-  deriving (Eq, Ord, Show)
+restart :: Drv -> HttpServerConf -> IO (Port, Maybe Port)
+restart (Drv var) conf = do
+    fromEither =<< restartService var (startServ conf) killServ
 
-deriveNoun ''Config
+kill :: Drv -> IO ()
+kill (Drv v) = stopService v killServ >>= fromEither
 
+respond :: Drv -> ReqId -> SeqId -> HttpEvent -> IO ()
+respond (Drv v) req seq ev = do
+    readMVar v >>= \case
+        Nothing -> pure ()
+        Just sv -> atomically $ do
+            liveReqs <- readTVar (sLiveReqs sv)
+            lookup req liveReqs & \case
+                Nothing -> pure ()
+                Just tm -> putTMVar tm (seq, ev)
+
+
+-- Top-Level Driver Interface --------------------------------------------------
+
+serv :: KingId
+     -> QueueEv
+     -> ([Ev], Acquire (EffCb HttpServerEf))
+serv inst plan =
+    (initialEvents, runHttpServer)
+  where
+    initialEvents :: [Ev]
+    initialEvents = [ bornEv inst ]
+
+    runHttpServer :: Acquire (EffCb HttpServerEf)
+    runHttpServer = handleEf <$> mkAcquire (Drv <$> newMVar Nothing) kill
+
+    handleEf :: Drv -> HttpServerEf -> IO ()
+    handleEf drv = \case
+        HSESetConfig (i, ()) conf ->
+            when (i == fromIntegral inst) $ do
+                (i, s) <- restart drv conf
+                atomically (plan (liveEv inst i s))
+        HSEResponse (i, req, sec, ()) ev ->
+            when (i == fromIntegral inst) $
+                respond drv (fromIntegral req) (fromIntegral sec) ev
+
+
+--------------------------------------------------------------------------------
+
+{-
 data ClientResponse
-  = Progress ResponseHeader Int (Maybe Int) (Maybe ByteString)
-  | Finished ResponseHeader (Maybe MimeData)
-  | Cancel ()
+    = Progress ResponseHeader Int (Maybe Int) (Maybe ByteString)
+    | Finished ResponseHeader (Maybe MimeData)
+    | Cancel ()
 
 data MimeData = MimeData Text ByteString
+-}
 
-data Ev
+{-
+  Alright, so the flow here is:
 
-data State = State
-  { thread :: MVar (Maybe (Config, ThreadId))
-  , sChan  :: MVar Ev
-  }
+    · Once we receive a request, send a %request or %request-local event.
+    · The request thread should stick an MVar into a map, and wait on
+      it for a response.
+-}
 
---------------------------------------------------------------------------------
-
-init :: IO State
-init =
-  -- When we initialize things, we send an event into arvo
-  -- When we receive the set-config event, then we start stuff up
-
-  --  This works for now, but we need to actually do stuff per above.
-  State <$> newMVar Nothing
-        <*> newEmptyMVar
-
-onSetConfig :: State -> Config -> IO ()
-onSetConfig s c = do
-  v <- takeMVar (thread s)
-
-  maybe (pure ()) (killThread . snd) v
-
-  putMVar (thread s) Nothing
-  startServer s c
+{-
+data HttpServerEv
+    = HttpServerEvRequest       (KingId, Word, Word, ())  HttpServerReq
+    | HttpServerEvRequestLocal  Path                      HttpServerReq
+    | HttpServerEvLive          (KingId, ())              Port (Maybe Port)
+-}
 
+{-
 cordBytes :: Cord -> ByteString
 cordBytes = encodeUtf8 . unCord
 
-startServer :: State -> Config -> IO ()
+startServer :: ServDrv -> Config -> IO ()
 startServer s c = do
   tls <- case (secure c) of
     Nothing -> error "no wai"
@@ -99,9 +182,9 @@ startServer s c = do
   -- we need to do the dance where we do the socket checking dance. or shove a
   -- socket into it.
   tid <- forkIO $ W.runTLS tls W.defaultSettings (app s)
-  putMVar (thread s) (Just (c, tid))
+  putMVar (sdThread s) (Just (c, tid))
 
-app :: State -> W.Application
+app :: ServDrv -> W.Application
 app s req respond = bracket_
     (pure ())
     (pure ())
@@ -125,3 +208,4 @@ readEvents req = do
   -- TODO: Check if wai just deletes the 'host': header like h2o does?
 
   pure (Request meth url headers body)
+-}

pkg/urbit/vere/http.c

@@ -1508,6 +1508,7 @@ u3_http_ef_http_server(c3_l    sev_l,
   if ( c3y == u3rz_sing(u3i_string("set-config"), u3k(tag)) ) {
     u3_http_ef_form(u3k(dat));
   }
+
   //  responds to an open request
   //
   else if ( 0 != (req_u = _http_search_req(sev_l, coq_l, seq_l)) ) {