From 8a03527dba479b520ebda47cdf00080d82d4e933 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Thu, 2 May 2019 22:55:09 +0200 Subject: Basic local network peer discovery --- erebos.cabal | 5 ++- src/Identity.hs | 22 +++++++++ src/Main.hs | 34 +++++++++++++- src/Network.hs | 137 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 195 insertions(+), 3 deletions(-) create mode 100644 src/Identity.hs create mode 100644 src/Network.hs diff --git a/erebos.cabal b/erebos.cabal index a276519..b448914 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -17,7 +17,9 @@ cabal-version: >=1.10 executable erebos main-is: Main.hs - other-modules: Storage + other-modules: Identity, + Network, + Storage default-extensions: FlexibleContexts, FlexibleInstances, @@ -35,6 +37,7 @@ executable erebos filepath >=1.4 && <1.5, mime >= 0.4 && < 0.5, mtl >=2.2 && <2.3, + network >= 3.0 && <3.1, skein >= 1.0 && <1.1, tagged >= 0.8 && <0.9, text >= 1.2 && <1.3, diff --git a/src/Identity.hs b/src/Identity.hs new file mode 100644 index 0000000..76d0c97 --- /dev/null +++ b/src/Identity.hs @@ -0,0 +1,22 @@ +module Identity ( + Identity(..), +) where + +import Data.Text (Text) + +import Storage + +data Identity = Identity + { idName :: Text + , idPrev :: Maybe (Stored Identity) + } + deriving (Show) + +instance Storable Identity where + store' idt = storeRec $ do + storeText "name" $ idName idt + storeMbRef "prev" $ idPrev idt + + load' = loadRec $ Identity + <$> loadText "name" + <*> loadMbRef "prev" diff --git a/src/Main.hs b/src/Main.hs index 65ae4a0..017d70d 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,34 @@ -module Main where +module Main (main) where + +import Control.Concurrent.Chan +import Control.Exception +import Control.Monad + +import qualified Data.Text.IO as T + +import System.Environment +import System.IO +import System.IO.Error + +import Identity +import Network +import Storage + main :: IO () -main = putStrLn "Hello, Haskell!" +main = do + [bhost] <- getArgs + st <- openStorage "test" + idhead <- catchJust (guard . isDoesNotExistError) (loadHead st "identity") $ \_ -> do + putStr "Name: " + hFlush stdout + name <- T.getLine + let base = Identity name Nothing + Right h <- replaceHead base (Left (st, "identity")) + return h + let sidentity = wrappedLoad (headRef idhead) :: Stored Identity + print $ fromStored sidentity + + chan <- peerDiscovery bhost sidentity + void $ forever $ print =<< readChan chan + return () 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