Basic local network peer discovery

4 files changed, 195 insertions, 3 deletions

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"