diff options
Diffstat (limited to 'main')
| -rw-r--r-- | main/Main.hs | 609 | ||||
| -rw-r--r-- | main/State.hs | 73 | ||||
| -rw-r--r-- | main/Terminal.hs | 120 | ||||
| -rw-r--r-- | main/Test.hs | 350 | ||||
| -rw-r--r-- | main/WebSocket.hs | 7 |
5 files changed, 735 insertions, 424 deletions
diff --git a/main/Main.hs b/main/Main.hs index 26f4b12..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) @@ -507,7 +580,7 @@ getSelectedConversation = gets csContext >>= getConversationFromContext getConversationFromContext :: CommandContext -> CommandM Conversation getConversationFromContext = \case - SelectedPeer peer -> peerIdentity peer >>= \case + SelectedPeer peer -> getPeerIdentity peer >>= \case PeerIdentityFull pid -> directMessageConversation $ finalOwner pid _ -> throwOtherError "incomplete peer identity" SelectedContact contact -> case contactIdentity contact of @@ -524,45 +597,39 @@ getSelectedOrManualContext :: CommandM CommandContext getSelectedOrManualContext = do asks ciLine >>= \case "" -> gets csContext - str | all isDigit str -> getContextByIndex (read str) + 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 @@ -585,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 @@ -597,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 @@ -635,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 @@ -648,32 +718,36 @@ cmdMembers = do 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" +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 - ctx <- getContextByIndex n + 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 @@ -690,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 @@ -704,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 @@ -744,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) @@ -777,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 () @@ -789,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) @@ -803,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 @@ -815,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 @@ -841,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 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 @@ -908,19 +1040,6 @@ 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 server <- asks ciServer @@ -929,80 +1048,6 @@ cmdDiscovery = void $ do Nothing -> throwOtherError "failed to parse ref" Just dgst -> discoverySearch server dgst -#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 - cmdQuit :: Command cmdQuit = modify $ \s -> s { csQuit = True } diff --git a/main/State.hs b/main/State.hs index 150178e..5d66ba9 100644 --- a/main/State.hs +++ b/main/State.hs @@ -1,15 +1,17 @@ module State ( loadLocalStateHead, + createLocalStateHead, updateSharedIdentity, interactiveIdentityUpdate, ) where +import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Data.Foldable -import Data.Maybe import Data.Proxy +import Data.Text (Text) import Data.Text qualified as T import Erebos.Error @@ -22,34 +24,67 @@ import Erebos.Storage import Terminal -loadLocalStateHead :: MonadIO m => Terminal -> Storage -> m (Head LocalState) -loadLocalStateHead term st = loadHeads st >>= \case - (h:_) -> return h - [] -> liftIO $ do - setPrompt term "Name: " - name <- getInputLine term $ KeepPrompt . maybe T.empty T.pack +loadLocalStateHead + :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m) + => Terminal -> m (Head LocalState) +loadLocalStateHead term = getStorage >>= loadHeads >>= \case + (h : _) -> return h + [] -> do + name <- liftIO $ do + setPrompt term "Name: " + getInputLine term $ KeepPrompt . maybe T.empty T.pack - setPrompt term "Device: " - devName <- getInputLine term $ KeepPrompt . maybe T.empty T.pack + devName <- liftIO $ do + setPrompt term "Device: " + getInputLine term $ KeepPrompt . maybe T.empty T.pack - owner <- if - | T.null name -> return Nothing - | otherwise -> Just <$> createIdentity st (Just name) Nothing + ( owner, shared ) <- if + | T.null name -> do + return ( Nothing, [] ) + | otherwise -> do + owner <- createIdentity (Just name) Nothing + shared <- mstore SharedState + { ssPrev = [] + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy + , ssValue = [ storedRef $ idExtData owner ] + } + return ( Just owner, [ shared ] ) - identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner + identity <- createIdentity (if T.null devName then Nothing else Just devName) owner - shared <- wrappedStore st $ SharedState - { ssPrev = [] - , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy - , ssValue = [ storedRef $ idExtData $ fromMaybe identity owner ] - } + st <- getStorage storeHead st $ LocalState { lsPrev = Nothing , lsIdentity = idExtData identity - , lsShared = [ shared ] + , lsShared = shared , lsOther = [] } +createLocalStateHead + :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m) + => [ Maybe Text ] -> m (Head LocalState) +createLocalStateHead [] = throwOtherError "createLocalStateHead: empty name list" +createLocalStateHead ( ownerName : names ) = do + owner <- createIdentity ownerName Nothing + identity <- foldM createSingleIdentity owner names + shared <- case names of + [] -> return [] + _ : _ -> do + fmap (: []) $ mstore SharedState + { ssPrev = [] + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy + , ssValue = [ storedRef $ idExtData owner ] + } + st <- getStorage + storeHead st $ LocalState + { lsPrev = Nothing + , lsIdentity = idExtData identity + , lsShared = shared + , lsOther = [] + } + where + createSingleIdentity owner name = createIdentity name (Just owner) + updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m () updateSharedIdentity term = updateLocalState_ $ updateSharedState_ $ \case diff --git a/main/Terminal.hs b/main/Terminal.hs index 150bd8c..b8b953f 100644 --- a/main/Terminal.hs +++ b/main/Terminal.hs @@ -44,14 +44,20 @@ data Terminal = Terminal , termShowPrompt :: TVar Bool , termInput :: TVar ( String, String ) , termBottomLines :: TVar [ String ] + , termHistory :: TVar [ String ] + , termHistoryPos :: TVar Int + , termHistoryStash :: TVar ( String, String ) } data TerminalLine = TerminalLine { tlTerminal :: Terminal + , tlLineCount :: Int } data Input = InputChar Char + | InputMoveUp + | InputMoveDown | InputMoveRight | InputMoveLeft | InputMoveEnd @@ -84,6 +90,9 @@ initTerminal termCompletionFunc = do termShowPrompt <- newTVarIO False termInput <- newTVarIO ( "", "" ) termBottomLines <- newTVarIO [] + termHistory <- newTVarIO [] + termHistoryPos <- newTVarIO 0 + termHistoryStash <- newTVarIO ( "", "" ) return Terminal {..} bracketSet :: IO a -> (a -> IO b) -> a -> IO c -> IO c @@ -112,6 +121,8 @@ getInput = do '\ESC' -> do esc <- readEsc case parseEsc esc of + Just ( 'A' , [] ) -> return InputMoveUp + Just ( 'B' , [] ) -> return InputMoveDown Just ( 'C' , [] ) -> return InputMoveRight Just ( 'D' , [] ) -> return InputMoveLeft _ -> return (InputEscape esc) @@ -119,6 +130,8 @@ getInput = do '\DEL' -> return InputBackspace '\NAK' -> return InputClear '\ETB' -> return InputBackWord + '\DLE' -> return InputMoveUp + '\SO' -> return InputMoveDown '\SOH' -> return InputMoveStart '\ENQ' -> return InputMoveEnd '\EOT' -> return InputEnd @@ -136,19 +149,33 @@ getInput = do getInputLine :: Terminal -> (Maybe String -> InputHandling a) -> IO a getInputLine term@Terminal {..} handleResult = do - withMVar termLock $ \_ -> do - prompt <- atomically $ do - writeTVar termShowPrompt True - readTVar termPrompt - putStr $ prompt <> "\ESC[K" - drawBottomLines term - hFlush stdout - (handleResult <$> go) >>= \case + when termAnsi $ do + withMVar termLock $ \_ -> do + prompt <- atomically $ do + writeTVar termShowPrompt True + readTVar termPrompt + putStr $ prompt <> "\ESC[K" + drawBottomLines term + hFlush stdout + + mbLine <- go + forM_ mbLine $ \line -> do + let addLine xs + | null line = xs + | (x : _) <- xs, x == line = xs + | otherwise = line : xs + atomically $ do + writeTVar termHistory . addLine =<< readTVar termHistory + writeTVar termHistoryPos 0 + + case handleResult mbLine of KeepPrompt x -> do - termPutStr term "\n\ESC[J" + when termAnsi $ do + termPutStr term "\n\ESC[J" return x ErasePrompt x -> do - termPutStr term "\r\ESC[J" + when termAnsi $ do + termPutStr term "\r\ESC[J" return x where go = getInput >>= \case @@ -156,11 +183,12 @@ getInputLine term@Terminal {..} handleResult = do atomically $ do ( pre, post ) <- readTVar termInput writeTVar termInput ( "", "" ) - writeTVar termShowPrompt False - writeTVar termBottomLines [] + when termAnsi $ do + writeTVar termShowPrompt False + writeTVar termBottomLines [] return $ Just $ pre ++ post - InputChar '\t' -> do + InputChar '\t' | termAnsi -> do options <- withMVar termLock $ const $ do ( pre, post ) <- atomically $ readTVar termInput let updatePrompt pre' = do @@ -179,9 +207,11 @@ getInputLine term@Terminal {..} handleResult = do ( unused, completions@(c : cs) ) -> do let commonPrefixes' x y = fmap (\( common, _, _ ) -> common) $ T.commonPrefixes x y case foldl' (\mbcommon cur -> commonPrefixes' cur =<< mbcommon) (Just $ replacement c) (fmap replacement cs) of - Just common -> updatePrompt $ T.unpack unused ++ T.unpack common - Nothing -> return () - return $ map replacement completions + Just common | T.unpack common /= pre -> do + updatePrompt $ T.unpack unused ++ T.unpack common + return [] + _ -> do + return $ map replacement completions ( _, [] ) -> do return [] @@ -196,6 +226,37 @@ getInputLine term@Terminal {..} handleResult = do InputChar _ -> go + InputMoveUp -> withInput $ \prepost -> do + hist <- readTVar termHistory + pos <- readTVar termHistoryPos + case drop pos hist of + ( h : _ ) -> do + when (pos == 0) $ do + writeTVar termHistoryStash prepost + writeTVar termHistoryPos (pos + 1) + writeTVar termInput ( h, "" ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + [] -> do + return "" + + InputMoveDown -> withInput $ \_ -> do + readTVar termHistoryPos >>= \case + 0 -> do + return "" + 1 -> do + writeTVar termHistoryPos 0 + writeTVar termInput =<< readTVar termHistoryStash + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + pos -> do + writeTVar termHistoryPos (pos - 1) + hist <- readTVar termHistory + case drop (pos - 2) hist of + ( h : _ ) -> do + writeTVar termInput ( h, "" ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + [] -> do + return "" + InputMoveRight -> withInput $ \case ( pre, c : post ) -> do writeTVar termInput ( pre ++ [ c ], post ) @@ -241,7 +302,7 @@ getInputLine term@Terminal {..} handleResult = do withInput f = do withMVar termLock $ const $ do str <- atomically $ f =<< readTVar termInput - when (not $ null str) $ do + when (termAnsi && not (null str)) $ do putStr str hFlush stdout go @@ -254,6 +315,8 @@ getCurrentPromptLine Terminal {..} = do return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u" setPrompt :: Terminal -> String -> IO () +setPrompt Terminal { termAnsi = False } _ = do + return () setPrompt term@Terminal {..} prompt = do withMVar termLock $ \_ -> do join $ atomically $ do @@ -269,17 +332,26 @@ setPrompt term@Terminal {..} prompt = do printLine :: Terminal -> String -> IO TerminalLine printLine tlTerminal@Terminal {..} str = do withMVar termLock $ \_ -> do - promptLine <- atomically $ do - readTVar termShowPrompt >>= \case - True -> getCurrentPromptLine tlTerminal - False -> return "" - putStr $ "\r\ESC[K" <> str <> "\n\ESC[K" <> promptLine - drawBottomLines tlTerminal + let strLines = lines str + tlLineCount = length strLines + if termAnsi + then do + promptLine <- atomically $ do + readTVar termShowPrompt >>= \case + True -> getCurrentPromptLine tlTerminal + False -> return "" + putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine + drawBottomLines tlTerminal + else do + putStr $ unlines strLines + hFlush stdout return TerminalLine {..} printBottomLines :: Terminal -> String -> IO () +printBottomLines Terminal { termAnsi = False } _ = do + return () printBottomLines term@Terminal {..} str = do case lines str of [] -> clearBottomLines term @@ -290,6 +362,8 @@ printBottomLines term@Terminal {..} str = do hFlush stdout clearBottomLines :: Terminal -> IO () +clearBottomLines Terminal { termAnsi = False } = do + return () clearBottomLines Terminal {..} = do withMVar termLock $ \_ -> do atomically (readTVar termBottomLines) >>= \case diff --git a/main/Test.hs b/main/Test.hs index c563291..da49257 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -15,10 +15,12 @@ import Control.Monad.State import Crypto.Random import Data.Bool +import Data.ByteString (ByteString) import Data.ByteString qualified as B import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL import Data.ByteString.Lazy.Char8 qualified as BL +import Data.Char import Data.Foldable import Data.Ord import Data.Text (Text) @@ -39,6 +41,7 @@ import Erebos.Contact import Erebos.DirectMessage import Erebos.Discovery import Erebos.Identity +import Erebos.Invite import Erebos.Network import Erebos.Object import Erebos.Pairing @@ -117,9 +120,9 @@ runTestTool st = do getLineMb :: MonadIO m => m (Maybe Text) getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e) -getLines :: MonadIO m => m [Text] -getLines = getLineMb >>= \case - Just line | not (T.null line) -> (line:) <$> getLines +getLines :: MonadIO m => Text -> m [ Text ] +getLines eof = getLineMb >>= \case + Just line | line /= eof -> (line :) <$> getLines eof _ -> return [] getHead :: CommandM (Head LocalState) @@ -128,6 +131,26 @@ getHead = do modify $ \s -> s { tsHead = Just h } return h +showHex :: ByteString -> ByteString +showHex = B.concat . map showHexByte . B.unpack + where showHexChar x | x < 10 = x + o '0' + | otherwise = x + o 'a' - 10 + showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ] + o = fromIntegral . ord + +readHex :: ByteString -> Maybe ByteString +readHex = return . B.concat <=< readHex' + where readHex' bs | B.null bs = Just [] + readHex' bs = do (bx, bs') <- B.uncons bs + (by, bs'') <- B.uncons bs' + x <- hexDigit bx + y <- hexDigit by + (B.singleton (x * 16 + y) :) <$> readHex' bs'' + hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0' + | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10 + | otherwise = Nothing + o = fromIntegral . ord + type Output = MVar () @@ -227,14 +250,33 @@ directMessageAttributes out = DirectMessageAttributes { dmOwnerMismatch = afterCommit $ outLine out "dm-owner-mismatch" } -dmReceivedWatcher :: Output -> Stored DirectMessage -> IO () -dmReceivedWatcher out smsg = do - let msg = fromStored smsg - outLine out $ unwords - [ "dm-received" - , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg - , "text", T.unpack $ msgText msg - ] +discoveryAttributes :: DiscoveryAttributes +discoveryAttributes = (defaultServiceAttributes Proxy) + { discoveryProvideTunnel = \_ _ -> False + } + +inviteAttributes :: Output -> InviteServiceAttributes +inviteAttributes out = (defaultServiceAttributes Proxy) + { inviteHookAccepted = \token -> do + pid <- asks svcPeerIdentity + afterCommit $ outLine out $ "invite-accepted " <> BC.unpack (showHex token) <> " " <> (BC.unpack $ showRef $ storedRef $ idExtData pid) + , inviteHookReplyContact = \token _ -> do + afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " contact" + , inviteHookReplyInvalid = \token -> do + afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " invalid" + } + +dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () +dmThreadWatcher self out prev cur = do + forM_ (reverse $ dmThreadToListSinceUnread prev cur) $ \( msg, new ) -> do + outLine out $ unwords + [ if sameIdentity self (msgFrom msg) + then "dm-sent" + else "dm-received" + , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg + , "new", if new then "yes" else "no" + , "text", T.unpack $ msgText msg + ] newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a) @@ -258,63 +300,72 @@ instance MonadHead LocalState CommandM where type Command = CommandM () -commands :: [(Text, Command)] -commands = map (T.pack *** id) - [ ("store", cmdStore) - , ("load", cmdLoad) - , ("stored-generation", cmdStoredGeneration) - , ("stored-roots", cmdStoredRoots) - , ("stored-set-add", cmdStoredSetAdd) - , ("stored-set-list", cmdStoredSetList) - , ("head-create", cmdHeadCreate) - , ("head-replace", cmdHeadReplace) - , ("head-watch", cmdHeadWatch) - , ("head-unwatch", cmdHeadUnwatch) - , ("create-identity", cmdCreateIdentity) - , ("identity-info", cmdIdentityInfo) - , ("start-server", cmdStartServer) - , ("stop-server", cmdStopServer) - , ("peer-add", cmdPeerAdd) - , ("peer-drop", cmdPeerDrop) - , ("peer-list", cmdPeerList) - , ("test-message-send", cmdTestMessageSend) - , ("test-stream-open", cmdTestStreamOpen) - , ("test-stream-close", cmdTestStreamClose) - , ("test-stream-send", cmdTestStreamSend) - , ("local-state-get", cmdLocalStateGet) - , ("local-state-replace", cmdLocalStateReplace) - , ("local-state-wait", cmdLocalStateWait) - , ("shared-state-get", cmdSharedStateGet) - , ("shared-state-wait", cmdSharedStateWait) - , ("watch-local-identity", cmdWatchLocalIdentity) - , ("watch-shared-identity", cmdWatchSharedIdentity) - , ("update-local-identity", cmdUpdateLocalIdentity) - , ("update-shared-identity", cmdUpdateSharedIdentity) - , ("attach-to", cmdAttachTo) - , ("attach-accept", cmdAttachAccept) - , ("attach-reject", cmdAttachReject) - , ("contact-request", cmdContactRequest) - , ("contact-accept", cmdContactAccept) - , ("contact-reject", cmdContactReject) - , ("contact-list", cmdContactList) - , ("contact-set-name", cmdContactSetName) - , ("dm-send-peer", cmdDmSendPeer) - , ("dm-send-contact", cmdDmSendContact) - , ("dm-list-peer", cmdDmListPeer) - , ("dm-list-contact", cmdDmListContact) - , ("chatroom-create", cmdChatroomCreate) - , ("chatroom-delete", cmdChatroomDelete) - , ("chatroom-list-local", cmdChatroomListLocal) - , ("chatroom-watch-local", cmdChatroomWatchLocal) - , ("chatroom-set-name", cmdChatroomSetName) - , ("chatroom-subscribe", cmdChatroomSubscribe) - , ("chatroom-unsubscribe", cmdChatroomUnsubscribe) - , ("chatroom-members", cmdChatroomMembers) - , ("chatroom-join", cmdChatroomJoin) - , ("chatroom-join-as", cmdChatroomJoinAs) - , ("chatroom-leave", cmdChatroomLeave) - , ("chatroom-message-send", cmdChatroomMessageSend) - , ("discovery-connect", cmdDiscoveryConnect) +commands :: [ ( Text, Command ) ] +commands = + [ ( "store", cmdStore ) + , ( "store-raw", cmdStoreRaw ) + , ( "load", cmdLoad ) + , ( "load-type", cmdLoadType ) + , ( "stored-generation", cmdStoredGeneration ) + , ( "stored-roots", cmdStoredRoots ) + , ( "stored-set-add", cmdStoredSetAdd ) + , ( "stored-set-list", cmdStoredSetList ) + , ( "stored-difference", cmdStoredDifference ) + , ( "head-create", cmdHeadCreate ) + , ( "head-replace", cmdHeadReplace ) + , ( "head-watch", cmdHeadWatch ) + , ( "head-unwatch", cmdHeadUnwatch ) + , ( "create-identity", cmdCreateIdentity ) + , ( "identity-info", cmdIdentityInfo ) + , ( "start-server", cmdStartServer ) + , ( "stop-server", cmdStopServer ) + , ( "peer-add", cmdPeerAdd ) + , ( "peer-drop", cmdPeerDrop ) + , ( "peer-list", cmdPeerList ) + , ( "test-message-send", cmdTestMessageSend ) + , ( "test-stream-open", cmdTestStreamOpen ) + , ( "test-stream-close", cmdTestStreamClose ) + , ( "test-stream-send", cmdTestStreamSend ) + , ( "local-state-get", cmdLocalStateGet ) + , ( "local-state-replace", cmdLocalStateReplace ) + , ( "local-state-wait", cmdLocalStateWait ) + , ( "shared-state-get", cmdSharedStateGet ) + , ( "shared-state-wait", cmdSharedStateWait ) + , ( "watch-local-identity", cmdWatchLocalIdentity ) + , ( "watch-shared-identity", cmdWatchSharedIdentity ) + , ( "update-local-identity", cmdUpdateLocalIdentity ) + , ( "update-shared-identity", cmdUpdateSharedIdentity ) + , ( "attach-to", cmdAttachTo ) + , ( "attach-accept", cmdAttachAccept ) + , ( "attach-reject", cmdAttachReject ) + , ( "contact-request", cmdContactRequest ) + , ( "contact-accept", cmdContactAccept ) + , ( "contact-reject", cmdContactReject ) + , ( "contact-list", cmdContactList ) + , ( "contact-set-name", cmdContactSetName ) + , ( "dm-send-peer", cmdDmSendPeer ) + , ( "dm-send-contact", cmdDmSendContact ) + , ( "dm-send-identity", cmdDmSendIdentity ) + , ( "dm-list-peer", cmdDmListPeer ) + , ( "dm-list-contact", cmdDmListContact ) + , ( "dm-list-identity", cmdDmListIdentity ) + , ( "dm-mark-seen", cmdDmMarkSeen ) + , ( "chatroom-create", cmdChatroomCreate ) + , ( "chatroom-delete", cmdChatroomDelete ) + , ( "chatroom-list-local", cmdChatroomListLocal ) + , ( "chatroom-watch-local", cmdChatroomWatchLocal ) + , ( "chatroom-set-name", cmdChatroomSetName ) + , ( "chatroom-subscribe", cmdChatroomSubscribe ) + , ( "chatroom-unsubscribe", cmdChatroomUnsubscribe ) + , ( "chatroom-members", cmdChatroomMembers ) + , ( "chatroom-join", cmdChatroomJoin ) + , ( "chatroom-join-as", cmdChatroomJoinAs ) + , ( "chatroom-leave", cmdChatroomLeave ) + , ( "chatroom-message-send", cmdChatroomMessageSend ) + , ( "discovery-connect", cmdDiscoveryConnect ) + , ( "discovery-tunnel", cmdDiscoveryTunnel ) + , ( "invite-contact-create", cmdInviteContactCreate ) + , ( "invite-accept", cmdInviteAccept ) ] cmdStore :: Command @@ -322,7 +373,7 @@ cmdStore = do st <- asks tiStorage pst <- liftIO $ derivePartialStorage st [otype] <- asks tiParams - ls <- getLines + ls <- getLines T.empty let cnt = encodeUtf8 $ T.unlines ls full = BL.fromChunks @@ -335,6 +386,18 @@ cmdStore = do Right ref -> cmdOut $ "store-done " ++ show (refDigest ref) Left _ -> cmdOut $ "store-failed" +cmdStoreRaw :: Command +cmdStoreRaw = do + st <- asks tiStorage + pst <- liftIO $ derivePartialStorage st + [ eof ] <- asks tiParams + ls <- getLines eof + + let full = BL.fromStrict $ BC.init $ encodeUtf8 $ T.unlines ls + liftIO (copyRef st =<< storeRawBytes pst full) >>= \case + Right ref -> cmdOut $ "store-done " ++ show (refDigest ref) + Left _ -> cmdOut $ "store-failed" + cmdLoad :: Command cmdLoad = do st <- asks tiStorage @@ -347,6 +410,20 @@ cmdLoad = do cmdOut $ "load-line " <> T.unpack (decodeUtf8 $ BL.toStrict line) cmdOut "load-done" +cmdLoadType :: Command +cmdLoadType = do + st <- asks tiStorage + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + let obj = load @Object ref + let otype = case obj of + Blob {} -> "blob" + Rec {} -> "rec" + OnDemand {} -> "ondemand" + ZeroObject {} -> "zero" + UnknownObject utype _ -> "unknown " <> decodeUtf8 utype + cmdOut $ "load-type " <> T.unpack otype + cmdStoredGeneration :: Command cmdStoredGeneration = do st <- asks tiStorage @@ -368,7 +445,7 @@ cmdStoredSetAdd = do [Just iref, Just sref] -> return (wrappedLoad iref, loadSet @[Stored Object] sref) [Just iref] -> return (wrappedLoad iref, emptySet) _ -> fail "unexpected parameters" - set' <- storeSetAdd st [item] set + set' <- storeSetAdd [ item ] set cmdOut $ "stored-set-add" ++ concatMap ((' ':) . show . refDigest . storedRef) (toComponents set') cmdStoredSetList :: Command @@ -381,6 +458,19 @@ cmdStoredSetList = do cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item cmdOut $ "stored-set-done" +cmdStoredDifference :: Command +cmdStoredDifference = do + st <- asks tiStorage + ( trefs1, "|" : trefs2 ) <- span (/= "|") <$> asks tiParams + + let loadObjs = mapM (maybe (fail "invalid ref") (return . wrappedLoad @Object) <=< liftIO . readRef st . encodeUtf8) + objs1 <- loadObjs trefs1 + objs2 <- loadObjs trefs2 + + forM_ (storedDifference objs1 objs2) $ \item -> do + cmdOut $ "stored-difference-item " ++ (show $ refDigest $ storedRef item) + cmdOut $ "stored-difference-done" + cmdHeadCreate :: Command cmdHeadCreate = do [ ttid, tref ] <- asks tiParams @@ -435,7 +525,8 @@ cmdHeadUnwatch = do initTestHead :: Head LocalState -> Command initTestHead h = do - _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput + let self = finalOwner $ headLocalIdentity h + _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher self =<< asks tiOutput modify $ \s -> s { tsHead = Just h } loadTestHead :: CommandM (Head LocalState) @@ -458,13 +549,13 @@ cmdCreateIdentity = do st <- asks tiStorage names <- asks tiParams - h <- liftIO $ do + h <- do Just identity <- if null names - then Just <$> createIdentity st Nothing Nothing - else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names + then Just <$> createIdentity Nothing Nothing + else foldrM (\n o -> Just <$> createIdentity (Just n) o) Nothing names shared <- case names of - _:_:_ -> (:[]) <$> makeSharedStateUpdate st (Just $ finalOwner identity) [] + _:_:_ -> (: []) <$> makeSharedStateUpdate (Just $ finalOwner identity) [] _ -> return [] storeHead st $ LocalState @@ -497,21 +588,32 @@ cmdStartServer = do let parseParams = \case (name : value : rest) - | name == "services" -> T.splitOn "," value + | name == "services" -> second ( map splitServiceParams (T.splitOn "," value) ++ ) (parseParams rest) + (name : rest) + | name == "test-log" -> first (\o -> o { serverTestLog = True }) (parseParams rest) | otherwise -> parseParams rest - _ -> [] - serviceNames <- parseParams <$> asks tiParams + _ -> ( defaultServerOptions { serverErrorPrefix = "server-error-message " }, [] ) + + splitServiceParams svc = + case T.splitOn ":" svc of + name : params -> ( name, params ) + _ -> ( svc, [] ) + + ( serverOptions, serviceNames ) <- parseParams <$> asks tiParams h <- getOrLoadHead rsPeers <- liftIO $ newMVar (1, []) services <- forM serviceNames $ \case - "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" - "chatroom" -> return $ someService @ChatroomService Proxy - "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" - "discovery" -> return $ someService @DiscoveryService Proxy - "dm" -> return $ someServiceAttr $ directMessageAttributes out - "sync" -> return $ someService @SyncService Proxy - "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) + ( "attach", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" + ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy + ( "contact", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" + ( "discovery", params ) -> return $ someServiceAttr $ discoveryAttributes + { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params + } + ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out + ( "invite", _ ) -> return $ someServiceAttr $ inviteAttributes out + ( "sync", _ ) -> return $ someService @SyncService Proxy + ( "test", _ ) -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) { testMessageReceived = \obj otype len sref -> do liftIO $ do void $ store (headStorage h) obj @@ -530,17 +632,22 @@ cmdStartServer = do outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ] go } - sname -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" + ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" - rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services + let logPrint str = do BC.hPutStrLn stdout (BC.pack str) + hFlush stdout + rsServer <- liftIO $ startServer serverOptions h logPrint services rsPeerThread <- liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange rsServer let printPeer TestPeer {..} = do - params <- peerIdentity tpPeer >>= return . \case - PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) - _ -> [ "addr", show (peerAddress tpPeer) ] + params <- getPeerIdentity tpPeer >>= \case + PeerIdentityFull pid -> do + return $ ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) + _ -> do + paddr <- getPeerAddress tpPeer + return $ [ "addr", show paddr ] outLine out $ unwords $ [ "peer", show tpIndex ] ++ params update ( tpIndex, [] ) = do @@ -591,10 +698,11 @@ cmdPeerList = do tpeers <- liftIO $ readMVar rsPeers forM_ peers $ \peer -> do Just tp <- return $ find ((peer ==) . tpPeer) . snd $ tpeers - mbpid <- peerIdentity peer + mbpid <- getPeerIdentity peer + paddr <- getPeerAddress peer cmdOut $ unwords $ concat [ [ "peer-list-item", show (tpIndex tp) ] - , [ "addr", show (peerAddress peer) ] + , [ "addr", show paddr ] , case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) _ -> [] ] @@ -807,7 +915,7 @@ cmdContactSetName = do cmdDmSendPeer :: Command cmdDmSendPeer = do [spidx, msg] <- asks tiParams - PeerIdentityFull to <- peerIdentity =<< getPeer spidx + PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx void $ sendDirectMessage to msg cmdDmSendContact :: Command @@ -816,13 +924,22 @@ cmdDmSendContact = do Just to <- contactIdentity <$> getContact cid void $ sendDirectMessage to msg +cmdDmSendIdentity :: Command +cmdDmSendIdentity = do + st <- asks tiStorage + [ tid, msg ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tid + Just to <- return $ validateExtendedIdentity $ wrappedLoad ref + void $ sendDirectMessage to msg + dmList :: Foldable f => Identity f -> Command dmList peer = do - threads <- toThreadList . lookupSharedValue . lsShared . headObject <$> getHead + threads <- dmThreadList . lookupSharedValue . lsShared . headObject <$> getHead case find (sameIdentity peer . msgPeer) threads of Just thread -> do - forM_ (reverse $ threadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item" + forM_ (reverse $ dmThreadToListUnread thread) $ \( DirectMessage {..}, new ) -> cmdOut $ "dm-list-item" <> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom) + <> " new " <> (if new then "yes" else "no") <> " text " <> (T.unpack msgText) Nothing -> return () cmdOut "dm-list-done" @@ -830,7 +947,7 @@ dmList peer = do cmdDmListPeer :: Command cmdDmListPeer = do [spidx] <- asks tiParams - PeerIdentityFull to <- peerIdentity =<< getPeer spidx + PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx dmList to cmdDmListContact :: Command @@ -839,6 +956,23 @@ cmdDmListContact = do Just to <- contactIdentity <$> getContact cid dmList to +cmdDmListIdentity :: Command +cmdDmListIdentity = do + st <- asks tiStorage + [ tid ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tid + Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref + dmList pid + +cmdDmMarkSeen :: Command +cmdDmMarkSeen = do + st <- asks tiStorage + [ tid ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tid + Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref + dmMarkAsSeen pid + cmdOut $ unwords [ "dm-mark-seen-done", T.unpack tid ] + cmdChatroomCreate :: Command cmdChatroomCreate = do [name] <- asks tiParams @@ -938,8 +1072,7 @@ cmdChatroomJoin = do cmdChatroomJoinAs :: Command cmdChatroomJoinAs = do [ cid, name ] <- asks tiParams - st <- asks tiStorage - identity <- liftIO $ createIdentity st (Just name) Nothing + identity <- createIdentity (Just name) Nothing joinChatroomAsByStateData identity =<< getChatroomStateData cid cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ] @@ -961,3 +1094,24 @@ cmdDiscoveryConnect = do Just dgst <- return $ readRefDigest $ encodeUtf8 tref Just RunningServer {..} <- gets tsServer discoverySearch rsServer dgst + +cmdDiscoveryTunnel :: Command +cmdDiscoveryTunnel = do + [ tvia, ttarget ] <- asks tiParams + via <- getPeer tvia + Just target <- return $ readRefDigest $ encodeUtf8 ttarget + liftIO $ discoverySetupTunnel via target + +cmdInviteContactCreate :: Command +cmdInviteContactCreate = do + [ name ] <- asks tiParams + Just token <- inviteToken <$> createSingleContactInvite name + cmdOut $ unwords [ "invite-contact-create-done", BC.unpack (showHex token) ] + +cmdInviteAccept :: Command +cmdInviteAccept = do + [ tokenText, idref ] <- asks tiParams + Just token <- return $ readHex $ encodeUtf8 tokenText + Just from <- return $ readRefDigest $ encodeUtf8 idref + Just RunningServer {..} <- gets tsServer + acceptInvite rsServer from token diff --git a/main/WebSocket.hs b/main/WebSocket.hs index fbdd65f..7a957e2 100644 --- a/main/WebSocket.hs +++ b/main/WebSocket.hs @@ -1,4 +1,5 @@ module WebSocket ( + WebSocketAddress(..), startWebsocketServer, ) where @@ -26,8 +27,10 @@ instance Show WebSocketAddress where show (WebSocketAddress _ _) = "websocket" instance PeerAddressType WebSocketAddress where - sendBytesToAddress (WebSocketAddress _ conn) msg = do - WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg + sendBytesToAddress (WebSocketAddress _ conn) msg = do + WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg + connectionToAddressClosed (WebSocketAddress _ conn) = do + WS.sendClose conn BL.empty startWebsocketServer :: Server -> String -> Int -> (String -> IO ()) -> IO () startWebsocketServer server addr port logd = do |