summaryrefslogtreecommitdiff
path: root/main
diff options
context:
space:
mode:
Diffstat (limited to 'main')
-rw-r--r--main/Main.hs700
-rw-r--r--main/State.hs115
-rw-r--r--main/Terminal.hs421
-rw-r--r--main/Test.hs390
-rw-r--r--main/Test/Service.hs24
-rw-r--r--main/WebSocket.hs48
6 files changed, 1278 insertions, 420 deletions
diff --git a/main/Main.hs b/main/Main.hs
index db141cf..5bda7e7 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -1,9 +1,7 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
-import Control.Arrow (first)
import Control.Concurrent
import Control.Exception
import Control.Monad
@@ -11,11 +9,13 @@ import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Maybe
+import Control.Monad.Writer
import Crypto.Random
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.ByteString.Lazy as BL
+import Data.Bifunctor
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
import Data.Char
import Data.List
import Data.Maybe
@@ -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,30 +40,34 @@ 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
+import WebSocket
data Options = Options
{ optServer :: ServerOptions
, optServices :: [ServiceOption]
, optStorage :: StorageOption
+ , optCreateIdentity :: Maybe ( Maybe Text, [ Maybe Text ] )
, optChatroomAutoSubscribe :: Maybe Int
, optDmBotEcho :: Maybe Text
+ , optWebSocketServer :: Maybe Int
, optShowHelp :: Bool
, optShowVersion :: Bool
}
@@ -84,8 +88,10 @@ defaultOptions = Options
{ optServer = defaultServerOptions
, optServices = availableServices
, optStorage = DefaultStorage
+ , optCreateIdentity = Nothing
, optChatroomAutoSubscribe = Nothing
, optDmBotEcho = Nothing
+ , optWebSocketServer = Nothing
, optShowHelp = False
, optShowVersion = False
}
@@ -106,7 +112,7 @@ availableServices =
True "peer discovery"
]
-options :: [OptDescr (Options -> Options)]
+options :: [ OptDescr (Options -> Writer [ String ] Options) ]
options =
[ Option ['p'] ["port"]
(ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "<port>")
@@ -115,34 +121,92 @@ options =
(NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))
"do not send announce packets for local discovery"
, Option [] [ "storage" ]
- (ReqArg (\path -> \opts -> opts { optStorage = FilesystemStorage path }) "<path>")
+ (ReqArg (\path -> \opts -> return opts { optStorage = FilesystemStorage path }) "<path>")
"use storage in <path>"
, Option [] [ "memory-storage" ]
- (NoArg (\opts -> opts { optStorage = MemoryStorage }))
+ (NoArg (\opts -> return opts { optStorage = MemoryStorage }))
"use memory storage"
+ , Option [] [ "create-identity" ]
+ (OptArg (\value -> \opts -> return opts
+ { optCreateIdentity =
+ let devName = T.pack <$> value
+ in maybe (Just ( devName, [] )) (Just . first (const devName)) (optCreateIdentity opts)
+ }) "<name>")
+ "create a new (device) identity in a new local state"
+ , Option [] [ "create-owner" ]
+ (OptArg (\value -> \opts -> return opts
+ { optCreateIdentity =
+ let ownerName = T.pack <$> value
+ in maybe (Just ( Nothing, [ ownerName ] )) (Just . second (ownerName :)) (optCreateIdentity opts)
+ }) "<name>")
+ "create owner for a new device identity"
, Option [] ["chatroom-auto-subscribe"]
- (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")
+ (ReqArg (\count -> \opts -> return opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")
"automatically subscribe for up to <count> chatrooms"
+ , Option [] [ "discovery-stun-port" ]
+ (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryStunPort = Just (read value) }) "<port>")
+ "offer specified <port> to discovery peers for STUN protocol"
+ , Option [] [ "discovery-stun-server" ]
+ (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryStunServer = Just (read value) }) "<server>")
+ "offer <server> (domain name or IP address) to discovery peers for STUN protocol"
+ , Option [] [ "discovery-turn-port" ]
+ (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnPort = Just (read value) }) "<port>")
+ "offer specified <port> to discovery peers for TURN protocol"
+ , Option [] [ "discovery-turn-server" ]
+ (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnServer = Just (read value) }) "<server>")
+ "offer <server> (domain name or IP address) to discovery peers for TURN protocol"
+ , Option [] [ "discovery-tunnel" ]
+ (OptArg (\value -> \opts -> do
+ fun <- provideTunnelFun value
+ serviceAttr (\attrs -> return attrs { discoveryProvideTunnel = fun }) opts) "<peer-type>")
+ "offer to provide tunnel for peers of given <peer-type>, possible values: all, none, websocket"
, Option [] ["dm-bot-echo"]
- (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")
+ (ReqArg (\prefix -> \opts -> return opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")
"automatically reply to direct messages with the same text prefixed with <prefix>"
+ , Option [] [ "websocket-server" ]
+ (ReqArg (\value -> \opts -> return opts { optWebSocketServer = Just (read value) }) "<port>")
+ "start WebSocket server on given port"
, Option ['h'] ["help"]
- (NoArg $ \opts -> opts { optShowHelp = True })
+ (NoArg $ \opts -> return opts { optShowHelp = True })
"show this help and exit"
, Option ['V'] ["version"]
- (NoArg $ \opts -> opts { optShowVersion = True })
+ (NoArg $ \opts -> return opts { optShowVersion = True })
"show version and exit"
]
- where so f opts = opts { optServer = f $ optServer opts }
-
-servicesOptions :: [OptDescr (Options -> Options)]
+ where
+ so f opts = return opts { optServer = f $ optServer opts }
+
+ updateService :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> SomeService -> m SomeService
+ updateService f some@(SomeService proxy attrs)
+ | Just f' <- cast f = SomeService proxy <$> f' attrs
+ | otherwise = return some
+
+ serviceAttr :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> Options -> m Options
+ serviceAttr f opts = do
+ services' <- forM (optServices opts) $ \sopt -> do
+ service <- updateService f (soptService sopt)
+ return sopt { soptService = service }
+ return opts { optServices = services' }
+
+ provideTunnelFun :: Maybe String -> Writer [ String ] (Peer -> PeerAddress -> Bool)
+ provideTunnelFun Nothing = return $ \_ _ -> True
+ provideTunnelFun (Just "all") = return $ \_ _ -> True
+ provideTunnelFun (Just "none") = return $ \_ _ -> False
+ provideTunnelFun (Just "websocket") = return $ \_ -> \case
+ CustomPeerAddress addr | Just WebSocketAddress {} <- cast addr -> True
+ _ -> False
+ provideTunnelFun (Just name) = do
+ tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ]
+ return $ \_ _ -> False
+
+servicesOptions :: [ OptDescr (Options -> Writer [ String ] Options) ]
servicesOptions = concatMap helper $ "all" : map soptName availableServices
where
helper name =
- [ Option [] ["enable-" <> name] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = True }) ""
- , Option [] ["disable-" <> name] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = False }) ""
+ [ Option [] [ "enable-" <> name ] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = True }) ""
+ , Option [] [ "disable-" <> name ] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = False }) ""
]
- so f opts = opts { optServices = f $ optServices opts }
+ so f opts = return opts { optServices = f $ optServices opts }
change :: String -> (ServiceOption -> ServiceOption) -> [ServiceOption] -> [ServiceOption]
change name f (s : ss)
| soptName s == name || name == "all"
@@ -150,18 +214,29 @@ 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
- (o, args, []) -> do
- return (foldl (flip id) defaultOptions o, args)
- (_, _, errs) -> do
+ let printErrors errs = do
progName <- getProgName
hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information."
exitFailure
+ (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case
+ (wo, args, []) ->
+ case runWriter (foldM (flip ($)) defaultOptions wo) of
+ ( o, [] ) -> return ( o, args )
+ ( _, errs ) -> printErrors errs
+ (_, _, errs) -> printErrors errs
st <- liftIO $ case optStorage opts of
- DefaultStorage -> openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR"
+ DefaultStorage -> openStorage =<< getDefaultStorageDir
FilesystemStorage path -> openStorage path
MemoryStorage -> memoryStorage
@@ -201,17 +276,28 @@ 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
+ [ "identity" ] -> do
+ loadHeads st >>= \case
+ (h : _) -> do
+ T.putStr $ showIdentityDetails $ headLocalIdentity h
+ [] -> do
+ T.putStrLn "no local state head"
+ exitFailure
+
+ ["update-identity"] -> do
+ withTerminal noCompletion $ \term -> do
+ either (fail . showErebosError) return <=< runExceptT $ do
+ runReaderT (updateSharedIdentity term) =<< runReaderT (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
@@ -241,27 +327,24 @@ 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 <- either (fail . showErebosError) return <=< runExceptT . flip runReaderT st $ do
+ case optCreateIdentity opts of
+ Nothing -> loadLocalStateHead term
+ Just ( devName, names ) -> createLocalStateHead (names ++ [ devName ])
+ void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
+
+ let tui = hasTerminalUI term
+ 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
NoContext -> return ""
- SelectedPeer peer -> peerIdentity peer >>= return . \case
+ SelectedPeer peer -> getPeerIdentity peer >>= return . \case
PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid
PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
PeerIdentityUnknown _ -> "<unknown>"
@@ -270,69 +353,92 @@ 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
+ | tui -> KeepPrompt mzero
+ | otherwise -> KeepPrompt $ liftIO $ forever $ threadDelay 100000000
getInputCommandTui cstate = do
- input <- getInputLinesTui cstate
- let (CommandM cmd, line) = case input of
- '/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest
- in if not (null scmd) && all isDigit scmd
- then (cmdSelectContext, scmd)
- else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
- _ -> (cmdSend, input)
- return (cmd, line)
-
- getInputLinesPipe = do
- lift (getInputLine "") >>= \case
- Just input -> return input
- Nothing -> liftIO $ forever $ threadDelay 100000000
-
- getInputCommandPipe _ = do
- input <- getInputLinesPipe
- let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') input
- let (CommandM cmd, line) = (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
- return (cmd, line)
-
- let getInputCommand = if tui then getInputCommandTui . Left
- else getInputCommandPipe
+ let parseCommand cmdline =
+ case dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') cmdline of
+ ( scmd, args )
+ | not (null scmd) && all isDigit scmd
+ -> ( cmdSelectContext, scmd )
+
+ | otherwise
+ -> ( fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args )
+
+ ( CommandM cmd, line ) <- getInputLinesTui cstate >>= return . \case
+ '/' : input -> parseCommand input
+ input | not tui -> parseCommand input
+ input -> ( cmdSend, input )
+ return ( cmd, line )
+
+ let getInputCommand = getInputCommandTui . Left
+
+ contextVar <- liftIO $ newMVar NoContext
_ <- liftIO $ do
tzone <- getCurrentTimeZone
- watchReceivedMessages erebosHead $ \smsg -> do
- let msg = fromStored smsg
- extPrintLn $ formatDirectMessage tzone msg
- case optDmBotEcho opts of
- Nothing -> return ()
- Just prefix -> do
- res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg)
- case res of
- Right reply -> extPrintLn $ formatDirectMessage tzone $ fromStored reply
- Left err -> extPrintLn $ "Failed to send dm echo: " <> err
+ let self = finalOwner $ headLocalIdentity erebosHead
+ watchDirectMessageThreads erebosHead $ \prev cur -> do
+ forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do
+ withMVar contextVar $ \ctx -> do
+ mbpid <- case ctx of
+ SelectedPeer peer -> getPeerIdentity peer >>= return . \case
+ PeerIdentityFull pid -> Just $ finalOwner pid
+ _ -> Nothing
+ SelectedContact contact
+ | Just cid <- contactIdentity contact -> return (Just cid)
+ SelectedConversation conv -> return $ conversationPeer conv
+ _ -> return Nothing
+ when (not tui || maybe False (msgPeer cur `sameIdentity`) mbpid) $ do
+ extPrintLn $ formatDirectMessage tzone msg
+
+ case optDmBotEcho opts of
+ Just prefix
+ | not (msgFrom msg `sameIdentity` self)
+ -> do
+ void $ forkIO $ do
+ res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg)
+ case res of
+ Right _ -> return ()
+ Left err -> extPrintLn $ "Failed to send dm echo: " <> err
+ _ -> return ()
peers <- liftIO $ newMVar []
- contextOptions <- liftIO $ newMVar []
+ contextOptions <- liftIO $ newMVar ( Nothing, [] )
chatroomSetVar <- liftIO $ newEmptyMVar
let autoSubscribe = optChatroomAutoSubscribe opts
chatroomList = fromSetBy (comparing roomStateData) . lookupSharedValue . lsShared . headObject $ erebosHead
watched <- if isJust autoSubscribe || any roomStateSubscribe chatroomList
- then fmap Just $ liftIO $ watchChatroomsForCli extPrintLn erebosHead chatroomSetVar contextOptions autoSubscribe
- else return Nothing
+ then do
+ fmap Just $ liftIO $ watchChatroomsForCli tui extPrintLn erebosHead
+ chatroomSetVar contextVar contextOptions autoSubscribe
+ else do
+ return Nothing
server <- liftIO $ do
startServer (optServer opts) erebosHead extPrintLn $
map soptService $ filter soptEnabled $ optServices opts
+ case optWebSocketServer opts of
+ Just port -> startWebsocketServer server "::" port extPrintLn
+ Nothing -> return ()
+
void $ liftIO $ forkIO $ void $ forever $ do
peer <- getNextPeerChange server
- peerIdentity peer >>= \case
+ getPeerIdentity peer >>= \case
pid@(PeerIdentityFull _) -> do
dropped <- isPeerDropped peer
- let shown = showPeer pid $ peerAddress peer
+ shown <- showPeer pid <$> getPeerAddress peer
let update [] = ([(peer, shown)], (Nothing, "NEW"))
update ((p,s):ps)
| p == peer && dropped = (ps, (Nothing, "DEL"))
@@ -344,36 +450,47 @@ interactiveLoop st opts = runInputT inputSettings $ do
| otherwise = first (ctx:) $ ctxUpdate (n + 1) ctxs
(op, updateType) <- modifyMVar peers (return . update)
let updateType' = if dropped then "DEL" else updateType
- idx <- modifyMVar contextOptions (return . ctxUpdate (1 :: Int))
- when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown
+ modifyMVar_ contextOptions $ \case
+ ( watch, clist )
+ | watch == Just WatchPeers || not tui
+ -> do
+ let ( clist', idx ) = ctxUpdate (1 :: Int) clist
+ when (Just shown /= op) $ do
+ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown
+ return ( Just WatchPeers, clist' )
+ cur -> return cur
_ -> return ()
- let process :: CommandState -> MaybeT (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
- , ciLine = line
- , ciPrint = extPrintLn
- , ciOptions = opts
- , ciPeers = liftIO $ modifyMVar peers $ \ps -> do
- ps' <- filterM (fmap not . isPeerDropped . fst) ps
- return (ps', ps')
- , ciContextOptions = liftIO $ readMVar contextOptions
- , ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs
- , ciContextOptionsVar = contextOptions
- , ciChatroomSetVar = chatroomSetVar
- }
+ res <- liftIO $ modifyMVar contextVar $ \ctx -> do
+ res <- runExceptT $ flip execStateT cstate { csHead = h, csContext = ctx } $ runReaderT cmd CommandInput
+ { ciServer = server
+ , ciTerminal = term
+ , ciLine = line
+ , ciPrint = extPrintLn
+ , ciOptions = opts
+ , ciPeers = liftIO $ modifyMVar peers $ \ps -> do
+ ps' <- filterM (fmap not . isPeerDropped . fst) ps
+ return (ps', ps')
+ , ciContextOptions = liftIO $ snd <$> readMVar contextOptions
+ , ciSetContextOptions = \watch ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ( Just watch, ctxs )
+ , ciContextVar = contextVar
+ , ciContextOptionsVar = contextOptions
+ , ciChatroomSetVar = chatroomSetVar
+ }
+ return ( either (const ctx) csContext res, res )
case res of
Right cstate'
| csQuit cstate' -> mzero
| 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
@@ -381,10 +498,6 @@ interactiveLoop st opts = runInputT inputSettings $ do
loop $ Just $ CommandState
{ csHead = erebosHead
, csContext = NoContext
-#ifdef ENABLE_ICE_SUPPORT
- , csIceSessions = []
-#endif
- , csIcePeer = Nothing
, csWatchChatrooms = watched
, csQuit = False
}
@@ -392,42 +505,48 @@ interactiveLoop st opts = runInputT inputSettings $ do
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 ]
+ , ciContextOptions :: CommandM [ CommandContext ]
+ , ciSetContextOptions :: ContextWatchOptions -> [ CommandContext ] -> Command
+ , ciContextVar :: MVar CommandContext
+ , ciContextOptionsVar :: MVar ( Maybe ContextWatchOptions, [ CommandContext ] )
, ciChatroomSetVar :: MVar (Set ChatroomState)
}
data CommandState = CommandState
{ csHead :: Head LocalState
, csContext :: CommandContext
-#ifdef ENABLE_ICE_SUPPORT
- , csIceSessions :: [IceSession]
-#endif
- , csIcePeer :: Maybe Peer
, csWatchChatrooms :: Maybe WatchedHead
, csQuit :: Bool
}
-data CommandContext = NoContext
- | SelectedPeer Peer
- | SelectedContact Contact
- | SelectedChatroom ChatroomState
- | SelectedConversation Conversation
+data CommandContext
+ = NoContext
+ | SelectedPeer Peer
+ | SelectedContact Contact
+ | SelectedChatroom ChatroomState
+ | SelectedConversation Conversation
-newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a)
- deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String)
+data ContextWatchOptions
+ = WatchPeers
+ | WatchContacts
+ | WatchChatrooms
+ | WatchConversations
+ deriving (Eq)
+
+newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a)
+ deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError)
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
@@ -448,36 +567,48 @@ 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
+getSelectedConversation = gets csContext >>= getConversationFromContext
+
+getConversationFromContext :: CommandContext -> CommandM Conversation
+getConversationFromContext = \case
+ SelectedPeer peer -> getPeerIdentity 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"
+
+getSelectedOrManualContext :: CommandM CommandContext
+getSelectedOrManualContext = do
+ asks ciLine >>= \case
+ "" -> gets csContext
+ str | all isDigit str -> getContextByIndex id (read str)
+ _ -> throwOtherError "invalid index"
commands :: [(String, Command)]
commands =
[ ("history", cmdHistory)
+ , ("identity", cmdIdentity)
, ("peers", cmdPeers)
, ("peer-add", cmdPeerAdd)
, ("peer-add-public", cmdPeerAddPublic)
, ("peer-drop", cmdPeerDrop)
, ("send", cmdSend)
+ , ("delete", cmdDelete)
, ("update-identity", cmdUpdateIdentity)
, ("attach", cmdAttach)
, ("attach-accept", cmdAttachAccept)
@@ -490,15 +621,7 @@ commands =
, ("contact-reject", cmdContactReject)
, ("conversations", cmdConversations)
, ("details", cmdDetails)
- , ("discovery-init", cmdDiscoveryInit)
, ("discovery", cmdDiscovery)
-#ifdef ENABLE_ICE_SUPPORT
- , ("ice-create", cmdIceCreate)
- , ("ice-destroy", cmdIceDestroy)
- , ("ice-show", cmdIceShow)
- , ("ice-connect", cmdIceConnect)
- , ("ice-send", cmdIceSend)
-#endif
, ("join", cmdJoin)
, ("join-as", cmdJoinAs)
, ("leave", cmdLeave)
@@ -515,16 +638,21 @@ 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
peers <- join $ asks ciPeers
set <- asks ciSetContextOptions
- set $ map (SelectedPeer . fst) peers
+ set WatchPeers $ map (SelectedPeer . fst) peers
forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do
- liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ name
+ cmdPutStrLn $ "[" ++ show i ++ "] " ++ name
cmdPeerAdd :: Command
cmdPeerAdd = void $ do
@@ -532,13 +660,17 @@ 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)
+ contextOptsVar <- asks ciContextOptionsVar
+ liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers)
liftIO $ serverPeer server (addrAddress addr)
cmdPeerAddPublic :: Command
cmdPeerAddPublic = do
server <- asks ciServer
+ contextOptsVar <- asks ciContextOptionsVar
+ liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers)
liftIO $ mapM_ (serverPeer server . addrAddress) =<< gather 'a'
where
gather c
@@ -572,8 +704,7 @@ cmdJoin = joinChatroom =<< getSelectedChatroom
cmdJoinAs :: Command
cmdJoinAs = do
name <- asks ciLine
- st <- getStorage
- identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing
+ identity <- createIdentity (Just $ T.pack name) Nothing
joinChatroomAs identity =<< getSelectedChatroom
cmdLeave :: Command
@@ -583,45 +714,72 @@ 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
+
+getContextByIndex :: (Maybe ContextWatchOptions -> Maybe ContextWatchOptions) -> Int -> CommandM CommandContext
+getContextByIndex f n = do
+ contextOptsVar <- asks ciContextOptionsVar
+ join $ liftIO $ modifyMVar contextOptsVar $ \cur@( watch, ctxs ) -> if
+ | n > 0, (ctx : _) <- drop (n - 1) ctxs
+ -> return ( ( f watch, ctxs ), return ctx )
+ | otherwise
+ -> return ( cur, throwOtherError "invalid index" )
cmdSelectContext :: Command
cmdSelectContext = do
n <- read <$> asks ciLine
- join (asks ciContextOptions) >>= \ctxs -> if
- | n > 0, (ctx : _) <- drop (n - 1) ctxs -> do
- modify $ \s -> s { csContext = ctx }
- case ctx of
- SelectedChatroom rstate -> do
- when (not (roomStateSubscribe rstate)) $ do
- chatroomSetSubscribe (head $ roomStateData rstate) True
- _ -> return ()
- | otherwise -> throwError "invalid index"
+ ctx <- getContextByIndex (const Nothing) n
+ modify $ \s -> s { csContext = ctx }
+ case ctx of
+ SelectedChatroom rstate -> do
+ when (not (roomStateSubscribe rstate)) $ do
+ chatroomSetSubscribe (head $ roomStateData rstate) True
+ _ -> return ()
cmdSend :: Command
cmdSend = void $ do
text <- asks ciLine
conv <- getSelectedConversation
- sendMessage conv (T.pack text) >>= \case
- Just msg -> do
- tzone <- liftIO $ getCurrentTimeZone
- liftIO $ putStrLn $ formatMessage tzone msg
- Nothing -> return ()
+ sendMessage conv (T.pack text)
+
+cmdDelete :: Command
+cmdDelete = void $ do
+ deleteConversation =<< getConversationFromContext =<< getSelectedOrManualContext
+ modify $ \s -> s { csContext = NoContext }
cmdHistory :: Command
cmdHistory = void $ do
- conv <- getSelectedConversation
+ conv <- getConversationFromContext =<< getSelectedOrManualContext
case conversationHistory conv of
thread@(_:_) -> do
tzone <- liftIO $ getCurrentTimeZone
- 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>"
+
+showIdentityDetails :: Foldable f => Identity f -> Text
+showIdentityDetails identity = T.unlines $ go $ reverse $ unfoldOwners identity
+ where
+ go (i : is) = concat
+ [ maybeToList $ ("Name: " <>) <$> idName i
+ , map (("Ref: " <>) . T.pack . show . refDigest . storedRef) $ idDataF i
+ , map (("ExtRef: " <>) . T.pack . show . refDigest . storedRef) $ filter isExtension $ idExtDataF i
+ , do guard $ not (null is)
+ "" : "Device:" : map (" " <>) (go is)
+ ]
+ go [] = []
+ isExtension x = case fromSigned x of BaseIdentityData {} -> False
+ _ -> True
+
+cmdIdentity :: Command
+cmdIdentity = do
+ cmdPutStrLn . T.unpack . showIdentityDetails . localIdentity . fromStored =<< getLocalHead
cmdUpdateIdentity :: Command
cmdUpdateIdentity = void $ do
- runReaderT updateSharedIdentity =<< gets csHead
+ term <- asks ciTerminal
+ runReaderT (updateSharedIdentity term) =<< gets csHead
cmdAttach :: Command
cmdAttach = attachToOwner =<< getSelectedPeer
@@ -632,8 +790,11 @@ cmdAttachAccept = attachAccept =<< getSelectedPeer
cmdAttachReject :: Command
cmdAttachReject = attachReject =<< getSelectedPeer
-watchChatroomsForCli :: (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) -> MVar [ CommandContext ] -> Maybe Int -> IO WatchedHead
-watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do
+watchChatroomsForCli
+ :: Bool -> (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState)
+ -> MVar CommandContext -> MVar ( Maybe ContextWatchOptions, [ CommandContext ] )
+ -> Maybe Int -> IO WatchedHead
+watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe = do
subscribedNumVar <- newEmptyMVar
let ctxUpdate updateType (idx :: Int) rstate = \case
@@ -655,7 +816,7 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do
watchChatrooms h $ \set -> \case
Nothing -> do
- let chatroomList = fromSetBy (comparing roomStateData) set
+ let chatroomList = filter (not . roomStateDeleted) $ fromSetBy (comparing roomStateData) set
(subscribed, notSubscribed) = partition roomStateSubscribe chatroomList
subscribedNum = length subscribed
@@ -668,32 +829,48 @@ 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
+ modifyMVar_ contextOptsVar $ \case
+ ( watch, clist )
+ | watch == Just WatchChatrooms || not tui
+ -> do
+ let upd c = \case
+ AddedChatroom rstate -> ctxUpdate "NEW" 1 rstate c
+ RemovedChatroom rstate -> ctxUpdate "DEL" 1 rstate c
+ UpdatedChatroom _ rstate
+ | any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)
+ -> do
+ ctxUpdate "UPD" 1 rstate c
+ | otherwise -> return c
+ ( watch, ) <$> foldM upd clist diff
+ cur -> return cur
+
forM_ diff $ \case
AddedChatroom rstate -> do
- modifyMVar_ contextVar $ ctxUpdate "NEW" 1 rstate
modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then (+ 1) else id
RemovedChatroom rstate -> do
- modifyMVar_ contextVar $ ctxUpdate "DEL" 1 rstate
modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then subtract 1 else id
UpdatedChatroom oldroom rstate -> do
- when (any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)) $ do
- modifyMVar_ contextVar $ ctxUpdate "UPD" 1 rstate
when (any (not . null . rsdMessages . fromStored) (roomStateData rstate)) $ do
- tzone <- getCurrentTimeZone
- forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do
- eprint $ concat $
- [ maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg
- , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg
- , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg
- , if cmsgLeave msg then " left" else ""
- , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg
- ]
+ withMVar contextVar $ \ctx -> do
+ isSelected <- case ctx of
+ SelectedChatroom rstate' -> return $ isSameChatroom rstate' rstate
+ SelectedConversation conv -> return $ isChatroomStateConversation rstate conv
+ _ -> return False
+ when (not tui || isSelected) $ do
+ tzone <- getCurrentTimeZone
+ forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do
+ eprint $ concat $
+ [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg
+ , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg
+ , if cmsgLeave msg then " left" else ""
+ , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg
+ ]
modifyMVar_ subscribedNumVar $ return
. (if roomStateSubscribe rstate then (+ 1) else id)
. (if roomStateSubscribe oldroom then subtract 1 else id)
@@ -705,9 +882,11 @@ ensureWatchedChatrooms = do
eprint <- asks ciPrint
h <- gets csHead
chatroomSetVar <- asks ciChatroomSetVar
- contextVar <- asks ciContextOptionsVar
+ contextVar <- asks ciContextVar
+ contextOptsVar <- asks ciContextOptionsVar
autoSubscribe <- asks $ optChatroomAutoSubscribe . ciOptions
- watched <- liftIO $ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe
+ tui <- asks $ hasTerminalUI . ciTerminal
+ watched <- liftIO $ watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe
modify $ \s -> s { csWatchChatrooms = Just watched }
Just _ -> return ()
@@ -715,22 +894,24 @@ cmdChatrooms :: Command
cmdChatrooms = do
ensureWatchedChatrooms
chatroomSetVar <- asks ciChatroomSetVar
- chatroomList <- fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar)
+ chatroomList <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar)
set <- asks ciSetContextOptions
- set $ map SelectedChatroom chatroomList
+ set WatchChatrooms $ map SelectedChatroom chatroomList
forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do
- 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
+ contextOptsVar <- asks ciContextOptionsVar
+ liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchChatrooms)
void $ createChatroom
(if T.null name then Nothing else Just name)
Nothing
@@ -743,9 +924,9 @@ cmdContacts = do
let contacts = fromSetBy (comparing contactName) $ lookupSharedValue $ lsShared $ headObject ehead
verbose = "-v" `elem` args
set <- asks ciSetContextOptions
- set $ map SelectedContact contacts
- forM_ (zip [1..] contacts) $ \(i :: Int, c) -> liftIO $ do
- T.putStrLn $ T.concat
+ set WatchContacts $ map SelectedContact contacts
+ 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
@@ -769,38 +950,39 @@ cmdConversations :: Command
cmdConversations = do
conversations <- lookupConversations
set <- asks ciSetContextOptions
- set $ map SelectedConversation conversations
+ set WatchConversations $ map SelectedConversation conversations
forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do
- liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)
+ cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)
cmdDetails :: Command
cmdDetails = do
- gets csContext >>= \case
+ getSelectedOrManualContext >>= \case
SelectedPeer peer -> do
- liftIO $ putStr $ unlines
+ paddr <- getPeerAddress peer
+ cmdPutStrLn $ unlines
[ "Network peer:"
- , " " <> show (peerAddress peer)
+ , " " <> show paddr
]
- peerIdentity peer >>= \case
- PeerIdentityUnknown _ -> liftIO $ do
- putStrLn $ "unknown identity"
- PeerIdentityRef wref _ -> liftIO $ do
- putStrLn $ "Identity ref:"
- putStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref)
+ getPeerIdentity peer >>= \case
+ 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
@@ -808,11 +990,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
@@ -821,94 +1003,28 @@ 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
]
-cmdDiscoveryInit :: Command
-cmdDiscoveryInit = void $ do
- server <- asks ciServer
-
- (hostname, port) <- (words <$> asks ciLine) >>= return . \case
- hostname:p:_ -> (hostname, p)
- [hostname] -> (hostname, show discoveryPort)
- [] -> ("discovery.erebosprotocol.net", show discoveryPort)
- addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
- peer <- liftIO $ serverPeer server (addrAddress addr)
- sendToPeer peer $ DiscoverySelf [ T.pack "ICE" ] Nothing
- modify $ \s -> s { csIcePeer = Just peer }
-
cmdDiscovery :: Command
cmdDiscovery = void $ do
- Just peer <- gets csIcePeer
- st <- getStorage
- sref <- asks ciLine
- eprint <- asks ciPrint
- liftIO $ readRef st (BC.pack sref) >>= \case
- Nothing -> error "ref does not exist"
- Just ref -> do
- res <- runExceptT $ sendToPeer peer $ DiscoverySearch ref
- case res of
- Right _ -> return ()
- Left err -> eprint err
-
-#ifdef ENABLE_ICE_SUPPORT
-
-cmdIceCreate :: Command
-cmdIceCreate = do
- role <- asks ciLine >>= return . \case
- 'm':_ -> PjIceSessRoleControlling
- 's':_ -> PjIceSessRoleControlled
- _ -> PjIceSessRoleUnknown
- eprint <- asks ciPrint
- sess <- liftIO $ iceCreate role $ eprint <=< iceShow
- modify $ \s -> s { csIceSessions = sess : csIceSessions s }
-
-cmdIceDestroy :: Command
-cmdIceDestroy = do
- s:ss <- gets csIceSessions
- modify $ \st -> st { csIceSessions = ss }
- liftIO $ iceDestroy s
-
-cmdIceShow :: Command
-cmdIceShow = do
- sess <- gets csIceSessions
- eprint <- asks ciPrint
- liftIO $ forM_ (zip [1::Int ..] sess) $ \(i, s) -> do
- eprint $ "[" ++ show i ++ "]"
- eprint =<< iceShow s
-
-cmdIceConnect :: Command
-cmdIceConnect = do
- s:_ <- gets csIceSessions
- server <- asks ciServer
- let loadInfo = BC.getLine >>= \case line | BC.null line -> return []
- | otherwise -> (line:) <$> loadInfo
- Right remote <- liftIO $ do
- st <- memoryStorage
- pst <- derivePartialStorage st
- rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo
- copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes)
- liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s
-
-cmdIceSend :: Command
-cmdIceSend = void $ do
- s:_ <- gets csIceSessions
server <- asks ciServer
- liftIO $ serverPeerIce server s
-
-#endif
+ sref <- asks ciLine
+ case readRefDigest (BC.pack sref) of
+ Nothing -> throwOtherError "failed to parse ref"
+ Just dgst -> discoverySearch server dgst
cmdQuit :: Command
cmdQuit = modify $ \s -> s { csQuit = True }
diff --git a/main/State.hs b/main/State.hs
new file mode 100644
index 0000000..5d66ba9
--- /dev/null
+++ b/main/State.hs
@@ -0,0 +1,115 @@
+module State (
+ loadLocalStateHead,
+ createLocalStateHead,
+ updateSharedIdentity,
+ interactiveIdentityUpdate,
+) where
+
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.IO.Class
+
+import Data.Foldable
+import Data.Proxy
+import Data.Text (Text)
+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
+ :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m)
+ => Terminal -> m (Head LocalState)
+loadLocalStateHead term = getStorage >>= loadHeads >>= \case
+ (h : _) -> return h
+ [] -> do
+ name <- liftIO $ do
+ setPrompt term "Name: "
+ getInputLine term $ KeepPrompt . maybe T.empty T.pack
+
+ devName <- liftIO $ do
+ setPrompt term "Device: "
+ getInputLine term $ KeepPrompt . maybe T.empty T.pack
+
+ ( owner, shared ) <- if
+ | T.null name -> do
+ return ( Nothing, [] )
+ | otherwise -> do
+ owner <- createIdentity (Just name) Nothing
+ shared <- mstore SharedState
+ { ssPrev = []
+ , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
+ , ssValue = [ storedRef $ idExtData owner ]
+ }
+ return ( Just owner, [ shared ] )
+
+ identity <- createIdentity (if T.null devName then Nothing else Just devName) owner
+
+ st <- getStorage
+ storeHead st $ LocalState
+ { lsPrev = Nothing
+ , lsIdentity = idExtData identity
+ , lsShared = shared
+ , lsOther = []
+ }
+
+createLocalStateHead
+ :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m)
+ => [ Maybe Text ] -> m (Head LocalState)
+createLocalStateHead [] = throwOtherError "createLocalStateHead: empty name list"
+createLocalStateHead ( ownerName : names ) = do
+ owner <- createIdentity ownerName Nothing
+ identity <- foldM createSingleIdentity owner names
+ shared <- case names of
+ [] -> return []
+ _ : _ -> do
+ fmap (: []) $ mstore SharedState
+ { ssPrev = []
+ , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
+ , ssValue = [ storedRef $ idExtData owner ]
+ }
+ st <- getStorage
+ storeHead st $ LocalState
+ { lsPrev = Nothing
+ , lsIdentity = idExtData identity
+ , lsShared = shared
+ , lsOther = []
+ }
+ where
+ createSingleIdentity owner name = createIdentity name (Just owner)
+
+
+updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m ()
+updateSharedIdentity term = updateLocalState_ $ updateSharedState_ $ \case
+ 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 fidentity = do
+ identity <- mergeIdentity fidentity
+ 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 -> return identity
+ | otherwise -> do
+ secret <- loadKey $ idKeyIdentity identity
+ maybe (throwOtherError "created invalid identity") return . validateExtendedIdentity =<<
+ mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData identity)
+ { idePrev = toList $ idExtDataF identity
+ , ideName = Just name
+ }
diff --git a/main/Terminal.hs b/main/Terminal.hs
new file mode 100644
index 0000000..b8b953f
--- /dev/null
+++ b/main/Terminal.hs
@@ -0,0 +1,421 @@
+{-# 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.Console.ANSI
+import System.IO
+import System.IO.Error
+
+
+data Terminal = Terminal
+ { termLock :: MVar ()
+ , termAnsi :: Bool
+ , termCompletionFunc :: CompletionFunc IO
+ , termPrompt :: TVar String
+ , termShowPrompt :: TVar Bool
+ , termInput :: TVar ( String, String )
+ , termBottomLines :: TVar [ String ]
+ , termHistory :: TVar [ String ]
+ , termHistoryPos :: TVar Int
+ , termHistoryStash :: TVar ( String, String )
+ }
+
+data TerminalLine = TerminalLine
+ { tlTerminal :: Terminal
+ , tlLineCount :: Int
+ }
+
+data Input
+ = InputChar Char
+ | InputMoveUp
+ | InputMoveDown
+ | InputMoveRight
+ | InputMoveLeft
+ | InputMoveEnd
+ | 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 []
+ termHistory <- newTVarIO []
+ termHistoryPos <- newTVarIO 0
+ termHistoryStash <- 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
+ handleJust (guard . isEOFError) (\() -> return InputEnd) $ getChar >>= \case
+ '\ESC' -> do
+ esc <- readEsc
+ case parseEsc esc of
+ Just ( 'A' , [] ) -> return InputMoveUp
+ Just ( 'B' , [] ) -> return InputMoveDown
+ Just ( 'C' , [] ) -> return InputMoveRight
+ Just ( 'D' , [] ) -> return InputMoveLeft
+ _ -> return (InputEscape esc)
+ '\b' -> return InputBackspace
+ '\DEL' -> return InputBackspace
+ '\NAK' -> return InputClear
+ '\ETB' -> return InputBackWord
+ '\DLE' -> return InputMoveUp
+ '\SO' -> return InputMoveDown
+ '\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
+ when termAnsi $ do
+ withMVar termLock $ \_ -> do
+ prompt <- atomically $ do
+ writeTVar termShowPrompt True
+ readTVar termPrompt
+ putStr $ prompt <> "\ESC[K"
+ drawBottomLines term
+ hFlush stdout
+
+ mbLine <- go
+ forM_ mbLine $ \line -> do
+ let addLine xs
+ | null line = xs
+ | (x : _) <- xs, x == line = xs
+ | otherwise = line : xs
+ atomically $ do
+ writeTVar termHistory . addLine =<< readTVar termHistory
+ writeTVar termHistoryPos 0
+
+ case handleResult mbLine of
+ KeepPrompt x -> do
+ when termAnsi $ do
+ termPutStr term "\n\ESC[J"
+ return x
+ ErasePrompt x -> do
+ when termAnsi $ do
+ termPutStr term "\r\ESC[J"
+ return x
+ where
+ go = getInput >>= \case
+ InputChar '\n' -> do
+ atomically $ do
+ ( pre, post ) <- readTVar termInput
+ writeTVar termInput ( "", "" )
+ when termAnsi $ do
+ writeTVar termShowPrompt False
+ writeTVar termBottomLines []
+ return $ Just $ pre ++ post
+
+ InputChar '\t' | termAnsi -> 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 | T.unpack common /= pre -> do
+ updatePrompt $ T.unpack unused ++ T.unpack common
+ return []
+ _ -> do
+ 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
+
+ InputMoveUp -> withInput $ \prepost -> do
+ hist <- readTVar termHistory
+ pos <- readTVar termHistoryPos
+ case drop pos hist of
+ ( h : _ ) -> do
+ when (pos == 0) $ do
+ writeTVar termHistoryStash prepost
+ writeTVar termHistoryPos (pos + 1)
+ writeTVar termInput ( h, "" )
+ ("\r\ESC[K" <>) <$> getCurrentPromptLine term
+ [] -> do
+ return ""
+
+ InputMoveDown -> withInput $ \_ -> do
+ readTVar termHistoryPos >>= \case
+ 0 -> do
+ return ""
+ 1 -> do
+ writeTVar termHistoryPos 0
+ writeTVar termInput =<< readTVar termHistoryStash
+ ("\r\ESC[K" <>) <$> getCurrentPromptLine term
+ pos -> do
+ writeTVar termHistoryPos (pos - 1)
+ hist <- readTVar termHistory
+ case drop (pos - 2) hist of
+ ( h : _ ) -> do
+ writeTVar termInput ( h, "" )
+ ("\r\ESC[K" <>) <$> getCurrentPromptLine term
+ [] -> do
+ return ""
+
+ InputMoveRight -> withInput $ \case
+ ( pre, c : post ) -> do
+ writeTVar termInput ( pre ++ [ c ], post )
+ 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 (termAnsi && 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 Terminal { termAnsi = False } _ = do
+ return ()
+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
+ let strLines = lines str
+ tlLineCount = length strLines
+ if termAnsi
+ then do
+ promptLine <- atomically $ do
+ readTVar termShowPrompt >>= \case
+ True -> getCurrentPromptLine tlTerminal
+ False -> return ""
+ putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine
+ drawBottomLines tlTerminal
+ else do
+ putStr $ unlines strLines
+
+ hFlush stdout
+ return TerminalLine {..}
+
+
+printBottomLines :: Terminal -> String -> IO ()
+printBottomLines Terminal { termAnsi = False } _ = do
+ return ()
+printBottomLines term@Terminal {..} str = do
+ case lines str of
+ [] -> clearBottomLines term
+ blines -> do
+ withMVar termLock $ \_ -> do
+ atomically $ writeTVar termBottomLines blines
+ drawBottomLines term
+ hFlush stdout
+
+clearBottomLines :: Terminal -> IO ()
+clearBottomLines Terminal { termAnsi = False } = do
+ return ()
+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 183ed51..c3dca14 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -26,7 +26,7 @@ import Data.Text qualified as T
import Data.Text.Encoding
import Data.Text.IO qualified as T
import Data.Typeable
-import Data.UUID qualified as U
+import Data.UUID.Types qualified as U
import Network.Socket
@@ -36,17 +36,20 @@ 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.Service.Stream
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
@@ -64,10 +67,17 @@ data TestState = TestState
data RunningServer = RunningServer
{ rsServer :: Server
- , rsPeers :: MVar (Int, [(Int, Peer)])
+ , rsPeers :: MVar ( Int, [ TestPeer ] )
, rsPeerThread :: ThreadId
}
+data TestPeer = TestPeer
+ { tpIndex :: Int
+ , tpPeer :: Peer
+ , tpStreamReaders :: MVar [ (Int, StreamReader ) ]
+ , tpStreamWriters :: MVar [ (Int, StreamWriter ) ]
+ }
+
initTestState :: TestState
initTestState = TestState
{ tsHead = Nothing
@@ -101,7 +111,7 @@ runTestTool st = do
Nothing -> return ()
runExceptT (evalStateT testLoop initTestState) >>= \case
- Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack x
+ Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack (showErebosError x)
Right () -> return ()
getLineMb :: MonadIO m => m (Maybe Text)
@@ -135,17 +145,20 @@ cmdOut line = do
getPeer :: Text -> CommandM Peer
-getPeer spidx = do
+getPeer spidx = tpPeer <$> getTestPeer spidx
+
+getTestPeer :: Text -> CommandM TestPeer
+getTestPeer spidx = do
Just RunningServer {..} <- gets tsServer
- Just peer <- lookup (read $ T.unpack spidx) . snd <$> liftIO (readMVar rsPeers)
+ Just peer <- find (((read $ T.unpack spidx) ==) . tpIndex) . snd <$> liftIO (readMVar rsPeers)
return peer
-getPeerIndex :: MVar (Int, [(Int, Peer)]) -> ServiceHandler (PairingService a) Int
+getPeerIndex :: MVar ( Int, [ TestPeer ] ) -> ServiceHandler s Int
getPeerIndex pmvar = do
peer <- asks svcPeer
- maybe 0 fst . find ((==peer) . snd) . snd <$> liftIO (readMVar pmvar)
+ maybe 0 tpIndex . find ((peer ==) . tpPeer) . snd <$> liftIO (readMVar pmvar)
-pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar (Int, [(Int, Peer)]) -> String -> PairingAttributes a
+pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar ( Int, [ TestPeer ] ) -> String -> PairingAttributes a
pairingAttributes _ out peers prefix = PairingAttributes
{ pairingHookRequest = return ()
@@ -173,7 +186,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"
}
@@ -214,21 +227,28 @@ directMessageAttributes out = DirectMessageAttributes
{ dmOwnerMismatch = afterCommit $ outLine out "dm-owner-mismatch"
}
-dmReceivedWatcher :: Output -> Stored DirectMessage -> IO ()
-dmReceivedWatcher out smsg = do
- let msg = fromStored smsg
- outLine out $ unwords
- [ "dm-received"
- , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
- , "text", T.unpack $ msgText msg
- ]
+discoveryAttributes :: DiscoveryAttributes
+discoveryAttributes = (defaultServiceAttributes Proxy)
+ { discoveryProvideTunnel = \_ _ -> False
+ }
+
+dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO ()
+dmThreadWatcher self out prev cur = do
+ forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do
+ outLine out $ unwords
+ [ if sameIdentity self (msgFrom msg)
+ then "dm-sent"
+ else "dm-received"
+ , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
+ , "text", T.unpack $ msgText msg
+ ]
-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
@@ -245,70 +265,85 @@ instance MonadHead LocalState CommandM where
type Command = CommandM ()
-commands :: [(Text, Command)]
-commands = map (T.pack *** id)
- [ ("store", cmdStore)
- , ("load", cmdLoad)
- , ("stored-generation", cmdStoredGeneration)
- , ("stored-roots", cmdStoredRoots)
- , ("stored-set-add", cmdStoredSetAdd)
- , ("stored-set-list", cmdStoredSetList)
- , ("head-create", cmdHeadCreate)
- , ("head-replace", cmdHeadReplace)
- , ("head-watch", cmdHeadWatch)
- , ("head-unwatch", cmdHeadUnwatch)
- , ("create-identity", cmdCreateIdentity)
- , ("identity-info", cmdIdentityInfo)
- , ("start-server", cmdStartServer)
- , ("stop-server", cmdStopServer)
- , ("peer-add", cmdPeerAdd)
- , ("peer-drop", cmdPeerDrop)
- , ("peer-list", cmdPeerList)
- , ("test-message-send", cmdTestMessageSend)
- , ("local-state-get", cmdLocalStateGet)
- , ("local-state-replace", cmdLocalStateReplace)
- , ("local-state-wait", cmdLocalStateWait)
- , ("shared-state-get", cmdSharedStateGet)
- , ("shared-state-wait", cmdSharedStateWait)
- , ("watch-local-identity", cmdWatchLocalIdentity)
- , ("watch-shared-identity", cmdWatchSharedIdentity)
- , ("update-local-identity", cmdUpdateLocalIdentity)
- , ("update-shared-identity", cmdUpdateSharedIdentity)
- , ("attach-to", cmdAttachTo)
- , ("attach-accept", cmdAttachAccept)
- , ("attach-reject", cmdAttachReject)
- , ("contact-request", cmdContactRequest)
- , ("contact-accept", cmdContactAccept)
- , ("contact-reject", cmdContactReject)
- , ("contact-list", cmdContactList)
- , ("contact-set-name", cmdContactSetName)
- , ("dm-send-peer", cmdDmSendPeer)
- , ("dm-send-contact", cmdDmSendContact)
- , ("dm-list-peer", cmdDmListPeer)
- , ("dm-list-contact", cmdDmListContact)
- , ("chatroom-create", cmdChatroomCreate)
- , ("chatroom-list-local", cmdChatroomListLocal)
- , ("chatroom-watch-local", cmdChatroomWatchLocal)
- , ("chatroom-set-name", cmdChatroomSetName)
- , ("chatroom-subscribe", cmdChatroomSubscribe)
- , ("chatroom-unsubscribe", cmdChatroomUnsubscribe)
- , ("chatroom-members", cmdChatroomMembers)
- , ("chatroom-join", cmdChatroomJoin)
- , ("chatroom-join-as", cmdChatroomJoinAs)
- , ("chatroom-leave", cmdChatroomLeave)
- , ("chatroom-message-send", cmdChatroomMessageSend)
- , ("discovery-connect", cmdDiscoveryConnect)
+commands :: [ ( Text, Command ) ]
+commands =
+ [ ( "store", cmdStore )
+ , ( "load", cmdLoad )
+ , ( "stored-generation", cmdStoredGeneration )
+ , ( "stored-roots", cmdStoredRoots )
+ , ( "stored-set-add", cmdStoredSetAdd )
+ , ( "stored-set-list", cmdStoredSetList )
+ , ( "stored-difference", cmdStoredDifference )
+ , ( "head-create", cmdHeadCreate )
+ , ( "head-replace", cmdHeadReplace )
+ , ( "head-watch", cmdHeadWatch )
+ , ( "head-unwatch", cmdHeadUnwatch )
+ , ( "create-identity", cmdCreateIdentity )
+ , ( "identity-info", cmdIdentityInfo )
+ , ( "start-server", cmdStartServer )
+ , ( "stop-server", cmdStopServer )
+ , ( "peer-add", cmdPeerAdd )
+ , ( "peer-drop", cmdPeerDrop )
+ , ( "peer-list", cmdPeerList )
+ , ( "test-message-send", cmdTestMessageSend )
+ , ( "test-stream-open", cmdTestStreamOpen )
+ , ( "test-stream-close", cmdTestStreamClose )
+ , ( "test-stream-send", cmdTestStreamSend )
+ , ( "local-state-get", cmdLocalStateGet )
+ , ( "local-state-replace", cmdLocalStateReplace )
+ , ( "local-state-wait", cmdLocalStateWait )
+ , ( "shared-state-get", cmdSharedStateGet )
+ , ( "shared-state-wait", cmdSharedStateWait )
+ , ( "watch-local-identity", cmdWatchLocalIdentity )
+ , ( "watch-shared-identity", cmdWatchSharedIdentity )
+ , ( "update-local-identity", cmdUpdateLocalIdentity )
+ , ( "update-shared-identity", cmdUpdateSharedIdentity )
+ , ( "attach-to", cmdAttachTo )
+ , ( "attach-accept", cmdAttachAccept )
+ , ( "attach-reject", cmdAttachReject )
+ , ( "contact-request", cmdContactRequest )
+ , ( "contact-accept", cmdContactAccept )
+ , ( "contact-reject", cmdContactReject )
+ , ( "contact-list", cmdContactList )
+ , ( "contact-set-name", cmdContactSetName )
+ , ( "dm-send-peer", cmdDmSendPeer )
+ , ( "dm-send-contact", cmdDmSendContact )
+ , ( "dm-send-identity", cmdDmSendIdentity )
+ , ( "dm-list-peer", cmdDmListPeer )
+ , ( "dm-list-contact", cmdDmListContact )
+ , ( "chatroom-create", cmdChatroomCreate )
+ , ( "chatroom-delete", cmdChatroomDelete )
+ , ( "chatroom-list-local", cmdChatroomListLocal )
+ , ( "chatroom-watch-local", cmdChatroomWatchLocal )
+ , ( "chatroom-set-name", cmdChatroomSetName )
+ , ( "chatroom-subscribe", cmdChatroomSubscribe )
+ , ( "chatroom-unsubscribe", cmdChatroomUnsubscribe )
+ , ( "chatroom-members", cmdChatroomMembers )
+ , ( "chatroom-join", cmdChatroomJoin )
+ , ( "chatroom-join-as", cmdChatroomJoinAs )
+ , ( "chatroom-leave", cmdChatroomLeave )
+ , ( "chatroom-message-send", cmdChatroomMessageSend )
+ , ( "discovery-connect", cmdDiscoveryConnect )
+ , ( "discovery-tunnel", cmdDiscoveryTunnel )
]
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
@@ -343,7 +378,7 @@ cmdStoredSetAdd = do
[Just iref, Just sref] -> return (wrappedLoad iref, loadSet @[Stored Object] sref)
[Just iref] -> return (wrappedLoad iref, emptySet)
_ -> fail "unexpected parameters"
- set' <- storeSetAdd st [item] set
+ set' <- storeSetAdd [ item ] set
cmdOut $ "stored-set-add" ++ concatMap ((' ':) . show . refDigest . storedRef) (toComponents set')
cmdStoredSetList :: Command
@@ -356,6 +391,19 @@ cmdStoredSetList = do
cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item
cmdOut $ "stored-set-done"
+cmdStoredDifference :: Command
+cmdStoredDifference = do
+ st <- asks tiStorage
+ ( trefs1, "|" : trefs2 ) <- span (/= "|") <$> asks tiParams
+
+ let loadObjs = mapM (maybe (fail "invalid ref") (return . wrappedLoad @Object) <=< liftIO . readRef st . encodeUtf8)
+ objs1 <- loadObjs trefs1
+ objs2 <- loadObjs trefs2
+
+ forM_ (storedDifference objs1 objs2) $ \item -> do
+ cmdOut $ "stored-difference-item " ++ (show $ refDigest $ storedRef item)
+ cmdOut $ "stored-difference-done"
+
cmdHeadCreate :: Command
cmdHeadCreate = do
[ ttid, tref ] <- asks tiParams
@@ -410,7 +458,8 @@ cmdHeadUnwatch = do
initTestHead :: Head LocalState -> Command
initTestHead h = do
- _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput
+ let self = finalOwner $ headLocalIdentity h
+ _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher self =<< asks tiOutput
modify $ \s -> s { tsHead = Just h }
loadTestHead :: CommandM (Head LocalState)
@@ -433,17 +482,18 @@ cmdCreateIdentity = do
st <- asks tiStorage
names <- asks tiParams
- h <- liftIO $ do
+ h <- do
Just identity <- if null names
- then Just <$> createIdentity st Nothing Nothing
- else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names
+ then Just <$> createIdentity Nothing Nothing
+ else foldrM (\n o -> Just <$> createIdentity (Just n) o) Nothing names
shared <- case names of
- _:_:_ -> (:[]) <$> makeSharedStateUpdate st (Just $ finalOwner identity) []
+ _:_:_ -> (: []) <$> makeSharedStateUpdate (Just $ finalOwner identity) []
_ -> return []
storeHead st $ LocalState
- { lsIdentity = idExtData identity
+ { lsPrev = Nothing
+ , lsIdentity = idExtData identity
, lsShared = shared
, lsOther = []
}
@@ -471,42 +521,78 @@ cmdStartServer = do
let parseParams = \case
(name : value : rest)
- | name == "services" -> T.splitOn "," value
+ | name == "services" -> second ( map splitServiceParams (T.splitOn "," value) ++ ) (parseParams rest)
+ (name : rest)
+ | name == "test-log" -> first (\o -> o { serverTestLog = True }) (parseParams rest)
| otherwise -> parseParams rest
- _ -> []
- serviceNames <- parseParams <$> asks tiParams
+ _ -> ( defaultServerOptions { serverErrorPrefix = "server-error-message " }, [] )
+
+ splitServiceParams svc =
+ case T.splitOn ":" svc of
+ name : params -> ( name, params )
+ _ -> ( svc, [] )
+
+ ( serverOptions, serviceNames ) <- parseParams <$> asks tiParams
h <- getOrLoadHead
rsPeers <- liftIO $ newMVar (1, [])
services <- forM serviceNames $ \case
- "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
- "chatroom" -> return $ someService @ChatroomService Proxy
- "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
- "discovery" -> return $ someService @DiscoveryService Proxy
- "dm" -> return $ someServiceAttr $ directMessageAttributes out
- "sync" -> return $ someService @SyncService Proxy
- "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy)
+ ( "attach", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
+ ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy
+ ( "contact", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
+ ( "discovery", params ) -> return $ someServiceAttr $ discoveryAttributes
+ { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params
+ }
+ ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out
+ ( "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]
+ outLine out $ unwords [ "test-message-received", otype, len, sref ]
+ , testStreamsReceived = \streams -> do
+ pidx <- getPeerIndex rsPeers
+ liftIO $ do
+ nums <- mapM getStreamReaderNumber streams
+ outLine out $ unwords $ "test-stream-open-from" : show pidx : map show nums
+ forM_ (zip nums streams) $ \( num, stream ) -> void $ forkIO $ do
+ let go = readStreamPacket stream >>= \case
+ StreamData seqNum bytes -> do
+ outLine out $ unwords [ "test-stream-received", show pidx, show num, show seqNum, BC.unpack bytes ]
+ go
+ StreamClosed seqNum -> do
+ outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ]
+ go
}
- sname -> throwError $ "unknown service `" <> T.unpack sname <> "'"
+ ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'"
- rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services
+ let logPrint str = do BC.hPutStrLn stdout (BC.pack str)
+ hFlush stdout
+ rsServer <- liftIO $ startServer serverOptions h logPrint services
rsPeerThread <- liftIO $ forkIO $ void $ forever $ do
peer <- getNextPeerChange rsServer
- let printPeer (idx, p) = do
- params <- peerIdentity p >>= return . \case
- PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
- _ -> [ "addr", show (peerAddress p) ]
- outLine out $ unwords $ [ "peer", show idx ] ++ params
-
- update (nid, []) = printPeer (nid, peer) >> return (nid + 1, [(nid, peer)])
- update cur@(nid, p:ps) | snd p == peer = printPeer p >> return cur
- | otherwise = fmap (p:) <$> update (nid, ps)
+ let printPeer TestPeer {..} = do
+ params <- getPeerIdentity tpPeer >>= \case
+ PeerIdentityFull pid -> do
+ return $ ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
+ _ -> do
+ paddr <- getPeerAddress tpPeer
+ return $ [ "addr", show paddr ]
+ outLine out $ unwords $ [ "peer", show tpIndex ] ++ params
+
+ update ( tpIndex, [] ) = do
+ tpPeer <- return peer
+ tpStreamReaders <- newMVar []
+ tpStreamWriters <- newMVar []
+ let tp = TestPeer {..}
+ printPeer tp
+ return ( tpIndex + 1, [ tp ] )
+
+ update cur@( nid, p : ps )
+ | tpPeer p == peer = printPeer p >> return cur
+ | otherwise = fmap (p :) <$> update ( nid, ps )
modifyMVar_ rsPeers update
@@ -543,11 +629,12 @@ cmdPeerList = do
peers <- liftIO $ getCurrentPeerList rsServer
tpeers <- liftIO $ readMVar rsPeers
forM_ peers $ \peer -> do
- Just (n, _) <- return $ find ((peer==).snd) . snd $ tpeers
- mbpid <- peerIdentity peer
+ Just tp <- return $ find ((peer ==) . tpPeer) . snd $ tpeers
+ mbpid <- getPeerIdentity peer
+ paddr <- getPeerAddress peer
cmdOut $ unwords $ concat
- [ [ "peer-list-item", show n ]
- , [ "addr", show (peerAddress peer) ]
+ [ [ "peer-list-item", show (tpIndex tp) ]
+ , [ "addr", show paddr ]
, case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
_ -> []
]
@@ -563,6 +650,40 @@ cmdTestMessageSend = do
sendManyToPeer peer $ map (TestMessage . wrappedLoad) refs
cmdOut "test-message-send done"
+cmdTestStreamOpen :: Command
+cmdTestStreamOpen = do
+ spidx : rest <- asks tiParams
+ tp <- getTestPeer spidx
+ count <- case rest of
+ [] -> return 1
+ tcount : _ -> return $ read $ T.unpack tcount
+
+ out <- asks tiOutput
+ runPeerService (tpPeer tp) $ do
+ streams <- openTestStreams count
+ afterCommit $ do
+ nums <- mapM getStreamWriterNumber streams
+ modifyMVar_ (tpStreamWriters tp) $ return . (++ zip nums streams)
+ outLine out $ unwords $ "test-stream-open-done"
+ : T.unpack spidx
+ : map show nums
+
+cmdTestStreamClose :: Command
+cmdTestStreamClose = do
+ [ spidx, sid ] <- asks tiParams
+ tp <- getTestPeer spidx
+ Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp))
+ liftIO $ closeStream stream
+ cmdOut $ unwords [ "test-stream-close-done", T.unpack spidx, T.unpack sid ]
+
+cmdTestStreamSend :: Command
+cmdTestStreamSend = do
+ [ spidx, sid, content ] <- asks tiParams
+ tp <- getTestPeer spidx
+ Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp))
+ liftIO $ writeStream stream $ encodeUtf8 content
+ cmdOut $ unwords [ "test-stream-send-done", T.unpack spidx, T.unpack sid ]
+
cmdLocalStateGet :: Command
cmdLocalStateGet = do
h <- getHead
@@ -635,7 +756,7 @@ cmdWatchSharedIdentity = do
cmdUpdateLocalIdentity :: Command
cmdUpdateLocalIdentity = do
[name] <- asks tiParams
- updateLocalHead_ $ \ls -> do
+ updateLocalState_ $ \ls -> do
Just identity <- return $ validateExtendedIdentity $ lsIdentity $ fromStored ls
let public = idKeyIdentity identity
@@ -650,8 +771,8 @@ cmdUpdateLocalIdentity = do
cmdUpdateSharedIdentity :: Command
cmdUpdateSharedIdentity = do
[name] <- asks tiParams
- updateLocalHead_ $ updateSharedState_ $ \case
- Nothing -> throwError "no existing shared identity"
+ updateLocalState_ $ updateSharedState_ $ \case
+ Nothing -> throwOtherError "no existing shared identity"
Just identity -> do
let public = idKeyIdentity identity
secret <- loadKey public
@@ -720,13 +841,13 @@ cmdContactSetName :: Command
cmdContactSetName = do
[cid, name] <- asks tiParams
contact <- getContact cid
- updateLocalHead_ $ updateSharedState_ $ contactSetName contact name
+ updateLocalState_ $ updateSharedState_ $ contactSetName contact name
cmdOut "contact-set-name-done"
cmdDmSendPeer :: Command
cmdDmSendPeer = do
[spidx, msg] <- asks tiParams
- PeerIdentityFull to <- peerIdentity =<< getPeer spidx
+ PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx
void $ sendDirectMessage to msg
cmdDmSendContact :: Command
@@ -735,12 +856,20 @@ cmdDmSendContact = do
Just to <- contactIdentity <$> getContact cid
void $ sendDirectMessage to msg
+cmdDmSendIdentity :: Command
+cmdDmSendIdentity = do
+ st <- asks tiStorage
+ [ tid, msg ] <- asks tiParams
+ Just ref <- liftIO $ readRef st $ encodeUtf8 tid
+ Just to <- return $ validateExtendedIdentity $ wrappedLoad ref
+ void $ sendDirectMessage to msg
+
dmList :: Foldable f => Identity f -> Command
dmList peer = do
- threads <- toThreadList . lookupSharedValue . lsShared . headObject <$> getHead
+ threads <- dmThreadList . lookupSharedValue . lsShared . headObject <$> getHead
case find (sameIdentity peer . msgPeer) threads of
Just thread -> do
- forM_ (reverse $ threadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item"
+ forM_ (reverse $ dmThreadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item"
<> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom)
<> " text " <> (T.unpack msgText)
Nothing -> return ()
@@ -749,7 +878,7 @@ dmList peer = do
cmdDmListPeer :: Command
cmdDmListPeer = do
[spidx] <- asks tiParams
- PeerIdentityFull to <- peerIdentity =<< getPeer spidx
+ PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx
dmList to
cmdDmListContact :: Command
@@ -764,6 +893,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
@@ -850,8 +986,7 @@ cmdChatroomJoin = do
cmdChatroomJoinAs :: Command
cmdChatroomJoinAs = do
[ cid, name ] <- asks tiParams
- st <- asks tiStorage
- identity <- liftIO $ createIdentity st (Just name) Nothing
+ identity <- createIdentity (Just name) Nothing
joinChatroomAsByStateData identity =<< getChatroomStateData cid
cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ]
@@ -869,11 +1004,14 @@ cmdChatroomMessageSend = do
cmdDiscoveryConnect :: Command
cmdDiscoveryConnect = do
- st <- asks tiStorage
[ tref ] <- asks tiParams
- Just ref <- liftIO $ readRef st $ encodeUtf8 tref
-
+ Just dgst <- return $ readRefDigest $ encodeUtf8 tref
Just RunningServer {..} <- gets tsServer
- peers <- liftIO $ getCurrentPeerList rsServer
- forM_ peers $ \peer -> do
- sendToPeer peer $ DiscoverySearch ref
+ discoverySearch rsServer dgst
+
+cmdDiscoveryTunnel :: Command
+cmdDiscoveryTunnel = do
+ [ tvia, ttarget ] <- asks tiParams
+ via <- getPeer tvia
+ Just target <- return $ readRefDigest $ encodeUtf8 ttarget
+ liftIO $ discoverySetupTunnel via target
diff --git a/main/Test/Service.hs b/main/Test/Service.hs
index 3e6eb83..c0be07d 100644
--- a/main/Test/Service.hs
+++ b/main/Test/Service.hs
@@ -1,20 +1,26 @@
module Test.Service (
TestMessage(..),
TestMessageAttributes(..),
+
+ openTestStreams,
) where
+import Control.Monad
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.Service.Stream
+import Erebos.Storable
data TestMessage = TestMessage (Stored Object)
data TestMessageAttributes = TestMessageAttributes
{ testMessageReceived :: Object -> String -> String -> String -> ServiceHandler TestMessage ()
+ , testStreamsReceived :: [ StreamReader ] -> ServiceHandler TestMessage ()
}
instance Storable TestMessage where
@@ -25,7 +31,10 @@ instance Service TestMessage where
serviceID _ = mkServiceID "cb46b92c-9203-4694-8370-8742d8ac9dc8"
type ServiceAttributes TestMessage = TestMessageAttributes
- defaultServiceAttributes _ = TestMessageAttributes (\_ _ _ _ -> return ())
+ defaultServiceAttributes _ = TestMessageAttributes
+ { testMessageReceived = \_ _ _ _ -> return ()
+ , testStreamsReceived = \_ -> return ()
+ }
serviceHandler smsg = do
let TestMessage sobj = fromStored smsg
@@ -35,3 +44,14 @@ instance Service TestMessage where
cb <- asks $ testMessageReceived . svcAttributes
cb obj otype len (show $ refDigest $ storedRef sobj)
_ -> return ()
+
+ streams <- receivedStreams
+ when (not $ null streams) $ do
+ cb <- asks $ testStreamsReceived . svcAttributes
+ cb streams
+
+
+openTestStreams :: Int -> ServiceHandler TestMessage [ StreamWriter ]
+openTestStreams count = do
+ replyPacket . TestMessage =<< mstore (Rec [])
+ replicateM count openStream
diff --git a/main/WebSocket.hs b/main/WebSocket.hs
new file mode 100644
index 0000000..7a957e2
--- /dev/null
+++ b/main/WebSocket.hs
@@ -0,0 +1,48 @@
+module WebSocket (
+ WebSocketAddress(..),
+ startWebsocketServer,
+) where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+
+import Data.ByteString.Lazy qualified as BL
+import Data.Unique
+
+import Erebos.Network
+
+import Network.WebSockets qualified as WS
+
+
+data WebSocketAddress = WebSocketAddress Unique WS.Connection
+
+instance Eq WebSocketAddress where
+ WebSocketAddress u _ == WebSocketAddress u' _ = u == u'
+
+instance Ord WebSocketAddress where
+ compare (WebSocketAddress u _) (WebSocketAddress u' _) = compare u u'
+
+instance Show WebSocketAddress where
+ show (WebSocketAddress _ _) = "websocket"
+
+instance PeerAddressType WebSocketAddress where
+ sendBytesToAddress (WebSocketAddress _ conn) msg = do
+ WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg
+ connectionToAddressClosed (WebSocketAddress _ conn) = do
+ WS.sendClose conn BL.empty
+
+startWebsocketServer :: Server -> String -> Int -> (String -> IO ()) -> IO ()
+startWebsocketServer server addr port logd = do
+ void $ forkIO $ do
+ WS.runServer addr port $ \pending -> do
+ conn <- WS.acceptRequest pending
+ u <- newUnique
+ let paddr = WebSocketAddress u conn
+ void $ serverPeerCustom server paddr
+ handle (\(e :: SomeException) -> logd $ "WebSocket thread exception: " ++ show e) $ do
+ WS.withPingThread conn 30 (return ()) $ do
+ forever $ do
+ WS.receiveDataMessage conn >>= \case
+ WS.Binary msg -> receivedFromCustomAddress server paddr $ BL.toStrict msg
+ WS.Text {} -> logd $ "unexpected websocket text message"
generated by cgit v1.2.3 (git 2.25.1) at 2025-09-14 03:08:50 +0000