summaryrefslogtreecommitdiff
path: root/src/Network/Protocol.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-09-12 22:08:54 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2023-09-16 09:58:13 +0200
commit07893b2edd6f872f9549b3e0eb5443208cdea66a (patch)
treefdb18dd8b6b478c6a0a021a4c342fcfe6a64154a /src/Network/Protocol.hs
parente6a5ec99e0f94ec33c0e52e6cf64cfbb7f7d5e97 (diff)
Protocol: use cookies during whole plaintext phase
Diffstat (limited to 'src/Network/Protocol.hs')
-rw-r--r--src/Network/Protocol.hs134
1 files changed, 89 insertions, 45 deletions
diff --git a/src/Network/Protocol.hs b/src/Network/Protocol.hs
index dc33296..e286a67 100644
--- a/src/Network/Protocol.hs
+++ b/src/Network/Protocol.hs
@@ -59,6 +59,7 @@ protocolVersions = [protocolVersion]
data TransportPacket a = TransportPacket TransportHeader [a]
data TransportHeader = TransportHeader [TransportHeaderItem]
+ deriving (Show)
data TransportHeaderItem
= Acknowledged RefDigest
@@ -75,10 +76,10 @@ data TransportHeaderItem
| TrChannelAccept RefDigest
| ServiceType ServiceID
| ServiceRef RefDigest
- deriving (Eq)
+ deriving (Eq, Show)
newtype Cookie = Cookie ByteString
- deriving (Eq)
+ deriving (Eq, Show)
transportToObject :: PartialStorage -> TransportHeader -> PartialObject
transportToObject st (TransportHeader items) = Rec $ map single items
@@ -171,11 +172,12 @@ wrDigest = refDigest . wrefPartial
data ChannelState = ChannelNone
- | ChannelCookieWait
- | ChannelCookieReceived Cookie
- | ChannelOurRequest (Stored ChannelRequest)
- | ChannelPeerRequest WaitingRef
- | ChannelOurAccept (Stored ChannelAccept) Channel
+ | ChannelCookieWait -- sent initiation, waiting for response
+ | ChannelCookieReceived Cookie -- received cookie, but no cookie echo yet
+ | ChannelCookieConfirmed Cookie -- received cookie echo, no need to send from our side
+ | ChannelOurRequest (Maybe Cookie) (Stored ChannelRequest)
+ | ChannelPeerRequest (Maybe Cookie) WaitingRef
+ | ChannelOurAccept (Maybe Cookie) (Stored ChannelAccept) Channel
| ChannelEstablished Channel
@@ -272,9 +274,9 @@ processIncoming gs@GlobalState {..} = do
mbch <- case mbconn of
Nothing -> return Nothing
Just conn -> readTVar (cChannel conn) >>= return . \case
- ChannelEstablished ch -> Just ch
- ChannelOurAccept _ ch -> Just ch
- _ -> Nothing
+ ChannelEstablished ch -> Just ch
+ ChannelOurAccept _ _ ch -> Just ch
+ _ -> Nothing
return $ do
let deserialize = liftEither . runExcept . deserializeObjects gStorage . BL.fromStrict
@@ -324,9 +326,43 @@ processIncoming gs@GlobalState {..} = do
processPacket :: GlobalState addr -> Either addr (Connection addr) -> Bool -> TransportPacket a -> IO (Maybe (Connection addr, Maybe (TransportPacket a)))
processPacket gs@GlobalState {..} econn secure packet@(TransportPacket (TransportHeader header) _) = if
+ -- Established secure communication
| Right conn <- econn, secure
-> return $ Just (conn, Just packet)
+ -- Plaintext communication with cookies to prove origin
+ | cookie:_ <- mapMaybe (\case CookieEcho x -> Just x; _ -> Nothing) header
+ -> verifyCookie gs addr cookie >>= \case
+ True -> do
+ atomically $ do
+ conn@Connection {..} <- getConnection gs addr
+ channel <- readTVar cChannel
+ let received = listToMaybe $ mapMaybe (\case CookieSet x -> Just x; _ -> Nothing) header
+ case received `mplus` channelCurrentCookie channel of
+ Just current -> do
+ cookieEchoReceived gs conn mbpid current
+ return $ Just (conn, Just packet)
+ Nothing -> do
+ gLog $ show addr <> ": missing cookie set, dropping " <> show header
+ return $ Nothing
+
+ False -> do
+ atomically $ gLog $ show addr <> ": cookie verification failed, dropping " <> show header
+ return Nothing
+
+ -- Response to initiation packet
+ | cookie:_ <- mapMaybe (\case CookieSet x -> Just x; _ -> Nothing) header
+ , Just _ <- version
+ , Right conn@Connection {..} <- econn
+ -> do
+ atomically $ readTVar cChannel >>= \case
+ ChannelCookieWait -> do
+ writeTVar cChannel $ ChannelCookieReceived cookie
+ writeFlow gControlFlow (NewConnection conn mbpid)
+ return $ Just (conn, Nothing)
+ _ -> return Nothing
+
+ -- Initiation packet
| _:_ <- mapMaybe (\case Initiation x -> Just x; _ -> Nothing) header
, Just ver <- version
-> do
@@ -341,33 +377,7 @@ processPacket gs@GlobalState {..} econn secure packet@(TransportPacket (Transpor
writeFlow gDataFlow (addr, reply)
return Nothing
- | cookie:_ <- mapMaybe (\case CookieSet x -> Just x; _ -> Nothing) header
- , Just _ <- version
- , Right conn@Connection {..} <- econn
- -> do
- atomically $ readTVar cChannel >>= \case
- ChannelCookieWait -> do
- writeTVar cChannel $ ChannelCookieReceived cookie
- writeFlow gControlFlow (NewConnection conn mbpid)
- return $ Just (conn, Nothing)
- _ -> return Nothing
-
- | Right conn <- econn
- -> return $ Just (conn, Just packet)
-
- | cookie:_ <- mapMaybe (\case CookieEcho x -> Just x; _ -> Nothing) header
- , Just _ <- version
- -> verifyCookie gs addr cookie >>= \case
- True -> do
- conn <- atomically $ findConnection gs addr >>= \case
- Just conn -> return conn
- Nothing -> do
- conn <- newConnection gs addr
- writeFlow gControlFlow (NewConnection conn mbpid)
- return conn
- return $ Just (conn, Just packet)
- False -> return Nothing
-
+ -- Announce packet outside any connection
| dgst:_ <- mapMaybe (\case AnnounceSelf x -> Just x; _ -> Nothing) header
, Just _ <- version
-> do
@@ -377,13 +387,46 @@ processPacket gs@GlobalState {..} econn secure packet@(TransportPacket (Transpor
writeFlow gControlFlow $ ReceivedAnnounce addr dgst
return Nothing
- | otherwise -> return Nothing
+ | otherwise -> do
+ atomically $ gLog $ show addr <> ": dropping packet " <> show header
+ return Nothing
where
addr = either id cAddress econn
mbpid = listToMaybe $ mapMaybe (\case AnnounceSelf dgst -> Just dgst; _ -> Nothing) header
version = listToMaybe $ filter (\v -> ProtocolVersion v `elem` header) protocolVersions
+channelCurrentCookie :: ChannelState -> Maybe Cookie
+channelCurrentCookie = \case
+ ChannelCookieReceived cookie -> Just cookie
+ ChannelCookieConfirmed cookie -> Just cookie
+ ChannelOurRequest mbcookie _ -> mbcookie
+ ChannelPeerRequest mbcookie _ -> mbcookie
+ ChannelOurAccept mbcookie _ _ -> mbcookie
+ _ -> Nothing
+
+cookieEchoReceived :: GlobalState addr -> Connection addr -> Maybe RefDigest -> Cookie -> STM ()
+cookieEchoReceived GlobalState {..} conn@Connection {..} mbpid cookieSet = do
+ readTVar cChannel >>= \case
+ ChannelNone -> newConn
+ ChannelCookieWait -> newConn
+ ChannelCookieReceived {} -> update
+ _ -> return ()
+ where
+ update = do
+ writeTVar cChannel $ ChannelCookieConfirmed cookieSet
+ newConn = do
+ update
+ writeFlow gControlFlow (NewConnection conn mbpid)
+
+generateCookieHeaders :: GlobalState addr -> addr -> ChannelState -> IO [TransportHeaderItem]
+generateCookieHeaders gs addr ch = catMaybes <$> sequence [ echoHeader, setHeader ]
+ where
+ echoHeader = return $ CookieEcho <$> channelCurrentCookie ch
+ setHeader = case ch of
+ ChannelCookieWait {} -> Just . CookieSet <$> createCookie gs addr
+ ChannelCookieReceived {} -> Just . CookieSet <$> createCookie gs addr
+ _ -> return Nothing
createCookie :: GlobalState addr -> addr -> IO Cookie
createCookie GlobalState {} addr = return (Cookie $ BC.pack $ show addr)
@@ -430,15 +473,16 @@ processOutgoing gs@GlobalState {..} = do
when (isNothing mbch && secure) $ do
writeTQueue cSecureOutQueue (secure, packet, ackedBy)
- header <- readTVar cChannel >>= return . TransportHeader . \case
- ChannelCookieReceived cookie -> CookieEcho cookie : ProtocolVersion protocolVersion : hitems
- _ -> hitems
-
- let plain = BL.concat $
- (serializeObject $ transportToObject gStorage header)
- : map lazyLoadBytes content
+ channel <- readTVar cChannel
return $ do
+ cookieHeaders <- generateCookieHeaders gs cAddress channel
+ let header = TransportHeader $ cookieHeaders ++ hitems
+
+ let plain = BL.concat $
+ (serializeObject $ transportToObject gStorage header)
+ : map lazyLoadBytes content
+
mbs <- case mbch of
Just ch -> do
runExceptT (channelEncrypt ch $ BL.toStrict $ 0x00 `BL.cons` plain) >>= \case