diff options
Diffstat (limited to 'main')
| -rw-r--r-- | main/Main.hs | 530 | ||||
| -rw-r--r-- | main/State.hs | 80 | ||||
| -rw-r--r-- | main/Terminal.hs | 346 | ||||
| -rw-r--r-- | main/Test.hs | 202 | ||||
| -rw-r--r-- | main/Test/Service.hs | 12 |
5 files changed, 1013 insertions, 157 deletions
diff --git a/main/Main.hs b/main/Main.hs index 0eb414c..3f78db1 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -24,46 +24,58 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T +import Data.Time.Format import Data.Time.LocalTime import Data.Typeable import Network.Socket import System.Console.GetOpt -import System.Console.Haskeline +import System.Directory import System.Environment import System.Exit import System.IO import Erebos.Attach import Erebos.Contact +import Erebos.Chatroom import Erebos.Conversation -#ifdef ENABLE_ICE_SUPPORT +import Erebos.DirectMessage import Erebos.Discovery +#ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif import Erebos.Identity -import Erebos.Message hiding (formatMessage) import Erebos.Network +import Erebos.Object import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State +import Erebos.Storable import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync +import State +import Terminal import Test import Version data Options = Options { optServer :: ServerOptions , optServices :: [ServiceOption] + , optStorage :: StorageOption + , optChatroomAutoSubscribe :: Maybe Int , optDmBotEcho :: Maybe Text , optShowHelp :: Bool , optShowVersion :: Bool } +data StorageOption = DefaultStorage + | FilesystemStorage FilePath + | MemoryStorage + data ServiceOption = ServiceOption { soptName :: String , soptService :: SomeService @@ -75,6 +87,8 @@ defaultOptions :: Options defaultOptions = Options { optServer = defaultServerOptions , optServices = availableServices + , optStorage = DefaultStorage + , optChatroomAutoSubscribe = Nothing , optDmBotEcho = Nothing , optShowHelp = False , optShowVersion = False @@ -86,14 +100,14 @@ availableServices = True "attach (to) other devices" , ServiceOption "sync" (someService @SyncService Proxy) True "synchronization with attached devices" + , ServiceOption "chatroom" (someService @ChatroomService Proxy) + True "chatrooms with multiple participants" , ServiceOption "contact" (someService @ContactService Proxy) True "create contacts with network peers" , ServiceOption "dm" (someService @DirectMessage Proxy) True "direct messages" -#ifdef ENABLE_ICE_SUPPORT , ServiceOption "discovery" (someService @DiscoveryService Proxy) True "peer discovery" -#endif ] options :: [OptDescr (Options -> Options)] @@ -104,6 +118,29 @@ options = , Option ['s'] ["silent"] (NoArg (so $ \opts -> opts { serverLocalDiscovery = False })) "do not send announce packets for local discovery" + , Option [] [ "storage" ] + (ReqArg (\path -> \opts -> opts { optStorage = FilesystemStorage path }) "<path>") + "use storage in <path>" + , Option [] [ "memory-storage" ] + (NoArg (\opts -> opts { optStorage = MemoryStorage })) + "use memory storage" + , Option [] ["chatroom-auto-subscribe"] + (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>") + "automatically subscribe for up to <count> chatrooms" +#ifdef ENABLE_ICE_SUPPORT + , Option [] [ "discovery-stun-port" ] + (ReqArg (\value -> serviceAttr $ \attrs -> 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>") + "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>") + "offer specified <port> to discovery peers for TURN protocol" + , Option [] [ "discovery-turn-server" ] + (ReqArg (\value -> serviceAttr $ \attrs -> 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>") "automatically reply to direct messages with the same text prefixed with <prefix>" @@ -114,7 +151,16 @@ options = (NoArg $ \opts -> opts { optShowVersion = True }) "show version and exit" ] - where so f opts = opts { optServer = f $ optServer opts } + where + so f opts = opts { optServer = f $ optServer opts } + + updateService :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> SomeService -> 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)] servicesOptions = concatMap helper $ "all" : map soptName availableServices @@ -131,10 +177,30 @@ servicesOptions = concatMap helper $ "all" : map soptName availableServices | otherwise = s : change name f ss change _ _ [] = [] +getDefaultStorageDir :: IO FilePath +getDefaultStorageDir = do + lookupEnv "EREBOS_DIR" >>= \case + Just dir -> return dir + Nothing -> doesFileExist "./.erebos/erebos-storage" >>= \case + True -> return "./.erebos" + False -> getXdgDirectory XdgData "erebos" + main :: IO () main = do - st <- liftIO $ openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR" - getArgs >>= \case + (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case + (o, args, []) -> do + return (foldl (flip id) defaultOptions o, args) + (_, _, errs) -> do + progName <- getProgName + hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information." + exitFailure + + st <- liftIO $ case optStorage opts of + DefaultStorage -> openStorage =<< getDefaultStorageDir + FilesystemStorage path -> openStorage path + MemoryStorage -> memoryStorage + + case args of ["cat-file", sref] -> do readRef st (BC.pack sref) >>= \case Nothing -> error "ref does not exist" @@ -150,7 +216,7 @@ main = do forM_ (signedSignature signed) $ \sig -> do putStr $ "SIG " BC.putStrLn $ showRef $ storedRef $ sigKey $ fromStored sig - "identity" -> case validateIdentityF (wrappedLoad <$> refs) of + "identity" -> case validateExtendedIdentityF (wrappedLoad <$> refs) of Just identity -> do let disp :: Identity m -> IO () disp idt = do @@ -160,7 +226,7 @@ main = do case idOwner idt of Nothing -> return () Just owner -> do - mapM_ (putStrLn . ("OWNER " ++) . BC.unpack . showRefDigest . refDigest . storedRef) $ idDataF owner + mapM_ (putStrLn . ("OWNER " ++) . BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF owner disp owner disp identity Nothing -> putStrLn $ "Identity verification failed" @@ -170,62 +236,59 @@ main = do Nothing -> error "ref does not exist" Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object) - ["update-identity"] -> either fail return <=< runExceptT $ do - runReaderT updateSharedIdentity =<< loadLocalStateHead st + ["update-identity"] -> do + withTerminal noCompletion $ \term -> do + either (fail . showErebosError) return <=< runExceptT $ do + runReaderT (updateSharedIdentity term) =<< loadLocalStateHead term st ("update-identity" : srefs) -> do - sequence <$> mapM (readRef st . BC.pack) srefs >>= \case - Nothing -> error "ref does not exist" - Just refs - | Just idt <- validateIdentityF $ map wrappedLoad refs -> do - BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< - (either fail return <=< runExceptT $ runReaderT (interactiveIdentityUpdate idt) st) - | otherwise -> error "invalid identity" + withTerminal noCompletion $ \term -> do + sequence <$> mapM (readRef st . BC.pack) srefs >>= \case + Nothing -> error "ref does not exist" + Just refs + | Just idt <- validateIdentityF $ map wrappedLoad refs -> do + BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< + (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st) + | otherwise -> error "invalid identity" ["test"] -> runTestTool st - args -> case getOpt Permute (options ++ servicesOptions) args of - (o, [], []) -> do - let opts = foldl (flip id) defaultOptions o - header = "Usage: erebos [OPTION...]" - serviceDesc ServiceOption {..} = padService (" " <> soptName) <> soptDescription - - padTo n str = str <> replicate (n - length str) ' ' - padOpt = padTo 37 - padService = padTo 16 - - if | optShowHelp opts -> putStr $ usageInfo header options <> unlines - ( - [ padOpt " --enable-<service>" <> "enable network service <service>" - , padOpt " --disable-<service>" <> "disable network service <service>" - , padOpt " --enable-all" <> "enable all network services" - , padOpt " --disable-all" <> "disable all network services" - , "" - , "Available network services:" - ] ++ map serviceDesc availableServices - ) - | optShowVersion opts -> putStrLn versionLine - | otherwise -> interactiveLoop st opts - (_, _, errs) -> do - progName <- getProgName - hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information." - exitFailure - - -inputSettings :: Settings IO -inputSettings = setComplete commandCompletion $ defaultSettings + [] -> do + let header = "Usage: erebos [OPTION...]" + serviceDesc ServiceOption {..} = padService (" " <> soptName) <> soptDescription + + padTo n str = str <> replicate (n - length str) ' ' + padOpt = padTo 37 + padService = padTo 16 + + if | optShowHelp opts -> putStr $ usageInfo header options <> unlines + ( + [ padOpt " --enable-<service>" <> "enable network service <service>" + , padOpt " --disable-<service>" <> "disable network service <service>" + , padOpt " --enable-all" <> "enable all network services" + , padOpt " --disable-all" <> "disable all network services" + , "" + , "Available network services:" + ] ++ map serviceDesc availableServices + ) + | optShowVersion opts -> putStrLn versionLine + | otherwise -> interactiveLoop st opts + + (cmdname : _) -> do + hPutStrLn stderr $ "Unknown command `" <> cmdname <> "'" + exitFailure + interactiveLoop :: Storage -> Options -> IO () -interactiveLoop st opts = runInputT inputSettings $ do - erebosHead <- liftIO $ loadLocalStateHead st - outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead +interactiveLoop st opts = withTerminal commandCompletion $ \term -> do + erebosHead <- liftIO $ loadLocalStateHead term st + void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead - tui <- haveTerminalUI - extPrint <- getExternalPrint - let extPrintLn str = extPrint $ case reverse str of ('\n':_) -> str - _ -> str ++ "\n"; + let tui = hasTerminalUI term + let extPrintLn = void . printLine term - let getInputLinesTui eprompt = do + let getInputLinesTui :: Either CommandState String -> MaybeT IO String + getInputLinesTui eprompt = do prompt <- case eprompt of Left cstate -> do pname <- case csContext cstate of @@ -235,14 +298,18 @@ interactiveLoop st opts = runInputT inputSettings $ do PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">" PeerIdentityUnknown _ -> "<unknown>" SelectedContact contact -> return $ T.unpack $ contactName contact + SelectedChatroom rstate -> return $ T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate SelectedConversation conv -> return $ T.unpack $ conversationName conv return $ pname ++ "> " Right prompt -> return prompt - Just input <- lift $ getInputLine prompt - case reverse input of - _ | all isSpace input -> getInputLinesTui eprompt - '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ") - _ -> return input + lift $ setPrompt term prompt + join $ lift $ getInputLine term $ \case + Just input@('/' : _) -> KeepPrompt $ return input + Just input -> ErasePrompt $ case reverse input of + _ | all isSpace input -> getInputLinesTui eprompt + '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ") + _ -> return input + Nothing -> KeepPrompt mzero getInputCommandTui cstate = do input <- getInputLinesTui cstate @@ -255,7 +322,7 @@ interactiveLoop st opts = runInputT inputSettings $ do return (cmd, line) getInputLinesPipe = do - lift (getInputLine "") >>= \case + join $ lift $ getInputLine term $ KeepPrompt . \case Just input -> return input Nothing -> liftIO $ forever $ threadDelay 100000000 @@ -281,13 +348,20 @@ interactiveLoop st opts = runInputT inputSettings $ do Right reply -> extPrintLn $ formatDirectMessage tzone $ fromStored reply Left err -> extPrintLn $ "Failed to send dm echo: " <> err + peers <- liftIO $ newMVar [] + contextOptions <- liftIO $ newMVar [] + chatroomSetVar <- liftIO $ newEmptyMVar + + let autoSubscribe = optChatroomAutoSubscribe opts + chatroomList = fromSetBy (comparing roomStateData) . lookupSharedValue . lsShared . headObject $ erebosHead + watched <- if isJust autoSubscribe || any roomStateSubscribe chatroomList + then fmap Just $ liftIO $ watchChatroomsForCli extPrintLn erebosHead chatroomSetVar contextOptions autoSubscribe + else return Nothing + server <- liftIO $ do startServer (optServer opts) erebosHead extPrintLn $ map soptService $ filter soptEnabled $ optServices opts - peers <- liftIO $ newMVar [] - contextOptions <- liftIO $ newMVar [] - void $ liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange server peerIdentity peer >>= \case @@ -309,29 +383,33 @@ interactiveLoop st opts = runInputT inputSettings $ do when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown _ -> return () - let process :: CommandState -> MaybeT (InputT IO) CommandState + let process :: CommandState -> MaybeT IO CommandState process cstate = do (cmd, line) <- getInputCommand cstate h <- liftIO (reloadHead $ csHead cstate) >>= \case Just h -> return h - Nothing -> do lift $ lift $ extPrintLn "current head deleted" + Nothing -> do lift $ extPrintLn "current head deleted" mzero res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput { ciServer = server + , ciTerminal = term , ciLine = line , ciPrint = extPrintLn + , ciOptions = opts , ciPeers = liftIO $ modifyMVar peers $ \ps -> do ps' <- filterM (fmap not . isPeerDropped . fst) ps return (ps', ps') , ciContextOptions = liftIO $ readMVar contextOptions , ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs + , ciContextOptionsVar = contextOptions + , ciChatroomSetVar = chatroomSetVar } case res of Right cstate' | csQuit cstate' -> mzero | otherwise -> return cstate' Left err -> do - lift $ lift $ extPrintLn $ "Error: " ++ err + lift $ extPrintLn $ "Error: " ++ showErebosError err return cstate let loop (Just cstate) = runMaybeT (process cstate) >>= loop @@ -343,17 +421,22 @@ interactiveLoop st opts = runInputT inputSettings $ do , csIceSessions = [] #endif , csIcePeer = Nothing + , csWatchChatrooms = watched , csQuit = False } data CommandInput = CommandInput { ciServer :: Server + , ciTerminal :: Terminal , ciLine :: String , ciPrint :: String -> IO () + , ciOptions :: Options , ciPeers :: CommandM [(Peer, String)] , ciContextOptions :: CommandM [CommandContext] , ciSetContextOptions :: [CommandContext] -> Command + , ciContextOptionsVar :: MVar [ CommandContext ] + , ciChatroomSetVar :: MVar (Set ChatroomState) } data CommandState = CommandState @@ -363,23 +446,25 @@ data CommandState = CommandState , csIceSessions :: [IceSession] #endif , csIcePeer :: Maybe Peer + , csWatchChatrooms :: Maybe WatchedHead , csQuit :: Bool } data CommandContext = NoContext | SelectedPeer Peer | SelectedContact Contact + | SelectedChatroom ChatroomState | SelectedConversation Conversation -newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String) +newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a) + deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError) instance MonadFail CommandM where - fail = throwError + fail = throwOtherError instance MonadIO CommandM where liftIO act = CommandM (liftIO (try act)) >>= \case - Left (e :: SomeException) -> throwError (show e) + Left (e :: SomeException) -> throwOtherError (show e) Right x -> return x instance MonadRandom CommandM where @@ -400,18 +485,27 @@ type Command = CommandM () getSelectedPeer :: CommandM Peer getSelectedPeer = gets csContext >>= \case SelectedPeer peer -> return peer - _ -> throwError "no peer selected" + _ -> throwOtherError "no peer selected" + +getSelectedChatroom :: CommandM ChatroomState +getSelectedChatroom = gets csContext >>= \case + SelectedChatroom rstate -> return rstate + _ -> throwOtherError "no chatroom selected" getSelectedConversation :: CommandM Conversation getSelectedConversation = gets csContext >>= \case SelectedPeer peer -> peerIdentity peer >>= \case PeerIdentityFull pid -> directMessageConversation $ finalOwner pid - _ -> throwError "incomplete peer identity" + _ -> throwOtherError "incomplete peer identity" SelectedContact contact -> case contactIdentity contact of Just cid -> directMessageConversation cid - Nothing -> throwError "contact without erebos identity" + Nothing -> throwOtherError "contact without erebos identity" + SelectedChatroom rstate -> + chatroomConversation rstate >>= \case + Just conv -> return conv + Nothing -> throwOtherError "invalid chatroom" SelectedConversation conv -> reloadConversation conv - _ -> throwError "no contact, peer or conversation selected" + _ -> throwOtherError "no contact, peer or conversation selected" commands :: [(String, Command)] commands = @@ -421,25 +515,32 @@ commands = , ("peer-add-public", cmdPeerAddPublic) , ("peer-drop", cmdPeerDrop) , ("send", cmdSend) + , ("delete", cmdDelete) , ("update-identity", cmdUpdateIdentity) , ("attach", cmdAttach) , ("attach-accept", cmdAttachAccept) , ("attach-reject", cmdAttachReject) + , ("chatrooms", cmdChatrooms) + , ("chatroom-create-public", cmdChatroomCreatePublic) , ("contacts", cmdContacts) , ("contact-add", cmdContactAdd) , ("contact-accept", cmdContactAccept) , ("contact-reject", cmdContactReject) , ("conversations", cmdConversations) , ("details", cmdDetails) -#ifdef ENABLE_ICE_SUPPORT , ("discovery-init", cmdDiscoveryInit) , ("discovery", cmdDiscovery) +#ifdef ENABLE_ICE_SUPPORT , ("ice-create", cmdIceCreate) , ("ice-destroy", cmdIceDestroy) , ("ice-show", cmdIceShow) , ("ice-connect", cmdIceConnect) , ("ice-send", cmdIceSend) #endif + , ("join", cmdJoin) + , ("join-as", cmdJoinAs) + , ("leave", cmdLeave) + , ("members", cmdMembers) , ("select", cmdSelectContext) , ("quit", cmdQuit) ] @@ -452,8 +553,13 @@ commandCompletion = completeWordWithPrev Nothing [ ' ', '\t', '\n', '\r' ] $ cur sortedCommandNames = sort $ map fst commands +cmdPutStrLn :: String -> Command +cmdPutStrLn str = do + term <- asks ciTerminal + void $ liftIO $ printLine term str + cmdUnknown :: String -> Command -cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd +cmdUnknown cmd = cmdPutStrLn $ "Unknown command: " ++ cmd cmdPeers :: Command cmdPeers = do @@ -461,7 +567,7 @@ cmdPeers = do set <- asks ciSetContextOptions set $ map (SelectedPeer . fst) peers forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ name + cmdPutStrLn $ "[" ++ show i ++ "] " ++ name cmdPeerAdd :: Command cmdPeerAdd = void $ do @@ -469,15 +575,26 @@ cmdPeerAdd = void $ do (hostname, port) <- (words <$> asks ciLine) >>= \case hostname:p:_ -> return (hostname, p) [hostname] -> return (hostname, show discoveryPort) - [] -> throwError "missing peer address" + [] -> throwOtherError "missing peer address" addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) liftIO $ serverPeer server (addrAddress addr) cmdPeerAddPublic :: Command cmdPeerAddPublic = do server <- asks ciServer - addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just "discovery1.erebosprotocol.net") (Just (show discoveryPort)) - void $ liftIO $ serverPeer server (addrAddress addr) + liftIO $ mapM_ (serverPeer server . addrAddress) =<< gather 'a' + where + gather c + | c <= 'z' = do + let hints = Just $ defaultHints { addrSocketType = Datagram } + hostname = Just $ c : ".discovery.erebosprotocol.net" + service = Just $ show discoveryPort + handle (\(_ :: IOException) -> return []) (getAddrInfo hints hostname service) >>= \case + addr : _ -> (addr :) <$> gather (succ c) + [] -> return [] + + | otherwise = do + return [] cmdPeerDrop :: Command cmdPeerDrop = do @@ -492,20 +609,53 @@ showPeer pidentity paddr = PeerIdentityFull pid -> T.unpack $ displayIdentity pid in name ++ " [" ++ show paddr ++ "]" +cmdJoin :: Command +cmdJoin = joinChatroom =<< getSelectedChatroom + +cmdJoinAs :: Command +cmdJoinAs = do + name <- asks ciLine + st <- getStorage + identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing + joinChatroomAs identity =<< getSelectedChatroom + +cmdLeave :: Command +cmdLeave = leaveChatroom =<< getSelectedChatroom + +cmdMembers :: Command +cmdMembers = do + Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom + forM_ (chatroomMembers room) $ \x -> do + cmdPutStrLn $ maybe "<unnamed>" T.unpack $ idName x + + cmdSelectContext :: Command cmdSelectContext = do n <- read <$> asks ciLine join (asks ciContextOptions) >>= \ctxs -> if - | n > 0, (ctx : _) <- drop (n - 1) ctxs -> modify $ \s -> s { csContext = ctx } - | otherwise -> throwError "invalid index" + | 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" cmdSend :: Command cmdSend = void $ do text <- asks ciLine conv <- getSelectedConversation - msg <- sendMessage conv $ T.pack text - tzone <- liftIO $ getCurrentTimeZone - liftIO $ putStrLn $ formatMessage tzone msg + sendMessage conv (T.pack text) >>= \case + Just msg -> do + tzone <- liftIO $ getCurrentTimeZone + cmdPutStrLn $ formatMessage tzone msg + Nothing -> return () + +cmdDelete :: Command +cmdDelete = void $ do + deleteConversation =<< getSelectedConversation + modify $ \s -> s { csContext = NoContext } cmdHistory :: Command cmdHistory = void $ do @@ -513,13 +663,14 @@ cmdHistory = void $ do case conversationHistory conv of thread@(_:_) -> do tzone <- liftIO $ getCurrentTimeZone - liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 thread + mapM_ (cmdPutStrLn . formatMessage tzone) $ reverse $ take 50 thread [] -> do - liftIO $ putStrLn $ "<empty history>" + cmdPutStrLn $ "<empty history>" cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do - runReaderT updateSharedIdentity =<< gets csHead + term <- asks ciTerminal + runReaderT (updateSharedIdentity term) =<< gets csHead cmdAttach :: Command cmdAttach = attachToOwner =<< getSelectedPeer @@ -530,6 +681,110 @@ cmdAttachAccept = attachAccept =<< getSelectedPeer cmdAttachReject :: Command cmdAttachReject = attachReject =<< getSelectedPeer +watchChatroomsForCli :: (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) -> MVar [ CommandContext ] -> Maybe Int -> IO WatchedHead +watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do + subscribedNumVar <- newEmptyMVar + + let ctxUpdate updateType (idx :: Int) rstate = \case + SelectedChatroom rstate' : rest + | currentRoots <- filterAncestors (concatMap storedRoots $ roomStateData rstate) + , any ((`intersectsSorted` currentRoots) . storedRoots) $ roomStateData rstate' + -> do + eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name + return (SelectedChatroom rstate : rest) + selected : rest + -> do + (selected : ) <$> ctxUpdate updateType (idx + 1) rstate rest + [] + -> do + eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name + return [ SelectedChatroom rstate ] + where + name = maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom rstate + + watchChatrooms h $ \set -> \case + Nothing -> do + let chatroomList = filter (not . roomStateDeleted) $ fromSetBy (comparing roomStateData) set + (subscribed, notSubscribed) = partition roomStateSubscribe chatroomList + subscribedNum = length subscribed + + putMVar chatroomSetVar set + putMVar subscribedNumVar subscribedNum + + case autoSubscribe of + Nothing -> return () + Just num -> do + forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do + (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case + Right () -> return () + Left err -> eprint (showErebosError err) + + Just diff -> do + modifyMVar_ chatroomSetVar $ return . const set + forM_ diff $ \case + AddedChatroom rstate -> do + modifyMVar_ contextVar $ ctxUpdate "NEW" 1 rstate + modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then (+ 1) else id + + RemovedChatroom rstate -> do + modifyMVar_ contextVar $ ctxUpdate "DEL" 1 rstate + modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then subtract 1 else id + + UpdatedChatroom oldroom rstate -> do + when (any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)) $ do + modifyMVar_ contextVar $ ctxUpdate "UPD" 1 rstate + when (any (not . null . rsdMessages . fromStored) (roomStateData rstate)) $ do + tzone <- getCurrentTimeZone + forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do + eprint $ concat $ + [ maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg + , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg + , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg + , if cmsgLeave msg then " left" else "" + , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg + ] + modifyMVar_ subscribedNumVar $ return + . (if roomStateSubscribe rstate then (+ 1) else id) + . (if roomStateSubscribe oldroom then subtract 1 else id) + +ensureWatchedChatrooms :: Command +ensureWatchedChatrooms = do + gets csWatchChatrooms >>= \case + Nothing -> do + eprint <- asks ciPrint + h <- gets csHead + chatroomSetVar <- asks ciChatroomSetVar + contextVar <- asks ciContextOptionsVar + autoSubscribe <- asks $ optChatroomAutoSubscribe . ciOptions + watched <- liftIO $ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe + modify $ \s -> s { csWatchChatrooms = Just watched } + Just _ -> return () + +cmdChatrooms :: Command +cmdChatrooms = do + ensureWatchedChatrooms + chatroomSetVar <- asks ciChatroomSetVar + chatroomList <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) + set <- asks ciSetContextOptions + set $ map SelectedChatroom chatroomList + forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do + cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate) + +cmdChatroomCreatePublic :: Command +cmdChatroomCreatePublic = do + term <- asks ciTerminal + name <- asks ciLine >>= \case + line | not (null line) -> return $ T.pack line + _ -> liftIO $ do + setPrompt term "Name: " + getInputLine term $ KeepPrompt . maybe T.empty T.pack + + ensureWatchedChatrooms + void $ createChatroom + (if T.null name then Nothing else Just name) + Nothing + + cmdContacts :: Command cmdContacts = do args <- words <$> asks ciLine @@ -538,8 +793,8 @@ cmdContacts = do verbose = "-v" `elem` args set <- asks ciSetContextOptions set $ map SelectedContact contacts - forM_ (zip [1..] contacts) $ \(i :: Int, c) -> liftIO $ do - T.putStrLn $ T.concat + forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do + cmdPutStrLn $ T.unpack $ T.concat [ "[", T.pack (show i), "] ", contactName c , case contactIdentity c of Just idt | cname <- displayIdentity idt @@ -565,33 +820,36 @@ cmdConversations = do set <- asks ciSetContextOptions set $ map SelectedConversation conversations forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) + cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) cmdDetails :: Command cmdDetails = do gets csContext >>= \case SelectedPeer peer -> do - liftIO $ putStr $ unlines + cmdPutStrLn $ unlines [ "Network peer:" , " " <> show (peerAddress peer) ] peerIdentity peer >>= \case - PeerIdentityUnknown _ -> liftIO $ do - putStrLn $ "unknown identity" - PeerIdentityRef wref _ -> liftIO $ do - putStrLn $ "Identity ref:" - putStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref) + PeerIdentityUnknown _ -> do + cmdPutStrLn $ "unknown identity" + PeerIdentityRef wref _ -> do + cmdPutStrLn $ "Identity ref:" + cmdPutStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref) PeerIdentityFull pid -> printContactOrIdentityDetails pid SelectedContact contact -> do printContactDetails contact + SelectedChatroom rstate -> do + cmdPutStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate) + SelectedConversation conv -> do case conversationPeer conv of Just pid -> printContactOrIdentityDetails pid - Nothing -> liftIO $ putStrLn $ "(conversation without peer)" + Nothing -> cmdPutStrLn $ "(conversation without peer)" - NoContext -> liftIO $ putStrLn "nothing selected" + NoContext -> cmdPutStrLn "nothing selected" where printContactOrIdentityDetails cid = do contacts <- fromSetBy (comparing contactName) . lookupSharedValue . lsShared . fromStored <$> getLocalHead @@ -599,11 +857,11 @@ cmdDetails = do Just contact -> printContactDetails contact Nothing -> printIdentityDetails cid - printContactDetails contact = liftIO $ do - putStrLn $ "Contact:" + printContactDetails contact = do + cmdPutStrLn $ "Contact:" prefix <- case contactCustomName contact of Just name -> do - putStrLn $ " " <> T.unpack name + cmdPutStrLn $ " " <> T.unpack name return $ Just "alias of" Nothing -> do return $ Nothing @@ -612,23 +870,21 @@ cmdDetails = do Just cid -> do printIdentityDetailsBody prefix cid Nothing -> do - putStrLn $ " (without erebos identity)" + cmdPutStrLn $ " (without erebos identity)" - printIdentityDetails identity = liftIO $ do - putStrLn $ "Identity:" + printIdentityDetails identity = do + cmdPutStrLn $ "Identity:" printIdentityDetailsBody Nothing identity printIdentityDetailsBody prefix identity = do forM_ (zip (False : repeat True) $ unfoldOwners identity) $ \(owned, cpid) -> do - putStrLn $ unwords $ concat + cmdPutStrLn $ unwords $ concat [ [ " " ] , if owned then [ "owned by" ] else maybeToList prefix , [ maybe "<unnamed>" T.unpack (idName cpid) ] , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid ] -#ifdef ENABLE_ICE_SUPPORT - cmdDiscoveryInit :: Command cmdDiscoveryInit = void $ do server <- asks ciServer @@ -639,7 +895,7 @@ cmdDiscoveryInit = void $ do [] -> ("discovery.erebosprotocol.net", show discoveryPort) addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) peer <- liftIO $ serverPeer server (addrAddress addr) - sendToPeer peer $ DiscoverySelf (T.pack "ICE") 0 + sendToPeer peer $ DiscoverySelf [ T.pack "ICE" ] Nothing modify $ \s -> s { csIcePeer = Just peer } cmdDiscovery :: Command @@ -656,14 +912,39 @@ cmdDiscovery = void $ do Right _ -> return () Left err -> eprint err +#ifdef ENABLE_ICE_SUPPORT + cmdIceCreate :: Command cmdIceCreate = do - role <- asks ciLine >>= return . \case - 'm':_ -> PjIceSessRoleControlling - 's':_ -> PjIceSessRoleControlled - _ -> PjIceSessRoleUnknown + let getRole = \case + 'm':_ -> PjIceSessRoleControlling + 's':_ -> PjIceSessRoleControlled + _ -> PjIceSessRoleUnknown + + ( role, stun, turn ) <- asks (words . ciLine) >>= \case + [] -> return ( PjIceSessRoleControlling, Nothing, Nothing ) + [ role ] -> return + ( getRole role, Nothing, Nothing ) + [ role, server ] -> return + ( getRole role + , Just ( T.pack server, 0 ) + , Just ( T.pack server, 0 ) + ) + [ role, server, port ] -> return + ( getRole role + , Just ( T.pack server, read port ) + , Just ( T.pack server, read port ) + ) + [ role, stunServer, stunPort, turnServer, turnPort ] -> return + ( getRole role + , Just ( T.pack stunServer, read stunPort ) + , Just ( T.pack turnServer, read turnPort ) + ) + _ -> throwOtherError "invalid parameters" + eprint <- asks ciPrint - sess <- liftIO $ iceCreate role $ eprint <=< iceShow + Just cfg <- liftIO $ iceCreateConfig stun turn + sess <- liftIO $ iceCreateSession cfg role $ eprint <=< iceShow modify $ \s -> s { csIceSessions = sess : csIceSessions s } cmdIceDestroy :: Command @@ -684,11 +965,15 @@ cmdIceConnect :: Command cmdIceConnect = do s:_ <- gets csIceSessions server <- asks ciServer - let loadInfo = BC.getLine >>= \case line | BC.null line -> return [] - | otherwise -> (line:) <$> loadInfo + term <- asks ciTerminal + let loadInfo = + getInputLine term (KeepPrompt . maybe BC.empty BC.pack) >>= \case + line | BC.null line -> return [] + | otherwise -> (line :) <$> loadInfo Right remote <- liftIO $ do st <- memoryStorage pst <- derivePartialStorage st + setPrompt term "" rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes) liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s @@ -703,3 +988,10 @@ cmdIceSend = void $ do cmdQuit :: Command cmdQuit = modify $ \s -> s { csQuit = True } + + +intersectsSorted :: Ord a => [a] -> [a] -> Bool +intersectsSorted (x:xs) (y:ys) | x < y = intersectsSorted xs (y:ys) + | x > y = intersectsSorted (x:xs) ys + | otherwise = True +intersectsSorted _ _ = False diff --git a/main/State.hs b/main/State.hs new file mode 100644 index 0000000..76441df --- /dev/null +++ b/main/State.hs @@ -0,0 +1,80 @@ +module State ( + loadLocalStateHead, + updateSharedIdentity, + interactiveIdentityUpdate, +) where + +import Control.Monad.Except +import Control.Monad.IO.Class + +import Data.Foldable +import Data.Maybe +import Data.Proxy +import Data.Text qualified as T + +import Erebos.Error +import Erebos.Identity +import Erebos.PubKey +import Erebos.State +import Erebos.Storable +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 + + setPrompt term "Device: " + devName <- getInputLine term $ KeepPrompt . maybe T.empty T.pack + + owner <- if + | T.null name -> return Nothing + | otherwise -> Just <$> createIdentity st (Just name) Nothing + + identity <- createIdentity st (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 ] + } + storeHead st $ LocalState + { lsIdentity = idExtData identity + , lsShared = [ shared ] + , lsOther = [] + } + + +updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m () +updateSharedIdentity term = updateLocalHead_ $ updateSharedState_ $ \case + Just identity -> do + Just . toComposedIdentity <$> interactiveIdentityUpdate term identity + Nothing -> throwOtherError "no existing shared identity" + +interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => Terminal -> Identity f -> m UnifiedIdentity +interactiveIdentityUpdate term identity = do + let public = idKeyIdentity identity + + name <- liftIO $ do + setPrompt term $ T.unpack $ T.concat $ concat + [ [ T.pack "Name" ] + , case idName identity of + Just name -> [T.pack " [", name, T.pack "]"] + Nothing -> [] + , [ T.pack ": " ] + ] + getInputLine term $ KeepPrompt . maybe T.empty T.pack + + if | T.null name -> mergeIdentity identity + | otherwise -> do + secret <- loadKey public + maybe (throwOtherError "created invalid identity") return . validateIdentity =<< + mstore =<< sign secret =<< mstore (emptyIdentityData public) + { iddPrev = toList $ idDataF identity + , iddName = Just name + } diff --git a/main/Terminal.hs b/main/Terminal.hs new file mode 100644 index 0000000..5dc3612 --- /dev/null +++ b/main/Terminal.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE CPP #-} + +module Terminal ( + Terminal, + hasTerminalUI, + withTerminal, + setPrompt, + getInputLine, + InputHandling(..), + + TerminalLine, + printLine, + + printBottomLines, + clearBottomLines, + + CompletionFunc, Completion, + noCompletion, + simpleCompletion, + completeWordWithPrev, +) where + +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad + +import Data.Char +import Data.List +import Data.Text (Text) +import Data.Text qualified as T + +import System.IO +import System.Console.ANSI + + +data Terminal = Terminal + { termLock :: MVar () + , termAnsi :: Bool + , termCompletionFunc :: CompletionFunc IO + , termPrompt :: TVar String + , termShowPrompt :: TVar Bool + , termInput :: TVar ( String, String ) + , termBottomLines :: TVar [ String ] + } + +data TerminalLine = TerminalLine + { tlTerminal :: Terminal + } + +data Input + = InputChar Char + | InputMoveRight + | InputMoveLeft + | InputMoveEnd + | InputMoveStart + | InputBackspace + | InputClear + | InputBackWord + | InputEnd + | InputEscape String + deriving (Eq, Ord, Show) + + +data InputHandling a + = KeepPrompt a + | ErasePrompt a + + +hasTerminalUI :: Terminal -> Bool +hasTerminalUI = termAnsi + +initTerminal :: CompletionFunc IO -> IO Terminal +initTerminal termCompletionFunc = do + termLock <- newMVar () +#if MIN_VERSION_ansi_terminal(1, 0, 1) + termAnsi <- hNowSupportsANSI stdout +#else + termAnsi <- hSupportsANSI stdout +#endif + termPrompt <- newTVarIO "" + termShowPrompt <- newTVarIO False + termInput <- newTVarIO ( "", "" ) + termBottomLines <- newTVarIO [] + return Terminal {..} + +bracketSet :: IO a -> (a -> IO b) -> a -> IO c -> IO c +bracketSet get set val = bracket (get <* set val) set . const + +withTerminal :: CompletionFunc IO -> (Terminal -> IO a) -> IO a +withTerminal compl act = do + term <- initTerminal compl + + bracketSet (hGetEcho stdin) (hSetEcho stdin) False $ + bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering $ + bracketSet (hGetBuffering stdout) (hSetBuffering stdout) (BlockBuffering Nothing) $ + act term + + +termPutStr :: Terminal -> String -> IO () +termPutStr Terminal {..} str = do + withMVar termLock $ \_ -> do + putStr str + hFlush stdout + + +getInput :: IO Input +getInput = do + getChar >>= \case + '\ESC' -> do + esc <- readEsc + case parseEsc esc of + Just ( 'C' , [] ) -> return InputMoveRight + Just ( 'D' , [] ) -> return InputMoveLeft + _ -> return (InputEscape esc) + '\b' -> return InputBackspace + '\DEL' -> return InputBackspace + '\NAK' -> return InputClear + '\ETB' -> return InputBackWord + '\SOH' -> return InputMoveStart + '\ENQ' -> return InputMoveEnd + '\EOT' -> return InputEnd + c -> return (InputChar c) + where + readEsc = getChar >>= \case + c | c == '\ESC' || isAlpha c -> return [ c ] + | otherwise -> (c :) <$> readEsc + + parseEsc = \case + '[' : c : [] -> do + Just ( c, [] ) + _ -> Nothing + + +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 + KeepPrompt x -> do + termPutStr term "\n\ESC[J" + return x + ErasePrompt x -> do + termPutStr term "\r\ESC[J" + return x + where + go = getInput >>= \case + InputChar '\n' -> do + atomically $ do + ( pre, post ) <- readTVar termInput + writeTVar termInput ( "", "" ) + writeTVar termShowPrompt False + writeTVar termBottomLines [] + return $ Just $ pre ++ post + + InputChar '\t' -> do + options <- withMVar termLock $ const $ do + ( pre, post ) <- atomically $ readTVar termInput + let updatePrompt pre' = do + prompt <- atomically $ do + writeTVar termInput ( pre', post ) + getCurrentPromptLine term + putStr $ "\r" <> prompt + hFlush stdout + + termCompletionFunc ( T.pack pre, T.pack post ) >>= \case + + ( unused, [ compl ] ) -> do + updatePrompt $ T.unpack unused ++ T.unpack (replacement compl) ++ if isFinished compl then " " else "" + return [] + + ( 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 + + ( _, [] ) -> do + return [] + + printBottomLines term $ T.unpack $ T.unlines options + go + + InputChar c | isPrint c -> withInput $ \case + ( _, post ) -> do + writeTVar termInput . first (++ [ c ]) =<< readTVar termInput + return $ c : (if null post then "" else "\ESC[s" <> post <> "\ESC[u") + + InputChar _ -> go + + InputMoveRight -> withInput $ \case + ( pre, c : post ) -> do + writeTVar termInput ( pre ++ [ c ], post ) + return $ "\ESC[C" + _ -> return "" + + InputMoveLeft -> withInput $ \case + ( pre@(_ : _), post ) -> do + writeTVar termInput ( init pre, last pre : post ) + return $ "\ESC[D" + _ -> return "" + + InputBackspace -> withInput $ \case + ( pre@(_ : _), post ) -> do + writeTVar termInput ( init pre, post ) + return $ "\b\ESC[K" <> (if null post then "" else "\ESC[s" <> post <> "\ESC[u") + _ -> return "" + + InputClear -> withInput $ \_ -> do + writeTVar termInput ( "", "" ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + + InputBackWord -> withInput $ \( pre, post ) -> do + let pre' = reverse $ dropWhile (not . isSpace) $ dropWhile isSpace $ reverse pre + writeTVar termInput ( pre', post ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + + InputMoveStart -> withInput $ \( pre, post ) -> do + writeTVar termInput ( "", pre <> post ) + return $ "\ESC[" <> show (length pre) <> "D" + + InputMoveEnd -> withInput $ \( pre, post ) -> do + writeTVar termInput ( pre <> post, "" ) + return $ "\ESC[" <> show (length post) <> "C" + + InputEnd -> do + atomically (readTVar termInput) >>= \case + ( "", "" ) -> return Nothing + _ -> go + + InputEscape _ -> go + + withInput f = do + withMVar termLock $ const $ do + str <- atomically $ f =<< readTVar termInput + when (not $ null str) $ do + putStr str + hFlush stdout + go + + +getCurrentPromptLine :: Terminal -> STM String +getCurrentPromptLine Terminal {..} = do + prompt <- readTVar termPrompt + ( pre, post ) <- readTVar termInput + return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u" + +setPrompt :: Terminal -> String -> IO () +setPrompt term@Terminal {..} prompt = do + withMVar termLock $ \_ -> do + join $ atomically $ do + writeTVar termPrompt prompt + readTVar termShowPrompt >>= \case + True -> do + promptLine <- getCurrentPromptLine term + return $ do + putStr $ "\r\ESC[K" <> promptLine + hFlush stdout + False -> return $ return () + +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 + hFlush stdout + return TerminalLine {..} + + +printBottomLines :: Terminal -> String -> IO () +printBottomLines term@Terminal {..} str = do + case lines str of + [] -> clearBottomLines term + blines -> do + withMVar termLock $ \_ -> do + atomically $ writeTVar termBottomLines blines + drawBottomLines term + hFlush stdout + +clearBottomLines :: Terminal -> IO () +clearBottomLines Terminal {..} = do + withMVar termLock $ \_ -> do + atomically (readTVar termBottomLines) >>= \case + [] -> return () + _:_ -> do + atomically $ writeTVar termBottomLines [] + putStr $ "\ESC[s\n\ESC[J\ESC[u" + hFlush stdout + +drawBottomLines :: Terminal -> IO () +drawBottomLines Terminal {..} = do + atomically (readTVar termBottomLines) >>= \case + blines@( firstLine : otherLines ) -> do + ( shift ) <- atomically $ do + readTVar termShowPrompt >>= \case + True -> do + prompt <- readTVar termPrompt + ( pre, _ ) <- readTVar termInput + return (displayWidth (prompt <> pre) + 1) + False -> do + return 0 + putStr $ concat + [ "\n\ESC[J", firstLine, concat (map ('\n' :) otherLines) + , "\ESC[", show (length blines), "F" + , "\ESC[", show shift, "G" + ] + [] -> return () + + +displayWidth :: String -> Int +displayWidth = \case + ('\ESC' : '[' : rest) -> displayWidth $ drop 1 $ dropWhile (not . isAlpha) rest + ('\ESC' : _ : rest) -> displayWidth rest + (_ : rest) -> 1 + displayWidth rest + [] -> 0 + + +type CompletionFunc m = ( Text, Text ) -> m ( Text, [ Completion ] ) + +data Completion = Completion + { replacement :: Text + , isFinished :: Bool + } + +noCompletion :: Monad m => CompletionFunc m +noCompletion ( l, _ ) = return ( l, [] ) + +completeWordWithPrev :: Monad m => Maybe Char -> [ Char ] -> (String -> String -> m [ Completion ]) -> CompletionFunc m +completeWordWithPrev _ spaceChars fun ( l, _ ) = do + let lastSpaceIndex = snd $ T.foldl' (\( i, found ) c -> if c `elem` spaceChars then ( i + 1, i ) else ( i + 1, found )) ( 1, 0 ) l + let ( pre, word ) = T.splitAt lastSpaceIndex l + ( pre, ) <$> fun (T.unpack pre) (T.unpack word) + +simpleCompletion :: String -> Completion +simpleCompletion str = Completion (T.pack str) True diff --git a/main/Test.hs b/main/Test.hs index 711f9fa..08ad880 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Test ( runTestTool, ) where @@ -16,6 +18,7 @@ import Data.Bool 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.Foldable import Data.Ord import Data.Text (Text) @@ -33,16 +36,19 @@ import System.IO.Error import Erebos.Attach import Erebos.Chatroom import Erebos.Contact +import Erebos.DirectMessage +import Erebos.Discovery import Erebos.Identity -import Erebos.Message import Erebos.Network +import Erebos.Object import Erebos.Pairing import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State +import Erebos.Storable import Erebos.Storage -import Erebos.Storage.Internal (unsafeStoreRawBytes) +import Erebos.Storage.Head import Erebos.Storage.Merge import Erebos.Sync @@ -97,7 +103,7 @@ runTestTool st = do Nothing -> return () runExceptT (evalStateT testLoop initTestState) >>= \case - Left x -> hPutStrLn stderr x + Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack (showErebosError x) Right () -> return () getLineMb :: MonadIO m => m (Maybe Text) @@ -121,7 +127,7 @@ outLine :: Output -> String -> IO () outLine mvar line = do evaluate $ foldl' (flip seq) () line withMVar mvar $ \() -> do - putStrLn line + B.putStr $ (`BC.snoc` '\n') $ BC.pack line hFlush stdout cmdOut :: String -> Command @@ -169,7 +175,7 @@ pairingAttributes _ out peers prefix = PairingAttributes , pairingHookFailed = \case PairingUserRejected -> failed "user" PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet - PairingFailedOther str -> failed $ "other " ++ str + PairingFailedOther err -> failed $ "other " ++ showErebosError err , pairingHookVerifyFailed = failed "verify" , pairingHookRejected = failed "rejected" } @@ -220,11 +226,11 @@ dmReceivedWatcher out smsg = do ] -newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String) +newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError ErebosError) instance MonadFail CommandM where - fail = throwError + fail = throwOtherError instance MonadRandom CommandM where getRandomBytes = liftIO . getRandomBytes @@ -244,6 +250,7 @@ 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) @@ -253,12 +260,16 @@ commands = map (T.pack *** id) , ("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) + , ("local-state-get", cmdLocalStateGet) + , ("local-state-replace", cmdLocalStateReplace) + , ("local-state-wait", cmdLocalStateWait) , ("shared-state-get", cmdSharedStateGet) , ("shared-state-wait", cmdSharedStateWait) , ("watch-local-identity", cmdWatchLocalIdentity) @@ -278,23 +289,49 @@ commands = map (T.pack *** id) , ("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) ] cmdStore :: Command cmdStore = do st <- asks tiStorage + pst <- liftIO $ derivePartialStorage st [otype] <- asks tiParams ls <- getLines let cnt = encodeUtf8 $ T.unlines ls - ref <- liftIO $ unsafeStoreRawBytes st $ BL.fromChunks [encodeUtf8 otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] - cmdOut $ "store-done " ++ show (refDigest ref) + full = BL.fromChunks + [ encodeUtf8 otype + , BC.singleton ' ' + , BC.pack (show $ B.length cnt) + , BC.singleton '\n', cnt + ] + 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 + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + let obj = load @Object ref + header : content <- return $ BL.lines $ serializeObject obj + cmdOut $ "load-type " <> T.unpack (decodeUtf8 $ BL.toStrict header) + forM_ content $ \line -> do + cmdOut $ "load-line " <> T.unpack (decodeUtf8 $ BL.toStrict line) + cmdOut "load-done" cmdStoredGeneration :: Command cmdStoredGeneration = do @@ -419,26 +456,55 @@ cmdCreateIdentity = do storeHead st $ LocalState { lsIdentity = idExtData identity , lsShared = shared + , lsOther = [] } initTestHead h + cmdOut $ unwords [ "create-identity-done", "ref", show $ refDigest $ storedRef $ lsIdentity $ headObject h ] + +cmdIdentityInfo :: Command +cmdIdentityInfo = do + st <- asks tiStorage + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + let sidata = wrappedLoad ref + idata = fromSigned sidata + cmdOut $ unwords $ concat + [ [ "identity-info" ] + , [ "ref", T.unpack tref ] + , [ "base", show $ refDigest $ storedRef $ eiddStoredBase sidata ] + , maybe [] (\owner -> [ "owner", show $ refDigest $ storedRef owner ]) $ eiddOwner idata + , maybe [] (\name -> [ "name", T.unpack name ]) $ eiddName idata + ] cmdStartServer :: Command cmdStartServer = do out <- asks tiOutput + let parseParams = \case + (name : value : rest) + | name == "services" -> T.splitOn "," value + | otherwise -> parseParams rest + _ -> [] + serviceNames <- parseParams <$> asks tiParams + h <- getOrLoadHead rsPeers <- liftIO $ newMVar (1, []) - rsServer <- liftIO $ startServer defaultServerOptions h (hPutStrLn stderr) - [ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" - , someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" - , someServiceAttr $ directMessageAttributes out - , someService @SyncService Proxy - , someService @ChatroomService Proxy - , someServiceAttr $ (defaultServiceAttributes Proxy) - { testMessageReceived = \otype len sref -> - liftIO $ outLine out $ unwords ["test-message-received", otype, len, sref] + 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) + { testMessageReceived = \obj otype len sref -> do + liftIO $ do + void $ store (headStorage h) obj + outLine out $ unwords ["test-message-received", otype, len, sref] } - ] + sname -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" + + rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services rsPeerThread <- liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange rsServer @@ -501,20 +567,32 @@ cmdPeerList = do cmdTestMessageSend :: Command cmdTestMessageSend = do - [spidx, tref] <- asks tiParams + spidx : trefs <- asks tiParams st <- asks tiStorage - Just ref <- liftIO $ readRef st (encodeUtf8 tref) + Just refs <- liftIO $ fmap sequence $ mapM (readRef st . encodeUtf8) trefs peer <- getPeer spidx - sendToPeer peer $ TestMessage $ wrappedLoad ref + sendManyToPeer peer $ map (TestMessage . wrappedLoad) refs cmdOut "test-message-send done" -cmdSharedStateGet :: Command -cmdSharedStateGet = do +cmdLocalStateGet :: Command +cmdLocalStateGet = do h <- getHead - cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h) + cmdOut $ unwords $ "local-state-get" : map (show . refDigest . storedRef) [ headStoredObject h ] -cmdSharedStateWait :: Command -cmdSharedStateWait = do +cmdLocalStateReplace :: Command +cmdLocalStateReplace = do + st <- asks tiStorage + [ told, tnew ] <- asks tiParams + Just rold <- liftIO $ readRef st $ encodeUtf8 told + Just rnew <- liftIO $ readRef st $ encodeUtf8 tnew + ok <- updateLocalHead @LocalState $ \ls -> do + if storedRef ls == rold + then return ( wrappedLoad rnew, True ) + else return ( ls, False ) + cmdOut $ if ok then "local-state-replace-done" else "local-state-replace-failed" + +localStateWaitHelper :: Storable a => String -> (Head LocalState -> [ Stored a ]) -> Command +localStateWaitHelper label sel = do st <- asks tiStorage out <- asks tiOutput h <- getOrLoadHead @@ -522,15 +600,26 @@ cmdSharedStateWait = do liftIO $ do mvar <- newEmptyMVar - w <- watchHeadWith h (lsShared . headObject) $ \cur -> do + w <- watchHeadWith h sel $ \cur -> do mbobjs <- mapM (readRef st . encodeUtf8) trefs case map wrappedLoad <$> sequence mbobjs of Just objs | filterAncestors (cur ++ objs) == cur -> do - outLine out $ unwords $ "shared-state-wait" : map T.unpack trefs + outLine out $ unwords $ label : map T.unpack trefs void $ forkIO $ unwatchHead =<< takeMVar mvar _ -> return () putMVar mvar w +cmdLocalStateWait :: Command +cmdLocalStateWait = localStateWaitHelper "local-state-wait" ((: []) . headStoredObject) + +cmdSharedStateGet :: Command +cmdSharedStateGet = do + h <- getHead + cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h) + +cmdSharedStateWait :: Command +cmdSharedStateWait = localStateWaitHelper "shared-state-wait" (lsShared . headObject) + cmdWatchLocalIdentity :: Command cmdWatchLocalIdentity = do h <- getOrLoadHead @@ -573,7 +662,7 @@ cmdUpdateSharedIdentity :: Command cmdUpdateSharedIdentity = do [name] <- asks tiParams updateLocalHead_ $ updateSharedState_ $ \case - Nothing -> throwError "no existing shared identity" + Nothing -> throwOtherError "no existing shared identity" Just identity -> do let public = idKeyIdentity identity secret <- loadKey public @@ -686,6 +775,13 @@ cmdChatroomCreate = do room <- createChatroom (Just name) Nothing cmdOut $ unwords $ "chatroom-create-done" : chatroomInfo room +cmdChatroomDelete :: Command +cmdChatroomDelete = do + [ cid ] <- asks tiParams + sdata <- getChatroomStateData cid + deleteChatroomByStateData sdata + cmdOut $ unwords [ "chatroom-delete-done", T.unpack cid ] + getChatroomStateData :: Text -> CommandM (Stored ChatroomStateData) getChatroomStateData tref = do st <- asks tiStorage @@ -711,7 +807,7 @@ cmdChatroomListLocal = do cmdChatroomWatchLocal :: Command cmdChatroomWatchLocal = do [] <- asks tiParams - h <- getHead + h <- getOrLoadHead out <- asks tiOutput void $ watchChatrooms h $ \_ -> \case Nothing -> return () @@ -732,6 +828,7 @@ cmdChatroomWatchLocal = do , [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room ] , [ "room", maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg ] , [ "from", maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg ] + , if cmsgLeave msg then [ "leave" ] else [] , maybe [] (("text":) . (:[]) . T.unpack) $ cmsgText msg ] @@ -754,8 +851,47 @@ cmdChatroomUnsubscribe = do to <- getChatroomStateData cid void $ chatroomSetSubscribe to False +cmdChatroomMembers :: Command +cmdChatroomMembers = do + [ cid ] <- asks tiParams + Just chatroom <- findChatroomByStateData =<< getChatroomStateData cid + forM_ (chatroomMembers chatroom) $ \user -> do + cmdOut $ unwords [ "chatroom-members-item", maybe "<unnamed>" T.unpack $ idName user ] + cmdOut "chatroom-members-done" + +cmdChatroomJoin :: Command +cmdChatroomJoin = do + [ cid ] <- asks tiParams + joinChatroomByStateData =<< getChatroomStateData cid + cmdOut "chatroom-join-done" + +cmdChatroomJoinAs :: Command +cmdChatroomJoinAs = do + [ cid, name ] <- asks tiParams + st <- asks tiStorage + identity <- liftIO $ createIdentity st (Just name) Nothing + joinChatroomAsByStateData identity =<< getChatroomStateData cid + cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ] + +cmdChatroomLeave :: Command +cmdChatroomLeave = do + [ cid ] <- asks tiParams + leaveChatroomByStateData =<< getChatroomStateData cid + cmdOut "chatroom-leave-done" + cmdChatroomMessageSend :: Command cmdChatroomMessageSend = do [cid, msg] <- asks tiParams to <- getChatroomStateData cid - void $ chatroomMessageByStateData to msg + void $ sendChatroomMessageByStateData to msg + +cmdDiscoveryConnect :: Command +cmdDiscoveryConnect = do + st <- asks tiStorage + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + + Just RunningServer {..} <- gets tsServer + peers <- liftIO $ getCurrentPeerList rsServer + forM_ peers $ \peer -> do + sendToPeer peer $ DiscoverySearch ref diff --git a/main/Test/Service.hs b/main/Test/Service.hs index 1018e0d..8c58dee 100644 --- a/main/Test/Service.hs +++ b/main/Test/Service.hs @@ -8,13 +8,14 @@ import Control.Monad.Reader import Data.ByteString.Lazy.Char8 qualified as BL import Erebos.Network +import Erebos.Object import Erebos.Service -import Erebos.Storage +import Erebos.Storable data TestMessage = TestMessage (Stored Object) data TestMessageAttributes = TestMessageAttributes - { testMessageReceived :: String -> String -> String -> ServiceHandler TestMessage () + { testMessageReceived :: Object -> String -> String -> String -> ServiceHandler TestMessage () } instance Storable TestMessage where @@ -25,12 +26,13 @@ instance Service TestMessage where serviceID _ = mkServiceID "cb46b92c-9203-4694-8370-8742d8ac9dc8" type ServiceAttributes TestMessage = TestMessageAttributes - defaultServiceAttributes _ = TestMessageAttributes (\_ _ _ -> return ()) + defaultServiceAttributes _ = TestMessageAttributes (\_ _ _ _ -> return ()) serviceHandler smsg = do let TestMessage sobj = fromStored smsg - case map BL.unpack $ BL.words $ BL.takeWhile (/='\n') $ serializeObject $ fromStored sobj of + obj = fromStored sobj + case map BL.unpack $ BL.words $ BL.takeWhile (/='\n') $ serializeObject obj of [otype, len] -> do cb <- asks $ testMessageReceived . svcAttributes - cb otype len (show $ refDigest $ storedRef sobj) + cb obj otype len (show $ refDigest $ storedRef sobj) _ -> return () |