diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 74 |
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 |