summaryrefslogtreecommitdiff
path: root/main
diff options
context:
space:
mode:
Diffstat (limited to 'main')
-rw-r--r--main/Main.hs705
-rw-r--r--main/Test.hs683
-rw-r--r--main/Test/Service.hs36
-rw-r--r--main/Version.hs23
-rw-r--r--main/Version/Git.hs31
5 files changed, 1478 insertions, 0 deletions
diff --git a/main/Main.hs b/main/Main.hs
new file mode 100644
index 0000000..0eb414c
--- /dev/null
+++ b/main/Main.hs
@@ -0,0 +1,705 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Control.Arrow (first)
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Trans.Maybe
+
+import Crypto.Random
+
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as BL
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Ord
+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.LocalTime
+import Data.Typeable
+
+import Network.Socket
+
+import System.Console.GetOpt
+import System.Console.Haskeline
+import System.Environment
+import System.Exit
+import System.IO
+
+import Erebos.Attach
+import Erebos.Contact
+import Erebos.Conversation
+#ifdef ENABLE_ICE_SUPPORT
+import Erebos.Discovery
+import Erebos.ICE
+#endif
+import Erebos.Identity
+import Erebos.Message hiding (formatMessage)
+import Erebos.Network
+import Erebos.PubKey
+import Erebos.Service
+import Erebos.Set
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Merge
+import Erebos.Sync
+
+import Test
+import Version
+
+data Options = Options
+ { optServer :: ServerOptions
+ , optServices :: [ServiceOption]
+ , optDmBotEcho :: Maybe Text
+ , optShowHelp :: Bool
+ , optShowVersion :: Bool
+ }
+
+data ServiceOption = ServiceOption
+ { soptName :: String
+ , soptService :: SomeService
+ , soptEnabled :: Bool
+ , soptDescription :: String
+ }
+
+defaultOptions :: Options
+defaultOptions = Options
+ { optServer = defaultServerOptions
+ , optServices = availableServices
+ , optDmBotEcho = Nothing
+ , optShowHelp = False
+ , optShowVersion = False
+ }
+
+availableServices :: [ServiceOption]
+availableServices =
+ [ ServiceOption "attach" (someService @AttachService Proxy)
+ True "attach (to) other devices"
+ , ServiceOption "sync" (someService @SyncService Proxy)
+ True "synchronization with attached devices"
+ , 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)]
+options =
+ [ Option ['p'] ["port"]
+ (ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "<port>")
+ "local port to bind"
+ , Option ['s'] ["silent"]
+ (NoArg (so $ \opts -> opts { serverLocalDiscovery = False }))
+ "do not send announce packets for local discovery"
+ , 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 ['h'] ["help"]
+ (NoArg $ \opts -> opts { optShowHelp = True })
+ "show this help and exit"
+ , Option ['V'] ["version"]
+ (NoArg $ \opts -> opts { optShowVersion = True })
+ "show version and exit"
+ ]
+ where so f opts = opts { optServer = f $ optServer opts }
+
+servicesOptions :: [OptDescr (Options -> 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 }) ""
+ ]
+ so f opts = opts { optServices = f $ optServices opts }
+ change :: String -> (ServiceOption -> ServiceOption) -> [ServiceOption] -> [ServiceOption]
+ change name f (s : ss)
+ | soptName s == name || name == "all"
+ = f s : change name f ss
+ | otherwise = s : change name f ss
+ change _ _ [] = []
+
+main :: IO ()
+main = do
+ st <- liftIO $ openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR"
+ getArgs >>= \case
+ ["cat-file", sref] -> do
+ readRef st (BC.pack sref) >>= \case
+ Nothing -> error "ref does not exist"
+ Just ref -> BL.putStr $ lazyLoadBytes ref
+
+ ("cat-file" : objtype : srefs@(_:_)) -> do
+ sequence <$> (mapM (readRef st . BC.pack) srefs) >>= \case
+ Nothing -> error "ref does not exist"
+ Just refs -> case objtype of
+ "signed" -> forM_ refs $ \ref -> do
+ let signed = load ref :: Signed Object
+ BL.putStr $ lazyLoadBytes $ storedRef $ signedData signed
+ forM_ (signedSignature signed) $ \sig -> do
+ putStr $ "SIG "
+ BC.putStrLn $ showRef $ storedRef $ sigKey $ fromStored sig
+ "identity" -> case validateIdentityF (wrappedLoad <$> refs) of
+ Just identity -> do
+ let disp :: Identity m -> IO ()
+ disp idt = do
+ maybe (return ()) (T.putStrLn . (T.pack "Name: " `T.append`)) $ idName idt
+ BC.putStrLn . (BC.pack "KeyId: " `BC.append`) . showRefDigest . refDigest . storedRef $ idKeyIdentity idt
+ BC.putStrLn . (BC.pack "KeyMsg: " `BC.append`) . showRefDigest . refDigest . storedRef $ idKeyMessage idt
+ case idOwner idt of
+ Nothing -> return ()
+ Just owner -> do
+ mapM_ (putStrLn . ("OWNER " ++) . BC.unpack . showRefDigest . refDigest . storedRef) $ idDataF owner
+ disp owner
+ disp identity
+ Nothing -> putStrLn $ "Identity verification failed"
+ _ -> error $ "unknown object type '" ++ objtype ++ "'"
+
+ ["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"] -> either fail return <=< runExceptT $ do
+ runReaderT updateSharedIdentity =<< loadLocalStateHead 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"
+
+ ["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
+
+interactiveLoop :: Storage -> Options -> IO ()
+interactiveLoop st opts = runInputT inputSettings $ do
+ erebosHead <- liftIO $ loadLocalStateHead st
+ outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
+
+ tui <- haveTerminalUI
+ extPrint <- getExternalPrint
+ let extPrintLn str = extPrint $ case reverse str of ('\n':_) -> str
+ _ -> str ++ "\n";
+
+ let getInputLinesTui eprompt = do
+ prompt <- case eprompt of
+ Left cstate -> do
+ pname <- case csContext cstate of
+ NoContext -> return ""
+ SelectedPeer peer -> peerIdentity peer >>= return . \case
+ PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid
+ PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
+ PeerIdentityUnknown _ -> "<unknown>"
+ SelectedContact contact -> return $ T.unpack $ contactName contact
+ 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
+
+ getInputCommandTui cstate = do
+ input <- getInputLinesTui cstate
+ let (CommandM cmd, line) = case input of
+ '/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest
+ in if not (null scmd) && all isDigit scmd
+ then (cmdSelectContext, scmd)
+ else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
+ _ -> (cmdSend, input)
+ return (cmd, line)
+
+ getInputLinesPipe = do
+ lift (getInputLine "") >>= \case
+ Just input -> return input
+ Nothing -> liftIO $ forever $ threadDelay 100000000
+
+ getInputCommandPipe _ = do
+ input <- getInputLinesPipe
+ let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') input
+ let (CommandM cmd, line) = (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args)
+ return (cmd, line)
+
+ let getInputCommand = if tui then getInputCommandTui . Left
+ else getInputCommandPipe
+
+ _ <- 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
+
+ server <- liftIO $ do
+ startServer (optServer opts) erebosHead extPrintLn $
+ map soptService $ filter soptEnabled $ optServices opts
+
+ peers <- liftIO $ newMVar []
+ contextOptions <- liftIO $ newMVar []
+
+ void $ liftIO $ forkIO $ void $ forever $ do
+ peer <- getNextPeerChange server
+ peerIdentity peer >>= \case
+ pid@(PeerIdentityFull _) -> do
+ dropped <- isPeerDropped peer
+ let shown = showPeer pid $ peerAddress peer
+ let update [] = ([(peer, shown)], (Nothing, "NEW"))
+ update ((p,s):ps)
+ | p == peer && dropped = (ps, (Nothing, "DEL"))
+ | p == peer = ((peer, shown) : ps, (Just s, "UPD"))
+ | otherwise = first ((p,s):) $ update ps
+ let ctxUpdate n [] = ([SelectedPeer peer], n)
+ ctxUpdate n (ctx:ctxs)
+ | SelectedPeer p <- ctx, p == peer = (ctx:ctxs, n)
+ | 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
+ _ -> return ()
+
+ let process :: CommandState -> MaybeT (InputT 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"
+ mzero
+ res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput
+ { ciServer = server
+ , ciLine = line
+ , ciPrint = extPrintLn
+ , 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
+ }
+ case res of
+ Right cstate'
+ | csQuit cstate' -> mzero
+ | otherwise -> return cstate'
+ Left err -> do
+ lift $ lift $ extPrintLn $ "Error: " ++ err
+ return cstate
+
+ let loop (Just cstate) = runMaybeT (process cstate) >>= loop
+ loop Nothing = return ()
+ loop $ Just $ CommandState
+ { csHead = erebosHead
+ , csContext = NoContext
+#ifdef ENABLE_ICE_SUPPORT
+ , csIceSessions = []
+#endif
+ , csIcePeer = Nothing
+ , csQuit = False
+ }
+
+
+data CommandInput = CommandInput
+ { ciServer :: Server
+ , ciLine :: String
+ , ciPrint :: String -> IO ()
+ , ciPeers :: CommandM [(Peer, String)]
+ , ciContextOptions :: CommandM [CommandContext]
+ , ciSetContextOptions :: [CommandContext] -> Command
+ }
+
+data CommandState = CommandState
+ { csHead :: Head LocalState
+ , csContext :: CommandContext
+#ifdef ENABLE_ICE_SUPPORT
+ , csIceSessions :: [IceSession]
+#endif
+ , csIcePeer :: Maybe Peer
+ , csQuit :: Bool
+ }
+
+data CommandContext = NoContext
+ | SelectedPeer Peer
+ | SelectedContact Contact
+ | SelectedConversation Conversation
+
+newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a)
+ deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String)
+
+instance MonadFail CommandM where
+ fail = throwError
+
+instance MonadIO CommandM where
+ liftIO act = CommandM (liftIO (try act)) >>= \case
+ Left (e :: SomeException) -> throwError (show e)
+ Right x -> return x
+
+instance MonadRandom CommandM where
+ getRandomBytes = liftIO . getRandomBytes
+
+instance MonadStorage CommandM where
+ getStorage = gets $ headStorage . csHead
+
+instance MonadHead LocalState CommandM where
+ updateLocalHead f = do
+ h <- gets csHead
+ (Just h', x) <- maybe (fail "failed to reload head") (flip updateHead f) =<< reloadHead h
+ modify $ \s -> s { csHead = h' }
+ return x
+
+type Command = CommandM ()
+
+getSelectedPeer :: CommandM Peer
+getSelectedPeer = gets csContext >>= \case
+ SelectedPeer peer -> return peer
+ _ -> throwError "no peer selected"
+
+getSelectedConversation :: CommandM Conversation
+getSelectedConversation = gets csContext >>= \case
+ SelectedPeer peer -> peerIdentity peer >>= \case
+ PeerIdentityFull pid -> directMessageConversation $ finalOwner pid
+ _ -> throwError "incomplete peer identity"
+ SelectedContact contact -> case contactIdentity contact of
+ Just cid -> directMessageConversation cid
+ Nothing -> throwError "contact without erebos identity"
+ SelectedConversation conv -> reloadConversation conv
+ _ -> throwError "no contact, peer or conversation selected"
+
+commands :: [(String, Command)]
+commands =
+ [ ("history", cmdHistory)
+ , ("peers", cmdPeers)
+ , ("peer-add", cmdPeerAdd)
+ , ("peer-add-public", cmdPeerAddPublic)
+ , ("peer-drop", cmdPeerDrop)
+ , ("send", cmdSend)
+ , ("update-identity", cmdUpdateIdentity)
+ , ("attach", cmdAttach)
+ , ("attach-accept", cmdAttachAccept)
+ , ("attach-reject", cmdAttachReject)
+ , ("contacts", cmdContacts)
+ , ("contact-add", cmdContactAdd)
+ , ("contact-accept", cmdContactAccept)
+ , ("contact-reject", cmdContactReject)
+ , ("conversations", cmdConversations)
+ , ("details", cmdDetails)
+#ifdef ENABLE_ICE_SUPPORT
+ , ("discovery-init", cmdDiscoveryInit)
+ , ("discovery", cmdDiscovery)
+ , ("ice-create", cmdIceCreate)
+ , ("ice-destroy", cmdIceDestroy)
+ , ("ice-show", cmdIceShow)
+ , ("ice-connect", cmdIceConnect)
+ , ("ice-send", cmdIceSend)
+#endif
+ , ("select", cmdSelectContext)
+ , ("quit", cmdQuit)
+ ]
+
+commandCompletion :: CompletionFunc IO
+commandCompletion = completeWordWithPrev Nothing [ ' ', '\t', '\n', '\r' ] $ curry $ \case
+ ([], '/':pref) -> return . map (simpleCompletion . ('/':)) . filter (pref `isPrefixOf`) $ sortedCommandNames
+ _ -> return []
+ where
+ sortedCommandNames = sort $ map fst commands
+
+
+cmdUnknown :: String -> Command
+cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd
+
+cmdPeers :: Command
+cmdPeers = do
+ peers <- join $ asks ciPeers
+ set <- asks ciSetContextOptions
+ set $ map (SelectedPeer . fst) peers
+ forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do
+ liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ name
+
+cmdPeerAdd :: Command
+cmdPeerAdd = void $ do
+ server <- asks ciServer
+ (hostname, port) <- (words <$> asks ciLine) >>= \case
+ hostname:p:_ -> return (hostname, p)
+ [hostname] -> return (hostname, show discoveryPort)
+ [] -> throwError "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)
+
+cmdPeerDrop :: Command
+cmdPeerDrop = do
+ dropPeer =<< getSelectedPeer
+ modify $ \s -> s { csContext = NoContext }
+
+showPeer :: PeerIdentity -> PeerAddress -> String
+showPeer pidentity paddr =
+ let name = case pidentity of
+ PeerIdentityUnknown _ -> "<noid>"
+ PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">"
+ PeerIdentityFull pid -> T.unpack $ displayIdentity pid
+ in name ++ " [" ++ show paddr ++ "]"
+
+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"
+
+cmdSend :: Command
+cmdSend = void $ do
+ text <- asks ciLine
+ conv <- getSelectedConversation
+ msg <- sendMessage conv $ T.pack text
+ tzone <- liftIO $ getCurrentTimeZone
+ liftIO $ putStrLn $ formatMessage tzone msg
+
+cmdHistory :: Command
+cmdHistory = void $ do
+ conv <- getSelectedConversation
+ case conversationHistory conv of
+ thread@(_:_) -> do
+ tzone <- liftIO $ getCurrentTimeZone
+ liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 thread
+ [] -> do
+ liftIO $ putStrLn $ "<empty history>"
+
+cmdUpdateIdentity :: Command
+cmdUpdateIdentity = void $ do
+ runReaderT updateSharedIdentity =<< gets csHead
+
+cmdAttach :: Command
+cmdAttach = attachToOwner =<< getSelectedPeer
+
+cmdAttachAccept :: Command
+cmdAttachAccept = attachAccept =<< getSelectedPeer
+
+cmdAttachReject :: Command
+cmdAttachReject = attachReject =<< getSelectedPeer
+
+cmdContacts :: Command
+cmdContacts = do
+ args <- words <$> asks ciLine
+ ehead <- gets csHead
+ let contacts = fromSetBy (comparing contactName) $ lookupSharedValue $ lsShared $ headObject ehead
+ verbose = "-v" `elem` args
+ set <- asks ciSetContextOptions
+ set $ map SelectedContact contacts
+ forM_ (zip [1..] contacts) $ \(i :: Int, c) -> liftIO $ do
+ T.putStrLn $ T.concat
+ [ "[", T.pack (show i), "] ", contactName c
+ , case contactIdentity c of
+ Just idt | cname <- displayIdentity idt
+ , cname /= contactName c
+ -> " (" <> cname <> ")"
+ _ -> ""
+ , if verbose then " " <> (T.unwords $ map (T.decodeUtf8 . showRef . storedRef) $ maybe [] idDataF $ contactIdentity c)
+ else ""
+ ]
+
+cmdContactAdd :: Command
+cmdContactAdd = contactRequest =<< getSelectedPeer
+
+cmdContactAccept :: Command
+cmdContactAccept = contactAccept =<< getSelectedPeer
+
+cmdContactReject :: Command
+cmdContactReject = contactReject =<< getSelectedPeer
+
+cmdConversations :: Command
+cmdConversations = do
+ conversations <- lookupConversations
+ set <- asks ciSetContextOptions
+ set $ map SelectedConversation conversations
+ forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do
+ liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv)
+
+cmdDetails :: Command
+cmdDetails = do
+ gets csContext >>= \case
+ SelectedPeer peer -> do
+ liftIO $ putStr $ 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)
+ PeerIdentityFull pid -> printContactOrIdentityDetails pid
+
+ SelectedContact contact -> do
+ printContactDetails contact
+
+ SelectedConversation conv -> do
+ case conversationPeer conv of
+ Just pid -> printContactOrIdentityDetails pid
+ Nothing -> liftIO $ putStrLn $ "(conversation without peer)"
+
+ NoContext -> liftIO $ putStrLn "nothing selected"
+ where
+ printContactOrIdentityDetails cid = do
+ contacts <- fromSetBy (comparing contactName) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
+ case find (maybe False (sameIdentity cid) . contactIdentity) contacts of
+ Just contact -> printContactDetails contact
+ Nothing -> printIdentityDetails cid
+
+ printContactDetails contact = liftIO $ do
+ putStrLn $ "Contact:"
+ prefix <- case contactCustomName contact of
+ Just name -> do
+ putStrLn $ " " <> T.unpack name
+ return $ Just "alias of"
+ Nothing -> do
+ return $ Nothing
+
+ case contactIdentity contact of
+ Just cid -> do
+ printIdentityDetailsBody prefix cid
+ Nothing -> do
+ putStrLn $ " (without erebos identity)"
+
+ printIdentityDetails identity = liftIO $ do
+ putStrLn $ "Identity:"
+ printIdentityDetailsBody Nothing identity
+
+ printIdentityDetailsBody prefix identity = do
+ forM_ (zip (False : repeat True) $ unfoldOwners identity) $ \(owned, cpid) -> do
+ putStrLn $ 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
+
+ (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") 0
+ 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
+
+cmdIceCreate :: Command
+cmdIceCreate = do
+ role <- asks ciLine >>= return . \case
+ 'm':_ -> PjIceSessRoleControlling
+ 's':_ -> PjIceSessRoleControlled
+ _ -> PjIceSessRoleUnknown
+ eprint <- asks ciPrint
+ sess <- liftIO $ iceCreate role $ eprint <=< iceShow
+ modify $ \s -> s { csIceSessions = sess : csIceSessions s }
+
+cmdIceDestroy :: Command
+cmdIceDestroy = do
+ s:ss <- gets csIceSessions
+ modify $ \st -> st { csIceSessions = ss }
+ liftIO $ iceDestroy s
+
+cmdIceShow :: Command
+cmdIceShow = do
+ sess <- gets csIceSessions
+ eprint <- asks ciPrint
+ liftIO $ forM_ (zip [1::Int ..] sess) $ \(i, s) -> do
+ eprint $ "[" ++ show i ++ "]"
+ eprint =<< iceShow s
+
+cmdIceConnect :: Command
+cmdIceConnect = do
+ s:_ <- gets csIceSessions
+ server <- asks ciServer
+ let loadInfo = BC.getLine >>= \case line | BC.null line -> return []
+ | otherwise -> (line:) <$> loadInfo
+ Right remote <- liftIO $ do
+ st <- memoryStorage
+ pst <- derivePartialStorage st
+ rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo
+ copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes)
+ liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s
+
+cmdIceSend :: Command
+cmdIceSend = void $ do
+ s:_ <- gets csIceSessions
+ server <- asks ciServer
+ liftIO $ serverPeerIce server s
+
+#endif
+
+cmdQuit :: Command
+cmdQuit = modify $ \s -> s { csQuit = True }
diff --git a/main/Test.hs b/main/Test.hs
new file mode 100644
index 0000000..cdc337e
--- /dev/null
+++ b/main/Test.hs
@@ -0,0 +1,683 @@
+module Test (
+ runTestTool,
+) where
+
+import Control.Arrow
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.State
+
+import Crypto.Random
+
+import Data.ByteString qualified as B
+import Data.ByteString.Char8 qualified as BC
+import Data.ByteString.Lazy qualified as BL
+import Data.Foldable
+import Data.Ord
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.Encoding
+import Data.Text.IO qualified as T
+import Data.Typeable
+
+import Network.Socket
+
+import System.IO
+import System.IO.Error
+
+import Erebos.Attach
+import Erebos.Chatroom
+import Erebos.Contact
+import Erebos.Identity
+import Erebos.Message
+import Erebos.Network
+import Erebos.Pairing
+import Erebos.PubKey
+import Erebos.Service
+import Erebos.Set
+import Erebos.State
+import Erebos.Storage
+import Erebos.Storage.Internal (unsafeStoreRawBytes)
+import Erebos.Storage.Merge
+import Erebos.Sync
+
+import Test.Service
+
+
+data TestState = TestState
+ { tsHead :: Maybe (Head LocalState)
+ , tsServer :: Maybe RunningServer
+ , tsWatchedLocalIdentity :: Maybe WatchedHead
+ , tsWatchedSharedIdentity :: Maybe WatchedHead
+ }
+
+data RunningServer = RunningServer
+ { rsServer :: Server
+ , rsPeers :: MVar (Int, [(Int, Peer)])
+ , rsPeerThread :: ThreadId
+ }
+
+initTestState :: TestState
+initTestState = TestState
+ { tsHead = Nothing
+ , tsServer = Nothing
+ , tsWatchedLocalIdentity = Nothing
+ , tsWatchedSharedIdentity = Nothing
+ }
+
+data TestInput = TestInput
+ { tiOutput :: Output
+ , tiStorage :: Storage
+ , tiParams :: [Text]
+ }
+
+
+runTestTool :: Storage -> IO ()
+runTestTool st = do
+ out <- newMVar ()
+ let testLoop = getLineMb >>= \case
+ Just line -> do
+ case T.words line of
+ (cname:params)
+ | Just (CommandM cmd) <- lookup cname commands -> do
+ runReaderT cmd $ TestInput out st params
+ | otherwise -> fail $ "Unknown command '" ++ T.unpack cname ++ "'"
+ [] -> return ()
+ testLoop
+
+ Nothing -> return ()
+
+ runExceptT (evalStateT testLoop initTestState) >>= \case
+ Left x -> hPutStrLn stderr x
+ Right () -> return ()
+
+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
+ _ -> return []
+
+getHead :: CommandM (Head LocalState)
+getHead = do
+ h <- maybe (fail "failed to reload head") return =<< maybe (fail "no current head") reloadHead =<< gets tsHead
+ modify $ \s -> s { tsHead = Just h }
+ return h
+
+
+type Output = MVar ()
+
+outLine :: Output -> String -> IO ()
+outLine mvar line = do
+ evaluate $ foldl' (flip seq) () line
+ withMVar mvar $ \() -> do
+ putStrLn line
+ hFlush stdout
+
+cmdOut :: String -> Command
+cmdOut line = do
+ out <- asks tiOutput
+ liftIO $ outLine out line
+
+
+getPeer :: Text -> CommandM Peer
+getPeer spidx = do
+ Just RunningServer {..} <- gets tsServer
+ Just peer <- lookup (read $ T.unpack spidx) . snd <$> liftIO (readMVar rsPeers)
+ return peer
+
+getPeerIndex :: MVar (Int, [(Int, Peer)]) -> ServiceHandler (PairingService a) Int
+getPeerIndex pmvar = do
+ peer <- asks svcPeer
+ maybe 0 fst . find ((==peer) . snd) . snd <$> liftIO (readMVar pmvar)
+
+pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar (Int, [(Int, Peer)]) -> String -> PairingAttributes a
+pairingAttributes _ out peers prefix = PairingAttributes
+ { pairingHookRequest = return ()
+
+ , pairingHookResponse = \confirm -> do
+ index <- show <$> getPeerIndex peers
+ afterCommit $ outLine out $ unwords [prefix ++ "-response", index, confirm]
+
+ , pairingHookRequestNonce = \confirm -> do
+ index <- show <$> getPeerIndex peers
+ afterCommit $ outLine out $ unwords [prefix ++ "-request", index, confirm]
+
+ , pairingHookRequestNonceFailed = failed "nonce"
+
+ , pairingHookConfirmedResponse = return ()
+ , pairingHookConfirmedRequest = return ()
+
+ , pairingHookAcceptedResponse = do
+ index <- show <$> getPeerIndex peers
+ afterCommit $ outLine out $ unwords [prefix ++ "-response-done", index]
+
+ , pairingHookAcceptedRequest = do
+ index <- show <$> getPeerIndex peers
+ afterCommit $ outLine out $ unwords [prefix ++ "-request-done", index]
+
+ , pairingHookFailed = \case
+ PairingUserRejected -> failed "user"
+ PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet
+ PairingFailedOther str -> failed $ "other " ++ str
+ , pairingHookVerifyFailed = failed "verify"
+ , pairingHookRejected = failed "rejected"
+ }
+ where
+ failed :: PairingResult a => String -> ServiceHandler (PairingService a) ()
+ failed detail = do
+ ptype <- svcGet >>= return . \case
+ OurRequest {} -> "response"
+ OurRequestConfirm {} -> "response"
+ OurRequestReady -> "response"
+ PeerRequest {} -> "request"
+ PeerRequestConfirm -> "request"
+ _ -> fail "unexpected pairing state"
+
+ index <- show <$> getPeerIndex peers
+ afterCommit $ outLine out $ prefix ++ "-" ++ ptype ++ "-failed " ++ index ++ " " ++ detail
+
+ strState :: PairingState a -> String
+ strState = \case
+ NoPairing -> "none"
+ OurRequest {} -> "our-request"
+ OurRequestConfirm {} -> "our-request-confirm"
+ OurRequestReady -> "our-request-ready"
+ PeerRequest {} -> "peer-request"
+ PeerRequestConfirm -> "peer-request-confirm"
+ PairingDone -> "done"
+
+ strPacket :: PairingService a -> String
+ strPacket = \case
+ PairingRequest {} -> "request"
+ PairingResponse {} -> "response"
+ PairingRequestNonce {} -> "nonce"
+ PairingAccept {} -> "accept"
+ PairingReject -> "reject"
+
+directMessageAttributes :: Output -> DirectMessageAttributes
+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
+ ]
+
+
+newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a)
+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String)
+
+instance MonadFail CommandM where
+ fail = throwError
+
+instance MonadRandom CommandM where
+ getRandomBytes = liftIO . getRandomBytes
+
+instance MonadStorage CommandM where
+ getStorage = asks tiStorage
+
+instance MonadHead LocalState CommandM where
+ updateLocalHead f = do
+ Just h <- gets tsHead
+ (Just h', x) <- maybe (fail "failed to reload head") (flip updateHead f) =<< reloadHead h
+ modify $ \s -> s { tsHead = Just h' }
+ return x
+
+type Command = CommandM ()
+
+commands :: [(Text, Command)]
+commands = map (T.pack *** id)
+ [ ("store", cmdStore)
+ , ("stored-generation", cmdStoredGeneration)
+ , ("stored-roots", cmdStoredRoots)
+ , ("stored-set-add", cmdStoredSetAdd)
+ , ("stored-set-list", cmdStoredSetList)
+ , ("create-identity", cmdCreateIdentity)
+ , ("start-server", cmdStartServer)
+ , ("stop-server", cmdStopServer)
+ , ("peer-add", cmdPeerAdd)
+ , ("peer-drop", cmdPeerDrop)
+ , ("peer-list", cmdPeerList)
+ , ("test-message-send", cmdTestMessageSend)
+ , ("shared-state-get", cmdSharedStateGet)
+ , ("shared-state-wait", cmdSharedStateWait)
+ , ("watch-local-identity", cmdWatchLocalIdentity)
+ , ("watch-shared-identity", cmdWatchSharedIdentity)
+ , ("update-local-identity", cmdUpdateLocalIdentity)
+ , ("update-shared-identity", cmdUpdateSharedIdentity)
+ , ("attach-to", cmdAttachTo)
+ , ("attach-accept", cmdAttachAccept)
+ , ("attach-reject", cmdAttachReject)
+ , ("contact-request", cmdContactRequest)
+ , ("contact-accept", cmdContactAccept)
+ , ("contact-reject", cmdContactReject)
+ , ("contact-list", cmdContactList)
+ , ("contact-set-name", cmdContactSetName)
+ , ("dm-send-peer", cmdDmSendPeer)
+ , ("dm-send-contact", cmdDmSendContact)
+ , ("dm-list-peer", cmdDmListPeer)
+ , ("dm-list-contact", cmdDmListContact)
+ , ("chatroom-create", cmdChatroomCreate)
+ , ("chatroom-list-local", cmdChatroomListLocal)
+ , ("chatroom-watch-local", cmdChatroomWatchLocal)
+ , ("chatroom-set-name", cmdChatroomSetName)
+ , ("chatroom-message-send", cmdChatroomMessageSend)
+ ]
+
+cmdStore :: Command
+cmdStore = do
+ st <- asks tiStorage
+ [otype] <- asks tiParams
+ ls <- getLines
+
+ let cnt = encodeUtf8 $ T.unlines ls
+ ref <- liftIO $ unsafeStoreRawBytes st $ BL.fromChunks [encodeUtf8 otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt]
+ cmdOut $ "store-done " ++ show (refDigest ref)
+
+cmdStoredGeneration :: Command
+cmdStoredGeneration = do
+ st <- asks tiStorage
+ [tref] <- asks tiParams
+ Just ref <- liftIO $ readRef st (encodeUtf8 tref)
+ cmdOut $ "stored-generation " ++ T.unpack tref ++ " " ++ showGeneration (storedGeneration $ wrappedLoad @Object ref)
+
+cmdStoredRoots :: Command
+cmdStoredRoots = do
+ st <- asks tiStorage
+ [tref] <- asks tiParams
+ Just ref <- liftIO $ readRef st (encodeUtf8 tref)
+ cmdOut $ "stored-roots " ++ T.unpack tref ++ concatMap ((' ':) . show . refDigest . storedRef) (storedRoots $ wrappedLoad @Object ref)
+
+cmdStoredSetAdd :: Command
+cmdStoredSetAdd = do
+ st <- asks tiStorage
+ (item, set) <- asks tiParams >>= liftIO . mapM (readRef st . encodeUtf8) >>= \case
+ [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
+ cmdOut $ "stored-set-add" ++ concatMap ((' ':) . show . refDigest . storedRef) (toComponents set')
+
+cmdStoredSetList :: Command
+cmdStoredSetList = do
+ st <- asks tiStorage
+ [tref] <- asks tiParams
+ Just ref <- liftIO $ readRef st (encodeUtf8 tref)
+ let items = fromSetBy compare $ loadSet @[Stored Object] ref
+ forM_ items $ \item -> do
+ cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item
+ cmdOut $ "stored-set-done"
+
+initTestHead :: Head LocalState -> Command
+initTestHead h = do
+ _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput
+ modify $ \s -> s { tsHead = Just h }
+
+loadTestHead :: CommandM (Head LocalState)
+loadTestHead = do
+ st <- asks tiStorage
+ h <- loadHeads st >>= \case
+ h : _ -> return h
+ [] -> fail "no local head found"
+ initTestHead h
+ return h
+
+getOrLoadHead :: CommandM (Head LocalState)
+getOrLoadHead = do
+ gets tsHead >>= \case
+ Just h -> return h
+ Nothing -> loadTestHead
+
+cmdCreateIdentity :: Command
+cmdCreateIdentity = do
+ st <- asks tiStorage
+ names <- asks tiParams
+
+ h <- liftIO $ do
+ Just identity <- if null names
+ then Just <$> createIdentity st Nothing Nothing
+ else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names
+
+ shared <- case names of
+ _:_:_ -> (:[]) <$> makeSharedStateUpdate st (Just $ finalOwner identity) []
+ _ -> return []
+
+ storeHead st $ LocalState
+ { lsIdentity = idExtData identity
+ , lsShared = shared
+ }
+ initTestHead h
+
+cmdStartServer :: Command
+cmdStartServer = do
+ out <- asks tiOutput
+
+ h <- getOrLoadHead
+ rsPeers <- liftIO $ newMVar (1, [])
+ rsServer <- liftIO $ startServer defaultServerOptions h (hPutStrLn stderr)
+ [ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach"
+ , someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact"
+ , someServiceAttr $ directMessageAttributes out
+ , someService @SyncService Proxy
+ , someService @ChatroomService Proxy
+ , someServiceAttr $ (defaultServiceAttributes Proxy)
+ { testMessageReceived = \otype len sref ->
+ liftIO $ outLine out $ unwords ["test-message-received", otype, len, sref]
+ }
+ ]
+
+ 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)
+
+ modifyMVar_ rsPeers update
+
+ modify $ \s -> s { tsServer = Just RunningServer {..} }
+
+cmdStopServer :: Command
+cmdStopServer = do
+ Just RunningServer {..} <- gets tsServer
+ liftIO $ do
+ killThread rsPeerThread
+ stopServer rsServer
+ modify $ \s -> s { tsServer = Nothing }
+ cmdOut "stop-server-done"
+
+cmdPeerAdd :: Command
+cmdPeerAdd = do
+ Just RunningServer {..} <- gets tsServer
+ host:rest <- map T.unpack <$> asks tiParams
+
+ let port = case rest of [] -> show discoveryPort
+ (p:_) -> p
+ addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just host) (Just port)
+ void $ liftIO $ serverPeer rsServer (addrAddress addr)
+
+cmdPeerDrop :: Command
+cmdPeerDrop = do
+ [spidx] <- asks tiParams
+ peer <- getPeer spidx
+ liftIO $ dropPeer peer
+
+cmdPeerList :: Command
+cmdPeerList = do
+ Just RunningServer {..} <- gets tsServer
+ peers <- liftIO $ getCurrentPeerList rsServer
+ tpeers <- liftIO $ readMVar rsPeers
+ forM_ peers $ \peer -> do
+ Just (n, _) <- return $ find ((peer==).snd) . snd $ tpeers
+ mbpid <- peerIdentity peer
+ cmdOut $ unwords $ concat
+ [ [ "peer-list-item", show n ]
+ , [ "addr", show (peerAddress peer) ]
+ , case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid)
+ _ -> []
+ ]
+ cmdOut "peer-list-done"
+
+
+cmdTestMessageSend :: Command
+cmdTestMessageSend = do
+ [spidx, tref] <- asks tiParams
+ st <- asks tiStorage
+ Just ref <- liftIO $ readRef st (encodeUtf8 tref)
+ peer <- getPeer spidx
+ sendToPeer peer $ TestMessage $ wrappedLoad ref
+ cmdOut "test-message-send done"
+
+cmdSharedStateGet :: Command
+cmdSharedStateGet = do
+ h <- getHead
+ cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h)
+
+cmdSharedStateWait :: Command
+cmdSharedStateWait = do
+ st <- asks tiStorage
+ out <- asks tiOutput
+ h <- getOrLoadHead
+ trefs <- asks tiParams
+
+ liftIO $ do
+ mvar <- newEmptyMVar
+ w <- watchHeadWith h (lsShared . headObject) $ \cur -> do
+ mbobjs <- mapM (readRef st . encodeUtf8) trefs
+ case map wrappedLoad <$> sequence mbobjs of
+ Just objs | filterAncestors (cur ++ objs) == cur -> do
+ outLine out $ unwords $ "shared-state-wait" : map T.unpack trefs
+ void $ forkIO $ unwatchHead =<< takeMVar mvar
+ _ -> return ()
+ putMVar mvar w
+
+cmdWatchLocalIdentity :: Command
+cmdWatchLocalIdentity = do
+ h <- getOrLoadHead
+ Nothing <- gets tsWatchedLocalIdentity
+
+ out <- asks tiOutput
+ w <- liftIO $ watchHeadWith h headLocalIdentity $ \idt -> do
+ outLine out $ unwords $ "local-identity" : map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners idt)
+ modify $ \s -> s { tsWatchedLocalIdentity = Just w }
+
+cmdWatchSharedIdentity :: Command
+cmdWatchSharedIdentity = do
+ h <- getOrLoadHead
+ Nothing <- gets tsWatchedSharedIdentity
+
+ out <- asks tiOutput
+ w <- liftIO $ watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \case
+ Just (idt :: ComposedIdentity) -> do
+ outLine out $ unwords $ "shared-identity" : map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners idt)
+ Nothing -> do
+ outLine out $ "shared-identity-failed"
+ modify $ \s -> s { tsWatchedSharedIdentity = Just w }
+
+cmdUpdateLocalIdentity :: Command
+cmdUpdateLocalIdentity = do
+ [name] <- asks tiParams
+ updateLocalHead_ $ \ls -> do
+ Just identity <- return $ validateExtendedIdentity $ lsIdentity $ fromStored ls
+ let public = idKeyIdentity identity
+
+ secret <- loadKey public
+ nidata <- maybe (error "created invalid identity") (return . idExtData) . validateExtendedIdentity =<<
+ mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData identity)
+ { idePrev = toList $ idExtDataF identity
+ , ideName = Just name
+ }
+ mstore (fromStored ls) { lsIdentity = nidata }
+
+cmdUpdateSharedIdentity :: Command
+cmdUpdateSharedIdentity = do
+ [name] <- asks tiParams
+ updateLocalHead_ $ updateSharedState_ $ \case
+ Nothing -> throwError "no existing shared identity"
+ Just identity -> do
+ let public = idKeyIdentity identity
+ secret <- loadKey public
+ uidentity <- mergeIdentity identity
+ maybe (error "created invalid identity") (return . Just . toComposedIdentity) . validateExtendedIdentity =<<
+ mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData uidentity)
+ { idePrev = toList $ idExtDataF identity
+ , ideName = Just name
+ }
+
+cmdAttachTo :: Command
+cmdAttachTo = do
+ [spidx] <- asks tiParams
+ attachToOwner =<< getPeer spidx
+
+cmdAttachAccept :: Command
+cmdAttachAccept = do
+ [spidx] <- asks tiParams
+ attachAccept =<< getPeer spidx
+
+cmdAttachReject :: Command
+cmdAttachReject = do
+ [spidx] <- asks tiParams
+ attachReject =<< getPeer spidx
+
+cmdContactRequest :: Command
+cmdContactRequest = do
+ [spidx] <- asks tiParams
+ contactRequest =<< getPeer spidx
+
+cmdContactAccept :: Command
+cmdContactAccept = do
+ [spidx] <- asks tiParams
+ contactAccept =<< getPeer spidx
+
+cmdContactReject :: Command
+cmdContactReject = do
+ [spidx] <- asks tiParams
+ contactReject =<< getPeer spidx
+
+cmdContactList :: Command
+cmdContactList = do
+ h <- getHead
+ let contacts = fromSetBy (comparing contactName) . lookupSharedValue . lsShared . headObject $ h
+ forM_ contacts $ \c -> do
+ r:_ <- return $ filterAncestors $ concatMap storedRoots $ toComponents c
+ cmdOut $ concat
+ [ "contact-list-item "
+ , show $ refDigest $ storedRef r
+ , " "
+ , T.unpack $ contactName c
+ , case contactIdentity c of Nothing -> ""; Just idt -> " " ++ T.unpack (displayIdentity idt)
+ ]
+ cmdOut "contact-list-done"
+
+getContact :: Text -> CommandM Contact
+getContact cid = do
+ h <- getHead
+ let contacts = fromSetBy (comparing contactName) . lookupSharedValue . lsShared . headObject $ h
+ [contact] <- flip filterM contacts $ \c -> do
+ r:_ <- return $ filterAncestors $ concatMap storedRoots $ toComponents c
+ return $ T.pack (show $ refDigest $ storedRef r) == cid
+ return contact
+
+cmdContactSetName :: Command
+cmdContactSetName = do
+ [cid, name] <- asks tiParams
+ contact <- getContact cid
+ updateLocalHead_ $ updateSharedState_ $ contactSetName contact name
+ cmdOut "contact-set-name-done"
+
+cmdDmSendPeer :: Command
+cmdDmSendPeer = do
+ [spidx, msg] <- asks tiParams
+ PeerIdentityFull to <- peerIdentity =<< getPeer spidx
+ void $ sendDirectMessage to msg
+
+cmdDmSendContact :: Command
+cmdDmSendContact = do
+ [cid, msg] <- asks tiParams
+ Just to <- contactIdentity <$> getContact cid
+ void $ sendDirectMessage to msg
+
+dmList :: Foldable f => Identity f -> Command
+dmList peer = do
+ threads <- toThreadList . lookupSharedValue . lsShared . headObject <$> getHead
+ case find (sameIdentity peer . msgPeer) threads of
+ Just thread -> do
+ forM_ (reverse $ threadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item"
+ <> " from " <> (maybe "<unnamed>" T.unpack $ idName msgFrom)
+ <> " text " <> (T.unpack msgText)
+ Nothing -> return ()
+ cmdOut "dm-list-done"
+
+cmdDmListPeer :: Command
+cmdDmListPeer = do
+ [spidx] <- asks tiParams
+ PeerIdentityFull to <- peerIdentity =<< getPeer spidx
+ dmList to
+
+cmdDmListContact :: Command
+cmdDmListContact = do
+ [cid] <- asks tiParams
+ Just to <- contactIdentity <$> getContact cid
+ dmList to
+
+cmdChatroomCreate :: Command
+cmdChatroomCreate = do
+ [name] <- asks tiParams
+ room <- createChatroom (Just name) Nothing
+ cmdOut $ unwords $ "chatroom-create-done" : chatroomInfo room
+
+getChatroomStateData :: Text -> CommandM (Stored ChatroomStateData)
+getChatroomStateData tref = do
+ st <- asks tiStorage
+ Just ref <- liftIO $ readRef st (encodeUtf8 tref)
+ return $ wrappedLoad ref
+
+cmdChatroomSetName :: Command
+cmdChatroomSetName = do
+ [cid, name] <- asks tiParams
+ sdata <- getChatroomStateData cid
+ updateChatroomByStateData sdata (Just name) Nothing >>= \case
+ Just room -> cmdOut $ unwords $ "chatroom-set-name-done" : chatroomInfo room
+ Nothing -> cmdOut "chatroom-set-name-failed"
+
+cmdChatroomListLocal :: Command
+cmdChatroomListLocal = do
+ [] <- asks tiParams
+ rooms <- listChatrooms
+ forM_ rooms $ \room -> do
+ cmdOut $ unwords $ "chatroom-list-item" : chatroomInfo room
+ cmdOut "chatroom-list-done"
+
+cmdChatroomWatchLocal :: Command
+cmdChatroomWatchLocal = do
+ [] <- asks tiParams
+ h <- getHead
+ out <- asks tiOutput
+ void $ watchChatrooms h $ \_ -> \case
+ Nothing -> return ()
+ Just diff -> forM_ diff $ \case
+ AddedChatroom room -> outLine out $ unwords $ "chatroom-watched-added" : chatroomInfo room
+ RemovedChatroom room -> outLine out $ unwords $ "chatroom-watched-removed" : chatroomInfo room
+ UpdatedChatroom oldroom room -> do
+ when (any (not . null . rsdRoom . fromStored) (roomStateData room)) $ do
+ outLine out $ unwords $ concat
+ [ [ "chatroom-watched-updated" ], chatroomInfo room
+ , [ "old" ], map (show . refDigest . storedRef) (roomStateData oldroom)
+ , [ "new" ], map (show . refDigest . storedRef) (roomStateData room)
+ ]
+ when (any (not . null . rsdMessages . fromStored) (roomStateData room)) $ do
+ forM_ (getMessagesSinceState room oldroom) $ \msg -> do
+ outLine out $ unwords $ concat
+ [ [ "chatroom-message-new" ]
+ , [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room ]
+ , [ "from", maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg ]
+ , maybe [] (("text":) . (:[]) . T.unpack) $ cmsgText msg
+ ]
+
+chatroomInfo :: ChatroomState -> [String]
+chatroomInfo room =
+ [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room
+ , maybe "<unnamed>" T.unpack $ roomName =<< roomStateRoom room
+ ]
+
+cmdChatroomMessageSend :: Command
+cmdChatroomMessageSend = do
+ [cid, msg] <- asks tiParams
+ to <- getChatroomStateData cid
+ void $ chatroomMessageByStateData to msg
diff --git a/main/Test/Service.hs b/main/Test/Service.hs
new file mode 100644
index 0000000..1018e0d
--- /dev/null
+++ b/main/Test/Service.hs
@@ -0,0 +1,36 @@
+module Test.Service (
+ TestMessage(..),
+ TestMessageAttributes(..),
+) where
+
+import Control.Monad.Reader
+
+import Data.ByteString.Lazy.Char8 qualified as BL
+
+import Erebos.Network
+import Erebos.Service
+import Erebos.Storage
+
+data TestMessage = TestMessage (Stored Object)
+
+data TestMessageAttributes = TestMessageAttributes
+ { testMessageReceived :: String -> String -> String -> ServiceHandler TestMessage ()
+ }
+
+instance Storable TestMessage where
+ store' (TestMessage msg) = store' msg
+ load' = TestMessage <$> load'
+
+instance Service TestMessage where
+ serviceID _ = mkServiceID "cb46b92c-9203-4694-8370-8742d8ac9dc8"
+
+ type ServiceAttributes TestMessage = TestMessageAttributes
+ defaultServiceAttributes _ = TestMessageAttributes (\_ _ _ -> return ())
+
+ serviceHandler smsg = do
+ let TestMessage sobj = fromStored smsg
+ case map BL.unpack $ BL.words $ BL.takeWhile (/='\n') $ serializeObject $ fromStored sobj of
+ [otype, len] -> do
+ cb <- asks $ testMessageReceived . svcAttributes
+ cb otype len (show $ refDigest $ storedRef sobj)
+ _ -> return ()
diff --git a/main/Version.hs b/main/Version.hs
new file mode 100644
index 0000000..71af694
--- /dev/null
+++ b/main/Version.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- "Pattern match is redundant" warning can be generated based on template
+-- haskell $$tGitVersion value
+{-# OPTIONS_GHC -Wno-error=overlapping-patterns #-}
+
+module Version (
+ versionLine,
+) where
+
+import Paths_erebos (version)
+import Data.Version (showVersion)
+import Version.Git
+
+{-# NOINLINE versionLine #-}
+versionLine :: String
+versionLine = do
+ let ver = case $$tGitVersion of
+ Just gver
+ | 'v':v <- gver, not $ all (`elem` ('.': ['0'..'9'])) v
+ -> "git " <> gver
+ _ -> "version " <> showVersion version
+ in "Erebos CLI " <> ver
diff --git a/main/Version/Git.hs b/main/Version/Git.hs
new file mode 100644
index 0000000..2aae6e3
--- /dev/null
+++ b/main/Version/Git.hs
@@ -0,0 +1,31 @@
+module Version.Git (
+ tGitVersion,
+) where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+import System.Directory
+import System.Exit
+import System.Process
+
+tGitVersion :: Code Q (Maybe String)
+tGitVersion = unsafeCodeCoerce $ do
+ let git args = do
+ (ExitSuccess, out, _) <- readCreateProcessWithExitCode
+ (proc "git" $ [ "--git-dir=./.git", "--work-tree=." ] ++ args) ""
+ return $ lines out
+
+ mbver <- runIO $ do
+ doesPathExist "./.git" >>= \case
+ False -> return Nothing
+ True -> do
+ desc:_ <- git [ "describe", "--always", "--dirty= (dirty)" ]
+ files <- git [ "ls-files" ]
+ return $ Just (desc, files)
+
+ case mbver of
+ Just (_, files) -> mapM_ addDependentFile files
+ Nothing -> return ()
+
+ lift (fst <$> mbver :: Maybe String)
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-08 22:23:49 +0000