Send cancel-request event if connection closed and correctly encode http-server path elements.

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)
 
 

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

@@ -123,8 +123,9 @@ data HttpClientEv
   deriving (Eq, Ord, Show)
 
 data HttpServerEv
-    = HttpServerEvRequest      (ServId, Word, Word, ()) HttpServerReq
-    | HttpServerEvRequestLocal (ServId, Word, Word, ()) HttpServerReq
+    = 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)

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

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