diff options
| -rw-r--r-- | src/Main.hs | 11 | ||||
| -rw-r--r-- | src/Network.hs | 38 |
2 files changed, 36 insertions, 13 deletions
diff --git a/src/Main.hs b/src/Main.hs index 6bd0967..5ce9f86 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -75,16 +75,15 @@ main = do interactiveLoop :: Storage -> String -> IO () interactiveLoop st bhost = runInputT defaultSettings $ do erebosHead <- liftIO $ loadLocalState st - let serebos = wrappedLoad (headRef erebosHead) :: Stored LocalState - Just self = verifyIdentity $ lsIdentity $ fromStored serebos - outputStrLn $ T.unpack $ displayIdentity self + outputStrLn $ T.unpack $ maybe (error "failed to verify local identity") displayIdentity $ + verifyIdentity $ lsIdentity $ fromStored $ wrappedLoad $ headRef erebosHead haveTerminalUI >>= \case True -> return () False -> error "Requires terminal" extPrint <- getExternalPrint let extPrintLn str = extPrint $ str ++ "\n"; chanPeer <- liftIO $ - startServer extPrintLn bhost self + startServer erebosHead extPrintLn bhost [ (T.pack "attach", SomeService (emptyServiceState :: AttachService)) , (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService)) ] @@ -123,8 +122,10 @@ interactiveLoop st bhost = runInputT defaultSettings $ do then (cmdSetPeer $ read scmd, args) else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args) _ -> (cmdSend, input) + curHead <- liftIO $ loadLocalState st res <- liftIO $ runExceptT $ flip execStateT cstate $ runReaderT cmd CommandInput - { ciSelf = self + { ciSelf = fromMaybe (error "failed to verify local identity") $ + verifyIdentity $ lsIdentity $ fromStored $ wrappedLoad $ headRef curHead , ciLine = line , ciPrint = extPrintLn , ciPeers = liftIO $ readMVar peers diff --git a/src/Network.hs b/src/Network.hs index 7d70d1d..0209853 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -28,12 +28,16 @@ import Channel import Identity import PubKey import Service +import State import Storage discoveryPort :: ServiceName discoveryPort = "29665" +announceIntervalSeconds :: Int +announceIntervalSeconds = 60 + data Peer = Peer { peerAddress :: PeerAddress @@ -150,13 +154,17 @@ receivedWaitingRef nref wr@(WaitingRef _ _ mvar) = do checkWaitingRef wr -startServer :: (String -> IO ()) -> String -> UnifiedIdentity -> [(T.Text, SomeService)] -> IO (Chan Peer) -startServer logd bhost identity services = do - let sidentity = idData identity +startServer :: Head -> (String -> IO ()) -> String -> [(T.Text, SomeService)] -> IO (Chan Peer) +startServer origHead logd bhost services = do + let storage = refStorage $ headRef origHead chanPeer <- newChan chanSvc <- newChan peers <- newMVar M.empty + Just self <- return $ verifyIdentity $ lsIdentity $ + fromStored $ wrappedLoad $ headRef origHead + midentity <- newMVar $ self + let open addr = do sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) setSocketOption sock ReuseAddr 1 @@ -166,9 +174,21 @@ startServer logd bhost identity services = do return sock loop sock = do - st <- derivePartialStorage $ storedStorage sidentity - baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort) - void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ TransportHeader [ AnnounceSelf $ partialRef st $ storedRef sidentity ]) (addrAddress baddr) + let announce identity = do + st <- derivePartialStorage storage + baddr:_ <- getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just bhost) (Just discoveryPort) + void $ sendTo sock (BL.toStrict $ serializeObject $ transportToObject $ TransportHeader [ AnnounceSelf $ partialRef st $ storedRef $ idData identity ]) (addrAddress baddr) + + void $ forkIO $ forever $ do + announce =<< readMVar midentity + threadDelay $ announceIntervalSeconds * 1000 * 1000 + + watchHead origHead $ \h -> do + idt <- modifyMVar midentity $ \cur -> do + return $ (\x -> (x,x)) $ fromMaybe cur $ verifyIdentity $ lsIdentity $ + fromStored $ wrappedLoad $ headRef h + announce idt + forever $ do (msg, paddr) <- recvFrom sock 4096 mbpeer <- M.lookup paddr <$> readMVar peers @@ -182,7 +202,7 @@ startServer logd bhost identity services = do -> return (peer, msg, False) | otherwise -> do - pst <- deriveEphemeralStorage $ storedStorage sidentity + pst <- deriveEphemeralStorage storage ist <- derivePartialStorage pst svcs <- newMVar M.empty let peer = Peer @@ -203,6 +223,7 @@ startServer logd bhost identity services = do Right (obj:objs) | Just header <- transportFromObject obj -> do forM_ objs $ storeObject $ peerInStorage peer + identity <- readMVar midentity handlePacket logd identity secure peer chanSvc header >>= \case Just peer' -> do modifyMVar_ peers $ return . M.insert paddr peer' @@ -236,7 +257,8 @@ startServer logd bhost identity services = do { svcPeer = peerId, svcPeerOwner = peerOwnerId , svcPrintOp = logd } - (rsp, s') <- handleServicePacket (storedStorage sidentity) inp s (wrappedLoad ref) + (rsp, s') <- handleServicePacket storage inp s (wrappedLoad ref) + identity <- readMVar midentity runExceptT (maybe (return ()) (sendToPeer identity peer svc) rsp) >>= \case Left err -> logd $ "failed to send response to peer: " ++ show err Right () -> return () |