From 8a03527dba479b520ebda47cdf00080d82d4e933 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Thu, 2 May 2019 22:55:09 +0200
Subject: Basic local network peer discovery

---
 src/Network.hs | 137 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 137 insertions(+)
 create mode 100644 src/Network.hs

(limited to 'src/Network.hs')

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"
-- 
cgit v1.2.3