summaryrefslogtreecommitdiff
path: root/main
diff options
context:
space:
mode:
Diffstat (limited to 'main')
-rw-r--r--main/Main.hs904
-rw-r--r--main/Test.hs785
-rw-r--r--main/Test/Service.hs36
-rw-r--r--main/Version.hs23
-rw-r--r--main/Version/Git.hs31
5 files changed, 1779 insertions, 0 deletions
diff --git a/main/Main.hs b/main/Main.hs
new file mode 100644
index 0000000..94c0418
--- /dev/null
+++ b/main/Main.hs
@@ -0,0 +1,904 @@
+{-# 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.Format
+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.Chatroom
+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]
+ , optStorage :: StorageOption
+ , optChatroomAutoSubscribe :: Maybe Int
+ , optDmBotEcho :: Maybe Text
+ , optShowHelp :: Bool
+ , optShowVersion :: Bool
+ }
+
+data StorageOption = DefaultStorage
+ | FilesystemStorage FilePath
+ | MemoryStorage
+
+data ServiceOption = ServiceOption
+ { soptName :: String
+ , soptService :: SomeService
+ , soptEnabled :: Bool
+ , soptDescription :: String
+ }
+
+defaultOptions :: Options
+defaultOptions = Options
+ { optServer = defaultServerOptions
+ , optServices = availableServices
+ , optStorage = DefaultStorage
+ , optChatroomAutoSubscribe = Nothing
+ , 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 "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)]
+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 [] [ "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"
+ , 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
+ (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 . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR"
+ 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"
+ 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 validateExtendedIdentityF (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) $ idExtDataF 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
+
+ [] -> 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
+
+
+inputSettings :: Settings IO
+inputSettings = setComplete commandCompletion $ defaultSettings
+
+interactiveLoop :: Storage -> Options -> IO ()
+interactiveLoop st opts = runInputT inputSettings $ do
+ erebosHead <- liftIO $ loadLocalStateHead st
+ outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead
+
+ tui <- haveTerminalUI
+ extPrint <- getExternalPrint
+ let extPrintLn str = do
+ let str' = case reverse str of ('\n':_) -> str
+ _ -> str ++ "\n";
+ extPrint $! str' -- evaluate str before calling extPrint to avoid blinking
+
+ let getInputLinesTui eprompt = do
+ 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
+ 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
+
+ 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
+
+ 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
+
+ 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
+ , 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
+ 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
+ , csWatchChatrooms = watched
+ , csQuit = False
+ }
+
+
+data CommandInput = CommandInput
+ { ciServer :: Server
+ , 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
+ { 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
+
+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"
+
+getSelectedChatroom :: CommandM ChatroomState
+getSelectedChatroom = gets csContext >>= \case
+ SelectedChatroom rstate -> return rstate
+ _ -> throwError "no chatroom 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"
+ SelectedChatroom rstate ->
+ chatroomConversation rstate >>= \case
+ Just conv -> return conv
+ Nothing -> throwError "invalid chatroom"
+ 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)
+ , ("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)
+ , ("ice-create", cmdIceCreate)
+ , ("ice-destroy", cmdIceDestroy)
+ , ("ice-show", cmdIceShow)
+ , ("ice-connect", cmdIceConnect)
+ , ("ice-send", cmdIceSend)
+#endif
+ , ("join", cmdJoin)
+ , ("leave", cmdLeave)
+ , ("members", cmdMembers)
+ , ("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 ++ "]"
+
+cmdJoin :: Command
+cmdJoin = joinChatroom =<< getSelectedChatroom
+
+cmdLeave :: Command
+cmdLeave = leaveChatroom =<< getSelectedChatroom
+
+cmdMembers :: Command
+cmdMembers = do
+ Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom
+ forM_ (chatroomMembers room) $ \x -> do
+ liftIO $ putStrLn $ maybe "<unnamed>" T.unpack $ idName x
+
+
+cmdSelectContext :: Command
+cmdSelectContext = do
+ n <- read <$> asks ciLine
+ join (asks ciContextOptions) >>= \ctxs -> if
+ | n > 0, (ctx : _) <- drop (n - 1) ctxs -> do
+ modify $ \s -> s { csContext = ctx }
+ case ctx of
+ SelectedChatroom rstate -> do
+ when (not (roomStateSubscribe rstate)) $ do
+ chatroomSetSubscribe (head $ roomStateData rstate) True
+ _ -> return ()
+ | otherwise -> throwError "invalid index"
+
+cmdSend :: Command
+cmdSend = void $ do
+ text <- asks ciLine
+ conv <- getSelectedConversation
+ sendMessage conv (T.pack text) >>= \case
+ Just msg -> do
+ tzone <- liftIO $ getCurrentTimeZone
+ liftIO $ putStrLn $ formatMessage tzone msg
+ Nothing -> return ()
+
+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
+
+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 = 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 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 <- fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar)
+ set <- asks ciSetContextOptions
+ set $ map SelectedChatroom chatroomList
+ forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do
+ liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate)
+
+cmdChatroomCreatePublic :: Command
+cmdChatroomCreatePublic = do
+ name <- asks ciLine >>= \case
+ line | not (null line) -> return $ T.pack line
+ _ -> liftIO $ do
+ T.putStr $ T.pack "Name: "
+ hFlush stdout
+ T.getLine
+
+ ensureWatchedChatrooms
+ void $ createChatroom
+ (if T.null name then Nothing else Just name)
+ Nothing
+
+
+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
+
+ SelectedChatroom rstate -> do
+ liftIO $ putStrLn $ "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)"
+
+ 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 }
+
+
+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
diff --git a/main/Test.hs b/main/Test.hs
new file mode 100644
index 0000000..c6448b8
--- /dev/null
+++ b/main/Test.hs
@@ -0,0 +1,785 @@
+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.Bool
+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 Data.UUID qualified as U
+
+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
+ , tsWatchedHeads :: [ ( Int, WatchedHead ) ]
+ , tsWatchedHeadNext :: Int
+ , 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
+ , tsWatchedHeads = []
+ , tsWatchedHeadNext = 1
+ , 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 -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack 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
+ B.putStr $ (`BC.snoc` '\n') $ BC.pack 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)
+ , ("head-create", cmdHeadCreate)
+ , ("head-replace", cmdHeadReplace)
+ , ("head-watch", cmdHeadWatch)
+ , ("head-unwatch", cmdHeadUnwatch)
+ , ("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-subscribe", cmdChatroomSubscribe)
+ , ("chatroom-unsubscribe", cmdChatroomUnsubscribe)
+ , ("chatroom-members", cmdChatroomMembers)
+ , ("chatroom-join", cmdChatroomJoin)
+ , ("chatroom-leave", cmdChatroomLeave)
+ , ("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"
+
+cmdHeadCreate :: Command
+cmdHeadCreate = do
+ [ ttid, tref ] <- asks tiParams
+ st <- asks tiStorage
+ Just tid <- return $ fromUUID <$> U.fromText ttid
+ Just ref <- liftIO $ readRef st (encodeUtf8 tref)
+
+ h <- storeHeadRaw st tid ref
+ cmdOut $ unwords $ [ "head-create-done", show (toUUID tid), show (toUUID h) ]
+
+cmdHeadReplace :: Command
+cmdHeadReplace = do
+ [ ttid, thid, told, tnew ] <- asks tiParams
+ st <- asks tiStorage
+ Just tid <- return $ fmap fromUUID $ U.fromText ttid
+ Just hid <- return $ fmap fromUUID $ U.fromText thid
+ Just old <- liftIO $ readRef st (encodeUtf8 told)
+ Just new <- liftIO $ readRef st (encodeUtf8 tnew)
+
+ replaceHeadRaw st tid hid old new >>= cmdOut . unwords . \case
+ Left Nothing -> [ "head-replace-fail", T.unpack ttid, T.unpack thid, T.unpack told, T.unpack tnew ]
+ Left (Just r) -> [ "head-replace-fail", T.unpack ttid, T.unpack thid, T.unpack told, T.unpack tnew, show (refDigest r) ]
+ Right _ -> [ "head-replace-done", T.unpack ttid, T.unpack thid, T.unpack told, T.unpack tnew ]
+
+cmdHeadWatch :: Command
+cmdHeadWatch = do
+ [ ttid, thid ] <- asks tiParams
+ st <- asks tiStorage
+ Just tid <- return $ fmap fromUUID $ U.fromText ttid
+ Just hid <- return $ fmap fromUUID $ U.fromText thid
+
+ out <- asks tiOutput
+ wid <- gets tsWatchedHeadNext
+
+ watched <- liftIO $ watchHeadRaw st tid hid id $ \r -> do
+ outLine out $ unwords [ "head-watch-cb", show wid, show $ refDigest r ]
+
+ modify $ \s -> s
+ { tsWatchedHeads = ( wid, watched ) : tsWatchedHeads s
+ , tsWatchedHeadNext = wid + 1
+ }
+
+ cmdOut $ unwords $ [ "head-watch-done", T.unpack ttid, T.unpack thid, show wid ]
+
+cmdHeadUnwatch :: Command
+cmdHeadUnwatch = do
+ [ twid ] <- asks tiParams
+ let wid = read (T.unpack twid)
+ Just watched <- lookup wid <$> gets tsWatchedHeads
+ liftIO $ unwatchHead watched
+ cmdOut $ unwords [ "head-unwatch-done", show wid ]
+
+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 (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack)
+ [ 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 : trefs <- asks tiParams
+ st <- asks tiStorage
+ Just refs <- liftIO $ fmap sequence $ mapM (readRef st . encodeUtf8) trefs
+ peer <- getPeer spidx
+ sendManyToPeer peer $ map (TestMessage . wrappedLoad) refs
+ 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 ((\rsd -> not (null (rsdRoom rsd)) || not (null (rsdSubscribe rsd))) . 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_ (reverse $ getMessagesSinceState room oldroom) $ \msg -> do
+ outLine out $ unwords $ concat
+ [ [ "chatroom-message-new" ]
+ , [ show . refDigest . storedRef . head . filterAncestors . concatMap storedRoots . toComponents $ room ]
+ , [ "room", maybe "<unnamed>" T.unpack $ roomName =<< cmsgRoom msg ]
+ , [ "from", maybe "<unnamed>" T.unpack $ idName $ cmsgFrom msg ]
+ , if cmsgLeave msg then [ "leave" ] else []
+ , 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
+ , "sub " <> bool "false" "true" (roomStateSubscribe room)
+ ]
+
+cmdChatroomSubscribe :: Command
+cmdChatroomSubscribe = do
+ [ cid ] <- asks tiParams
+ to <- getChatroomStateData cid
+ void $ chatroomSetSubscribe to True
+
+cmdChatroomUnsubscribe :: Command
+cmdChatroomUnsubscribe = do
+ [ cid ] <- asks tiParams
+ to <- getChatroomStateData cid
+ void $ chatroomSetSubscribe to False
+
+cmdChatroomMembers :: Command
+cmdChatroomMembers = do
+ [ cid ] <- asks tiParams
+ Just chatroom <- findChatroomByStateData =<< getChatroomStateData cid
+ forM_ (chatroomMembers chatroom) $ \user -> do
+ cmdOut $ unwords [ "chatroom-members-item", maybe "<unnamed>" T.unpack $ idName user ]
+ cmdOut "chatroom-members-done"
+
+cmdChatroomJoin :: Command
+cmdChatroomJoin = do
+ [ cid ] <- asks tiParams
+ joinChatroomByStateData =<< getChatroomStateData cid
+ cmdOut "chatroom-join-done"
+
+cmdChatroomLeave :: Command
+cmdChatroomLeave = do
+ [ cid ] <- asks tiParams
+ leaveChatroomByStateData =<< getChatroomStateData cid
+ cmdOut "chatroom-leave-done"
+
+cmdChatroomMessageSend :: Command
+cmdChatroomMessageSend = do
+ [cid, msg] <- asks tiParams
+ to <- getChatroomStateData cid
+ void $ sendChatroomMessageByStateData 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-11-08 11:58:14 +0000