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.

1 files changed, 52 insertions, 22 deletions

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 "<noid>" (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 "<unnamed>" T.unpack $ idName . finalOwner <=< peerIdentity $ peer
+                             Just peer -> case peerOwner peer of
+                                 PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName pid
+                                 PeerIdentityRef wref -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
+                                 PeerIdentityUnknown  -> "<unknown>"
             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 "<noid>" (T.unpack . displayIdentity) (peerIdentity p)
+        liftIO $ putStrLn $ show i ++ ": " ++ showPeer p
+
+showPeer :: Peer -> String
+showPeer peer =
+    let name = case peerIdentity peer of
+                    PeerIdentityUnknown  -> "<noid>"
+                    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