diff options
| -rw-r--r-- | src/Network.hs | 2 | ||||
| -rw-r--r-- | src/Network/Protocol.hs | 20 |
2 files changed, 18 insertions, 4 deletions
diff --git a/src/Network.hs b/src/Network.hs index c5ba393..071a0b0 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -480,6 +480,8 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = | otherwise -> addHeader $ Rejected dgst | otherwise -> throwError $ "service ref without type" + _ -> return () + let logd = writeTQueue (serverErrorLog server) case res of Left err -> do diff --git a/src/Network/Protocol.hs b/src/Network/Protocol.hs index 488080e..db5e767 100644 --- a/src/Network/Protocol.hs +++ b/src/Network/Protocol.hs @@ -36,6 +36,8 @@ import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL import Data.List import Data.Maybe +import Data.Text (Text) +import Data.Text qualified as T import System.Clock @@ -46,6 +48,13 @@ import Service import Storage +protocolVersion :: Text +protocolVersion = T.pack "0.1" + +protocolVersions :: [Text] +protocolVersions = [protocolVersion] + + data TransportPacket a = TransportPacket TransportHeader [a] data TransportHeader = TransportHeader [TransportHeaderItem] @@ -53,6 +62,7 @@ data TransportHeader = TransportHeader [TransportHeaderItem] data TransportHeaderItem = Acknowledged RefDigest | Rejected RefDigest + | ProtocolVersion Text | DataRequest RefDigest | DataResponse RefDigest | AnnounceSelf RefDigest @@ -68,6 +78,7 @@ transportToObject st (TransportHeader items) = Rec $ map single items where single = \case Acknowledged dgst -> (BC.pack "ACK", RecRef $ partialRefFromDigest st dgst) Rejected dgst -> (BC.pack "REJ", RecRef $ partialRefFromDigest st dgst) + ProtocolVersion ver -> (BC.pack "VER", RecText ver) DataRequest dgst -> (BC.pack "REQ", RecRef $ partialRefFromDigest st dgst) DataResponse dgst -> (BC.pack "RSP", RecRef $ partialRefFromDigest st dgst) AnnounceSelf dgst -> (BC.pack "ANN", RecRef $ partialRefFromDigest st dgst) @@ -84,6 +95,7 @@ transportFromObject (Rec items) = case catMaybes $ map single items of where single (name, content) = if | name == BC.pack "ACK", RecRef ref <- content -> Just $ Acknowledged $ refDigest ref | name == BC.pack "REJ", RecRef ref <- content -> Just $ Rejected $ refDigest ref + | name == BC.pack "VER", RecText ver <- content -> Just $ ProtocolVersion ver | name == BC.pack "REQ", RecRef ref <- content -> Just $ DataRequest $ refDigest ref | name == BC.pack "RSP", RecRef ref <- content -> Just $ DataResponse $ refDigest ref | name == BC.pack "ANN", RecRef ref <- content -> Just $ AnnounceSelf $ refDigest ref @@ -344,17 +356,17 @@ processOutgoing gs@GlobalState {..} = do RequestConnection addr -> do _ <- getConnection gs addr identity <- readTVar gIdentity - let packet = BL.toStrict $ serializeObject $ transportToObject gStorage $ TransportHeader + let packet = BL.toStrict $ serializeObject $ transportToObject gStorage $ TransportHeader $ [ AnnounceSelf $ refDigest $ storedRef $ idData identity - ] + ] ++ map ProtocolVersion protocolVersions writeFlow gDataFlow (addr, packet) return $ return () SendAnnounce addr -> do identity <- readTVar gIdentity - let packet = BL.toStrict $ serializeObject $ transportToObject gStorage $ TransportHeader + let packet = BL.toStrict $ serializeObject $ transportToObject gStorage $ TransportHeader $ [ AnnounceSelf $ refDigest $ storedRef $ idData identity - ] + ] ++ map ProtocolVersion protocolVersions writeFlow gDataFlow (addr, packet) return $ return () |