diff options
| -rw-r--r-- | erebos.cabal | 2 | ||||
| -rw-r--r-- | src/Main.hs | 175 | ||||
| -rw-r--r-- | src/Network.hs | 52 |
3 files changed, 167 insertions, 62 deletions
diff --git a/erebos.cabal b/erebos.cabal index 8a5e15f..0eedaa4 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -44,6 +44,7 @@ executable erebos cryptonite >=0.25 && <0.26, directory >= 1.3 && <1.4, filepath >=1.4 && <1.5, + haskeline >=0.7 && <0.8, memory >=0.14 && <0.15, mime >= 0.4 && < 0.5, mtl >=2.2 && <2.3, @@ -51,6 +52,7 @@ executable erebos tagged >= 0.8 && <0.9, text >= 1.2 && <1.3, time >= 1.8 && <1.9, + transformers >= 0.5 && <0.6, unix >=2.7 && <2.8, zlib >=0.6 && <0.7 hs-source-dirs: src diff --git a/src/Main.hs b/src/Main.hs index e6e9d9c..59e6d5c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,12 +3,19 @@ module Main (main) where import Control.Concurrent import Control.Exception import Control.Monad +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Maybe +import Data.Char import Data.List import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Time.Format +import Data.Time.LocalTime +import System.Console.Haskeline import System.Environment import System.IO import System.IO.Error @@ -71,54 +78,150 @@ updateErebosHead st f = do return x main :: IO () -main = do - [bhost] <- getArgs - st <- openStorage "test" - erebosHead <- loadErebosHead st +main = runInputT defaultSettings $ do + bhost <- liftIO getArgs >>= \case [bhost] -> return bhost + _ -> error "Expecting broadcast address" + st <- liftIO $ openStorage "test" + erebosHead <- liftIO $ loadErebosHead st let serebos = wrappedLoad (headRef erebosHead) :: Stored Erebos self = erbIdentity $ fromStored serebos - T.putStrLn $ displayIdentity self + outputStrLn $ T.unpack $ displayIdentity self - (chanPeer, chanSvc) <- startServer bhost $ erbIdentity $ fromStored serebos + haveTerminalUI >>= \case True -> return () + False -> error "Requires terminal" + extPrint <- getExternalPrint + let extPrintLn str = extPrint $ str ++ "\n"; + (chanPeer, chanSvc) <- liftIO $ + startServer extPrintLn bhost $ erbIdentity $ fromStored serebos - void $ forkIO $ void $ forever $ do + peers <- liftIO $ newMVar [] + + void $ liftIO $ forkIO $ void $ forever $ do peer@Peer { peerAddress = DatagramAddress addr } <- readChan chanPeer - print addr - T.putStrLn $ maybe (T.pack "<noid>") displayIdentity $ peerIdentity peer - if | Just powner <- finalOwner <$> peerIdentity peer - , _:_ <- peerChannels peer - -> do - msg <- updateErebosHead st $ \erb -> do - (slist, msg) <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of - Just thread -> do - (msg, thread') <- createDirectMessage self (fromStored thread) (T.pack "Hello") - (,msg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb) - Nothing -> do - (msg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack "Hello") - (,msg) <$> slistAddS thread' (erbMessages $ fromStored erb) - erb' <- wrappedStore st (fromStored erb) { erbMessages = slist } - return (erb', msg) - sendToPeer self peer (T.pack "dmsg") msg - - | otherwise -> return () - - void $ forever $ readChan chanSvc >>= \case + 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) + + tzone <- liftIO $ getCurrentTimeZone + void $ liftIO $ forkIO $ forever $ readChan chanSvc >>= \case (peer, svc, ref) | svc == T.pack "dmsg" -> do - let msg = wrappedLoad ref - putStr "Direct message from: " - T.putStrLn $ fromMaybe (T.pack "<unnamed>") $ idName $ fromStored $ signedData $ fromStored $ msgFrom $ fromStored msg + let smsg = wrappedLoad ref + msg = fromStored smsg + extPrintLn $ formatMessage tzone msg if | Just powner <- finalOwner <$> peerIdentity peer - , powner == msgFrom (fromStored msg) + , powner == msgFrom msg -> updateErebosHead_ st $ \erb -> do slist <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of - Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = msg : msgHead (fromStored thread) } + Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) } slistReplaceS thread thread' $ erbMessages $ fromStored erb - Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [msg] } $ erbMessages $ fromStored erb + Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ erbMessages $ fromStored erb wrappedStore st (fromStored erb) { erbMessages = slist } - | otherwise -> putStrLn $ "Owner mismatch" + | otherwise -> extPrint $ "Owner mismatch" + | otherwise -> extPrint $ "Unknown service: " ++ T.unpack svc + + let process cstate = do + let pname = case csPeer cstate of + Nothing -> "" + Just peer -> maybe "<unnamed>" T.unpack $ idName . fromStored . signedData . fromStored . finalOwner <=< peerIdentity $ peer + Just input <- lift $ getInputLine $ pname ++ "> " + let (cmd, line) = case input of + '/':rest -> let (scmd, args) = dropWhile isSpace <$> span isAlphaNum 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 + { ciSelf = self + , ciLine = line + , ciPeers = liftIO $ readMVar peers + } + + let loop (Just cstate) = runMaybeT (process cstate) >>= loop + loop Nothing = return () + loop $ Just $ CommandState { csPeer = Nothing } + - | otherwise -> T.putStrLn $ T.pack "Unknown service: " `T.append` svc +data CommandInput = CommandInput + { ciSelf :: Stored Identity + , ciLine :: String + , ciPeers :: CommandM [Peer] + } + +data CommandState = CommandState + { csPeer :: Maybe Peer + } - return () +type CommandM a = ReaderT CommandInput (StateT CommandState IO) a +type Command = CommandM () + +commands :: [(String, Command)] +commands = + [ ("history", cmdHistory) + , ("peers", cmdPeers) + , ("send", cmdSend) + ] + +cmdUnknown :: String -> Command +cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd + +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) + +cmdSetPeer :: Int -> Command +cmdSetPeer n | n < 1 = liftIO $ putStrLn "Invalid peer index" + | otherwise = do peers <- join $ asks ciPeers + modify $ \s -> s { csPeer = listToMaybe $ drop (n - 1) peers } + +cmdSend :: Command +cmdSend = void $ runMaybeT $ do + self <- asks ciSelf + let st = storedStorage self + Just peer <- gets csPeer + Just powner <- return $ finalOwner <$> peerIdentity peer + _:_ <- return $ peerChannels peer + text <- asks ciLine + smsg <- liftIO $ updateErebosHead st $ \erb -> do + (slist, smsg) <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of + Just thread -> do + (smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text) + (,smsg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb) + Nothing -> do + (smsg, thread') <- createDirectMessage self (emptyDirectThread powner) (T.pack text) + (,smsg) <$> slistAddS thread' (erbMessages $ fromStored erb) + erb' <- wrappedStore st (fromStored erb) { erbMessages = slist } + return (erb', smsg) + liftIO $ sendToPeer self peer (T.pack "dmsg") smsg + + tzone <- liftIO $ getCurrentTimeZone + liftIO $ putStrLn $ formatMessage tzone $ fromStored smsg + +cmdHistory :: Command +cmdHistory = void $ runMaybeT $ do + self <- asks ciSelf + let st = storedStorage self + Just peer <- gets csPeer + Just powner <- return $ finalOwner <$> peerIdentity peer + + erebosHead <- liftIO $ loadHead st "erebos" + let erebos = wrappedLoad (headRef erebosHead) + Just thread <- return $ find ((==powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos + tzone <- liftIO $ getCurrentTimeZone + liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread + + +formatMessage :: TimeZone -> DirectMessage -> String +formatMessage tzone msg = concat + [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg + , maybe "<unnamed>" T.unpack $ idName $ fromStored $ signedData $ fromStored $ msgFrom msg + , ": " + , T.unpack $ msgText msg + ] diff --git a/src/Network.hs b/src/Network.hs index 827f542..391e236 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -111,8 +111,8 @@ serviceFromObject (Rec items) serviceFromObject _ = Nothing -startServer :: String -> Stored Identity -> IO (Chan Peer, Chan (Peer, T.Text, Ref)) -startServer bhost sidentity = do +startServer :: (String -> IO ()) -> String -> Stored Identity -> IO (Chan Peer, Chan (Peer, T.Text, Ref)) +startServer logd bhost sidentity = do chanPeer <- newChan chanSvc <- newChan peers <- newMVar M.empty @@ -143,21 +143,21 @@ startServer bhost sidentity = do , Just tpack <- transportFromObject obj -> packet sock paddr tpack objs - | otherwise -> putStrLn $ show paddr ++ ": invalid packet" + | otherwise -> logd $ show paddr ++ ": invalid packet" packet sock paddr (AnnouncePacket ref) _ = do - putStrLn $ "Got announce: " ++ show ref ++ " from " ++ show paddr + logd $ "Got announce: " ++ show ref ++ " from " ++ show paddr when (ref /= storedRef sidentity) $ void $ sendTo sock (BL.toStrict $ BL.concat [ serializeObject $ transportToObject $ IdentityRequest ref (storedRef sidentity) , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity ]) paddr packet _ paddr (IdentityRequest ref from) [] = do - putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content" + logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr ++ " without content" packet sock paddr (IdentityRequest ref from) (obj:objs) = do - putStrLn $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr - print (obj:objs) + logd $ "Got identity request: for " ++ show ref ++ " by " ++ show from ++ " from " ++ show paddr + logd $ show (obj:objs) from' <- store (storedStorage sidentity) obj if from == from' then do forM_ objs $ store $ storedStorage sidentity @@ -168,14 +168,14 @@ startServer bhost sidentity = do [ serializeObject $ transportToObject $ IdentityResponse (storedRef sidentity) , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity ]) paddr - else putStrLn $ "Mismatched content" + else logd $ "Mismatched content" packet _ paddr (IdentityResponse ref) [] = do - putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content" + logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr ++ " without content" packet sock paddr (IdentityResponse ref) (obj:objs) = do - putStrLn $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr - print (obj:objs) + logd $ "Got identity response: by " ++ show ref ++ " from " ++ show paddr + logd $ show (obj:objs) ref' <- store (storedStorage sidentity) obj if ref == ref' then do forM_ objs $ store $ storedStorage sidentity @@ -191,14 +191,14 @@ startServer bhost sidentity = do , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req ]) paddr - else putStrLn $ "Mismatched content" + else logd $ "Mismatched content" packet _ paddr (TrChannelRequest _) [] = do - putStrLn $ "Got channel request: from " ++ show paddr ++ " without content" + logd $ "Got channel request: from " ++ show paddr ++ " without content" packet sock paddr (TrChannelRequest ref) (obj:objs) = do - putStrLn $ "Got channel request: from " ++ show paddr - print (obj:objs) + logd $ "Got channel request: from " ++ show paddr + logd $ show (obj:objs) ref' <- store (storedStorage sidentity) obj if ref == ref' then do forM_ objs $ store $ storedStorage sidentity @@ -206,10 +206,10 @@ startServer bhost sidentity = do modifyMVar_ peers $ \pval -> case M.lookup paddr pval of Just peer | Just pid <- peerIdentity peer -> runExceptT (acceptChannelRequest sidentity pid request) >>= \case - Left errs -> do mapM_ putStrLn ("Invalid channel request" : errs) + Left errs -> do mapM_ logd ("Invalid channel request" : errs) return pval Right (acc, channel) -> do - putStrLn $ "Got channel: " ++ show (storedRef channel) + logd $ "Got channel: " ++ show (storedRef channel) let peer' = peer { peerChannels = fromStored channel : peerChannels peer } writeChan chanPeer peer' void $ sendTo sock (BL.toStrict $ BL.concat @@ -221,16 +221,16 @@ startServer bhost sidentity = do ]) paddr return $ M.insert paddr peer' pval - _ -> do putStrLn $ "Invalid channel request - no peer identity" + _ -> do logd $ "Invalid channel request - no peer identity" return pval - else putStrLn $ "Mismatched content" + else logd $ "Mismatched content" packet _ paddr (TrChannelAccept _) [] = do - putStrLn $ "Got channel accept: from " ++ show paddr ++ " without content" + logd $ "Got channel accept: from " ++ show paddr ++ " without content" packet _ paddr (TrChannelAccept ref) (obj:objs) = do - putStrLn $ "Got channel accept: from " ++ show paddr - print (obj:objs) + logd $ "Got channel accept: from " ++ show paddr + logd $ show (obj:objs) ref' <- store (storedStorage sidentity) obj if ref == ref' then do forM_ objs $ store $ storedStorage sidentity @@ -238,17 +238,17 @@ startServer bhost sidentity = do modifyMVar_ peers $ \pval -> case M.lookup paddr pval of Just peer | Just pid <- peerIdentity peer -> runExceptT (acceptedChannel sidentity pid accepted) >>= \case - Left errs -> do mapM_ putStrLn ("Invalid channel accept" : errs) + Left errs -> do mapM_ logd ("Invalid channel accept" : errs) return pval Right channel -> do - putStrLn $ "Got channel: " ++ show (storedRef channel) + logd $ "Got channel: " ++ show (storedRef channel) let peer' = peer { peerChannels = fromStored channel : peerChannels peer } writeChan chanPeer peer' return $ M.insert paddr peer' pval - _ -> do putStrLn $ "Invalid channel accept - no peer identity" + _ -> do logd $ "Invalid channel accept - no peer identity" return pval - else putStrLn $ "Mismatched content" + else logd $ "Mismatched content" void $ forkIO $ withSocketsDo $ do let hints = defaultHints |