Some server stuff.

pkg/hair/lib/Vere/Http/Server.hs

@@ -5,10 +5,13 @@ module Vere.Http.Server where
 import ClassyPrelude
 import Vere.Http
 
+import Control.Concurrent (ThreadId, killThread)
 import Data.Noun.Atom
 import Data.Noun.Pill (packAtom)
-import qualified Network.HTTP.Types.Method as H
-import qualified Network.Wai as H
+import qualified Network.HTTP.Types as H
+import qualified Network.Wai as W
+import qualified Network.Wai.Handler.Warp as W
+import qualified Network.Wai.Handler.WarpTLS as W
 
 type ServerId = Word
 type ConnectionId = Word
@@ -34,7 +37,7 @@ newtype Key = Key PEM
 newtype Cert = Cert PEM
 data Wain = Wain [Text]
 
-data PEM
+newtype PEM = PEM ByteString
 
 data ClientResponse
   = Progress ResponseHeader Int (Maybe Int) (Maybe ByteString)
@@ -45,9 +48,51 @@ data MimeData = MimeData Text ByteString
 
 --
 
-cookMeth :: H.Request -> Maybe Method
+data Ev
+
+data State = State
+  { thread :: MVar (Maybe (Config, ThreadId))
+  , sChan  :: MVar Ev
+  }
+
+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
+
+startServer :: State -> Config -> IO ()
+startServer s c = do
+  tls <- case (secure c) of
+    Nothing -> error "no wai"
+    Just (Key (PEM key), Cert (PEM cert)) ->
+      pure (W.tlsSettingsMemory cert key)
+
+  -- we need to do the dance where we do the socket checking dance. or shove a
+  -- socket into it.
+  W.runTLS tls W.defaultSettings (app s)
+
+app :: State -> W.Application
+app s req respond = bracket_
+    (pure ())
+    (pure ())
+    (respond $ W.responseLBS H.status200 [] "Hello World")
+
+cookMeth :: W.Request -> Maybe Method
 cookMeth re =
-  case H.parseMethod (H.requestMethod re) of
+  case H.parseMethod (W.requestMethod re) of
     Left _ -> Nothing
     Right m -> Just m
 
@@ -56,12 +101,12 @@ data Octs = Octs Atom Atom
 bsToOcts :: ByteString -> Octs
 bsToOcts bs = Octs (fromIntegral (length bs)) (packAtom bs)
 
-readEvents :: H.Request -> IO Request
+readEvents :: W.Request -> IO Request
 readEvents request = do
   let Just method = cookMeth request
-      url = decodeUtf8 (H.rawPathInfo request)
-      headers = convertHeaders (H.requestHeaders request)
-  bodyLbs <- H.strictRequestBody request
+      url = decodeUtf8 (W.rawPathInfo request)
+      headers = convertHeaders (W.requestHeaders request)
+  bodyLbs <- W.strictRequestBody request
   let body = if length bodyLbs == 0 then Nothing
         else Just (toStrict bodyLbs)
 

pkg/hair/package.yaml

@@ -69,6 +69,8 @@ dependencies:
   - unordered-containers
   - vector
   - wai
+  - warp
+  - warp-tls
 
 default-extensions:
   - ApplicativeDo