diff options
Diffstat (limited to 'main/Main.hs')
| -rw-r--r-- | main/Main.hs | 597 |
1 files changed, 457 insertions, 140 deletions
diff --git a/main/Main.hs b/main/Main.hs index 0eb414c..064cf54 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -11,6 +11,7 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Maybe +import Control.Monad.Writer import Crypto.Random @@ -24,46 +25,60 @@ 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 import Network.Socket import System.Console.GetOpt -import System.Console.Haskeline +import System.Directory import System.Environment import System.Exit import System.IO import Erebos.Attach import Erebos.Contact +import Erebos.Chatroom import Erebos.Conversation -#ifdef ENABLE_ICE_SUPPORT +import Erebos.DirectMessage import Erebos.Discovery +#ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif import Erebos.Identity -import Erebos.Message hiding (formatMessage) import Erebos.Network +import Erebos.Object import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State +import Erebos.Storable import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync +import State +import Terminal import Test import Version +import WebSocket data Options = Options { optServer :: ServerOptions , optServices :: [ServiceOption] + , optStorage :: StorageOption + , optChatroomAutoSubscribe :: Maybe Int , optDmBotEcho :: Maybe Text + , optWebSocketServer :: Maybe Int , optShowHelp :: Bool , optShowVersion :: Bool } +data StorageOption = DefaultStorage + | FilesystemStorage FilePath + | MemoryStorage + data ServiceOption = ServiceOption { soptName :: String , soptService :: SomeService @@ -75,7 +90,10 @@ defaultOptions :: Options defaultOptions = Options { optServer = defaultServerOptions , optServices = availableServices + , optStorage = DefaultStorage + , optChatroomAutoSubscribe = Nothing , optDmBotEcho = Nothing + , optWebSocketServer = Nothing , optShowHelp = False , optShowVersion = False } @@ -86,17 +104,17 @@ 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) True "direct messages" -#ifdef ENABLE_ICE_SUPPORT , ServiceOption "discovery" (someService @DiscoveryService Proxy) True "peer discovery" -#endif ] -options :: [OptDescr (Options -> Options)] +options :: [ OptDescr (Options -> Writer [ String ] Options) ] options = [ Option ['p'] ["port"] (ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "<port>") @@ -104,26 +122,65 @@ options = , Option ['s'] ["silent"] (NoArg (so $ \opts -> opts { serverLocalDiscovery = False })) "do not send announce packets for local discovery" + , Option [] [ "storage" ] + (ReqArg (\path -> \opts -> return opts { optStorage = FilesystemStorage path }) "<path>") + "use storage in <path>" + , Option [] [ "memory-storage" ] + (NoArg (\opts -> return opts { optStorage = MemoryStorage })) + "use memory storage" + , Option [] ["chatroom-auto-subscribe"] + (ReqArg (\count -> \opts -> return opts { optChatroomAutoSubscribe = Just (read count) }) "<count>") + "automatically subscribe for up to <count> chatrooms" +#ifdef ENABLE_ICE_SUPPORT + , Option [] [ "discovery-stun-port" ] + (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryStunPort = Just (read value) }) "<port>") + "offer specified <port> to discovery peers for STUN protocol" + , Option [] [ "discovery-stun-server" ] + (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryStunServer = Just (read value) }) "<server>") + "offer <server> (domain name or IP address) to discovery peers for STUN protocol" + , Option [] [ "discovery-turn-port" ] + (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnPort = Just (read value) }) "<port>") + "offer specified <port> to discovery peers for TURN protocol" + , Option [] [ "discovery-turn-server" ] + (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnServer = Just (read value) }) "<server>") + "offer <server> (domain name or IP address) to discovery peers for TURN protocol" +#endif , Option [] ["dm-bot-echo"] - (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>") + (ReqArg (\prefix -> \opts -> return opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>") "automatically reply to direct messages with the same text prefixed with <prefix>" + , Option [] [ "websocket-server" ] + (ReqArg (\value -> \opts -> return opts { optWebSocketServer = Just (read value) }) "<port>") + "start WebSocket server on given port" , Option ['h'] ["help"] - (NoArg $ \opts -> opts { optShowHelp = True }) + (NoArg $ \opts -> return opts { optShowHelp = True }) "show this help and exit" , Option ['V'] ["version"] - (NoArg $ \opts -> opts { optShowVersion = True }) + (NoArg $ \opts -> return opts { optShowVersion = True }) "show version and exit" ] - where so f opts = opts { optServer = f $ optServer opts } + where + so f opts = return opts { optServer = f $ optServer opts } -servicesOptions :: [OptDescr (Options -> Options)] + updateService :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> SomeService -> m SomeService + updateService f some@(SomeService proxy attrs) + | Just f' <- cast f = SomeService proxy <$> f' attrs + | otherwise = return some + + serviceAttr :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> Options -> m Options + serviceAttr f opts = do + services' <- forM (optServices opts) $ \sopt -> do + service <- updateService f (soptService sopt) + return sopt { soptService = service } + return opts { optServices = services' } + +servicesOptions :: [ OptDescr (Options -> Writer [ String ] Options) ] servicesOptions = concatMap helper $ "all" : map soptName availableServices where helper name = - [ Option [] ["enable-" <> name] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = True }) "" - , Option [] ["disable-" <> name] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = False }) "" + [ Option [] [ "enable-" <> name ] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = True }) "" + , Option [] [ "disable-" <> name ] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = False }) "" ] - so f opts = opts { optServices = f $ optServices opts } + so f opts = return opts { optServices = f $ optServices opts } change :: String -> (ServiceOption -> ServiceOption) -> [ServiceOption] -> [ServiceOption] change name f (s : ss) | soptName s == name || name == "all" @@ -131,10 +188,33 @@ servicesOptions = concatMap helper $ "all" : map soptName availableServices | otherwise = s : change name f ss change _ _ [] = [] +getDefaultStorageDir :: IO FilePath +getDefaultStorageDir = do + lookupEnv "EREBOS_DIR" >>= \case + Just dir -> return dir + Nothing -> doesFileExist "./.erebos/erebos-storage" >>= \case + True -> return "./.erebos" + False -> getXdgDirectory XdgData "erebos" + main :: IO () main = do - st <- liftIO $ openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR" - getArgs >>= \case + let printErrors errs = do + progName <- getProgName + hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information." + exitFailure + (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case + (wo, args, []) -> + case runWriter (foldM (flip ($)) defaultOptions wo) of + ( o, [] ) -> return ( o, args ) + ( _, errs ) -> printErrors errs + (_, _, errs) -> printErrors errs + + st <- liftIO $ case optStorage opts of + DefaultStorage -> openStorage =<< getDefaultStorageDir + 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 +230,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 +240,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" @@ -170,62 +250,59 @@ main = do Nothing -> error "ref does not exist" Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object) - ["update-identity"] -> either fail return <=< runExceptT $ do - runReaderT updateSharedIdentity =<< loadLocalStateHead st + ["update-identity"] -> do + withTerminal noCompletion $ \term -> do + either (fail . showErebosError) return <=< runExceptT $ do + runReaderT (updateSharedIdentity term) =<< loadLocalStateHead term st ("update-identity" : srefs) -> do - sequence <$> mapM (readRef st . BC.pack) srefs >>= \case - Nothing -> error "ref does not exist" - Just refs - | Just idt <- validateIdentityF $ map wrappedLoad refs -> do - BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< - (either fail return <=< runExceptT $ runReaderT (interactiveIdentityUpdate idt) st) - | otherwise -> error "invalid identity" + withTerminal noCompletion $ \term -> do + sequence <$> mapM (readRef st . BC.pack) srefs >>= \case + Nothing -> error "ref does not exist" + Just refs + | Just idt <- validateIdentityF $ map wrappedLoad refs -> do + BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< + (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st) + | otherwise -> error "invalid identity" ["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 - - -inputSettings :: Settings IO -inputSettings = setComplete commandCompletion $ defaultSettings + [] -> 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 + interactiveLoop :: Storage -> Options -> IO () -interactiveLoop st opts = runInputT inputSettings $ do - erebosHead <- liftIO $ loadLocalStateHead st - outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead +interactiveLoop st opts = withTerminal commandCompletion $ \term -> do + erebosHead <- liftIO $ loadLocalStateHead term st + void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead - tui <- haveTerminalUI - extPrint <- getExternalPrint - let extPrintLn str = extPrint $ case reverse str of ('\n':_) -> str - _ -> str ++ "\n"; + let tui = hasTerminalUI term + let extPrintLn = void . printLine term - let getInputLinesTui eprompt = do + let getInputLinesTui :: Either CommandState String -> MaybeT IO String + getInputLinesTui eprompt = do prompt <- case eprompt of Left cstate -> do pname <- case csContext cstate of @@ -235,14 +312,18 @@ 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 - Just input <- lift $ getInputLine prompt - case reverse input of - _ | all isSpace input -> getInputLinesTui eprompt - '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ") - _ -> return input + lift $ setPrompt term prompt + join $ lift $ getInputLine term $ \case + Just input@('/' : _) -> KeepPrompt $ return input + Just input -> ErasePrompt $ case reverse input of + _ | all isSpace input -> getInputLinesTui eprompt + '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ") + _ -> return input + Nothing -> KeepPrompt mzero getInputCommandTui cstate = do input <- getInputLinesTui cstate @@ -255,7 +336,7 @@ interactiveLoop st opts = runInputT inputSettings $ do return (cmd, line) getInputLinesPipe = do - lift (getInputLine "") >>= \case + join $ lift $ getInputLine term $ KeepPrompt . \case Just input -> return input Nothing -> liftIO $ forever $ threadDelay 100000000 @@ -281,12 +362,23 @@ 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 [] + case optWebSocketServer opts of + Just port -> startWebsocketServer server "::" port extPrintLn + Nothing -> return () void $ liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange server @@ -309,29 +401,33 @@ interactiveLoop st opts = runInputT inputSettings $ do when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown _ -> return () - let process :: CommandState -> MaybeT (InputT IO) CommandState + let process :: CommandState -> MaybeT IO CommandState process cstate = do (cmd, line) <- getInputCommand cstate h <- liftIO (reloadHead $ csHead cstate) >>= \case Just h -> return h - Nothing -> do lift $ lift $ extPrintLn "current head deleted" + Nothing -> do lift $ extPrintLn "current head deleted" mzero res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput { ciServer = server + , ciTerminal = term , 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' | csQuit cstate' -> mzero | otherwise -> return cstate' Left err -> do - lift $ lift $ extPrintLn $ "Error: " ++ err + lift $ extPrintLn $ "Error: " ++ showErebosError err return cstate let loop (Just cstate) = runMaybeT (process cstate) >>= loop @@ -343,17 +439,22 @@ interactiveLoop st opts = runInputT inputSettings $ do , csIceSessions = [] #endif , csIcePeer = Nothing + , csWatchChatrooms = watched , csQuit = False } data CommandInput = CommandInput { ciServer :: Server + , ciTerminal :: Terminal , 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,23 +464,25 @@ 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) - deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String) +newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a) + deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError) instance MonadFail CommandM where - fail = throwError + fail = throwOtherError instance MonadIO CommandM where liftIO act = CommandM (liftIO (try act)) >>= \case - Left (e :: SomeException) -> throwError (show e) + Left (e :: SomeException) -> throwOtherError (show e) Right x -> return x instance MonadRandom CommandM where @@ -400,18 +503,37 @@ type Command = CommandM () getSelectedPeer :: CommandM Peer getSelectedPeer = gets csContext >>= \case SelectedPeer peer -> return peer - _ -> throwError "no peer selected" + _ -> throwOtherError "no peer selected" + +getSelectedChatroom :: CommandM ChatroomState +getSelectedChatroom = gets csContext >>= \case + SelectedChatroom rstate -> return rstate + _ -> throwOtherError "no chatroom selected" getSelectedConversation :: CommandM Conversation -getSelectedConversation = gets csContext >>= \case +getSelectedConversation = gets csContext >>= getConversationFromContext + +getConversationFromContext :: CommandContext -> CommandM Conversation +getConversationFromContext = \case SelectedPeer peer -> peerIdentity peer >>= \case PeerIdentityFull pid -> directMessageConversation $ finalOwner pid - _ -> throwError "incomplete peer identity" + _ -> throwOtherError "incomplete peer identity" SelectedContact contact -> case contactIdentity contact of Just cid -> directMessageConversation cid - Nothing -> throwError "contact without erebos identity" + Nothing -> throwOtherError "contact without erebos identity" + SelectedChatroom rstate -> + chatroomConversation rstate >>= \case + Just conv -> return conv + Nothing -> throwOtherError "invalid chatroom" SelectedConversation conv -> reloadConversation conv - _ -> throwError "no contact, peer or conversation selected" + _ -> throwOtherError "no contact, peer or conversation selected" + +getSelectedOrManualContext :: CommandM CommandContext +getSelectedOrManualContext = do + asks ciLine >>= \case + "" -> gets csContext + str | all isDigit str -> getContextByIndex (read str) + _ -> throwOtherError "invalid index" commands :: [(String, Command)] commands = @@ -421,25 +543,32 @@ commands = , ("peer-add-public", cmdPeerAddPublic) , ("peer-drop", cmdPeerDrop) , ("send", cmdSend) + , ("delete", cmdDelete) , ("update-identity", cmdUpdateIdentity) , ("attach", cmdAttach) , ("attach-accept", cmdAttachAccept) , ("attach-reject", cmdAttachReject) + , ("chatrooms", cmdChatrooms) + , ("chatroom-create-public", cmdChatroomCreatePublic) , ("contacts", cmdContacts) , ("contact-add", cmdContactAdd) , ("contact-accept", cmdContactAccept) , ("contact-reject", cmdContactReject) , ("conversations", cmdConversations) , ("details", cmdDetails) -#ifdef ENABLE_ICE_SUPPORT , ("discovery-init", cmdDiscoveryInit) , ("discovery", cmdDiscovery) +#ifdef ENABLE_ICE_SUPPORT , ("ice-create", cmdIceCreate) , ("ice-destroy", cmdIceDestroy) , ("ice-show", cmdIceShow) , ("ice-connect", cmdIceConnect) , ("ice-send", cmdIceSend) #endif + , ("join", cmdJoin) + , ("join-as", cmdJoinAs) + , ("leave", cmdLeave) + , ("members", cmdMembers) , ("select", cmdSelectContext) , ("quit", cmdQuit) ] @@ -452,8 +581,13 @@ commandCompletion = completeWordWithPrev Nothing [ ' ', '\t', '\n', '\r' ] $ cur sortedCommandNames = sort $ map fst commands +cmdPutStrLn :: String -> Command +cmdPutStrLn str = do + term <- asks ciTerminal + void $ liftIO $ printLine term str + cmdUnknown :: String -> Command -cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd +cmdUnknown cmd = cmdPutStrLn $ "Unknown command: " ++ cmd cmdPeers :: Command cmdPeers = do @@ -461,7 +595,7 @@ cmdPeers = do set <- asks ciSetContextOptions set $ map (SelectedPeer . fst) peers forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ name + cmdPutStrLn $ "[" ++ show i ++ "] " ++ name cmdPeerAdd :: Command cmdPeerAdd = void $ do @@ -469,15 +603,26 @@ cmdPeerAdd = void $ do (hostname, port) <- (words <$> asks ciLine) >>= \case hostname:p:_ -> return (hostname, p) [hostname] -> return (hostname, show discoveryPort) - [] -> throwError "missing peer address" + [] -> throwOtherError "missing peer address" addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) liftIO $ serverPeer server (addrAddress addr) cmdPeerAddPublic :: Command cmdPeerAddPublic = do server <- asks ciServer - addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just "discovery1.erebosprotocol.net") (Just (show discoveryPort)) - void $ liftIO $ serverPeer server (addrAddress addr) + liftIO $ mapM_ (serverPeer server . addrAddress) =<< gather 'a' + where + gather c + | c <= 'z' = do + let hints = Just $ defaultHints { addrSocketType = Datagram } + hostname = Just $ c : ".discovery.erebosprotocol.net" + service = Just $ show discoveryPort + handle (\(_ :: IOException) -> return []) (getAddrInfo hints hostname service) >>= \case + addr : _ -> (addr :) <$> gather (succ c) + [] -> return [] + + | otherwise = do + return [] cmdPeerDrop :: Command cmdPeerDrop = do @@ -492,34 +637,71 @@ showPeer pidentity paddr = PeerIdentityFull pid -> T.unpack $ displayIdentity pid in name ++ " [" ++ show paddr ++ "]" +cmdJoin :: Command +cmdJoin = joinChatroom =<< getSelectedChatroom + +cmdJoinAs :: Command +cmdJoinAs = do + name <- asks ciLine + st <- getStorage + identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing + joinChatroomAs identity =<< getSelectedChatroom + +cmdLeave :: Command +cmdLeave = leaveChatroom =<< getSelectedChatroom + +cmdMembers :: Command +cmdMembers = do + Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom + forM_ (chatroomMembers room) $ \x -> do + cmdPutStrLn $ maybe "<unnamed>" T.unpack $ idName x + +getContextByIndex :: Int -> CommandM CommandContext +getContextByIndex n = do + join (asks ciContextOptions) >>= \ctxs -> if + | n > 0, (ctx : _) <- drop (n - 1) ctxs -> return ctx + | otherwise -> throwOtherError "invalid index" + 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 } - | otherwise -> throwError "invalid index" + ctx <- getContextByIndex n + modify $ \s -> s { csContext = ctx } + case ctx of + SelectedChatroom rstate -> do + when (not (roomStateSubscribe rstate)) $ do + chatroomSetSubscribe (head $ roomStateData rstate) True + _ -> return () 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 + cmdPutStrLn $ formatMessage tzone msg + Nothing -> return () + +cmdDelete :: Command +cmdDelete = void $ do + deleteConversation =<< getConversationFromContext =<< getSelectedOrManualContext + modify $ \s -> s { csContext = NoContext } cmdHistory :: Command cmdHistory = void $ do - conv <- getSelectedConversation + conv <- getConversationFromContext =<< getSelectedOrManualContext case conversationHistory conv of thread@(_:_) -> do tzone <- liftIO $ getCurrentTimeZone - liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 thread + mapM_ (cmdPutStrLn . formatMessage tzone) $ reverse $ take 50 thread [] -> do - liftIO $ putStrLn $ "<empty history>" + cmdPutStrLn $ "<empty history>" cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do - runReaderT updateSharedIdentity =<< gets csHead + term <- asks ciTerminal + runReaderT (updateSharedIdentity term) =<< gets csHead cmdAttach :: Command cmdAttach = attachToOwner =<< getSelectedPeer @@ -530,6 +712,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 = filter (not . roomStateDeleted) $ 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 (showErebosError 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 <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) + set <- asks ciSetContextOptions + set $ map SelectedChatroom chatroomList + forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do + cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate) + +cmdChatroomCreatePublic :: Command +cmdChatroomCreatePublic = do + term <- asks ciTerminal + name <- asks ciLine >>= \case + line | not (null line) -> return $ T.pack line + _ -> liftIO $ do + setPrompt term "Name: " + getInputLine term $ KeepPrompt . maybe T.empty T.pack + + ensureWatchedChatrooms + void $ createChatroom + (if T.null name then Nothing else Just name) + Nothing + + cmdContacts :: Command cmdContacts = do args <- words <$> asks ciLine @@ -538,8 +824,8 @@ cmdContacts = do verbose = "-v" `elem` args set <- asks ciSetContextOptions set $ map SelectedContact contacts - forM_ (zip [1..] contacts) $ \(i :: Int, c) -> liftIO $ do - T.putStrLn $ T.concat + forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do + cmdPutStrLn $ T.unpack $ T.concat [ "[", T.pack (show i), "] ", contactName c , case contactIdentity c of Just idt | cname <- displayIdentity idt @@ -565,33 +851,36 @@ cmdConversations = do set <- asks ciSetContextOptions set $ map SelectedConversation conversations forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) + cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) cmdDetails :: Command cmdDetails = do - gets csContext >>= \case + getSelectedOrManualContext >>= \case SelectedPeer peer -> do - liftIO $ putStr $ unlines + cmdPutStrLn $ unlines [ "Network peer:" , " " <> show (peerAddress peer) ] peerIdentity peer >>= \case - PeerIdentityUnknown _ -> liftIO $ do - putStrLn $ "unknown identity" - PeerIdentityRef wref _ -> liftIO $ do - putStrLn $ "Identity ref:" - putStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref) + PeerIdentityUnknown _ -> do + cmdPutStrLn $ "unknown identity" + PeerIdentityRef wref _ -> do + cmdPutStrLn $ "Identity ref:" + cmdPutStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref) PeerIdentityFull pid -> printContactOrIdentityDetails pid SelectedContact contact -> do printContactDetails contact + SelectedChatroom rstate -> do + cmdPutStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate) + SelectedConversation conv -> do case conversationPeer conv of Just pid -> printContactOrIdentityDetails pid - Nothing -> liftIO $ putStrLn $ "(conversation without peer)" + Nothing -> cmdPutStrLn $ "(conversation without peer)" - NoContext -> liftIO $ putStrLn "nothing selected" + NoContext -> cmdPutStrLn "nothing selected" where printContactOrIdentityDetails cid = do contacts <- fromSetBy (comparing contactName) . lookupSharedValue . lsShared . fromStored <$> getLocalHead @@ -599,11 +888,11 @@ cmdDetails = do Just contact -> printContactDetails contact Nothing -> printIdentityDetails cid - printContactDetails contact = liftIO $ do - putStrLn $ "Contact:" + printContactDetails contact = do + cmdPutStrLn $ "Contact:" prefix <- case contactCustomName contact of Just name -> do - putStrLn $ " " <> T.unpack name + cmdPutStrLn $ " " <> T.unpack name return $ Just "alias of" Nothing -> do return $ Nothing @@ -612,23 +901,21 @@ cmdDetails = do Just cid -> do printIdentityDetailsBody prefix cid Nothing -> do - putStrLn $ " (without erebos identity)" + cmdPutStrLn $ " (without erebos identity)" - printIdentityDetails identity = liftIO $ do - putStrLn $ "Identity:" + printIdentityDetails identity = do + cmdPutStrLn $ "Identity:" printIdentityDetailsBody Nothing identity printIdentityDetailsBody prefix identity = do forM_ (zip (False : repeat True) $ unfoldOwners identity) $ \(owned, cpid) -> do - putStrLn $ unwords $ concat + cmdPutStrLn $ unwords $ concat [ [ " " ] , if owned then [ "owned by" ] else maybeToList prefix , [ maybe "<unnamed>" T.unpack (idName cpid) ] , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid ] -#ifdef ENABLE_ICE_SUPPORT - cmdDiscoveryInit :: Command cmdDiscoveryInit = void $ do server <- asks ciServer @@ -639,31 +926,50 @@ cmdDiscoveryInit = void $ do [] -> ("discovery.erebosprotocol.net", show discoveryPort) addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) peer <- liftIO $ serverPeer server (addrAddress addr) - sendToPeer peer $ DiscoverySelf (T.pack "ICE") 0 + sendToPeer peer $ DiscoverySelf [ T.pack "ICE" ] Nothing modify $ \s -> s { csIcePeer = Just peer } cmdDiscovery :: Command cmdDiscovery = void $ do - Just peer <- gets csIcePeer - st <- getStorage + server <- asks ciServer sref <- asks ciLine - eprint <- asks ciPrint - liftIO $ readRef st (BC.pack sref) >>= \case - Nothing -> error "ref does not exist" - Just ref -> do - res <- runExceptT $ sendToPeer peer $ DiscoverySearch ref - case res of - Right _ -> return () - Left err -> eprint err + case readRefDigest (BC.pack sref) of + Nothing -> throwOtherError "failed to parse ref" + Just dgst -> discoverySearch server dgst + +#ifdef ENABLE_ICE_SUPPORT cmdIceCreate :: Command cmdIceCreate = do - role <- asks ciLine >>= return . \case - 'm':_ -> PjIceSessRoleControlling - 's':_ -> PjIceSessRoleControlled - _ -> PjIceSessRoleUnknown + let getRole = \case + 'm':_ -> PjIceSessRoleControlling + 's':_ -> PjIceSessRoleControlled + _ -> PjIceSessRoleUnknown + + ( role, stun, turn ) <- asks (words . ciLine) >>= \case + [] -> return ( PjIceSessRoleControlling, Nothing, Nothing ) + [ role ] -> return + ( getRole role, Nothing, Nothing ) + [ role, server ] -> return + ( getRole role + , Just ( T.pack server, 0 ) + , Just ( T.pack server, 0 ) + ) + [ role, server, port ] -> return + ( getRole role + , Just ( T.pack server, read port ) + , Just ( T.pack server, read port ) + ) + [ role, stunServer, stunPort, turnServer, turnPort ] -> return + ( getRole role + , Just ( T.pack stunServer, read stunPort ) + , Just ( T.pack turnServer, read turnPort ) + ) + _ -> throwOtherError "invalid parameters" + eprint <- asks ciPrint - sess <- liftIO $ iceCreate role $ eprint <=< iceShow + Just cfg <- liftIO $ iceCreateConfig stun turn + sess <- liftIO $ iceCreateSession cfg role $ eprint <=< iceShow modify $ \s -> s { csIceSessions = sess : csIceSessions s } cmdIceDestroy :: Command @@ -684,11 +990,15 @@ cmdIceConnect :: Command cmdIceConnect = do s:_ <- gets csIceSessions server <- asks ciServer - let loadInfo = BC.getLine >>= \case line | BC.null line -> return [] - | otherwise -> (line:) <$> loadInfo + term <- asks ciTerminal + let loadInfo = + getInputLine term (KeepPrompt . maybe BC.empty BC.pack) >>= \case + line | BC.null line -> return [] + | otherwise -> (line :) <$> loadInfo Right remote <- liftIO $ do st <- memoryStorage pst <- derivePartialStorage st + setPrompt term "" rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes) liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s @@ -703,3 +1013,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 |