summaryrefslogtreecommitdiff
path: root/src/Network.hs
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2019-05-19 22:19:15 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2019-05-22 20:50:01 +0200
commitb3dd410bb4ed093b74fe349d3a51a5767c76f952 (patch)
tree0a3e22be5d9632993ea436fef5b6e2767b64f715 /src/Network.hs
parent75cf4c130cc21afd4d569ce0291c2656de162908 (diff)
Direct message service basics
Diffstat (limited to 'src/Network.hs')
-rw-r--r--src/Network.hs66
1 files changed, 54 insertions, 12 deletions
diff --git a/src/Network.hs b/src/Network.hs
index 1056265..827f542 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -1,7 +1,8 @@
module Network (
Peer(..),
- PeerAddress,
- peerDiscovery,
+ PeerAddress(..),
+ startServer,
+ sendToPeer,
) where
import Control.Concurrent
@@ -31,6 +32,7 @@ data Peer = Peer
{ peerAddress :: PeerAddress
, peerIdentity :: Maybe (Stored Identity)
, peerChannels :: [Channel]
+ , peerSocket :: Socket
}
deriving (Show)
@@ -44,6 +46,8 @@ data TransportHeader = AnnouncePacket Ref
| TrChannelRequest Ref
| TrChannelAccept Ref
+data ServiceHeader = ServiceHeader T.Text Ref
+
transportToObject :: TransportHeader -> Object
transportToObject = \case
AnnouncePacket ref -> Rec
@@ -93,10 +97,24 @@ transportFromObject (Rec items)
transportFromObject _ = Nothing
+serviceToObject :: ServiceHeader -> Object
+serviceToObject (ServiceHeader svc ref) = Rec
+ [ (BC.pack "SVC", RecText svc)
+ , (BC.pack "ref", RecRef ref)
+ ]
+
+serviceFromObject :: Object -> Maybe ServiceHeader
+serviceFromObject (Rec items)
+ | Just (RecText svc) <- lookup (BC.pack "SVC") items
+ , Just (RecRef ref) <- lookup (BC.pack "ref") items
+ = Just $ ServiceHeader svc ref
+serviceFromObject _ = Nothing
-peerDiscovery :: String -> Stored Identity -> IO (Chan Peer)
-peerDiscovery bhost sidentity = do
+
+startServer :: String -> Stored Identity -> IO (Chan Peer, Chan (Peer, T.Text, Ref))
+startServer bhost sidentity = do
chanPeer <- newChan
+ chanSvc <- newChan
peers <- newMVar M.empty
let open addr = do
@@ -112,11 +130,20 @@ peerDiscovery bhost sidentity = do
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"
+ mbpeer <- M.lookup paddr <$> readMVar peers
+ if | Just peer <- mbpeer
+ , ch:_ <- peerChannels peer
+ , Just plain <- channelDecrypt ch msg
+ , Right (obj:objs) <- runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict plain
+ , Just (ServiceHeader svc ref) <- serviceFromObject obj
+ -> do forM_ objs $ store $ storedStorage sidentity
+ writeChan chanSvc (peer, svc, ref)
+
+ | Right (obj:objs) <- runExcept $ deserializeObjects (storedStorage sidentity) $ BL.fromStrict msg
+ , Just tpack <- transportFromObject obj
+ -> packet sock paddr tpack objs
+
+ | otherwise -> putStrLn $ show paddr ++ ": invalid packet"
packet sock paddr (AnnouncePacket ref) _ = do
putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show paddr
@@ -134,7 +161,7 @@ peerDiscovery bhost sidentity = do
from' <- store (storedStorage sidentity) obj
if from == from'
then do forM_ objs $ store $ storedStorage sidentity
- let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) []
+ let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad from) [] sock
modifyMVar_ peers $ return . M.insert paddr peer
writeChan chanPeer peer
void $ sendTo sock (BL.toStrict $ BL.concat
@@ -153,7 +180,7 @@ peerDiscovery bhost sidentity = do
if ref == ref'
then do forM_ objs $ store $ storedStorage sidentity
let pidentity = wrappedLoad ref
- peer = Peer (DatagramAddress paddr) (Just pidentity) []
+ peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock
modifyMVar_ peers $ return . M.insert paddr peer
writeChan chanPeer peer
req <- createChannelRequest sidentity pidentity
@@ -231,4 +258,19 @@ peerDiscovery bhost sidentity = do
addr:_ <- getAddrInfo (Just hints) Nothing (Just discoveryPort)
bracket (open addr) close loop
- return chanPeer
+ return (chanPeer, chanSvc)
+
+
+sendToPeer :: Storable a => Stored Identity -> Peer -> T.Text -> a -> IO ()
+sendToPeer self peer@Peer { peerChannels = ch:_ } svc obj = do
+ let st = storedStorage self
+ ref <- store st obj
+ let plain = BL.toStrict $ BL.concat
+ [ serializeObject $ serviceToObject $ ServiceHeader svc ref
+ , lazyLoadBytes ref
+ ]
+ ctext <- channelEncrypt ch plain
+ let DatagramAddress paddr = peerAddress peer
+ void $ sendTo (peerSocket peer) ctext paddr
+
+sendToPeer _ _ _ _ = putStrLn $ "No channel to peer"