summaryrefslogtreecommitdiff
path: root/src/Erebos/Network
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2024-05-23 20:50:39 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2024-05-23 21:10:12 +0200
commite40317a3b43594c0629c8a0d1d569b4c8d55e2ae (patch)
tree68587223eae00467638cb4837687a644dc1afd48 /src/Erebos/Network
parent266f13f977e69dc3ed92b2c1bd52fc58354a0a7c (diff)
Plaintext data response to plaintext request
Diffstat (limited to 'src/Erebos/Network')
-rw-r--r--src/Erebos/Network/Protocol.hs27
1 files changed, 17 insertions, 10 deletions
diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs
index 6c974bd..27e05ba 100644
--- a/src/Erebos/Network/Protocol.hs
+++ b/src/Erebos/Network/Protocol.hs
@@ -3,6 +3,7 @@ module Erebos.Network.Protocol (
transportToObject,
TransportHeader(..),
TransportHeaderItem(..),
+ SecurityRequirement(..),
WaitingRef(..),
WaitingRefCallback,
@@ -93,6 +94,11 @@ data TransportHeaderItem
newtype Cookie = Cookie ByteString
deriving (Eq, Show)
+data SecurityRequirement = PlaintextOnly
+ | PlaintextAllowed
+ | EncryptedOnly
+ deriving (Eq, Ord)
+
isHeaderItemAcknowledged :: TransportHeaderItem -> Bool
isHeaderItemAcknowledged = \case
Acknowledged {} -> False
@@ -165,10 +171,10 @@ data GlobalState addr = (Eq addr, Show addr) => GlobalState
data Connection addr = Connection
{ cGlobalState :: GlobalState addr
, cAddress :: addr
- , cDataUp :: Flow (Bool, TransportPacket PartialObject) (Bool, TransportPacket Ref, [TransportHeaderItem])
- , cDataInternal :: Flow (Bool, TransportPacket Ref, [TransportHeaderItem]) (Bool, TransportPacket PartialObject)
+ , cDataUp :: Flow (Bool, TransportPacket PartialObject) (SecurityRequirement, TransportPacket Ref, [TransportHeaderItem])
+ , cDataInternal :: Flow (SecurityRequirement, TransportPacket Ref, [TransportHeaderItem]) (Bool, TransportPacket PartialObject)
, cChannel :: TVar ChannelState
- , cSecureOutQueue :: TQueue (Bool, TransportPacket Ref, [TransportHeaderItem])
+ , cSecureOutQueue :: TQueue (SecurityRequirement, TransportPacket Ref, [TransportHeaderItem])
, cMaxInFlightPackets :: TVar Int
, cReservedPackets :: TVar Int
, cSentPackets :: TVar [SentPacket]
@@ -180,7 +186,7 @@ data Connection addr = Connection
connAddress :: Connection addr -> addr
connAddress = cAddress
-connData :: Connection addr -> Flow (Bool, TransportPacket PartialObject) (Bool, TransportPacket Ref, [TransportHeaderItem])
+connData :: Connection addr -> Flow (Bool, TransportPacket PartialObject) (SecurityRequirement, TransportPacket Ref, [TransportHeaderItem])
connData = cDataUp
connGetChannel :: Connection addr -> STM ChannelState
@@ -734,13 +740,13 @@ processOutgoing gs@GlobalState {..} = do
| isJust mbch = do
acks <- readTVar cToAcknowledge
if null acks then retry
- else return ((True, TransportPacket (TransportHeader []) [], []), Nothing)
+ else return ((EncryptedOnly, TransportPacket (TransportHeader []) [], []), Nothing)
| otherwise = retry
((secure, packet@(TransportPacket (TransportHeader hitems) content), plainAckedBy), mbReserved) <-
checkOutstanding <|> checkDataInternal <|> checkAcknowledgements
- when (isNothing mbch && secure) $ do
+ when (isNothing mbch && secure >= EncryptedOnly) $ do
writeTQueue cSecureOutQueue (secure, packet, plainAckedBy)
acknowledge <- case mbch of
@@ -759,16 +765,17 @@ processOutgoing gs@GlobalState {..} = do
[] -> return ()
xs -> sequence_ $ map (streamAccepted conn) xs
- mbs <- case mbch of
- Just ch -> do
+ mbs <- case (secure, mbch) of
+ (PlaintextOnly, _) -> return $ Just (BL.toStrict plain, plainAckedBy)
+ (PlaintextAllowed, Nothing) -> return $ Just (BL.toStrict plain, plainAckedBy)
+ (_, Just ch) -> do
runExceptT (channelEncrypt ch $ BL.toStrict $ 0x00 `BL.cons` plain) >>= \case
Right (ctext, counter) -> do
let isAcked = any isHeaderItemAcknowledged hitems
return $ Just (0x80 `B.cons` ctext, if isAcked then [ AcknowledgedSingle $ fromIntegral counter ] else [])
Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ err
return Nothing
- Nothing | secure -> return Nothing
- | otherwise -> return $ Just (BL.toStrict plain, plainAckedBy)
+ (EncryptedOnly, Nothing) -> return Nothing
case mbs of
Just (bs, ackedBy) -> do