diff options
Diffstat (limited to 'main')
| -rw-r--r-- | main/Main.hs | 41 | ||||
| -rw-r--r-- | main/Terminal.hs | 295 | ||||
| -rw-r--r-- | main/Test.hs | 18 | ||||
| -rw-r--r-- | main/Test/Service.hs | 3 |
4 files changed, 333 insertions, 24 deletions
diff --git a/main/Main.hs b/main/Main.hs index db141cf..6e96c14 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -31,7 +31,6 @@ import Data.Typeable import Network.Socket import System.Console.GetOpt -import System.Console.Haskeline import System.Environment import System.Exit import System.IO @@ -40,21 +39,24 @@ 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 Terminal import Test import Version @@ -241,22 +243,20 @@ main = do exitFailure -inputSettings :: Settings IO -inputSettings = setComplete commandCompletion $ defaultSettings - interactiveLoop :: Storage -> Options -> IO () -interactiveLoop st opts = runInputT inputSettings $ do +interactiveLoop st opts = withTerminal commandCompletion $ \term -> do erebosHead <- liftIO $ loadLocalStateHead st - outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead + void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead - tui <- haveTerminalUI - extPrint <- getExternalPrint + let tui = hasTerminalUI term + let extPrint = void . printLine term 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 + let getInputLinesTui :: Either CommandState String -> MaybeT IO String + getInputLinesTui eprompt = do prompt <- case eprompt of Left cstate -> do pname <- case csContext cstate of @@ -270,11 +270,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 @@ -287,7 +290,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 @@ -348,12 +351,12 @@ 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 @@ -373,7 +376,7 @@ interactiveLoop st opts = runInputT inputSettings $ do | csQuit cstate' -> mzero | otherwise -> return cstate' Left err -> do - lift $ lift $ extPrintLn $ "Error: " ++ err + lift $ extPrintLn $ "Error: " ++ err return cstate let loop (Just cstate) = runMaybeT (process cstate) >>= loop diff --git a/main/Terminal.hs b/main/Terminal.hs new file mode 100644 index 0000000..21bbf4b --- /dev/null +++ b/main/Terminal.hs @@ -0,0 +1,295 @@ +module Terminal ( + Terminal, + hasTerminalUI, + withTerminal, + setPrompt, + getInputLine, + InputHandling(..), + + TerminalLine, + printLine, + + printBottomLines, + clearBottomLines, + + CompletionFunc, Completion, + simpleCompletion, + completeWordWithPrev, +) where + +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad + +import Data.Char + +import System.IO +import System.Console.ANSI + + +data Terminal = Terminal + { termLock :: MVar () + , termAnsi :: Bool + , 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 :: IO Terminal +initTerminal = do + termLock <- newMVar () + termAnsi <- hNowSupportsANSI stdout + 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 _ act = do + term <- initTerminal + + 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 + hFlush stdout + (handleResult <$> go) >>= \case + KeepPrompt x -> do + termPutStr term "\n" + return x + ErasePrompt x -> do + termPutStr term "\r\ESC[K" + return x + where + go = getInput >>= \case + InputChar '\n' -> do + atomically $ do + ( pre, post ) <- readTVar termInput + writeTVar termInput ( "", "" ) + writeTVar termShowPrompt False + return $ Just $ pre ++ post + + 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 = ( String, String ) -> m ( String, [ Completion ] ) + +data Completion + +completeWordWithPrev :: Maybe Char -> [ Char ] -> (String -> String -> m [ Completion ]) -> CompletionFunc m +completeWordWithPrev = error "TODO" + +simpleCompletion :: String -> Completion +simpleCompletion = error "TODO" diff --git a/main/Test.hs b/main/Test.hs index 183ed51..550e47f 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -36,17 +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 @@ -303,12 +305,20 @@ commands = map (T.pack *** id) 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 diff --git a/main/Test/Service.hs b/main/Test/Service.hs index 3e6eb83..8c58dee 100644 --- a/main/Test/Service.hs +++ b/main/Test/Service.hs @@ -8,8 +8,9 @@ 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) |