mirror of
https://github.com/urbit/shrub.git
synced 2024-12-21 09:51:36 +03:00
138 lines
3.6 KiB
Haskell
138 lines
3.6 KiB
Haskell
-- +http-server ----------------------------------------------------------------
|
|
|
|
module Vere.Http.Server where
|
|
|
|
import ClassyPrelude
|
|
import Vere.Http
|
|
import Data.Noun.Atom
|
|
import Data.Noun.Poet
|
|
import Control.Lens
|
|
|
|
import Control.Concurrent (ThreadId, killThread, forkIO)
|
|
import Data.Noun.Pill (pill, pillBS, Pill(..))
|
|
|
|
import qualified Data.ByteString as BS
|
|
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
|
|
type RequestId = Word
|
|
|
|
data Foo = A | B | C
|
|
|
|
data Eff = Eff ServerId ConnectionId RequestId ServerRequest
|
|
deriving (Eq, Ord, Show, Generic, ToNoun)
|
|
|
|
-- | An http server effect is configuration, or it sends an outbound response
|
|
data ServerRequest
|
|
= SetConfig Config
|
|
| Response Event
|
|
deriving (Eq, Ord, Show, Generic, ToNoun)
|
|
|
|
data Config = Config
|
|
{ secure :: Maybe (Key, Cert)
|
|
, proxy :: Bool
|
|
, log :: Bool
|
|
, redirect :: Bool
|
|
}
|
|
deriving (Eq, Ord, Show, Generic, ToNoun)
|
|
|
|
|
|
-- Note: We need to parse PEM-encoded RSA private keys and cert or cert chain
|
|
-- from Wain
|
|
type Key = PEM
|
|
type Cert = PEM
|
|
data Wain = Wain [Text]
|
|
|
|
newtype PEM = PEM Cord
|
|
deriving newtype (Eq, Ord, Show, ToNoun)
|
|
|
|
data ClientResponse
|
|
= Progress ResponseHeader Int (Maybe Int) (Maybe ByteString)
|
|
| Finished ResponseHeader (Maybe MimeData)
|
|
| Cancel
|
|
|
|
data MimeData = MimeData Text ByteString
|
|
|
|
--
|
|
|
|
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 (PEM key, PEM cert) ->
|
|
pure (W.tlsSettingsMemory (unCord cert) (unCord key))
|
|
|
|
-- 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))
|
|
|
|
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 (W.requestMethod re) of
|
|
Left _ -> Nothing
|
|
Right m -> Just m
|
|
|
|
data Octs = Octs Atom Atom
|
|
|
|
bsOcts :: Iso' ByteString Octs
|
|
bsOcts = iso toOcts fromOcts
|
|
where
|
|
toOcts :: ByteString -> Octs
|
|
toOcts bs =
|
|
Octs (fromIntegral (length bs)) (bs ^. from (pill . pillBS))
|
|
|
|
fromOcts :: Octs -> ByteString
|
|
fromOcts (Octs (fromIntegral -> len) atm) = bs <> pad
|
|
where
|
|
bs = atm ^. pill . pillBS
|
|
pad = BS.replicate (max 0 (len - length bs)) 0
|
|
|
|
readEvents :: W.Request -> IO Request
|
|
readEvents request = do
|
|
let Just method = cookMeth 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)
|
|
|
|
-- TODO: Check if wai just deletes the 'host': header like h2o does?
|
|
|
|
pure (Request method url headers body)
|