From 3ed73a0e3ed70452f86e83b287e5bdb1548a867b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Wed, 5 Feb 2020 22:42:05 +0100
Subject: Network: add "rejected" header type
---
src/Network.hs | 54 ++++++++++++++++++++++++++++++++++--------------------
1 file changed, 34 insertions(+), 20 deletions(-)
diff --git a/src/Network.hs b/src/Network.hs
index eb319b2..2644af2 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -71,6 +71,7 @@ data PeerChannel = ChannelWait
data TransportHeaderItem
= Acknowledged PartialRef
+ | Rejected PartialRef
| DataRequest PartialRef
| DataResponse PartialRef
| AnnounceSelf PartialRef
@@ -86,6 +87,7 @@ transportToObject :: TransportHeader -> PartialObject
transportToObject (TransportHeader items) = Rec $ map single items
where single = \case
Acknowledged ref -> (BC.pack "ACK", RecRef ref)
+ Rejected ref -> (BC.pack "REJ", RecRef ref)
DataRequest ref -> (BC.pack "REQ", RecRef ref)
DataResponse ref -> (BC.pack "RSP", RecRef ref)
AnnounceSelf ref -> (BC.pack "ANN", RecRef ref)
@@ -101,6 +103,7 @@ transportFromObject (Rec items) = case catMaybes $ map single items of
titems -> Just $ TransportHeader titems
where single (name, content) = if
| name == BC.pack "ACK", RecRef ref <- content -> Just $ Acknowledged ref
+ | name == BC.pack "REJ", RecRef ref <- content -> Just $ Rejected ref
| name == BC.pack "REQ", RecRef ref <- content -> Just $ DataRequest ref
| name == BC.pack "RSP", RecRef ref <- content -> Just $ DataResponse ref
| name == BC.pack "ANN", RecRef ref <- content -> Just $ AnnounceSelf ref
@@ -254,7 +257,8 @@ startServer origHead logd bhost services = do
| Just header <- transportFromObject obj -> do
forM_ objs $ storeObject $ peerInStorage peer
identity <- readMVar midentity
- handlePacket logd identity secure peer chanSvc header >>= \case
+ let svcs = map someServiceID services
+ handlePacket logd identity secure peer chanSvc svcs header >>= \case
Just peer' -> do
modifyMVar_ peers $ return . M.insert paddr peer'
writeChan chanPeer peer'
@@ -317,9 +321,9 @@ addBody :: Ref -> PacketHandler ()
addBody r = modify $ \ph -> ph { phBody = r : phBody ph }
handlePacket :: (String -> IO ()) -> UnifiedIdentity -> Bool
- -> Peer -> Chan (Peer, ServiceID, Ref)
+ -> Peer -> Chan (Peer, ServiceID, Ref) -> [ServiceID]
-> TransportHeader -> IO (Maybe Peer)
-handlePacket logd identity secure opeer chanSvc (TransportHeader headers) = do
+handlePacket logd identity secure opeer chanSvc svcs (TransportHeader headers) = do
let sidentity = idData identity
DatagramAddress paddr = peerAddress opeer
plaintextRefs = map (refDigest . storedRef) $ concatMap (collectStoredObjects . wrappedLoad) $ concat
@@ -342,12 +346,16 @@ handlePacket logd identity secure opeer chanSvc (TransportHeader headers) = do
liftIO (loadLocalState $ storedStorage $ idData identity)
_ -> return ()
+ Rejected _ -> return ()
+
DataRequest ref
| secure || refDigest ref `elem` plaintextRefs -> do
Right mref <- copyRef (storedStorage sidentity) ref
addHeader $ DataResponse ref
addBody $ mref
- | otherwise -> throwError $ "unauthorized data request for " ++ show ref
+ | otherwise -> do
+ liftIO $ logd $ "unauthorized data request for " ++ show ref
+ addHeader $ Rejected ref
DataResponse ref -> do
liftIO (ioLoadBytes ref) >>= \case
@@ -387,39 +395,45 @@ handlePacket logd identity secure opeer chanSvc (TransportHeader headers) = do
_ -> return ()
TrChannelRequest reqref -> do
- addHeader $ Acknowledged reqref
pst <- gets $ peerStorage . phPeer
- let process = handleChannelRequest identity =<< newWaitingRef pst reqref
+ let process = do
+ addHeader $ Acknowledged reqref
+ handleChannelRequest identity =<< newWaitingRef pst reqref
+ reject = addHeader $ Rejected reqref
+
gets (peerChannel . phPeer) >>= \case
ChannelWait {} -> process
ChannelOurRequest our | refDigest reqref < refDigest (storedRef our) -> process
- | otherwise -> return ()
+ | otherwise -> reject
ChannelPeerRequest {} -> process
- ChannelOurAccept {} -> return ()
+ ChannelOurAccept {} -> reject
ChannelEstablished {} -> process
TrChannelAccept accref -> do
- addHeader $ Acknowledged accref
- let process = handleChannelAccept identity accref
+ let process = do
+ addHeader $ Acknowledged accref
+ handleChannelAccept identity accref
gets (peerChannel . phPeer) >>= \case
ChannelWait {} -> process
ChannelOurRequest {} -> process
ChannelPeerRequest {} -> process
ChannelOurAccept our _ | refDigest accref < refDigest (storedRef our) -> process
- | otherwise -> return ()
+ | otherwise -> addHeader $ Rejected accref
ChannelEstablished {} -> process
ServiceType _ -> return ()
ServiceRef pref
- | not secure -> throwError $ "service packet without secure channeel"
- | Just svc <- lookupServiceType headers -> do
- liftIO (ioLoadBytes pref) >>= \case
- Right _ -> do
- addHeader $ Acknowledged pref
- pst <- gets $ peerStorage . phPeer
- wref <- newWaitingRef pst pref
- updatePeer $ \p -> p { peerServiceQueue = (svc, wref) : peerServiceQueue p }
- Left _ -> throwError $ "missing service object " ++ show pref
+ | not secure -> throwError $ "service packet without secure channel"
+ | Just svc <- lookupServiceType headers -> if
+ | svc `elem` svcs -> do
+ liftIO (ioLoadBytes pref) >>= \case
+ Right _ -> do
+ addHeader $ Acknowledged pref
+ pst <- gets $ peerStorage . phPeer
+ wref <- newWaitingRef pst pref
+ updatePeer $ \p -> p { peerServiceQueue = (svc, wref) : peerServiceQueue p }
+ Left _ -> throwError $ "missing service object " ++ show pref
+ | otherwise -> addHeader $ Rejected pref
| otherwise -> throwError $ "service ref without type"
setupChannel identity
--
cgit v1.2.3