king: ted's new packet format

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

@@ -25,6 +25,7 @@ module Urbit.Arvo.Common
 import Urbit.Prelude
 
 import Control.Monad.Fail (fail)
+import Data.Bits
 
 import qualified Network.HTTP.Types.Method as H
 import qualified Urbit.Ob                  as Ob
@@ -166,7 +167,14 @@ newtype Port = Port { unPort :: Word16 }
 
 -- @if
 newtype Ipv4 = Ipv4 { unIpv4 :: Word32 }
-  deriving newtype (Eq, Ord, Show, Enum, Real, Integral, Num, ToNoun, FromNoun)
+  deriving newtype (Eq, Ord, Enum, Real, Integral, Num, ToNoun, FromNoun)
+
+instance Show Ipv4 where
+  show (Ipv4 i) =
+    show ((shiftL i 24) .&. 0xff) ++ "." ++
+    show ((shiftL i 16) .&. 0xff) ++ "." ++
+    show ((shiftL i  8) .&. 0xff) ++ "." ++
+    show (i .&. 0xff)
 
 -- @is
 newtype Ipv6 = Ipv6 { unIpv6 :: Word128 }

pkg/hs/urbit-king/lib/Urbit/Vere/Ames.hs

@@ -15,11 +15,11 @@ import Urbit.Arvo                  hiding (Fake)
 import Urbit.King.Config
 import Urbit.King.Scry
 import Urbit.Vere.Ames.LaneCache
---import Urbit.Vere.Ames.Packet
+import Urbit.Vere.Ames.Packet
 import Urbit.Vere.Pier.Types
 import Urbit.Vere.Ports
 
--- import Data.Serialize      (decode, encode)
+import Data.Serialize      (decode, encode)
 import Urbit.King.App      (HasKingId(..), HasPierEnv(..))
 import Urbit.Vere.Ames.DNS (NetworkMode(..), ResolvServ(..))
 import Urbit.Vere.Ames.DNS (galaxyPort, resolvServ)
@@ -145,6 +145,12 @@ ames'
   -> (Text -> RIO e ())
   -> RIO e ([Ev], RAcquire e (DriverApi NewtEf))
 ames' who isFake stat scry stderr = do
+  stderr "YO-HOI"
+  stderr $ tshow (AAIpv4 (Ipv4 16777343) 60008)
+  -- stderr $ pack $ showUD $ bytesAtom $ encode
+  --        $ Packet 0 (Ship 1) (Ship 0) 2 3 Nothing "hi"
+  -- stderr $ pack $ showUD $ bytesAtom $ encode
+  --        $ Packet 0 (Ship 1) (Ship 0) 2 3 (Just $ AAIpv4 (Ipv4 0xffeeffee) 0xaacc) "hi"
   -- Unfortunately, we cannot use TBQueue because the only behavior
   -- provided for when full is to block the writer. The implementation
   -- below uses materially the same data structures as TBQueue, however.
