diff options
Diffstat (limited to 'main/Main.hs')
| -rw-r--r-- | main/Main.hs | 648 |
1 files changed, 350 insertions, 298 deletions
diff --git a/main/Main.hs b/main/Main.hs index a1a8b50..a876d7b 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Arrow (first) import Control.Concurrent import Control.Exception import Control.Monad @@ -11,11 +9,13 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Maybe +import Control.Monad.Writer import Crypto.Random -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL +import Data.Bifunctor +import Data.ByteString.Char8 qualified as BC +import Data.ByteString.Lazy qualified as BL import Data.Char import Data.List import Data.Maybe @@ -42,9 +42,6 @@ import Erebos.Chatroom import Erebos.Conversation import Erebos.DirectMessage import Erebos.Discovery -#ifdef ENABLE_ICE_SUPPORT -import Erebos.ICE -#endif import Erebos.Identity import Erebos.Network import Erebos.Object @@ -67,6 +64,7 @@ data Options = Options { optServer :: ServerOptions , optServices :: [ServiceOption] , optStorage :: StorageOption + , optCreateIdentity :: Maybe ( Maybe Text, [ Maybe Text ] ) , optChatroomAutoSubscribe :: Maybe Int , optDmBotEcho :: Maybe Text , optWebSocketServer :: Maybe Int @@ -74,9 +72,10 @@ data Options = Options , optShowVersion :: Bool } -data StorageOption = DefaultStorage - | FilesystemStorage FilePath - | MemoryStorage +data StorageOption + = DefaultStorage + | FilesystemStorage FilePath + | MemoryStorage data ServiceOption = ServiceOption { soptName :: String @@ -90,6 +89,7 @@ defaultOptions = Options { optServer = defaultServerOptions , optServices = availableServices , optStorage = DefaultStorage + , optCreateIdentity = Nothing , optChatroomAutoSubscribe = Nothing , optDmBotEcho = Nothing , optWebSocketServer = Nothing @@ -113,69 +113,101 @@ availableServices = True "peer discovery" ] -options :: [OptDescr (Options -> Options)] +options :: [ OptDescr (Options -> Writer [ String ] Options) ] options = - [ Option ['p'] ["port"] + [ Option [ 'p' ] [ "port" ] (ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "<port>") "local port to bind" - , Option ['s'] ["silent"] + , 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>") + (ReqArg (\path -> \opts -> return opts { optStorage = FilesystemStorage path }) "<path>") "use storage in <path>" , Option [] [ "memory-storage" ] - (NoArg (\opts -> opts { optStorage = MemoryStorage })) + (NoArg (\opts -> return opts { optStorage = MemoryStorage })) "use memory storage" - , Option [] ["chatroom-auto-subscribe"] - (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>") + , Option [] [ "create-identity" ] + (OptArg (\value -> \opts -> return opts + { optCreateIdentity = + let devName = T.pack <$> value + in maybe (Just ( devName, [] )) (Just . first (const devName)) (optCreateIdentity opts) + }) "<name>") + "create a new (device) identity in a new local state" + , Option [] [ "create-owner" ] + (OptArg (\value -> \opts -> return opts + { optCreateIdentity = + let ownerName = T.pack <$> value + in maybe (Just ( Nothing, [ ownerName ] )) (Just . second (ownerName :)) (optCreateIdentity opts) + }) "<name>") + "create owner for a new device identity" + , 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 -> attrs { discoveryStunPort = Just (read value) }) "<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 -> attrs { discoveryStunServer = Just (read value) }) "<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 -> attrs { discoveryTurnPort = Just (read value) }) "<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 -> attrs { discoveryTurnServer = Just (read value) }) "<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>") + , Option [] [ "discovery-tunnel" ] + (OptArg (\value -> \opts -> do + fun <- provideTunnelFun value + serviceAttr (\attrs -> return attrs { discoveryProvideTunnel = fun }) opts) "<peer-type>") + "offer to provide tunnel for peers of given <peer-type>, possible values: all, none, websocket" + , Option [] [ "dm-bot-echo" ] + (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 -> opts { optWebSocketServer = Just (read value) }) "<port>") + (ReqArg (\value -> \opts -> return opts { optWebSocketServer = Just (read value) }) "<port>") "start WebSocket server on given port" - , Option ['h'] ["help"] - (NoArg $ \opts -> opts { optShowHelp = True }) + , Option [ 'h' ] [ "help" ] + (NoArg $ \opts -> return opts { optShowHelp = True }) "show this help and exit" - , Option ['V'] ["version"] - (NoArg $ \opts -> opts { optShowVersion = True }) + , Option [ 'V' ] [ "version" ] + (NoArg $ \opts -> return opts { optShowVersion = True }) "show version and exit" ] where - so f opts = opts { optServer = f $ optServer opts } + so f opts = return opts { optServer = f $ optServer opts } - updateService :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> SomeService -> SomeService + 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 = some - - serviceAttr :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> Options -> Options - serviceAttr f opts = opts { optServices = map (\sopt -> sopt { soptService = updateService f (soptService sopt) }) (optServices opts) } - -servicesOptions :: [OptDescr (Options -> Options)] + | 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' } + + provideTunnelFun :: Maybe String -> Writer [ String ] (Peer -> PeerAddress -> Bool) + provideTunnelFun Nothing = return $ \_ _ -> True + provideTunnelFun (Just "all") = return $ \_ _ -> True + provideTunnelFun (Just "none") = return $ \_ _ -> False + provideTunnelFun (Just "websocket") = return $ \_ -> \case + CustomPeerAddress addr | Just WebSocketAddress {} <- cast addr -> True + _ -> False + provideTunnelFun (Just name) = do + tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ] + return $ \_ _ -> False + +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" @@ -193,13 +225,16 @@ getDefaultStorageDir = do main :: IO () main = do - (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case - (o, args, []) -> do - return (foldl (flip id) defaultOptions o, args) - (_, _, errs) -> do + 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 @@ -207,7 +242,7 @@ main = do MemoryStorage -> memoryStorage case args of - ["cat-file", sref] -> do + [ "cat-file", sref ] -> do readRef st (BC.pack sref) >>= \case Nothing -> error "ref does not exist" Just ref -> BL.putStr $ lazyLoadBytes ref @@ -238,14 +273,22 @@ main = do Nothing -> putStrLn $ "Identity verification failed" _ -> error $ "unknown object type '" ++ objtype ++ "'" - ["show-generation", sref] -> readRef st (BC.pack sref) >>= \case + [ "show-generation", sref ] -> readRef st (BC.pack sref) >>= \case Nothing -> error "ref does not exist" Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object) - ["update-identity"] -> do + [ "identity" ] -> do + loadHeads st >>= \case + (h : _) -> do + T.putStr $ showIdentityDetails $ headLocalIdentity h + [] -> do + T.putStrLn "no local state head" + exitFailure + + [ "update-identity" ] -> do withTerminal noCompletion $ \term -> do either (fail . showErebosError) return <=< runExceptT $ do - runReaderT (updateSharedIdentity term) =<< loadLocalStateHead term st + runReaderT (updateSharedIdentity term) =<< runReaderT (loadLocalStateHead term) st ("update-identity" : srefs) -> do withTerminal noCompletion $ \term -> do @@ -257,7 +300,7 @@ main = do (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st) | otherwise -> error "invalid identity" - ["test"] -> runTestTool st + [ "test" ] -> runTestTool st [] -> do let header = "Usage: erebos [OPTION...]" @@ -287,7 +330,10 @@ main = do interactiveLoop :: Storage -> Options -> IO () interactiveLoop st opts = withTerminal commandCompletion $ \term -> do - erebosHead <- liftIO $ loadLocalStateHead term st + erebosHead <- either (fail . showErebosError) return <=< runExceptT . flip runReaderT st $ do + case optCreateIdentity opts of + Nothing -> loadLocalStateHead term + Just ( devName, names ) -> createLocalStateHead (names ++ [ devName ]) void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead let tui = hasTerminalUI term @@ -299,7 +345,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do Left cstate -> do pname <- case csContext cstate of NoContext -> return "" - SelectedPeer peer -> peerIdentity peer >>= return . \case + SelectedPeer peer -> getPeerIdentity peer >>= return . \case PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">" PeerIdentityUnknown _ -> "<unknown>" @@ -315,54 +361,70 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do _ | all isSpace input -> getInputLinesTui eprompt '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ") _ -> return input - Nothing -> KeepPrompt mzero + Nothing + | tui -> KeepPrompt mzero + | otherwise -> KeepPrompt $ liftIO $ forever $ threadDelay 100000000 getInputCommandTui cstate = do - input <- getInputLinesTui cstate - let (CommandM cmd, line) = case input of - '/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest - in if not (null scmd) && all isDigit scmd - then (cmdSelectContext, scmd) - else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args) - _ -> (cmdSend, input) - return (cmd, line) - - getInputLinesPipe = do - join $ lift $ getInputLine term $ KeepPrompt . \case - Just input -> return input - Nothing -> liftIO $ forever $ threadDelay 100000000 - - getInputCommandPipe _ = do - input <- getInputLinesPipe - let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') input - let (CommandM cmd, line) = (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args) - return (cmd, line) - - let getInputCommand = if tui then getInputCommandTui . Left - else getInputCommandPipe + let parseCommand cmdline = + case dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') cmdline of + ( scmd, args ) + | not (null scmd) && all isDigit scmd + -> ( cmdSelectContext, scmd ) + + | otherwise + -> ( fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args ) + + ( CommandM cmd, line ) <- getInputLinesTui cstate >>= return . \case + '/' : input -> parseCommand input + input | not tui -> parseCommand input + input -> ( cmdSend, input ) + return ( cmd, line ) + + let getInputCommand = getInputCommandTui . Left + + contextVar <- liftIO $ newMVar NoContext _ <- liftIO $ do tzone <- getCurrentTimeZone - watchReceivedMessages erebosHead $ \smsg -> do - let msg = fromStored smsg - extPrintLn $ formatDirectMessage tzone msg - case optDmBotEcho opts of - Nothing -> return () - Just prefix -> do - res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg) - case res of - Right reply -> extPrintLn $ formatDirectMessage tzone $ fromStored reply - Left err -> extPrintLn $ "Failed to send dm echo: " <> err + let self = finalOwner $ headLocalIdentity erebosHead + watchDirectMessageThreads erebosHead $ \prev cur -> do + forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do + withMVar contextVar $ \ctx -> do + mbpid <- case ctx of + SelectedPeer peer -> getPeerIdentity peer >>= return . \case + PeerIdentityFull pid -> Just $ finalOwner pid + _ -> Nothing + SelectedContact contact + | Just cid <- contactIdentity contact -> return (Just cid) + SelectedConversation conv -> return $ conversationPeer conv + _ -> return Nothing + when (not tui || maybe False (msgPeer cur `sameIdentity`) mbpid) $ do + extPrintLn $ formatDirectMessage tzone msg + + case optDmBotEcho opts of + Just prefix + | not (msgFrom msg `sameIdentity` self) + -> do + void $ forkIO $ do + res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg) + case res of + Right _ -> return () + Left err -> extPrintLn $ "Failed to send dm echo: " <> err + _ -> return () peers <- liftIO $ newMVar [] - contextOptions <- liftIO $ newMVar [] + contextOptions <- liftIO $ newMVar ( Nothing, [] ) 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 + then do + fmap Just $ liftIO $ watchChatroomsForCli tui extPrintLn erebosHead + chatroomSetVar contextVar contextOptions autoSubscribe + else do + return Nothing server <- liftIO $ do startServer (optServer opts) erebosHead extPrintLn $ @@ -374,10 +436,10 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do void $ liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange server - peerIdentity peer >>= \case + getPeerIdentity peer >>= \case pid@(PeerIdentityFull _) -> do dropped <- isPeerDropped peer - let shown = showPeer pid $ peerAddress peer + shown <- showPeer pid <$> getPeerAddress peer let update [] = ([(peer, shown)], (Nothing, "NEW")) update ((p,s):ps) | p == peer && dropped = (ps, (Nothing, "DEL")) @@ -389,8 +451,15 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do | otherwise = first (ctx:) $ ctxUpdate (n + 1) ctxs (op, updateType) <- modifyMVar peers (return . update) let updateType' = if dropped then "DEL" else updateType - idx <- modifyMVar contextOptions (return . ctxUpdate (1 :: Int)) - when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown + modifyMVar_ contextOptions $ \case + ( watch, clist ) + | watch == Just WatchPeers || not tui + -> do + let ( clist', idx ) = ctxUpdate (1 :: Int) clist + when (Just shown /= op) $ do + extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown + return ( Just WatchPeers, clist' ) + cur -> return cur _ -> return () let process :: CommandState -> MaybeT IO CommandState @@ -400,20 +469,23 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do Just h -> return h 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 - } + res <- liftIO $ modifyMVar contextVar $ \ctx -> do + res <- runExceptT $ flip execStateT cstate { csHead = h, csContext = ctx } $ 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 $ snd <$> readMVar contextOptions + , ciSetContextOptions = \watch ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ( Just watch, ctxs ) + , ciContextVar = contextVar + , ciContextOptionsVar = contextOptions + , ciChatroomSetVar = chatroomSetVar + } + return ( either (const ctx) csContext res, res ) case res of Right cstate' | csQuit cstate' -> mzero @@ -427,10 +499,6 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do loop $ Just $ CommandState { csHead = erebosHead , csContext = NoContext -#ifdef ENABLE_ICE_SUPPORT - , csIceSessions = [] -#endif - , csIcePeer = Nothing , csWatchChatrooms = watched , csQuit = False } @@ -443,28 +511,33 @@ data CommandInput = CommandInput , ciPrint :: String -> IO () , ciOptions :: Options , ciPeers :: CommandM [(Peer, String)] - , ciContextOptions :: CommandM [CommandContext] - , ciSetContextOptions :: [CommandContext] -> Command - , ciContextOptionsVar :: MVar [ CommandContext ] + , ciContextOptions :: CommandM [ CommandContext ] + , ciSetContextOptions :: ContextWatchOptions -> [ CommandContext ] -> Command + , ciContextVar :: MVar CommandContext + , ciContextOptionsVar :: MVar ( Maybe ContextWatchOptions, [ CommandContext ] ) , ciChatroomSetVar :: MVar (Set ChatroomState) } data CommandState = CommandState { csHead :: Head LocalState , csContext :: CommandContext -#ifdef ENABLE_ICE_SUPPORT - , csIceSessions :: [IceSession] -#endif - , csIcePeer :: Maybe Peer , csWatchChatrooms :: Maybe WatchedHead , csQuit :: Bool } -data CommandContext = NoContext - | SelectedPeer Peer - | SelectedContact Contact - | SelectedChatroom ChatroomState - | SelectedConversation Conversation +data CommandContext + = NoContext + | SelectedPeer Peer + | SelectedContact Contact + | SelectedChatroom ChatroomState + | SelectedConversation Conversation + +data ContextWatchOptions + = WatchPeers + | WatchContacts + | WatchChatrooms + | WatchConversations + deriving (Eq) newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a) deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError) @@ -503,8 +576,11 @@ getSelectedChatroom = gets csContext >>= \case _ -> throwOtherError "no chatroom selected" getSelectedConversation :: CommandM Conversation -getSelectedConversation = gets csContext >>= \case - SelectedPeer peer -> peerIdentity peer >>= \case +getSelectedConversation = gets csContext >>= getConversationFromContext + +getConversationFromContext :: CommandContext -> CommandM Conversation +getConversationFromContext = \case + SelectedPeer peer -> getPeerIdentity peer >>= \case PeerIdentityFull pid -> directMessageConversation $ finalOwner pid _ -> throwOtherError "incomplete peer identity" SelectedContact contact -> case contactIdentity contact of @@ -517,42 +593,43 @@ getSelectedConversation = gets csContext >>= \case SelectedConversation conv -> reloadConversation conv _ -> throwOtherError "no contact, peer or conversation selected" +getSelectedOrManualContext :: CommandM CommandContext +getSelectedOrManualContext = do + asks ciLine >>= \case + "" -> gets csContext + str | all isDigit str -> getContextByIndex id (read str) + _ -> throwOtherError "invalid index" + commands :: [(String, Command)] commands = - [ ("history", cmdHistory) - , ("peers", cmdPeers) - , ("peer-add", cmdPeerAdd) - , ("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) - , ("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) + [ ( "history", cmdHistory ) + , ( "identity", cmdIdentity ) + , ( "peers", cmdPeers ) + , ( "peer-add", cmdPeerAdd ) + , ( "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 ) + , ( "new", cmdNew ) + , ( "details", cmdDetails ) + , ( "discovery", cmdDiscovery ) + , ( "join", cmdJoin ) + , ( "join-as", cmdJoinAs ) + , ( "leave", cmdLeave ) + , ( "members", cmdMembers ) + , ( "select", cmdSelectContext ) + , ( "quit", cmdQuit ) ] commandCompletion :: CompletionFunc IO @@ -575,7 +652,7 @@ cmdPeers :: Command cmdPeers = do peers <- join $ asks ciPeers set <- asks ciSetContextOptions - set $ map (SelectedPeer . fst) peers + set WatchPeers $ map (SelectedPeer . fst) peers forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do cmdPutStrLn $ "[" ++ show i ++ "] " ++ name @@ -587,11 +664,15 @@ cmdPeerAdd = void $ do [hostname] -> return (hostname, show discoveryPort) [] -> throwOtherError "missing peer address" addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) + contextOptsVar <- asks ciContextOptionsVar + liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers) liftIO $ serverPeer server (addrAddress addr) cmdPeerAddPublic :: Command cmdPeerAddPublic = do server <- asks ciServer + contextOptsVar <- asks ciContextOptionsVar + liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers) liftIO $ mapM_ (serverPeer server . addrAddress) =<< gather 'a' where gather c @@ -625,8 +706,7 @@ cmdJoin = joinChatroom =<< getSelectedChatroom cmdJoinAs :: Command cmdJoinAs = do name <- asks ciLine - st <- getStorage - identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing + identity <- createIdentity (Just $ T.pack name) Nothing joinChatroomAs identity =<< getSelectedChatroom cmdLeave :: Command @@ -638,38 +718,45 @@ cmdMembers = do forM_ (chatroomMembers room) $ \x -> do cmdPutStrLn $ maybe "<unnamed>" T.unpack $ idName x +getContextByIndex :: (Maybe ContextWatchOptions -> Maybe ContextWatchOptions) -> Int -> CommandM CommandContext +getContextByIndex f n = do + contextOptsVar <- asks ciContextOptionsVar + join $ liftIO $ modifyMVar contextOptsVar $ \cur@( watch, ctxs ) -> if + | n > 0, (ctx : _) <- drop (n - 1) ctxs + -> return ( ( f watch, ctxs ), return ctx ) + + | otherwise + -> return ( cur, throwOtherError "invalid index" ) cmdSelectContext :: Command cmdSelectContext = do n <- read <$> asks ciLine - join (asks ciContextOptions) >>= \ctxs -> if - | 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 -> throwOtherError "invalid index" + ctx <- getContextByIndex (const Nothing) n + modify $ \s -> s { csContext = ctx } + case ctx of + SelectedChatroom rstate -> do + when (not (roomStateSubscribe rstate)) $ do + chatroomSetSubscribe (head $ roomStateData rstate) True + _ -> return () + handleError (\_ -> return ()) $ do + conv <- getConversationFromContext ctx + tzone <- liftIO $ getCurrentTimeZone + mapM_ (cmdPutStrLn . formatMessage tzone) $ takeWhile messageUnread $ conversationHistory conv cmdSend :: Command cmdSend = void $ do text <- asks ciLine conv <- getSelectedConversation - sendMessage conv (T.pack text) >>= \case - Just msg -> do - tzone <- liftIO $ getCurrentTimeZone - cmdPutStrLn $ formatMessage tzone msg - Nothing -> return () + sendMessage conv (T.pack text) cmdDelete :: Command cmdDelete = void $ do - deleteConversation =<< getSelectedConversation + 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 @@ -677,6 +764,24 @@ cmdHistory = void $ do [] -> do cmdPutStrLn $ "<empty history>" +showIdentityDetails :: Foldable f => Identity f -> Text +showIdentityDetails identity = T.unlines $ go $ reverse $ unfoldOwners identity + where + go (i : is) = concat + [ maybeToList $ ("Name: " <>) <$> idName i + , map (("Ref: " <>) . T.pack . show . refDigest . storedRef) $ idDataF i + , map (("ExtRef: " <>) . T.pack . show . refDigest . storedRef) $ filter isExtension $ idExtDataF i + , do guard $ not (null is) + "" : "Device:" : map (" " <>) (go is) + ] + go [] = [] + isExtension x = case fromSigned x of BaseIdentityData {} -> False + _ -> True + +cmdIdentity :: Command +cmdIdentity = do + cmdPutStrLn . T.unpack . showIdentityDetails . localIdentity . fromStored =<< getLocalHead + cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do term <- asks ciTerminal @@ -691,8 +796,11 @@ 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 +watchChatroomsForCli + :: Bool -> (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) + -> MVar CommandContext -> MVar ( Maybe ContextWatchOptions, [ CommandContext ] ) + -> Maybe Int -> IO WatchedHead +watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe = do subscribedNumVar <- newEmptyMVar let ctxUpdate updateType (idx :: Int) rstate = \case @@ -731,28 +839,44 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do Just diff -> do modifyMVar_ chatroomSetVar $ return . const set + modifyMVar_ contextOptsVar $ \case + ( watch, clist ) + | watch == Just WatchChatrooms || not tui + -> do + let upd c = \case + AddedChatroom rstate -> ctxUpdate "NEW" 1 rstate c + RemovedChatroom rstate -> ctxUpdate "DEL" 1 rstate c + UpdatedChatroom _ rstate + | any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate) + -> do + ctxUpdate "UPD" 1 rstate c + | otherwise -> return c + ( watch, ) <$> foldM upd clist diff + cur -> return cur + 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 - ] + withMVar contextVar $ \ctx -> do + isSelected <- case ctx of + SelectedChatroom rstate' -> return $ isSameChatroom rstate' rstate + SelectedConversation conv -> return $ isChatroomStateConversation rstate conv + _ -> return False + when (not tui || isSelected) $ do + tzone <- getCurrentTimeZone + forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do + eprint $ concat $ + [ 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) @@ -764,9 +888,11 @@ ensureWatchedChatrooms = do eprint <- asks ciPrint h <- gets csHead chatroomSetVar <- asks ciChatroomSetVar - contextVar <- asks ciContextOptionsVar + contextVar <- asks ciContextVar + contextOptsVar <- asks ciContextOptionsVar autoSubscribe <- asks $ optChatroomAutoSubscribe . ciOptions - watched <- liftIO $ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe + tui <- asks $ hasTerminalUI . ciTerminal + watched <- liftIO $ watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe modify $ \s -> s { csWatchChatrooms = Just watched } Just _ -> return () @@ -776,7 +902,7 @@ cmdChatrooms = do chatroomSetVar <- asks ciChatroomSetVar chatroomList <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) set <- asks ciSetContextOptions - set $ map SelectedChatroom chatroomList + set WatchChatrooms $ map SelectedChatroom chatroomList forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate) @@ -790,6 +916,8 @@ cmdChatroomCreatePublic = do getInputLine term $ KeepPrompt . maybe T.empty T.pack ensureWatchedChatrooms + contextOptsVar <- asks ciContextOptionsVar + liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchChatrooms) void $ createChatroom (if T.null name then Nothing else Just name) Nothing @@ -802,7 +930,7 @@ cmdContacts = do let contacts = fromSetBy (comparing contactName) $ lookupSharedValue $ lsShared $ headObject ehead verbose = "-v" `elem` args set <- asks ciSetContextOptions - set $ map SelectedContact contacts + set WatchContacts $ map SelectedContact contacts forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do cmdPutStrLn $ T.unpack $ T.concat [ "[", T.pack (show i), "] ", contactName c @@ -828,19 +956,36 @@ cmdConversations :: Command cmdConversations = do conversations <- lookupConversations set <- asks ciSetContextOptions - set $ map SelectedConversation conversations + set WatchConversations $ map SelectedConversation conversations forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) +cmdNew :: Command +cmdNew = do + conversations <- mapMaybe checkNew <$> lookupConversations + set <- asks ciSetContextOptions + set WatchConversations $ map (SelectedConversation . fst) conversations + tzone <- liftIO $ getCurrentTimeZone + forM_ (zip [1..] conversations) $ \(i :: Int, ( conv, msg )) -> do + cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) ++ " " ++ formatMessage tzone msg + where + checkNew conv + | (msg : _) <- conversationHistory conv + , messageUnread msg + = Just ( conv, msg ) + checkNew _ = Nothing + + cmdDetails :: Command cmdDetails = do - gets csContext >>= \case + getSelectedOrManualContext >>= \case SelectedPeer peer -> do + paddr <- getPeerAddress peer cmdPutStrLn $ unlines [ "Network peer:" - , " " <> show (peerAddress peer) + , " " <> show paddr ] - peerIdentity peer >>= \case + getPeerIdentity peer >>= \case PeerIdentityUnknown _ -> do cmdPutStrLn $ "unknown identity" PeerIdentityRef wref _ -> do @@ -895,106 +1040,13 @@ cmdDetails = do , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid ] -cmdDiscoveryInit :: Command -cmdDiscoveryInit = void $ do - server <- asks ciServer - - (hostname, port) <- (words <$> asks ciLine) >>= return . \case - hostname:p:_ -> (hostname, p) - [hostname] -> (hostname, show discoveryPort) - [] -> ("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" ] Nothing - modify $ \s -> s { csIcePeer = Just peer } - cmdDiscovery :: Command cmdDiscovery = void $ do - Just peer <- gets csIcePeer - st <- getStorage - 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 - -#ifdef ENABLE_ICE_SUPPORT - -cmdIceCreate :: Command -cmdIceCreate = do - 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 - Just cfg <- liftIO $ iceCreateConfig stun turn - sess <- liftIO $ iceCreateSession cfg role $ eprint <=< iceShow - modify $ \s -> s { csIceSessions = sess : csIceSessions s } - -cmdIceDestroy :: Command -cmdIceDestroy = do - s:ss <- gets csIceSessions - modify $ \st -> st { csIceSessions = ss } - liftIO $ iceDestroy s - -cmdIceShow :: Command -cmdIceShow = do - sess <- gets csIceSessions - eprint <- asks ciPrint - liftIO $ forM_ (zip [1::Int ..] sess) $ \(i, s) -> do - eprint $ "[" ++ show i ++ "]" - eprint =<< iceShow s - -cmdIceConnect :: Command -cmdIceConnect = do - s:_ <- gets csIceSessions server <- asks ciServer - 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 - -cmdIceSend :: Command -cmdIceSend = void $ do - s:_ <- gets csIceSessions - server <- asks ciServer - liftIO $ serverPeerIce server s - -#endif + sref <- asks ciLine + case readRefDigest (BC.pack sref) of + Nothing -> throwOtherError "failed to parse ref" + Just dgst -> discoverySearch server dgst cmdQuit :: Command cmdQuit = modify $ \s -> s { csQuit = True } |