From e4fd563f40bacce33712a84e0b275feb1881ea28 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 13 Aug 2023 18:38:09 +0200
Subject: Network: send protocol version with announce

---
 src/Network.hs          |  2 ++
 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 ()
 
-- 
cgit v1.2.3