@@ -267,9 +273,6 @@ ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
       -- port number, host address, bytestring
     (p, a, b) <- atomically (bump' asRcv >> usRecv)
     ver <- readTVarIO vers
-    -- TODO
-    serfsUp p a b
-    {-
     case decode b of
       Right (pkt@Packet {..}) | ver == Nothing || ver == Just pktVersion -> do
         logDebug $ displayShow ("ames: bon packet", pkt, showUD $ bytesAtom b)
@@ -284,7 +287,8 @@ ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
               -> do
                 bump asFwd
                 forward dest $ encode pkt
-                  { pktOrigin = pktOrigin <|> Just (ipDest p a) }
+                  { pktOrigin = pktOrigin
+                            <|> Just (AAIpv4 (Ipv4 a) (fromIntegral p)) }
               where
                 notSelf (EachYes g) = who /= Ship (fromIntegral g)
                 notSelf (EachNo  _) = True
@@ -315,7 +319,6 @@ ames env who isFake stat scry enqueueEv stderr = (initialEvents, runAmes)
       Left e -> do
         bump asDml
         logInfo $ displayShow ("ames: dropping malformed", e)
-    -}
 
     where
       serfsUp p a b =

pkg/hs/urbit-king/lib/Urbit/Vere/Ames/Packet.hs

@@ -9,18 +9,19 @@ import Urbit.Prelude
 import Control.Monad.Fail
 import Data.Bits
 import Data.LargeWord
+import Data.List (genericIndex)
 import Data.Serialize
 
-import Urbit.Arvo (AmesDest)
+import Urbit.Arvo (AmesAddress(..), Ipv4(..), Port(..))
 
 data Packet = Packet
-  { pktVersion    :: Word8
-  , pktEncrypted  :: Bool
-  --
-  , pktSndr       :: Ship
-  , pktRcvr       :: Ship
-  , pktOrigin     :: Maybe AmesDest
-  , pktContent    :: Bytes
+  { pktVersion  :: Word3
+  , pktSndr     :: Ship
+  , pktRcvr     :: Ship
+  , pktSndrTick :: Word4
+  , pktRcvrTick :: Word4
+  , pktOrigin   :: Maybe AmesAddress
+  , pktContent  :: ByteString
   }
   deriving Eq
 
@@ -28,73 +29,140 @@ instance Show Packet where
   show Packet {..}
     = "Packet {pktVersion = "
    <> show pktVersion
-   <> ", pktEncrypted = "
-   <> show pktEncrypted
    <> ", pktSndr = "
    <> show pktSndr
    <> ", pktRcvr = "
    <> show pktRcvr
+   <> ", pktSndrTick = "
+   <> show pktSndrTick
+   <> ", pktRcvrTick = "
+   <> show pktRcvrTick
    <> ", pktOrigin = "
    <> show pktOrigin
    <> ", pktContent = "
-   <> showUD (bytesAtom $ unBytes pktContent)
+   <> showUD (bytesAtom pktContent)
    <> "}"
 
+{-
+-- Wire format
+data PacketHeader = PacketHeader
+  { pktIsAmes    :: Bool       -- sim_o
+  , pktVersion   :: Word3      -- ver_y
+  , pktSndrClass :: ShipClass  -- sac_y
+  , pktRcvrClass :: ShipClass  -- rac_y
+  , pktChecksum  :: Word20     -- mug_l
+  , pktIsRelayed :: Bool       -- rel_o
+  }
+  deriving Eq
+
+data PacketBody = PacketBody
+  { pktSndr     :: Ship               -- sen_d
+  , pktRcvr     :: Ship               -- rec_d
+  , pktSndrTick :: Word4              -- sic_y
+  , pktRcvrTick :: Word4              -- ric_y
+  , pktContent  :: ByteString         -- (con_s, con_y)
+  , pktOrigin   :: Maybe AmesAddress  -- rog_d
+  }
+  deriving Eq
+-}
+
+type Word3 = Word8
+type Word4 = Word8
+type Word20 = Word32
+
+data ShipClass
+  = Lord
+  | Planet
+  | Moon
+  | Comet
+  deriving (Eq, Show)
+
+muk :: ByteString -> Word20
+muk bs = mugBS bs .&. (2 ^ 20 - 1)
+
+-- XX check this
+getAmesAddress :: Get AmesAddress
+getAmesAddress = AAIpv4 <$> (Ipv4 <$> getWord32le) <*> (Port <$> getWord16le)
+
+putAmesAddress :: Putter AmesAddress
+putAmesAddress = \case
+  AAIpv4 (Ipv4 ip) (Port port) -> putWord32le ip >> putWord16le port
+
 instance Serialize Packet where
   get = do
     -- header
     head <- getWord32le
-    let pktVersion   =         head    .&. 0b111        & fromIntegral
-    let checksum     = shiftR  head  3 .&. (2 ^ 20 - 1)
-    let sndrRank     = shiftR  head 23 .&. 0b11
-    let rcvrRank     = shiftR  head 25 .&. 0b11
-    let pktEncrypted = testBit head 27  &  not  -- loobean
-    -- verify checksum
+    -- skip first three bits
+    let isAmes     = testBit head  3  &  not
+    let pktVersion = shiftR  head  4 .&. 0b111 & fromIntegral
+    let sndrRank   = shiftR  head  7 .&. 0b11
+    let rcvrRank   = shiftR  head  9 .&. 0b11
+    let checksum   = shiftR  head 11 .&. (2 ^ 20 - 1)
+    let isRelayed  = testBit head 31  &  not  -- loobean
+    let sndrClass = genericIndex [Lord, Planet, Moon, Comet] sndrRank
+    let rcvrClass = genericIndex [Lord, Planet, Moon, Comet] rcvrRank
+    guard isAmes
+
+    pktOrigin <- if isRelayed
+      then Just <$> getAmesAddress
+      else pure Nothing
+
+    -- body
     lookAhead $ do
-      len  <- remaining
+      len <- remaining
       body <- getBytes len
-      let chk = fromIntegral (mugBS body) .&. (2 ^ 20 - 1)
+      let chk = muk body
       when (checksum /= chk) $
         fail ("checksum mismatch: expected " <> show checksum
            <> "; got " <> show chk)
-    -- body
-    pktSndr <- getShip sndrRank
-    pktRcvr <- getShip rcvrRank
-    len     <- remaining
-    payload <- getBytes len
-    -- data ("payload")
-    (pktOrigin, pktContent) <- case cueBS payload of
-          Left  e -> fail (show e)
-          Right n -> case fromNounErr n of
-            Left  e -> fail (show e)
-            Right c -> pure c
-    pure Packet {..}
+
+    tick <- getWord8
+    let pktSndrTick = tick .&. 0b1111
+    let pktRcvrTick = shiftR tick 4
+
+    pktSndr <- getShip sndrClass
+    pktRcvr <- getShip rcvrClass
+
+    len <- remaining
+    pktContent <- getBytes len
+
+    pure Packet{..}
     where
       getShip = fmap Ship . \case
-        0 -> fromIntegral <$> getWord16le              -- galaxy / star
-        1 -> fromIntegral <$> getWord32le              -- planet
-        2 -> fromIntegral <$> getWord64le              -- moon
-        3 -> LargeKey <$> getWord64le <*> getWord64le  -- comet
-        _ -> fail "impossibiru"
+        Lord   -> fromIntegral <$> getWord16le
+        Planet -> fromIntegral <$> getWord32le
+        Moon   -> fromIntegral <$> getWord64le
+        Comet  -> LargeKey <$> getWord64le <*> getWord64le
 
-  put Packet {..} = do
-    let load = jamBS $ toNoun (pktOrigin, pktContent)
+  put Packet{..} = do
     let (sndR, putSndr) = putShipGetRank pktSndr
     let (rcvR, putRcvr) = putShipGetRank pktRcvr
-    let body = runPut (putSndr <> putRcvr <> putByteString load)
-    let chek = fromIntegral (mugBS body) .&. (2 ^ 20 - 1)
-    let encr = pktEncrypted
+
+    let body = runPut $ do
+          putWord8 $ (pktSndrTick .&. 0b1111)
+                 .|. shiftL (pktRcvrTick .&. 0b1111) 4
+          putSndr
+          putRcvr
+          putByteString pktContent
+
     let vers = fromIntegral pktVersion .&. 0b111
-    let head =        vers
-           .|. shiftL chek                  3
-           .|. shiftL sndR                 23
-           .|. shiftL rcvR                 25
-           .|. if     encr then 0 else bit 27
+    let chek = muk body
+
+    -- skip first 3 bytes, set 4th to yes (0) for "is ames"
+    let head = shiftL vers 4
+           .|. shiftL sndR 7
+           .|. shiftL rcvR 9
+           .|. shiftL chek 11
+           .|. if isJust pktOrigin then 0 else bit 31
+
     putWord32le head
-    putByteString body  -- XX can we avoid copy?
+    case pktOrigin of
+      Just o  -> putAmesAddress o
+      Nothing -> pure ()
+    putByteString body
     where
       putShipGetRank s@(Ship (LargeKey p q)) = case () of
-        _ | s < 2 ^ 16 -> (0, putWord16le $ fromIntegral s)    -- gar
-          | s < 2 ^ 32 -> (1, putWord32le $ fromIntegral s)    -- pan
-          | s < 2 ^ 64 -> (2, putWord64le $ fromIntegral s)    -- mon
-          | otherwise  -> (3, putWord64le p >> putWord64le q)  -- com
+        _ | s < 2 ^ 16 -> (0, putWord16le $ fromIntegral s)    -- lord
+          | s < 2 ^ 32 -> (1, putWord32le $ fromIntegral s)    -- planet
+          | s < 2 ^ 64 -> (2, putWord64le $ fromIntegral s)    -- moon
+          | otherwise  -> (3, putWord64le p >> putWord64le q)  -- comet

pkg/hs/urbit-king/test/AmesTests.hs

@@ -108,9 +108,10 @@ instance Arbitrary LogIdentity where
 instance Arbitrary Packet where
   arbitrary = do
     pktVersion   <- suchThat arb (< 8)
-    pktEncrypted <- arb
     pktSndr      <- arb
     pktRcvr      <- arb
+    pktSndrTick  <- suchThat arb (< 16)
+    pktRcvrTick  <- suchThat arb (< 16)
     pktOrigin    <- arb
     pktContent   <- arb
     pure Packet {..}