From 0f8561a997952a76a92919e527b6bc05ade8ee65 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 19 Oct 2019 23:07:04 +0200 Subject: Network rewrite with data request and ack Packet header is now composed of individual header items, which can be combined in various ways. Received data is properly acknowledged and missing objects can be requested using hashes. --- src/Main.hs | 74 +++++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 52 insertions(+), 22 deletions(-) (limited to 'src/Main.hs') diff --git a/src/Main.hs b/src/Main.hs index 2a04796..d473f2e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,11 +1,16 @@ module Main (main) where +import Control.Arrow (first) import Control.Concurrent import Control.Monad +import Control.Monad.Except +import Control.Monad.Fail import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Maybe +import Crypto.Random + import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import Data.Char @@ -68,14 +73,15 @@ interactiveLoop st bhost = runInputT defaultSettings $ do peers <- liftIO $ newMVar [] void $ liftIO $ forkIO $ void $ forever $ do - peer@Peer { peerAddress = DatagramAddress addr } <- readChan chanPeer - extPrint $ show addr ++ "\n" - extPrintLn $ maybe "" (T.unpack . displayIdentity) $ peerIdentity peer - let update [] = [peer] - update (p:ps) | peerIdentity p == peerIdentity peer = peer : ps - | otherwise = p : update ps - when (isJust $ peerIdentity peer) $ - modifyMVar_ peers (return . update) + peer <- readChan chanPeer + let update [] = ([peer], Nothing) + update (p:ps) | peerIdentityRef p == peerIdentityRef peer = (peer : ps, Just p) + | otherwise = first (p:) $ update ps + if | PeerIdentityUnknown <- peerIdentity peer -> return () + | otherwise -> do + op <- modifyMVar peers (return . update) + let shown = showPeer peer + when (Just shown /= (showPeer <$> op)) $ extPrint shown tzone <- liftIO $ getCurrentTimeZone void $ liftIO $ forkIO $ forever $ readChan chanSvc >>= \case @@ -84,7 +90,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do let smsg = wrappedLoad ref msg = fromStored smsg extPrintLn $ formatMessage tzone msg - if | Just powner <- finalOwner <$> peerIdentity peer + if | PeerIdentityFull powner <- peerOwner peer , idData powner == msgFrom msg -> updateLocalState_ st $ \erb -> do slist <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of @@ -102,22 +108,30 @@ interactiveLoop st bhost = runInputT defaultSettings $ do '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLines ">> " _ -> return input - let process cstate = do + let process :: CommandState -> MaybeT (InputT IO) CommandState + process cstate = do let pname = case csPeer cstate of Nothing -> "" - Just peer -> maybe "" T.unpack $ idName . finalOwner <=< peerIdentity $ peer + Just peer -> case peerOwner peer of + PeerIdentityFull pid -> maybe "" T.unpack $ idName pid + PeerIdentityRef wref -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">" + PeerIdentityUnknown -> "" input <- getInputLines $ pname ++ "> " - let (cmd, line) = case input of + let (CommandM cmd, line) = case input of '/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest in if all isDigit scmd then (cmdSetPeer $ read scmd, args) else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args) _ -> (cmdSend, input) - liftIO $ flip execStateT cstate $ runReaderT cmd CommandInput + res <- liftIO $ runExceptT $ flip execStateT cstate $ runReaderT cmd CommandInput { ciSelf = self , ciLine = line , ciPeers = liftIO $ readMVar peers } + case res of + Right cstate' -> return cstate' + Left err -> do lift $ lift $ extPrint $ "Error: " ++ err + return cstate let loop (Just cstate) = runMaybeT (process cstate) >>= loop loop Nothing = return () @@ -134,7 +148,15 @@ data CommandState = CommandState { csPeer :: Maybe Peer } -type CommandM a = ReaderT CommandInput (StateT CommandState IO) a +newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader CommandInput, MonadState CommandState, MonadError String) + +instance MonadFail CommandM where + fail = throwError + +instance MonadRandom CommandM where + getRandomBytes = liftIO . getRandomBytes + type Command = CommandM () commands :: [(String, Command)] @@ -152,7 +174,16 @@ cmdPeers :: Command cmdPeers = do peers <- join $ asks ciPeers forM_ (zip [1..] peers) $ \(i :: Int, p) -> do - liftIO $ putStrLn $ show i ++ ": " ++ maybe "" (T.unpack . displayIdentity) (peerIdentity p) + liftIO $ putStrLn $ show i ++ ": " ++ showPeer p + +showPeer :: Peer -> String +showPeer peer = + let name = case peerIdentity peer of + PeerIdentityUnknown -> "" + PeerIdentityRef wref -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">" + PeerIdentityFull pid -> T.unpack $ displayIdentity pid + DatagramAddress addr = peerAddress peer + in name ++ " [" ++ show addr ++ "]" cmdSetPeer :: Int -> Command cmdSetPeer n | n < 1 = liftIO $ putStrLn "Invalid peer index" @@ -160,12 +191,11 @@ cmdSetPeer n | n < 1 = liftIO $ putStrLn "Invalid peer index" modify $ \s -> s { csPeer = listToMaybe $ drop (n - 1) peers } cmdSend :: Command -cmdSend = void $ runMaybeT $ do +cmdSend = void $ do self <- asks ciSelf let st = storedStorage $ idData self Just peer <- gets csPeer - Just powner <- return $ finalOwner <$> peerIdentity peer - _:_ <- return $ peerChannels peer + PeerIdentityFull powner <- return $ peerOwner peer text <- asks ciLine smsg <- liftIO $ updateLocalState st $ \erb -> do (slist, smsg) <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of @@ -177,17 +207,17 @@ cmdSend = void $ runMaybeT $ do (,smsg) <$> slistAddS thread' (lsMessages $ fromStored erb) erb' <- wrappedStore st (fromStored erb) { lsMessages = slist } return (erb', smsg) - liftIO $ sendToPeer self peer (T.pack "dmsg") smsg + sendToPeer self peer (T.pack "dmsg") smsg tzone <- liftIO $ getCurrentTimeZone liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg cmdHistory :: Command -cmdHistory = void $ runMaybeT $ do +cmdHistory = void $ do self <- asks ciSelf let st = storedStorage $ idData self Just peer <- gets csPeer - Just powner <- return $ finalOwner <$> peerIdentity peer + PeerIdentityFull powner <- return $ peerOwner peer Just erebosHead <- liftIO $ loadHead st "erebos" let erebos = wrappedLoad (headRef erebosHead) @@ -196,7 +226,7 @@ cmdHistory = void $ runMaybeT $ do liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread cmdUpdateIdentity :: Command -cmdUpdateIdentity = void $ runMaybeT $ do +cmdUpdateIdentity = void $ do st <- asks $ storedStorage . idData . ciSelf liftIO $ updateIdentity st -- cgit v1.2.3