diff options
Diffstat (limited to 'main/Main.hs')
| -rw-r--r-- | main/Main.hs | 188 |
1 files changed, 106 insertions, 82 deletions
diff --git a/main/Main.hs b/main/Main.hs index 8a4729f..3f78db1 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -31,7 +31,7 @@ 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 @@ -40,21 +40,25 @@ import Erebos.Attach import Erebos.Contact 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.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 @@ -173,6 +177,14 @@ 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 (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case @@ -184,7 +196,7 @@ main = do exitFailure st <- liftIO $ case optStorage opts of - DefaultStorage -> openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR" + DefaultStorage -> openStorage =<< getDefaultStorageDir FilesystemStorage path -> openStorage path MemoryStorage -> memoryStorage @@ -224,17 +236,20 @@ 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 @@ -264,22 +279,16 @@ main = do exitFailure -inputSettings :: Settings IO -inputSettings = setComplete commandCompletion $ defaultSettings - interactiveLoop :: Storage -> Options -> IO () -interactiveLoop st opts = runInputT inputSettings $ do - erebosHead <- liftIO $ loadLocalStateHead st - outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead - - tui <- haveTerminalUI - extPrint <- getExternalPrint - let extPrintLn str = do - let str' = case reverse str of ('\n':_) -> str - _ -> str ++ "\n"; - extPrint $! str' -- evaluate str before calling extPrint to avoid blinking - - let getInputLinesTui eprompt = do +interactiveLoop st opts = withTerminal commandCompletion $ \term -> do + erebosHead <- liftIO $ loadLocalStateHead term st + void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead + + let tui = hasTerminalUI term + let extPrintLn = void . printLine term + + let getInputLinesTui :: Either CommandState String -> MaybeT IO String + getInputLinesTui eprompt = do prompt <- case eprompt of Left cstate -> do pname <- case csContext cstate of @@ -293,11 +302,14 @@ interactiveLoop st opts = runInputT inputSettings $ do 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 @@ -310,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 @@ -371,15 +383,16 @@ 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 @@ -396,7 +409,7 @@ interactiveLoop st opts = runInputT inputSettings $ do | 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 @@ -415,6 +428,7 @@ interactiveLoop st opts = runInputT inputSettings $ do data CommandInput = CommandInput { ciServer :: Server + , ciTerminal :: Terminal , ciLine :: String , ciPrint :: String -> IO () , ciOptions :: Options @@ -442,15 +456,15 @@ data CommandContext = NoContext | 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 @@ -471,27 +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 - _ -> throwError "no chatroom selected" + _ -> 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 -> throwError "invalid chatroom" + 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 = @@ -539,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 @@ -548,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 @@ -556,7 +575,7 @@ 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) @@ -607,7 +626,7 @@ cmdMembers :: Command cmdMembers = do Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom forM_ (chatroomMembers room) $ \x -> do - liftIO $ putStrLn $ maybe "<unnamed>" T.unpack $ idName x + cmdPutStrLn $ maybe "<unnamed>" T.unpack $ idName x cmdSelectContext :: Command @@ -621,7 +640,7 @@ cmdSelectContext = do when (not (roomStateSubscribe rstate)) $ do chatroomSetSubscribe (head $ roomStateData rstate) True _ -> return () - | otherwise -> throwError "invalid index" + | otherwise -> throwOtherError "invalid index" cmdSend :: Command cmdSend = void $ do @@ -630,7 +649,7 @@ cmdSend = void $ do sendMessage conv (T.pack text) >>= \case Just msg -> do tzone <- liftIO $ getCurrentTimeZone - liftIO $ putStrLn $ formatMessage tzone msg + cmdPutStrLn $ formatMessage tzone msg Nothing -> return () cmdDelete :: Command @@ -644,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 @@ -697,7 +717,7 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case Right () -> return () - Left err -> eprint err + Left err -> eprint (showErebosError err) Just diff -> do modifyMVar_ chatroomSetVar $ return . const set @@ -748,16 +768,16 @@ cmdChatrooms = do set <- asks ciSetContextOptions set $ map SelectedChatroom chatroomList forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate) + 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 - T.putStr $ T.pack "Name: " - hFlush stdout - T.getLine + setPrompt term "Name: " + getInputLine term $ KeepPrompt . maybe T.empty T.pack ensureWatchedChatrooms void $ createChatroom @@ -773,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 @@ -800,36 +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 - liftIO $ putStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate) + 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 @@ -837,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 @@ -850,15 +870,15 @@ 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) ] @@ -920,7 +940,7 @@ cmdIceCreate = do , Just ( T.pack stunServer, read stunPort ) , Just ( T.pack turnServer, read turnPort ) ) - _ -> throwError "invalid parameters" + _ -> throwOtherError "invalid parameters" eprint <- asks ciPrint Just cfg <- liftIO $ iceCreateConfig stun turn @@ -945,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 |