summaryrefslogtreecommitdiff
path: root/main/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'main/Main.hs')
-rw-r--r--main/Main.hs573
1 files changed, 441 insertions, 132 deletions
diff --git a/main/Main.hs b/main/Main.hs
index 0eb414c..26f4b12 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -24,46 +24,60 @@ import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.IO qualified as T
+import Data.Time.Format
import Data.Time.LocalTime
import Data.Typeable
import Network.Socket
import System.Console.GetOpt
-import System.Console.Haskeline
+import System.Directory
import System.Environment
import System.Exit
import System.IO
import Erebos.Attach
import Erebos.Contact
+import Erebos.Chatroom
import Erebos.Conversation
-#ifdef ENABLE_ICE_SUPPORT
+import Erebos.DirectMessage
import Erebos.Discovery
+#ifdef ENABLE_ICE_SUPPORT
import Erebos.ICE
#endif
import Erebos.Identity
-import Erebos.Message hiding (formatMessage)
import Erebos.Network
+import Erebos.Object
import Erebos.PubKey
import Erebos.Service
import Erebos.Set
import Erebos.State
+import Erebos.Storable
import Erebos.Storage
import Erebos.Storage.Merge
import Erebos.Sync
+import State
+import Terminal
import Test
import Version
+import WebSocket
data Options = Options
{ optServer :: ServerOptions
, optServices :: [ServiceOption]
+ , optStorage :: StorageOption
+ , optChatroomAutoSubscribe :: Maybe Int
, optDmBotEcho :: Maybe Text
+ , optWebSocketServer :: Maybe Int
, optShowHelp :: Bool
, optShowVersion :: Bool
}
+data StorageOption = DefaultStorage
+ | FilesystemStorage FilePath
+ | MemoryStorage
+
data ServiceOption = ServiceOption
{ soptName :: String
, soptService :: SomeService
@@ -75,7 +89,10 @@ defaultOptions :: Options
defaultOptions = Options
{ optServer = defaultServerOptions
, optServices = availableServices
+ , optStorage = DefaultStorage
+ , optChatroomAutoSubscribe = Nothing
, optDmBotEcho = Nothing
+ , optWebSocketServer = Nothing
, optShowHelp = False
, optShowVersion = False
}
@@ -86,14 +103,14 @@ availableServices =
True "attach (to) other devices"
, ServiceOption "sync" (someService @SyncService Proxy)
True "synchronization with attached devices"
+ , ServiceOption "chatroom" (someService @ChatroomService Proxy)
+ True "chatrooms with multiple participants"
, ServiceOption "contact" (someService @ContactService Proxy)
True "create contacts with network peers"
, ServiceOption "dm" (someService @DirectMessage Proxy)
True "direct messages"
-#ifdef ENABLE_ICE_SUPPORT
, ServiceOption "discovery" (someService @DiscoveryService Proxy)
True "peer discovery"
-#endif
]
options :: [OptDescr (Options -> Options)]
@@ -104,9 +121,35 @@ options =
, Option ['s'] ["silent"]
(NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))
"do not send announce packets for local discovery"
+ , Option [] [ "storage" ]
+ (ReqArg (\path -> \opts -> opts { optStorage = FilesystemStorage path }) "<path>")
+ "use storage in <path>"
+ , Option [] [ "memory-storage" ]
+ (NoArg (\opts -> opts { optStorage = MemoryStorage }))
+ "use memory storage"
+ , Option [] ["chatroom-auto-subscribe"]
+ (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>")
+ "automatically subscribe for up to <count> chatrooms"
+#ifdef ENABLE_ICE_SUPPORT
+ , Option [] [ "discovery-stun-port" ]
+ (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunPort = Just (read value) }) "<port>")
+ "offer specified <port> to discovery peers for STUN protocol"
+ , Option [] [ "discovery-stun-server" ]
+ (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunServer = Just (read value) }) "<server>")
+ "offer <server> (domain name or IP address) to discovery peers for STUN protocol"
+ , Option [] [ "discovery-turn-port" ]
+ (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnPort = Just (read value) }) "<port>")
+ "offer specified <port> to discovery peers for TURN protocol"
+ , Option [] [ "discovery-turn-server" ]
+ (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnServer = Just (read value) }) "<server>")
+ "offer <server> (domain name or IP address) to discovery peers for TURN protocol"
+#endif
, Option [] ["dm-bot-echo"]
(ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>")
"automatically reply to direct messages with the same text prefixed with <prefix>"
+ , Option [] [ "websocket-server" ]
+ (ReqArg (\value -> \opts -> opts { optWebSocketServer = Just (read value) }) "<port>")
+ "start WebSocket server on given port"
, Option ['h'] ["help"]
(NoArg $ \opts -> opts { optShowHelp = True })
"show this help and exit"
@@ -114,7 +157,16 @@ options =
(NoArg $ \opts -> opts { optShowVersion = True })
"show version and exit"
]
- where so f opts = opts { optServer = f $ optServer opts }
+ where
+ so f opts = opts { optServer = f $ optServer opts }
+
+ updateService :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> SomeService -> SomeService
+ updateService f some@(SomeService proxy attrs)
+ | Just f' <- cast f = SomeService proxy (f' attrs)
+ | otherwise = some
+
+ serviceAttr :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> Options -> Options
+ serviceAttr f opts = opts { optServices = map (\sopt -> sopt { soptService = updateService f (soptService sopt) }) (optServices opts) }
servicesOptions :: [OptDescr (Options -> Options)]
servicesOptions = concatMap helper $ "all" : map soptName availableServices
@@ -131,10 +183,30 @@ servicesOptions = concatMap helper $ "all" : map soptName availableServices
| otherwise = s : change name f ss
change _ _ [] = []
+getDefaultStorageDir :: IO FilePath
+getDefaultStorageDir = do
+ lookupEnv "EREBOS_DIR" >>= \case
+ Just dir -> return dir
+ Nothing -> doesFileExist "./.erebos/erebos-storage" >>= \case
+ True -> return "./.erebos"
+ False -> getXdgDirectory XdgData "erebos"
+
main :: IO ()
main = do
- st <- liftIO $ openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR"
- getArgs >>= \case
+ (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case
+ (o, args, []) -> do
+ return (foldl (flip id) defaultOptions o, args)
+ (_, _, errs) -> do
+ progName <- getProgName
+ hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information."
+ exitFailure
+
+ st <- liftIO $ case optStorage opts of
+ DefaultStorage -> openStorage =<< getDefaultStorageDir
+ FilesystemStorage path -> openStorage path
+ MemoryStorage -> memoryStorage
+
+ case args of
["cat-file", sref] -> do
readRef st (BC.pack sref) >>= \case
Nothing -> error "ref does not exist"
@@ -150,7 +222,7 @@ main = do
forM_ (signedSignature signed) $ \sig -> do
putStr $ "SIG "
BC.putStrLn $ showRef $ storedRef $ sigKey $ fromStored sig
- "identity" -> case validateIdentityF (wrappedLoad <$> refs) of
+ "identity" -> case validateExtendedIdentityF (wrappedLoad <$> refs) of
Just identity -> do
let disp :: Identity m -> IO ()
disp idt = do
@@ -160,7 +232,7 @@ main = do
case idOwner idt of
Nothing -> return ()
Just owner -> do
- mapM_ (putStrLn . ("OWNER " ++) . BC.unpack . showRefDigest . refDigest . storedRef) $ idDataF owner
+ mapM_ (putStrLn . ("OWNER " ++) . BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF owner
disp owner
disp identity
Nothing -> putStrLn $ "Identity verification failed"
@@ -170,62 +242,59 @@ main = do
Nothing -> error "ref does not exist"
Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object)
- ["update-identity"] -> either fail return <=< runExceptT $ do
- runReaderT updateSharedIdentity =<< loadLocalStateHead st
+ ["update-identity"] -> do
+ withTerminal noCompletion $ \term -> do
+ either (fail . showErebosError) return <=< runExceptT $ do
+ runReaderT (updateSharedIdentity term) =<< loadLocalStateHead term st
("update-identity" : srefs) -> do
- sequence <$> mapM (readRef st . BC.pack) srefs >>= \case
- Nothing -> error "ref does not exist"
- Just refs
- | Just idt <- validateIdentityF $ map wrappedLoad refs -> do
- BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<<
- (either fail return <=< runExceptT $ runReaderT (interactiveIdentityUpdate idt) st)
- | otherwise -> error "invalid identity"
+ withTerminal noCompletion $ \term -> do
+ sequence <$> mapM (readRef st . BC.pack) srefs >>= \case
+ Nothing -> error "ref does not exist"
+ Just refs
+ | Just idt <- validateIdentityF $ map wrappedLoad refs -> do
+ BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<<
+ (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st)
+ | otherwise -> error "invalid identity"
["test"] -> runTestTool st
- args -> case getOpt Permute (options ++ servicesOptions) args of
- (o, [], []) -> do
- let opts = foldl (flip id) defaultOptions o
- header = "Usage: erebos [OPTION...]"
- serviceDesc ServiceOption {..} = padService (" " <> soptName) <> soptDescription
-
- padTo n str = str <> replicate (n - length str) ' '
- padOpt = padTo 37
- padService = padTo 16
-
- if | optShowHelp opts -> putStr $ usageInfo header options <> unlines
- (
- [ padOpt " --enable-<service>" <> "enable network service <service>"
- , padOpt " --disable-<service>" <> "disable network service <service>"
- , padOpt " --enable-all" <> "enable all network services"
- , padOpt " --disable-all" <> "disable all network services"
- , ""
- , "Available network services:"
- ] ++ map serviceDesc availableServices
- )
- | optShowVersion opts -> putStrLn versionLine
- | otherwise -> interactiveLoop st opts
- (_, _, errs) -> do
- progName <- getProgName
- hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information."
- exitFailure
-
-
-inputSettings :: Settings IO
-inputSettings = setComplete commandCompletion $ defaultSettings
+ [] -> do
+ let header = "Usage: erebos [OPTION...]"
+ serviceDesc ServiceOption {..} = padService (" " <> soptName) <> soptDescription
+
+ padTo n str = str <> replicate (n - length str) ' '
+ padOpt = padTo 37
+ padService = padTo 16
+
+ if | optShowHelp opts -> putStr $ usageInfo header options <> unlines
+ (
+ [ padOpt " --enable-<service>" <> "enable network service <service>"
+ , padOpt " --disable-<service>" <> "disable network service <service>"
+ , padOpt " --enable-all" <> "enable all network services"
+ , padOpt " --disable-all" <> "disable all network services"
+ , ""
+ , "Available network services:"
+ ] ++ map serviceDesc availableServices
+ )
+ | optShowVersion opts -> putStrLn versionLine
+ | otherwise -> interactiveLoop st opts
+
+ (cmdname : _) -> do
+ hPutStrLn stderr $ "Unknown command `" <> cmdname <> "'"
+ exitFailure
+
interactiveLoop :: Storage -> Options -> IO ()
-interactiveLoop st opts = runInputT inputSettings $ do
- erebosHead <- liftIO $ loadLocalStateHead st
- outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
+interactiveLoop st opts = withTerminal commandCompletion $ \term -> do
+ erebosHead <- liftIO $ loadLocalStateHead term st
+ void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
- tui <- haveTerminalUI
- extPrint <- getExternalPrint
- let extPrintLn str = extPrint $ case reverse str of ('\n':_) -> str
- _ -> str ++ "\n";
+ let tui = hasTerminalUI term
+ let extPrintLn = void . printLine term
- let getInputLinesTui eprompt = do
+ let getInputLinesTui :: Either CommandState String -> MaybeT IO String
+ getInputLinesTui eprompt = do
prompt <- case eprompt of
Left cstate -> do
pname <- case csContext cstate of
@@ -235,14 +304,18 @@ interactiveLoop st opts = runInputT inputSettings $ do
PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
PeerIdentityUnknown _ -> "<unknown>"
SelectedContact contact -> return $ T.unpack $ contactName contact
+ SelectedChatroom rstate -> return $ T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate
SelectedConversation conv -> return $ T.unpack $ conversationName conv
return $ pname ++ "> "
Right prompt -> return prompt
- Just input <- lift $ getInputLine prompt
- case reverse input of
- _ | all isSpace input -> getInputLinesTui eprompt
- '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ")
- _ -> return input
+ lift $ setPrompt term prompt
+ join $ lift $ getInputLine term $ \case
+ Just input@('/' : _) -> KeepPrompt $ return input
+ Just input -> ErasePrompt $ case reverse input of
+ _ | all isSpace input -> getInputLinesTui eprompt
+ '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ")
+ _ -> return input
+ Nothing -> KeepPrompt mzero
getInputCommandTui cstate = do
input <- getInputLinesTui cstate
@@ -255,7 +328,7 @@ interactiveLoop st opts = runInputT inputSettings $ do
return (cmd, line)
getInputLinesPipe = do
- lift (getInputLine "") >>= \case
+ join $ lift $ getInputLine term $ KeepPrompt . \case
Just input -> return input
Nothing -> liftIO $ forever $ threadDelay 100000000
@@ -281,12 +354,23 @@ interactiveLoop st opts = runInputT inputSettings $ do
Right reply -> extPrintLn $ formatDirectMessage tzone $ fromStored reply
Left err -> extPrintLn $ "Failed to send dm echo: " <> err
+ peers <- liftIO $ newMVar []
+ contextOptions <- liftIO $ newMVar []
+ chatroomSetVar <- liftIO $ newEmptyMVar
+
+ let autoSubscribe = optChatroomAutoSubscribe opts
+ chatroomList = fromSetBy (comparing roomStateData) . lookupSharedValue . lsShared . headObject $ erebosHead
+ watched <- if isJust autoSubscribe || any roomStateSubscribe chatroomList
+ then fmap Just $ liftIO $ watchChatroomsForCli extPrintLn erebosHead chatroomSetVar contextOptions autoSubscribe
+ else return Nothing
+
server <- liftIO $ do
startServer (optServer opts) erebosHead extPrintLn $
map soptService $ filter soptEnabled $ optServices opts
- peers <- liftIO $ newMVar []
- contextOptions <- liftIO $ newMVar []
+ case optWebSocketServer opts of
+ Just port -> startWebsocketServer server "::" port extPrintLn
+ Nothing -> return ()
void $ liftIO $ forkIO $ void $ forever $ do
peer <- getNextPeerChange server
@@ -309,29 +393,33 @@ interactiveLoop st opts = runInputT inputSettings $ do
when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown
_ -> return ()
- let process :: CommandState -> MaybeT (InputT IO) CommandState
+ let process :: CommandState -> MaybeT IO CommandState
process cstate = do
(cmd, line) <- getInputCommand cstate
h <- liftIO (reloadHead $ csHead cstate) >>= \case
Just h -> return h
- Nothing -> do lift $ lift $ extPrintLn "current head deleted"
+ Nothing -> do lift $ extPrintLn "current head deleted"
mzero
res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput
{ ciServer = server
+ , ciTerminal = term
, ciLine = line
, ciPrint = extPrintLn
+ , ciOptions = opts
, ciPeers = liftIO $ modifyMVar peers $ \ps -> do
ps' <- filterM (fmap not . isPeerDropped . fst) ps
return (ps', ps')
, ciContextOptions = liftIO $ readMVar contextOptions
, ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs
+ , ciContextOptionsVar = contextOptions
+ , ciChatroomSetVar = chatroomSetVar
}
case res of
Right cstate'
| csQuit cstate' -> mzero
| otherwise -> return cstate'
Left err -> do
- lift $ lift $ extPrintLn $ "Error: " ++ err
+ lift $ extPrintLn $ "Error: " ++ showErebosError err
return cstate
let loop (Just cstate) = runMaybeT (process cstate) >>= loop
@@ -343,17 +431,22 @@ interactiveLoop st opts = runInputT inputSettings $ do
, csIceSessions = []
#endif
, csIcePeer = Nothing
+ , csWatchChatrooms = watched
, csQuit = False
}
data CommandInput = CommandInput
{ ciServer :: Server
+ , ciTerminal :: Terminal
, ciLine :: String
, ciPrint :: String -> IO ()
+ , ciOptions :: Options
, ciPeers :: CommandM [(Peer, String)]
, ciContextOptions :: CommandM [CommandContext]
, ciSetContextOptions :: [CommandContext] -> Command
+ , ciContextOptionsVar :: MVar [ CommandContext ]
+ , ciChatroomSetVar :: MVar (Set ChatroomState)
}
data CommandState = CommandState
@@ -363,23 +456,25 @@ data CommandState = CommandState
, csIceSessions :: [IceSession]
#endif
, csIcePeer :: Maybe Peer
+ , csWatchChatrooms :: Maybe WatchedHead
, csQuit :: Bool
}
data CommandContext = NoContext
| SelectedPeer Peer
| SelectedContact Contact
+ | SelectedChatroom ChatroomState
| SelectedConversation Conversation
-newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a)
- deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String)
+newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a)
+ deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError)
instance MonadFail CommandM where
- fail = throwError
+ fail = throwOtherError
instance MonadIO CommandM where
liftIO act = CommandM (liftIO (try act)) >>= \case
- Left (e :: SomeException) -> throwError (show e)
+ Left (e :: SomeException) -> throwOtherError (show e)
Right x -> return x
instance MonadRandom CommandM where
@@ -400,18 +495,37 @@ type Command = CommandM ()
getSelectedPeer :: CommandM Peer
getSelectedPeer = gets csContext >>= \case
SelectedPeer peer -> return peer
- _ -> throwError "no peer selected"
+ _ -> throwOtherError "no peer selected"
+
+getSelectedChatroom :: CommandM ChatroomState
+getSelectedChatroom = gets csContext >>= \case
+ SelectedChatroom rstate -> return rstate
+ _ -> throwOtherError "no chatroom selected"
getSelectedConversation :: CommandM Conversation
-getSelectedConversation = gets csContext >>= \case
+getSelectedConversation = gets csContext >>= getConversationFromContext
+
+getConversationFromContext :: CommandContext -> CommandM Conversation
+getConversationFromContext = \case
SelectedPeer peer -> peerIdentity peer >>= \case
PeerIdentityFull pid -> directMessageConversation $ finalOwner pid
- _ -> throwError "incomplete peer identity"
+ _ -> throwOtherError "incomplete peer identity"
SelectedContact contact -> case contactIdentity contact of
Just cid -> directMessageConversation cid
- Nothing -> throwError "contact without erebos identity"
+ Nothing -> throwOtherError "contact without erebos identity"
+ SelectedChatroom rstate ->
+ chatroomConversation rstate >>= \case
+ Just conv -> return conv
+ Nothing -> throwOtherError "invalid chatroom"
SelectedConversation conv -> reloadConversation conv
- _ -> throwError "no contact, peer or conversation selected"
+ _ -> throwOtherError "no contact, peer or conversation selected"
+
+getSelectedOrManualContext :: CommandM CommandContext
+getSelectedOrManualContext = do
+ asks ciLine >>= \case
+ "" -> gets csContext
+ str | all isDigit str -> getContextByIndex (read str)
+ _ -> throwOtherError "invalid index"
commands :: [(String, Command)]
commands =
@@ -421,25 +535,32 @@ commands =
, ("peer-add-public", cmdPeerAddPublic)
, ("peer-drop", cmdPeerDrop)
, ("send", cmdSend)
+ , ("delete", cmdDelete)
, ("update-identity", cmdUpdateIdentity)
, ("attach", cmdAttach)
, ("attach-accept", cmdAttachAccept)
, ("attach-reject", cmdAttachReject)
+ , ("chatrooms", cmdChatrooms)
+ , ("chatroom-create-public", cmdChatroomCreatePublic)
, ("contacts", cmdContacts)
, ("contact-add", cmdContactAdd)
, ("contact-accept", cmdContactAccept)
, ("contact-reject", cmdContactReject)
, ("conversations", cmdConversations)
, ("details", cmdDetails)
-#ifdef ENABLE_ICE_SUPPORT
, ("discovery-init", cmdDiscoveryInit)
, ("discovery", cmdDiscovery)
+#ifdef ENABLE_ICE_SUPPORT
, ("ice-create", cmdIceCreate)
, ("ice-destroy", cmdIceDestroy)
, ("ice-show", cmdIceShow)
, ("ice-connect", cmdIceConnect)
, ("ice-send", cmdIceSend)
#endif
+ , ("join", cmdJoin)
+ , ("join-as", cmdJoinAs)
+ , ("leave", cmdLeave)
+ , ("members", cmdMembers)
, ("select", cmdSelectContext)
, ("quit", cmdQuit)
]
@@ -452,8 +573,13 @@ commandCompletion = completeWordWithPrev Nothing [ ' ', '\t', '\n', '\r' ] $ cur
sortedCommandNames = sort $ map fst commands
+cmdPutStrLn :: String -> Command
+cmdPutStrLn str = do
+ term <- asks ciTerminal
+ void $ liftIO $ printLine term str
+
cmdUnknown :: String -> Command
-cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd
+cmdUnknown cmd = cmdPutStrLn $ "Unknown command: " ++ cmd
cmdPeers :: Command
cmdPeers = do
@@ -461,7 +587,7 @@ cmdPeers = do
set <- asks ciSetContextOptions
set $ map (SelectedPeer . fst) peers
forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do
- liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ name
+ cmdPutStrLn $ "[" ++ show i ++ "] " ++ name
cmdPeerAdd :: Command
cmdPeerAdd = void $ do
@@ -469,15 +595,26 @@ cmdPeerAdd = void $ do
(hostname, port) <- (words <$> asks ciLine) >>= \case
hostname:p:_ -> return (hostname, p)
[hostname] -> return (hostname, show discoveryPort)
- [] -> throwError "missing peer address"
+ [] -> throwOtherError "missing peer address"
addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
liftIO $ serverPeer server (addrAddress addr)
cmdPeerAddPublic :: Command
cmdPeerAddPublic = do
server <- asks ciServer
- addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just "discovery1.erebosprotocol.net") (Just (show discoveryPort))
- void $ liftIO $ serverPeer server (addrAddress addr)
+ liftIO $ mapM_ (serverPeer server . addrAddress) =<< gather 'a'
+ where
+ gather c
+ | c <= 'z' = do
+ let hints = Just $ defaultHints { addrSocketType = Datagram }
+ hostname = Just $ c : ".discovery.erebosprotocol.net"
+ service = Just $ show discoveryPort
+ handle (\(_ :: IOException) -> return []) (getAddrInfo hints hostname service) >>= \case
+ addr : _ -> (addr :) <$> gather (succ c)
+ [] -> return []
+
+ | otherwise = do
+ return []
cmdPeerDrop :: Command
cmdPeerDrop = do
@@ -492,34 +629,71 @@ showPeer pidentity paddr =
PeerIdentityFull pid -> T.unpack $ displayIdentity pid
in name ++ " [" ++ show paddr ++ "]"
+cmdJoin :: Command
+cmdJoin = joinChatroom =<< getSelectedChatroom
+
+cmdJoinAs :: Command
+cmdJoinAs = do
+ name <- asks ciLine
+ st <- getStorage
+ identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing
+ joinChatroomAs identity =<< getSelectedChatroom
+
+cmdLeave :: Command
+cmdLeave = leaveChatroom =<< getSelectedChatroom
+
+cmdMembers :: Command
+cmdMembers = do
+ Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom
+ forM_ (chatroomMembers room) $ \x -> do
+ cmdPutStrLn $ maybe "<unnamed>" T.unpack $ idName x
+
+getContextByIndex :: Int -> CommandM CommandContext
+getContextByIndex n = do
+ join (asks ciContextOptions) >>= \ctxs -> if
+ | n > 0, (ctx : _) <- drop (n - 1) ctxs -> return ctx
+ | otherwise -> throwOtherError "invalid index"
+
cmdSelectContext :: Command
cmdSelectContext = do
n <- read <$> asks ciLine
- join (asks ciContextOptions) >>= \ctxs -> if
- | n > 0, (ctx : _) <- drop (n - 1) ctxs -> modify $ \s -> s { csContext = ctx }
- | otherwise -> throwError "invalid index"
+ ctx <- getContextByIndex 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
- msg <- sendMessage conv $ T.pack text
- tzone <- liftIO $ getCurrentTimeZone
- liftIO $ putStrLn $ formatMessage tzone msg
+ sendMessage conv (T.pack text) >>= \case
+ Just msg -> do
+ tzone <- liftIO $ getCurrentTimeZone
+ cmdPutStrLn $ formatMessage tzone msg
+ Nothing -> return ()
+
+cmdDelete :: Command
+cmdDelete = void $ do
+ deleteConversation =<< 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>"
cmdUpdateIdentity :: Command
cmdUpdateIdentity = void $ do
- runReaderT updateSharedIdentity =<< gets csHead
+ term <- asks ciTerminal
+ runReaderT (updateSharedIdentity term) =<< gets csHead
cmdAttach :: Command
cmdAttach = attachToOwner =<< getSelectedPeer
@@ -530,6 +704,110 @@ cmdAttachAccept = attachAccept =<< getSelectedPeer
cmdAttachReject :: Command
cmdAttachReject = attachReject =<< getSelectedPeer
+watchChatroomsForCli :: (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) -> MVar [ CommandContext ] -> Maybe Int -> IO WatchedHead
+watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do
+ subscribedNumVar <- newEmptyMVar
+
+ let ctxUpdate updateType (idx :: Int) rstate = \case
+ SelectedChatroom rstate' : rest
+ | currentRoots <- filterAncestors (concatMap storedRoots $ roomStateData rstate)
+ , any ((`intersectsSorted` currentRoots) . storedRoots) $ roomStateData rstate'
+ -> do
+ eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name
+ return (SelectedChatroom rstate : rest)
+ selected : rest
+ -> do
+ (selected : ) <$> ctxUpdate updateType (idx + 1) rstate rest
+ []
+ -> do
+ eprint $ "[" <> show idx <> "] CHATROOM " <> updateType <> " " <> name
+ return [ SelectedChatroom rstate ]
+ where
+ name = maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom rstate
+
+ watchChatrooms h $ \set -> \case
+ Nothing -> do
+ let chatroomList = filter (not . roomStateDeleted) $ fromSetBy (comparing roomStateData) set
+ (subscribed, notSubscribed) = partition roomStateSubscribe chatroomList
+ subscribedNum = length subscribed
+
+ putMVar chatroomSetVar set
+ putMVar subscribedNumVar subscribedNum
+
+ case autoSubscribe of
+ Nothing -> return ()
+ Just num -> do
+ forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do
+ (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case
+ Right () -> return ()
+ Left err -> eprint (showErebosError err)
+
+ Just diff -> do
+ modifyMVar_ chatroomSetVar $ return . const set
+ forM_ diff $ \case
+ AddedChatroom rstate -> do
+ modifyMVar_ contextVar $ ctxUpdate "NEW" 1 rstate
+ modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then (+ 1) else id
+
+ RemovedChatroom rstate -> do
+ modifyMVar_ contextVar $ ctxUpdate "DEL" 1 rstate
+ modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then subtract 1 else id
+
+ UpdatedChatroom oldroom rstate -> do
+ when (any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)) $ do
+ modifyMVar_ contextVar $ ctxUpdate "UPD" 1 rstate
+ when (any (not . null . rsdMessages . fromStored) (roomStateData rstate)) $ do
+ tzone <- getCurrentTimeZone
+ forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do
+ eprint $ concat $
+ [ maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg
+ , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg
+ , maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg
+ , if cmsgLeave msg then " left" else ""
+ , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg
+ ]
+ modifyMVar_ subscribedNumVar $ return
+ . (if roomStateSubscribe rstate then (+ 1) else id)
+ . (if roomStateSubscribe oldroom then subtract 1 else id)
+
+ensureWatchedChatrooms :: Command
+ensureWatchedChatrooms = do
+ gets csWatchChatrooms >>= \case
+ Nothing -> do
+ eprint <- asks ciPrint
+ h <- gets csHead
+ chatroomSetVar <- asks ciChatroomSetVar
+ contextVar <- asks ciContextOptionsVar
+ autoSubscribe <- asks $ optChatroomAutoSubscribe . ciOptions
+ watched <- liftIO $ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe
+ modify $ \s -> s { csWatchChatrooms = Just watched }
+ Just _ -> return ()
+
+cmdChatrooms :: Command
+cmdChatrooms = do
+ ensureWatchedChatrooms
+ chatroomSetVar <- asks ciChatroomSetVar
+ chatroomList <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar)
+ set <- asks ciSetContextOptions
+ set $ map SelectedChatroom chatroomList
+ forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do
+ cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate)
+
+cmdChatroomCreatePublic :: Command
+cmdChatroomCreatePublic = do
+ term <- asks ciTerminal
+ name <- asks ciLine >>= \case
+ line | not (null line) -> return $ T.pack line
+ _ -> liftIO $ do
+ setPrompt term "Name: "
+ getInputLine term $ KeepPrompt . maybe T.empty T.pack
+
+ ensureWatchedChatrooms
+ void $ createChatroom
+ (if T.null name then Nothing else Just name)
+ Nothing
+
+
cmdContacts :: Command
cmdContacts = do
args <- words <$> asks ciLine
@@ -538,8 +816,8 @@ cmdContacts = do
verbose = "-v" `elem` args
set <- asks ciSetContextOptions
set $ map SelectedContact contacts
- forM_ (zip [1..] contacts) $ \(i :: Int, c) -> liftIO $ do
- T.putStrLn $ T.concat
+ forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do
+ cmdPutStrLn $ T.unpack $ T.concat
[ "[", T.pack (show i), "] ", contactName c
, case contactIdentity c of
Just idt | cname <- displayIdentity idt
@@ -565,33 +843,36 @@ cmdConversations = do
set <- asks ciSetContextOptions
set $ map SelectedConversation conversations
forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do
- liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)
+ cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)
cmdDetails :: Command
cmdDetails = do
- gets csContext >>= \case
+ getSelectedOrManualContext >>= \case
SelectedPeer peer -> do
- liftIO $ putStr $ unlines
+ cmdPutStrLn $ unlines
[ "Network peer:"
, " " <> show (peerAddress peer)
]
peerIdentity peer >>= \case
- PeerIdentityUnknown _ -> liftIO $ do
- putStrLn $ "unknown identity"
- PeerIdentityRef wref _ -> liftIO $ do
- putStrLn $ "Identity ref:"
- putStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref)
+ PeerIdentityUnknown _ -> do
+ cmdPutStrLn $ "unknown identity"
+ PeerIdentityRef wref _ -> do
+ cmdPutStrLn $ "Identity ref:"
+ cmdPutStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref)
PeerIdentityFull pid -> printContactOrIdentityDetails pid
SelectedContact contact -> do
printContactDetails contact
+ SelectedChatroom rstate -> do
+ cmdPutStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate)
+
SelectedConversation conv -> do
case conversationPeer conv of
Just pid -> printContactOrIdentityDetails pid
- Nothing -> liftIO $ putStrLn $ "(conversation without peer)"
+ Nothing -> cmdPutStrLn $ "(conversation without peer)"
- NoContext -> liftIO $ putStrLn "nothing selected"
+ NoContext -> cmdPutStrLn "nothing selected"
where
printContactOrIdentityDetails cid = do
contacts <- fromSetBy (comparing contactName) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
@@ -599,11 +880,11 @@ cmdDetails = do
Just contact -> printContactDetails contact
Nothing -> printIdentityDetails cid
- printContactDetails contact = liftIO $ do
- putStrLn $ "Contact:"
+ printContactDetails contact = do
+ cmdPutStrLn $ "Contact:"
prefix <- case contactCustomName contact of
Just name -> do
- putStrLn $ " " <> T.unpack name
+ cmdPutStrLn $ " " <> T.unpack name
return $ Just "alias of"
Nothing -> do
return $ Nothing
@@ -612,23 +893,21 @@ cmdDetails = do
Just cid -> do
printIdentityDetailsBody prefix cid
Nothing -> do
- putStrLn $ " (without erebos identity)"
+ cmdPutStrLn $ " (without erebos identity)"
- printIdentityDetails identity = liftIO $ do
- putStrLn $ "Identity:"
+ printIdentityDetails identity = do
+ cmdPutStrLn $ "Identity:"
printIdentityDetailsBody Nothing identity
printIdentityDetailsBody prefix identity = do
forM_ (zip (False : repeat True) $ unfoldOwners identity) $ \(owned, cpid) -> do
- putStrLn $ unwords $ concat
+ cmdPutStrLn $ unwords $ concat
[ [ " " ]
, if owned then [ "owned by" ] else maybeToList prefix
, [ maybe "<unnamed>" T.unpack (idName cpid) ]
, map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid
]
-#ifdef ENABLE_ICE_SUPPORT
-
cmdDiscoveryInit :: Command
cmdDiscoveryInit = void $ do
server <- asks ciServer
@@ -639,31 +918,50 @@ cmdDiscoveryInit = void $ do
[] -> ("discovery.erebosprotocol.net", show discoveryPort)
addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port)
peer <- liftIO $ serverPeer server (addrAddress addr)
- sendToPeer peer $ DiscoverySelf (T.pack "ICE") 0
+ sendToPeer peer $ DiscoverySelf [ T.pack "ICE" ] Nothing
modify $ \s -> s { csIcePeer = Just peer }
cmdDiscovery :: Command
cmdDiscovery = void $ do
- Just peer <- gets csIcePeer
- st <- getStorage
+ server <- asks ciServer
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
+ case readRefDigest (BC.pack sref) of
+ Nothing -> throwOtherError "failed to parse ref"
+ Just dgst -> discoverySearch server dgst
+
+#ifdef ENABLE_ICE_SUPPORT
cmdIceCreate :: Command
cmdIceCreate = do
- role <- asks ciLine >>= return . \case
- 'm':_ -> PjIceSessRoleControlling
- 's':_ -> PjIceSessRoleControlled
- _ -> PjIceSessRoleUnknown
+ let getRole = \case
+ 'm':_ -> PjIceSessRoleControlling
+ 's':_ -> PjIceSessRoleControlled
+ _ -> PjIceSessRoleUnknown
+
+ ( role, stun, turn ) <- asks (words . ciLine) >>= \case
+ [] -> return ( PjIceSessRoleControlling, Nothing, Nothing )
+ [ role ] -> return
+ ( getRole role, Nothing, Nothing )
+ [ role, server ] -> return
+ ( getRole role
+ , Just ( T.pack server, 0 )
+ , Just ( T.pack server, 0 )
+ )
+ [ role, server, port ] -> return
+ ( getRole role
+ , Just ( T.pack server, read port )
+ , Just ( T.pack server, read port )
+ )
+ [ role, stunServer, stunPort, turnServer, turnPort ] -> return
+ ( getRole role
+ , Just ( T.pack stunServer, read stunPort )
+ , Just ( T.pack turnServer, read turnPort )
+ )
+ _ -> throwOtherError "invalid parameters"
+
eprint <- asks ciPrint
- sess <- liftIO $ iceCreate role $ eprint <=< iceShow
+ Just cfg <- liftIO $ iceCreateConfig stun turn
+ sess <- liftIO $ iceCreateSession cfg role $ eprint <=< iceShow
modify $ \s -> s { csIceSessions = sess : csIceSessions s }
cmdIceDestroy :: Command
@@ -684,11 +982,15 @@ cmdIceConnect :: Command
cmdIceConnect = do
s:_ <- gets csIceSessions
server <- asks ciServer
- let loadInfo = BC.getLine >>= \case line | BC.null line -> return []
- | otherwise -> (line:) <$> loadInfo
+ term <- asks ciTerminal
+ let loadInfo =
+ getInputLine term (KeepPrompt . maybe BC.empty BC.pack) >>= \case
+ line | BC.null line -> return []
+ | otherwise -> (line :) <$> loadInfo
Right remote <- liftIO $ do
st <- memoryStorage
pst <- derivePartialStorage st
+ setPrompt term ""
rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo
copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes)
liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s
@@ -703,3 +1005,10 @@ cmdIceSend = void $ do
cmdQuit :: Command
cmdQuit = modify $ \s -> s { csQuit = True }
+
+
+intersectsSorted :: Ord a => [a] -> [a] -> Bool
+intersectsSorted (x:xs) (y:ys) | x < y = intersectsSorted xs (y:ys)
+ | x > y = intersectsSorted (x:xs) ys
+ | otherwise = True
+intersectsSorted _ _ = False