summaryrefslogtreecommitdiff
path: root/src/Network.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2019-05-17 23:43:14 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2019-05-20 22:20:13 +0200
commit75cf4c130cc21afd4d569ce0291c2656de162908 (patch)
tree88c216d183f59da1ec9a55d773411c4649d5ec43 /src/Network.hs
parentf609499402160aa908e6435b8a61f7cb1f258cfe (diff)
Encrypted channels negotiated with DH
Diffstat (limited to 'src/Network.hs')
-rw-r--r--src/Network.hs213
1 files changed, 154 insertions, 59 deletions
diff --git a/src/Network.hs b/src/Network.hs
index f294835..1056265 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -11,12 +11,15 @@ import Control.Monad.Except
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
+import qualified Data.Map as M
import qualified Data.Text as T
import Network.Socket
import Network.Socket.ByteString (recvFrom, sendTo)
+import Channel
import Identity
+import PubKey
import Storage
@@ -25,8 +28,9 @@ discoveryPort = "29665"
data Peer = Peer
- { peerIdentity :: Stored Identity
- , peerAddress :: PeerAddress
+ { peerAddress :: PeerAddress
+ , peerIdentity :: Maybe (Stored Identity)
+ , peerChannels :: [Channel]
}
deriving (Show)
@@ -37,6 +41,8 @@ data PeerAddress = DatagramAddress SockAddr
data TransportHeader = AnnouncePacket Ref
| IdentityRequest Ref Ref
| IdentityResponse Ref
+ | TrChannelRequest Ref
+ | TrChannelAccept Ref
transportToObject :: TransportHeader -> Object
transportToObject = \case
@@ -53,6 +59,14 @@ transportToObject = \case
[ (BC.pack "TRANS", RecText $ T.pack "idresp")
, (BC.pack "identity", RecRef ref)
]
+ TrChannelRequest ref -> Rec
+ [ (BC.pack "TRANS", RecText $ T.pack "chreq")
+ , (BC.pack "req", RecRef ref)
+ ]
+ TrChannelAccept ref -> Rec
+ [ (BC.pack "TRANS", RecText $ T.pack "chacc")
+ , (BC.pack "acc", RecRef ref)
+ ]
transportFromObject :: Object -> Maybe TransportHeader
transportFromObject (Rec items)
@@ -69,71 +83,152 @@ transportFromObject (Rec items)
, Just (RecRef ref) <- lookup (BC.pack "identity") items
= Just $ IdentityResponse ref
+ | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chreq"
+ , Just (RecRef ref) <- lookup (BC.pack "req") items
+ = Just $ TrChannelRequest ref
+
+ | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "chacc"
+ , Just (RecRef ref) <- lookup (BC.pack "acc") items
+ = Just $ TrChannelAccept ref
+
transportFromObject _ = Nothing
peerDiscovery :: String -> Stored Identity -> IO (Chan Peer)
peerDiscovery bhost sidentity = do
- chan <- newChan
+ chanPeer <- newChan
+ peers <- newMVar M.empty
+
+ let open addr = do
+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+ setSocketOption sock ReuseAddr 1
+ setSocketOption sock Broadcast 1
+ setCloseOnExecIfNeeded =<< fdSocket sock
+ bind sock (addrAddress addr)
+ return sock
+
+ loop sock = do
+ baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
+ void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr)
+ forever $ do
+ (msg, paddr) <- recvFrom sock 4096
+ let packet' = packet sock paddr
+ case runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg of
+ Left err -> putStrLn $ show paddr ++ ": " ++ err
+ Right (obj:objs) | Just tpack <- transportFromObject obj -> packet' tpack objs
+ _ -> putStrLn $ show paddr ++ ": invalid transport packet"
+
+ packet sock paddr (AnnouncePacket ref) _ = do
+ putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show paddr
+ when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat
+ [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
+ , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
+ ]) paddr
+
+ packet _ paddr (IdentityRequest ref from) [] = do
+ putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content"
+
+ packet sock paddr (IdentityRequest ref from) (obj:objs) = do
+ putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr
+ print (obj:objs)
+ from' <- store (storedStorage sidentity) obj
+ if from == from'
+ then do forM_ objs $ store $ storedStorage sidentity
+ let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) []
+ modifyMVar_ peers $ return . M.insert paddr peer
+ writeChan chanPeer peer
+ void $ sendTo sock (BL.toStrict $ BL.concat
+ [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
+ , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
+ ]) paddr
+ else putStrLn $ "Mismatched content"
+
+ packet _ paddr (IdentityResponse ref) [] = do
+ putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content"
+
+ packet sock paddr (IdentityResponse ref) (obj:objs) = do
+ putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr
+ print (obj:objs)
+ ref' <- store (storedStorage sidentity) obj
+ if ref == ref'
+ then do forM_ objs $ store $ storedStorage sidentity
+ let pidentity = wrappedLoad ref
+ peer = Peer (DatagramAddress paddr) (Just pidentity) []
+ modifyMVar_ peers $ return . M.insert paddr peer
+ writeChan chanPeer peer
+ req <- createChannelRequest sidentity pidentity
+ void $ sendTo sock (BL.toStrict $ BL.concat
+ [ serializeObject $ transportToObject $ TrChannelRequest (storedRef req)
+ , lazyLoadBytes $ storedRef req
+ , lazyLoadBytes $ storedRef $ signedData $ fromStored req
+ , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
+ , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
+ ]) paddr
+ else putStrLn $ "Mismatched content"
+
+ packet _ paddr (TrChannelRequest _) [] = do
+ putStrLn $ "Got channel request: from " ++ show paddr ++ " without content"
+
+ packet sock paddr (TrChannelRequest ref) (obj:objs) = do
+ putStrLn $ "Got channel request: from " ++ show paddr
+ print (obj:objs)
+ ref' <- store (storedStorage sidentity) obj
+ if ref == ref'
+ then do forM_ objs $ store $ storedStorage sidentity
+ let request = wrappedLoad ref :: Stored ChannelRequest
+ modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
+ Just peer | Just pid <- peerIdentity peer ->
+ runExceptT (acceptChannelRequest sidentity pid request) >>= \case
+ Left errs -> do mapM_ putStrLn ("Invalid channel request" : errs)
+ return pval
+ Right (acc, channel) -> do
+ putStrLn $ "Got channel: " ++ show (storedRef channel)
+ let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
+ writeChan chanPeer peer'
+ void $ sendTo sock (BL.toStrict $ BL.concat
+ [ serializeObject $ transportToObject $ TrChannelAccept (storedRef acc)
+ , lazyLoadBytes $ storedRef acc
+ , lazyLoadBytes $ storedRef $ signedData $ fromStored acc
+ , lazyLoadBytes $ storedRef $ caKey $ fromStored $ signedData $ fromStored acc
+ , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored acc
+ ]) paddr
+ return $ M.insert paddr peer' pval
+
+ _ -> do putStrLn $ "Invalid channel request - no peer identity"
+ return pval
+ else putStrLn $ "Mismatched content"
+
+ packet _ paddr (TrChannelAccept _) [] = do
+ putStrLn $ "Got channel accept: from " ++ show paddr ++ " without content"
+
+ packet _ paddr (TrChannelAccept ref) (obj:objs) = do
+ putStrLn $ "Got channel accept: from " ++ show paddr
+ print (obj:objs)
+ ref' <- store (storedStorage sidentity) obj
+ if ref == ref'
+ then do forM_ objs $ store $ storedStorage sidentity
+ let accepted = wrappedLoad ref :: Stored ChannelAccept
+ modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
+ Just peer | Just pid <- peerIdentity peer ->
+ runExceptT (acceptedChannel sidentity pid accepted) >>= \case
+ Left errs -> do mapM_ putStrLn ("Invalid channel accept" : errs)
+ return pval
+ Right channel -> do
+ putStrLn $ "Got channel: " ++ show (storedRef channel)
+ let peer' = peer { peerChannels = fromStored channel : peerChannels peer }
+ writeChan chanPeer peer'
+ return $ M.insert paddr peer' pval
+ _ -> do putStrLn $ "Invalid channel accept - no peer identity"
+ return pval
+
+ else putStrLn $ "Mismatched content"
+
void $ forkIO $ withSocketsDo $ do
let hints = defaultHints
{ addrFlags = [AI_PASSIVE]
, addrSocketType = Datagram
}
addr:_ <- getAddrInfo (Just hints) Nothing (Just discoveryPort)
- bracket (open addr) close (loop chan)
- return chan
- where
- open addr = do
- sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
- setSocketOption sock ReuseAddr 1
- setSocketOption sock Broadcast 1
- setCloseOnExecIfNeeded =<< fdSocket sock
- bind sock (addrAddress addr)
- return sock
-
- loop chan sock = do
- baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort)
- void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ AnnouncePacket $ storedRef sidentity) (addrAddress baddr)
- forever $ do
- (msg, peer) <- recvFrom sock 4096
- let packet' = packet chan sock peer
- case runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg of
- Left err -> putStrLn $ show peer ++ ": " ++ err
- Right (obj:objs) | Just tpack <- transportFromObject obj -> packet' tpack objs
- _ -> putStrLn $ show peer ++ ": invalid transport packet"
-
- packet _ sock peer (AnnouncePacket ref) _ = do
- putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show peer
- when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat
- [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
- , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
- ]) peer
-
- packet _ _ peer (IdentityRequest ref from) [] = do
- putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer ++ " without content"
-
- packet chan sock peer (IdentityRequest ref from) (obj:objs) = do
- putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer
- print (obj:objs)
- from' <- store (storedStorage sidentity) obj
- if from == from'
- then do forM_ objs $ store $ storedStorage sidentity
- writeChan chan $ Peer (wrappedLoad from) (DatagramAddress peer)
- void $ sendTo sock (BL.toStrict $ BL.concat
- [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
- , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
- ]) peer
- else putStrLn $ "Mismatched content"
-
- packet _ _ peer (IdentityResponse ref) [] = do
- putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer ++ " without content"
-
- packet chan _ peer (IdentityResponse ref) (obj:objs) = do
- putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer
- print (obj:objs)
- ref' <- store (storedStorage sidentity) obj
- if ref == ref'
- then do forM_ objs $ store $ storedStorage sidentity
- writeChan chan $ Peer (wrappedLoad ref) (DatagramAddress peer)
- else putStrLn $ "Mismatched content"
+ bracket (open addr) close loop
+
+ return chanPeer