From 753c9ef17c580b03986f4d3f850619c902a8c0a0 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Tue, 6 Aug 2019 17:46:47 -0700 Subject: [PATCH] Send cancel-request event if connection closed and correctly encode http-server path elements. --- pkg/hs-urbit/lib/Arvo/Common.hs | 4 +- pkg/hs-urbit/lib/Arvo/Event.hs | 9 ++-- pkg/hs-urbit/lib/Noun/Conversions.hs | 78 +++++++++++++++++++++++++++- pkg/hs-urbit/lib/Vere/Http/Server.hs | 31 ++++++----- 4 files changed, 102 insertions(+), 20 deletions(-) diff --git a/pkg/hs-urbit/lib/Arvo/Common.hs b/pkg/hs-urbit/lib/Arvo/Common.hs index 0d82e07c23..03b8833fcc 100644 --- a/pkg/hs-urbit/lib/Arvo/Common.hs +++ b/pkg/hs-urbit/lib/Arvo/Common.hs @@ -27,10 +27,10 @@ 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} +newtype KingId = KingId { unKingId :: Base32 } deriving newtype (Eq, Ord, Show, Num, Real, Enum, Integral, FromNoun, ToNoun) -newtype ServId = ServId { unServId :: Word32 } +newtype ServId = ServId { unServId :: Base32 } deriving newtype (Eq, Ord, Show, Num, Enum, Integral, Real, FromNoun, ToNoun) diff --git a/pkg/hs-urbit/lib/Arvo/Event.hs b/pkg/hs-urbit/lib/Arvo/Event.hs index 59955c4945..303a8ae850 100644 --- a/pkg/hs-urbit/lib/Arvo/Event.hs +++ b/pkg/hs-urbit/lib/Arvo/Event.hs @@ -123,10 +123,11 @@ data HttpClientEv deriving (Eq, Ord, Show) data HttpServerEv - = HttpServerEvRequest (ServId, Word, Word, ()) HttpServerReq - | HttpServerEvRequestLocal (ServId, Word, Word, ()) HttpServerReq - | HttpServerEvLive (ServId, ()) Port (Maybe Port) - | HttpServerEvBorn (KingId, ()) () + = HttpServerEvRequest (ServId, Decimal, Decimal, ()) HttpServerReq + | HttpServerEvCancelRequest (ServId, Decimal, Decimal, ()) () + | HttpServerEvRequestLocal (ServId, Decimal, Decimal, ()) HttpServerReq + | HttpServerEvLive (ServId, ()) Port (Maybe Port) + | HttpServerEvBorn (KingId, ()) () deriving (Eq, Ord, Show) deriveNoun ''Address diff --git a/pkg/hs-urbit/lib/Noun/Conversions.hs b/pkg/hs-urbit/lib/Noun/Conversions.hs index 851d12ddaa..6ba9ce0716 100644 --- a/pkg/hs-urbit/lib/Noun/Conversions.hs +++ b/pkg/hs-urbit/lib/Noun/Conversions.hs @@ -5,7 +5,7 @@ module Noun.Conversions , Word128, Word256, Word512 , Bytes(..), Octs(..), File(..) , Cord(..), Knot(..), Term(..), Tape(..), BigTape(..), Tour(..) - , Decimal(..) + , Decimal(..), Base32, UV(..) , Tank(..), Tang, Plum(..) , Mug(..), Path(..), EvilPath(..), Ship(..) , Lenient(..) @@ -30,6 +30,7 @@ import GHC.Types (Char(C#)) import GHC.Word (Word32(W32#)) import Noun.Cue (cue) import Noun.Jam (jam) +import Prelude ((!!)) import RIO (decodeUtf8Lenient) import System.IO.Unsafe (unsafePerformIO) import Text.Show.Pretty (ppShow) @@ -96,6 +97,81 @@ instance FromNoun Decimal where Just vl -> pure (Decimal vl) +-------------------------------------------------------------------------------- + +type Base32 = UV + +-- @uv +newtype UV = UV { unUV :: Atom } + deriving newtype (Eq, Ord, Show, Num, Enum, Real, Integral) + +instance ToNoun UV where + toNoun = toNoun . Cord . pack . toUV . fromIntegral . unUV + +instance FromNoun UV where + parseNoun n = do + Cord c <- parseNoun n + case fromUV $ unpack c of + Nothing -> fail ("Invalid @uv: " <> unpack c) + Just uv -> pure (UV uv) + +fromUV :: String -> Maybe Atom +fromUV = go (0, 0) + where + go (i, acc) [] = pure acc + go (i, acc) (c:cs) = do + n <- uvCharNum c + go (i+1, i*n) cs + +toUV :: Atom -> String +toUV = go [] + where + go acc 0 = reverse acc + go acc n = go (char n : acc) (n `div` 32) + + char n = base32Chars !! (fromIntegral (n `mod` 32)) + +base32Chars :: [Char] +base32Chars = (['0'..'9'] <> ['a'..'v']) + +uvCharNum :: Char -> Maybe Atom +uvCharNum = \case + '0' -> pure 0 + '1' -> pure 1 + '2' -> pure 2 + '3' -> pure 3 + '4' -> pure 4 + '5' -> pure 5 + '6' -> pure 6 + '7' -> pure 7 + '8' -> pure 8 + '9' -> pure 9 + 'a' -> pure 10 + 'b' -> pure 11 + 'c' -> pure 12 + 'd' -> pure 13 + 'e' -> pure 14 + 'f' -> pure 15 + 'g' -> pure 16 + 'h' -> pure 17 + 'i' -> pure 18 + 'j' -> pure 19 + 'k' -> pure 20 + 'l' -> pure 21 + 'm' -> pure 22 + 'n' -> pure 23 + 'o' -> pure 24 + 'p' -> pure 25 + 'q' -> pure 26 + 'r' -> pure 27 + 's' -> pure 28 + 't' -> pure 29 + 'u' -> pure 30 + 'v' -> pure 31 + _ -> Nothing + + + -- Char ------------------------------------------------------------------------ instance ToNoun Char where diff --git a/pkg/hs-urbit/lib/Vere/Http/Server.hs b/pkg/hs-urbit/lib/Vere/Http/Server.hs index 5fd23f1c8b..3578b2926f 100644 --- a/pkg/hs-urbit/lib/Vere/Http/Server.hs +++ b/pkg/hs-urbit/lib/Vere/Http/Server.hs @@ -18,9 +18,6 @@ (status < 400) ? "moved" : (status < 500) ? "missing" : "hosed"; - - - -} module Vere.Http.Server where @@ -122,8 +119,8 @@ stopService vServ kkill = do -- Live Requests Table -- All Requests Still Waiting for Responses ------------- -type ReqId = Word -type SeqId = Word -- TODO Unused. Why is this a thing? +type ReqId = Decimal +type SeqId = Decimal -- TODO Unused. Why is this a thing? data LiveReqs = LiveReqs { nextReqId :: ReqId @@ -218,6 +215,10 @@ 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 @@ -280,14 +281,15 @@ sendResponse cb tmv = do 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 - - (reqId, respVar) <- atomically (newLiveReq liv) - - let clearLiveReq = atomically (rmLiveReq liv reqId) - - bracket_ pass clearLiveReq $ do + with (liveReq liv) $ \(reqId, respVar) -> do body <- reqBody req meth <- maybe (error "bad method") pure (cookMeth req) @@ -297,7 +299,10 @@ app sId liv plan which req respond = do atomically $ plan (reqEv sId reqId which addr evReq) - sendResponse respond respVar + try (sendResponse respond respVar) >>= \case + Right rr -> pure rr + Left exn -> do atomically $ plan (cancelEv sId reqId) + throwIO (exn :: SomeException) -- Top-Level Driver Interface -------------------------------------------------- @@ -324,7 +329,7 @@ startServ conf plan = do Just (PEM key, PEM cert) -> pure (W.tlsSettingsMemory (cordBytes cert) (cordBytes key)) - sId <- ServId <$> randomIO + sId <- ServId . UV . fromIntegral <$> (randomIO :: IO Word32) liv <- newTVarIO emptyLiveReqs let httpPort = 8080 -- 80 if real ship