summaryrefslogtreecommitdiff
path: root/main
diff options
context:
space:
mode:
Diffstat (limited to 'main')
-rw-r--r--main/Main.hs648
-rw-r--r--main/State.hs73
-rw-r--r--main/Terminal.hs120
-rw-r--r--main/Test.hs451
-rw-r--r--main/Test/Service.hs21
-rw-r--r--main/WebSocket.hs7
6 files changed, 861 insertions, 459 deletions
diff --git a/main/Main.hs b/main/Main.hs
index a1a8b50..a876d7b 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -1,9 +1,7 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
-import Control.Arrow (first)
import Control.Concurrent
import Control.Exception
import Control.Monad
@@ -11,11 +9,13 @@ import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Maybe
+import Control.Monad.Writer
import Crypto.Random
-import qualified Data.ByteString.Char8 as BC
-import qualified Data.ByteString.Lazy as BL
+import Data.Bifunctor
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
import Data.Char
import Data.List
import Data.Maybe
@@ -42,9 +42,6 @@ import Erebos.Chatroom
import Erebos.Conversation
import Erebos.DirectMessage
import Erebos.Discovery
-#ifdef ENABLE_ICE_SUPPORT
-import Erebos.ICE
-#endif
import Erebos.Identity
import Erebos.Network
import Erebos.Object
@@ -67,6 +64,7 @@ data Options = Options
{ optServer :: ServerOptions
, optServices :: [ServiceOption]
, optStorage :: StorageOption
+ , optCreateIdentity :: Maybe ( Maybe Text, [ Maybe Text ] )
, optChatroomAutoSubscribe :: Maybe Int
, optDmBotEcho :: Maybe Text
, optWebSocketServer :: Maybe Int
@@ -74,9 +72,10 @@ data Options = Options
, optShowVersion :: Bool
}
-data StorageOption = DefaultStorage
- | FilesystemStorage FilePath
- | MemoryStorage
+data StorageOption
+ = DefaultStorage
+ | FilesystemStorage FilePath
+ | MemoryStorage
data ServiceOption = ServiceOption
{ soptName :: String
@@ -90,6 +89,7 @@ defaultOptions = Options
{ optServer = defaultServerOptions
, optServices = availableServices
, optStorage = DefaultStorage
+ , optCreateIdentity = Nothing
, optChatroomAutoSubscribe = Nothing
, optDmBotEcho = Nothing
, optWebSocketServer = Nothing
@@ -113,69 +113,101 @@ availableServices =
True "peer discovery"
]
-options :: [OptDescr (Options -> Options)]
+options :: [ OptDescr (Options -> Writer [ String ] Options) ]
options =
- [ Option ['p'] ["port"]
+ [ Option [ 'p' ] [ "port" ]
(ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "<port>")
"local port to bind"
- , Option ['s'] ["silent"]
+ , Option [ 's' ] [ "silent" ]
(NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))
"do not send announce packets for local discovery"
, Option [] [ "storage" ]
- (ReqArg (\path -> \opts -> opts { optStorage = FilesystemStorage path }) "<path>")
+ (ReqArg (\path -> \opts -> return opts { optStorage = FilesystemStorage path }) "<path>")
"use storage in <path>"
, Option [] [ "memory-storage" ]
- (NoArg (\opts -> opts { optStorage = MemoryStorage }))
+ (NoArg (\opts -> return opts { optStorage = MemoryStorage }))
"use memory storage"
- , Option [] ["chatroom-auto-subscribe"]
- (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")
+ , Option [] [ "create-identity" ]
+ (OptArg (\value -> \opts -> return opts
+ { optCreateIdentity =
+ let devName = T.pack <$> value
+ in maybe (Just ( devName, [] )) (Just . first (const devName)) (optCreateIdentity opts)
+ }) "<name>")
+ "create a new (device) identity in a new local state"
+ , Option [] [ "create-owner" ]
+ (OptArg (\value -> \opts -> return opts
+ { optCreateIdentity =
+ let ownerName = T.pack <$> value
+ in maybe (Just ( Nothing, [ ownerName ] )) (Just . second (ownerName :)) (optCreateIdentity opts)
+ }) "<name>")
+ "create owner for a new device identity"
+ , Option [] [ "chatroom-auto-subscribe" ]
+ (ReqArg (\count -> \opts -> return opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")
"automatically subscribe for up to <count> chatrooms"
-#ifdef ENABLE_ICE_SUPPORT
, Option [] [ "discovery-stun-port" ]
- (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunPort = Just (read value) }) "<port>")
+ (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryStunPort = Just (read value) }) "<port>")
"offer specified <port> to discovery peers for STUN protocol"
, Option [] [ "discovery-stun-server" ]
- (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunServer = Just (read value) }) "<server>")
+ (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryStunServer = Just (read value) }) "<server>")
"offer <server> (domain name or IP address) to discovery peers for STUN protocol"
, Option [] [ "discovery-turn-port" ]
- (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnPort = Just (read value) }) "<port>")
+ (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnPort = Just (read value) }) "<port>")
"offer specified <port> to discovery peers for TURN protocol"
, Option [] [ "discovery-turn-server" ]
- (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnServer = Just (read value) }) "<server>")
+ (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnServer = Just (read value) }) "<server>")
"offer <server> (domain name or IP address) to discovery peers for TURN protocol"
-#endif
- , Option [] ["dm-bot-echo"]
- (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")
+ , Option [] [ "discovery-tunnel" ]
+ (OptArg (\value -> \opts -> do
+ fun <- provideTunnelFun value
+ serviceAttr (\attrs -> return attrs { discoveryProvideTunnel = fun }) opts) "<peer-type>")
+ "offer to provide tunnel for peers of given <peer-type>, possible values: all, none, websocket"
+ , Option [] [ "dm-bot-echo" ]
+ (ReqArg (\prefix -> \opts -> return opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")
"automatically reply to direct messages with the same text prefixed with <prefix>"
, Option [] [ "websocket-server" ]
- (ReqArg (\value -> \opts -> opts { optWebSocketServer = Just (read value) }) "<port>")
+ (ReqArg (\value -> \opts -> return opts { optWebSocketServer = Just (read value) }) "<port>")
"start WebSocket server on given port"
- , Option ['h'] ["help"]
- (NoArg $ \opts -> opts { optShowHelp = True })
+ , Option [ 'h' ] [ "help" ]
+ (NoArg $ \opts -> return opts { optShowHelp = True })
"show this help and exit"
- , Option ['V'] ["version"]
- (NoArg $ \opts -> opts { optShowVersion = True })
+ , Option [ 'V' ] [ "version" ]
+ (NoArg $ \opts -> return opts { optShowVersion = True })
"show version and exit"
]
where
- so f opts = opts { optServer = f $ optServer opts }
+ so f opts = return opts { optServer = f $ optServer opts }
- updateService :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> SomeService -> SomeService
+ updateService :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> SomeService -> m SomeService
updateService f some@(SomeService proxy attrs)
- | Just f' <- cast f = SomeService proxy (f' attrs)
- | otherwise = some
-
- serviceAttr :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> Options -> Options
- serviceAttr f opts = opts { optServices = map (\sopt -> sopt { soptService = updateService f (soptService sopt) }) (optServices opts) }
-
-servicesOptions :: [OptDescr (Options -> Options)]
+ | Just f' <- cast f = SomeService proxy <$> f' attrs
+ | otherwise = return some
+
+ serviceAttr :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> Options -> m Options
+ serviceAttr f opts = do
+ services' <- forM (optServices opts) $ \sopt -> do
+ service <- updateService f (soptService sopt)
+ return sopt { soptService = service }
+ return opts { optServices = services' }
+
+ provideTunnelFun :: Maybe String -> Writer [ String ] (Peer -> PeerAddress -> Bool)
+ provideTunnelFun Nothing = return $ \_ _ -> True
+ provideTunnelFun (Just "all") = return $ \_ _ -> True
+ provideTunnelFun (Just "none") = return $ \_ _ -> False
+ provideTunnelFun (Just "websocket") = return $ \_ -> \case
+ CustomPeerAddress addr | Just WebSocketAddress {} <- cast addr -> True
+ _ -> False
+ provideTunnelFun (Just name) = do
+ tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ]
+ return $ \_ _ -> False
+
+servicesOptions :: [ OptDescr (Options -> Writer [ String ] Options) ]
servicesOptions = concatMap helper $ "all" : map soptName availableServices
where
helper name =
- [ Option [] ["enable-" <> name] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = True }) ""
- , Option [] ["disable-" <> name] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = False }) ""
+ [ Option [] [ "enable-" <> name ] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = True }) ""
+ , Option [] [ "disable-" <> name ] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = False }) ""
]
- so f opts = opts { optServices = f $ optServices opts }
+ so f opts = return opts { optServices = f $ optServices opts }
change :: String -> (ServiceOption -> ServiceOption) -> [ServiceOption] -> [ServiceOption]
change name f (s : ss)
| soptName s == name || name == "all"
@@ -193,13 +225,16 @@ getDefaultStorageDir = do
main :: IO ()
main = do
- (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case
- (o, args, []) -> do
- return (foldl (flip id) defaultOptions o, args)
- (_, _, errs) -> do
+ let printErrors errs = do
progName <- getProgName
hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information."
exitFailure
+ (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case
+ (wo, args, []) ->
+ case runWriter (foldM (flip ($)) defaultOptions wo) of
+ ( o, [] ) -> return ( o, args )
+ ( _, errs ) -> printErrors errs
+ (_, _, errs) -> printErrors errs
st <- liftIO $ case optStorage opts of
DefaultStorage -> openStorage =<< getDefaultStorageDir
@@ -207,7 +242,7 @@ main = do
MemoryStorage -> memoryStorage
case args of
- ["cat-file", sref] -> do
+ [ "cat-file", sref ] -> do
readRef st (BC.pack sref) >>= \case
Nothing -> error "ref does not exist"
Just ref -> BL.putStr $ lazyLoadBytes ref
@@ -238,14 +273,22 @@ main = do
Nothing -> putStrLn $ "Identity verification failed"
_ -> error $ "unknown object type '" ++ objtype ++ "'"
- ["show-generation", sref] -> readRef st (BC.pack sref) >>= \case
+ [ "show-generation", sref ] -> readRef st (BC.pack sref) >>= \case
Nothing -> error "ref does not exist"
Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object)
- ["update-identity"] -> do
+ [ "identity" ] -> do
+ loadHeads st >>= \case
+ (h : _) -> do
+ T.putStr $ showIdentityDetails $ headLocalIdentity h
+ [] -> do
+ T.putStrLn "no local state head"
+ exitFailure
+
+ [ "update-identity" ] -> do
withTerminal noCompletion $ \term -> do
either (fail . showErebosError) return <=< runExceptT $ do
- runReaderT (updateSharedIdentity term) =<< loadLocalStateHead term st
+ runReaderT (updateSharedIdentity term) =<< runReaderT (loadLocalStateHead term) st
("update-identity" : srefs) -> do
withTerminal noCompletion $ \term -> do
@@ -257,7 +300,7 @@ main = do
(either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st)
| otherwise -> error "invalid identity"
- ["test"] -> runTestTool st
+ [ "test" ] -> runTestTool st
[] -> do
let header = "Usage: erebos [OPTION...]"
@@ -287,7 +330,10 @@ main = do
interactiveLoop :: Storage -> Options -> IO ()
interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
- erebosHead <- liftIO $ loadLocalStateHead term st
+ erebosHead <- either (fail . showErebosError) return <=< runExceptT . flip runReaderT st $ do
+ case optCreateIdentity opts of
+ Nothing -> loadLocalStateHead term
+ Just ( devName, names ) -> createLocalStateHead (names ++ [ devName ])
void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
let tui = hasTerminalUI term
@@ -299,7 +345,7 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
Left cstate -> do
pname <- case csContext cstate of
NoContext -> return ""
- SelectedPeer peer -> peerIdentity peer >>= return . \case
+ SelectedPeer peer -> getPeerIdentity peer >>= return . \case
PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid
PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
PeerIdentityUnknown _ -> "<unknown>"
@@ -315,54 +361,70 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
_ | all isSpace input -> getInputLinesTui eprompt
'\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ")
_ -> return input
- Nothing -> KeepPrompt mzero
+ Nothing
+ | tui -> KeepPrompt mzero
+ | otherwise -> KeepPrompt $ liftIO $ forever $ threadDelay 100000000
getInputCommandTui cstate = do
- input <- getInputLinesTui cstate
- let (CommandM cmd, line) = case input of
- '/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest
- in if not (null scmd) && all isDigit scmd
- then (cmdSelectContext, scmd)
- else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
- _ -> (cmdSend, input)
- return (cmd, line)
-
- getInputLinesPipe = do
- join $ lift $ getInputLine term $ KeepPrompt . \case
- Just input -> return input
- Nothing -> liftIO $ forever $ threadDelay 100000000
-
- getInputCommandPipe _ = do
- input <- getInputLinesPipe
- let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') input
- let (CommandM cmd, line) = (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
- return (cmd, line)
-
- let getInputCommand = if tui then getInputCommandTui . Left
- else getInputCommandPipe
+ let parseCommand cmdline =
+ case dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') cmdline of
+ ( scmd, args )
+ | not (null scmd) && all isDigit scmd
+ -> ( cmdSelectContext, scmd )
+
+ | otherwise
+ -> ( fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args )
+
+ ( CommandM cmd, line ) <- getInputLinesTui cstate >>= return . \case
+ '/' : input -> parseCommand input
+ input | not tui -> parseCommand input
+ input -> ( cmdSend, input )
+ return ( cmd, line )
+
+ let getInputCommand = getInputCommandTui . Left
+
+ contextVar <- liftIO $ newMVar NoContext
_ <- liftIO $ do
tzone <- getCurrentTimeZone
- watchReceivedMessages erebosHead $ \smsg -> do
- let msg = fromStored smsg
- extPrintLn $ formatDirectMessage tzone msg
- case optDmBotEcho opts of
- Nothing -> return ()
- Just prefix -> do
- res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg)
- case res of
- Right reply -> extPrintLn $ formatDirectMessage tzone $ fromStored reply
- Left err -> extPrintLn $ "Failed to send dm echo: " <> err
+ let self = finalOwner $ headLocalIdentity erebosHead
+ watchDirectMessageThreads erebosHead $ \prev cur -> do
+ forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do
+ withMVar contextVar $ \ctx -> do
+ mbpid <- case ctx of
+ SelectedPeer peer -> getPeerIdentity peer >>= return . \case
+ PeerIdentityFull pid -> Just $ finalOwner pid
+ _ -> Nothing
+ SelectedContact contact
+ | Just cid <- contactIdentity contact -> return (Just cid)
+ SelectedConversation conv -> return $ conversationPeer conv
+ _ -> return Nothing
+ when (not tui || maybe False (msgPeer cur `sameIdentity`) mbpid) $ do
+ extPrintLn $ formatDirectMessage tzone msg
+
+ case optDmBotEcho opts of
+ Just prefix
+ | not (msgFrom msg `sameIdentity` self)
+ -> do
+ void $ forkIO $ do
+ res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg)
+ case res of
+ Right _ -> return ()
+ Left err -> extPrintLn $ "Failed to send dm echo: " <> err
+ _ -> return ()
peers <- liftIO $ newMVar []
- contextOptions <- liftIO $ newMVar []
+ contextOptions <- liftIO $ newMVar ( Nothing, [] )
chatroomSetVar <- liftIO $ newEmptyMVar
let autoSubscribe = optChatroomAutoSubscribe opts
chatroomList = fromSetBy (comparing roomStateData) . lookupSharedValue . lsShared . headObject $ erebosHead
watched <- if isJust autoSubscribe || any roomStateSubscribe chatroomList
- then fmap Just $ liftIO $ watchChatroomsForCli extPrintLn erebosHead chatroomSetVar contextOptions autoSubscribe
- else return Nothing
+ then do
+ fmap Just $ liftIO $ watchChatroomsForCli tui extPrintLn erebosHead
+ chatroomSetVar contextVar contextOptions autoSubscribe
+ else do
+ return Nothing
server <- liftIO $ do
startServer (optServer opts) erebosHead extPrintLn $
@@ -374,10 +436,10 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
void $ liftIO $ forkIO $ void $ forever $ do
peer <- getNextPeerChange server
- peerIdentity peer >>= \case
+ getPeerIdentity peer >>= \case
pid@(PeerIdentityFull _) -> do
dropped <- isPeerDropped peer
- let shown = showPeer pid $ peerAddress peer
+ shown <- showPeer pid <$> getPeerAddress peer
let update [] = ([(peer, shown)], (Nothing, "NEW"))
update ((p,s):ps)
| p == peer && dropped = (ps, (Nothing, "DEL"))
@@ -389,8 +451,15 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
| otherwise = first (ctx:) $ ctxUpdate (n + 1) ctxs
(op, updateType) <- modifyMVar peers (return . update)
let updateType' = if dropped then "DEL" else updateType
- idx <- modifyMVar contextOptions (return . ctxUpdate (1 :: Int))
- when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown
+ modifyMVar_ contextOptions $ \case
+ ( watch, clist )
+ | watch == Just WatchPeers || not tui
+ -> do
+ let ( clist', idx ) = ctxUpdate (1 :: Int) clist
+ when (Just shown /= op) $ do
+ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown
+ return ( Just WatchPeers, clist' )
+ cur -> return cur
_ -> return ()
let process :: CommandState -> MaybeT IO CommandState
@@ -400,20 +469,23 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
Just h -> return h
Nothing -> do lift $ extPrintLn "current head deleted"
mzero
- res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput
- { ciServer = server
- , ciTerminal = term
- , ciLine = line
- , ciPrint = extPrintLn
- , ciOptions = opts
- , ciPeers = liftIO $ modifyMVar peers $ \ps -> do
- ps' <- filterM (fmap not . isPeerDropped . fst) ps
- return (ps', ps')
- , ciContextOptions = liftIO $ readMVar contextOptions
- , ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs
- , ciContextOptionsVar = contextOptions
- , ciChatroomSetVar = chatroomSetVar
- }
+ res <- liftIO $ modifyMVar contextVar $ \ctx -> do
+ res <- runExceptT $ flip execStateT cstate { csHead = h, csContext = ctx } $ runReaderT cmd CommandInput
+ { ciServer = server
+ , ciTerminal = term
+ , ciLine = line
+ , ciPrint = extPrintLn
+ , ciOptions = opts
+ , ciPeers = liftIO $ modifyMVar peers $ \ps -> do
+ ps' <- filterM (fmap not . isPeerDropped . fst) ps
+ return (ps', ps')
+ , ciContextOptions = liftIO $ snd <$> readMVar contextOptions
+ , ciSetContextOptions = \watch ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ( Just watch, ctxs )
+ , ciContextVar = contextVar
+ , ciContextOptionsVar = contextOptions
+ , ciChatroomSetVar = chatroomSetVar
+ }
+ return ( either (const ctx) csContext res, res )
case res of
Right cstate'
| csQuit cstate' -> mzero
@@ -427,10 +499,6 @@ interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
loop $ Just $ CommandState
{ csHead = erebosHead
, csContext = NoContext
-#ifdef ENABLE_ICE_SUPPORT
- , csIceSessions = []
-#endif
- , csIcePeer = Nothing
, csWatchChatrooms = watched
, csQuit = False
}
@@ -443,28 +511,33 @@ data CommandInput = CommandInput
, ciPrint :: String -> IO ()
, ciOptions :: Options
, ciPeers :: CommandM [(Peer, String)]
- , ciContextOptions :: CommandM [CommandContext]
- , ciSetContextOptions :: [CommandContext] -> Command
- , ciContextOptionsVar :: MVar [ CommandContext ]
+ , ciContextOptions :: CommandM [ CommandContext ]
+ , ciSetContextOptions :: ContextWatchOptions -> [ CommandContext ] -> Command
+ , ciContextVar :: MVar CommandContext
+ , ciContextOptionsVar :: MVar ( Maybe ContextWatchOptions, [ CommandContext ] )
, ciChatroomSetVar :: MVar (Set ChatroomState)
}
data CommandState = CommandState
{ csHead :: Head LocalState
, csContext :: CommandContext
-#ifdef ENABLE_ICE_SUPPORT
- , csIceSessions :: [IceSession]
-#endif
- , csIcePeer :: Maybe Peer
, csWatchChatrooms :: Maybe WatchedHead
, csQuit :: Bool
}
-data CommandContext = NoContext
- | SelectedPeer Peer
- | SelectedContact Contact
- | SelectedChatroom ChatroomState
- | SelectedConversation Conversation
+data CommandContext
+ = NoContext
+ | SelectedPeer Peer
+ | SelectedContact Contact
+ | SelectedChatroom ChatroomState
+ | SelectedConversation Conversation
+
+data ContextWatchOptions
+ = WatchPeers
+ | WatchContacts
+ | WatchChatrooms
+ | WatchConversations
+ deriving (Eq)
newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a)
deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError)
@@ -503,8 +576,11 @@ getSelectedChatroom = gets csContext >>= \case
_ -> 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
_ -> throwOtherError "incomplete peer identity"
SelectedContact contact -> case contactIdentity contact of
@@ -517,42 +593,43 @@ getSelectedConversation = gets csContext >>= \case
SelectedConversation conv -> reloadConversation conv
_ -> 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)
- , ("peers", cmdPeers)
- , ("peer-add", cmdPeerAdd)
- , ("peer-add-public", cmdPeerAddPublic)
- , ("peer-drop", cmdPeerDrop)
- , ("send", cmdSend)
- , ("delete", cmdDelete)
- , ("update-identity", cmdUpdateIdentity)
- , ("attach", cmdAttach)
- , ("attach-accept", cmdAttachAccept)
- , ("attach-reject", cmdAttachReject)
- , ("chatrooms", cmdChatrooms)
- , ("chatroom-create-public", cmdChatroomCreatePublic)
- , ("contacts", cmdContacts)
- , ("contact-add", cmdContactAdd)
- , ("contact-accept", cmdContactAccept)
- , ("contact-reject", cmdContactReject)
- , ("conversations", cmdConversations)
- , ("details", cmdDetails)
- , ("discovery-init", cmdDiscoveryInit)
- , ("discovery", cmdDiscovery)
-#ifdef ENABLE_ICE_SUPPORT
- , ("ice-create", cmdIceCreate)
- , ("ice-destroy", cmdIceDestroy)
- , ("ice-show", cmdIceShow)
- , ("ice-connect", cmdIceConnect)
- , ("ice-send", cmdIceSend)
-#endif
- , ("join", cmdJoin)
- , ("join-as", cmdJoinAs)
- , ("leave", cmdLeave)
- , ("members", cmdMembers)
- , ("select", cmdSelectContext)
- , ("quit", cmdQuit)
+ [ ( "history", cmdHistory )
+ , ( "identity", cmdIdentity )
+ , ( "peers", cmdPeers )
+ , ( "peer-add", cmdPeerAdd )
+ , ( "peer-add-public", cmdPeerAddPublic )
+ , ( "peer-drop", cmdPeerDrop )
+ , ( "send", cmdSend )
+ , ( "delete", cmdDelete )
+ , ( "update-identity", cmdUpdateIdentity )
+ , ( "attach", cmdAttach )
+ , ( "attach-accept", cmdAttachAccept )
+ , ( "attach-reject", cmdAttachReject )
+ , ( "chatrooms", cmdChatrooms )
+ , ( "chatroom-create-public", cmdChatroomCreatePublic )
+ , ( "contacts", cmdContacts )
+ , ( "contact-add", cmdContactAdd )
+ , ( "contact-accept", cmdContactAccept )
+ , ( "contact-reject", cmdContactReject )
+ , ( "conversations", cmdConversations )
+ , ( "new", cmdNew )
+ , ( "details", cmdDetails )
+ , ( "discovery", cmdDiscovery )
+ , ( "join", cmdJoin )
+ , ( "join-as", cmdJoinAs )
+ , ( "leave", cmdLeave )
+ , ( "members", cmdMembers )
+ , ( "select", cmdSelectContext )
+ , ( "quit", cmdQuit )
]
commandCompletion :: CompletionFunc IO
@@ -575,7 +652,7 @@ cmdPeers :: Command
cmdPeers = do
peers <- join $ asks ciPeers
set <- asks ciSetContextOptions
- set $ map (SelectedPeer . fst) peers
+ set WatchPeers $ map (SelectedPeer . fst) peers
forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do
cmdPutStrLn $ "[" ++ show i ++ "] " ++ name
@@ -587,11 +664,15 @@ cmdPeerAdd = void $ do
[hostname] -> return (hostname, show discoveryPort)
[] -> throwOtherError "missing peer address"
addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
+ contextOptsVar <- asks ciContextOptionsVar
+ liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers)
liftIO $ serverPeer server (addrAddress addr)
cmdPeerAddPublic :: Command
cmdPeerAddPublic = do
server <- asks ciServer
+ contextOptsVar <- asks ciContextOptionsVar
+ liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers)
liftIO $ mapM_ (serverPeer server . addrAddress) =<< gather 'a'
where
gather c
@@ -625,8 +706,7 @@ cmdJoin = joinChatroom =<< getSelectedChatroom
cmdJoinAs :: Command
cmdJoinAs = do
name <- asks ciLine
- st <- getStorage
- identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing
+ identity <- createIdentity (Just $ T.pack name) Nothing
joinChatroomAs identity =<< getSelectedChatroom
cmdLeave :: Command
@@ -638,38 +718,45 @@ cmdMembers = do
forM_ (chatroomMembers room) $ \x -> do
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 -> throwOtherError "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 ()
+ handleError (\_ -> return ()) $ do
+ conv <- getConversationFromContext ctx
+ tzone <- liftIO $ getCurrentTimeZone
+ mapM_ (cmdPutStrLn . formatMessage tzone) $ takeWhile messageUnread $ conversationHistory conv
cmdSend :: Command
cmdSend = void $ do
text <- asks ciLine
conv <- getSelectedConversation
- sendMessage conv (T.pack text) >>= \case
- Just msg -> do
- tzone <- liftIO $ getCurrentTimeZone
- cmdPutStrLn $ formatMessage tzone msg
- Nothing -> return ()
+ sendMessage conv (T.pack text)
cmdDelete :: Command
cmdDelete = void $ do
- deleteConversation =<< getSelectedConversation
+ 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
@@ -677,6 +764,24 @@ cmdHistory = void $ do
[] -> do
cmdPutStrLn $ "<empty history>"
+showIdentityDetails :: Foldable f => Identity f -> Text
+showIdentityDetails identity = T.unlines $ go $ reverse $ unfoldOwners identity
+ where
+ go (i : is) = concat
+ [ maybeToList $ ("Name: " <>) <$> idName i
+ , map (("Ref: " <>) . T.pack . show . refDigest . storedRef) $ idDataF i
+ , map (("ExtRef: " <>) . T.pack . show . refDigest . storedRef) $ filter isExtension $ idExtDataF i
+ , do guard $ not (null is)
+ "" : "Device:" : map (" " <>) (go is)
+ ]
+ go [] = []
+ isExtension x = case fromSigned x of BaseIdentityData {} -> False
+ _ -> True
+
+cmdIdentity :: Command
+cmdIdentity = do
+ cmdPutStrLn . T.unpack . showIdentityDetails . localIdentity . fromStored =<< getLocalHead
+
cmdUpdateIdentity :: Command
cmdUpdateIdentity = void $ do
term <- asks ciTerminal
@@ -691,8 +796,11 @@ cmdAttachAccept = attachAccept =<< getSelectedPeer
cmdAttachReject :: Command
cmdAttachReject = attachReject =<< getSelectedPeer
-watchChatroomsForCli :: (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) -> MVar [ CommandContext ] -> Maybe Int -> IO WatchedHead
-watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do
+watchChatroomsForCli
+ :: Bool -> (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState)
+ -> MVar CommandContext -> MVar ( Maybe ContextWatchOptions, [ CommandContext ] )
+ -> Maybe Int -> IO WatchedHead
+watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe = do
subscribedNumVar <- newEmptyMVar
let ctxUpdate updateType (idx :: Int) rstate = \case
@@ -731,28 +839,44 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do
Just diff -> do
modifyMVar_ chatroomSetVar $ return . const set
+ modifyMVar_ contextOptsVar $ \case
+ ( watch, clist )
+ | watch == Just WatchChatrooms || not tui
+ -> do
+ let upd c = \case
+ AddedChatroom rstate -> ctxUpdate "NEW" 1 rstate c
+ RemovedChatroom rstate -> ctxUpdate "DEL" 1 rstate c
+ UpdatedChatroom _ rstate
+ | any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)
+ -> do
+ ctxUpdate "UPD" 1 rstate c
+ | otherwise -> return c
+ ( watch, ) <$> foldM upd clist diff
+ cur -> return cur
+
forM_ diff $ \case
AddedChatroom rstate -> do
- modifyMVar_ contextVar $ ctxUpdate "NEW" 1 rstate
modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then (+ 1) else id
RemovedChatroom rstate -> do
- modifyMVar_ contextVar $ ctxUpdate "DEL" 1 rstate
modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then subtract 1 else id
UpdatedChatroom oldroom rstate -> do
- when (any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)) $ do
- modifyMVar_ contextVar $ ctxUpdate "UPD" 1 rstate
when (any (not . null . rsdMessages . fromStored) (roomStateData rstate)) $ do
- tzone <- getCurrentTimeZone
- forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do
- eprint $ concat $
- [ maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg
- , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg
- , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg
- , if cmsgLeave msg then " left" else ""
- , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg
- ]
+ withMVar contextVar $ \ctx -> do
+ isSelected <- case ctx of
+ SelectedChatroom rstate' -> return $ isSameChatroom rstate' rstate
+ SelectedConversation conv -> return $ isChatroomStateConversation rstate conv
+ _ -> return False
+ when (not tui || isSelected) $ do
+ tzone <- getCurrentTimeZone
+ forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do
+ eprint $ concat $
+ [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg
+ , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg
+ , if cmsgLeave msg then " left" else ""
+ , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg
+ ]
modifyMVar_ subscribedNumVar $ return
. (if roomStateSubscribe rstate then (+ 1) else id)
. (if roomStateSubscribe oldroom then subtract 1 else id)
@@ -764,9 +888,11 @@ ensureWatchedChatrooms = do
eprint <- asks ciPrint
h <- gets csHead
chatroomSetVar <- asks ciChatroomSetVar
- contextVar <- asks ciContextOptionsVar
+ contextVar <- asks ciContextVar
+ contextOptsVar <- asks ciContextOptionsVar
autoSubscribe <- asks $ optChatroomAutoSubscribe . ciOptions
- watched <- liftIO $ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe
+ tui <- asks $ hasTerminalUI . ciTerminal
+ watched <- liftIO $ watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe
modify $ \s -> s { csWatchChatrooms = Just watched }
Just _ -> return ()
@@ -776,7 +902,7 @@ cmdChatrooms = do
chatroomSetVar <- asks ciChatroomSetVar
chatroomList <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar)
set <- asks ciSetContextOptions
- set $ map SelectedChatroom chatroomList
+ set WatchChatrooms $ map SelectedChatroom chatroomList
forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do
cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate)
@@ -790,6 +916,8 @@ cmdChatroomCreatePublic = do
getInputLine term $ KeepPrompt . maybe T.empty T.pack
ensureWatchedChatrooms
+ contextOptsVar <- asks ciContextOptionsVar
+ liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchChatrooms)
void $ createChatroom
(if T.null name then Nothing else Just name)
Nothing
@@ -802,7 +930,7 @@ cmdContacts = do
let contacts = fromSetBy (comparing contactName) $ lookupSharedValue $ lsShared $ headObject ehead
verbose = "-v" `elem` args
set <- asks ciSetContextOptions
- set $ map SelectedContact contacts
+ set WatchContacts $ map SelectedContact contacts
forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do
cmdPutStrLn $ T.unpack $ T.concat
[ "[", T.pack (show i), "] ", contactName c
@@ -828,19 +956,36 @@ cmdConversations :: Command
cmdConversations = do
conversations <- lookupConversations
set <- asks ciSetContextOptions
- set $ map SelectedConversation conversations
+ set WatchConversations $ map SelectedConversation conversations
forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do
cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)
+cmdNew :: Command
+cmdNew = do
+ conversations <- mapMaybe checkNew <$> lookupConversations
+ set <- asks ciSetContextOptions
+ set WatchConversations $ map (SelectedConversation . fst) conversations
+ tzone <- liftIO $ getCurrentTimeZone
+ forM_ (zip [1..] conversations) $ \(i :: Int, ( conv, msg )) -> do
+ cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) ++ " " ++ formatMessage tzone msg
+ where
+ checkNew conv
+ | (msg : _) <- conversationHistory conv
+ , messageUnread msg
+ = Just ( conv, msg )
+ checkNew _ = Nothing
+
+
cmdDetails :: Command
cmdDetails = do
- gets csContext >>= \case
+ getSelectedOrManualContext >>= \case
SelectedPeer peer -> do
+ paddr <- getPeerAddress peer
cmdPutStrLn $ unlines
[ "Network peer:"
- , " " <> show (peerAddress peer)
+ , " " <> show paddr
]
- peerIdentity peer >>= \case
+ getPeerIdentity peer >>= \case
PeerIdentityUnknown _ -> do
cmdPutStrLn $ "unknown identity"
PeerIdentityRef wref _ -> do
@@ -895,106 +1040,13 @@ cmdDetails = do
, map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid
]
-cmdDiscoveryInit :: Command
-cmdDiscoveryInit = void $ do
- server <- asks ciServer
-
- (hostname, port) <- (words <$> asks ciLine) >>= return . \case
- hostname:p:_ -> (hostname, p)
- [hostname] -> (hostname, show discoveryPort)
- [] -> ("discovery.erebosprotocol.net", show discoveryPort)
- addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
- peer <- liftIO $ serverPeer server (addrAddress addr)
- sendToPeer peer $ DiscoverySelf [ T.pack "ICE" ] Nothing
- modify $ \s -> s { csIcePeer = Just peer }
-
cmdDiscovery :: Command
cmdDiscovery = void $ do
- 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
- let getRole = \case
- 'm':_ -> PjIceSessRoleControlling
- 's':_ -> PjIceSessRoleControlled
- _ -> PjIceSessRoleUnknown
-
- ( role, stun, turn ) <- asks (words . ciLine) >>= \case
- [] -> return ( PjIceSessRoleControlling, Nothing, Nothing )
- [ role ] -> return
- ( getRole role, Nothing, Nothing )
- [ role, server ] -> return
- ( getRole role
- , Just ( T.pack server, 0 )
- , Just ( T.pack server, 0 )
- )
- [ role, server, port ] -> return
- ( getRole role
- , Just ( T.pack server, read port )
- , Just ( T.pack server, read port )
- )
- [ role, stunServer, stunPort, turnServer, turnPort ] -> return
- ( getRole role
- , Just ( T.pack stunServer, read stunPort )
- , Just ( T.pack turnServer, read turnPort )
- )
- _ -> throwOtherError "invalid parameters"
-
- eprint <- asks ciPrint
- Just cfg <- liftIO $ iceCreateConfig stun turn
- sess <- liftIO $ iceCreateSession cfg role $ eprint <=< iceShow
- modify $ \s -> s { csIceSessions = sess : csIceSessions s }
-
-cmdIceDestroy :: Command
-cmdIceDestroy = do
- s:ss <- gets csIceSessions
- modify $ \st -> st { csIceSessions = ss }
- liftIO $ iceDestroy s
-
-cmdIceShow :: Command
-cmdIceShow = do
- sess <- gets csIceSessions
- eprint <- asks ciPrint
- liftIO $ forM_ (zip [1::Int ..] sess) $ \(i, s) -> do
- eprint $ "[" ++ show i ++ "]"
- eprint =<< iceShow s
-
-cmdIceConnect :: Command
-cmdIceConnect = do
- s:_ <- gets csIceSessions
server <- asks ciServer
- term <- asks ciTerminal
- let loadInfo =
- getInputLine term (KeepPrompt . maybe BC.empty BC.pack) >>= \case
- line | BC.null line -> return []
- | otherwise -> (line :) <$> loadInfo
- Right remote <- liftIO $ do
- st <- memoryStorage
- pst <- derivePartialStorage st
- setPrompt term ""
- rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo
- copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes)
- liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s
-
-cmdIceSend :: Command
-cmdIceSend = void $ do
- s:_ <- gets csIceSessions
- server <- asks ciServer
- liftIO $ serverPeerIce server s
-
-#endif
+ 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
index 150178e..5d66ba9 100644
--- a/main/State.hs
+++ b/main/State.hs
@@ -1,15 +1,17 @@
module State (
loadLocalStateHead,
+ createLocalStateHead,
updateSharedIdentity,
interactiveIdentityUpdate,
) where
+import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Data.Foldable
-import Data.Maybe
import Data.Proxy
+import Data.Text (Text)
import Data.Text qualified as T
import Erebos.Error
@@ -22,34 +24,67 @@ import Erebos.Storage
import Terminal
-loadLocalStateHead :: MonadIO m => Terminal -> Storage -> m (Head LocalState)
-loadLocalStateHead term st = loadHeads st >>= \case
- (h:_) -> return h
- [] -> liftIO $ do
- setPrompt term "Name: "
- name <- getInputLine term $ KeepPrompt . maybe T.empty T.pack
+loadLocalStateHead
+ :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m)
+ => Terminal -> m (Head LocalState)
+loadLocalStateHead term = getStorage >>= loadHeads >>= \case
+ (h : _) -> return h
+ [] -> do
+ name <- liftIO $ do
+ setPrompt term "Name: "
+ getInputLine term $ KeepPrompt . maybe T.empty T.pack
- setPrompt term "Device: "
- devName <- getInputLine term $ KeepPrompt . maybe T.empty T.pack
+ devName <- liftIO $ do
+ setPrompt term "Device: "
+ getInputLine term $ KeepPrompt . maybe T.empty T.pack
- owner <- if
- | T.null name -> return Nothing
- | otherwise -> Just <$> createIdentity st (Just name) Nothing
+ ( owner, shared ) <- if
+ | T.null name -> do
+ return ( Nothing, [] )
+ | otherwise -> do
+ owner <- createIdentity (Just name) Nothing
+ shared <- mstore SharedState
+ { ssPrev = []
+ , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
+ , ssValue = [ storedRef $ idExtData owner ]
+ }
+ return ( Just owner, [ shared ] )
- identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner
+ identity <- createIdentity (if T.null devName then Nothing else Just devName) owner
- shared <- wrappedStore st $ SharedState
- { ssPrev = []
- , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
- , ssValue = [ storedRef $ idExtData $ fromMaybe identity owner ]
- }
+ st <- getStorage
storeHead st $ LocalState
{ lsPrev = Nothing
, lsIdentity = idExtData identity
- , lsShared = [ shared ]
+ , lsShared = shared
, lsOther = []
}
+createLocalStateHead
+ :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m)
+ => [ Maybe Text ] -> m (Head LocalState)
+createLocalStateHead [] = throwOtherError "createLocalStateHead: empty name list"
+createLocalStateHead ( ownerName : names ) = do
+ owner <- createIdentity ownerName Nothing
+ identity <- foldM createSingleIdentity owner names
+ shared <- case names of
+ [] -> return []
+ _ : _ -> do
+ fmap (: []) $ mstore SharedState
+ { ssPrev = []
+ , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
+ , ssValue = [ storedRef $ idExtData owner ]
+ }
+ st <- getStorage
+ storeHead st $ LocalState
+ { lsPrev = Nothing
+ , lsIdentity = idExtData identity
+ , lsShared = shared
+ , lsOther = []
+ }
+ where
+ createSingleIdentity owner name = createIdentity name (Just owner)
+
updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m ()
updateSharedIdentity term = updateLocalState_ $ updateSharedState_ $ \case
diff --git a/main/Terminal.hs b/main/Terminal.hs
index 150bd8c..b8b953f 100644
--- a/main/Terminal.hs
+++ b/main/Terminal.hs
@@ -44,14 +44,20 @@ data Terminal = Terminal
, termShowPrompt :: TVar Bool
, termInput :: TVar ( String, String )
, termBottomLines :: TVar [ String ]
+ , termHistory :: TVar [ String ]
+ , termHistoryPos :: TVar Int
+ , termHistoryStash :: TVar ( String, String )
}
data TerminalLine = TerminalLine
{ tlTerminal :: Terminal
+ , tlLineCount :: Int
}
data Input
= InputChar Char
+ | InputMoveUp
+ | InputMoveDown
| InputMoveRight
| InputMoveLeft
| InputMoveEnd
@@ -84,6 +90,9 @@ initTerminal termCompletionFunc = do
termShowPrompt <- newTVarIO False
termInput <- newTVarIO ( "", "" )
termBottomLines <- newTVarIO []
+ termHistory <- newTVarIO []
+ termHistoryPos <- newTVarIO 0
+ termHistoryStash <- newTVarIO ( "", "" )
return Terminal {..}
bracketSet :: IO a -> (a -> IO b) -> a -> IO c -> IO c
@@ -112,6 +121,8 @@ getInput = do
'\ESC' -> do
esc <- readEsc
case parseEsc esc of
+ Just ( 'A' , [] ) -> return InputMoveUp
+ Just ( 'B' , [] ) -> return InputMoveDown
Just ( 'C' , [] ) -> return InputMoveRight
Just ( 'D' , [] ) -> return InputMoveLeft
_ -> return (InputEscape esc)
@@ -119,6 +130,8 @@ getInput = do
'\DEL' -> return InputBackspace
'\NAK' -> return InputClear
'\ETB' -> return InputBackWord
+ '\DLE' -> return InputMoveUp
+ '\SO' -> return InputMoveDown
'\SOH' -> return InputMoveStart
'\ENQ' -> return InputMoveEnd
'\EOT' -> return InputEnd
@@ -136,19 +149,33 @@ getInput = do
getInputLine :: Terminal -> (Maybe String -> InputHandling a) -> IO a
getInputLine term@Terminal {..} handleResult = do
- withMVar termLock $ \_ -> do
- prompt <- atomically $ do
- writeTVar termShowPrompt True
- readTVar termPrompt
- putStr $ prompt <> "\ESC[K"
- drawBottomLines term
- hFlush stdout
- (handleResult <$> go) >>= \case
+ when termAnsi $ do
+ withMVar termLock $ \_ -> do
+ prompt <- atomically $ do
+ writeTVar termShowPrompt True
+ readTVar termPrompt
+ putStr $ prompt <> "\ESC[K"
+ drawBottomLines term
+ hFlush stdout
+
+ mbLine <- go
+ forM_ mbLine $ \line -> do
+ let addLine xs
+ | null line = xs
+ | (x : _) <- xs, x == line = xs
+ | otherwise = line : xs
+ atomically $ do
+ writeTVar termHistory . addLine =<< readTVar termHistory
+ writeTVar termHistoryPos 0
+
+ case handleResult mbLine of
KeepPrompt x -> do
- termPutStr term "\n\ESC[J"
+ when termAnsi $ do
+ termPutStr term "\n\ESC[J"
return x
ErasePrompt x -> do
- termPutStr term "\r\ESC[J"
+ when termAnsi $ do
+ termPutStr term "\r\ESC[J"
return x
where
go = getInput >>= \case
@@ -156,11 +183,12 @@ getInputLine term@Terminal {..} handleResult = do
atomically $ do
( pre, post ) <- readTVar termInput
writeTVar termInput ( "", "" )
- writeTVar termShowPrompt False
- writeTVar termBottomLines []
+ when termAnsi $ do
+ writeTVar termShowPrompt False
+ writeTVar termBottomLines []
return $ Just $ pre ++ post
- InputChar '\t' -> do
+ InputChar '\t' | termAnsi -> do
options <- withMVar termLock $ const $ do
( pre, post ) <- atomically $ readTVar termInput
let updatePrompt pre' = do
@@ -179,9 +207,11 @@ getInputLine term@Terminal {..} handleResult = do
( unused, completions@(c : cs) ) -> do
let commonPrefixes' x y = fmap (\( common, _, _ ) -> common) $ T.commonPrefixes x y
case foldl' (\mbcommon cur -> commonPrefixes' cur =<< mbcommon) (Just $ replacement c) (fmap replacement cs) of
- Just common -> updatePrompt $ T.unpack unused ++ T.unpack common
- Nothing -> return ()
- return $ map replacement completions
+ Just common | T.unpack common /= pre -> do
+ updatePrompt $ T.unpack unused ++ T.unpack common
+ return []
+ _ -> do
+ return $ map replacement completions
( _, [] ) -> do
return []
@@ -196,6 +226,37 @@ getInputLine term@Terminal {..} handleResult = do
InputChar _ -> go
+ InputMoveUp -> withInput $ \prepost -> do
+ hist <- readTVar termHistory
+ pos <- readTVar termHistoryPos
+ case drop pos hist of
+ ( h : _ ) -> do
+ when (pos == 0) $ do
+ writeTVar termHistoryStash prepost
+ writeTVar termHistoryPos (pos + 1)
+ writeTVar termInput ( h, "" )
+ ("\r\ESC[K" <>) <$> getCurrentPromptLine term
+ [] -> do
+ return ""
+
+ InputMoveDown -> withInput $ \_ -> do
+ readTVar termHistoryPos >>= \case
+ 0 -> do
+ return ""
+ 1 -> do
+ writeTVar termHistoryPos 0
+ writeTVar termInput =<< readTVar termHistoryStash
+ ("\r\ESC[K" <>) <$> getCurrentPromptLine term
+ pos -> do
+ writeTVar termHistoryPos (pos - 1)
+ hist <- readTVar termHistory
+ case drop (pos - 2) hist of
+ ( h : _ ) -> do
+ writeTVar termInput ( h, "" )
+ ("\r\ESC[K" <>) <$> getCurrentPromptLine term
+ [] -> do
+ return ""
+
InputMoveRight -> withInput $ \case
( pre, c : post ) -> do
writeTVar termInput ( pre ++ [ c ], post )
@@ -241,7 +302,7 @@ getInputLine term@Terminal {..} handleResult = do
withInput f = do
withMVar termLock $ const $ do
str <- atomically $ f =<< readTVar termInput
- when (not $ null str) $ do
+ when (termAnsi && not (null str)) $ do
putStr str
hFlush stdout
go
@@ -254,6 +315,8 @@ getCurrentPromptLine Terminal {..} = do
return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u"
setPrompt :: Terminal -> String -> IO ()
+setPrompt Terminal { termAnsi = False } _ = do
+ return ()
setPrompt term@Terminal {..} prompt = do
withMVar termLock $ \_ -> do
join $ atomically $ do
@@ -269,17 +332,26 @@ setPrompt term@Terminal {..} prompt = do
printLine :: Terminal -> String -> IO TerminalLine
printLine tlTerminal@Terminal {..} str = do
withMVar termLock $ \_ -> do
- promptLine <- atomically $ do
- readTVar termShowPrompt >>= \case
- True -> getCurrentPromptLine tlTerminal
- False -> return ""
- putStr $ "\r\ESC[K" <> str <> "\n\ESC[K" <> promptLine
- drawBottomLines tlTerminal
+ let strLines = lines str
+ tlLineCount = length strLines
+ if termAnsi
+ then do
+ promptLine <- atomically $ do
+ readTVar termShowPrompt >>= \case
+ True -> getCurrentPromptLine tlTerminal
+ False -> return ""
+ putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine
+ drawBottomLines tlTerminal
+ else do
+ putStr $ unlines strLines
+
hFlush stdout
return TerminalLine {..}
printBottomLines :: Terminal -> String -> IO ()
+printBottomLines Terminal { termAnsi = False } _ = do
+ return ()
printBottomLines term@Terminal {..} str = do
case lines str of
[] -> clearBottomLines term
@@ -290,6 +362,8 @@ printBottomLines term@Terminal {..} str = do
hFlush stdout
clearBottomLines :: Terminal -> IO ()
+clearBottomLines Terminal { termAnsi = False } = do
+ return ()
clearBottomLines Terminal {..} = do
withMVar termLock $ \_ -> do
atomically (readTVar termBottomLines) >>= \case
diff --git a/main/Test.hs b/main/Test.hs
index f2adf22..da49257 100644
--- a/main/Test.hs
+++ b/main/Test.hs
@@ -15,10 +15,12 @@ import Control.Monad.State
import Crypto.Random
import Data.Bool
+import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Lazy.Char8 qualified as BL
+import Data.Char
import Data.Foldable
import Data.Ord
import Data.Text (Text)
@@ -39,11 +41,13 @@ import Erebos.Contact
import Erebos.DirectMessage
import Erebos.Discovery
import Erebos.Identity
+import Erebos.Invite
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
@@ -66,10 +70,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
@@ -109,9 +120,9 @@ runTestTool st = do
getLineMb :: MonadIO m => m (Maybe Text)
getLineMb = liftIO $ catchIOError (Just <$> T.getLine) (\e -> if isEOFError e then return Nothing else ioError e)
-getLines :: MonadIO m => m [Text]
-getLines = getLineMb >>= \case
- Just line | not (T.null line) -> (line:) <$> getLines
+getLines :: MonadIO m => Text -> m [ Text ]
+getLines eof = getLineMb >>= \case
+ Just line | line /= eof -> (line :) <$> getLines eof
_ -> return []
getHead :: CommandM (Head LocalState)
@@ -120,6 +131,26 @@ getHead = do
modify $ \s -> s { tsHead = Just h }
return h
+showHex :: ByteString -> ByteString
+showHex = B.concat . map showHexByte . B.unpack
+ where showHexChar x | x < 10 = x + o '0'
+ | otherwise = x + o 'a' - 10
+ showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ]
+ o = fromIntegral . ord
+
+readHex :: ByteString -> Maybe ByteString
+readHex = return . B.concat <=< readHex'
+ where readHex' bs | B.null bs = Just []
+ readHex' bs = do (bx, bs') <- B.uncons bs
+ (by, bs'') <- B.uncons bs'
+ x <- hexDigit bx
+ y <- hexDigit by
+ (B.singleton (x * 16 + y) :) <$> readHex' bs''
+ hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0'
+ | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10
+ | otherwise = Nothing
+ o = fromIntegral . ord
+
type Output = MVar ()
@@ -137,17 +168,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 ()
@@ -216,14 +250,33 @@ directMessageAttributes out = DirectMessageAttributes
{ dmOwnerMismatch = afterCommit $ outLine out "dm-owner-mismatch"
}
-dmReceivedWatcher :: Output -> Stored DirectMessage -> IO ()
-dmReceivedWatcher out smsg = do
- let msg = fromStored smsg
- outLine out $ unwords
- [ "dm-received"
- , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
- , "text", T.unpack $ msgText msg
- ]
+discoveryAttributes :: DiscoveryAttributes
+discoveryAttributes = (defaultServiceAttributes Proxy)
+ { discoveryProvideTunnel = \_ _ -> False
+ }
+
+inviteAttributes :: Output -> InviteServiceAttributes
+inviteAttributes out = (defaultServiceAttributes Proxy)
+ { inviteHookAccepted = \token -> do
+ pid <- asks svcPeerIdentity
+ afterCommit $ outLine out $ "invite-accepted " <> BC.unpack (showHex token) <> " " <> (BC.unpack $ showRef $ storedRef $ idExtData pid)
+ , inviteHookReplyContact = \token _ -> do
+ afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " contact"
+ , inviteHookReplyInvalid = \token -> do
+ afterCommit $ outLine out $ "invite-accept-done " <> BC.unpack (showHex token) <> " invalid"
+ }
+
+dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO ()
+dmThreadWatcher self out prev cur = do
+ forM_ (reverse $ dmThreadToListSinceUnread prev cur) $ \( msg, new ) -> do
+ outLine out $ unwords
+ [ if sameIdentity self (msgFrom msg)
+ then "dm-sent"
+ else "dm-received"
+ , "from", maybe "<unnamed>" T.unpack $ idName $ msgFrom msg
+ , "new", if new then "yes" else "no"
+ , "text", T.unpack $ msgText msg
+ ]
newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a)
@@ -247,60 +300,72 @@ instance MonadHead LocalState CommandM where
type Command = CommandM ()
-commands :: [(Text, Command)]
-commands = map (T.pack *** id)
- [ ("store", cmdStore)
- , ("load", cmdLoad)
- , ("stored-generation", cmdStoredGeneration)
- , ("stored-roots", cmdStoredRoots)
- , ("stored-set-add", cmdStoredSetAdd)
- , ("stored-set-list", cmdStoredSetList)
- , ("head-create", cmdHeadCreate)
- , ("head-replace", cmdHeadReplace)
- , ("head-watch", cmdHeadWatch)
- , ("head-unwatch", cmdHeadUnwatch)
- , ("create-identity", cmdCreateIdentity)
- , ("identity-info", cmdIdentityInfo)
- , ("start-server", cmdStartServer)
- , ("stop-server", cmdStopServer)
- , ("peer-add", cmdPeerAdd)
- , ("peer-drop", cmdPeerDrop)
- , ("peer-list", cmdPeerList)
- , ("test-message-send", cmdTestMessageSend)
- , ("local-state-get", cmdLocalStateGet)
- , ("local-state-replace", cmdLocalStateReplace)
- , ("local-state-wait", cmdLocalStateWait)
- , ("shared-state-get", cmdSharedStateGet)
- , ("shared-state-wait", cmdSharedStateWait)
- , ("watch-local-identity", cmdWatchLocalIdentity)
- , ("watch-shared-identity", cmdWatchSharedIdentity)
- , ("update-local-identity", cmdUpdateLocalIdentity)
- , ("update-shared-identity", cmdUpdateSharedIdentity)
- , ("attach-to", cmdAttachTo)
- , ("attach-accept", cmdAttachAccept)
- , ("attach-reject", cmdAttachReject)
- , ("contact-request", cmdContactRequest)
- , ("contact-accept", cmdContactAccept)
- , ("contact-reject", cmdContactReject)
- , ("contact-list", cmdContactList)
- , ("contact-set-name", cmdContactSetName)
- , ("dm-send-peer", cmdDmSendPeer)
- , ("dm-send-contact", cmdDmSendContact)
- , ("dm-list-peer", cmdDmListPeer)
- , ("dm-list-contact", cmdDmListContact)
- , ("chatroom-create", cmdChatroomCreate)
- , ("chatroom-delete", cmdChatroomDelete)
- , ("chatroom-list-local", cmdChatroomListLocal)
- , ("chatroom-watch-local", cmdChatroomWatchLocal)
- , ("chatroom-set-name", cmdChatroomSetName)
- , ("chatroom-subscribe", cmdChatroomSubscribe)
- , ("chatroom-unsubscribe", cmdChatroomUnsubscribe)
- , ("chatroom-members", cmdChatroomMembers)
- , ("chatroom-join", cmdChatroomJoin)
- , ("chatroom-join-as", cmdChatroomJoinAs)
- , ("chatroom-leave", cmdChatroomLeave)
- , ("chatroom-message-send", cmdChatroomMessageSend)
- , ("discovery-connect", cmdDiscoveryConnect)
+commands :: [ ( Text, Command ) ]
+commands =
+ [ ( "store", cmdStore )
+ , ( "store-raw", cmdStoreRaw )
+ , ( "load", cmdLoad )
+ , ( "load-type", cmdLoadType )
+ , ( "stored-generation", cmdStoredGeneration )
+ , ( "stored-roots", cmdStoredRoots )
+ , ( "stored-set-add", cmdStoredSetAdd )
+ , ( "stored-set-list", cmdStoredSetList )
+ , ( "stored-difference", cmdStoredDifference )
+ , ( "head-create", cmdHeadCreate )
+ , ( "head-replace", cmdHeadReplace )
+ , ( "head-watch", cmdHeadWatch )
+ , ( "head-unwatch", cmdHeadUnwatch )
+ , ( "create-identity", cmdCreateIdentity )
+ , ( "identity-info", cmdIdentityInfo )
+ , ( "start-server", cmdStartServer )
+ , ( "stop-server", cmdStopServer )
+ , ( "peer-add", cmdPeerAdd )
+ , ( "peer-drop", cmdPeerDrop )
+ , ( "peer-list", cmdPeerList )
+ , ( "test-message-send", cmdTestMessageSend )
+ , ( "test-stream-open", cmdTestStreamOpen )
+ , ( "test-stream-close", cmdTestStreamClose )
+ , ( "test-stream-send", cmdTestStreamSend )
+ , ( "local-state-get", cmdLocalStateGet )
+ , ( "local-state-replace", cmdLocalStateReplace )
+ , ( "local-state-wait", cmdLocalStateWait )
+ , ( "shared-state-get", cmdSharedStateGet )
+ , ( "shared-state-wait", cmdSharedStateWait )
+ , ( "watch-local-identity", cmdWatchLocalIdentity )
+ , ( "watch-shared-identity", cmdWatchSharedIdentity )
+ , ( "update-local-identity", cmdUpdateLocalIdentity )
+ , ( "update-shared-identity", cmdUpdateSharedIdentity )
+ , ( "attach-to", cmdAttachTo )
+ , ( "attach-accept", cmdAttachAccept )
+ , ( "attach-reject", cmdAttachReject )
+ , ( "contact-request", cmdContactRequest )
+ , ( "contact-accept", cmdContactAccept )
+ , ( "contact-reject", cmdContactReject )
+ , ( "contact-list", cmdContactList )
+ , ( "contact-set-name", cmdContactSetName )
+ , ( "dm-send-peer", cmdDmSendPeer )
+ , ( "dm-send-contact", cmdDmSendContact )
+ , ( "dm-send-identity", cmdDmSendIdentity )
+ , ( "dm-list-peer", cmdDmListPeer )
+ , ( "dm-list-contact", cmdDmListContact )
+ , ( "dm-list-identity", cmdDmListIdentity )
+ , ( "dm-mark-seen", cmdDmMarkSeen )
+ , ( "chatroom-create", cmdChatroomCreate )
+ , ( "chatroom-delete", cmdChatroomDelete )
+ , ( "chatroom-list-local", cmdChatroomListLocal )
+ , ( "chatroom-watch-local", cmdChatroomWatchLocal )
+ , ( "chatroom-set-name", cmdChatroomSetName )
+ , ( "chatroom-subscribe", cmdChatroomSubscribe )
+ , ( "chatroom-unsubscribe", cmdChatroomUnsubscribe )
+ , ( "chatroom-members", cmdChatroomMembers )
+ , ( "chatroom-join", cmdChatroomJoin )
+ , ( "chatroom-join-as", cmdChatroomJoinAs )
+ , ( "chatroom-leave", cmdChatroomLeave )
+ , ( "chatroom-message-send", cmdChatroomMessageSend )
+ , ( "discovery-connect", cmdDiscoveryConnect )
+ , ( "discovery-tunnel", cmdDiscoveryTunnel )
+ , ( "invite-contact-create", cmdInviteContactCreate )
+ , ( "invite-accept", cmdInviteAccept )
]
cmdStore :: Command
@@ -308,7 +373,7 @@ cmdStore = do
st <- asks tiStorage
pst <- liftIO $ derivePartialStorage st
[otype] <- asks tiParams
- ls <- getLines
+ ls <- getLines T.empty
let cnt = encodeUtf8 $ T.unlines ls
full = BL.fromChunks
@@ -321,6 +386,18 @@ cmdStore = do
Right ref -> cmdOut $ "store-done " ++ show (refDigest ref)
Left _ -> cmdOut $ "store-failed"
+cmdStoreRaw :: Command
+cmdStoreRaw = do
+ st <- asks tiStorage
+ pst <- liftIO $ derivePartialStorage st
+ [ eof ] <- asks tiParams
+ ls <- getLines eof
+
+ let full = BL.fromStrict $ BC.init $ encodeUtf8 $ T.unlines ls
+ liftIO (copyRef st =<< storeRawBytes pst full) >>= \case
+ Right ref -> cmdOut $ "store-done " ++ show (refDigest ref)
+ Left _ -> cmdOut $ "store-failed"
+
cmdLoad :: Command
cmdLoad = do
st <- asks tiStorage
@@ -333,6 +410,20 @@ cmdLoad = do
cmdOut $ "load-line " <> T.unpack (decodeUtf8 $ BL.toStrict line)
cmdOut "load-done"
+cmdLoadType :: Command
+cmdLoadType = do
+ st <- asks tiStorage
+ [ tref ] <- asks tiParams
+ Just ref <- liftIO $ readRef st $ encodeUtf8 tref
+ let obj = load @Object ref
+ let otype = case obj of
+ Blob {} -> "blob"
+ Rec {} -> "rec"
+ OnDemand {} -> "ondemand"
+ ZeroObject {} -> "zero"
+ UnknownObject utype _ -> "unknown " <> decodeUtf8 utype
+ cmdOut $ "load-type " <> T.unpack otype
+
cmdStoredGeneration :: Command
cmdStoredGeneration = do
st <- asks tiStorage
@@ -354,7 +445,7 @@ cmdStoredSetAdd = do
[Just iref, Just sref] -> return (wrappedLoad iref, loadSet @[Stored Object] sref)
[Just iref] -> return (wrappedLoad iref, emptySet)
_ -> fail "unexpected parameters"
- set' <- storeSetAdd st [item] set
+ set' <- storeSetAdd [ item ] set
cmdOut $ "stored-set-add" ++ concatMap ((' ':) . show . refDigest . storedRef) (toComponents set')
cmdStoredSetList :: Command
@@ -367,6 +458,19 @@ cmdStoredSetList = do
cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item
cmdOut $ "stored-set-done"
+cmdStoredDifference :: Command
+cmdStoredDifference = do
+ st <- asks tiStorage
+ ( trefs1, "|" : trefs2 ) <- span (/= "|") <$> asks tiParams
+
+ let loadObjs = mapM (maybe (fail "invalid ref") (return . wrappedLoad @Object) <=< liftIO . readRef st . encodeUtf8)
+ objs1 <- loadObjs trefs1
+ objs2 <- loadObjs trefs2
+
+ forM_ (storedDifference objs1 objs2) $ \item -> do
+ cmdOut $ "stored-difference-item " ++ (show $ refDigest $ storedRef item)
+ cmdOut $ "stored-difference-done"
+
cmdHeadCreate :: Command
cmdHeadCreate = do
[ ttid, tref ] <- asks tiParams
@@ -421,7 +525,8 @@ cmdHeadUnwatch = do
initTestHead :: Head LocalState -> Command
initTestHead h = do
- _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput
+ let self = finalOwner $ headLocalIdentity h
+ _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher self =<< asks tiOutput
modify $ \s -> s { tsHead = Just h }
loadTestHead :: CommandM (Head LocalState)
@@ -444,13 +549,13 @@ cmdCreateIdentity = do
st <- asks tiStorage
names <- asks tiParams
- h <- liftIO $ do
+ h <- do
Just identity <- if null names
- then Just <$> createIdentity st Nothing Nothing
- else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names
+ then Just <$> createIdentity Nothing Nothing
+ else foldrM (\n o -> Just <$> createIdentity (Just n) o) Nothing names
shared <- case names of
- _:_:_ -> (:[]) <$> makeSharedStateUpdate st (Just $ finalOwner identity) []
+ _:_:_ -> (: []) <$> makeSharedStateUpdate (Just $ finalOwner identity) []
_ -> return []
storeHead st $ LocalState
@@ -483,42 +588,79 @@ cmdStartServer = do
let parseParams = \case
(name : value : rest)
- | name == "services" -> T.splitOn "," value
+ | name == "services" -> second ( map splitServiceParams (T.splitOn "," value) ++ ) (parseParams rest)
+ (name : rest)
+ | name == "test-log" -> first (\o -> o { serverTestLog = True }) (parseParams rest)
| otherwise -> parseParams rest
- _ -> []
- serviceNames <- parseParams <$> asks tiParams
+ _ -> ( defaultServerOptions { serverErrorPrefix = "server-error-message " }, [] )
+
+ splitServiceParams svc =
+ case T.splitOn ":" svc of
+ name : params -> ( name, params )
+ _ -> ( svc, [] )
+
+ ( serverOptions, serviceNames ) <- parseParams <$> asks tiParams
h <- getOrLoadHead
rsPeers <- liftIO $ newMVar (1, [])
services <- forM serviceNames $ \case
- "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
- "chatroom" -> return $ someService @ChatroomService Proxy
- "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
- "discovery" -> return $ someService @DiscoveryService Proxy
- "dm" -> return $ someServiceAttr $ directMessageAttributes out
- "sync" -> return $ someService @SyncService Proxy
- "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy)
+ ( "attach", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
+ ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy
+ ( "contact", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
+ ( "discovery", params ) -> return $ someServiceAttr $ discoveryAttributes
+ { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params
+ }
+ ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out
+ ( "invite", _ ) -> return $ someServiceAttr $ inviteAttributes out
+ ( "sync", _ ) -> return $ someService @SyncService Proxy
+ ( "test", _ ) -> return $ someServiceAttr $ (defaultServiceAttributes Proxy)
{ testMessageReceived = \obj otype len sref -> do
liftIO $ do
void $ store (headStorage h) obj
- 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 -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'"
+ ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'"
- rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services
+ let logPrint str = do BC.hPutStrLn stdout (BC.pack str)
+ hFlush stdout
+ rsServer <- liftIO $ startServer serverOptions h logPrint services
rsPeerThread <- liftIO $ forkIO $ void $ forever $ do
peer <- getNextPeerChange rsServer
- let printPeer (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
@@ -555,11 +697,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)
_ -> []
]
@@ -575,6 +718,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
@@ -738,7 +915,7 @@ cmdContactSetName = do
cmdDmSendPeer :: Command
cmdDmSendPeer = do
[spidx, msg] <- asks tiParams
- PeerIdentityFull to <- peerIdentity =<< getPeer spidx
+ PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx
void $ sendDirectMessage to msg
cmdDmSendContact :: Command
@@ -747,13 +924,22 @@ cmdDmSendContact = do
Just to <- contactIdentity <$> getContact cid
void $ sendDirectMessage to msg
+cmdDmSendIdentity :: Command
+cmdDmSendIdentity = do
+ st <- asks tiStorage
+ [ tid, msg ] <- asks tiParams
+ Just ref <- liftIO $ readRef st $ encodeUtf8 tid
+ Just to <- return $ validateExtendedIdentity $ wrappedLoad ref
+ void $ sendDirectMessage to msg
+
dmList :: Foldable f => Identity f -> Command
dmList peer = do
- threads <- toThreadList . lookupSharedValue . lsShared . headObject <$> getHead
+ threads <- dmThreadList . lookupSharedValue . lsShared . headObject <$> getHead
case find (sameIdentity peer . msgPeer) threads of
Just thread -> do
- forM_ (reverse $ threadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item"
+ forM_ (reverse $ dmThreadToListUnread thread) $ \( DirectMessage {..}, new ) -> cmdOut $ "dm-list-item"
<> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom)
+ <> " new " <> (if new then "yes" else "no")
<> " text " <> (T.unpack msgText)
Nothing -> return ()
cmdOut "dm-list-done"
@@ -761,7 +947,7 @@ dmList peer = do
cmdDmListPeer :: Command
cmdDmListPeer = do
[spidx] <- asks tiParams
- PeerIdentityFull to <- peerIdentity =<< getPeer spidx
+ PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx
dmList to
cmdDmListContact :: Command
@@ -770,6 +956,23 @@ cmdDmListContact = do
Just to <- contactIdentity <$> getContact cid
dmList to
+cmdDmListIdentity :: Command
+cmdDmListIdentity = do
+ st <- asks tiStorage
+ [ tid ] <- asks tiParams
+ Just ref <- liftIO $ readRef st $ encodeUtf8 tid
+ Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref
+ dmList pid
+
+cmdDmMarkSeen :: Command
+cmdDmMarkSeen = do
+ st <- asks tiStorage
+ [ tid ] <- asks tiParams
+ Just ref <- liftIO $ readRef st $ encodeUtf8 tid
+ Just pid <- return $ validateExtendedIdentity $ wrappedLoad ref
+ dmMarkAsSeen pid
+ cmdOut $ unwords [ "dm-mark-seen-done", T.unpack tid ]
+
cmdChatroomCreate :: Command
cmdChatroomCreate = do
[name] <- asks tiParams
@@ -869,8 +1072,7 @@ cmdChatroomJoin = do
cmdChatroomJoinAs :: Command
cmdChatroomJoinAs = do
[ cid, name ] <- asks tiParams
- st <- asks tiStorage
- identity <- liftIO $ createIdentity st (Just name) Nothing
+ identity <- createIdentity (Just name) Nothing
joinChatroomAsByStateData identity =<< getChatroomStateData cid
cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ]
@@ -888,11 +1090,28 @@ 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
+
+cmdInviteContactCreate :: Command
+cmdInviteContactCreate = do
+ [ name ] <- asks tiParams
+ Just token <- inviteToken <$> createSingleContactInvite name
+ cmdOut $ unwords [ "invite-contact-create-done", BC.unpack (showHex token) ]
+
+cmdInviteAccept :: Command
+cmdInviteAccept = do
+ [ tokenText, idref ] <- asks tiParams
+ Just token <- return $ readHex $ encodeUtf8 tokenText
+ Just from <- return $ readRefDigest $ encodeUtf8 idref
+ Just RunningServer {..} <- gets tsServer
+ acceptInvite rsServer from token
diff --git a/main/Test/Service.hs b/main/Test/Service.hs
index 8c58dee..c0be07d 100644
--- a/main/Test/Service.hs
+++ b/main/Test/Service.hs
@@ -1,8 +1,11 @@
module Test.Service (
TestMessage(..),
TestMessageAttributes(..),
+
+ openTestStreams,
) where
+import Control.Monad
import Control.Monad.Reader
import Data.ByteString.Lazy.Char8 qualified as BL
@@ -10,12 +13,14 @@ import Data.ByteString.Lazy.Char8 qualified as BL
import Erebos.Network
import Erebos.Object
import Erebos.Service
+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
@@ -26,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
@@ -36,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
index fbdd65f..7a957e2 100644
--- a/main/WebSocket.hs
+++ b/main/WebSocket.hs
@@ -1,4 +1,5 @@
module WebSocket (
+ WebSocketAddress(..),
startWebsocketServer,
) where
@@ -26,8 +27,10 @@ instance Show WebSocketAddress where
show (WebSocketAddress _ _) = "websocket"
instance PeerAddressType WebSocketAddress where
- sendBytesToAddress (WebSocketAddress _ conn) msg = do
- WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg
+ sendBytesToAddress (WebSocketAddress _ conn) msg = do
+ WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg
+ connectionToAddressClosed (WebSocketAddress _ conn) = do
+ WS.sendClose conn BL.empty
startWebsocketServer :: Server -> String -> Int -> (String -> IO ()) -> IO ()
startWebsocketServer server addr port logd = do
generated by cgit v1.2.3 (git 2.25.1) at 2025-12-16 17:00:43 +0000