summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/Erebos/Network.hs25
-rw-r--r--src/Erebos/Network/Protocol.hs27
2 files changed, 36 insertions, 16 deletions
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
index 744c476..cc111e2 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -108,7 +108,7 @@ defaultServerOptions = ServerOptions
data Peer = Peer
{ peerAddress :: PeerAddress
, peerServer_ :: Server
- , peerConnection :: TVar (Either [(Bool, TransportPacket Ref, [TransportHeaderItem])] (Connection PeerAddress))
+ , peerConnection :: TVar (Either [(SecurityRequirement, TransportPacket Ref, [TransportHeaderItem])] (Connection PeerAddress))
, peerIdentityVar :: TVar PeerIdentity
, peerStorage_ :: Storage
, peerInStorage :: PartialStorage
@@ -391,13 +391,17 @@ instance MonadFail PacketHandler where
runPacketHandler :: Bool -> Peer -> PacketHandler () -> STM ()
runPacketHandler secure peer@Peer {..} act = do
let logd = writeTQueue $ serverErrorLog peerServer_
- runExceptT (flip execStateT (PacketHandlerState peer [] [] []) $ unPacketHandler act) >>= \case
+ runExceptT (flip execStateT (PacketHandlerState peer [] [] [] False) $ unPacketHandler act) >>= \case
Left err -> do
logd $ "Error in handling packet from " ++ show peerAddress ++ ": " ++ err
Right ph -> do
when (not $ null $ phHead ph) $ do
let packet = TransportPacket (TransportHeader $ phHead ph) (phBody ph)
- sendToPeerS' secure peer (phAckedBy ph) packet
+ secreq = case (secure, phPlaintextReply ph) of
+ (True, _) -> EncryptedOnly
+ (False, False) -> PlaintextAllowed
+ (False, True) -> PlaintextOnly
+ sendToPeerS' secreq peer (phAckedBy ph) packet
liftSTM :: STM a -> PacketHandler a
liftSTM = PacketHandler . lift . lift
@@ -416,6 +420,7 @@ data PacketHandlerState = PacketHandlerState
, phHead :: [TransportHeaderItem]
, phAckedBy :: [TransportHeaderItem]
, phBody :: [Ref]
+ , phPlaintextReply :: Bool
}
addHeader :: TransportHeaderItem -> PacketHandler ()
@@ -427,6 +432,9 @@ addAckedBy hs = modify $ \ph -> ph { phAckedBy = foldr appendDistinct (phAckedBy
addBody :: Ref -> PacketHandler ()
addBody r = modify $ \ph -> ph { phBody = r `appendDistinct` phBody ph }
+keepPlaintextReply :: PacketHandler ()
+keepPlaintextReply = modify $ \ph -> ph { phPlaintextReply = True }
+
openStream :: PacketHandler RawStreamWriter
openStream = do
Peer {..} <- gets phPeer
@@ -489,6 +497,11 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs =
partialRefFromDigest (peerInStorage peer) dgst
addHeader $ DataResponse dgst
addAckedBy [ Acknowledged dgst, Rejected dgst ]
+
+ -- Plaintext request may indicate the peer has restarted/changed or
+ -- otherwise lost the channel, so keep the reply plaintext as well.
+ when (not secure) keepPlaintextReply
+
let bytes = lazyLoadBytes mref
-- TODO: MTU
if (secure && BL.length bytes > 500)
@@ -762,17 +775,17 @@ sendToPeerList peer parts = do
ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- dgsts ]
liftIO $ atomically $ sendToPeerS peer ackedBy packet
-sendToPeerS' :: Bool -> Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM ()
+sendToPeerS' :: SecurityRequirement -> Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM ()
sendToPeerS' secure Peer {..} ackedBy packet = do
readTVar peerConnection >>= \case
Left xs -> writeTVar peerConnection $ Left $ (secure, packet, ackedBy) : xs
Right conn -> writeFlow (connData conn) (secure, packet, ackedBy)
sendToPeerS :: Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM ()
-sendToPeerS = sendToPeerS' True
+sendToPeerS = sendToPeerS' EncryptedOnly
sendToPeerPlain :: Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM ()
-sendToPeerPlain = sendToPeerS' False
+sendToPeerPlain = sendToPeerS' PlaintextAllowed
sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m ()
sendToPeerWith peer fobj = do
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