diff options
Diffstat (limited to 'main')
| -rw-r--r-- | main/Main.hs | 277 | ||||
| -rw-r--r-- | main/Test.hs | 38 |
2 files changed, 269 insertions, 46 deletions
diff --git a/main/Main.hs b/main/Main.hs index 0eb414c..94c0418 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -24,6 +24,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T +import Data.Time.Format import Data.Time.LocalTime import Data.Typeable @@ -37,6 +38,7 @@ import System.IO import Erebos.Attach import Erebos.Contact +import Erebos.Chatroom import Erebos.Conversation #ifdef ENABLE_ICE_SUPPORT import Erebos.Discovery @@ -59,11 +61,17 @@ import Version data Options = Options { optServer :: ServerOptions , optServices :: [ServiceOption] + , optStorage :: StorageOption + , optChatroomAutoSubscribe :: Maybe Int , optDmBotEcho :: Maybe Text , optShowHelp :: Bool , optShowVersion :: Bool } +data StorageOption = DefaultStorage + | FilesystemStorage FilePath + | MemoryStorage + data ServiceOption = ServiceOption { soptName :: String , soptService :: SomeService @@ -75,6 +83,8 @@ defaultOptions :: Options defaultOptions = Options { optServer = defaultServerOptions , optServices = availableServices + , optStorage = DefaultStorage + , optChatroomAutoSubscribe = Nothing , optDmBotEcho = Nothing , optShowHelp = False , optShowVersion = False @@ -86,6 +96,8 @@ availableServices = True "attach (to) other devices" , ServiceOption "sync" (someService @SyncService Proxy) True "synchronization with attached devices" + , ServiceOption "chatroom" (someService @ChatroomService Proxy) + True "chatrooms with multiple participants" , ServiceOption "contact" (someService @ContactService Proxy) True "create contacts with network peers" , ServiceOption "dm" (someService @DirectMessage Proxy) @@ -104,6 +116,15 @@ options = , Option ['s'] ["silent"] (NoArg (so $ \opts -> opts { serverLocalDiscovery = False })) "do not send announce packets for local discovery" + , Option [] [ "storage" ] + (ReqArg (\path -> \opts -> opts { optStorage = FilesystemStorage path }) "<path>") + "use storage in <path>" + , Option [] [ "memory-storage" ] + (NoArg (\opts -> opts { optStorage = MemoryStorage })) + "use memory storage" + , Option [] ["chatroom-auto-subscribe"] + (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>") + "automatically subscribe for up to <count> chatrooms" , Option [] ["dm-bot-echo"] (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>") "automatically reply to direct messages with the same text prefixed with <prefix>" @@ -133,8 +154,20 @@ servicesOptions = concatMap helper $ "all" : map soptName availableServices main :: IO () main = do - st <- liftIO $ openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR" - getArgs >>= \case + (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case + (o, args, []) -> do + return (foldl (flip id) defaultOptions o, args) + (_, _, errs) -> do + progName <- getProgName + hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information." + exitFailure + + st <- liftIO $ case optStorage opts of + DefaultStorage -> openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR" + FilesystemStorage path -> openStorage path + MemoryStorage -> memoryStorage + + case args of ["cat-file", sref] -> do readRef st (BC.pack sref) >>= \case Nothing -> error "ref does not exist" @@ -150,7 +183,7 @@ main = do forM_ (signedSignature signed) $ \sig -> do putStr $ "SIG " BC.putStrLn $ showRef $ storedRef $ sigKey $ fromStored sig - "identity" -> case validateIdentityF (wrappedLoad <$> refs) of + "identity" -> case validateExtendedIdentityF (wrappedLoad <$> refs) of Just identity -> do let disp :: Identity m -> IO () disp idt = do @@ -160,7 +193,7 @@ main = do case idOwner idt of Nothing -> return () Just owner -> do - mapM_ (putStrLn . ("OWNER " ++) . BC.unpack . showRefDigest . refDigest . storedRef) $ idDataF owner + mapM_ (putStrLn . ("OWNER " ++) . BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF owner disp owner disp identity Nothing -> putStrLn $ "Identity verification failed" @@ -184,32 +217,30 @@ main = do ["test"] -> runTestTool st - args -> case getOpt Permute (options ++ servicesOptions) args of - (o, [], []) -> do - let opts = foldl (flip id) defaultOptions o - header = "Usage: erebos [OPTION...]" - serviceDesc ServiceOption {..} = padService (" " <> soptName) <> soptDescription - - padTo n str = str <> replicate (n - length str) ' ' - padOpt = padTo 37 - padService = padTo 16 - - if | optShowHelp opts -> putStr $ usageInfo header options <> unlines - ( - [ padOpt " --enable-<service>" <> "enable network service <service>" - , padOpt " --disable-<service>" <> "disable network service <service>" - , padOpt " --enable-all" <> "enable all network services" - , padOpt " --disable-all" <> "disable all network services" - , "" - , "Available network services:" - ] ++ map serviceDesc availableServices - ) - | optShowVersion opts -> putStrLn versionLine - | otherwise -> interactiveLoop st opts - (_, _, errs) -> do - progName <- getProgName - hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information." - exitFailure + [] -> do + let header = "Usage: erebos [OPTION...]" + serviceDesc ServiceOption {..} = padService (" " <> soptName) <> soptDescription + + padTo n str = str <> replicate (n - length str) ' ' + padOpt = padTo 37 + padService = padTo 16 + + if | optShowHelp opts -> putStr $ usageInfo header options <> unlines + ( + [ padOpt " --enable-<service>" <> "enable network service <service>" + , padOpt " --disable-<service>" <> "disable network service <service>" + , padOpt " --enable-all" <> "enable all network services" + , padOpt " --disable-all" <> "disable all network services" + , "" + , "Available network services:" + ] ++ map serviceDesc availableServices + ) + | optShowVersion opts -> putStrLn versionLine + | otherwise -> interactiveLoop st opts + + (cmdname : _) -> do + hPutStrLn stderr $ "Unknown command `" <> cmdname <> "'" + exitFailure inputSettings :: Settings IO @@ -222,8 +253,10 @@ interactiveLoop st opts = runInputT inputSettings $ do tui <- haveTerminalUI extPrint <- getExternalPrint - let extPrintLn str = extPrint $ case reverse str of ('\n':_) -> str - _ -> str ++ "\n"; + let extPrintLn str = do + let str' = case reverse str of ('\n':_) -> str + _ -> str ++ "\n"; + extPrint $! str' -- evaluate str before calling extPrint to avoid blinking let getInputLinesTui eprompt = do prompt <- case eprompt of @@ -235,6 +268,7 @@ interactiveLoop st opts = runInputT inputSettings $ do PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">" PeerIdentityUnknown _ -> "<unknown>" SelectedContact contact -> return $ T.unpack $ contactName contact + SelectedChatroom rstate -> return $ T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate SelectedConversation conv -> return $ T.unpack $ conversationName conv return $ pname ++ "> " Right prompt -> return prompt @@ -281,13 +315,20 @@ interactiveLoop st opts = runInputT inputSettings $ do Right reply -> extPrintLn $ formatDirectMessage tzone $ fromStored reply Left err -> extPrintLn $ "Failed to send dm echo: " <> err + peers <- liftIO $ newMVar [] + contextOptions <- liftIO $ newMVar [] + chatroomSetVar <- liftIO $ newEmptyMVar + + let autoSubscribe = optChatroomAutoSubscribe opts + chatroomList = fromSetBy (comparing roomStateData) . lookupSharedValue . lsShared . headObject $ erebosHead + watched <- if isJust autoSubscribe || any roomStateSubscribe chatroomList + then fmap Just $ liftIO $ watchChatroomsForCli extPrintLn erebosHead chatroomSetVar contextOptions autoSubscribe + else return Nothing + server <- liftIO $ do startServer (optServer opts) erebosHead extPrintLn $ map soptService $ filter soptEnabled $ optServices opts - peers <- liftIO $ newMVar [] - contextOptions <- liftIO $ newMVar [] - void $ liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange server peerIdentity peer >>= \case @@ -320,11 +361,14 @@ interactiveLoop st opts = runInputT inputSettings $ do { ciServer = server , ciLine = line , ciPrint = extPrintLn + , ciOptions = opts , ciPeers = liftIO $ modifyMVar peers $ \ps -> do ps' <- filterM (fmap not . isPeerDropped . fst) ps return (ps', ps') , ciContextOptions = liftIO $ readMVar contextOptions , ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs + , ciContextOptionsVar = contextOptions + , ciChatroomSetVar = chatroomSetVar } case res of Right cstate' @@ -343,6 +387,7 @@ interactiveLoop st opts = runInputT inputSettings $ do , csIceSessions = [] #endif , csIcePeer = Nothing + , csWatchChatrooms = watched , csQuit = False } @@ -351,9 +396,12 @@ data CommandInput = CommandInput { ciServer :: Server , ciLine :: String , ciPrint :: String -> IO () + , ciOptions :: Options , ciPeers :: CommandM [(Peer, String)] , ciContextOptions :: CommandM [CommandContext] , ciSetContextOptions :: [CommandContext] -> Command + , ciContextOptionsVar :: MVar [ CommandContext ] + , ciChatroomSetVar :: MVar (Set ChatroomState) } data CommandState = CommandState @@ -363,12 +411,14 @@ data CommandState = CommandState , csIceSessions :: [IceSession] #endif , csIcePeer :: Maybe Peer + , csWatchChatrooms :: Maybe WatchedHead , csQuit :: Bool } data CommandContext = NoContext | SelectedPeer Peer | SelectedContact Contact + | SelectedChatroom ChatroomState | SelectedConversation Conversation newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a) @@ -402,6 +452,11 @@ getSelectedPeer = gets csContext >>= \case SelectedPeer peer -> return peer _ -> throwError "no peer selected" +getSelectedChatroom :: CommandM ChatroomState +getSelectedChatroom = gets csContext >>= \case + SelectedChatroom rstate -> return rstate + _ -> throwError "no chatroom selected" + getSelectedConversation :: CommandM Conversation getSelectedConversation = gets csContext >>= \case SelectedPeer peer -> peerIdentity peer >>= \case @@ -410,6 +465,10 @@ getSelectedConversation = gets csContext >>= \case SelectedContact contact -> case contactIdentity contact of Just cid -> directMessageConversation cid Nothing -> throwError "contact without erebos identity" + SelectedChatroom rstate -> + chatroomConversation rstate >>= \case + Just conv -> return conv + Nothing -> throwError "invalid chatroom" SelectedConversation conv -> reloadConversation conv _ -> throwError "no contact, peer or conversation selected" @@ -425,6 +484,8 @@ commands = , ("attach", cmdAttach) , ("attach-accept", cmdAttachAccept) , ("attach-reject", cmdAttachReject) + , ("chatrooms", cmdChatrooms) + , ("chatroom-create-public", cmdChatroomCreatePublic) , ("contacts", cmdContacts) , ("contact-add", cmdContactAdd) , ("contact-accept", cmdContactAccept) @@ -440,6 +501,9 @@ commands = , ("ice-connect", cmdIceConnect) , ("ice-send", cmdIceSend) #endif + , ("join", cmdJoin) + , ("leave", cmdLeave) + , ("members", cmdMembers) , ("select", cmdSelectContext) , ("quit", cmdQuit) ] @@ -492,20 +556,41 @@ showPeer pidentity paddr = PeerIdentityFull pid -> T.unpack $ displayIdentity pid in name ++ " [" ++ show paddr ++ "]" +cmdJoin :: Command +cmdJoin = joinChatroom =<< getSelectedChatroom + +cmdLeave :: Command +cmdLeave = leaveChatroom =<< getSelectedChatroom + +cmdMembers :: Command +cmdMembers = do + Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom + forM_ (chatroomMembers room) $ \x -> do + liftIO $ putStrLn $ maybe "<unnamed>" T.unpack $ idName x + + cmdSelectContext :: Command cmdSelectContext = do n <- read <$> asks ciLine join (asks ciContextOptions) >>= \ctxs -> if - | n > 0, (ctx : _) <- drop (n - 1) ctxs -> modify $ \s -> s { csContext = ctx } + | n > 0, (ctx : _) <- drop (n - 1) ctxs -> do + modify $ \s -> s { csContext = ctx } + case ctx of + SelectedChatroom rstate -> do + when (not (roomStateSubscribe rstate)) $ do + chatroomSetSubscribe (head $ roomStateData rstate) True + _ -> return () | otherwise -> throwError "invalid index" cmdSend :: Command cmdSend = void $ do text <- asks ciLine conv <- getSelectedConversation - msg <- sendMessage conv $ T.pack text - tzone <- liftIO $ getCurrentTimeZone - liftIO $ putStrLn $ formatMessage tzone msg + sendMessage conv (T.pack text) >>= \case + Just msg -> do + tzone <- liftIO $ getCurrentTimeZone + liftIO $ putStrLn $ formatMessage tzone msg + Nothing -> return () cmdHistory :: Command cmdHistory = void $ do @@ -530,6 +615,110 @@ cmdAttachAccept = attachAccept =<< getSelectedPeer cmdAttachReject :: Command cmdAttachReject = attachReject =<< getSelectedPeer +watchChatroomsForCli :: (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) -> MVar [ CommandContext ] -> Maybe Int -> IO WatchedHead +watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do + subscribedNumVar <- newEmptyMVar + + let ctxUpdate updateType (idx :: Int) rstate = \case + SelectedChatroom rstate' : rest + | currentRoots <- filterAncestors (concatMap storedRoots $ roomStateData rstate) + , any ((`intersectsSorted` currentRoots) . storedRoots) $ roomStateData rstate' + -> do + eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name + return (SelectedChatroom rstate : rest) + selected : rest + -> do + (selected : ) <$> ctxUpdate updateType (idx + 1) rstate rest + [] + -> do + eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name + return [ SelectedChatroom rstate ] + where + name = maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom rstate + + watchChatrooms h $ \set -> \case + Nothing -> do + let chatroomList = fromSetBy (comparing roomStateData) set + (subscribed, notSubscribed) = partition roomStateSubscribe chatroomList + subscribedNum = length subscribed + + putMVar chatroomSetVar set + putMVar subscribedNumVar subscribedNum + + case autoSubscribe of + Nothing -> return () + Just num -> do + forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do + (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case + Right () -> return () + Left err -> eprint err + + Just diff -> do + modifyMVar_ chatroomSetVar $ return . const set + forM_ diff $ \case + AddedChatroom rstate -> do + modifyMVar_ contextVar $ ctxUpdate "NEW" 1 rstate + modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then (+ 1) else id + + RemovedChatroom rstate -> do + modifyMVar_ contextVar $ ctxUpdate "DEL" 1 rstate + modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then subtract 1 else id + + UpdatedChatroom oldroom rstate -> do + when (any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)) $ do + modifyMVar_ contextVar $ ctxUpdate "UPD" 1 rstate + when (any (not . null . rsdMessages . fromStored) (roomStateData rstate)) $ do + tzone <- getCurrentTimeZone + forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do + eprint $ concat $ + [ maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg + , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg + , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg + , if cmsgLeave msg then " left" else "" + , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg + ] + modifyMVar_ subscribedNumVar $ return + . (if roomStateSubscribe rstate then (+ 1) else id) + . (if roomStateSubscribe oldroom then subtract 1 else id) + +ensureWatchedChatrooms :: Command +ensureWatchedChatrooms = do + gets csWatchChatrooms >>= \case + Nothing -> do + eprint <- asks ciPrint + h <- gets csHead + chatroomSetVar <- asks ciChatroomSetVar + contextVar <- asks ciContextOptionsVar + autoSubscribe <- asks $ optChatroomAutoSubscribe . ciOptions + watched <- liftIO $ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe + modify $ \s -> s { csWatchChatrooms = Just watched } + Just _ -> return () + +cmdChatrooms :: Command +cmdChatrooms = do + ensureWatchedChatrooms + chatroomSetVar <- asks ciChatroomSetVar + chatroomList <- fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) + set <- asks ciSetContextOptions + set $ map SelectedChatroom chatroomList + forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do + liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate) + +cmdChatroomCreatePublic :: Command +cmdChatroomCreatePublic = do + name <- asks ciLine >>= \case + line | not (null line) -> return $ T.pack line + _ -> liftIO $ do + T.putStr $ T.pack "Name: " + hFlush stdout + T.getLine + + ensureWatchedChatrooms + void $ createChatroom + (if T.null name then Nothing else Just name) + Nothing + + cmdContacts :: Command cmdContacts = do args <- words <$> asks ciLine @@ -586,6 +775,9 @@ cmdDetails = do SelectedContact contact -> do printContactDetails contact + SelectedChatroom rstate -> do + liftIO $ putStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate) + SelectedConversation conv -> do case conversationPeer conv of Just pid -> printContactOrIdentityDetails pid @@ -703,3 +895,10 @@ cmdIceSend = void $ do cmdQuit :: Command cmdQuit = modify $ \s -> s { csQuit = True } + + +intersectsSorted :: Ord a => [a] -> [a] -> Bool +intersectsSorted (x:xs) (y:ys) | x < y = intersectsSorted xs (y:ys) + | x > y = intersectsSorted (x:xs) ys + | otherwise = True +intersectsSorted _ _ = False diff --git a/main/Test.hs b/main/Test.hs index 711f9fa..c6448b8 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -97,7 +97,7 @@ runTestTool st = do Nothing -> return () runExceptT (evalStateT testLoop initTestState) >>= \case - Left x -> hPutStrLn stderr x + Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack x Right () -> return () getLineMb :: MonadIO m => m (Maybe Text) @@ -121,7 +121,7 @@ outLine :: Output -> String -> IO () outLine mvar line = do evaluate $ foldl' (flip seq) () line withMVar mvar $ \() -> do - putStrLn line + B.putStr $ (`BC.snoc` '\n') $ BC.pack line hFlush stdout cmdOut :: String -> Command @@ -283,6 +283,9 @@ commands = map (T.pack *** id) , ("chatroom-set-name", cmdChatroomSetName) , ("chatroom-subscribe", cmdChatroomSubscribe) , ("chatroom-unsubscribe", cmdChatroomUnsubscribe) + , ("chatroom-members", cmdChatroomMembers) + , ("chatroom-join", cmdChatroomJoin) + , ("chatroom-leave", cmdChatroomLeave) , ("chatroom-message-send", cmdChatroomMessageSend) ] @@ -428,7 +431,7 @@ cmdStartServer = do h <- getOrLoadHead rsPeers <- liftIO $ newMVar (1, []) - rsServer <- liftIO $ startServer defaultServerOptions h (hPutStrLn stderr) + rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) [ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" , someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" , someServiceAttr $ directMessageAttributes out @@ -501,11 +504,11 @@ cmdPeerList = do cmdTestMessageSend :: Command cmdTestMessageSend = do - [spidx, tref] <- asks tiParams + spidx : trefs <- asks tiParams st <- asks tiStorage - Just ref <- liftIO $ readRef st (encodeUtf8 tref) + Just refs <- liftIO $ fmap sequence $ mapM (readRef st . encodeUtf8) trefs peer <- getPeer spidx - sendToPeer peer $ TestMessage $ wrappedLoad ref + sendManyToPeer peer $ map (TestMessage . wrappedLoad) refs cmdOut "test-message-send done" cmdSharedStateGet :: Command @@ -732,6 +735,7 @@ cmdChatroomWatchLocal = do , [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room ] , [ "room", maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg ] , [ "from", maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg ] + , if cmsgLeave msg then [ "leave" ] else [] , maybe [] (("text":) . (:[]) . T.unpack) $ cmsgText msg ] @@ -754,8 +758,28 @@ cmdChatroomUnsubscribe = do to <- getChatroomStateData cid void $ chatroomSetSubscribe to False +cmdChatroomMembers :: Command +cmdChatroomMembers = do + [ cid ] <- asks tiParams + Just chatroom <- findChatroomByStateData =<< getChatroomStateData cid + forM_ (chatroomMembers chatroom) $ \user -> do + cmdOut $ unwords [ "chatroom-members-item", maybe "<unnamed>" T.unpack $ idName user ] + cmdOut "chatroom-members-done" + +cmdChatroomJoin :: Command +cmdChatroomJoin = do + [ cid ] <- asks tiParams + joinChatroomByStateData =<< getChatroomStateData cid + cmdOut "chatroom-join-done" + +cmdChatroomLeave :: Command +cmdChatroomLeave = do + [ cid ] <- asks tiParams + leaveChatroomByStateData =<< getChatroomStateData cid + cmdOut "chatroom-leave-done" + cmdChatroomMessageSend :: Command cmdChatroomMessageSend = do [cid, msg] <- asks tiParams to <- getChatroomStateData cid - void $ chatroomMessageByStateData to msg + void $ sendChatroomMessageByStateData to msg |