summaryrefslogtreecommitdiff
path: root/src/Network.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network.hs')
-rw-r--r--src/Network.hs137
1 files changed, 137 insertions, 0 deletions
diff --git a/src/Network.hs b/src/Network.hs
new file mode 100644
index 0000000..6609667
--- /dev/null
+++ b/src/Network.hs
@@ -0,0 +1,137 @@
+module Network (
+ Peer(..),
+ PeerAddress,
+ peerDiscovery,
+) where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.Except
+
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+
+import Network.Socket
+import Network.Socket.ByteString (recvFrom, sendTo)
+
+import Identity
+import Storage
+
+
+discoveryPort :: ServiceName
+discoveryPort = "29665"
+
+
+data Peer = Peer
+ { peerIdentity :: Stored Identity
+ , peerAddress :: PeerAddress
+ }
+ deriving (Show)
+
+data PeerAddress = DatagramAddress SockAddr
+ deriving (Show)
+
+
+data TransportHeader = AnnouncePacket Ref
+ | IdentityRequest Ref Ref
+ | IdentityResponse Ref
+
+transportToObject :: TransportHeader -> Object
+transportToObject = \case
+ AnnouncePacket ref -> Rec
+ [ (BC.pack "TRANS", RecText $ T.pack "announce")
+ , (BC.pack "identity", RecRef ref)
+ ]
+ IdentityRequest ref from -> Rec
+ [ (BC.pack "TRANS", RecText $ T.pack "idreq")
+ , (BC.pack "identity", RecRef ref)
+ , (BC.pack "from", RecRef from)
+ ]
+ IdentityResponse ref -> Rec
+ [ (BC.pack "TRANS", RecText $ T.pack "idresp")
+ , (BC.pack "identity", RecRef ref)
+ ]
+
+transportFromObject :: Object -> Maybe TransportHeader
+transportFromObject (Rec items)
+ | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "announce"
+ , Just (RecRef ref) <- lookup (BC.pack "identity") items
+ = Just $ AnnouncePacket ref
+
+ | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "idreq"
+ , Just (RecRef ref) <- lookup (BC.pack "identity") items
+ , Just (RecRef from) <- lookup (BC.pack "from") items
+ = Just $ IdentityRequest ref from
+
+ | Just (RecText trans) <- lookup (BC.pack "TRANS") items, trans == T.pack "idresp"
+ , Just (RecRef ref) <- lookup (BC.pack "identity") items
+ = Just $ IdentityResponse ref
+
+transportFromObject _ = Nothing
+
+
+peerDiscovery :: String -> Stored Identity -> IO (Chan Peer)
+peerDiscovery bhost sidentity = do
+ chan <- newChan
+ 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
+ void $ sendTo sock (BL.toStrict $ BL.concat
+ [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity)
+ , lazyLoadBytes $ 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) objs@(obj:_) = do
+ putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show peer
+ print objs
+ from' <- store (storedStorage sidentity) obj
+ if from == from'
+ then do writeChan chan $ Peer (wrappedLoad from) (DatagramAddress peer)
+ void $ sendTo sock (BL.toStrict $ BL.concat
+ [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity)
+ , lazyLoadBytes $ 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) objs@(obj:_) = do
+ putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show peer
+ print objs
+ ref' <- store (storedStorage sidentity) obj
+ if ref == ref'
+ then writeChan chan $ Peer (wrappedLoad ref) (DatagramAddress peer)
+ else putStrLn $ "Mismatched content"