diff options
56 files changed, 4850 insertions, 2020 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index de69a6e..cddb159 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,24 @@ # Revision history for erebos +## 0.1.8.1 -- 2025-03-29 + +* Fix build from sdist (add missing include) + +## 0.1.8 -- 2025-03-28 + +* Discovery service without requiring ICE support +* Added `/delete` command to delete chatrooms for current user +* Ignore record items with unexpected type +* Support GHC 9.12 + +## 0.1.7 -- 2024-10-30 + +* Chatroom-specific identity +* Secure cookie for connection initialization +* Support multiple public peers +* Handle unknown object and record item types +* Keep unknown items in local state + ## 0.1.6 -- 2024-08-12 * Chatroom members list and join/leave commands @@ -102,11 +102,13 @@ Test chatroom [19:03] Some Name: Hi `<message>` : Send `<message>` to selected conversation. -`/history` -: Show message history of the selected conversation. +`/history [<number>]` +: Show message history of the selected conversation, or the one identified by + `<number>` if given. -`/details` -: Show information about the selected conversations, contact or peer. +`/details [<number>]` +: Show information about the selected conversations, contact or peer; or the + one identified by `<number>` if given. ### Chatrooms @@ -128,10 +130,23 @@ are signed, so message author can not be forged. `/join` : Join chatroom without sending text message. +`/join-as <name>` +: Join chatroom using a new identity with a name `<name>`. This new identity is + unrelated to the main one, and will be used for any future messages sent to + this chatroom. + `/leave` : Leave the chatroom. User will no longer be listed as a member and erebos tool will no longer collect message of this chatroom. +`/delete [<number>]` +: Delete the chatroom (currently selected one, or the one identified by + `<number>`); this action is only synchronized with devices belonging to the + current user and does not affect the chatroom state for others. Due to the + storage design, the chatroom data will not be purged from the local state + history, but the chatroom will no longer be listed as available and no futher + updates for this chatroom will be collected or shared with other peers. + ### Add contacts To ensure the identity of the contact and prevent man-in-the-middle attack, @@ -211,8 +226,11 @@ target device with `/<number>`. Storage ------- -Data are by default stored within `.erebos` subdirectory of the current working -directory. This can be overriden by `EREBOS_DIR` environment variable. +Data are by default stored under `XDG_DATA_HOME`, typically +`$HOME/.local/share/erebos`, unless there is an erebos storage already +in `.erebos` subdirectory of the current working directory, in which case the +latter one in used instead. This can be overriden by `EREBOS_DIR` environment +variable. Private keys are currently stored in plaintext under the `keys` subdirectory of the erebos directory. diff --git a/erebos.cabal b/erebos.cabal index bd2a807..f001a24 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -1,20 +1,20 @@ Cabal-Version: 3.0 Name: erebos -Version: 0.1.6 +Version: 0.1.8.1 Synopsis: Decentralized messaging and synchronization Description: Library and simple CLI interface implementing the Erebos identity management, decentralized messaging and synchronization protocol, along with local storage. - . + Erebos identity is based on locally stored cryptographic keys, all communication is end-to-end encrypted. Multiple devices can be attached to the same identity, after which they function interchangeably, without any one being in any way "primary"; messages and other state data are then synchronized automatically whenever the devices are able to connect with one another. - . + See README for usage of the CLI tool. License: BSD-3-Clause License-File: LICENSE @@ -29,6 +29,7 @@ Extra-Doc-Files: CHANGELOG.md Extra-Source-Files: src/Erebos/ICE/pjproject.h + src/Erebos/Network/ifaddrs.h Flag ice Description: Enable peer discovery with ICE support using pjproject @@ -38,13 +39,18 @@ Flag ci default: False manual: True +Flag cryptonite + description: Use deprecated 'cryptonite' package + default: False + source-repository head type: git - location: git://erebosprotocol.net/erebos + location: https://code.erebosprotocol.net/erebos common common ghc-options: -Wall + -Wno-x-partial -fdefer-typed-holes if flag(ci) @@ -54,7 +60,7 @@ common common -Wno-error=unused-imports build-depends: - base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 }, + base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 }, default-extensions: DefaultSignatures @@ -94,39 +100,50 @@ library hs-source-dirs: src exposed-modules: Erebos.Attach - Erebos.Channel Erebos.Chatroom Erebos.Contact Erebos.Conversation + Erebos.DirectMessage + Erebos.Discovery + Erebos.Error Erebos.Identity - Erebos.Message Erebos.Network - Erebos.Network.Protocol + Erebos.Object Erebos.Pairing Erebos.PubKey Erebos.Service + Erebos.Service.Stream Erebos.Set Erebos.State + Erebos.Storable Erebos.Storage + Erebos.Storage.Backend + Erebos.Storage.Head Erebos.Storage.Key Erebos.Storage.Merge Erebos.Sync - -- Used by test tool: - Erebos.Storage.Internal other-modules: Erebos.Flow + Erebos.Network.Channel + Erebos.Network.Protocol + Erebos.Object.Internal + Erebos.Storage.Disk + Erebos.Storage.Internal + Erebos.Storage.Memory Erebos.Storage.Platform + Erebos.UUID Erebos.Util c-sources: src/Erebos/Network/ifaddrs.c include-dirs: src + includes: + src/Erebos/Network/ifaddrs.h if flag(ice) exposed-modules: - Erebos.Discovery Erebos.ICE c-sources: src/Erebos/ICE/pjproject.c @@ -142,24 +159,30 @@ library binary >=0.8 && <0.11, bytestring >=0.10 && <0.13, clock >=0.8 && < 0.9, - containers >= 0.6 && <0.8, - cryptonite >=0.25 && <0.31, + containers ^>= { 0.6, 0.7, 0.8 }, deepseq >= 1.4 && <1.6, directory >= 1.3 && <1.4, filepath >=1.4 && <1.6, - fsnotify ^>= { 0.4 }, - hashable >=1.3 && <1.5, - hashtables >=1.2 && <1.4, + fsnotify ^>= { 0.3, 0.4 }, + hashable ^>= { 1.3, 1.4, 1.5 }, + hashtables ^>= { 1.2, 1.3, 1.4 }, iproute >=1.7.12 && <1.8, memory >=0.14 && <0.19, mtl >=2.2 && <2.4, - network >= 3.1 && <3.2, + network ^>= { 3.1, 3.2 }, stm >=2.5 && <2.6, text >= 1.2 && <2.2, - time >= 1.8 && <1.14, - uuid >=1.3 && <1.4, + time ^>= { 1.8, 1.9, 1.10, 1.11, 1.12, 1.13, 1.14 }, + uuid-types ^>= { 1.0.4 }, zlib >=0.6 && <0.8 + if !flag(cryptonite) + build-depends: + crypton ^>= { 0.34, 1.0 }, + else + build-depends: + cryptonite >=0.25 && <0.31, + if os(windows) hs-source-dirs: src/windows build-depends: @@ -178,24 +201,35 @@ executable erebos main-is: Main.hs other-modules: Paths_erebos + State + Terminal Test Test.Service Version Version.Git + WebSocket autogen-modules: Paths_erebos build-depends: + ansi-terminal ^>= { 0.11, 1.0, 1.1 }, bytestring, - cryptonite, directory, erebos, - haskeline >=0.7 && <0.9, mtl, network, process >=1.6 && <1.7, - template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22 }, + stm, + template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 }, text, time, transformers >= 0.5 && <0.7, - uuid, + uuid-types, + websockets ^>= { 0.12.7, 0.13 }, + + if !flag(cryptonite) + build-depends: + crypton, + else + build-depends: + cryptonite, diff --git a/main/Main.hs b/main/Main.hs index 94c0418..26f4b12 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -31,7 +31,7 @@ import Data.Typeable import Network.Socket import System.Console.GetOpt -import System.Console.Haskeline +import System.Directory import System.Environment import System.Exit import System.IO @@ -40,23 +40,28 @@ import Erebos.Attach import Erebos.Contact import Erebos.Chatroom import Erebos.Conversation -#ifdef ENABLE_ICE_SUPPORT +import Erebos.DirectMessage import Erebos.Discovery +#ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif import Erebos.Identity -import Erebos.Message hiding (formatMessage) import Erebos.Network +import Erebos.Object import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State +import Erebos.Storable import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync +import State +import Terminal import Test import Version +import WebSocket data Options = Options { optServer :: ServerOptions @@ -64,6 +69,7 @@ data Options = Options , optStorage :: StorageOption , optChatroomAutoSubscribe :: Maybe Int , optDmBotEcho :: Maybe Text + , optWebSocketServer :: Maybe Int , optShowHelp :: Bool , optShowVersion :: Bool } @@ -86,6 +92,7 @@ defaultOptions = Options , optStorage = DefaultStorage , optChatroomAutoSubscribe = Nothing , optDmBotEcho = Nothing + , optWebSocketServer = Nothing , optShowHelp = False , optShowVersion = False } @@ -102,10 +109,8 @@ availableServices = 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)] @@ -125,9 +130,26 @@ options = , Option [] ["chatroom-auto-subscribe"] (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>") "automatically subscribe for up to <count> chatrooms" +#ifdef ENABLE_ICE_SUPPORT + , Option [] [ "discovery-stun-port" ] + (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunPort = Just (read value) }) "<port>") + "offer specified <port> to discovery peers for STUN protocol" + , Option [] [ "discovery-stun-server" ] + (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunServer = Just (read value) }) "<server>") + "offer <server> (domain name or IP address) to discovery peers for STUN protocol" + , Option [] [ "discovery-turn-port" ] + (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnPort = Just (read value) }) "<port>") + "offer specified <port> to discovery peers for TURN protocol" + , Option [] [ "discovery-turn-server" ] + (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnServer = Just (read value) }) "<server>") + "offer <server> (domain name or IP address) to discovery peers for TURN protocol" +#endif , Option [] ["dm-bot-echo"] (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>") "automatically reply to direct messages with the same text prefixed with <prefix>" + , Option [] [ "websocket-server" ] + (ReqArg (\value -> \opts -> opts { optWebSocketServer = Just (read value) }) "<port>") + "start WebSocket server on given port" , Option ['h'] ["help"] (NoArg $ \opts -> opts { optShowHelp = True }) "show this help and exit" @@ -135,7 +157,16 @@ options = (NoArg $ \opts -> opts { optShowVersion = True }) "show version and exit" ] - where so f opts = opts { optServer = f $ optServer opts } + where + so f opts = opts { optServer = f $ optServer opts } + + updateService :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> SomeService -> SomeService + updateService f some@(SomeService proxy attrs) + | Just f' <- cast f = SomeService proxy (f' attrs) + | otherwise = some + + serviceAttr :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> Options -> Options + serviceAttr f opts = opts { optServices = map (\sopt -> sopt { soptService = updateService f (soptService sopt) }) (optServices opts) } servicesOptions :: [OptDescr (Options -> Options)] servicesOptions = concatMap helper $ "all" : map soptName availableServices @@ -152,6 +183,14 @@ servicesOptions = concatMap helper $ "all" : map soptName availableServices | otherwise = s : change name f ss change _ _ [] = [] +getDefaultStorageDir :: IO FilePath +getDefaultStorageDir = do + lookupEnv "EREBOS_DIR" >>= \case + Just dir -> return dir + Nothing -> doesFileExist "./.erebos/erebos-storage" >>= \case + True -> return "./.erebos" + False -> getXdgDirectory XdgData "erebos" + main :: IO () main = do (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case @@ -163,7 +202,7 @@ main = do exitFailure st <- liftIO $ case optStorage opts of - DefaultStorage -> openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR" + DefaultStorage -> openStorage =<< getDefaultStorageDir FilesystemStorage path -> openStorage path MemoryStorage -> memoryStorage @@ -203,17 +242,20 @@ main = do Nothing -> error "ref does not exist" Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object) - ["update-identity"] -> either fail return <=< runExceptT $ do - runReaderT updateSharedIdentity =<< loadLocalStateHead st + ["update-identity"] -> do + withTerminal noCompletion $ \term -> do + either (fail . showErebosError) return <=< runExceptT $ do + runReaderT (updateSharedIdentity term) =<< loadLocalStateHead term st ("update-identity" : srefs) -> do - sequence <$> mapM (readRef st . BC.pack) srefs >>= \case - Nothing -> error "ref does not exist" - Just refs - | Just idt <- validateIdentityF $ map wrappedLoad refs -> do - BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< - (either fail return <=< runExceptT $ runReaderT (interactiveIdentityUpdate idt) st) - | otherwise -> error "invalid identity" + withTerminal noCompletion $ \term -> do + sequence <$> mapM (readRef st . BC.pack) srefs >>= \case + Nothing -> error "ref does not exist" + Just refs + | Just idt <- validateIdentityF $ map wrappedLoad refs -> do + BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< + (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st) + | otherwise -> error "invalid identity" ["test"] -> runTestTool st @@ -243,22 +285,16 @@ main = do exitFailure -inputSettings :: Settings IO -inputSettings = setComplete commandCompletion $ defaultSettings - interactiveLoop :: Storage -> Options -> IO () -interactiveLoop st opts = runInputT inputSettings $ do - erebosHead <- liftIO $ loadLocalStateHead st - outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead - - tui <- haveTerminalUI - extPrint <- getExternalPrint - let extPrintLn str = do - let str' = case reverse str of ('\n':_) -> str - _ -> str ++ "\n"; - extPrint $! str' -- evaluate str before calling extPrint to avoid blinking - - let getInputLinesTui eprompt = do +interactiveLoop st opts = withTerminal commandCompletion $ \term -> do + erebosHead <- liftIO $ loadLocalStateHead term st + void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead + + let tui = hasTerminalUI term + let extPrintLn = void . printLine term + + let getInputLinesTui :: Either CommandState String -> MaybeT IO String + getInputLinesTui eprompt = do prompt <- case eprompt of Left cstate -> do pname <- case csContext cstate of @@ -272,11 +308,14 @@ interactiveLoop st opts = runInputT inputSettings $ do SelectedConversation conv -> return $ T.unpack $ conversationName conv return $ pname ++ "> " Right prompt -> return prompt - Just input <- lift $ getInputLine prompt - case reverse input of - _ | all isSpace input -> getInputLinesTui eprompt - '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ") - _ -> return input + lift $ setPrompt term prompt + join $ lift $ getInputLine term $ \case + Just input@('/' : _) -> KeepPrompt $ return input + Just input -> ErasePrompt $ case reverse input of + _ | all isSpace input -> getInputLinesTui eprompt + '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ") + _ -> return input + Nothing -> KeepPrompt mzero getInputCommandTui cstate = do input <- getInputLinesTui cstate @@ -289,7 +328,7 @@ interactiveLoop st opts = runInputT inputSettings $ do return (cmd, line) getInputLinesPipe = do - lift (getInputLine "") >>= \case + join $ lift $ getInputLine term $ KeepPrompt . \case Just input -> return input Nothing -> liftIO $ forever $ threadDelay 100000000 @@ -329,6 +368,10 @@ interactiveLoop st opts = runInputT inputSettings $ do startServer (optServer opts) erebosHead extPrintLn $ map soptService $ filter soptEnabled $ optServices opts + case optWebSocketServer opts of + Just port -> startWebsocketServer server "::" port extPrintLn + Nothing -> return () + void $ liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange server peerIdentity peer >>= \case @@ -350,15 +393,16 @@ interactiveLoop st opts = runInputT inputSettings $ do when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown _ -> return () - let process :: CommandState -> MaybeT (InputT IO) CommandState + let process :: CommandState -> MaybeT IO CommandState process cstate = do (cmd, line) <- getInputCommand cstate h <- liftIO (reloadHead $ csHead cstate) >>= \case Just h -> return h - Nothing -> do lift $ lift $ extPrintLn "current head deleted" + Nothing -> do lift $ extPrintLn "current head deleted" mzero res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput { ciServer = server + , ciTerminal = term , ciLine = line , ciPrint = extPrintLn , ciOptions = opts @@ -375,7 +419,7 @@ interactiveLoop st opts = runInputT inputSettings $ do | csQuit cstate' -> mzero | otherwise -> return cstate' Left err -> do - lift $ lift $ extPrintLn $ "Error: " ++ err + lift $ extPrintLn $ "Error: " ++ showErebosError err return cstate let loop (Just cstate) = runMaybeT (process cstate) >>= loop @@ -394,6 +438,7 @@ interactiveLoop st opts = runInputT inputSettings $ do data CommandInput = CommandInput { ciServer :: Server + , ciTerminal :: Terminal , ciLine :: String , ciPrint :: String -> IO () , ciOptions :: Options @@ -421,15 +466,15 @@ data CommandContext = NoContext | SelectedChatroom ChatroomState | SelectedConversation Conversation -newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String) +newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a) + deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError) instance MonadFail CommandM where - fail = throwError + fail = throwOtherError instance MonadIO CommandM where liftIO act = CommandM (liftIO (try act)) >>= \case - Left (e :: SomeException) -> throwError (show e) + Left (e :: SomeException) -> throwOtherError (show e) Right x -> return x instance MonadRandom CommandM where @@ -450,27 +495,37 @@ type Command = CommandM () getSelectedPeer :: CommandM Peer getSelectedPeer = gets csContext >>= \case SelectedPeer peer -> return peer - _ -> throwError "no peer selected" + _ -> throwOtherError "no peer selected" getSelectedChatroom :: CommandM ChatroomState getSelectedChatroom = gets csContext >>= \case SelectedChatroom rstate -> return rstate - _ -> throwError "no chatroom selected" + _ -> throwOtherError "no chatroom selected" getSelectedConversation :: CommandM Conversation -getSelectedConversation = gets csContext >>= \case +getSelectedConversation = gets csContext >>= getConversationFromContext + +getConversationFromContext :: CommandContext -> CommandM Conversation +getConversationFromContext = \case SelectedPeer peer -> peerIdentity peer >>= \case PeerIdentityFull pid -> directMessageConversation $ finalOwner pid - _ -> throwError "incomplete peer identity" + _ -> throwOtherError "incomplete peer identity" SelectedContact contact -> case contactIdentity contact of Just cid -> directMessageConversation cid - Nothing -> throwError "contact without erebos identity" + Nothing -> throwOtherError "contact without erebos identity" SelectedChatroom rstate -> chatroomConversation rstate >>= \case Just conv -> return conv - Nothing -> throwError "invalid chatroom" + Nothing -> throwOtherError "invalid chatroom" SelectedConversation conv -> reloadConversation conv - _ -> throwError "no contact, peer or conversation selected" + _ -> throwOtherError "no contact, peer or conversation selected" + +getSelectedOrManualContext :: CommandM CommandContext +getSelectedOrManualContext = do + asks ciLine >>= \case + "" -> gets csContext + str | all isDigit str -> getContextByIndex (read str) + _ -> throwOtherError "invalid index" commands :: [(String, Command)] commands = @@ -480,6 +535,7 @@ commands = , ("peer-add-public", cmdPeerAddPublic) , ("peer-drop", cmdPeerDrop) , ("send", cmdSend) + , ("delete", cmdDelete) , ("update-identity", cmdUpdateIdentity) , ("attach", cmdAttach) , ("attach-accept", cmdAttachAccept) @@ -492,9 +548,9 @@ commands = , ("contact-reject", cmdContactReject) , ("conversations", cmdConversations) , ("details", cmdDetails) -#ifdef ENABLE_ICE_SUPPORT , ("discovery-init", cmdDiscoveryInit) , ("discovery", cmdDiscovery) +#ifdef ENABLE_ICE_SUPPORT , ("ice-create", cmdIceCreate) , ("ice-destroy", cmdIceDestroy) , ("ice-show", cmdIceShow) @@ -502,6 +558,7 @@ commands = , ("ice-send", cmdIceSend) #endif , ("join", cmdJoin) + , ("join-as", cmdJoinAs) , ("leave", cmdLeave) , ("members", cmdMembers) , ("select", cmdSelectContext) @@ -516,8 +573,13 @@ commandCompletion = completeWordWithPrev Nothing [ ' ', '\t', '\n', '\r' ] $ cur sortedCommandNames = sort $ map fst commands +cmdPutStrLn :: String -> Command +cmdPutStrLn str = do + term <- asks ciTerminal + void $ liftIO $ printLine term str + cmdUnknown :: String -> Command -cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd +cmdUnknown cmd = cmdPutStrLn $ "Unknown command: " ++ cmd cmdPeers :: Command cmdPeers = do @@ -525,7 +587,7 @@ cmdPeers = do set <- asks ciSetContextOptions set $ map (SelectedPeer . fst) peers forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ name + cmdPutStrLn $ "[" ++ show i ++ "] " ++ name cmdPeerAdd :: Command cmdPeerAdd = void $ do @@ -533,15 +595,26 @@ cmdPeerAdd = void $ do (hostname, port) <- (words <$> asks ciLine) >>= \case hostname:p:_ -> return (hostname, p) [hostname] -> return (hostname, show discoveryPort) - [] -> throwError "missing peer address" + [] -> throwOtherError "missing peer address" addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) liftIO $ serverPeer server (addrAddress addr) cmdPeerAddPublic :: Command cmdPeerAddPublic = do server <- asks ciServer - addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just "discovery1.erebosprotocol.net") (Just (show discoveryPort)) - void $ liftIO $ serverPeer server (addrAddress addr) + liftIO $ mapM_ (serverPeer server . addrAddress) =<< gather 'a' + where + gather c + | c <= 'z' = do + let hints = Just $ defaultHints { addrSocketType = Datagram } + hostname = Just $ c : ".discovery.erebosprotocol.net" + service = Just $ show discoveryPort + handle (\(_ :: IOException) -> return []) (getAddrInfo hints hostname service) >>= \case + addr : _ -> (addr :) <$> gather (succ c) + [] -> return [] + + | otherwise = do + return [] cmdPeerDrop :: Command cmdPeerDrop = do @@ -559,6 +632,13 @@ showPeer pidentity paddr = cmdJoin :: Command cmdJoin = joinChatroom =<< getSelectedChatroom +cmdJoinAs :: Command +cmdJoinAs = do + name <- asks ciLine + st <- getStorage + identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing + joinChatroomAs identity =<< getSelectedChatroom + cmdLeave :: Command cmdLeave = leaveChatroom =<< getSelectedChatroom @@ -566,21 +646,24 @@ cmdMembers :: Command cmdMembers = do Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom forM_ (chatroomMembers room) $ \x -> do - liftIO $ putStrLn $ maybe "<unnamed>" T.unpack $ idName x + cmdPutStrLn $ maybe "<unnamed>" T.unpack $ idName x +getContextByIndex :: Int -> CommandM CommandContext +getContextByIndex n = do + join (asks ciContextOptions) >>= \ctxs -> if + | n > 0, (ctx : _) <- drop (n - 1) ctxs -> return ctx + | otherwise -> throwOtherError "invalid index" cmdSelectContext :: Command cmdSelectContext = do n <- read <$> asks ciLine - join (asks ciContextOptions) >>= \ctxs -> if - | n > 0, (ctx : _) <- drop (n - 1) ctxs -> do - modify $ \s -> s { csContext = ctx } - case ctx of - SelectedChatroom rstate -> do - when (not (roomStateSubscribe rstate)) $ do - chatroomSetSubscribe (head $ roomStateData rstate) True - _ -> return () - | otherwise -> throwError "invalid index" + ctx <- getContextByIndex n + modify $ \s -> s { csContext = ctx } + case ctx of + SelectedChatroom rstate -> do + when (not (roomStateSubscribe rstate)) $ do + chatroomSetSubscribe (head $ roomStateData rstate) True + _ -> return () cmdSend :: Command cmdSend = void $ do @@ -589,22 +672,28 @@ cmdSend = void $ do sendMessage conv (T.pack text) >>= \case Just msg -> do tzone <- liftIO $ getCurrentTimeZone - liftIO $ putStrLn $ formatMessage tzone msg + cmdPutStrLn $ formatMessage tzone msg Nothing -> return () +cmdDelete :: Command +cmdDelete = void $ do + deleteConversation =<< getConversationFromContext =<< getSelectedOrManualContext + modify $ \s -> s { csContext = NoContext } + cmdHistory :: Command cmdHistory = void $ do - conv <- getSelectedConversation + conv <- getConversationFromContext =<< getSelectedOrManualContext case conversationHistory conv of thread@(_:_) -> do tzone <- liftIO $ getCurrentTimeZone - liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 thread + mapM_ (cmdPutStrLn . formatMessage tzone) $ reverse $ take 50 thread [] -> do - liftIO $ putStrLn $ "<empty history>" + cmdPutStrLn $ "<empty history>" cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do - runReaderT updateSharedIdentity =<< gets csHead + term <- asks ciTerminal + runReaderT (updateSharedIdentity term) =<< gets csHead cmdAttach :: Command cmdAttach = attachToOwner =<< getSelectedPeer @@ -638,7 +727,7 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do watchChatrooms h $ \set -> \case Nothing -> do - let chatroomList = fromSetBy (comparing roomStateData) set + let chatroomList = filter (not . roomStateDeleted) $ fromSetBy (comparing roomStateData) set (subscribed, notSubscribed) = partition roomStateSubscribe chatroomList subscribedNum = length subscribed @@ -651,7 +740,7 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case Right () -> return () - Left err -> eprint err + Left err -> eprint (showErebosError err) Just diff -> do modifyMVar_ chatroomSetVar $ return . const set @@ -698,20 +787,20 @@ cmdChatrooms :: Command cmdChatrooms = do ensureWatchedChatrooms chatroomSetVar <- asks ciChatroomSetVar - chatroomList <- fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) + chatroomList <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) set <- asks ciSetContextOptions set $ map SelectedChatroom chatroomList forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate) + cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate) cmdChatroomCreatePublic :: Command cmdChatroomCreatePublic = do + term <- asks ciTerminal name <- asks ciLine >>= \case line | not (null line) -> return $ T.pack line _ -> liftIO $ do - T.putStr $ T.pack "Name: " - hFlush stdout - T.getLine + setPrompt term "Name: " + getInputLine term $ KeepPrompt . maybe T.empty T.pack ensureWatchedChatrooms void $ createChatroom @@ -727,8 +816,8 @@ cmdContacts = do verbose = "-v" `elem` args set <- asks ciSetContextOptions set $ map SelectedContact contacts - forM_ (zip [1..] contacts) $ \(i :: Int, c) -> liftIO $ do - T.putStrLn $ T.concat + forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do + cmdPutStrLn $ T.unpack $ T.concat [ "[", T.pack (show i), "] ", contactName c , case contactIdentity c of Just idt | cname <- displayIdentity idt @@ -754,36 +843,36 @@ cmdConversations = do set <- asks ciSetContextOptions set $ map SelectedConversation conversations forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) + cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) cmdDetails :: Command cmdDetails = do - gets csContext >>= \case + getSelectedOrManualContext >>= \case SelectedPeer peer -> do - liftIO $ putStr $ unlines + cmdPutStrLn $ unlines [ "Network peer:" , " " <> show (peerAddress peer) ] peerIdentity peer >>= \case - PeerIdentityUnknown _ -> liftIO $ do - putStrLn $ "unknown identity" - PeerIdentityRef wref _ -> liftIO $ do - putStrLn $ "Identity ref:" - putStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref) + PeerIdentityUnknown _ -> do + cmdPutStrLn $ "unknown identity" + PeerIdentityRef wref _ -> do + cmdPutStrLn $ "Identity ref:" + cmdPutStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref) PeerIdentityFull pid -> printContactOrIdentityDetails pid SelectedContact contact -> do printContactDetails contact SelectedChatroom rstate -> do - liftIO $ putStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate) + cmdPutStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate) SelectedConversation conv -> do case conversationPeer conv of Just pid -> printContactOrIdentityDetails pid - Nothing -> liftIO $ putStrLn $ "(conversation without peer)" + Nothing -> cmdPutStrLn $ "(conversation without peer)" - NoContext -> liftIO $ putStrLn "nothing selected" + NoContext -> cmdPutStrLn "nothing selected" where printContactOrIdentityDetails cid = do contacts <- fromSetBy (comparing contactName) . lookupSharedValue . lsShared . fromStored <$> getLocalHead @@ -791,11 +880,11 @@ cmdDetails = do Just contact -> printContactDetails contact Nothing -> printIdentityDetails cid - printContactDetails contact = liftIO $ do - putStrLn $ "Contact:" + printContactDetails contact = do + cmdPutStrLn $ "Contact:" prefix <- case contactCustomName contact of Just name -> do - putStrLn $ " " <> T.unpack name + cmdPutStrLn $ " " <> T.unpack name return $ Just "alias of" Nothing -> do return $ Nothing @@ -804,23 +893,21 @@ cmdDetails = do Just cid -> do printIdentityDetailsBody prefix cid Nothing -> do - putStrLn $ " (without erebos identity)" + cmdPutStrLn $ " (without erebos identity)" - printIdentityDetails identity = liftIO $ do - putStrLn $ "Identity:" + printIdentityDetails identity = do + cmdPutStrLn $ "Identity:" printIdentityDetailsBody Nothing identity printIdentityDetailsBody prefix identity = do forM_ (zip (False : repeat True) $ unfoldOwners identity) $ \(owned, cpid) -> do - putStrLn $ unwords $ concat + cmdPutStrLn $ unwords $ concat [ [ " " ] , if owned then [ "owned by" ] else maybeToList prefix , [ maybe "<unnamed>" T.unpack (idName cpid) ] , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid ] -#ifdef ENABLE_ICE_SUPPORT - cmdDiscoveryInit :: Command cmdDiscoveryInit = void $ do server <- asks ciServer @@ -831,31 +918,50 @@ cmdDiscoveryInit = void $ do [] -> ("discovery.erebosprotocol.net", show discoveryPort) addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) peer <- liftIO $ serverPeer server (addrAddress addr) - sendToPeer peer $ DiscoverySelf (T.pack "ICE") 0 + sendToPeer peer $ DiscoverySelf [ T.pack "ICE" ] Nothing modify $ \s -> s { csIcePeer = Just peer } cmdDiscovery :: Command cmdDiscovery = void $ do - Just peer <- gets csIcePeer - st <- getStorage + server <- asks ciServer sref <- asks ciLine - eprint <- asks ciPrint - liftIO $ readRef st (BC.pack sref) >>= \case - Nothing -> error "ref does not exist" - Just ref -> do - res <- runExceptT $ sendToPeer peer $ DiscoverySearch ref - case res of - Right _ -> return () - Left err -> eprint err + case readRefDigest (BC.pack sref) of + Nothing -> throwOtherError "failed to parse ref" + Just dgst -> discoverySearch server dgst + +#ifdef ENABLE_ICE_SUPPORT cmdIceCreate :: Command cmdIceCreate = do - role <- asks ciLine >>= return . \case - 'm':_ -> PjIceSessRoleControlling - 's':_ -> PjIceSessRoleControlled - _ -> PjIceSessRoleUnknown + let getRole = \case + 'm':_ -> PjIceSessRoleControlling + 's':_ -> PjIceSessRoleControlled + _ -> PjIceSessRoleUnknown + + ( role, stun, turn ) <- asks (words . ciLine) >>= \case + [] -> return ( PjIceSessRoleControlling, Nothing, Nothing ) + [ role ] -> return + ( getRole role, Nothing, Nothing ) + [ role, server ] -> return + ( getRole role + , Just ( T.pack server, 0 ) + , Just ( T.pack server, 0 ) + ) + [ role, server, port ] -> return + ( getRole role + , Just ( T.pack server, read port ) + , Just ( T.pack server, read port ) + ) + [ role, stunServer, stunPort, turnServer, turnPort ] -> return + ( getRole role + , Just ( T.pack stunServer, read stunPort ) + , Just ( T.pack turnServer, read turnPort ) + ) + _ -> throwOtherError "invalid parameters" + eprint <- asks ciPrint - sess <- liftIO $ iceCreate role $ eprint <=< iceShow + Just cfg <- liftIO $ iceCreateConfig stun turn + sess <- liftIO $ iceCreateSession cfg role $ eprint <=< iceShow modify $ \s -> s { csIceSessions = sess : csIceSessions s } cmdIceDestroy :: Command @@ -876,11 +982,15 @@ cmdIceConnect :: Command cmdIceConnect = do s:_ <- gets csIceSessions server <- asks ciServer - let loadInfo = BC.getLine >>= \case line | BC.null line -> return [] - | otherwise -> (line:) <$> loadInfo + term <- asks ciTerminal + let loadInfo = + getInputLine term (KeepPrompt . maybe BC.empty BC.pack) >>= \case + line | BC.null line -> return [] + | otherwise -> (line :) <$> loadInfo Right remote <- liftIO $ do st <- memoryStorage pst <- derivePartialStorage st + setPrompt term "" rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes) liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s diff --git a/main/State.hs b/main/State.hs new file mode 100644 index 0000000..150178e --- /dev/null +++ b/main/State.hs @@ -0,0 +1,80 @@ +module State ( + loadLocalStateHead, + updateSharedIdentity, + interactiveIdentityUpdate, +) where + +import Control.Monad.Except +import Control.Monad.IO.Class + +import Data.Foldable +import Data.Maybe +import Data.Proxy +import Data.Text qualified as T + +import Erebos.Error +import Erebos.Identity +import Erebos.PubKey +import Erebos.State +import Erebos.Storable +import Erebos.Storage + +import Terminal + + +loadLocalStateHead :: MonadIO m => Terminal -> Storage -> m (Head LocalState) +loadLocalStateHead term st = loadHeads st >>= \case + (h:_) -> return h + [] -> liftIO $ do + setPrompt term "Name: " + name <- getInputLine term $ KeepPrompt . maybe T.empty T.pack + + setPrompt term "Device: " + devName <- getInputLine term $ KeepPrompt . maybe T.empty T.pack + + owner <- if + | T.null name -> return Nothing + | otherwise -> Just <$> createIdentity st (Just name) Nothing + + identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner + + shared <- wrappedStore st $ SharedState + { ssPrev = [] + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy + , ssValue = [ storedRef $ idExtData $ fromMaybe identity owner ] + } + storeHead st $ LocalState + { lsPrev = Nothing + , lsIdentity = idExtData identity + , lsShared = [ shared ] + , lsOther = [] + } + + +updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m () +updateSharedIdentity term = updateLocalState_ $ updateSharedState_ $ \case + Just identity -> do + Just . toComposedIdentity <$> interactiveIdentityUpdate term identity + Nothing -> throwOtherError "no existing shared identity" + +interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => Terminal -> Identity f -> m UnifiedIdentity +interactiveIdentityUpdate term fidentity = do + identity <- mergeIdentity fidentity + name <- liftIO $ do + setPrompt term $ T.unpack $ T.concat $ concat + [ [ T.pack "Name" ] + , case idName identity of + Just name -> [T.pack " [", name, T.pack "]"] + Nothing -> [] + , [ T.pack ": " ] + ] + getInputLine term $ KeepPrompt . maybe T.empty T.pack + + if | T.null name -> return identity + | otherwise -> do + secret <- loadKey $ idKeyIdentity identity + maybe (throwOtherError "created invalid identity") return . validateExtendedIdentity =<< + mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData identity) + { idePrev = toList $ idExtDataF identity + , ideName = Just name + } diff --git a/main/Terminal.hs b/main/Terminal.hs new file mode 100644 index 0000000..150bd8c --- /dev/null +++ b/main/Terminal.hs @@ -0,0 +1,347 @@ +{-# LANGUAGE CPP #-} + +module Terminal ( + Terminal, + hasTerminalUI, + withTerminal, + setPrompt, + getInputLine, + InputHandling(..), + + TerminalLine, + printLine, + + printBottomLines, + clearBottomLines, + + CompletionFunc, Completion, + noCompletion, + simpleCompletion, + completeWordWithPrev, +) where + +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad + +import Data.Char +import Data.List +import Data.Text (Text) +import Data.Text qualified as T + +import System.Console.ANSI +import System.IO +import System.IO.Error + + +data Terminal = Terminal + { termLock :: MVar () + , termAnsi :: Bool + , termCompletionFunc :: CompletionFunc IO + , termPrompt :: TVar String + , termShowPrompt :: TVar Bool + , termInput :: TVar ( String, String ) + , termBottomLines :: TVar [ String ] + } + +data TerminalLine = TerminalLine + { tlTerminal :: Terminal + } + +data Input + = InputChar Char + | InputMoveRight + | InputMoveLeft + | InputMoveEnd + | InputMoveStart + | InputBackspace + | InputClear + | InputBackWord + | InputEnd + | InputEscape String + deriving (Eq, Ord, Show) + + +data InputHandling a + = KeepPrompt a + | ErasePrompt a + + +hasTerminalUI :: Terminal -> Bool +hasTerminalUI = termAnsi + +initTerminal :: CompletionFunc IO -> IO Terminal +initTerminal termCompletionFunc = do + termLock <- newMVar () +#if MIN_VERSION_ansi_terminal(1, 0, 1) + termAnsi <- hNowSupportsANSI stdout +#else + termAnsi <- hSupportsANSI stdout +#endif + termPrompt <- newTVarIO "" + termShowPrompt <- newTVarIO False + termInput <- newTVarIO ( "", "" ) + termBottomLines <- newTVarIO [] + return Terminal {..} + +bracketSet :: IO a -> (a -> IO b) -> a -> IO c -> IO c +bracketSet get set val = bracket (get <* set val) set . const + +withTerminal :: CompletionFunc IO -> (Terminal -> IO a) -> IO a +withTerminal compl act = do + term <- initTerminal compl + + bracketSet (hGetEcho stdin) (hSetEcho stdin) False $ + bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering $ + bracketSet (hGetBuffering stdout) (hSetBuffering stdout) (BlockBuffering Nothing) $ + act term + + +termPutStr :: Terminal -> String -> IO () +termPutStr Terminal {..} str = do + withMVar termLock $ \_ -> do + putStr str + hFlush stdout + + +getInput :: IO Input +getInput = do + handleJust (guard . isEOFError) (\() -> return InputEnd) $ getChar >>= \case + '\ESC' -> do + esc <- readEsc + case parseEsc esc of + Just ( 'C' , [] ) -> return InputMoveRight + Just ( 'D' , [] ) -> return InputMoveLeft + _ -> return (InputEscape esc) + '\b' -> return InputBackspace + '\DEL' -> return InputBackspace + '\NAK' -> return InputClear + '\ETB' -> return InputBackWord + '\SOH' -> return InputMoveStart + '\ENQ' -> return InputMoveEnd + '\EOT' -> return InputEnd + c -> return (InputChar c) + where + readEsc = getChar >>= \case + c | c == '\ESC' || isAlpha c -> return [ c ] + | otherwise -> (c :) <$> readEsc + + parseEsc = \case + '[' : c : [] -> do + Just ( c, [] ) + _ -> Nothing + + +getInputLine :: Terminal -> (Maybe String -> InputHandling a) -> IO a +getInputLine term@Terminal {..} handleResult = do + withMVar termLock $ \_ -> do + prompt <- atomically $ do + writeTVar termShowPrompt True + readTVar termPrompt + putStr $ prompt <> "\ESC[K" + drawBottomLines term + hFlush stdout + (handleResult <$> go) >>= \case + KeepPrompt x -> do + termPutStr term "\n\ESC[J" + return x + ErasePrompt x -> do + termPutStr term "\r\ESC[J" + return x + where + go = getInput >>= \case + InputChar '\n' -> do + atomically $ do + ( pre, post ) <- readTVar termInput + writeTVar termInput ( "", "" ) + writeTVar termShowPrompt False + writeTVar termBottomLines [] + return $ Just $ pre ++ post + + InputChar '\t' -> do + options <- withMVar termLock $ const $ do + ( pre, post ) <- atomically $ readTVar termInput + let updatePrompt pre' = do + prompt <- atomically $ do + writeTVar termInput ( pre', post ) + getCurrentPromptLine term + putStr $ "\r" <> prompt + hFlush stdout + + termCompletionFunc ( T.pack pre, T.pack post ) >>= \case + + ( unused, [ compl ] ) -> do + updatePrompt $ T.unpack unused ++ T.unpack (replacement compl) ++ if isFinished compl then " " else "" + return [] + + ( unused, completions@(c : cs) ) -> do + let commonPrefixes' x y = fmap (\( common, _, _ ) -> common) $ T.commonPrefixes x y + case foldl' (\mbcommon cur -> commonPrefixes' cur =<< mbcommon) (Just $ replacement c) (fmap replacement cs) of + Just common -> updatePrompt $ T.unpack unused ++ T.unpack common + Nothing -> return () + return $ map replacement completions + + ( _, [] ) -> do + return [] + + printBottomLines term $ T.unpack $ T.unlines options + go + + InputChar c | isPrint c -> withInput $ \case + ( _, post ) -> do + writeTVar termInput . first (++ [ c ]) =<< readTVar termInput + return $ c : (if null post then "" else "\ESC[s" <> post <> "\ESC[u") + + InputChar _ -> go + + InputMoveRight -> withInput $ \case + ( pre, c : post ) -> do + writeTVar termInput ( pre ++ [ c ], post ) + return $ "\ESC[C" + _ -> return "" + + InputMoveLeft -> withInput $ \case + ( pre@(_ : _), post ) -> do + writeTVar termInput ( init pre, last pre : post ) + return $ "\ESC[D" + _ -> return "" + + InputBackspace -> withInput $ \case + ( pre@(_ : _), post ) -> do + writeTVar termInput ( init pre, post ) + return $ "\b\ESC[K" <> (if null post then "" else "\ESC[s" <> post <> "\ESC[u") + _ -> return "" + + InputClear -> withInput $ \_ -> do + writeTVar termInput ( "", "" ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + + InputBackWord -> withInput $ \( pre, post ) -> do + let pre' = reverse $ dropWhile (not . isSpace) $ dropWhile isSpace $ reverse pre + writeTVar termInput ( pre', post ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + + InputMoveStart -> withInput $ \( pre, post ) -> do + writeTVar termInput ( "", pre <> post ) + return $ "\ESC[" <> show (length pre) <> "D" + + InputMoveEnd -> withInput $ \( pre, post ) -> do + writeTVar termInput ( pre <> post, "" ) + return $ "\ESC[" <> show (length post) <> "C" + + InputEnd -> do + atomically (readTVar termInput) >>= \case + ( "", "" ) -> return Nothing + _ -> go + + InputEscape _ -> go + + withInput f = do + withMVar termLock $ const $ do + str <- atomically $ f =<< readTVar termInput + when (not $ null str) $ do + putStr str + hFlush stdout + go + + +getCurrentPromptLine :: Terminal -> STM String +getCurrentPromptLine Terminal {..} = do + prompt <- readTVar termPrompt + ( pre, post ) <- readTVar termInput + return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u" + +setPrompt :: Terminal -> String -> IO () +setPrompt term@Terminal {..} prompt = do + withMVar termLock $ \_ -> do + join $ atomically $ do + writeTVar termPrompt prompt + readTVar termShowPrompt >>= \case + True -> do + promptLine <- getCurrentPromptLine term + return $ do + putStr $ "\r\ESC[K" <> promptLine + hFlush stdout + False -> return $ return () + +printLine :: Terminal -> String -> IO TerminalLine +printLine tlTerminal@Terminal {..} str = do + withMVar termLock $ \_ -> do + promptLine <- atomically $ do + readTVar termShowPrompt >>= \case + True -> getCurrentPromptLine tlTerminal + False -> return "" + putStr $ "\r\ESC[K" <> str <> "\n\ESC[K" <> promptLine + drawBottomLines tlTerminal + hFlush stdout + return TerminalLine {..} + + +printBottomLines :: Terminal -> String -> IO () +printBottomLines term@Terminal {..} str = do + case lines str of + [] -> clearBottomLines term + blines -> do + withMVar termLock $ \_ -> do + atomically $ writeTVar termBottomLines blines + drawBottomLines term + hFlush stdout + +clearBottomLines :: Terminal -> IO () +clearBottomLines Terminal {..} = do + withMVar termLock $ \_ -> do + atomically (readTVar termBottomLines) >>= \case + [] -> return () + _:_ -> do + atomically $ writeTVar termBottomLines [] + putStr $ "\ESC[s\n\ESC[J\ESC[u" + hFlush stdout + +drawBottomLines :: Terminal -> IO () +drawBottomLines Terminal {..} = do + atomically (readTVar termBottomLines) >>= \case + blines@( firstLine : otherLines ) -> do + ( shift ) <- atomically $ do + readTVar termShowPrompt >>= \case + True -> do + prompt <- readTVar termPrompt + ( pre, _ ) <- readTVar termInput + return (displayWidth (prompt <> pre) + 1) + False -> do + return 0 + putStr $ concat + [ "\n\ESC[J", firstLine, concat (map ('\n' :) otherLines) + , "\ESC[", show (length blines), "F" + , "\ESC[", show shift, "G" + ] + [] -> return () + + +displayWidth :: String -> Int +displayWidth = \case + ('\ESC' : '[' : rest) -> displayWidth $ drop 1 $ dropWhile (not . isAlpha) rest + ('\ESC' : _ : rest) -> displayWidth rest + (_ : rest) -> 1 + displayWidth rest + [] -> 0 + + +type CompletionFunc m = ( Text, Text ) -> m ( Text, [ Completion ] ) + +data Completion = Completion + { replacement :: Text + , isFinished :: Bool + } + +noCompletion :: Monad m => CompletionFunc m +noCompletion ( l, _ ) = return ( l, [] ) + +completeWordWithPrev :: Monad m => Maybe Char -> [ Char ] -> (String -> String -> m [ Completion ]) -> CompletionFunc m +completeWordWithPrev _ spaceChars fun ( l, _ ) = do + let lastSpaceIndex = snd $ T.foldl' (\( i, found ) c -> if c `elem` spaceChars then ( i + 1, i ) else ( i + 1, found )) ( 1, 0 ) l + let ( pre, word ) = T.splitAt lastSpaceIndex l + ( pre, ) <$> fun (T.unpack pre) (T.unpack word) + +simpleCompletion :: String -> Completion +simpleCompletion str = Completion (T.pack str) True diff --git a/main/Test.hs b/main/Test.hs index c6448b8..fa8501e 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Test ( runTestTool, ) where @@ -16,6 +18,7 @@ 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.ByteString.Lazy.Char8 qualified as BL import Data.Foldable import Data.Ord import Data.Text (Text) @@ -23,7 +26,7 @@ import Data.Text qualified as T import Data.Text.Encoding import Data.Text.IO qualified as T import Data.Typeable -import Data.UUID qualified as U +import Data.UUID.Types qualified as U import Network.Socket @@ -33,16 +36,20 @@ import System.IO.Error import Erebos.Attach import Erebos.Chatroom import Erebos.Contact +import Erebos.DirectMessage +import Erebos.Discovery import Erebos.Identity -import Erebos.Message import Erebos.Network +import Erebos.Object import Erebos.Pairing import Erebos.PubKey import Erebos.Service +import Erebos.Service.Stream import Erebos.Set import Erebos.State +import Erebos.Storable import Erebos.Storage -import Erebos.Storage.Internal (unsafeStoreRawBytes) +import Erebos.Storage.Head import Erebos.Storage.Merge import Erebos.Sync @@ -60,10 +67,17 @@ data TestState = TestState data RunningServer = RunningServer { rsServer :: Server - , rsPeers :: MVar (Int, [(Int, Peer)]) + , rsPeers :: MVar ( Int, [ TestPeer ] ) , rsPeerThread :: ThreadId } +data TestPeer = TestPeer + { tpIndex :: Int + , tpPeer :: Peer + , tpStreamReaders :: MVar [ (Int, StreamReader ) ] + , tpStreamWriters :: MVar [ (Int, StreamWriter ) ] + } + initTestState :: TestState initTestState = TestState { tsHead = Nothing @@ -97,7 +111,7 @@ runTestTool st = do Nothing -> return () runExceptT (evalStateT testLoop initTestState) >>= \case - Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack x + Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack (showErebosError x) Right () -> return () getLineMb :: MonadIO m => m (Maybe Text) @@ -131,17 +145,20 @@ cmdOut line = do getPeer :: Text -> CommandM Peer -getPeer spidx = do +getPeer spidx = tpPeer <$> getTestPeer spidx + +getTestPeer :: Text -> CommandM TestPeer +getTestPeer spidx = do Just RunningServer {..} <- gets tsServer - Just peer <- lookup (read $ T.unpack spidx) . snd <$> liftIO (readMVar rsPeers) + Just peer <- find (((read $ T.unpack spidx) ==) . tpIndex) . snd <$> liftIO (readMVar rsPeers) return peer -getPeerIndex :: MVar (Int, [(Int, Peer)]) -> ServiceHandler (PairingService a) Int +getPeerIndex :: MVar ( Int, [ TestPeer ] ) -> ServiceHandler s Int getPeerIndex pmvar = do peer <- asks svcPeer - maybe 0 fst . find ((==peer) . snd) . snd <$> liftIO (readMVar pmvar) + maybe 0 tpIndex . find ((peer ==) . tpPeer) . snd <$> liftIO (readMVar pmvar) -pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar (Int, [(Int, Peer)]) -> String -> PairingAttributes a +pairingAttributes :: PairingResult a => proxy (PairingService a) -> Output -> MVar ( Int, [ TestPeer ] ) -> String -> PairingAttributes a pairingAttributes _ out peers prefix = PairingAttributes { pairingHookRequest = return () @@ -169,7 +186,7 @@ pairingAttributes _ out peers prefix = PairingAttributes , pairingHookFailed = \case PairingUserRejected -> failed "user" PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet - PairingFailedOther str -> failed $ "other " ++ str + PairingFailedOther err -> failed $ "other " ++ showErebosError err , pairingHookVerifyFailed = failed "verify" , pairingHookRejected = failed "rejected" } @@ -220,11 +237,11 @@ dmReceivedWatcher out smsg = do ] -newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String) +newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError ErebosError) instance MonadFail CommandM where - fail = throwError + fail = throwOtherError instance MonadRandom CommandM where getRandomBytes = liftIO . getRandomBytes @@ -244,6 +261,7 @@ type Command = CommandM () commands :: [(Text, Command)] commands = map (T.pack *** id) [ ("store", cmdStore) + , ("load", cmdLoad) , ("stored-generation", cmdStoredGeneration) , ("stored-roots", cmdStoredRoots) , ("stored-set-add", cmdStoredSetAdd) @@ -253,12 +271,19 @@ commands = map (T.pack *** id) , ("head-watch", cmdHeadWatch) , ("head-unwatch", cmdHeadUnwatch) , ("create-identity", cmdCreateIdentity) + , ("identity-info", cmdIdentityInfo) , ("start-server", cmdStartServer) , ("stop-server", cmdStopServer) , ("peer-add", cmdPeerAdd) , ("peer-drop", cmdPeerDrop) , ("peer-list", cmdPeerList) , ("test-message-send", cmdTestMessageSend) + , ("test-stream-open", cmdTestStreamOpen) + , ("test-stream-close", cmdTestStreamClose) + , ("test-stream-send", cmdTestStreamSend) + , ("local-state-get", cmdLocalStateGet) + , ("local-state-replace", cmdLocalStateReplace) + , ("local-state-wait", cmdLocalStateWait) , ("shared-state-get", cmdSharedStateGet) , ("shared-state-wait", cmdSharedStateWait) , ("watch-local-identity", cmdWatchLocalIdentity) @@ -275,9 +300,11 @@ commands = map (T.pack *** id) , ("contact-set-name", cmdContactSetName) , ("dm-send-peer", cmdDmSendPeer) , ("dm-send-contact", cmdDmSendContact) + , ("dm-send-identity", cmdDmSendIdentity) , ("dm-list-peer", cmdDmListPeer) , ("dm-list-contact", cmdDmListContact) , ("chatroom-create", cmdChatroomCreate) + , ("chatroom-delete", cmdChatroomDelete) , ("chatroom-list-local", cmdChatroomListLocal) , ("chatroom-watch-local", cmdChatroomWatchLocal) , ("chatroom-set-name", cmdChatroomSetName) @@ -285,19 +312,41 @@ commands = map (T.pack *** id) , ("chatroom-unsubscribe", cmdChatroomUnsubscribe) , ("chatroom-members", cmdChatroomMembers) , ("chatroom-join", cmdChatroomJoin) + , ("chatroom-join-as", cmdChatroomJoinAs) , ("chatroom-leave", cmdChatroomLeave) , ("chatroom-message-send", cmdChatroomMessageSend) + , ("discovery-connect", cmdDiscoveryConnect) ] cmdStore :: Command cmdStore = do st <- asks tiStorage + pst <- liftIO $ derivePartialStorage st [otype] <- asks tiParams ls <- getLines let cnt = encodeUtf8 $ T.unlines ls - ref <- liftIO $ unsafeStoreRawBytes st $ BL.fromChunks [encodeUtf8 otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] - cmdOut $ "store-done " ++ show (refDigest ref) + full = BL.fromChunks + [ encodeUtf8 otype + , BC.singleton ' ' + , BC.pack (show $ B.length cnt) + , BC.singleton '\n', cnt + ] + liftIO (copyRef st =<< storeRawBytes pst full) >>= \case + Right ref -> cmdOut $ "store-done " ++ show (refDigest ref) + Left _ -> cmdOut $ "store-failed" + +cmdLoad :: Command +cmdLoad = do + st <- asks tiStorage + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + let obj = load @Object ref + header : content <- return $ BL.lines $ serializeObject obj + cmdOut $ "load-type " <> T.unpack (decodeUtf8 $ BL.toStrict header) + forM_ content $ \line -> do + cmdOut $ "load-line " <> T.unpack (decodeUtf8 $ BL.toStrict line) + cmdOut "load-done" cmdStoredGeneration :: Command cmdStoredGeneration = do @@ -420,41 +469,92 @@ cmdCreateIdentity = do _ -> return [] storeHead st $ LocalState - { lsIdentity = idExtData identity + { lsPrev = Nothing + , lsIdentity = idExtData identity , lsShared = shared + , lsOther = [] } initTestHead h + cmdOut $ unwords [ "create-identity-done", "ref", show $ refDigest $ storedRef $ lsIdentity $ headObject h ] + +cmdIdentityInfo :: Command +cmdIdentityInfo = do + st <- asks tiStorage + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + let sidata = wrappedLoad ref + idata = fromSigned sidata + cmdOut $ unwords $ concat + [ [ "identity-info" ] + , [ "ref", T.unpack tref ] + , [ "base", show $ refDigest $ storedRef $ eiddStoredBase sidata ] + , maybe [] (\owner -> [ "owner", show $ refDigest $ storedRef owner ]) $ eiddOwner idata + , maybe [] (\name -> [ "name", T.unpack name ]) $ eiddName idata + ] cmdStartServer :: Command cmdStartServer = do out <- asks tiOutput + let parseParams = \case + (name : value : rest) + | name == "services" -> T.splitOn "," value + | otherwise -> parseParams rest + _ -> [] + serviceNames <- parseParams <$> asks tiParams + 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] + services <- forM serviceNames $ \case + "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" + "chatroom" -> return $ someService @ChatroomService Proxy + "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" + "discovery" -> return $ someService @DiscoveryService Proxy + "dm" -> return $ someServiceAttr $ directMessageAttributes out + "sync" -> return $ someService @SyncService Proxy + "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) + { testMessageReceived = \obj otype len sref -> do + liftIO $ do + void $ store (headStorage h) obj + outLine out $ unwords [ "test-message-received", otype, len, sref ] + , testStreamsReceived = \streams -> do + pidx <- getPeerIndex rsPeers + liftIO $ do + nums <- mapM getStreamReaderNumber streams + outLine out $ unwords $ "test-stream-open-from" : show pidx : map show nums + forM_ (zip nums streams) $ \( num, stream ) -> void $ forkIO $ do + let go = readStreamPacket stream >>= \case + StreamData seqNum bytes -> do + outLine out $ unwords [ "test-stream-received", show pidx, show num, show seqNum, BC.unpack bytes ] + go + StreamClosed seqNum -> do + outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ] + go } - ] + sname -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" + + rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services rsPeerThread <- liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange rsServer - let printPeer (idx, p) = do - params <- peerIdentity p >>= return . \case + let printPeer TestPeer {..} = do + params <- peerIdentity tpPeer >>= return . \case PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) - _ -> [ "addr", show (peerAddress p) ] - outLine out $ unwords $ [ "peer", show idx ] ++ params + _ -> [ "addr", show (peerAddress tpPeer) ] + outLine out $ unwords $ [ "peer", show tpIndex ] ++ params + + update ( tpIndex, [] ) = do + tpPeer <- return peer + tpStreamReaders <- newMVar [] + tpStreamWriters <- newMVar [] + let tp = TestPeer {..} + printPeer tp + return ( tpIndex + 1, [ tp ] ) - update (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) + update cur@( nid, p : ps ) + | tpPeer p == peer = printPeer p >> return cur + | otherwise = fmap (p :) <$> update ( nid, ps ) modifyMVar_ rsPeers update @@ -491,10 +591,10 @@ cmdPeerList = do peers <- liftIO $ getCurrentPeerList rsServer tpeers <- liftIO $ readMVar rsPeers forM_ peers $ \peer -> do - Just (n, _) <- return $ find ((peer==).snd) . snd $ tpeers + Just tp <- return $ find ((peer ==) . tpPeer) . snd $ tpeers mbpid <- peerIdentity peer cmdOut $ unwords $ concat - [ [ "peer-list-item", show n ] + [ [ "peer-list-item", show (tpIndex tp) ] , [ "addr", show (peerAddress peer) ] , case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners pid) _ -> [] @@ -511,13 +611,59 @@ cmdTestMessageSend = do sendManyToPeer peer $ map (TestMessage . wrappedLoad) refs cmdOut "test-message-send done" -cmdSharedStateGet :: Command -cmdSharedStateGet = do +cmdTestStreamOpen :: Command +cmdTestStreamOpen = do + spidx : rest <- asks tiParams + tp <- getTestPeer spidx + count <- case rest of + [] -> return 1 + tcount : _ -> return $ read $ T.unpack tcount + + out <- asks tiOutput + runPeerService (tpPeer tp) $ do + streams <- openTestStreams count + afterCommit $ do + nums <- mapM getStreamWriterNumber streams + modifyMVar_ (tpStreamWriters tp) $ return . (++ zip nums streams) + outLine out $ unwords $ "test-stream-open-done" + : T.unpack spidx + : map show nums + +cmdTestStreamClose :: Command +cmdTestStreamClose = do + [ spidx, sid ] <- asks tiParams + tp <- getTestPeer spidx + Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp)) + liftIO $ closeStream stream + cmdOut $ unwords [ "test-stream-close-done", T.unpack spidx, T.unpack sid ] + +cmdTestStreamSend :: Command +cmdTestStreamSend = do + [ spidx, sid, content ] <- asks tiParams + tp <- getTestPeer spidx + Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp)) + liftIO $ writeStream stream $ encodeUtf8 content + cmdOut $ unwords [ "test-stream-send-done", T.unpack spidx, T.unpack sid ] + +cmdLocalStateGet :: Command +cmdLocalStateGet = do h <- getHead - cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h) + cmdOut $ unwords $ "local-state-get" : map (show . refDigest . storedRef) [ headStoredObject h ] -cmdSharedStateWait :: Command -cmdSharedStateWait = do +cmdLocalStateReplace :: Command +cmdLocalStateReplace = do + st <- asks tiStorage + [ told, tnew ] <- asks tiParams + Just rold <- liftIO $ readRef st $ encodeUtf8 told + Just rnew <- liftIO $ readRef st $ encodeUtf8 tnew + ok <- updateLocalHead @LocalState $ \ls -> do + if storedRef ls == rold + then return ( wrappedLoad rnew, True ) + else return ( ls, False ) + cmdOut $ if ok then "local-state-replace-done" else "local-state-replace-failed" + +localStateWaitHelper :: Storable a => String -> (Head LocalState -> [ Stored a ]) -> Command +localStateWaitHelper label sel = do st <- asks tiStorage out <- asks tiOutput h <- getOrLoadHead @@ -525,15 +671,26 @@ cmdSharedStateWait = do liftIO $ do mvar <- newEmptyMVar - w <- watchHeadWith h (lsShared . headObject) $ \cur -> do + w <- watchHeadWith h sel $ \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 + outLine out $ unwords $ label : map T.unpack trefs void $ forkIO $ unwatchHead =<< takeMVar mvar _ -> return () putMVar mvar w +cmdLocalStateWait :: Command +cmdLocalStateWait = localStateWaitHelper "local-state-wait" ((: []) . headStoredObject) + +cmdSharedStateGet :: Command +cmdSharedStateGet = do + h <- getHead + cmdOut $ unwords $ "shared-state-get" : map (show . refDigest . storedRef) (lsShared $ headObject h) + +cmdSharedStateWait :: Command +cmdSharedStateWait = localStateWaitHelper "shared-state-wait" (lsShared . headObject) + cmdWatchLocalIdentity :: Command cmdWatchLocalIdentity = do h <- getOrLoadHead @@ -560,7 +717,7 @@ cmdWatchSharedIdentity = do cmdUpdateLocalIdentity :: Command cmdUpdateLocalIdentity = do [name] <- asks tiParams - updateLocalHead_ $ \ls -> do + updateLocalState_ $ \ls -> do Just identity <- return $ validateExtendedIdentity $ lsIdentity $ fromStored ls let public = idKeyIdentity identity @@ -575,8 +732,8 @@ cmdUpdateLocalIdentity = do cmdUpdateSharedIdentity :: Command cmdUpdateSharedIdentity = do [name] <- asks tiParams - updateLocalHead_ $ updateSharedState_ $ \case - Nothing -> throwError "no existing shared identity" + updateLocalState_ $ updateSharedState_ $ \case + Nothing -> throwOtherError "no existing shared identity" Just identity -> do let public = idKeyIdentity identity secret <- loadKey public @@ -645,7 +802,7 @@ cmdContactSetName :: Command cmdContactSetName = do [cid, name] <- asks tiParams contact <- getContact cid - updateLocalHead_ $ updateSharedState_ $ contactSetName contact name + updateLocalState_ $ updateSharedState_ $ contactSetName contact name cmdOut "contact-set-name-done" cmdDmSendPeer :: Command @@ -660,6 +817,14 @@ cmdDmSendContact = do Just to <- contactIdentity <$> getContact cid void $ sendDirectMessage to msg +cmdDmSendIdentity :: Command +cmdDmSendIdentity = do + st <- asks tiStorage + [ tid, msg ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tid + Just to <- return $ validateExtendedIdentity $ wrappedLoad ref + void $ sendDirectMessage to msg + dmList :: Foldable f => Identity f -> Command dmList peer = do threads <- toThreadList . lookupSharedValue . lsShared . headObject <$> getHead @@ -689,6 +854,13 @@ cmdChatroomCreate = do room <- createChatroom (Just name) Nothing cmdOut $ unwords $ "chatroom-create-done" : chatroomInfo room +cmdChatroomDelete :: Command +cmdChatroomDelete = do + [ cid ] <- asks tiParams + sdata <- getChatroomStateData cid + deleteChatroomByStateData sdata + cmdOut $ unwords [ "chatroom-delete-done", T.unpack cid ] + getChatroomStateData :: Text -> CommandM (Stored ChatroomStateData) getChatroomStateData tref = do st <- asks tiStorage @@ -714,7 +886,7 @@ cmdChatroomListLocal = do cmdChatroomWatchLocal :: Command cmdChatroomWatchLocal = do [] <- asks tiParams - h <- getHead + h <- getOrLoadHead out <- asks tiOutput void $ watchChatrooms h $ \_ -> \case Nothing -> return () @@ -772,6 +944,14 @@ cmdChatroomJoin = do joinChatroomByStateData =<< getChatroomStateData cid cmdOut "chatroom-join-done" +cmdChatroomJoinAs :: Command +cmdChatroomJoinAs = do + [ cid, name ] <- asks tiParams + st <- asks tiStorage + identity <- liftIO $ createIdentity st (Just name) Nothing + joinChatroomAsByStateData identity =<< getChatroomStateData cid + cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ] + cmdChatroomLeave :: Command cmdChatroomLeave = do [ cid ] <- asks tiParams @@ -783,3 +963,10 @@ cmdChatroomMessageSend = do [cid, msg] <- asks tiParams to <- getChatroomStateData cid void $ sendChatroomMessageByStateData to msg + +cmdDiscoveryConnect :: Command +cmdDiscoveryConnect = do + [ tref ] <- asks tiParams + Just dgst <- return $ readRefDigest $ encodeUtf8 tref + Just RunningServer {..} <- gets tsServer + discoverySearch rsServer dgst diff --git a/main/Test/Service.hs b/main/Test/Service.hs index 1018e0d..c0be07d 100644 --- a/main/Test/Service.hs +++ b/main/Test/Service.hs @@ -1,20 +1,26 @@ module Test.Service ( TestMessage(..), TestMessageAttributes(..), + + openTestStreams, ) where +import Control.Monad import Control.Monad.Reader import Data.ByteString.Lazy.Char8 qualified as BL import Erebos.Network +import Erebos.Object import Erebos.Service -import Erebos.Storage +import Erebos.Service.Stream +import Erebos.Storable data TestMessage = TestMessage (Stored Object) data TestMessageAttributes = TestMessageAttributes - { testMessageReceived :: String -> String -> String -> ServiceHandler TestMessage () + { testMessageReceived :: Object -> String -> String -> String -> ServiceHandler TestMessage () + , testStreamsReceived :: [ StreamReader ] -> ServiceHandler TestMessage () } instance Storable TestMessage where @@ -25,12 +31,27 @@ instance Service TestMessage where serviceID _ = mkServiceID "cb46b92c-9203-4694-8370-8742d8ac9dc8" type ServiceAttributes TestMessage = TestMessageAttributes - defaultServiceAttributes _ = TestMessageAttributes (\_ _ _ -> return ()) + defaultServiceAttributes _ = TestMessageAttributes + { testMessageReceived = \_ _ _ _ -> return () + , testStreamsReceived = \_ -> return () + } serviceHandler smsg = do let TestMessage sobj = fromStored smsg - case map BL.unpack $ BL.words $ BL.takeWhile (/='\n') $ serializeObject $ fromStored sobj of + obj = fromStored sobj + case map BL.unpack $ BL.words $ BL.takeWhile (/='\n') $ serializeObject obj of [otype, len] -> do cb <- asks $ testMessageReceived . svcAttributes - cb otype len (show $ refDigest $ storedRef sobj) + cb obj otype len (show $ refDigest $ storedRef sobj) _ -> return () + + streams <- receivedStreams + when (not $ null streams) $ do + cb <- asks $ testStreamsReceived . svcAttributes + cb streams + + +openTestStreams :: Int -> ServiceHandler TestMessage [ StreamWriter ] +openTestStreams count = do + replyPacket . TestMessage =<< mstore (Rec []) + replicateM count openStream diff --git a/main/WebSocket.hs b/main/WebSocket.hs new file mode 100644 index 0000000..fbdd65f --- /dev/null +++ b/main/WebSocket.hs @@ -0,0 +1,45 @@ +module WebSocket ( + startWebsocketServer, +) where + +import Control.Concurrent +import Control.Exception +import Control.Monad + +import Data.ByteString.Lazy qualified as BL +import Data.Unique + +import Erebos.Network + +import Network.WebSockets qualified as WS + + +data WebSocketAddress = WebSocketAddress Unique WS.Connection + +instance Eq WebSocketAddress where + WebSocketAddress u _ == WebSocketAddress u' _ = u == u' + +instance Ord WebSocketAddress where + compare (WebSocketAddress u _) (WebSocketAddress u' _) = compare u u' + +instance Show WebSocketAddress where + show (WebSocketAddress _ _) = "websocket" + +instance PeerAddressType WebSocketAddress where + sendBytesToAddress (WebSocketAddress _ conn) msg = do + WS.sendDataMessage conn $ WS.Binary $ BL.fromStrict msg + +startWebsocketServer :: Server -> String -> Int -> (String -> IO ()) -> IO () +startWebsocketServer server addr port logd = do + void $ forkIO $ do + WS.runServer addr port $ \pending -> do + conn <- WS.acceptRequest pending + u <- newUnique + let paddr = WebSocketAddress u conn + void $ serverPeerCustom server paddr + handle (\(e :: SomeException) -> logd $ "WebSocket thread exception: " ++ show e) $ do + WS.withPingThread conn 30 (return ()) $ do + forever $ do + WS.receiveDataMessage conn >>= \case + WS.Binary msg -> receivedFromCustomAddress server paddr $ BL.toStrict msg + WS.Text {} -> logd $ "unexpected websocket text message" diff --git a/src/Erebos/Attach.hs b/src/Erebos/Attach.hs index bd2f521..fad6197 100644 --- a/src/Erebos/Attach.hs +++ b/src/Erebos/Attach.hs @@ -20,7 +20,7 @@ import Erebos.Pairing import Erebos.PubKey import Erebos.Service import Erebos.State -import Erebos.Storage +import Erebos.Storable import Erebos.Storage.Key type AttachService = PairingService AttachIdentity @@ -52,7 +52,7 @@ instance PairingResult AttachIdentity where guard $ iddPrev (fromSigned $ idData identity) == [eiddStoredBase curid] return (identity, keys) - pairingFinalizeRequest (identity, keys) = updateLocalHead_ $ \slocal -> do + pairingFinalizeRequest (identity, keys) = updateLocalState_ $ \slocal -> do let owner = finalOwner identity st <- getStorage pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ] @@ -113,11 +113,11 @@ instance PairingResult AttachIdentity where svcPrint $ "Attachement failed" } -attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m () +attachToOwner :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachToOwner = pairingRequest @AttachIdentity Proxy -attachAccept :: (MonadIO m, MonadError String m) => Peer -> m () +attachAccept :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachAccept = pairingAccept @AttachIdentity Proxy -attachReject :: (MonadIO m, MonadError String m) => Peer -> m () +attachReject :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachReject = pairingReject @AttachIdentity Proxy diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index c8b5805..74456ff 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -6,6 +6,7 @@ module Erebos.Chatroom ( ChatroomState(..), ChatroomStateData(..), createChatroom, + deleteChatroomByStateData, updateChatroomByStateData, listChatrooms, findChatroomByRoomData, @@ -13,6 +14,7 @@ module Erebos.Chatroom ( chatroomSetSubscribe, chatroomMembers, joinChatroom, joinChatroomByStateData, + joinChatroomAs, joinChatroomAsByStateData, leaveChatroom, leaveChatroomByStateData, getMessagesSinceState, @@ -52,7 +54,8 @@ import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State -import Erebos.Storage +import Erebos.Storable +import Erebos.Storage.Head import Erebos.Storage.Merge import Erebos.Util @@ -178,22 +181,25 @@ threadToListSince since thread = helper (S.fromList since) thread cmpView msg = (zonedTimeToUTC $ mdTime $ fromSigned msg, msg) sendChatroomMessage - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => ChatroomState -> Text -> m () sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStateData rstate) msg sendChatroomMessageByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> Text -> m () -sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing (Just msg) False +sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing Nothing (Just msg) False sendRawChatroomMessageByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) - => Stored ChatroomStateData -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m () -sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) + => Stored ChatroomStateData -> Maybe UnifiedIdentity -> Maybe (Stored (Signed ChatMessageData)) -> Maybe Text -> Bool -> m () +sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave = void $ findAndUpdateChatroomState $ \cstate -> do guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate Just $ do - mdFrom <- finalOwner . localIdentity . fromStored <$> getLocalHead + mdFrom <- finalOwner <$> if + | Just identity <- mbIdentity -> return identity + | Just identity <- roomStateIdentity cstate -> return identity + | otherwise -> localIdentity . fromStored <$> getLocalHead secret <- loadKey $ idKeyMessage mdFrom mdTime <- liftIO getZonedTime let mdPrev = roomStateMessageData cstate @@ -202,10 +208,10 @@ sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ f else [] mdata <- mstore =<< sign secret =<< mstore ChatMessageData {..} - mergeSorted . (:[]) <$> mstore ChatroomStateData + mergeSorted . (:[]) <$> mstore emptyChatroomStateData { rsdPrev = roomStateData cstate - , rsdRoom = [] - , rsdSubscribe = Just True + , rsdSubscribe = Just (not mdLeave) + , rsdIdentity = mbIdentity , rsdMessages = [ mdata ] } @@ -213,15 +219,29 @@ sendRawChatroomMessageByStateData lookupData mdReplyTo mdText mdLeave = void $ f data ChatroomStateData = ChatroomStateData { rsdPrev :: [Stored ChatroomStateData] , rsdRoom :: [Stored (Signed ChatroomData)] + , rsdDelete :: Bool , rsdSubscribe :: Maybe Bool + , rsdIdentity :: Maybe UnifiedIdentity , rsdMessages :: [Stored (Signed ChatMessageData)] } +emptyChatroomStateData :: ChatroomStateData +emptyChatroomStateData = ChatroomStateData + { rsdPrev = [] + , rsdRoom = [] + , rsdDelete = False + , rsdSubscribe = Nothing + , rsdIdentity = Nothing + , rsdMessages = [] + } + data ChatroomState = ChatroomState { roomStateData :: [Stored ChatroomStateData] , roomStateRoom :: Maybe Chatroom , roomStateMessageData :: [Stored (Signed ChatMessageData)] + , roomStateDeleted :: Bool , roomStateSubscribe :: Bool + , roomStateIdentity :: Maybe UnifiedIdentity , roomStateMessages :: [ChatMessage] } @@ -229,13 +249,17 @@ instance Storable ChatroomStateData where store' ChatroomStateData {..} = storeRec $ do forM_ rsdPrev $ storeRef "PREV" forM_ rsdRoom $ storeRef "room" + when rsdDelete $ storeEmpty "delete" forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1 + forM_ rsdIdentity $ storeRef "id" . idExtData forM_ rsdMessages $ storeRef "msg" load' = loadRec $ do rsdPrev <- loadRefs "PREV" rsdRoom <- loadRefs "room" + rsdDelete <- isJust <$> loadMbEmpty "delete" rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe" + rsdIdentity <- loadMbUnifiedIdentity "id" rsdMessages <- loadRefs "msg" return ChatroomStateData {..} @@ -248,7 +272,9 @@ instance Mergeable ChatroomState where roomStateMessageData = filterAncestors $ concat $ flip findProperty roomStateData $ \case ChatroomStateData {..} | null rsdMessages -> Nothing | otherwise -> Just rsdMessages - roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData + roomStateDeleted = any (rsdDelete . fromStored) roomStateData + roomStateSubscribe = not roomStateDeleted && (fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData) + roomStateIdentity = findPropertyFirst rsdIdentity roomStateData roomStateMessages = threadToListSince [] $ concatMap (rsdMessages . fromStored) roomStateData in ChatroomState {..} @@ -257,19 +283,17 @@ instance Mergeable ChatroomState where instance SharedType (Set ChatroomState) where sharedTypeID _ = mkSharedTypeID "7bc71cbf-bc43-42b1-b413-d3a2c9a2aae0" -createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError String m) => Maybe Text -> Maybe Text -> m ChatroomState +createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e) => Maybe Text -> Maybe Text -> m ChatroomState createChatroom rdName rdDescription = do (secret, rdKey) <- liftIO . generateKeys =<< getStorage let rdPrev = [] rdata <- mstore =<< sign secret =<< mstore ChatroomData {..} - cstate <- mergeSorted . (:[]) <$> mstore ChatroomStateData - { rsdPrev = [] - , rsdRoom = [ rdata ] + cstate <- mergeSorted . (:[]) <$> mstore emptyChatroomStateData + { rsdRoom = [ rdata ] , rsdSubscribe = Just True - , rsdMessages = [] } - updateLocalHead $ updateSharedState $ \rooms -> do + updateLocalState $ updateSharedState $ \rooms -> do st <- getStorage (, cstate) <$> storeSetAdd st cstate rooms @@ -278,7 +302,7 @@ findAndUpdateChatroomState => (ChatroomState -> Maybe (m ChatroomState)) -> m (Maybe ChatroomState) findAndUpdateChatroomState f = do - updateLocalHead $ updateSharedState $ \roomSet -> do + updateLocalState $ updateSharedState $ \roomSet -> do let roomList = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet case catMaybes $ map (\x -> (x,) <$> f x) roomList of ((orig, act) : _) -> do @@ -292,8 +316,19 @@ findAndUpdateChatroomState f = do return (roomSet, Just upd) [] -> return (roomSet, Nothing) +deleteChatroomByStateData + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) + => Stored ChatroomStateData -> m () +deleteChatroomByStateData lookupData = void $ findAndUpdateChatroomState $ \cstate -> do + guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate + Just $ do + mergeSorted . (:[]) <$> mstore emptyChatroomStateData + { rsdPrev = roomStateData cstate + , rsdDelete = True + } + updateChatroomByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> Maybe Text -> Maybe Text @@ -309,16 +344,16 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat , rdDescription = newDesc , rdKey = roomKey room } - mergeSorted . (:[]) <$> mstore ChatroomStateData + mergeSorted . (:[]) <$> mstore emptyChatroomStateData { rsdPrev = roomStateData cstate , rsdRoom = [ rdata ] , rsdSubscribe = Just True - , rsdMessages = [] } listChatrooms :: MonadHead LocalState m => m [ChatroomState] -listChatrooms = fromSetBy (comparing $ roomName <=< roomStateRoom) . +listChatrooms = filter (not . roomStateDeleted) . + fromSetBy (comparing $ roomName <=< roomStateRoom) . lookupSharedValue . lsShared . fromStored <$> getLocalHead findChatroom :: MonadHead LocalState m => (ChatroomState -> Bool) -> m (Maybe ChatroomState) @@ -334,16 +369,14 @@ findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData chatroomSetSubscribe - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> Bool -> m () chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ \cstate -> do guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate Just $ do - mergeSorted . (:[]) <$> mstore ChatroomStateData + mergeSorted . (:[]) <$> mstore emptyChatroomStateData { rsdPrev = roomStateData cstate - , rsdRoom = [] , rsdSubscribe = Just subscribe - , rsdMessages = [] } chatroomMembers :: ChatroomState -> [ ComposedIdentity ] @@ -357,24 +390,34 @@ chatroomMembers ChatroomState {..} = toList $ ancestors $ roomStateMessageData joinChatroom - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => ChatroomState -> m () joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate) joinChatroomByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> m () -joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing False +joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing False + +joinChatroomAs + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) + => UnifiedIdentity -> ChatroomState -> m () +joinChatroomAs identity rstate = joinChatroomAsByStateData identity (head $ roomStateData rstate) + +joinChatroomAsByStateData + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) + => UnifiedIdentity -> Stored ChatroomStateData -> m () +joinChatroomAsByStateData identity lookupData = sendRawChatroomMessageByStateData lookupData (Just identity) Nothing Nothing False leaveChatroom - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => ChatroomState -> m () leaveChatroom rstate = leaveChatroomByStateData (head $ roomStateData rstate) leaveChatroomByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> m () -leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing True +leaveChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing Nothing True getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage] getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur) @@ -396,7 +439,7 @@ watchChatrooms h f = liftIO $ do return $ makeChatroomDiff lastList curList chatroomSetToList :: Set ChatroomState -> [(Stored ChatroomStateData, ChatroomState)] -chatroomSetToList = map (cmp &&& id) . fromSetBy (comparing cmp) +chatroomSetToList = map (cmp &&& id) . filter (not . roomStateDeleted) . fromSetBy (comparing cmp) where cmp :: ChatroomState -> Stored ChatroomStateData cmp = head . filterAncestors . concatMap storedRoots . toComponents @@ -480,7 +523,7 @@ instance Service ChatroomService where } when (not $ null chatRoomInfo) $ do - updateLocalHead_ $ updateSharedState_ $ \roomSet -> do + updateLocalState_ $ updateSharedState_ $ \roomSet -> do let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet upd set (roomInfo :: Stored (Signed ChatroomData)) = do let currentRoots = storedRoots roomInfo @@ -494,11 +537,9 @@ instance Service ChatroomService where -- update local state only if we got roomInfo not present there if roomInfo `notElem` prevRoom && roomInfo `elem` room then do - sdata <- mstore ChatroomStateData + sdata <- mstore emptyChatroomStateData { rsdPrev = prev , rsdRoom = room - , rsdSubscribe = Nothing - , rsdMessages = [] } storeSetAddComponent sdata set else return set @@ -521,7 +562,7 @@ instance Service ChatroomService where svcModify $ \ps -> ps { psSubscribedTo = filter (/= leastRoot) (psSubscribedTo ps) } when (not (null chatRoomMessage)) $ do - updateLocalHead_ $ updateSharedState_ $ \roomSet -> do + updateLocalState_ $ updateSharedState_ $ \roomSet -> do let rooms = fromSetBy (comparing $ roomName <=< roomStateRoom) roomSet upd set (msgData :: Stored (Signed ChatMessageData)) | Just msg <- validateSingleMessage msgData = do @@ -538,10 +579,8 @@ instance Service ChatroomService where -- update local state only if subscribed and we got some new messages if roomStateSubscribe prev && messages /= prevMessages then do - sdata <- mstore ChatroomStateData + sdata <- mstore emptyChatroomStateData { rsdPrev = prevData - , rsdRoom = [] - , rsdSubscribe = Nothing , rsdMessages = messages } storeSetAddComponent sdata set diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs index d90aa50..88e6c44 100644 --- a/src/Erebos/Contact.hs +++ b/src/Erebos/Contact.hs @@ -28,7 +28,7 @@ import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State -import Erebos.Storage +import Erebos.Storable import Erebos.Storage.Merge data Contact = Contact @@ -155,17 +155,17 @@ instance PairingResult ContactAccepted where svcPrint $ "Contact failed" } -contactRequest :: (MonadIO m, MonadError String m) => Peer -> m () +contactRequest :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactRequest = pairingRequest @ContactAccepted Proxy -contactAccept :: (MonadIO m, MonadError String m) => Peer -> m () +contactAccept :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactAccept = pairingAccept @ContactAccepted Proxy -contactReject :: (MonadIO m, MonadError String m) => Peer -> m () +contactReject :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactReject = pairingReject @ContactAccepted Proxy finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m () -finalizeContact identity = updateLocalHead_ $ updateSharedState_ $ \contacts -> do +finalizeContact identity = updateLocalState_ $ updateSharedState_ $ \contacts -> do st <- getStorage cdata <- wrappedStore st ContactData { cdPrev = [] diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs index 63475bd..187fddd 100644 --- a/src/Erebos/Conversation.hs +++ b/src/Erebos/Conversation.hs @@ -18,6 +18,7 @@ module Erebos.Conversation ( conversationHistory, sendMessage, + deleteConversation, ) where import Control.Monad.Except @@ -29,11 +30,11 @@ import Data.Text qualified as T import Data.Time.Format import Data.Time.LocalTime -import Erebos.Identity import Erebos.Chatroom -import Erebos.Message hiding (formatMessage) +import Erebos.DirectMessage +import Erebos.Identity import Erebos.State -import Erebos.Storage +import Erebos.Storable data Message = DirectMessageMessage DirectMessage Bool @@ -70,7 +71,7 @@ directMessageConversation :: MonadHead LocalState m => ComposedIdentity -> m Con directMessageConversation peer = do (find (sameIdentity peer . msgPeer) . toThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead) >>= \case Just thread -> return $ DirectMessageConversation thread - Nothing -> return $ DirectMessageConversation $ DirectMessageThread peer [] [] [] + Nothing -> return $ DirectMessageConversation $ DirectMessageThread peer [] [] [] [] chatroomConversation :: MonadHead LocalState m => ChatroomState -> m (Maybe Conversation) chatroomConversation rstate = chatroomConversationByStateData (head $ roomStateData rstate) @@ -100,6 +101,10 @@ conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMess conversationHistory (ChatroomConversation rstate) = map (\msg -> ChatroomMessage msg False) $ roomStateMessages rstate -sendMessage :: (MonadHead LocalState m, MonadError String m) => Conversation -> Text -> m (Maybe Message) +sendMessage :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> Text -> m (Maybe Message) sendMessage (DirectMessageConversation thread) text = fmap Just $ DirectMessageMessage <$> (fromStored <$> sendDirectMessage (msgPeer thread) text) <*> pure False sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text >> return Nothing + +deleteConversation :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> m () +deleteConversation (DirectMessageConversation _) = throwOtherError "deleting direct message conversation is not supported" +deleteConversation (ChatroomConversation rstate) = deleteChatroomByStateData (head $ roomStateData rstate) diff --git a/src/Erebos/Message.hs b/src/Erebos/DirectMessage.hs index 5ef27f3..dc6724c 100644 --- a/src/Erebos/Message.hs +++ b/src/Erebos/DirectMessage.hs @@ -1,4 +1,4 @@ -module Erebos.Message ( +module Erebos.DirectMessage ( DirectMessage(..), sendDirectMessage, @@ -13,7 +13,6 @@ module Erebos.Message ( messageThreadView, watchReceivedMessages, - formatMessage, formatDirectMessage, ) where @@ -29,11 +28,14 @@ import qualified Data.Text as T import Data.Time.Format import Data.Time.LocalTime +import Erebos.Discovery import Erebos.Identity import Erebos.Network +import Erebos.Object import Erebos.Service import Erebos.State -import Erebos.Storage +import Erebos.Storable +import Erebos.Storage.Head import Erebos.Storage.Merge data DirectMessage = DirectMessage @@ -103,8 +105,10 @@ instance Service DirectMessage where serviceNewPeer = syncDirectMessageToPeer . lookupSharedValue . lsShared . fromStored =<< svcGetLocal - serviceStorageWatchers _ = (:[]) $ - SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer + serviceStorageWatchers _ = + [ SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer + , GlobalStorageWatcher (lookupSharedValue . lsShared . fromStored) findMissingPeers + ] data MessageState = MessageState @@ -157,9 +161,9 @@ findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do return $ sel x -sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m) +sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m) => Identity f -> Text -> m (Stored DirectMessage) -sendDirectMessage pid text = updateLocalHead $ \ls -> do +sendDirectMessage pid text = updateLocalState $ \ls -> do let self = localIdentity $ fromStored ls powner = finalOwner pid flip updateSharedState ls $ \(DirectMessageThreads prev _) -> do @@ -189,7 +193,7 @@ syncDirectMessageToPeer (DirectMessageThreads mss _) = do peer <- asks svcPeer let thread = messageThreadFor pid mss mapM_ (sendToPeerStored peer) $ msgHead thread - updateLocalHead_ $ \ls -> do + updateLocalState_ $ \ls -> do let powner = finalOwner pid flip updateSharedState_ ls $ \unchanged@(DirectMessageThreads prev _) -> do let ready = findMsgProperty powner msReady prev @@ -210,12 +214,19 @@ syncDirectMessageToPeer (DirectMessageThreads mss _) = do else do return unchanged +findMissingPeers :: Server -> DirectMessageThreads -> ExceptT ErebosError IO () +findMissingPeers server threads = do + forM_ (toThreadList threads) $ \thread -> do + when (msgHead thread /= msgReceived thread) $ do + mapM_ (discoverySearch server) $ map (refDigest . storedRef) $ idDataF $ msgPeer thread + data DirectMessageThread = DirectMessageThread { msgPeer :: ComposedIdentity - , msgHead :: [Stored DirectMessage] - , msgSent :: [Stored DirectMessage] - , msgSeen :: [Stored DirectMessage] + , msgHead :: [ Stored DirectMessage ] + , msgSent :: [ Stored DirectMessage ] + , msgSeen :: [ Stored DirectMessage ] + , msgReceived :: [ Stored DirectMessage ] } threadToList :: DirectMessageThread -> [DirectMessage] @@ -249,6 +260,7 @@ messageThreadFor peer mss = , msgHead = filterAncestors $ ready ++ received , msgSent = filterAncestors $ sent ++ received , msgSeen = filterAncestors $ ready ++ seen + , msgReceived = filterAncestors $ received } @@ -259,10 +271,6 @@ watchReceivedMessages h f = do forM_ (map fromStored sms) $ \ms -> do mapM_ f $ filter (not . sameIdentity self . msgFrom . fromStored) $ msReceived ms -{-# DEPRECATED formatMessage "use formatDirectMessage instead" #-} -formatMessage :: TimeZone -> DirectMessage -> String -formatMessage = formatDirectMessage - formatDirectMessage :: TimeZone -> DirectMessage -> String formatDirectMessage tzone msg = concat [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index 48df9c3..2fb0ffe 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE CPP #-} + module Erebos.Discovery ( DiscoveryService(..), - DiscoveryConnection(..) + DiscoveryAttributes(..), + DiscoveryConnection(..), + + discoverySearch, ) where import Control.Concurrent @@ -8,196 +13,344 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Data.IP qualified as IP +import Data.List import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M +import Data.Map.Strict qualified as M import Data.Maybe +import Data.Proxy +import Data.Set (Set) +import Data.Set qualified as S import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T +import Data.Word import Network.Socket +#ifdef ENABLE_ICE_SUPPORT import Erebos.ICE +#endif import Erebos.Identity import Erebos.Network +import Erebos.Object import Erebos.Service -import Erebos.Storage +import Erebos.Storable -keepaliveSeconds :: Int -keepaliveSeconds = 20 +#ifndef ENABLE_ICE_SUPPORT +type IceConfig = () +type IceSession = () +type IceRemoteInfo = Stored Object +#endif -data DiscoveryService = DiscoverySelf Text Int - | DiscoveryAcknowledged Text - | DiscoverySearch Ref - | DiscoveryResult Ref (Maybe Text) - | DiscoveryConnectionRequest DiscoveryConnection - | DiscoveryConnectionResponse DiscoveryConnection +data DiscoveryService + = DiscoverySelf [ Text ] (Maybe Int) + | DiscoveryAcknowledged [ Text ] (Maybe Text) (Maybe Word16) (Maybe Text) (Maybe Word16) + | DiscoverySearch (Either Ref RefDigest) + | DiscoveryResult (Either Ref RefDigest) [ Text ] + | DiscoveryConnectionRequest DiscoveryConnection + | DiscoveryConnectionResponse DiscoveryConnection + +data DiscoveryAttributes = DiscoveryAttributes + { discoveryStunPort :: Maybe Word16 + , discoveryStunServer :: Maybe Text + , discoveryTurnPort :: Maybe Word16 + , discoveryTurnServer :: Maybe Text + } + +defaultDiscoveryAttributes :: DiscoveryAttributes +defaultDiscoveryAttributes = DiscoveryAttributes + { discoveryStunPort = Nothing + , discoveryStunServer = Nothing + , discoveryTurnPort = Nothing + , discoveryTurnServer = Nothing + } data DiscoveryConnection = DiscoveryConnection - { dconnSource :: Ref - , dconnTarget :: Ref + { dconnSource :: Either Ref RefDigest + , dconnTarget :: Either Ref RefDigest , dconnAddress :: Maybe Text - , dconnIceSession :: Maybe IceRemoteInfo + , dconnIceInfo :: Maybe IceRemoteInfo } -emptyConnection :: Ref -> Ref -> DiscoveryConnection -emptyConnection source target = DiscoveryConnection source target Nothing Nothing +emptyConnection :: Either Ref RefDigest -> Either Ref RefDigest -> DiscoveryConnection +emptyConnection dconnSource dconnTarget = DiscoveryConnection {..} + where + dconnAddress = Nothing + dconnIceInfo = Nothing instance Storable DiscoveryService where store' x = storeRec $ do case x of - DiscoverySelf addr priority -> do - storeText "self" addr - storeInt "priority" priority - DiscoveryAcknowledged addr -> do - storeText "ack" addr - DiscoverySearch ref -> storeRawRef "search" ref - DiscoveryResult ref addr -> do - storeRawRef "result" ref - storeMbText "address" addr + DiscoverySelf addrs priority -> do + mapM_ (storeText "self") addrs + mapM_ (storeInt "priority") priority + DiscoveryAcknowledged addrs stunServer stunPort turnServer turnPort -> do + if null addrs then storeEmpty "ack" + else mapM_ (storeText "ack") addrs + storeMbText "stun-server" stunServer + storeMbInt "stun-port" stunPort + storeMbText "turn-server" turnServer + storeMbInt "turn-port" turnPort + DiscoverySearch edgst -> either (storeRawRef "search") (storeRawWeak "search") edgst + DiscoveryResult edgst addr -> do + either (storeRawRef "result") (storeRawWeak "result") edgst + mapM_ (storeText "address") addr DiscoveryConnectionRequest conn -> storeConnection "request" conn DiscoveryConnectionResponse conn -> storeConnection "response" conn - where storeConnection ctype conn = do - storeText "connection" $ ctype - storeRawRef "source" $ dconnSource conn - storeRawRef "target" $ dconnTarget conn - storeMbText "address" $ dconnAddress conn - storeMbRef "ice-session" $ dconnIceSession conn + where + storeConnection ctype DiscoveryConnection {..} = do + storeText "connection" $ ctype + either (storeRawRef "source") (storeRawWeak "source") dconnSource + either (storeRawRef "target") (storeRawWeak "target") dconnTarget + storeMbText "address" dconnAddress + storeMbRef "ice-info" dconnIceInfo load' = loadRec $ msum - [ DiscoverySelf - <$> loadText "self" - <*> loadInt "priority" - , DiscoveryAcknowledged - <$> loadText "ack" - , DiscoverySearch <$> loadRawRef "search" + [ do + addrs <- loadTexts "self" + guard (not $ null addrs) + DiscoverySelf addrs + <$> loadMbInt "priority" + , do + addrs <- loadTexts "ack" + mbEmpty <- loadMbEmpty "ack" + guard (not (null addrs) || isJust mbEmpty) + DiscoveryAcknowledged + <$> pure addrs + <*> loadMbText "stun-server" + <*> loadMbInt "stun-port" + <*> loadMbText "turn-server" + <*> loadMbInt "turn-port" + , DiscoverySearch <$> msum + [ Left <$> loadRawRef "search" + , Right <$> loadRawWeak "search" + ] , DiscoveryResult - <$> loadRawRef "result" - <*> loadMbText "address" + <$> msum + [ Left <$> loadRawRef "result" + , Right <$> loadRawWeak "result" + ] + <*> loadTexts "address" , loadConnection "request" DiscoveryConnectionRequest , loadConnection "response" DiscoveryConnectionResponse ] - where loadConnection ctype ctor = do - ctype' <- loadText "connection" - guard $ ctype == ctype' - return . ctor =<< DiscoveryConnection - <$> loadRawRef "source" - <*> loadRawRef "target" - <*> loadMbText "address" - <*> loadMbRef "ice-session" + where + loadConnection ctype ctor = do + ctype' <- loadText "connection" + guard $ ctype == ctype' + dconnSource <- msum + [ Left <$> loadRawRef "source" + , Right <$> loadRawWeak "source" + ] + dconnTarget <- msum + [ Left <$> loadRawRef "target" + , Right <$> loadRawWeak "target" + ] + dconnAddress <- loadMbText "address" + dconnIceInfo <- loadMbRef "ice-info" + return $ ctor DiscoveryConnection {..} data DiscoveryPeer = DiscoveryPeer { dpPriority :: Int , dpPeer :: Maybe Peer - , dpAddress :: Maybe Text + , dpAddress :: [ Text ] , dpIceSession :: Maybe IceSession } +emptyPeer :: DiscoveryPeer +emptyPeer = DiscoveryPeer + { dpPriority = 0 + , dpPeer = Nothing + , dpAddress = [] + , dpIceSession = Nothing + } + +data DiscoveryPeerState = DiscoveryPeerState + { dpsStunServer :: Maybe ( Text, Word16 ) + , dpsTurnServer :: Maybe ( Text, Word16 ) + , dpsIceConfig :: Maybe IceConfig + } + +data DiscoveryGlobalState = DiscoveryGlobalState + { dgsPeers :: Map RefDigest DiscoveryPeer + , dgsSearchingFor :: Set RefDigest + } + instance Service DiscoveryService where - serviceID _ = mkServiceID "dd59c89c-69cc-4703-b75b-4ddcd4b3c23b" + serviceID _ = mkServiceID "dd59c89c-69cc-4703-b75b-4ddcd4b3c23c" + + type ServiceAttributes DiscoveryService = DiscoveryAttributes + defaultServiceAttributes _ = defaultDiscoveryAttributes - type ServiceGlobalState DiscoveryService = Map RefDigest DiscoveryPeer - emptyServiceGlobalState _ = M.empty + type ServiceState DiscoveryService = DiscoveryPeerState + emptyServiceState _ = DiscoveryPeerState + { dpsStunServer = Nothing + , dpsTurnServer = Nothing + , dpsIceConfig = Nothing + } + + type ServiceGlobalState DiscoveryService = DiscoveryGlobalState + emptyServiceGlobalState _ = DiscoveryGlobalState + { dgsPeers = M.empty + , dgsSearchingFor = S.empty + } serviceHandler msg = case fromStored msg of - DiscoverySelf addr priority -> do + DiscoverySelf addrs priority -> do pid <- asks svcPeerIdentity peer <- asks svcPeer let insertHelper new old | dpPriority new > dpPriority old = new | otherwise = old - mbaddr <- case words (T.unpack addr) of - [ipaddr, port] | DatagramAddress paddr <- peerAddress peer -> do + matchedAddrs <- fmap catMaybes $ forM addrs $ \addr -> if + | addr == T.pack "ICE" -> do + return $ Just addr + + | [ ipaddr, port ] <- words (T.unpack addr) + , DatagramAddress paddr <- peerAddress peer -> do saddr <- liftIO $ head <$> getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) return $ if paddr == addrAddress saddr then Just addr else Nothing - _ -> return Nothing - forM_ (idDataF =<< unfoldOwners pid) $ \s -> - svcModifyGlobal $ M.insertWith insertHelper (refDigest $ storedRef s) $ - DiscoveryPeer priority (Just peer) mbaddr Nothing - replyPacket $ DiscoveryAcknowledged $ fromMaybe (T.pack "ICE") mbaddr - - DiscoveryAcknowledged addr -> do - when (addr == T.pack "ICE") $ do - -- keep-alive packet from behind NAT - peer <- asks svcPeer - liftIO $ void $ forkIO $ do - threadDelay (keepaliveSeconds * 1000 * 1000) - res <- runExceptT $ sendToPeer peer $ DiscoverySelf addr 0 - case res of - Right _ -> return () - Left err -> putStrLn $ "Discovery: failed to send keep-alive: " ++ err - - DiscoverySearch ref -> do - addr <- M.lookup (refDigest ref) <$> svcGetGlobal - replyPacket $ DiscoveryResult ref $ fromMaybe (T.pack "ICE") . dpAddress <$> addr - - DiscoveryResult ref Nothing -> do - svcPrint $ "Discovery: " ++ show (refDigest ref) ++ " not found" - - DiscoveryResult ref (Just addr) -> do + + | otherwise -> return Nothing + + forM_ (idDataF =<< unfoldOwners pid) $ \sdata -> do + let dp = DiscoveryPeer + { dpPriority = fromMaybe 0 priority + , dpPeer = Just peer + , dpAddress = addrs + , dpIceSession = Nothing + } + svcModifyGlobal $ \s -> s { dgsPeers = M.insertWith insertHelper (refDigest $ storedRef sdata) dp $ dgsPeers s } + attrs <- asks svcAttributes + replyPacket $ DiscoveryAcknowledged matchedAddrs + (discoveryStunServer attrs) + (discoveryStunPort attrs) + (discoveryTurnServer attrs) + (discoveryTurnPort attrs) + + DiscoveryAcknowledged _ stunServer stunPort turnServer turnPort -> do + paddr <- asks (peerAddress . svcPeer) >>= return . \case + (DatagramAddress saddr) -> case IP.fromSockAddr saddr of + Just (IP.IPv6 ipv6, _) + | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6 + -> Just $ T.pack $ show (IP.toIPv4w ipv4) + Just (addr, _) + -> Just $ T.pack $ show addr + _ -> Nothing + _ -> Nothing + + let toIceServer Nothing Nothing = Nothing + toIceServer Nothing (Just port) = ( , port) <$> paddr + toIceServer (Just server) Nothing = Just ( server, 0 ) + toIceServer (Just server) (Just port) = Just ( server, port ) + + svcModify $ \s -> s + { dpsStunServer = toIceServer stunServer stunPort + , dpsTurnServer = toIceServer turnServer turnPort + } + + DiscoverySearch edgst -> do + dpeer <- M.lookup (either refDigest id edgst) . dgsPeers <$> svcGetGlobal + replyPacket $ DiscoveryResult edgst $ maybe [] dpAddress dpeer + + DiscoveryResult edgst [] -> do + svcPrint $ "Discovery: " ++ show (either refDigest id edgst) ++ " not found" + + DiscoveryResult edgst addrs -> do + let dgst = either refDigest id edgst -- TODO: check if we really requested that server <- asks svcServer - if addr == T.pack "ICE" - then do - self <- svcSelf - peer <- asks svcPeer - ice <- liftIO $ iceCreate PjIceSessRoleControlling $ \ice -> do - rinfo <- iceRemoteInfo ice - res <- runExceptT $ sendToPeer peer $ - DiscoveryConnectionRequest (emptyConnection (storedRef $ idData self) ref) { dconnIceSession = Just rinfo } - case res of - Right _ -> return () - Left err -> putStrLn $ "Discovery: failed to send connection request: " ++ err - - svcModifyGlobal $ M.insert (refDigest ref) $ - DiscoveryPeer 0 Nothing Nothing (Just ice) - else do - case words (T.unpack addr) of - [ipaddr, port] -> do - saddr <- liftIO $ head <$> - getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) - peer <- liftIO $ serverPeer server (addrAddress saddr) - svcModifyGlobal $ M.insert (refDigest ref) $ - DiscoveryPeer 0 (Just peer) Nothing Nothing + st <- getStorage + self <- svcSelf + discoveryPeer <- asks svcPeer + let runAsService = runPeerService @DiscoveryService discoveryPeer + + forM_ addrs $ \addr -> if + | addr == T.pack "ICE" + -> do +#ifdef ENABLE_ICE_SUPPORT + getIceConfig >>= \case + Just config -> void $ liftIO $ forkIO $ do + ice <- iceCreateSession config PjIceSessRoleControlling $ \ice -> do + rinfo <- iceRemoteInfo ice + + -- Try to promote weak ref to normal one for older peers: + edgst' <- case edgst of + Left r -> return (Left r) + Right d -> refFromDigest st d >>= \case + Just r -> return (Left r) + Nothing -> return (Right d) + + res <- runExceptT $ sendToPeer discoveryPeer $ + DiscoveryConnectionRequest (emptyConnection (Left $ storedRef $ idData self) edgst') { dconnIceInfo = Just rinfo } + case res of + Right _ -> return () + Left err -> putStrLn $ "Discovery: failed to send connection request: " ++ err - _ -> svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr + runAsService $ do + let upd dp = dp { dpIceSession = Just ice } + svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) dgst $ dgsPeers s } + + Nothing -> do + return () +#endif + return () + + | [ ipaddr, port ] <- words (T.unpack addr) -> do + void $ liftIO $ forkIO $ do + saddr <- head <$> + getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) + peer <- serverPeer server (addrAddress saddr) + runAsService $ do + let upd dp = dp { dpPeer = Just peer } + svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) dgst $ dgsPeers s } + + | otherwise -> do + svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr DiscoveryConnectionRequest conn -> do self <- svcSelf let rconn = emptyConnection (dconnSource conn) (dconnTarget conn) - if refDigest (dconnTarget conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self) - then do - -- request for us, create ICE sesssion + if either refDigest id (dconnTarget conn) `elem` identityDigests self + then if +#ifdef ENABLE_ICE_SUPPORT + -- request for us, create ICE sesssion + | Just prinfo <- dconnIceInfo conn -> do server <- asks svcServer peer <- asks svcPeer - liftIO $ void $ iceCreate PjIceSessRoleControlled $ \ice -> do - rinfo <- iceRemoteInfo ice - res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionResponse rconn { dconnIceSession = Just rinfo } - case res of - Right _ -> do - case dconnIceSession conn of - Just prinfo -> iceConnect ice prinfo $ void $ serverPeerIce server ice - Nothing -> putStrLn $ "Discovery: connection request without ICE remote info" - Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err + getIceConfig >>= \case + Just config -> do + liftIO $ void $ iceCreateSession config PjIceSessRoleControlled $ \ice -> do + rinfo <- iceRemoteInfo ice + res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionResponse rconn { dconnIceInfo = Just rinfo } + case res of + Right _ -> iceConnect ice prinfo $ void $ serverPeerIce server ice + Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err + Nothing -> do + return () +#endif - else do + | otherwise -> do + svcPrint $ "Discovery: unsupported connection request" + + else do -- request to some of our peers, relay - mbdp <- M.lookup (refDigest $ dconnTarget conn) <$> svcGetGlobal + mbdp <- M.lookup (either refDigest id $ dconnTarget conn) . dgsPeers <$> svcGetGlobal case mbdp of Nothing -> replyPacket $ DiscoveryConnectionResponse rconn - Just dp | Just addr <- dpAddress dp -> do - replyPacket $ DiscoveryConnectionResponse rconn { dconnAddress = Just addr } - | Just dpeer <- dpPeer dp -> do - sendToPeer dpeer $ DiscoveryConnectionRequest conn - | otherwise -> svcPrint $ "Discovery: failed to relay connection request" + Just dp + | Just dpeer <- dpPeer dp -> do + sendToPeer dpeer $ DiscoveryConnectionRequest conn + | otherwise -> svcPrint $ "Discovery: failed to relay connection request" DiscoveryConnectionResponse conn -> do self <- svcSelf - dpeers <- svcGetGlobal - if refDigest (dconnSource conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self) + dpeers <- dgsPeers <$> svcGetGlobal + if either refDigest id (dconnSource conn) `elem` identityDigests self then do -- response to our request, try to connect to the peer server <- asks svcServer @@ -206,18 +359,91 @@ instance Service DiscoveryService where saddr <- liftIO $ head <$> getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) peer <- liftIO $ serverPeer server (addrAddress saddr) - svcModifyGlobal $ M.insert (refDigest $ dconnTarget conn) $ - DiscoveryPeer 0 (Just peer) Nothing Nothing + let upd dp = dp { dpPeer = Just peer } + svcModifyGlobal $ \s -> s + { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) (either refDigest id $ dconnTarget conn) $ dgsPeers s } - | Just dp <- M.lookup (refDigest $ dconnTarget conn) dpeers +#ifdef ENABLE_ICE_SUPPORT + | Just dp <- M.lookup (either refDigest id $ dconnTarget conn) dpeers , Just ice <- dpIceSession dp - , Just rinfo <- dconnIceSession conn -> do + , Just rinfo <- dconnIceInfo conn -> do liftIO $ iceConnect ice rinfo $ void $ serverPeerIce server ice +#endif | otherwise -> svcPrint $ "Discovery: connection request failed" else do -- response to relayed request - case M.lookup (refDigest $ dconnSource conn) dpeers of + case M.lookup (either refDigest id $ dconnSource conn) dpeers of Just dp | Just dpeer <- dpPeer dp -> do sendToPeer dpeer $ DiscoveryConnectionResponse conn _ -> svcPrint $ "Discovery: failed to relay connection response" + + serviceNewPeer = do + server <- asks svcServer + peer <- asks svcPeer + + let addrToText saddr = do + ( addr, port ) <- IP.fromSockAddr saddr + Just $ T.pack $ show addr <> " " <> show port + addrs <- concat <$> sequence + [ catMaybes . map addrToText <$> liftIO (getServerAddresses server) +#ifdef ENABLE_ICE_SUPPORT + , return [ T.pack "ICE" ] +#endif + ] + + pid <- asks svcPeerIdentity + gs <- svcGetGlobal + let searchingFor = foldl' (flip S.delete) (dgsSearchingFor gs) (identityDigests pid) + svcModifyGlobal $ \s -> s { dgsSearchingFor = searchingFor } + + when (not $ null addrs) $ do + sendToPeer peer $ DiscoverySelf addrs Nothing + forM_ searchingFor $ \dgst -> do + sendToPeer peer $ DiscoverySearch (Right dgst) + +#ifdef ENABLE_ICE_SUPPORT + serviceStopServer _ _ _ pstates = do + forM_ pstates $ \( _, DiscoveryPeerState {..} ) -> do + mapM_ iceStopThread dpsIceConfig +#endif + + +identityDigests :: Foldable f => Identity f -> [ RefDigest ] +identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid + + +getIceConfig :: ServiceHandler DiscoveryService (Maybe IceConfig) +getIceConfig = do + dpsIceConfig <$> svcGet >>= \case + Just cfg -> return $ Just cfg + Nothing -> do +#ifdef ENABLE_ICE_SUPPORT + stun <- dpsStunServer <$> svcGet + turn <- dpsTurnServer <$> svcGet + liftIO (iceCreateConfig stun turn) >>= \case + Just cfg -> do + svcModify $ \s -> s { dpsIceConfig = Just cfg } + return $ Just cfg + Nothing -> do + svcPrint $ "Discovery: failed to create ICE config" + return Nothing +#else + return Nothing +#endif + + +discoverySearch :: (MonadIO m, MonadError e m, FromErebosError e) => Server -> RefDigest -> m () +discoverySearch server dgst = do + peers <- liftIO $ getCurrentPeerList server + match <- forM peers $ \peer -> do + peerIdentity peer >>= \case + PeerIdentityFull pid -> do + return $ dgst `elem` identityDigests pid + _ -> return False + when (not $ or match) $ do + modifyServiceGlobalState server (Proxy @DiscoveryService) $ \s -> (, ()) s + { dgsSearchingFor = S.insert dgst $ dgsSearchingFor s + } + forM_ peers $ \peer -> do + sendToPeer peer $ DiscoverySearch $ Right dgst diff --git a/src/Erebos/Error.hs b/src/Erebos/Error.hs new file mode 100644 index 0000000..3bb8736 --- /dev/null +++ b/src/Erebos/Error.hs @@ -0,0 +1,39 @@ +module Erebos.Error ( + ErebosError(..), + showErebosError, + + FromErebosError(..), + throwOtherError, +) where + +import Control.Monad.Except + + +data ErebosError + = ManyErrors [ ErebosError ] + | OtherError String + +showErebosError :: ErebosError -> String +showErebosError (ManyErrors errs) = unlines $ map showErebosError errs +showErebosError (OtherError str) = str + +instance Semigroup ErebosError where + ManyErrors [] <> b = b + a <> ManyErrors [] = a + ManyErrors a <> ManyErrors b = ManyErrors (a ++ b) + ManyErrors a <> b = ManyErrors (a ++ [ b ]) + a <> ManyErrors b = ManyErrors (a : b) + a@OtherError {} <> b@OtherError {} = ManyErrors [ a, b ] + +instance Monoid ErebosError where + mempty = ManyErrors [] + + +class FromErebosError e where + fromErebosError :: ErebosError -> e + +instance FromErebosError ErebosError where + fromErebosError = id + +throwOtherError :: (MonadError e m, FromErebosError e) => String -> m a +throwOtherError = throwError . fromErebosError . OtherError diff --git a/src/Erebos/Flow.hs b/src/Erebos/Flow.hs index ba2607a..1e1a521 100644 --- a/src/Erebos/Flow.hs +++ b/src/Erebos/Flow.hs @@ -11,54 +11,53 @@ module Erebos.Flow ( import Control.Concurrent.STM -data Flow r w = Flow (TMVar [r]) (TMVar [w]) - | forall r' w'. MappedFlow (r' -> r) (w -> w') (Flow r' w') +data Flow r w + = Flow (TBQueue r) (TBQueue w) + | forall r' w'. MappedFlow (r' -> r) (w -> w') (Flow r' w') type SymFlow a = Flow a a newFlow :: STM (Flow a b, Flow b a) newFlow = do - x <- newEmptyTMVar - y <- newEmptyTMVar + x <- newTBQueue 16 + y <- newTBQueue 16 return (Flow x y, Flow y x) newFlowIO :: IO (Flow a b, Flow b a) newFlowIO = atomically newFlow readFlow :: Flow r w -> STM r -readFlow (Flow rvar _) = takeTMVar rvar >>= \case - (x:[]) -> return x - (x:xs) -> putTMVar rvar xs >> return x - [] -> error "Flow: empty list" +readFlow (Flow rvar _) = readTBQueue rvar readFlow (MappedFlow f _ up) = f <$> readFlow up tryReadFlow :: Flow r w -> STM (Maybe r) -tryReadFlow (Flow rvar _) = tryTakeTMVar rvar >>= \case - Just (x:[]) -> return (Just x) - Just (x:xs) -> putTMVar rvar xs >> return (Just x) - Just [] -> error "Flow: empty list" - Nothing -> return Nothing +tryReadFlow (Flow rvar _) = tryReadTBQueue rvar tryReadFlow (MappedFlow f _ up) = fmap f <$> tryReadFlow up canReadFlow :: Flow r w -> STM Bool -canReadFlow (Flow rvar _) = not <$> isEmptyTMVar rvar +canReadFlow (Flow rvar _) = not <$> isEmptyTBQueue rvar canReadFlow (MappedFlow _ _ up) = canReadFlow up writeFlow :: Flow r w -> w -> STM () -writeFlow (Flow _ wvar) = putTMVar wvar . (:[]) +writeFlow (Flow _ wvar) = writeTBQueue wvar writeFlow (MappedFlow _ f up) = writeFlow up . f writeFlowBulk :: Flow r w -> [w] -> STM () writeFlowBulk _ [] = return () -writeFlowBulk (Flow _ wvar) xs = putTMVar wvar xs +writeFlowBulk (Flow _ wvar) xs = mapM_ (writeTBQueue wvar) xs writeFlowBulk (MappedFlow _ f up) xs = writeFlowBulk up $ map f xs tryWriteFlow :: Flow r w -> w -> STM Bool -tryWriteFlow (Flow _ wvar) = tryPutTMVar wvar . (:[]) -tryWriteFlow (MappedFlow _ f up) = tryWriteFlow up . f +tryWriteFlow (Flow _ wvar) x = do + isFullTBQueue wvar >>= \case + True -> return False + False -> do + writeTBQueue wvar x + return True +tryWriteFlow (MappedFlow _ f up) x = tryWriteFlow up $ f x canWriteFlow :: Flow r w -> STM Bool -canWriteFlow (Flow _ wvar) = isEmptyTMVar wvar +canWriteFlow (Flow _ wvar) = not <$> isFullTBQueue wvar canWriteFlow (MappedFlow _ _ up) = canWriteFlow up readFlowIO :: Flow r w -> IO r diff --git a/src/Erebos/ICE.chs b/src/Erebos/ICE.chs index 096ee0d..dceeb2c 100644 --- a/src/Erebos/ICE.chs +++ b/src/Erebos/ICE.chs @@ -4,9 +4,12 @@ module Erebos.ICE ( IceSession, IceSessionRole(..), + IceConfig, IceRemoteInfo, - iceCreate, + iceCreateConfig, + iceStopThread, + iceCreateSession, iceDestroy, iceRemoteInfo, iceShow, @@ -17,35 +20,39 @@ module Erebos.ICE ( ) where import Control.Arrow -import Control.Concurrent.MVar +import Control.Concurrent import Control.Monad -import Control.Monad.Except import Control.Monad.Identity import Data.ByteString (ByteString, packCStringLen, useAsCString) -import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.ByteString.Lazy.Char8 qualified as BLC import Data.ByteString.Unsafe import Data.Function import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Read as T +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Read qualified as T import Data.Void +import Data.Word import Foreign.C.String import Foreign.C.Types +import Foreign.ForeignPtr import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Ptr import Foreign.StablePtr import Erebos.Flow +import Erebos.Object +import Erebos.Storable import Erebos.Storage #include "pjproject.h" data IceSession = IceSession { isStrans :: PjIceStrans + , _isConfig :: IceConfig , isChan :: MVar (Either [ByteString] (Flow Void ByteString)) } @@ -111,19 +118,49 @@ instance StorableText IceCandidate where , icandPort = port , icandType = ctype } - _ -> throwError "failed to parse candidate" + _ -> throwOtherError "failed to parse candidate" {#enum pj_ice_sess_role as IceSessionRole {underscoreToCase} deriving (Show, Eq) #} +data PjIceStransCfg +newtype IceConfig = IceConfig (ForeignPtr PjIceStransCfg) + +foreign import ccall unsafe "pjproject.h &ice_cfg_free" + ice_cfg_free :: FunPtr (Ptr PjIceStransCfg -> IO ()) +foreign import ccall unsafe "pjproject.h ice_cfg_create" + ice_cfg_create :: CString -> Word16 -> CString -> Word16 -> IO (Ptr PjIceStransCfg) + +iceCreateConfig :: Maybe ( Text, Word16 ) -> Maybe ( Text, Word16 ) -> IO (Maybe IceConfig) +iceCreateConfig stun turn = + maybe ($ nullPtr) (withText . fst) stun $ \cstun -> + maybe ($ nullPtr) (withText . fst) turn $ \cturn -> do + cfg <- ice_cfg_create cstun (maybe 0 snd stun) cturn (maybe 0 snd turn) + if cfg == nullPtr + then return Nothing + else Just . IceConfig <$> newForeignPtr ice_cfg_free cfg + +foreign import ccall unsafe "pjproject.h ice_cfg_stop_thread" + ice_cfg_stop_thread :: Ptr PjIceStransCfg -> IO () + +iceStopThread :: IceConfig -> IO () +iceStopThread (IceConfig fcfg) = withForeignPtr fcfg ice_cfg_stop_thread + {#pointer *pj_ice_strans as ^ #} -iceCreate :: IceSessionRole -> (IceSession -> IO ()) -> IO IceSession -iceCreate role cb = do +iceCreateSession :: IceConfig -> IceSessionRole -> (IceSession -> IO ()) -> IO IceSession +iceCreateSession icfg@(IceConfig fcfg) role cb = do rec sptr <- newStablePtr sess - cbptr <- newStablePtr $ cb sess + cbptr <- newStablePtr $ do + -- The callback may be called directly from pj_ice_strans_create or later + -- from a different thread; make sure we use a different thread here + -- to avoid deadlock on accessing 'sess'. + forkIO $ cb sess sess <- IceSession - <$> {#call ice_create #} (fromIntegral $ fromEnum role) (castStablePtrToPtr sptr) (castStablePtrToPtr cbptr) + <$> (withForeignPtr fcfg $ \cfg -> + {#call ice_create #} (castPtr cfg) (fromIntegral $ fromEnum role) (castStablePtrToPtr sptr) (castStablePtrToPtr cbptr) + ) + <*> pure icfg <*> (newMVar $ Left []) return $ sess diff --git a/src/Erebos/ICE/pjproject.c b/src/Erebos/ICE/pjproject.c index bb06b1f..e9446fe 100644 --- a/src/Erebos/ICE/pjproject.c +++ b/src/Erebos/ICE/pjproject.c @@ -1,6 +1,7 @@ #include "pjproject.h" #include "Erebos/ICE_stub.h" +#include <stdatomic.h> #include <stdio.h> #include <stdlib.h> #include <stdbool.h> @@ -12,10 +13,16 @@ static struct { pj_caching_pool cp; pj_pool_t * pool; - pj_ice_strans_cfg cfg; pj_sockaddr def_addr; } ice; +struct erebos_ice_cfg +{ + pj_ice_strans_cfg cfg; + pj_thread_t * thread; + atomic_bool exit; +}; + struct user_data { pj_ice_sess_role role; @@ -31,17 +38,17 @@ static void ice_perror(const char * msg, pj_status_t status) fprintf(stderr, "ICE: %s: %s\n", msg, err); } -static int ice_worker_thread(void * unused) +static int ice_worker_thread( void * vcfg ) { - PJ_UNUSED_ARG(unused); + struct erebos_ice_cfg * ecfg = (struct erebos_ice_cfg *)( vcfg ); - while (true) { + while( ! ecfg->exit ){ pj_time_val max_timeout = { 0, 0 }; pj_time_val timeout = { 0, 0 }; max_timeout.msec = 500; - pj_timer_heap_poll(ice.cfg.stun_cfg.timer_heap, &timeout); + pj_timer_heap_poll( ecfg->cfg.stun_cfg.timer_heap, &timeout ); pj_assert(timeout.sec >= 0 && timeout.msec >= 0); if (timeout.msec >= 1000) @@ -50,7 +57,7 @@ static int ice_worker_thread(void * unused) if (PJ_TIME_VAL_GT(timeout, max_timeout)) timeout = max_timeout; - int c = pj_ioqueue_poll(ice.cfg.stun_cfg.ioqueue, &timeout); + int c = pj_ioqueue_poll( ecfg->cfg.stun_cfg.ioqueue, &timeout ); if (c < 0) pj_thread_sleep(PJ_TIME_VAL_MSEC(timeout)); } @@ -105,7 +112,7 @@ static void ice_init(void) if (done) { pthread_mutex_unlock(&mutex); - goto exit; + return; } pj_log_set_level(1); @@ -125,54 +132,105 @@ static void ice_init(void) pj_caching_pool_init(&ice.cp, NULL, 0); - pj_ice_strans_cfg_default(&ice.cfg); - ice.cfg.stun_cfg.pf = &ice.cp.factory; - ice.pool = pj_pool_create(&ice.cp.factory, "ice", 512, 512, NULL); - if (pj_timer_heap_create(ice.pool, 100, - &ice.cfg.stun_cfg.timer_heap) != PJ_SUCCESS) { - fprintf(stderr, "pj_timer_heap_create failed\n"); - goto exit; +exit: + done = true; + pthread_mutex_unlock(&mutex); +} + +struct erebos_ice_cfg * ice_cfg_create( const char * stun_server, uint16_t stun_port, + const char * turn_server, uint16_t turn_port ) +{ + ice_init(); + + struct erebos_ice_cfg * ecfg = malloc( sizeof(struct erebos_ice_cfg) ); + pj_ice_strans_cfg_default( &ecfg->cfg ); + ecfg->exit = false; + ecfg->thread = NULL; + + ecfg->cfg.stun_cfg.pf = &ice.cp.factory; + if( pj_timer_heap_create( ice.pool, 100, + &ecfg->cfg.stun_cfg.timer_heap ) != PJ_SUCCESS ){ + fprintf( stderr, "pj_timer_heap_create failed\n" ); + goto fail; } - if (pj_ioqueue_create(ice.pool, 16, &ice.cfg.stun_cfg.ioqueue) != PJ_SUCCESS) { - fprintf(stderr, "pj_ioqueue_create failed\n"); - goto exit; + if( pj_ioqueue_create( ice.pool, 16, &ecfg->cfg.stun_cfg.ioqueue ) != PJ_SUCCESS ){ + fprintf( stderr, "pj_ioqueue_create failed\n" ); + goto fail; } - pj_thread_t * thread; - if (pj_thread_create(ice.pool, "ice", &ice_worker_thread, - NULL, 0, 0, &thread) != PJ_SUCCESS) { - fprintf(stderr, "pj_thread_create failed\n"); - goto exit; + if( pj_thread_create( ice.pool, NULL, &ice_worker_thread, + ecfg, 0, 0, &ecfg->thread ) != PJ_SUCCESS ){ + fprintf( stderr, "pj_thread_create failed\n" ); + goto fail; } - ice.cfg.af = pj_AF_INET(); - ice.cfg.opt.aggressive = PJ_TRUE; + ecfg->cfg.af = pj_AF_INET(); + ecfg->cfg.opt.aggressive = PJ_TRUE; - ice.cfg.stun.server.ptr = "discovery1.erebosprotocol.net"; - ice.cfg.stun.server.slen = strlen(ice.cfg.stun.server.ptr); - ice.cfg.stun.port = 29670; + if( stun_server ){ + ecfg->cfg.stun.server.ptr = malloc( strlen( stun_server )); + pj_strcpy2( &ecfg->cfg.stun.server, stun_server ); + if( stun_port ) + ecfg->cfg.stun.port = stun_port; + } - ice.cfg.turn.server = ice.cfg.stun.server; - ice.cfg.turn.port = ice.cfg.stun.port; - ice.cfg.turn.auth_cred.type = PJ_STUN_AUTH_CRED_STATIC; - ice.cfg.turn.auth_cred.data.static_cred.data_type = PJ_STUN_PASSWD_PLAIN; - ice.cfg.turn.conn_type = PJ_TURN_TP_UDP; + if( turn_server ){ + ecfg->cfg.turn.server.ptr = malloc( strlen( turn_server )); + pj_strcpy2( &ecfg->cfg.turn.server, turn_server ); + if( turn_port ) + ecfg->cfg.turn.port = turn_port; + ecfg->cfg.turn.auth_cred.type = PJ_STUN_AUTH_CRED_STATIC; + ecfg->cfg.turn.auth_cred.data.static_cred.data_type = PJ_STUN_PASSWD_PLAIN; + ecfg->cfg.turn.conn_type = PJ_TURN_TP_UDP; + } -exit: - done = true; - pthread_mutex_unlock(&mutex); + return ecfg; +fail: + ice_cfg_free( ecfg ); + return NULL; } -pj_ice_strans * ice_create(pj_ice_sess_role role, HsStablePtr sptr, HsStablePtr cb) +void ice_cfg_free( struct erebos_ice_cfg * ecfg ) +{ + if( ! ecfg ) + return; + + ecfg->exit = true; + pj_thread_join( ecfg->thread ); + + if( ecfg->cfg.turn.server.ptr ) + free( ecfg->cfg.turn.server.ptr ); + + if( ecfg->cfg.stun.server.ptr ) + free( ecfg->cfg.stun.server.ptr ); + + if( ecfg->cfg.stun_cfg.ioqueue ) + pj_ioqueue_destroy( ecfg->cfg.stun_cfg.ioqueue ); + + if( ecfg->cfg.stun_cfg.timer_heap ) + pj_timer_heap_destroy( ecfg->cfg.stun_cfg.timer_heap ); + + free( ecfg ); +} + +void ice_cfg_stop_thread( struct erebos_ice_cfg * ecfg ) +{ + if( ! ecfg ) + return; + ecfg->exit = true; +} + +pj_ice_strans * ice_create( const struct erebos_ice_cfg * ecfg, pj_ice_sess_role role, + HsStablePtr sptr, HsStablePtr cb ) { ice_init(); pj_ice_strans * res; - struct user_data * udata = malloc(sizeof(struct user_data)); + struct user_data * udata = calloc( 1, sizeof( struct user_data )); udata->role = role; udata->sptr = sptr; udata->cb_init = cb; @@ -182,8 +240,8 @@ pj_ice_strans * ice_create(pj_ice_sess_role role, HsStablePtr sptr, HsStablePtr .on_ice_complete = cb_on_ice_complete, }; - pj_status_t status = pj_ice_strans_create(NULL, &ice.cfg, 1, - udata, &icecb, &res); + pj_status_t status = pj_ice_strans_create( NULL, &ecfg->cfg, 1, + udata, &icecb, &res ); if (status != PJ_SUCCESS) ice_perror("error creating ice", status); @@ -213,7 +271,9 @@ ssize_t ice_encode_session(pj_ice_strans * strans, char * ufrag, char * pass, pj_str_t local_ufrag, local_pwd; pj_status_t status; - pj_ice_strans_get_ufrag_pwd(strans, &local_ufrag, &local_pwd, NULL, NULL); + status = pj_ice_strans_get_ufrag_pwd( strans, &local_ufrag, &local_pwd, NULL, NULL ); + if( status != PJ_SUCCESS ) + return -status; n = snprintf(ufrag, maxlen, "%.*s", (int) local_ufrag.slen, local_ufrag.ptr); if (n < 0 || n == maxlen) @@ -356,7 +416,7 @@ void ice_send(pj_ice_strans * strans, const char * data, size_t len) return; } - pj_status_t status = pj_ice_strans_sendto(strans, 1, data, len, + pj_status_t status = pj_ice_strans_sendto2(strans, 1, data, len, &ice.def_addr, pj_sockaddr_get_len(&ice.def_addr)); if (status != PJ_SUCCESS && status != PJ_EPENDING) ice_perror("error sending data", status); diff --git a/src/Erebos/ICE/pjproject.h b/src/Erebos/ICE/pjproject.h index e230e75..c31e227 100644 --- a/src/Erebos/ICE/pjproject.h +++ b/src/Erebos/ICE/pjproject.h @@ -3,7 +3,13 @@ #include <pjnath.h> #include <HsFFI.h> -pj_ice_strans * ice_create(pj_ice_sess_role role, HsStablePtr sptr, HsStablePtr cb); +struct erebos_ice_cfg * ice_cfg_create( const char * stun_server, uint16_t stun_port, + const char * turn_server, uint16_t turn_port ); +void ice_cfg_free( struct erebos_ice_cfg * cfg ); +void ice_cfg_stop_thread( struct erebos_ice_cfg * cfg ); + +pj_ice_strans * ice_create( const struct erebos_ice_cfg *, pj_ice_sess_role role, + HsStablePtr sptr, HsStablePtr cb ); void ice_destroy(pj_ice_strans * strans); ssize_t ice_encode_session(pj_ice_strans *, char * ufrag, char * pass, diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs index f2094f6..a3f17b5 100644 --- a/src/Erebos/Identity.hs +++ b/src/Erebos/Identity.hs @@ -13,7 +13,7 @@ module Erebos.Identity ( createIdentity, validateIdentity, validateIdentityF, validateIdentityFE, validateExtendedIdentity, validateExtendedIdentityF, validateExtendedIdentityFE, - loadIdentity, loadUnifiedIdentity, + loadIdentity, loadMbIdentity, loadUnifiedIdentity, loadMbUnifiedIdentity, mergeIdentity, toUnifiedIdentity, toComposedIdentity, updateIdentity, updateOwners, @@ -41,7 +41,7 @@ import Data.Text (Text) import qualified Data.Text as T import Erebos.PubKey -import Erebos.Storage +import Erebos.Storable import Erebos.Storage.Merge import Erebos.Util @@ -280,10 +280,16 @@ validateExtendedIdentityFE mdata = do Just mk -> return mk loadIdentity :: String -> LoadRec ComposedIdentity -loadIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name +loadIdentity name = maybe (throwOtherError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name + +loadMbIdentity :: String -> LoadRec (Maybe ComposedIdentity) +loadMbIdentity name = return . validateExtendedIdentityF =<< loadRefs name loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity -loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentity =<< loadRef name +loadUnifiedIdentity name = maybe (throwOtherError "identity validation failed") return . validateExtendedIdentity =<< loadRef name + +loadMbUnifiedIdentity :: String -> LoadRec (Maybe UnifiedIdentity) +loadMbUnifiedIdentity name = return . (validateExtendedIdentity =<<) =<< loadMbRef name gatherPrevious :: Set (Stored (Signed ExtendedIdentityData)) -> [Stored (Signed ExtendedIdentityData)] -> Set (Stored (Signed ExtendedIdentityData)) @@ -316,7 +322,7 @@ lookupProperty sel topHeads = findResult propHeads findResult [] = Nothing findResult xs = sel $ fromSigned $ minimum xs -mergeIdentity :: (MonadStorage m, MonadError String m, MonadIO m) => Identity f -> m UnifiedIdentity +mergeIdentity :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m) => Identity f -> m UnifiedIdentity mergeIdentity idt | Just idt' <- toUnifiedIdentity idt = return idt' mergeIdentity idt@Identity {..} = do (owner, ownerData) <- case idOwner_ of diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs index 2064d1c..8da4c8d 100644 --- a/src/Erebos/Network.hs +++ b/src/Erebos/Network.hs @@ -6,6 +6,7 @@ module Erebos.Network ( stopServer, getCurrentPeerList, getNextPeerChange, + getServerAddresses, ServerOptions(..), serverIdentity, defaultServerOptions, Peer, peerServer, peerStorage, @@ -13,7 +14,12 @@ module Erebos.Network ( PeerIdentity(..), peerIdentity, WaitingRef, wrDigest, Service(..), + + PeerAddressType(..), + receivedFromCustomAddress, + serverPeer, + serverPeerCustom, #ifdef ENABLE_ICE_SUPPORT serverPeerIce, #endif @@ -23,6 +29,7 @@ module Erebos.Network ( sendToPeerStored, sendManyToPeerStored, sendToPeerWith, runPeerService, + modifyServiceGlobalState, discoveryPort, ) where @@ -35,34 +42,37 @@ import Control.Monad.Except import Control.Monad.Reader import Control.Monad.State +import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC import Data.ByteString.Lazy qualified as BL import Data.Function import Data.IP qualified as IP import Data.List import Data.Map (Map) -import qualified Data.Map as M +import Data.Map qualified as M import Data.Maybe import Data.Typeable import Data.Word +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array import Foreign.Ptr -import Foreign.Storable +import Foreign.Storable as F import GHC.Conc.Sync (unsafeIOToSTM) import Network.Socket hiding (ControlMessage) -import qualified Network.Socket.ByteString as S - -import Foreign.C.Types -import Foreign.Marshal.Alloc +import Network.Socket.ByteString qualified as S -import Erebos.Channel +import Erebos.Error #ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif import Erebos.Identity +import Erebos.Network.Channel import Erebos.Network.Protocol +import Erebos.Object.Internal import Erebos.PubKey import Erebos.Service import Erebos.State @@ -83,6 +93,7 @@ announceIntervalSeconds = 60 data Server = Server { serverStorage :: Storage + , serverOptions :: ServerOptions , serverOrigHead :: Head LocalState , serverIdentity_ :: MVar UnifiedIdentity , serverThreads :: MVar [ThreadId] @@ -90,7 +101,7 @@ data Server = Server , serverRawPath :: SymFlow (PeerAddress, BC.ByteString) , serverControlFlow :: Flow (ControlMessage PeerAddress) (ControlRequest PeerAddress) , serverDataResponse :: TQueue (Peer, Maybe PartialRef) - , serverIOActions :: TQueue (ExceptT String IO ()) + , serverIOActions :: TQueue (ExceptT ErebosError IO ()) , serverServices :: [SomeService] , serverServiceStates :: TMVar (M.Map ServiceID SomeServiceGlobalState) , serverPeers :: MVar (Map PeerAddress Peer) @@ -153,12 +164,19 @@ setPeerChannel Peer {..} ch = do instance Eq Peer where (==) = (==) `on` peerIdentityVar -data PeerAddress = DatagramAddress SockAddr +class (Eq addr, Ord addr, Show addr, Typeable addr) => PeerAddressType addr where + sendBytesToAddress :: addr -> ByteString -> IO () + +data PeerAddress + = forall addr. PeerAddressType addr => CustomPeerAddress addr + | DatagramAddress SockAddr #ifdef ENABLE_ICE_SUPPORT - | PeerIceSession IceSession + | PeerIceSession IceSession #endif instance Show PeerAddress where + show (CustomPeerAddress addr) = show addr + show (DatagramAddress saddr) = unwords $ case IP.fromSockAddr saddr of Just (IP.IPv6 ipv6, port) | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6 @@ -166,37 +184,48 @@ instance Show PeerAddress where Just (addr, port) -> [show addr, show port] _ -> [show saddr] + #ifdef ENABLE_ICE_SUPPORT show (PeerIceSession ice) = show ice #endif instance Eq PeerAddress where + CustomPeerAddress addr == CustomPeerAddress addr' + | Just addr'' <- cast addr' = addr == addr'' DatagramAddress addr == DatagramAddress addr' = addr == addr' #ifdef ENABLE_ICE_SUPPORT PeerIceSession ice == PeerIceSession ice' = ice == ice' - _ == _ = False #endif + _ == _ = False instance Ord PeerAddress where + compare (CustomPeerAddress addr) (CustomPeerAddress addr') + | Just addr'' <- cast addr' = compare addr addr'' + | otherwise = compare (typeOf addr) (typeOf addr') + compare (CustomPeerAddress _ ) _ = LT + compare _ (CustomPeerAddress _ ) = GT + compare (DatagramAddress addr) (DatagramAddress addr') = compare addr addr' #ifdef ENABLE_ICE_SUPPORT compare (DatagramAddress _ ) _ = LT compare _ (DatagramAddress _ ) = GT + compare (PeerIceSession ice ) (PeerIceSession ice') = compare ice ice' #endif -data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT String IO ()]) - | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT String IO ()]) +data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT ErebosError IO ()]) + | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT ErebosError IO ()]) | PeerIdentityFull UnifiedIdentity peerIdentity :: MonadIO m => Peer -> m PeerIdentity peerIdentity = liftIO . atomically . readTVar . peerIdentityVar -data PeerState = PeerInit [(SecurityRequirement, TransportPacket Ref, [TransportHeaderItem])] - | PeerConnected (Connection PeerAddress) - | PeerDropped +data PeerState + = PeerInit [ ( SecurityRequirement, TransportPacket Ref, [ TransportHeaderItem ] ) ] + | PeerConnected (Connection PeerAddress) + | PeerDropped lookupServiceType :: [TransportHeaderItem] -> Maybe ServiceID @@ -229,7 +258,7 @@ forkServerThread server act = do return (t:ts) startServer :: ServerOptions -> Head LocalState -> (String -> IO ()) -> [SomeService] -> IO Server -startServer opt serverOrigHead logd' serverServices = do +startServer serverOptions serverOrigHead logd' serverServices = do let serverStorage = headStorage serverOrigHead serverIdentity_ <- newMVar $ headLocalIdentity serverOrigHead serverThreads <- newMVar [] @@ -252,7 +281,7 @@ startServer opt serverOrigHead logd' serverServices = do forkServerThread server $ dataResponseWorker server forkServerThread server $ forever $ do - either (atomically . logd) return =<< runExceptT =<< + either (atomically . logd . showErebosError) return =<< runExceptT =<< atomically (readTQueue serverIOActions) let open addr = do @@ -265,7 +294,7 @@ startServer opt serverOrigHead logd' serverServices = do return sock loop sock = do - when (serverLocalDiscovery opt) $ forkServerThread server $ do + when (serverLocalDiscovery serverOptions) $ forkServerThread server $ do announceAddreses <- fmap concat $ sequence $ [ map (SockAddrInet6 discoveryPort 0 discoveryMulticastGroup) <$> joinMulticast sock , getBroadcastAddresses discoveryPort @@ -298,13 +327,18 @@ startServer opt serverOrigHead logd' serverServices = do announceUpdate idt forM_ serverServices $ \(SomeService service _) -> do - forM_ (serviceStorageWatchers service) $ \(SomeStorageWatcher sel act) -> do - watchHeadWith serverOrigHead (sel . headStoredObject) $ \x -> do - withMVar serverPeers $ mapM_ $ \peer -> atomically $ do - readTVar (peerIdentityVar peer) >>= \case - PeerIdentityFull _ -> writeTQueue serverIOActions $ do - runPeerService peer $ act x - _ -> return () + forM_ (serviceStorageWatchers service) $ \case + SomeStorageWatcher sel act -> do + watchHeadWith serverOrigHead (sel . headStoredObject) $ \x -> do + withMVar serverPeers $ mapM_ $ \peer -> atomically $ do + readTVar (peerIdentityVar peer) >>= \case + PeerIdentityFull _ -> writeTQueue serverIOActions $ do + runPeerService peer $ act x + _ -> return () + GlobalStorageWatcher sel act -> do + watchHeadWith serverOrigHead (sel . headStoredObject) $ \x -> do + atomically $ writeTQueue serverIOActions $ do + act server x forkServerThread server $ forever $ do (msg, saddr) <- S.recvFrom sock 4096 @@ -312,8 +346,9 @@ startServer opt serverOrigHead logd' serverServices = do forkServerThread server $ forever $ do (paddr, msg) <- readFlowIO serverRawPath - handle (\(e :: IOException) -> atomically . logd $ "failed to send packet to " ++ show paddr ++ ": " ++ show e) $ do + handle (\(e :: SomeException) -> atomically . logd $ "failed to send packet to " ++ show paddr ++ ": " ++ show e) $ do case paddr of + CustomPeerAddress addr -> sendBytesToAddress addr msg DatagramAddress addr -> void $ S.sendTo sock msg addr #ifdef ENABLE_ICE_SUPPORT PeerIceSession ice -> iceSend ice msg @@ -377,20 +412,33 @@ startServer opt serverOrigHead logd' serverServices = do , addrFamily = AF_INET6 , addrSocketType = Datagram } - addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort opt) + addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort serverOptions) bracket (open addr) close loop forkServerThread server $ forever $ do - (peer, svc, ref) <- atomically $ readTQueue chanSvc + ( peer, svc, ref, streams ) <- atomically $ readTQueue chanSvc case find ((svc ==) . someServiceID) serverServices of - Just service@(SomeService (_ :: Proxy s) attr) -> runPeerServiceOn (Just (service, attr)) peer (serviceHandler $ wrappedLoad @s ref) + Just service@(SomeService (_ :: Proxy s) attr) -> runPeerServiceOn (Just ( service, attr )) streams peer (serviceHandler $ wrappedLoad @s ref) _ -> atomically $ logd $ "unhandled service '" ++ show (toUUID svc) ++ "'" return server stopServer :: Server -> IO () -stopServer Server {..} = do - mapM_ killThread =<< takeMVar serverThreads +stopServer server@Server {..} = do + withMVar serverPeers $ \peers -> do + ( global, peerStates ) <- atomically $ (,) + <$> takeTMVar serverServiceStates + <*> (forM (M.elems peers) $ \p@Peer {..} -> ( p, ) <$> takeTMVar peerServiceState) + + forM_ global $ \(SomeServiceGlobalState (proxy :: Proxy s) gs) -> do + ps <- forM peerStates $ \( peer, states ) -> + return $ ( peer, ) $ case M.lookup (serviceID proxy) states of + Just (SomeServiceState (_ :: Proxy ps) pstate) + | Just (Refl :: s :~: ps) <- eqT + -> pstate + _ -> emptyServiceState proxy + serviceStopServer proxy server gs ps + mapM_ killThread =<< takeMVar serverThreads dataResponseWorker :: Server -> IO () dataResponseWorker server = forever $ do @@ -404,7 +452,7 @@ dataResponseWorker server = forever $ do Right ref -> do atomically (writeTVar tvar $ Right ref) forkServerThread server $ runExceptT (wrefAction wr ref) >>= \case - Left err -> atomically $ writeTQueue (serverErrorLog server) err + Left err -> atomically $ writeTQueue (serverErrorLog server) (showErebosError err) Right () -> return () return (Nothing, []) @@ -498,9 +546,7 @@ openStream = do conn <- readTVarP peerState >>= \case PeerConnected conn -> return conn _ -> throwError "can't open stream without established connection" - (hdr, writer, handler) <- liftSTM (connAddWriteStream conn) >>= \case - Right res -> return res - Left err -> throwError err + (hdr, writer, handler) <- liftEither =<< liftSTM (connAddWriteStream conn) liftSTM $ writeTQueue (serverIOActions peerServer_) (liftIO $ forkServerThread peerServer_ handler) addHeader hdr @@ -520,8 +566,8 @@ appendDistinct x (y:ys) | x == y = y : ys appendDistinct x [] = [x] handlePacket :: UnifiedIdentity -> Bool - -> Peer -> TQueue (Peer, ServiceID, Ref) -> [ServiceID] - -> TransportHeader -> [PartialRef] -> IO () + -> Peer -> TQueue ( Peer, ServiceID, Ref, [ RawStreamReader ]) -> [ ServiceID ] + -> TransportHeader -> [ PartialRef ] -> IO () handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = atomically $ do let server = peerServer peer ochannel <- getPeerChannel peer @@ -583,7 +629,7 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = liftSTM $ writeTQueue (serverIOActions server) $ void $ liftIO $ forkIO $ do (runExcept <$> readObjectsFromStream (peerInStorage peer) streamReader) >>= \case Left err -> atomically $ writeTQueue (serverErrorLog server) $ - "failed to receive object from stream: " <> err + "failed to receive object from stream: " <> showErebosError err Right objs -> do forM_ objs $ \obj -> do pref <- storeObject (peerInStorage peer) obj @@ -655,17 +701,18 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = | Just svc <- lookupServiceType headers -> if | svc `elem` svcs -> do if dgst `elem` map refDigest prefs || True {- TODO: used by Message service to confirm receive -} - then do - void $ newWaitingRef dgst $ \ref -> - liftIO $ atomically $ writeTQueue chanSvc (peer, svc, ref) - else throwError $ "missing service object " ++ show dgst + then do + streamReaders <- mapM acceptStream $ lookupNewStreams headers + void $ newWaitingRef dgst $ \ref -> + liftIO $ atomically $ writeTQueue chanSvc ( peer, svc, ref, streamReaders ) + else throwError $ "missing service object " ++ show dgst | otherwise -> addHeader $ Rejected dgst | otherwise -> throwError $ "service ref without type" _ -> return () -withPeerIdentity :: MonadIO m => Peer -> (UnifiedIdentity -> ExceptT String IO ()) -> m () +withPeerIdentity :: MonadIO m => Peer -> (UnifiedIdentity -> ExceptT ErebosError IO ()) -> m () withPeerIdentity peer act = liftIO $ atomically $ readTVar (peerIdentityVar peer) >>= \case PeerIdentityUnknown tvar -> modifyTVar' tvar (act:) PeerIdentityRef _ tvar -> modifyTVar' tvar (act:) @@ -721,7 +768,7 @@ handleChannelAccept identity accref = do sendToPeerS peer [] $ TransportPacket (TransportHeader [Acknowledged $ refDigest accref]) [] finalizedChannel peer ch identity - Left dgst -> throwError $ "missing accept data " ++ BC.unpack (showRefDigest dgst) + Left dgst -> throwOtherError $ "missing accept data " ++ BC.unpack (showRefDigest dgst) finalizedChannel :: Peer -> Channel -> UnifiedIdentity -> STM () @@ -783,9 +830,13 @@ notifyServicesOfPeer :: Peer -> STM () notifyServicesOfPeer peer@Peer { peerServer_ = Server {..} } = do writeTQueue serverIOActions $ do forM_ serverServices $ \service@(SomeService _ attrs) -> - runPeerServiceOn (Just (service, attrs)) peer serviceNewPeer + runPeerServiceOn (Just ( service, attrs )) [] peer serviceNewPeer +receivedFromCustomAddress :: PeerAddressType addr => Server -> addr -> ByteString -> IO () +receivedFromCustomAddress Server {..} addr msg = do + writeFlowIO serverRawPath ( CustomPeerAddress addr, msg ) + mkPeer :: Server -> PeerAddress -> IO Peer mkPeer peerServer_ peerAddress = do peerState <- newTVarIO (PeerInit []) @@ -804,6 +855,9 @@ serverPeer server paddr = do _ -> paddr serverPeer' server (DatagramAddress paddr') +serverPeerCustom :: PeerAddressType addr => Server -> addr -> IO Peer +serverPeerCustom server addr = serverPeer' server (CustomPeerAddress addr) + #ifdef ENABLE_ICE_SUPPORT serverPeerIce :: Server -> IceSession -> IO Peer serverPeerIce server@Server {..} ice = do @@ -852,19 +906,49 @@ sendToPeerStored peer = sendManyToPeerStored peer . (: []) sendManyToPeerStored :: (Service s, MonadIO m) => Peer -> [ Stored s ] -> m () sendManyToPeerStored peer = sendToPeerList peer . map (\part -> ServiceReply (Right part) True) -sendToPeerList :: (Service s, MonadIO m) => Peer -> [ServiceReply s] -> m () +sendToPeerList :: (Service s, MonadIO m) => Peer -> [ ServiceReply s ] -> m () sendToPeerList peer parts = do let st = peerStorage peer - srefs <- liftIO $ fmap catMaybes $ forM parts $ \case - ServiceReply (Left x) use -> Just . (,use) <$> store st x - ServiceReply (Right sx) use -> return $ Just (storedRef sx, use) - ServiceFinally act -> act >> return Nothing - let dgsts = map (refDigest . fst) srefs - let content = map fst $ filter (\(ref, use) -> use && BL.length (lazyLoadBytes ref) < 500) srefs -- TODO: MTU - header = TransportHeader (ServiceType (serviceID $ head parts) : map ServiceRef dgsts) - packet = TransportPacket header content - ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- dgsts ] - liftIO $ atomically $ sendToPeerS peer ackedBy packet + res <- runExceptT $ do + srefs <- liftIO $ fmap catMaybes $ forM parts $ \case + ServiceReply (Left x) use -> Just . (,use) <$> store st x + ServiceReply (Right sx) use -> return $ Just (storedRef sx, use) + _ -> return Nothing + + streamHeaders <- concat <$> do + (liftEither =<<) $ liftIO $ atomically $ runExceptT $ do + forM parts $ \case + ServiceOpenStream cb -> do + conn <- lift (readTVar (peerState peer)) >>= \case + PeerConnected conn -> return conn + _ -> throwError "can't open stream without established connection" + (hdr, writer, handler) <- liftEither =<< lift (connAddWriteStream conn) + + lift $ writeTQueue (serverIOActions (peerServer peer)) $ do + liftIO $ forkServerThread (peerServer peer) handler + return [ ( hdr, cb writer ) ] + _ -> return [] + liftIO $ sequence_ $ map snd streamHeaders + + liftIO $ forM_ parts $ \case + ServiceFinally act -> act + _ -> return () + + let dgsts = map (refDigest . fst) srefs + let content = map fst $ filter (\(ref, use) -> use && BL.length (lazyLoadBytes ref) < 500) srefs -- TODO: MTU + header = TransportHeader $ concat + [ [ ServiceType (serviceID $ head parts) ] + , map ServiceRef dgsts + , map fst streamHeaders + ] + packet = TransportPacket header content + ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- dgsts ] + liftIO $ atomically $ sendToPeerS peer ackedBy packet + + case res of + Right () -> return () + Left err -> liftIO $ atomically $ writeTQueue (serverErrorLog $ peerServer peer) $ + "failed to send packet to " <> show (peerAddress peer) <> ": " <> err sendToPeerS' :: SecurityRequirement -> Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM () sendToPeerS' secure Peer {..} ackedBy packet = do @@ -879,7 +963,7 @@ sendToPeerS = sendToPeerS' EncryptedOnly sendToPeerPlain :: Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM () sendToPeerPlain = sendToPeerS' PlaintextAllowed -sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m () +sendToPeerWith :: forall s m e. (Service s, MonadIO m, MonadError e m, FromErebosError e) => Peer -> (ServiceState s -> ExceptT ErebosError IO (Maybe s, ServiceState s)) -> m () sendToPeerWith peer fobj = do let sproxy = Proxy @s sid = serviceID sproxy @@ -894,20 +978,20 @@ sendToPeerWith peer fobj = do case res of Right (Just obj) -> sendToPeer peer obj Right Nothing -> return () - Left err -> throwError err + Left err -> throwError $ fromErebosError err -lookupService :: forall s. Service s => Proxy s -> [SomeService] -> Maybe (SomeService, ServiceAttributes s) +lookupService :: forall s proxy. Service s => proxy s -> [SomeService] -> Maybe (SomeService, ServiceAttributes s) lookupService proxy (service@(SomeService (_ :: Proxy t) attr) : rest) | Just (Refl :: s :~: t) <- eqT = Just (service, attr) | otherwise = lookupService proxy rest lookupService _ [] = Nothing runPeerService :: forall s m. (Service s, MonadIO m) => Peer -> ServiceHandler s () -> m () -runPeerService = runPeerServiceOn Nothing +runPeerService = runPeerServiceOn Nothing [] -runPeerServiceOn :: forall s m. (Service s, MonadIO m) => Maybe (SomeService, ServiceAttributes s) -> Peer -> ServiceHandler s () -> m () -runPeerServiceOn mbservice peer handler = liftIO $ do +runPeerServiceOn :: forall s m. (Service s, MonadIO m) => Maybe ( SomeService, ServiceAttributes s ) -> [ RawStreamReader ] -> Peer -> ServiceHandler s () -> m () +runPeerServiceOn mbservice newStreams peer handler = liftIO $ do let server = peerServer peer proxy = Proxy @s svc = serviceID proxy @@ -932,6 +1016,7 @@ runPeerServiceOn mbservice peer handler = liftIO $ do , svcPeerIdentity = peerId , svcServer = server , svcPrintOp = atomically . logd + , svcNewStreams = newStreams } reloadHead (serverOrigHead server) >>= \case Nothing -> atomically $ do @@ -952,19 +1037,79 @@ runPeerServiceOn mbservice peer handler = liftIO $ do _ -> atomically $ do logd $ "unhandled service '" ++ show (toUUID svc) ++ "'" +modifyServiceGlobalState + :: forall s a m e proxy. (Service s, MonadIO m, MonadError e m, FromErebosError e) + => Server -> proxy s + -> (ServiceGlobalState s -> ( ServiceGlobalState s, a )) + -> m a +modifyServiceGlobalState server proxy f = do + let svc = serviceID proxy + case lookupService proxy (serverServices server) of + Just ( service, _ ) -> do + liftIO $ atomically $ do + global <- takeTMVar (serverServiceStates server) + ( global', res ) <- case fromMaybe (someServiceEmptyGlobalState service) $ M.lookup svc global of + SomeServiceGlobalState (_ :: Proxy gs) gs -> do + (Refl :: s :~: gs) <- return $ fromMaybe (error "service ID mismatch in global map") eqT + let ( gs', res ) = f gs + return ( M.insert svc (SomeServiceGlobalState (Proxy @s) gs') global, res ) + putTMVar (serverServiceStates server) global' + return res + Nothing -> do + throwOtherError $ "unhandled service '" ++ show (toUUID svc) ++ "'" + foreign import ccall unsafe "Network/ifaddrs.h join_multicast" cJoinMulticast :: CInt -> Ptr CSize -> IO (Ptr Word32) +foreign import ccall unsafe "Network/ifaddrs.h local_addresses" cLocalAddresses :: Ptr CSize -> IO (Ptr InetAddress) foreign import ccall unsafe "Network/ifaddrs.h broadcast_addresses" cBroadcastAddresses :: IO (Ptr Word32) -foreign import ccall unsafe "stdlib.h free" cFree :: Ptr Word32 -> IO () +foreign import ccall unsafe "stdlib.h free" cFree :: Ptr a -> IO () + +data InetAddress = InetAddress { fromInetAddress :: IP.IP } + +instance F.Storable InetAddress where + sizeOf _ = sizeOf (undefined :: CInt) + 16 + alignment _ = 8 + + peek ptr = (unpackFamily <$> peekByteOff ptr 0) >>= \case + AF_INET -> InetAddress . IP.IPv4 . IP.fromHostAddress <$> peekByteOff ptr (sizeOf (undefined :: CInt)) + AF_INET6 -> InetAddress . IP.IPv6 . IP.toIPv6b . map fromIntegral <$> peekArray 16 (ptr `plusPtr` sizeOf (undefined :: CInt) :: Ptr Word8) + _ -> fail "InetAddress: unknown family" + + poke ptr (InetAddress addr) = case addr of + IP.IPv4 ip -> do + pokeByteOff ptr 0 (packFamily AF_INET) + pokeByteOff ptr (sizeOf (undefined :: CInt)) (IP.toHostAddress ip) + IP.IPv6 ip -> do + pokeByteOff ptr 0 (packFamily AF_INET6) + pokeArray (ptr `plusPtr` sizeOf (undefined :: CInt) :: Ptr Word8) (map fromIntegral $ IP.fromIPv6b ip) joinMulticast :: Socket -> IO [ Word32 ] joinMulticast sock = withFdSocket sock $ \fd -> alloca $ \pcount -> do ptr <- cJoinMulticast fd pcount - count <- fromIntegral <$> peek pcount - forM [ 0 .. count - 1 ] $ \i -> - peekElemOff ptr i + if ptr == nullPtr + then do + return [] + else do + count <- fromIntegral <$> peek pcount + res <- forM [ 0 .. count - 1 ] $ \i -> + peekElemOff ptr i + cFree ptr + return res + +getServerAddresses :: Server -> IO [ SockAddr ] +getServerAddresses Server {..} = do + alloca $ \pcount -> do + ptr <- cLocalAddresses pcount + if ptr == nullPtr + then do + return [] + else do + count <- fromIntegral <$> peek pcount + res <- peekArray count ptr + cFree ptr + return $ map (IP.toSockAddr . (, serverPort serverOptions ) . fromInetAddress) res getBroadcastAddresses :: PortNumber -> IO [SockAddr] getBroadcastAddresses port = do diff --git a/src/Erebos/Network.hs-boot b/src/Erebos/Network.hs-boot index 849bfc1..af77581 100644 --- a/src/Erebos/Network.hs-boot +++ b/src/Erebos/Network.hs-boot @@ -1,6 +1,6 @@ module Erebos.Network where -import Erebos.Storage +import Erebos.Object.Internal data Server data Peer diff --git a/src/Erebos/Channel.hs b/src/Erebos/Network/Channel.hs index 5f66637..d9679bd 100644 --- a/src/Erebos/Channel.hs +++ b/src/Erebos/Network/Channel.hs @@ -1,4 +1,4 @@ -module Erebos.Channel ( +module Erebos.Network.Channel ( Channel, ChannelRequest, ChannelRequestData(..), ChannelAccept, ChannelAcceptData(..), @@ -27,7 +27,7 @@ import Data.List import Erebos.Identity import Erebos.PubKey -import Erebos.Storage +import Erebos.Storable data Channel = Channel { chPeers :: [Stored (Signed IdentityData)] @@ -78,23 +78,23 @@ instance Storable ChannelAcceptData where keySize :: Int keySize = 32 -createChannelRequest :: (MonadStorage m, MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> m (Stored ChannelRequest) +createChannelRequest :: (MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> m (Stored ChannelRequest) createChannelRequest self peer = do (_, xpublic) <- liftIO . generateKeys =<< getStorage skey <- loadKey $ idKeyMessage self mstore =<< sign skey =<< mstore ChannelRequest { crPeers = sort [idData self, idData peer], crKey = xpublic } -acceptChannelRequest :: (MonadStorage m, MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Channel) +acceptChannelRequest :: (MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Channel) acceptChannelRequest self peer req = do case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of - Nothing -> throwError $ "invalid peers in channel request" + Nothing -> throwOtherError $ "invalid peers in channel request" Just peers -> do when (not $ any (self `sameIdentity`) peers) $ - throwError $ "self identity missing in channel request peers" + throwOtherError $ "self identity missing in channel request peers" when (not $ any (peer `sameIdentity`) peers) $ - throwError $ "peer identity missing in channel request peers" + throwOtherError $ "peer identity missing in channel request peers" when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $ - throwError $ "channel requent not signed by peer" + throwOtherError $ "channel requent not signed by peer" (xsecret, xpublic) <- liftIO . generateKeys =<< getStorage skey <- loadKey $ idKeyMessage self @@ -110,20 +110,20 @@ acceptChannelRequest self peer req = do return (acc, Channel {..}) -acceptedChannel :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m Channel +acceptedChannel :: (MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m Channel acceptedChannel self peer acc = do let req = caRequest $ fromStored $ signedData $ fromStored acc case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of - Nothing -> throwError $ "invalid peers in channel accept" + Nothing -> throwOtherError $ "invalid peers in channel accept" Just peers -> do when (not $ any (self `sameIdentity`) peers) $ - throwError $ "self identity missing in channel accept peers" + throwOtherError $ "self identity missing in channel accept peers" when (not $ any (peer `sameIdentity`) peers) $ - throwError $ "peer identity missing in channel accept peers" + throwOtherError $ "peer identity missing in channel accept peers" when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)) $ - throwError $ "channel accept not signed by peer" + throwOtherError $ "channel accept not signed by peer" when (idKeyMessage self `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $ - throwError $ "original channel request not signed by us" + throwOtherError $ "original channel request not signed by us" xsecret <- loadKey $ crKey $ fromStored $ signedData $ fromStored req let chPeers = crPeers $ fromStored $ signedData $ fromStored req @@ -137,23 +137,23 @@ acceptedChannel self peer acc = do return Channel {..} -channelEncrypt :: (ByteArray ba, MonadIO m, MonadError String m) => Channel -> ba -> m (ba, Word64) +channelEncrypt :: (ByteArray ba, MonadIO m, MonadError e m, FromErebosError e) => Channel -> ba -> m (ba, Word64) channelEncrypt Channel {..} plain = do count <- liftIO $ modifyMVar chCounterNextOut $ \c -> return (c + 1, c) let cbytes = convert $ BL.toStrict $ encode count nonce = nonce8 chNonceFixedOur cbytes state <- case initialize chKey =<< nonce of CryptoPassed state -> return state - CryptoFailed err -> throwError $ "failed to init chacha-poly1305 cipher: " <> show err + CryptoFailed err -> throwOtherError $ "failed to init chacha-poly1305 cipher: " <> show err let (ctext, state') = encrypt plain state tag = finalize state' return (BA.concat [ convert $ BA.drop 7 cbytes, ctext, convert tag ], count) -channelDecrypt :: (ByteArray ba, MonadIO m, MonadError String m) => Channel -> ba -> m (ba, Word64) +channelDecrypt :: (ByteArray ba, MonadIO m, MonadError e m, FromErebosError e) => Channel -> ba -> m (ba, Word64) channelDecrypt Channel {..} body = do when (BA.length body < 17) $ do - throwError $ "invalid encrypted data length" + throwOtherError $ "invalid encrypted data length" expectedCount <- liftIO $ readMVar chCounterNextIn let countByte = body `BA.index` 0 @@ -165,11 +165,11 @@ channelDecrypt Channel {..} body = do tag = BA.dropView body' blen state <- case initialize chKey =<< nonce of CryptoPassed state -> return state - CryptoFailed err -> throwError $ "failed to init chacha-poly1305 cipher: " <> show err + CryptoFailed err -> throwOtherError $ "failed to init chacha-poly1305 cipher: " <> show err let (plain, state') = decrypt (convert ctext) state when (not $ tag `BA.constEq` finalize state') $ do - throwError $ "tag validation falied" + throwOtherError $ "tag validation falied" liftIO $ modifyMVar_ chCounterNextIn $ return . max (guessedCount + 1) return (plain, guessedCount) diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs index ded0b05..025f52c 100644 --- a/src/Erebos/Network/Protocol.hs +++ b/src/Erebos/Network/Protocol.hs @@ -3,6 +3,7 @@ module Erebos.Network.Protocol ( transportToObject, TransportHeader(..), TransportHeaderItem(..), + ServiceID(..), SecurityRequirement(..), WaitingRef(..), @@ -22,7 +23,8 @@ module Erebos.Network.Protocol ( connSetChannel, connClose, - RawStreamReader, RawStreamWriter, + RawStreamReader(..), RawStreamWriter(..), + StreamPacket(..), connAddWriteStream, connAddReadStream, readStreamToList, @@ -36,11 +38,22 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM +import Control.Exception import Control.Monad import Control.Monad.Except import Control.Monad.Trans +import Crypto.Cipher.ChaChaPoly1305 qualified as C +import Crypto.MAC.Poly1305 qualified as C (Auth(..), authTag) +import Crypto.Error +import Crypto.Random + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put import Data.Bits +import Data.ByteArray (Bytes, ScrubbedBytes) +import Data.ByteArray qualified as BA import Data.ByteString (ByteString) import Data.ByteString qualified as B import Data.ByteString.Char8 qualified as BC @@ -51,15 +64,16 @@ import Data.Maybe import Data.Text (Text) import Data.Text qualified as T import Data.Void -import Data.Word import System.Clock -import Erebos.Channel import Erebos.Flow import Erebos.Identity -import Erebos.Service +import Erebos.Network.Channel +import Erebos.Object +import Erebos.Storable import Erebos.Storage +import Erebos.UUID (UUID) protocolVersion :: Text @@ -96,6 +110,9 @@ data TransportHeaderItem | StreamOpen Word8 deriving (Eq, Show) +newtype ServiceID = ServiceID UUID + deriving (Eq, Ord, Show, StorableUUID) + newtype Cookie = Cookie ByteString deriving (Eq, Show) @@ -104,6 +121,35 @@ data SecurityRequirement = PlaintextOnly | EncryptedOnly deriving (Eq, Ord) +data ParsedCookie = ParsedCookie + { cookieNonce :: C.Nonce + , cookieValidity :: Word32 + , cookieContent :: ByteString + , cookieMac :: C.Auth + } + +instance Eq ParsedCookie where + (==) = (==) `on` (\c -> ( BA.convert (cookieNonce c) :: ByteString, cookieValidity c, cookieContent c, cookieMac c )) + +instance Show ParsedCookie where + show ParsedCookie {..} = show (nonce, cookieValidity, cookieContent, mac) + where C.Auth mac = cookieMac + nonce = BA.convert cookieNonce :: ByteString + +instance Binary ParsedCookie where + put ParsedCookie {..} = do + putByteString $ BA.convert cookieNonce + putWord32be cookieValidity + putByteString $ BA.convert cookieMac + putByteString cookieContent + + get = do + Just cookieNonce <- maybeCryptoError . C.nonce12 <$> getByteString 12 + cookieValidity <- getWord32be + Just cookieMac <- maybeCryptoError . C.authTag <$> getByteString 16 + cookieContent <- BL.toStrict <$> getRemainingLazyByteString + return ParsedCookie {..} + isHeaderItemAcknowledged :: TransportHeaderItem -> Bool isHeaderItemAcknowledged = \case Acknowledged {} -> False @@ -168,9 +214,12 @@ data GlobalState addr = (Eq addr, Show addr) => GlobalState , gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject)) , gLog :: String -> STM () , gStorage :: PartialStorage + , gStartTime :: TimeSpec , gNowVar :: TVar TimeSpec , gNextTimeout :: TVar TimeSpec , gInitConfig :: Ref + , gCookieKey :: ScrubbedBytes + , gCookieStartTime :: Word32 } data Connection addr = Connection @@ -240,7 +289,11 @@ connAddWriteStream conn@Connection {..} = do runExceptT $ do ((streamNumber, stream), outStreams') <- doInsert 1 outStreams lift $ writeTVar cOutStreams outStreams' - return (StreamOpen streamNumber, sFlowIn stream, go cGlobalState streamNumber stream) + return + ( StreamOpen streamNumber + , RawStreamWriter (fromIntegral streamNumber) (sFlowIn stream) + , go cGlobalState streamNumber stream + ) where go gs@GlobalState {..} streamNumber stream = do @@ -280,7 +333,7 @@ connAddWriteStream conn@Connection {..} = do Right (ctext, counter) -> do let isAcked = True return $ Just (0x80 `B.cons` ctext, if isAcked then [ AcknowledgedSingle $ fromIntegral counter ] else []) - Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ err + Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ showErebosError err return Nothing Nothing | secure -> return Nothing | otherwise -> return $ Just (plain, plainAckedBy) @@ -313,14 +366,21 @@ connAddReadStream Connection {..} streamNumber = do sNextSequence <- newTVar 0 sWaitingForAck <- newTVar 0 let stream = Stream {..} - return (stream, (streamNumber, stream) : streams) - (stream, inStreams') <- doInsert inStreams + return ( streamNumber, stream, (streamNumber, stream) : streams ) + ( num, stream, inStreams' ) <- doInsert inStreams writeTVar cInStreams inStreams' - return $ sFlowOut stream + return $ RawStreamReader (fromIntegral num) (sFlowOut stream) + +data RawStreamReader = RawStreamReader + { rsrNum :: Int + , rsrFlow :: Flow StreamPacket Void + } -type RawStreamReader = Flow StreamPacket Void -type RawStreamWriter = Flow Void StreamPacket +data RawStreamWriter = RawStreamWriter + { rswNum :: Int + , rswFlow :: Flow Void StreamPacket + } data Stream = Stream { sState :: TVar StreamState @@ -355,20 +415,20 @@ streamClosed Connection {..} snum = atomically $ do modifyTVar' cOutStreams $ filter ((snum /=) . fst) readStreamToList :: RawStreamReader -> IO (Word64, [(Word64, BC.ByteString)]) -readStreamToList stream = readFlowIO stream >>= \case +readStreamToList stream = readFlowIO (rsrFlow stream) >>= \case StreamData sq bytes -> fmap ((sq, bytes) :) <$> readStreamToList stream StreamClosed sqEnd -> return (sqEnd, []) -readObjectsFromStream :: PartialStorage -> RawStreamReader -> IO (Except String [PartialObject]) +readObjectsFromStream :: PartialStorage -> RawStreamReader -> IO (Except ErebosError [PartialObject]) readObjectsFromStream st stream = do (seqEnd, list) <- readStreamToList stream let validate s ((s', bytes) : rest) | s == s' = (bytes : ) <$> validate (s + 1) rest | s > s' = validate s rest - | otherwise = throwError "missing object chunk" + | otherwise = throwOtherError "missing object chunk" validate s [] | s == seqEnd = return [] - | otherwise = throwError "content length mismatch" + | otherwise = throwOtherError "content length mismatch" return $ do content <- BL.fromChunks <$> validate 0 list deserializeObjects st content @@ -377,10 +437,10 @@ writeByteStringToStream :: RawStreamWriter -> BL.ByteString -> IO () writeByteStringToStream stream = go 0 where go seqNum bstr - | BL.null bstr = writeFlowIO stream $ StreamClosed seqNum + | BL.null bstr = writeFlowIO (rswFlow stream) $ StreamClosed seqNum | otherwise = do let (cur, rest) = BL.splitAt 500 bstr -- TODO: MTU - writeFlowIO stream $ StreamData seqNum (BL.toStrict cur) + writeFlowIO (rswFlow stream) $ StreamData seqNum (BL.toStrict cur) go (seqNum + 1) rest @@ -391,7 +451,7 @@ data WaitingRef = WaitingRef , wrefStatus :: TVar (Either [RefDigest] Ref) } -type WaitingRefCallback = ExceptT String IO () +type WaitingRefCallback = ExceptT ErebosError IO () wrDigest :: WaitingRef -> RefDigest wrDigest = refDigest . wrefPartial @@ -444,11 +504,14 @@ erebosNetworkProtocol initialIdentity gLog gDataFlow gControlFlow = do mStorage <- memoryStorage gStorage <- derivePartialStorage mStorage - startTime <- getTime Monotonic - gNowVar <- newTVarIO startTime - gNextTimeout <- newTVarIO startTime + gStartTime <- getTime Monotonic + gNowVar <- newTVarIO gStartTime + gNextTimeout <- newTVarIO gStartTime gInitConfig <- store mStorage $ (Rec [] :: Object) + gCookieKey <- getRandomBytes 32 + gCookieStartTime <- runGet getWord32host . BL.pack . BA.unpack @ScrubbedBytes <$> getRandomBytes 4 + let gs = GlobalState {..} let signalTimeouts = forever $ do @@ -466,8 +529,10 @@ erebosNetworkProtocol initialIdentity gLog gDataFlow gControlFlow = do race_ (waitTill next) waitForUpdate - race_ signalTimeouts $ forever $ join $ atomically $ - passUpIncoming gs <|> processIncoming gs <|> processOutgoing gs + race_ signalTimeouts $ forever $ do + io <- atomically $ do + passUpIncoming gs <|> processIncoming gs <|> processOutgoing gs + catch io $ \(e :: SomeException) -> atomically $ gLog $ "exception during network protocol handling: " <> show e getConnection :: GlobalState addr -> addr -> STM (Connection addr) @@ -525,7 +590,7 @@ processIncoming gs@GlobalState {..} = do let parse = case B.uncons msg of Just (b, enc) | b .&. 0xE0 == 0x80 -> do - ch <- maybe (throwError "unexpected encrypted packet") return mbch + ch <- maybe (throwOtherError "unexpected encrypted packet") return mbch (dec, counter) <- channelDecrypt ch enc case B.uncons dec of @@ -540,18 +605,18 @@ processIncoming gs@GlobalState {..} = do return $ Right (snum, seq8, content, counter) Just (_, _) -> do - throwError "unexpected stream header" + throwOtherError "unexpected stream header" Nothing -> do - throwError "empty decrypted content" + throwOtherError "empty decrypted content" | b .&. 0xE0 == 0x60 -> do objs <- deserialize msg return $ Left (False, objs, Nothing) - | otherwise -> throwError "invalid packet" + | otherwise -> throwOtherError "invalid packet" - Nothing -> throwError "empty packet" + Nothing -> throwOtherError "empty packet" now <- getTime Monotonic runExceptT parse >>= \case @@ -602,7 +667,7 @@ processIncoming gs@GlobalState {..} = do atomically $ gLog $ show addr <> ": stream packet without connection" Left err -> do - atomically $ gLog $ show addr <> ": failed to parse packet: " <> err + atomically $ gLog $ show addr <> ": failed to parse packet: " <> showErebosError err processPacket :: GlobalState addr -> Either addr (Connection addr) -> Bool -> TransportPacket a -> IO (Maybe (Connection addr, Maybe (TransportPacket a))) processPacket gs@GlobalState {..} econn secure packet@(TransportPacket (TransportHeader header) _) = if @@ -702,11 +767,38 @@ generateCookieHeaders Connection {..} ch = catMaybes <$> sequence [ echoHeader, _ -> return Nothing createCookie :: GlobalState addr -> addr -> IO Cookie -createCookie GlobalState {} addr = return (Cookie $ BC.pack $ show addr) +createCookie GlobalState {..} addr = do + (nonceBytes :: Bytes) <- getRandomBytes 12 + validUntil <- (fromNanoSecs (60 * 10^(9 :: Int)) +) <$> getTime Monotonic + let validSecondsFromStart = fromIntegral $ toNanoSecs (validUntil - gStartTime) `div` (10^(9 :: Int)) + cookieValidity = validSecondsFromStart - gCookieStartTime + plainContent = BC.pack (show addr) + throwCryptoErrorIO $ do + cookieNonce <- C.nonce12 nonceBytes + st1 <- C.initialize gCookieKey cookieNonce + let st2 = C.finalizeAAD $ C.appendAAD (BL.toStrict $ runPut $ putWord32be cookieValidity) st1 + (cookieContent, st3) = C.encrypt plainContent st2 + cookieMac = C.finalize st3 + return $ Cookie $ BL.toStrict $ encode $ ParsedCookie {..} verifyCookie :: GlobalState addr -> addr -> Cookie -> IO Bool -verifyCookie GlobalState {} addr (Cookie cookie) = return $ show addr == BC.unpack cookie - +verifyCookie GlobalState {..} addr (Cookie cookie) = do + ctime <- getTime Monotonic + return $ fromMaybe False $ do + ( _, _, ParsedCookie {..} ) <- either (const Nothing) Just $ decodeOrFail $ BL.fromStrict cookie + maybeCryptoError $ do + st1 <- C.initialize gCookieKey cookieNonce + let st2 = C.finalizeAAD $ C.appendAAD (BL.toStrict $ runPut $ putWord32be cookieValidity) st1 + (plainContent, st3) = C.decrypt cookieContent st2 + mac = C.finalize st3 + + validSecondsFromStart = fromIntegral $ cookieValidity + gCookieStartTime + validUntil = gStartTime + fromNanoSecs (validSecondsFromStart * (10^(9 :: Int))) + return $ and + [ mac == cookieMac + , ctime <= validUntil + , show addr == BC.unpack plainContent + ] reservePacket :: Connection addr -> STM ReservedToSend reservePacket conn@Connection {..} = do @@ -809,7 +901,7 @@ processOutgoing gs@GlobalState {..} = do Right (ctext, counter) -> do let isAcked = any isHeaderItemAcknowledged hitems return $ Just (0x80 `B.cons` ctext, if isAcked then [ AcknowledgedSingle $ fromIntegral counter ] else []) - Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ err + Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ showErebosError err return Nothing mbs <- case (secure, mbch) of diff --git a/src/Erebos/Network/ifaddrs.c b/src/Erebos/Network/ifaddrs.c index 70685bc..ff4382a 100644 --- a/src/Erebos/Network/ifaddrs.c +++ b/src/Erebos/Network/ifaddrs.c @@ -9,6 +9,7 @@ #ifndef _WIN32 #include <arpa/inet.h> #include <net/if.h> +#include <netinet/in.h> #include <ifaddrs.h> #include <endian.h> #include <sys/types.h> @@ -36,8 +37,10 @@ uint32_t * join_multicast(int fd, size_t * count) return 0; for (struct ifaddrs * ifa = addrs; ifa; ifa = ifa->ifa_next) { - if (ifa->ifa_addr && ifa->ifa_addr->sa_family == AF_INET6 && - !(ifa->ifa_flags & IFF_LOOPBACK)) { + if( ifa->ifa_addr && ifa->ifa_addr->sa_family == AF_INET6 && + ! (ifa->ifa_flags & IFF_LOOPBACK) && + (ifa->ifa_flags & IFF_MULTICAST) && + ! IN6_IS_ADDR_LINKLOCAL( & ((struct sockaddr_in6 *) ifa->ifa_addr)->sin6_addr ) ){ int idx = if_nametoindex(ifa->ifa_name); bool seen = false; @@ -83,8 +86,73 @@ uint32_t * join_multicast(int fd, size_t * count) return interfaces; } +static bool copy_local_address( struct InetAddress * dst, const struct sockaddr * src ) +{ + int family = src->sa_family; + + if( family == AF_INET ){ + struct in_addr * addr = & (( struct sockaddr_in * ) src)->sin_addr; + if (! ((ntohl( addr->s_addr ) & 0xff000000) == 0x7f000000) && // loopback + ! ((ntohl( addr->s_addr ) & 0xffff0000) == 0xa9fe0000) // link-local + ){ + dst->family = family; + memcpy( & dst->addr, addr, sizeof( * addr )); + return true; + } + } + + if( family == AF_INET6 ){ + struct in6_addr * addr = & (( struct sockaddr_in6 * ) src)->sin6_addr; + if (! IN6_IS_ADDR_LOOPBACK( addr ) && + ! IN6_IS_ADDR_LINKLOCAL( addr ) + ){ + dst->family = family; + memcpy( & dst->addr, addr, sizeof( * addr )); + return true; + } + } + + return false; +} + #ifndef _WIN32 +struct InetAddress * local_addresses( size_t * count ) +{ + struct ifaddrs * addrs; + if( getifaddrs( &addrs ) < 0 ) + return 0; + + * count = 0; + size_t capacity = 16; + struct InetAddress * ret = malloc( sizeof(* ret) * capacity ); + + for( struct ifaddrs * ifa = addrs; ifa; ifa = ifa->ifa_next ){ + if ( ifa->ifa_addr ){ + int family = ifa->ifa_addr->sa_family; + if( family == AF_INET || family == AF_INET6 ){ + if( (* count) >= capacity ){ + capacity *= 2; + struct InetAddress * nret = realloc( ret, sizeof(* ret) * capacity ); + if (nret) { + ret = nret; + } else { + free( ret ); + freeifaddrs( addrs ); + return 0; + } + } + + if( copy_local_address( & ret[ * count ], ifa->ifa_addr )) + (* count)++; + } + } + } + + freeifaddrs(addrs); + return ret; +} + uint32_t * broadcast_addresses(void) { struct ifaddrs * addrs; @@ -104,6 +172,7 @@ uint32_t * broadcast_addresses(void) ret = nret; } else { free(ret); + freeifaddrs(addrs); return 0; } } @@ -122,9 +191,52 @@ uint32_t * broadcast_addresses(void) #include <winsock2.h> #include <ws2tcpip.h> +#include <iptypes.h> +#include <iphlpapi.h> #pragma comment(lib, "ws2_32.lib") +struct InetAddress * local_addresses( size_t * count ) +{ + * count = 0; + struct InetAddress * ret = NULL; + + ULONG bufsize = 15000; + IP_ADAPTER_ADDRESSES * buf = NULL; + + DWORD rv = 0; + + do { + buf = realloc( buf, bufsize ); + rv = GetAdaptersAddresses( AF_UNSPEC, 0, NULL, buf, & bufsize ); + + if( rv == ERROR_BUFFER_OVERFLOW ) + continue; + } while (0); + + if( rv == NO_ERROR ){ + size_t capacity = 16; + ret = malloc( sizeof( * ret ) * capacity ); + + for( IP_ADAPTER_ADDRESSES * cur = (IP_ADAPTER_ADDRESSES *) buf; + cur && (* count) < capacity; + cur = cur->Next ){ + + for( IP_ADAPTER_UNICAST_ADDRESS * curAddr = cur->FirstUnicastAddress; + curAddr && (* count) < capacity; + curAddr = curAddr->Next ){ + + if( copy_local_address( & ret[ * count ], curAddr->Address.lpSockaddr )) + (* count)++; + } + } + } + +cleanup: + free( buf ); + return ret; +} + uint32_t * broadcast_addresses(void) { uint32_t * ret = NULL; diff --git a/src/Erebos/Network/ifaddrs.h b/src/Erebos/Network/ifaddrs.h index 8852ec6..2ee45a7 100644 --- a/src/Erebos/Network/ifaddrs.h +++ b/src/Erebos/Network/ifaddrs.h @@ -1,5 +1,18 @@ #include <stddef.h> #include <stdint.h> +#ifndef _WIN32 +#include <sys/socket.h> +#else +#include <winsock2.h> +#endif + +struct InetAddress +{ + int family; + uint8_t addr[16]; +} __attribute__((packed)); + uint32_t * join_multicast(int fd, size_t * count); +struct InetAddress * local_addresses( size_t * count ); uint32_t * broadcast_addresses(void); diff --git a/src/Erebos/Object.hs b/src/Erebos/Object.hs new file mode 100644 index 0000000..f00b63d --- /dev/null +++ b/src/Erebos/Object.hs @@ -0,0 +1,23 @@ +{-| +Description: Core Erebos objects and references + +Data types and functions for working with "raw" Erebos objects and references. +-} + +module Erebos.Object ( + Object, PartialObject, Object'(..), + serializeObject, deserializeObject, deserializeObjects, + ioLoadObject, ioLoadBytes, + storeRawBytes, lazyLoadBytes, + + RecItem, RecItem'(..), + + Ref, PartialRef, RefDigest, + refDigest, refFromDigest, + readRef, showRef, + readRefDigest, showRefDigest, + refDigestFromByteString, hashToRefDigest, + copyRef, partialRef, partialRefFromDigest, +) where + +import Erebos.Object.Internal diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs new file mode 100644 index 0000000..fdb587a --- /dev/null +++ b/src/Erebos/Object/Internal.hs @@ -0,0 +1,772 @@ +module Erebos.Object.Internal ( + Storage, PartialStorage, StorageCompleteness, + + Ref, PartialRef, RefDigest, + refDigest, refFromDigest, + readRef, showRef, + readRefDigest, showRefDigest, + refDigestFromByteString, hashToRefDigest, + copyRef, partialRef, partialRefFromDigest, + + Object, PartialObject, Object'(..), RecItem, RecItem'(..), + serializeObject, deserializeObject, deserializeObjects, + ioLoadObject, ioLoadBytes, + storeRawBytes, lazyLoadBytes, + storeObject, + collectObjects, collectStoredObjects, + + MonadStorage(..), + + Storable(..), ZeroStorable(..), + StorableText(..), StorableDate(..), StorableUUID(..), + + Store, StoreRec, + evalStore, evalStoreObject, + storeBlob, storeRec, storeZero, + storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, storeWeak, storeRawWeak, + storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, storeMbWeak, storeMbRawWeak, + storeZRef, storeZWeak, + storeRecItems, + + Load, LoadRec, + evalLoad, + loadCurrentRef, loadCurrentObject, + loadRecCurrentRef, loadRecItems, + + loadBlob, loadRec, loadZero, + loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, loadRawWeak, + loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, loadMbRawWeak, + loadTexts, loadBinaries, loadRefs, loadRawRefs, loadRawWeaks, + loadZRef, + + Stored, + fromStored, storedRef, + wrappedStore, wrappedLoad, + copyStored, + unsafeMapStored, +) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.Writer + +import Crypto.Hash + +import Data.Bifunctor +import Data.ByteString (ByteString) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.Char +import Data.Function +import Data.Maybe +import Data.Ratio +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Data.Text.Encoding.Error +import Data.Time.Calendar +import Data.Time.Clock +import Data.Time.Format +import Data.Time.LocalTime + +import System.IO.Unsafe + +import Erebos.Error +import Erebos.Storage.Internal +import Erebos.UUID (UUID) +import Erebos.UUID qualified as U +import Erebos.Util + + +zeroRef :: Storage' c -> Ref' c +zeroRef s = Ref s (RefDigest h) + where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of + Nothing -> error $ "Failed to create zero hash" + Just h' -> h' + digestAlgo :: Digest a -> a + digestAlgo = undefined + +isZeroRef :: Ref' c -> Bool +isZeroRef (Ref _ h) = all (==0) $ BA.unpack h + + +refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c)) +refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst + +readRef :: Storage -> ByteString -> IO (Maybe Ref) +readRef s b = + case readRefDigest b of + Nothing -> return Nothing + Just dgst -> refFromDigest s dgst + +copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c')) +copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref + Nothing -> doCopy + where doCopy = do mbobj' <- ioLoadObject ref' + mbobj <- sequence $ copyObject' st <$> mbobj' + sequence $ unsafeStoreObject st <$> join mbobj + +copyRecItem' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> RecItem' c -> IO (c (RecItem' c')) +copyRecItem' st = \case + RecEmpty -> return $ return $ RecEmpty + RecInt x -> return $ return $ RecInt x + RecNum x -> return $ return $ RecNum x + RecText x -> return $ return $ RecText x + RecBinary x -> return $ return $ RecBinary x + RecDate x -> return $ return $ RecDate x + RecUUID x -> return $ return $ RecUUID x + RecRef x -> fmap RecRef <$> copyRef' st x + RecWeak x -> return $ return $ RecWeak x + RecUnknown t x -> return $ return $ RecUnknown t x + +copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c')) +copyObject' _ (Blob bs) = return $ return $ Blob bs +copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs +copyObject' _ ZeroObject = return $ return ZeroObject +copyObject' _ (UnknownObject otype content) = return $ return $ UnknownObject otype content + +copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c')) +copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref' + +copyRecItem :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> RecItem' c -> m (LoadResult c (RecItem' c')) +copyRecItem st item' = liftIO $ returnLoadResult <$> copyRecItem' st item' + +copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c')) +copyObject st obj' = returnLoadResult <$> copyObject' st obj' + +partialRef :: PartialStorage -> Ref -> PartialRef +partialRef st (Ref _ dgst) = Ref st dgst + +partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef +partialRefFromDigest st dgst = Ref st dgst + + +data Object' c + = Blob ByteString + | Rec [(ByteString, RecItem' c)] + | ZeroObject + | UnknownObject ByteString ByteString + deriving (Show) + +type Object = Object' Complete +type PartialObject = Object' Partial + +data RecItem' c + = RecEmpty + | RecInt Integer + | RecNum Rational + | RecText Text + | RecBinary ByteString + | RecDate ZonedTime + | RecUUID UUID + | RecRef (Ref' c) + | RecWeak RefDigest + | RecUnknown ByteString ByteString + deriving (Show) + +type RecItem = RecItem' Complete + +serializeObject :: Object' c -> BL.ByteString +serializeObject = \case + Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] + Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec + in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt + ZeroObject -> BL.empty + UnknownObject otype cnt -> BL.fromChunks [ otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt ] + +-- |Serializes and stores object data without ony dependencies, so is safe only +-- if all the referenced objects are already stored or reference is partial. +unsafeStoreObject :: Storage' c -> Object' c -> IO (Ref' c) +unsafeStoreObject storage = \case + ZeroObject -> return $ zeroRef storage + obj -> unsafeStoreRawBytes storage $ serializeObject obj + +storeObject :: PartialStorage -> PartialObject -> IO PartialRef +storeObject = unsafeStoreObject + +storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef +storeRawBytes = unsafeStoreRawBytes + +serializeRecItem :: ByteString -> RecItem' c -> [ByteString] +serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n'] +serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n'] +serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n'] +serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n'] + where escaped = BC.concatMap escape $ encodeUtf8 x + escape '\n' = BC.pack "\n\t" + escape c = BC.singleton c +serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.singleton '\n'] +serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n'] +serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n'] +serializeRecItem name (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n'] +serializeRecItem name (RecWeak x) = [name, BC.pack ":w ", showRefDigest x, BC.singleton '\n'] +serializeRecItem name (RecUnknown t x) = [ name, BC.singleton ':', t, BC.singleton ' ', x, BC.singleton '\n' ] + +lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c) +lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject + +ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c)) +ioLoadObject ref | isZeroRef ref = return $ return ZeroObject +ioLoadObject ref@(Ref st rhash) = do + file' <- ioLoadBytes ref + return $ do + file <- file' + let chash = hashToRefDigest file + when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -} + return $ case runExcept $ unsafeDeserializeObject st file of + Left err -> error $ showErebosError err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -} + Right (x, rest) | BL.null rest -> x + | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -} + +lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString +lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString) +lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref + +unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except ErebosError (Object' c, BL.ByteString) +unsafeDeserializeObject _ bytes | BL.null bytes = return (ZeroObject, bytes) +unsafeDeserializeObject st bytes = + case BLC.break (=='\n') bytes of + (line, rest) | Just (otype, len) <- splitObjPrefix line -> do + let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest + guard $ B.length content == len + (,next) <$> case otype of + _ | otype == BC.pack "blob" -> return $ Blob content + | otype == BC.pack "rec" -> maybe (throwOtherError $ "malformed record item ") + (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content + | otherwise -> return $ UnknownObject otype content + _ -> throwOtherError $ "malformed object" + where splitObjPrefix line = do + [otype, tlen] <- return $ BLC.words line + (len, rest) <- BLC.readInt tlen + guard $ BL.null rest + return (BL.toStrict otype, len) + + mergeCont cs (a:b:rest) | Just ('\t', b') <- BC.uncons b = mergeCont (b':BC.pack "\n":cs) (a:rest) + mergeCont cs (a:rest) = B.concat (a : reverse cs) : mergeCont [] rest + mergeCont _ [] = [] + + parseRecLine line = do + colon <- BC.elemIndex ':' line + space <- BC.elemIndex ' ' line + guard $ colon < space + let name = B.take colon line + itype = B.take (space-colon-1) $ B.drop (colon+1) line + content = B.drop (space+1) line + + let val = fromMaybe (RecUnknown itype content) $ + case BC.unpack itype of + "e" -> do guard $ B.null content + return RecEmpty + "i" -> do (num, rest) <- BC.readInteger content + guard $ B.null rest + return $ RecInt num + "n" -> RecNum <$> parseRatio content + "t" -> return $ RecText $ decodeUtf8With lenientDecode content + "b" -> RecBinary <$> readHex content + "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content) + "u" -> RecUUID <$> U.fromASCIIBytes content + "r" -> RecRef . Ref st <$> readRefDigest content + "w" -> RecWeak <$> readRefDigest content + _ -> Nothing + return (name, val) + +deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString) +deserializeObject = unsafeDeserializeObject + +deserializeObjects :: PartialStorage -> BL.ByteString -> Except ErebosError [PartialObject] +deserializeObjects _ bytes | BL.null bytes = return [] +deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes + (obj:) <$> deserializeObjects st rest + + +collectObjects :: Object -> [Object] +collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj) + +collectStoredObjects :: Stored Object -> [Stored Object] +collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj) + +collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest) +collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items + where helper (RecRef ref) (xs, s) | r <- refDigest ref + , r `S.notMember` s + = let o = wrappedLoad ref + (xs', s') = collectOtherStored (S.insert r s) $ fromStored o + in ((o : xs') ++ xs, s') + helper _ (xs, s) = (xs, s) +collectOtherStored seen _ = ([], seen) + + +deriving instance StorableUUID HeadID +deriving instance StorableUUID HeadTypeID + + +class Monad m => MonadStorage m where + getStorage :: m Storage + mstore :: Storable a => a -> m (Stored a) + + default mstore :: MonadIO m => Storable a => a -> m (Stored a) + mstore x = do + st <- getStorage + wrappedStore st x + +instance MonadIO m => MonadStorage (ReaderT Storage m) where + getStorage = ask + + +class Storable a where + store' :: a -> Store + load' :: Load a + + store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c) + store st = evalStore st . store' + load :: Ref -> a + load = evalLoad load' + +class Storable a => ZeroStorable a where + fromZero :: Storage -> a + +data Store = StoreBlob ByteString + | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]]) + | StoreZero + | StoreUnknown ByteString ByteString + +evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c) +evalStore st = unsafeStoreObject st <=< evalStoreObject st + +evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c) +evalStoreObject _ (StoreBlob x) = return $ Blob x +evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s) +evalStoreObject _ StoreZero = return ZeroObject +evalStoreObject _ (StoreUnknown otype content) = return $ UnknownObject otype content + +newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a) + deriving (Functor, Applicative, Monad) + +type StoreRec c = StoreRecM c () + +newtype Load a = Load (ReaderT (Ref, Object) (Except ErebosError) a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError) + +evalLoad :: Load a -> Ref -> a +evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ") ++) . showErebosError) id $ + runExcept $ runReaderT f (ref, lazyLoadObject ref) + +loadCurrentRef :: Load Ref +loadCurrentRef = Load $ asks fst + +loadCurrentObject :: Load Object +loadCurrentObject = Load $ asks snd + +newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except ErebosError) a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError ErebosError) + +loadRecCurrentRef :: LoadRec Ref +loadRecCurrentRef = LoadRec $ asks fst + +loadRecItems :: LoadRec [(ByteString, RecItem)] +loadRecItems = LoadRec $ asks snd + + +instance Storable Object where + store' (Blob bs) = StoreBlob bs + store' (Rec xs) = StoreRec $ \st -> return $ do + Rec xs' <- copyObject st (Rec xs) + return xs' + store' ZeroObject = StoreZero + store' (UnknownObject otype content) = StoreUnknown otype content + + load' = loadCurrentObject + + store st = unsafeStoreObject st <=< copyObject st + load = lazyLoadObject + +instance Storable ByteString where + store' = storeBlob + load' = loadBlob id + +instance Storable a => Storable [a] where + store' [] = storeZero + store' (x:xs) = storeRec $ do + storeRef "i" x + storeRef "n" xs + + load' = loadCurrentObject >>= \case + ZeroObject -> return [] + _ -> loadRec $ (:) + <$> loadRef "i" + <*> loadRef "n" + +instance Storable a => ZeroStorable [a] where + fromZero _ = [] + + +storeBlob :: ByteString -> Store +storeBlob = StoreBlob + +storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store +storeRec sr = StoreRec $ do + let StoreRecM r = sr + execWriter . runReaderT r + +storeZero :: Store +storeZero = StoreZero + + +class StorableText a where + toText :: a -> Text + fromText :: MonadError ErebosError m => Text -> m a + +instance StorableText Text where + toText = id; fromText = return + +instance StorableText [Char] where + toText = T.pack; fromText = return . T.unpack + + +class StorableDate a where + toDate :: a -> ZonedTime + fromDate :: ZonedTime -> a + +instance StorableDate ZonedTime where + toDate = id; fromDate = id + +instance StorableDate UTCTime where + toDate = utcToZonedTime utc + fromDate = zonedTimeToUTC + +instance StorableDate Day where + toDate day = toDate $ UTCTime day 0 + fromDate = utctDay . fromDate + + +class StorableUUID a where + toUUID :: a -> UUID + fromUUID :: UUID -> a + +instance StorableUUID UUID where + toUUID = id; fromUUID = id + + +storeEmpty :: String -> StoreRec c +storeEmpty name = StoreRecM $ tell [return [(BC.pack name, RecEmpty)]] + +storeMbEmpty :: String -> Maybe () -> StoreRec c +storeMbEmpty name = maybe (return ()) (const $ storeEmpty name) + +storeInt :: Integral a => String -> a -> StoreRec c +storeInt name x = StoreRecM $ tell [return [(BC.pack name, RecInt $ toInteger x)]] + +storeMbInt :: Integral a => String -> Maybe a -> StoreRec c +storeMbInt name = maybe (return ()) (storeInt name) + +storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c +storeNum name x = StoreRecM $ tell [return [(BC.pack name, RecNum $ toRational x)]] + +storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c +storeMbNum name = maybe (return ()) (storeNum name) + +storeText :: StorableText a => String -> a -> StoreRec c +storeText name x = StoreRecM $ tell [return [(BC.pack name, RecText $ toText x)]] + +storeMbText :: StorableText a => String -> Maybe a -> StoreRec c +storeMbText name = maybe (return ()) (storeText name) + +storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c +storeBinary name x = StoreRecM $ tell [return [(BC.pack name, RecBinary $ BA.convert x)]] + +storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c +storeMbBinary name = maybe (return ()) (storeBinary name) + +storeDate :: StorableDate a => String -> a -> StoreRec c +storeDate name x = StoreRecM $ tell [return [(BC.pack name, RecDate $ toDate x)]] + +storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c +storeMbDate name = maybe (return ()) (storeDate name) + +storeUUID :: StorableUUID a => String -> a -> StoreRec c +storeUUID name x = StoreRecM $ tell [return [(BC.pack name, RecUUID $ toUUID x)]] + +storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c +storeMbUUID name = maybe (return ()) (storeUUID name) + +storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c +storeRef name x = StoreRecM $ do + s <- ask + tell $ (:[]) $ do + ref <- store s x + return [(BC.pack name, RecRef ref)] + +storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c +storeMbRef name = maybe (return ()) (storeRef name) + +storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c +storeRawRef name ref = StoreRecM $ do + st <- ask + tell $ (:[]) $ do + ref' <- copyRef st ref + return [(BC.pack name, RecRef ref')] + +storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c +storeMbRawRef name = maybe (return ()) (storeRawRef name) + +storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c +storeZRef name x = StoreRecM $ do + s <- ask + tell $ (:[]) $ do + ref <- store s x + return $ if isZeroRef ref then [] + else [(BC.pack name, RecRef ref)] + +storeWeak :: Storable a => StorageCompleteness c => String -> a -> StoreRec c +storeWeak name x = StoreRecM $ do + s <- ask + tell $ (:[]) $ do + ref <- store s x + return [ ( BC.pack name, RecWeak $ refDigest ref ) ] + +storeMbWeak :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c +storeMbWeak name = maybe (return ()) (storeWeak name) + +storeRawWeak :: StorageCompleteness c => String -> RefDigest -> StoreRec c +storeRawWeak name dgst = StoreRecM $ do + tell $ (:[]) $ do + return [ ( BC.pack name, RecWeak dgst ) ] + +storeMbRawWeak :: StorageCompleteness c => String -> Maybe RefDigest -> StoreRec c +storeMbRawWeak name = maybe (return ()) (storeRawWeak name) + +storeZWeak :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c +storeZWeak name x = StoreRecM $ do + s <- ask + tell $ (:[]) $ do + ref <- store s x + return $ if isZeroRef ref then [] + else [ ( BC.pack name, RecWeak $ refDigest ref ) ] + + +storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c +storeRecItems items = StoreRecM $ do + st <- ask + tell $ flip map items $ \( name, value ) -> do + value' <- copyRecItem st value + return [ ( name, value' ) ] + +loadBlob :: (ByteString -> a) -> Load a +loadBlob f = loadCurrentObject >>= \case + Blob x -> return $ f x + _ -> throwOtherError "Expecting blob" + +loadRec :: LoadRec a -> Load a +loadRec (LoadRec lrec) = loadCurrentObject >>= \case + Rec rs -> do + ref <- loadCurrentRef + either throwError return $ runExcept $ runReaderT lrec (ref, rs) + _ -> throwOtherError "Expecting record" + +loadZero :: a -> Load a +loadZero x = loadCurrentObject >>= \case + ZeroObject -> return x + _ -> throwOtherError "Expecting zero" + + +loadEmpty :: String -> LoadRec () +loadEmpty name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name + +loadMbEmpty :: String -> LoadRec (Maybe ()) +loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecEmpty ) | name' == bname + = Just () + p _ = Nothing + +loadInt :: Num a => String -> LoadRec a +loadInt name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbInt name + +loadMbInt :: Num a => String -> LoadRec (Maybe a) +loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecInt x ) | name' == bname + = Just (fromInteger x) + p _ = Nothing + +loadNum :: (Real a, Fractional a) => String -> LoadRec a +loadNum name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbNum name + +loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a) +loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecNum x ) | name' == bname + = Just (fromRational x) + p _ = Nothing + +loadText :: StorableText a => String -> LoadRec a +loadText name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbText name + +loadMbText :: StorableText a => String -> LoadRec (Maybe a) +loadMbText name = listToMaybe <$> loadTexts name + +loadTexts :: StorableText a => String -> LoadRec [a] +loadTexts name = sequence . mapMaybe p =<< loadRecItems + where + bname = BC.pack name + p ( name', RecText x ) | name' == bname + = Just (fromText x) + p _ = Nothing + +loadBinary :: BA.ByteArray a => String -> LoadRec a +loadBinary name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbBinary name + +loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a) +loadMbBinary name = listToMaybe <$> loadBinaries name + +loadBinaries :: BA.ByteArray a => String -> LoadRec [a] +loadBinaries name = mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecBinary x ) | name' == bname + = Just (BA.convert x) + p _ = Nothing + +loadDate :: StorableDate a => String -> LoadRec a +loadDate name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbDate name + +loadMbDate :: StorableDate a => String -> LoadRec (Maybe a) +loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecDate x ) | name' == bname + = Just (fromDate x) + p _ = Nothing + +loadUUID :: StorableUUID a => String -> LoadRec a +loadUUID name = maybe (throwOtherError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name + +loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a) +loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecUUID x ) | name' == bname + = Just (fromUUID x) + p _ = Nothing + +loadRawRef :: String -> LoadRec Ref +loadRawRef name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name + +loadMbRawRef :: String -> LoadRec (Maybe Ref) +loadMbRawRef name = listToMaybe <$> loadRawRefs name + +loadRawRefs :: String -> LoadRec [Ref] +loadRawRefs name = mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecRef x ) | name' == bname = Just x + p _ = Nothing + +loadRef :: Storable a => String -> LoadRec a +loadRef name = load <$> loadRawRef name + +loadMbRef :: Storable a => String -> LoadRec (Maybe a) +loadMbRef name = fmap load <$> loadMbRawRef name + +loadRefs :: Storable a => String -> LoadRec [a] +loadRefs name = map load <$> loadRawRefs name + +loadZRef :: ZeroStorable a => String -> LoadRec a +loadZRef name = loadMbRef name >>= \case + Nothing -> do Ref st _ <- loadRecCurrentRef + return $ fromZero st + Just x -> return x + +loadRawWeak :: String -> LoadRec RefDigest +loadRawWeak name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawWeak name + +loadMbRawWeak :: String -> LoadRec (Maybe RefDigest) +loadMbRawWeak name = listToMaybe <$> loadRawWeaks name + +loadRawWeaks :: String -> LoadRec [ RefDigest ] +loadRawWeaks name = mapMaybe p <$> loadRecItems + where + bname = BC.pack name + p ( name', RecRef x ) | name' == bname = Just (refDigest x) + p ( name', RecWeak x ) | name' == bname = Just x + p _ = Nothing + + + +instance Storable a => Storable (Stored a) where + store st = copyRef st . storedRef + store' (Stored _ x) = store' x + load' = Stored <$> loadCurrentRef <*> load' + +instance ZeroStorable a => ZeroStorable (Stored a) where + fromZero st = Stored (zeroRef st) $ fromZero st + +fromStored :: Stored a -> a +fromStored = storedObject' + +storedRef :: Stored a -> Ref +storedRef = storedRef' + +wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a) +wrappedStore st x = do ref <- liftIO $ store st x + return $ Stored ref x + +wrappedLoad :: Storable a => Ref -> Stored a +wrappedLoad ref = Stored ref (load ref) + +copyStored :: forall m a. MonadIO m => Storage -> Stored a -> m (Stored a) +copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (\r -> Stored r x) <$> copyRef' st ref' + +-- |Passed function needs to preserve the object representation to be safe +unsafeMapStored :: (a -> b) -> Stored a -> Stored b +unsafeMapStored f (Stored ref x) = Stored ref (f x) + + +showRatio :: Rational -> String +showRatio r = case decimalRatio r of + Just (n, 1) -> show n + Just (n', d) -> let n = abs n' + in (if n' < 0 then "-" else "") ++ show (n `div` d) ++ "." ++ + (concatMap (show.(`mod` 10).snd) $ reverse $ takeWhile ((>1).fst) $ zip (iterate (`div` 10) d) (iterate (`div` 10) (n `mod` d))) + Nothing -> show (numerator r) ++ "/" ++ show (denominator r) + +decimalRatio :: Rational -> Maybe (Integer, Integer) +decimalRatio r = do + let n = numerator r + d = denominator r + (c2, d') = takeFactors 2 d + (c5, d'') = takeFactors 5 d' + guard $ d'' == 1 + let m = if c2 > c5 then 5 ^ (c2 - c5) + else 2 ^ (c5 - c2) + return (n * m, d * m) + +takeFactors :: Integer -> Integer -> (Integer, Integer) +takeFactors f n | n `mod` f == 0 = let (c, n') = takeFactors f (n `div` f) + in (c+1, n') + | otherwise = (0, n) + +parseRatio :: ByteString -> Maybe Rational +parseRatio bs = case BC.groupBy ((==) `on` isNumber) bs of + (m:xs) | m == BC.pack "-" -> negate <$> positive xs + xs -> positive xs + where positive = \case + [bx] -> fromInteger . fst <$> BC.readInteger bx + [bx, op, by] -> do + (x, _) <- BC.readInteger bx + (y, _) <- BC.readInteger by + case BC.unpack op of + "." -> return $ (x % 1) + (y % (10 ^ BC.length by)) + "/" -> return $ x % y + _ -> Nothing + _ -> Nothing diff --git a/src/Erebos/Pairing.hs b/src/Erebos/Pairing.hs index 2166e71..e3ebf2b 100644 --- a/src/Erebos/Pairing.hs +++ b/src/Erebos/Pairing.hs @@ -17,9 +17,10 @@ import Control.Monad.Reader import Crypto.Random import Data.Bits -import Data.ByteArray (Bytes, convert) -import qualified Data.ByteArray as BA -import qualified Data.ByteString.Char8 as BC +import Data.ByteArray qualified as BA +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BC import Data.Kind import Data.Maybe import Data.Typeable @@ -27,28 +28,29 @@ import Data.Word import Erebos.Identity import Erebos.Network +import Erebos.Object import Erebos.PubKey import Erebos.Service import Erebos.State -import Erebos.Storage +import Erebos.Storable data PairingService a = PairingRequest (Stored (Signed IdentityData)) (Stored (Signed IdentityData)) RefDigest - | PairingResponse Bytes - | PairingRequestNonce Bytes + | PairingResponse ByteString + | PairingRequestNonce ByteString | PairingAccept a | PairingReject data PairingState a = NoPairing - | OurRequest UnifiedIdentity UnifiedIdentity Bytes + | OurRequest UnifiedIdentity UnifiedIdentity ByteString | OurRequestConfirm (Maybe (PairingVerifiedResult a)) | OurRequestReady - | PeerRequest UnifiedIdentity UnifiedIdentity Bytes RefDigest + | PeerRequest UnifiedIdentity UnifiedIdentity ByteString RefDigest | PeerRequestConfirm | PairingDone data PairingFailureReason a = PairingUserRejected | PairingUnexpectedMessage (PairingState a) (PairingService a) - | PairingFailedOther String + | PairingFailedOther ErebosError data PairingAttributes a = PairingAttributes { pairingHookRequest :: ServiceHandler (PairingService a) () @@ -87,7 +89,7 @@ instance Storable a => Storable (PairingService a) where load' = do res <- loadRec $ do - (req :: Maybe Bytes) <- loadMbBinary "request" + (req :: Maybe ByteString) <- loadMbBinary "request" idReq <- loadMbRef "id-req" idRsp <- loadMbRef "id-rsp" rsp <- loadMbBinary "response" @@ -115,16 +117,16 @@ instance PairingResult a => Service (PairingService a) where serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case (NoPairing, PairingRequest pdata sdata confirm) -> do - self <- maybe (throwError "failed to validate received identity") return $ validateIdentity sdata - self' <- maybe (throwError "failed to validate own identity") return . + self <- maybe (throwOtherError "failed to validate received identity") return $ validateIdentity sdata + self' <- maybe (throwOtherError "failed to validate own identity") return . validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal when (not $ self `sameIdentity` self') $ do - throwError "pairing request to different identity" + throwOtherError "pairing request to different identity" - peer <- maybe (throwError "failed to validate received peer identity") return $ validateIdentity pdata + peer <- maybe (throwOtherError "failed to validate received peer identity") return $ validateIdentity pdata peer' <- asks $ svcPeerIdentity when (not $ peer `sameIdentity` peer') $ do - throwError "pairing request from different identity" + throwOtherError "pairing request from different identity" join $ asks $ pairingHookRequest . svcAttributes nonce <- liftIO $ getRandomBytes 32 @@ -166,11 +168,11 @@ instance PairingResult a => Service (PairingService a) where svcSet $ PairingDone Nothing -> do join $ asks $ pairingHookVerifyFailed . svcAttributes - throwError "" + throwOtherError "" x@(OurRequestReady, _) -> reject $ uncurry PairingUnexpectedMessage x (PeerRequest peer self nonce dgst, PairingRequestNonce pnonce) -> do - if dgst == nonceDigest peer self pnonce BA.empty + if dgst == nonceDigest peer self pnonce BS.empty then do hook <- asks $ pairingHookRequestNonce . svcAttributes hook $ confirmationNumber $ nonceDigest peer self pnonce nonce svcSet PeerRequestConfirm @@ -187,12 +189,12 @@ reject reason = do replyPacket PairingReject -nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest +nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> ByteString -> ByteString -> RefDigest nonceDigest idReq idRsp nonceReq nonceRsp = hashToRefDigest $ serializeObject $ Rec [ (BC.pack "id-req", RecRef $ storedRef $ idData idReq) , (BC.pack "id-rsp", RecRef $ storedRef $ idData idRsp) - , (BC.pack "nonce-req", RecBinary $ convert nonceReq) - , (BC.pack "nonce-rsp", RecBinary $ convert nonceRsp) + , (BC.pack "nonce-req", RecBinary nonceReq) + , (BC.pack "nonce-rsp", RecBinary nonceRsp) ] confirmationNumber :: RefDigest -> String @@ -203,22 +205,22 @@ confirmationNumber dgst = _ -> "" where len = 6 -pairingRequest :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () +pairingRequest :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingRequest _ peer = do self <- liftIO $ serverIdentity $ peerServer peer nonce <- liftIO $ getRandomBytes 32 pid <- peerIdentity peer >>= \case PeerIdentityFull pid -> return pid - _ -> throwError "incomplete peer identity" + _ -> throwOtherError "incomplete peer identity" sendToPeerWith @(PairingService a) peer $ \case - NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BA.empty), OurRequest self pid nonce) - _ -> throwError "already in progress" + NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BS.empty), OurRequest self pid nonce) + _ -> throwOtherError "already in progress" -pairingAccept :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () +pairingAccept :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingAccept _ peer = runPeerService @(PairingService a) peer $ do svcGet >>= \case - NoPairing -> throwError $ "none in progress" - OurRequest {} -> throwError $ "waiting for peer" + NoPairing -> throwOtherError $ "none in progress" + OurRequest {} -> throwOtherError $ "waiting for peer" OurRequestConfirm Nothing -> do join $ asks $ pairingHookConfirmedResponse . svcAttributes svcSet OurRequestReady @@ -226,17 +228,17 @@ pairingAccept _ peer = runPeerService @(PairingService a) peer $ do join $ asks $ pairingHookAcceptedResponse . svcAttributes pairingFinalizeRequest verified svcSet PairingDone - OurRequestReady -> throwError $ "already accepted, waiting for peer" - PeerRequest {} -> throwError $ "waiting for peer" + OurRequestReady -> throwOtherError $ "already accepted, waiting for peer" + PeerRequest {} -> throwOtherError $ "waiting for peer" PeerRequestConfirm -> do join $ asks $ pairingHookAcceptedRequest . svcAttributes replyPacket . PairingAccept =<< pairingFinalizeResponse svcSet PairingDone - PairingDone -> throwError $ "already done" + PairingDone -> throwOtherError $ "already done" -pairingReject :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () +pairingReject :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingReject _ peer = runPeerService @(PairingService a) peer $ do svcGet >>= \case - NoPairing -> throwError $ "none in progress" - PairingDone -> throwError $ "already done" + NoPairing -> throwOtherError $ "none in progress" + PairingDone -> throwOtherError $ "already done" _ -> reject PairingUserRejected diff --git a/src/Erebos/PubKey.hs b/src/Erebos/PubKey.hs index 09a8e02..a2ee519 100644 --- a/src/Erebos/PubKey.hs +++ b/src/Erebos/PubKey.hs @@ -11,7 +11,6 @@ module Erebos.PubKey ( ) where import Control.Monad -import Control.Monad.Except import Crypto.Error import qualified Crypto.PubKey.Ed25519 as ED @@ -21,7 +20,7 @@ import Data.ByteArray import Data.ByteString (ByteString) import qualified Data.Text as T -import Erebos.Storage +import Erebos.Storable import Erebos.Storage.Key data PublicKey = PublicKey ED.PublicKey @@ -70,7 +69,7 @@ instance Storable PublicKey where load' = loadRec $ do ktype <- loadText "type" guard $ ktype == "ed25519" - maybe (throwError "Public key decoding failed") (return . PublicKey) . + maybe (throwOtherError "public key decoding failed") (return . PublicKey) . maybeCryptoError . (ED.publicKey :: ByteString -> CryptoFailable ED.PublicKey) =<< loadBinary "pubkey" @@ -82,7 +81,7 @@ instance Storable Signature where load' = loadRec $ Signature <$> loadRef "key" <*> loadSignature "sig" - where loadSignature = maybe (throwError "Signature decoding failed") return . + where loadSignature = maybe (throwOtherError "signature decoding failed") return . maybeCryptoError . (ED.signature :: ByteString -> CryptoFailable ED.Signature) <=< loadBinary instance Storable a => Storable (Signed a) where @@ -96,7 +95,7 @@ instance Storable a => Storable (Signed a) where forM_ sigs $ \sig -> do let PublicKey pubkey = fromStored $ sigKey $ fromStored sig when (not $ ED.verify pubkey (storedRef sdata) $ sigSignature $ fromStored sig) $ - throwError "signature verification failed" + throwOtherError "signature verification failed" return $ Signed sdata sigs sign :: MonadStorage m => SecretKey -> Stored a -> m (Signed a) @@ -148,7 +147,7 @@ instance Storable PublicKexKey where load' = loadRec $ do ktype <- loadText "type" guard $ ktype == "x25519" - maybe (throwError "public key decoding failed") (return . PublicKexKey) . + maybe (throwOtherError "public key decoding failed") (return . PublicKexKey) . maybeCryptoError . (CX.publicKey :: ScrubbedBytes -> CryptoFailable CX.PublicKey) =<< loadBinary "pubkey" diff --git a/src/Erebos/Service.hs b/src/Erebos/Service.hs index f8428d1..4499ef9 100644 --- a/src/Erebos/Service.hs +++ b/src/Erebos/Service.hs @@ -29,15 +29,22 @@ import Control.Monad.Writer import Data.Kind import Data.Typeable -import Data.UUID (UUID) -import qualified Data.UUID as U import Erebos.Identity import {-# SOURCE #-} Erebos.Network +import Erebos.Network.Protocol import Erebos.State -import Erebos.Storage +import Erebos.Storable +import Erebos.Storage.Head +import Erebos.UUID qualified as U + +class ( + Typeable s, Storable s, + Typeable (ServiceAttributes s), + Typeable (ServiceState s), + Typeable (ServiceGlobalState s) + ) => Service s where -class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGlobalState s)) => Service s where serviceID :: proxy s -> ServiceID serviceHandler :: Stored s -> ServiceHandler s () @@ -65,6 +72,9 @@ class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGloba serviceStorageWatchers :: proxy s -> [SomeStorageWatcher s] serviceStorageWatchers _ = [] + serviceStopServer :: proxy s -> Server -> ServiceGlobalState s -> [ ( Peer, ServiceState s ) ] -> IO () + serviceStopServer _ _ _ _ = return () + data SomeService = forall s. Service s => SomeService (Proxy s) (ServiceAttributes s) @@ -94,11 +104,10 @@ someServiceEmptyGlobalState :: SomeService -> SomeServiceGlobalState someServiceEmptyGlobalState (SomeService p _) = SomeServiceGlobalState p (emptyServiceGlobalState p) -data SomeStorageWatcher s = forall a. Eq a => SomeStorageWatcher (Stored LocalState -> a) (a -> ServiceHandler s ()) - +data SomeStorageWatcher s + = forall a. Eq a => SomeStorageWatcher (Stored LocalState -> a) (a -> ServiceHandler s ()) + | forall a. Eq a => GlobalStorageWatcher (Stored LocalState -> a) (Server -> a -> ExceptT ErebosError IO ()) -newtype ServiceID = ServiceID UUID - deriving (Eq, Ord, Show, StorableUUID) mkServiceID :: String -> ServiceID mkServiceID = maybe (error "Invalid service ID") ServiceID . U.fromString @@ -109,10 +118,13 @@ data ServiceInput s = ServiceInput , svcPeerIdentity :: UnifiedIdentity , svcServer :: Server , svcPrintOp :: String -> IO () + , svcNewStreams :: [ RawStreamReader ] } -data ServiceReply s = ServiceReply (Either s (Stored s)) Bool - | ServiceFinally (IO ()) +data ServiceReply s + = ServiceReply (Either s (Stored s)) Bool + | ServiceOpenStream (RawStreamWriter -> IO ()) + | ServiceFinally (IO ()) data ServiceHandlerState s = ServiceHandlerState { svcValue :: ServiceState s @@ -120,8 +132,8 @@ data ServiceHandlerState s = ServiceHandlerState , svcLocal :: Stored LocalState } -newtype ServiceHandler s a = ServiceHandler (ReaderT (ServiceInput s) (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT String IO))) a) - deriving (Functor, Applicative, Monad, MonadReader (ServiceInput s), MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError String, MonadIO) +newtype ServiceHandler s a = ServiceHandler (ReaderT (ServiceInput s) (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT ErebosError IO))) a) + deriving (Functor, Applicative, Monad, MonadReader (ServiceInput s), MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError ErebosError, MonadIO) instance MonadStorage (ServiceHandler s) where getStorage = asks $ peerStorage . svcPeer @@ -138,7 +150,7 @@ runServiceHandler h input svc global shandler = do ServiceHandler handler = shandler (runExceptT $ flip runStateT sstate $ execWriterT $ flip runReaderT input $ handler) >>= \case Left err -> do - svcPrintOp input $ "service failed: " ++ err + svcPrintOp input $ "service failed: " ++ showErebosError err return ([], (svc, global)) Right (rsp, sstate') | svcLocal sstate' == svcLocal sstate -> return (rsp, (svcValue sstate', svcGlobal sstate')) @@ -171,7 +183,7 @@ svcSetLocal :: Stored LocalState -> ServiceHandler s () svcSetLocal x = modify $ \st -> st { svcLocal = x } svcSelf :: ServiceHandler s UnifiedIdentity -svcSelf = maybe (throwError "failed to validate own identity") return . +svcSelf = maybe (throwOtherError "failed to validate own identity") return . validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal svcPrint :: String -> ServiceHandler s () diff --git a/src/Erebos/Service/Stream.hs b/src/Erebos/Service/Stream.hs new file mode 100644 index 0000000..67df4d7 --- /dev/null +++ b/src/Erebos/Service/Stream.hs @@ -0,0 +1,74 @@ +module Erebos.Service.Stream ( + StreamPacket(..), + StreamReader, getStreamReaderNumber, + StreamWriter, getStreamWriterNumber, + openStream, receivedStreams, + readStreamPacket, writeStreamPacket, + writeStream, + closeStream, +) where + +import Control.Concurrent.MVar +import Control.Monad.Reader +import Control.Monad.Writer + +import Data.ByteString (ByteString) +import Data.Word + +import Erebos.Flow +import Erebos.Network +import Erebos.Network.Protocol +import Erebos.Service + + +data StreamReader = StreamReader RawStreamReader + +getStreamReaderNumber :: StreamReader -> IO Int +getStreamReaderNumber (StreamReader stream) = return $ rsrNum stream + +data StreamWriter = StreamWriter (MVar StreamWriterData) + +data StreamWriterData = StreamWriterData + { swdStream :: RawStreamWriter + , swdSequence :: Maybe Word64 + } + +getStreamWriterNumber :: StreamWriter -> IO Int +getStreamWriterNumber (StreamWriter stream) = rswNum . swdStream <$> readMVar stream + + +openStream :: Service s => ServiceHandler s StreamWriter +openStream = do + mvar <- liftIO newEmptyMVar + tell [ ServiceOpenStream $ \stream -> putMVar mvar $ StreamWriterData stream (Just 0) ] + return $ StreamWriter mvar + +receivedStreams :: Service s => ServiceHandler s [ StreamReader ] +receivedStreams = do + map StreamReader <$> asks svcNewStreams + +readStreamPacket :: StreamReader -> IO StreamPacket +readStreamPacket (StreamReader stream) = do + readFlowIO (rsrFlow stream) + +writeStreamPacket :: StreamWriter -> StreamPacket -> IO () +writeStreamPacket (StreamWriter mvar) packet = do + withMVar mvar $ \swd -> do + writeFlowIO (rswFlow $ swdStream swd) packet + +writeStream :: StreamWriter -> ByteString -> IO () +writeStream (StreamWriter mvar) bytes = do + modifyMVar_ mvar $ \swd -> do + case swdSequence swd of + Just seqNum -> do + writeFlowIO (rswFlow $ swdStream swd) $ StreamData seqNum bytes + return swd { swdSequence = Just (seqNum + 1) } + Nothing -> do + fail "writeStream: stream closed" + +closeStream :: StreamWriter -> IO () +closeStream (StreamWriter mvar) = do + withMVar mvar $ \swd -> do + case swdSequence swd of + Just seqNum -> writeFlowIO (rswFlow $ swdStream swd) $ StreamClosed seqNum + Nothing -> fail "closeStream: stream already closed" diff --git a/src/Erebos/Set.hs b/src/Erebos/Set.hs index c5edd56..270c0ba 100644 --- a/src/Erebos/Set.hs +++ b/src/Erebos/Set.hs @@ -19,7 +19,8 @@ import Data.Map qualified as M import Data.Maybe import Data.Ord -import Erebos.Storage +import Erebos.Object +import Erebos.Storable import Erebos.Storage.Merge import Erebos.Util diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs index 324127a..076a8c0 100644 --- a/src/Erebos/State.hs +++ b/src/Erebos/State.hs @@ -1,13 +1,13 @@ module Erebos.State ( LocalState(..), - SharedState, SharedType(..), + SharedState(..), SharedType(..), SharedTypeID, mkSharedTypeID, + MonadStorage(..), MonadHead(..), updateLocalHead_, - loadLocalStateHead, - + updateLocalState, updateLocalState_, updateSharedState, updateSharedState_, lookupSharedValue, makeSharedStateUpdate, @@ -15,31 +15,29 @@ module Erebos.State ( headLocalIdentity, mergeSharedIdentity, - updateSharedIdentity, - interactiveIdentityUpdate, ) where import Control.Monad.Except import Control.Monad.Reader -import Data.Foldable -import Data.Maybe -import qualified Data.Text as T -import qualified Data.Text.IO as T +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BC import Data.Typeable -import Data.UUID (UUID) -import qualified Data.UUID as U - -import System.IO import Erebos.Identity +import Erebos.Object import Erebos.PubKey -import Erebos.Storage +import Erebos.Storable +import Erebos.Storage.Head import Erebos.Storage.Merge +import Erebos.UUID (UUID) +import Erebos.UUID qualified as U data LocalState = LocalState - { lsIdentity :: Stored (Signed ExtendedIdentityData) + { lsPrev :: Maybe RefDigest + , lsIdentity :: Stored (Signed ExtendedIdentityData) , lsShared :: [Stored SharedState] + , lsOther :: [ ( ByteString, RecItem ) ] } data SharedState = SharedState @@ -58,13 +56,18 @@ class Mergeable a => SharedType a where sharedTypeID :: proxy a -> SharedTypeID instance Storable LocalState where - store' st = storeRec $ do - storeRef "id" $ lsIdentity st - mapM_ (storeRef "shared") $ lsShared st - - load' = loadRec $ LocalState - <$> loadRef "id" - <*> loadRefs "shared" + store' LocalState {..} = storeRec $ do + mapM_ (storeRawWeak "PREV") lsPrev + storeRef "id" lsIdentity + mapM_ (storeRef "shared") lsShared + storeRecItems lsOther + + load' = loadRec $ do + lsPrev <- loadMbRawWeak "PREV" + lsIdentity <- loadRef "id" + lsShared <- loadRefs "shared" + lsOther <- filter ((`notElem` [ BC.pack "id", BC.pack "shared" ]) . fst) <$> loadRecItems + return LocalState {..} instance HeadType LocalState where headTypeID _ = mkHeadTypeID "1d7491a9-7bcb-4eaa-8f13-c8c4c4087e4e" @@ -98,34 +101,6 @@ instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where snd <$> updateHead h f -loadLocalStateHead :: MonadIO m => Storage -> m (Head LocalState) -loadLocalStateHead st = loadHeads st >>= \case - (h:_) -> return h - [] -> liftIO $ do - putStr "Name: " - hFlush stdout - name <- T.getLine - - putStr "Device: " - hFlush stdout - devName <- T.getLine - - owner <- if - | T.null name -> return Nothing - | otherwise -> Just <$> createIdentity st (Just name) Nothing - - identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner - - shared <- wrappedStore st $ SharedState - { ssPrev = [] - , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy - , ssValue = [storedRef $ idExtData $ fromMaybe identity owner] - } - storeHead st $ LocalState - { lsIdentity = idExtData identity - , lsShared = [shared] - } - localIdentity :: LocalState -> UnifiedIdentity localIdentity ls = maybe (error "failed to verify local identity") (updateOwners $ maybe [] idExtDataF $ lookupSharedValue $ lsShared ls) @@ -135,6 +110,17 @@ headLocalIdentity :: Head LocalState -> UnifiedIdentity headLocalIdentity = localIdentity . headObject +updateLocalState :: forall m b. MonadHead LocalState m => (Stored LocalState -> m ( Stored LocalState, b )) -> m b +updateLocalState f = updateLocalHead $ \ls -> do + ( ls', x ) <- f ls + (, x) <$> if ls' == ls + then return ls' + else mstore (fromStored ls') { lsPrev = Just $ refDigest (storedRef ls) } + +updateLocalState_ :: forall m. MonadHead LocalState m => (Stored LocalState -> m (Stored LocalState)) -> m () +updateLocalState_ f = updateLocalState (fmap (,()) . f) + + updateSharedState_ :: forall a m. (SharedType a, MonadHead LocalState m) => (a -> m a) -> Stored LocalState -> m (Stored LocalState) updateSharedState_ f = fmap fst <$> updateSharedState (fmap (,()) . f) @@ -163,39 +149,9 @@ makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState } -mergeSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m UnifiedIdentity -mergeSharedIdentity = updateLocalHead $ updateSharedState $ \case +mergeSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => m UnifiedIdentity +mergeSharedIdentity = updateLocalState $ updateSharedState $ \case Just cidentity -> do identity <- mergeIdentity cidentity return (Just $ toComposedIdentity identity, identity) - Nothing -> throwError "no existing shared identity" - -updateSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m () -updateSharedIdentity = updateLocalHead_ $ updateSharedState_ $ \case - Just identity -> do - Just . toComposedIdentity <$> interactiveIdentityUpdate identity - Nothing -> throwError "no existing shared identity" - -interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError String m) => Identity f -> m UnifiedIdentity -interactiveIdentityUpdate identity = do - let public = idKeyIdentity identity - - name <- liftIO $ do - T.putStr $ T.concat $ concat - [ [ T.pack "Name" ] - , case idName identity of - Just name -> [T.pack " [", name, T.pack "]"] - Nothing -> [] - , [ T.pack ": " ] - ] - hFlush stdout - T.getLine - - if | T.null name -> mergeIdentity identity - | otherwise -> do - secret <- loadKey public - maybe (throwError "created invalid identity") return . validateIdentity =<< - mstore =<< sign secret =<< mstore (emptyIdentityData public) - { iddPrev = toList $ idDataF identity - , iddName = Just name - } + Nothing -> throwOtherError "no existing shared identity" diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs new file mode 100644 index 0000000..caaf525 --- /dev/null +++ b/src/Erebos/Storable.hs @@ -0,0 +1,44 @@ +{-| +Description: Encoding custom types into Erebos objects + +Module provides the 'Storable' class for types that can be serialized to/from +Erebos objects, along with various helpers, mostly for encoding using records. + +The 'Stored' wrapper for objects actually encoded and stored in some storage is +defined here as well. +-} + +module Erebos.Storable ( + Storable(..), ZeroStorable(..), + StorableText(..), StorableDate(..), StorableUUID(..), + + Store, StoreRec, + storeBlob, storeRec, storeZero, + storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, storeWeak, storeRawWeak, + storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, storeMbWeak, storeMbRawWeak, + storeZRef, storeZWeak, + storeRecItems, + + Load, LoadRec, + loadCurrentRef, loadCurrentObject, + loadRecCurrentRef, loadRecItems, + + loadBlob, loadRec, loadZero, + loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, loadRawWeak, + loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, loadMbRawWeak, + loadTexts, loadBinaries, loadRefs, loadRawRefs, loadRawWeaks, + loadZRef, + + Stored, + fromStored, storedRef, + wrappedStore, wrappedLoad, + copyStored, + unsafeMapStored, + + Storage, MonadStorage(..), + + module Erebos.Error, +) where + +import Erebos.Error +import Erebos.Object.Internal diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs index 2e6653a..f1cce84 100644 --- a/src/Erebos/Storage.hs +++ b/src/Erebos/Storage.hs @@ -1,1053 +1,29 @@ +{-| +Description: Working with storage and heads + +Provides functions for opening 'Storage' backed either by disk or memory. For +conveniance also function for working with 'Head's are reexported here. +-} + module Erebos.Storage ( - Storage, PartialStorage, StorageCompleteness, + Storage, PartialStorage, openStorage, memoryStorage, deriveEphemeralStorage, derivePartialStorage, - Ref, PartialRef, RefDigest, - refDigest, - readRef, showRef, showRefDigest, - refDigestFromByteString, hashToRefDigest, - copyRef, partialRef, partialRefFromDigest, - - Object, PartialObject, Object'(..), RecItem, RecItem'(..), - serializeObject, deserializeObject, deserializeObjects, - ioLoadObject, ioLoadBytes, - storeRawBytes, lazyLoadBytes, - storeObject, - collectObjects, collectStoredObjects, - - Head, HeadType(..), - HeadTypeID, mkHeadTypeID, + Head, HeadType, + HeadID, HeadTypeID, headId, headStorage, headRef, headObject, headStoredObject, loadHeads, loadHead, reloadHead, storeHead, replaceHead, updateHead, updateHead_, - loadHeadRaw, storeHeadRaw, replaceHeadRaw, WatchedHead, watchHead, watchHeadWith, unwatchHead, watchHeadRaw, MonadStorage(..), - - Storable(..), ZeroStorable(..), - StorableText(..), StorableDate(..), StorableUUID(..), - - Store, StoreRec, - evalStore, evalStoreObject, - storeBlob, storeRec, storeZero, - storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, - storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, - storeZRef, - - Load, LoadRec, - evalLoad, - loadCurrentRef, loadCurrentObject, - loadRecCurrentRef, loadRecItems, - - loadBlob, loadRec, loadZero, - loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, - loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, - loadTexts, loadBinaries, loadRefs, loadRawRefs, - loadZRef, - - Stored, - fromStored, storedRef, - wrappedStore, wrappedLoad, - copyStored, - unsafeMapStored, - - StoreInfo(..), makeStoreInfo, - - StoredHistory, - fromHistory, fromHistoryAt, storedFromHistory, storedHistoryList, - beginHistory, modifyHistory, ) where -import Control.Applicative -import Control.Concurrent -import Control.Exception -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.Writer - -import Crypto.Hash - -import Data.Bifunctor -import Data.ByteString (ByteString) -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC -import Data.Char -import Data.Function -import qualified Data.HashTable.IO as HT -import Data.List -import qualified Data.Map as M -import Data.Maybe -import Data.Ratio -import Data.Set (Set) -import qualified Data.Set as S -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding -import Data.Text.Encoding.Error -import Data.Time.Calendar -import Data.Time.Clock -import Data.Time.Format -import Data.Time.LocalTime -import Data.Typeable -import Data.UUID (UUID) -import qualified Data.UUID as U -import qualified Data.UUID.V4 as U - -import System.Directory -import System.FSNotify -import System.FilePath -import System.IO.Error -import System.IO.Unsafe - -import Erebos.Storage.Internal - - -type Storage = Storage' Complete -type PartialStorage = Storage' Partial - -storageVersion :: String -storageVersion = "0.1" - -openStorage :: FilePath -> IO Storage -openStorage path = modifyIOError annotate $ do - let versionFileName = "erebos-storage" - let versionPath = path </> versionFileName - let writeVersionFile = writeFile versionPath $ storageVersion <> "\n" - - doesDirectoryExist path >>= \case - True -> do - listDirectory path >>= \case - files@(_:_) - | versionFileName `elem` files -> do - readFile versionPath >>= \case - content | (ver:_) <- lines content, ver == storageVersion -> return () - | otherwise -> fail "unsupported storage version" - - | "objects" `notElem` files || "heads" `notElem` files -> do - fail "directory is neither empty, nor an existing erebos storage" - - _ -> writeVersionFile - False -> do - createDirectoryIfMissing True $ path - writeVersionFile - - createDirectoryIfMissing True $ path </> "objects" - createDirectoryIfMissing True $ path </> "heads" - watchers <- newMVar (Nothing, [], WatchList 1 []) - refgen <- newMVar =<< HT.new - refroots <- newMVar =<< HT.new - return $ Storage - { stBacking = StorageDir path watchers - , stParent = Nothing - , stRefGeneration = refgen - , stRefRoots = refroots - } - where - annotate e = annotateIOError e "failed to open storage" Nothing (Just path) - -memoryStorage' :: IO (Storage' c') -memoryStorage' = do - backing <- StorageMemory <$> newMVar [] <*> newMVar M.empty <*> newMVar M.empty <*> newMVar (WatchList 1 []) - refgen <- newMVar =<< HT.new - refroots <- newMVar =<< HT.new - return $ Storage - { stBacking = backing - , stParent = Nothing - , stRefGeneration = refgen - , stRefRoots = refroots - } - -memoryStorage :: IO Storage -memoryStorage = memoryStorage' - -deriveEphemeralStorage :: Storage -> IO Storage -deriveEphemeralStorage parent = do - st <- memoryStorage - return $ st { stParent = Just parent } - -derivePartialStorage :: Storage -> IO PartialStorage -derivePartialStorage parent = do - st <- memoryStorage' - return $ st { stParent = Just parent } - -type Ref = Ref' Complete -type PartialRef = Ref' Partial - -zeroRef :: Storage' c -> Ref' c -zeroRef s = Ref s (RefDigest h) - where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of - Nothing -> error $ "Failed to create zero hash" - Just h' -> h' - digestAlgo :: Digest a -> a - digestAlgo = undefined - -isZeroRef :: Ref' c -> Bool -isZeroRef (Ref _ h) = all (==0) $ BA.unpack h - - -refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c)) -refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst - -readRef :: Storage -> ByteString -> IO (Maybe Ref) -readRef s b = - case readRefDigest b of - Nothing -> return Nothing - Just dgst -> refFromDigest s dgst - -copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c')) -copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref - Nothing -> doCopy - where doCopy = do mbobj' <- ioLoadObject ref' - mbobj <- sequence $ copyObject' st <$> mbobj' - sequence $ unsafeStoreObject st <$> join mbobj - -copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c')) -copyObject' _ (Blob bs) = return $ return $ Blob bs -copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM copyItem rs - where copyItem :: (ByteString, RecItem' c) -> IO (c (ByteString, RecItem' c')) - copyItem (n, item) = fmap (n,) <$> case item of - RecEmpty -> return $ return $ RecEmpty - RecInt x -> return $ return $ RecInt x - RecNum x -> return $ return $ RecNum x - RecText x -> return $ return $ RecText x - RecBinary x -> return $ return $ RecBinary x - RecDate x -> return $ return $ RecDate x - RecUUID x -> return $ return $ RecUUID x - RecRef x -> fmap RecRef <$> copyRef' st x -copyObject' _ ZeroObject = return $ return ZeroObject - -copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c')) -copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref' - -copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c')) -copyObject st obj' = returnLoadResult <$> copyObject' st obj' - -partialRef :: PartialStorage -> Ref -> PartialRef -partialRef st (Ref _ dgst) = Ref st dgst - -partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef -partialRefFromDigest st dgst = Ref st dgst - - -data Object' c - = Blob ByteString - | Rec [(ByteString, RecItem' c)] - | ZeroObject - deriving (Show) - -type Object = Object' Complete -type PartialObject = Object' Partial - -data RecItem' c - = RecEmpty - | RecInt Integer - | RecNum Rational - | RecText Text - | RecBinary ByteString - | RecDate ZonedTime - | RecUUID UUID - | RecRef (Ref' c) - deriving (Show) - -type RecItem = RecItem' Complete - -serializeObject :: Object' c -> BL.ByteString -serializeObject = \case - Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] - Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec - in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt - ZeroObject -> BL.empty - --- |Serializes and stores object data without ony dependencies, so is safe only --- if all the referenced objects are already stored or reference is partial. -unsafeStoreObject :: Storage' c -> Object' c -> IO (Ref' c) -unsafeStoreObject storage = \case - ZeroObject -> return $ zeroRef storage - obj -> unsafeStoreRawBytes storage $ serializeObject obj - -storeObject :: PartialStorage -> PartialObject -> IO PartialRef -storeObject = unsafeStoreObject - -storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef -storeRawBytes = unsafeStoreRawBytes - -serializeRecItem :: ByteString -> RecItem' c -> [ByteString] -serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n'] -serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n'] -serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n'] -serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n'] - where escaped = BC.concatMap escape $ encodeUtf8 x - escape '\n' = BC.pack "\n\t" - escape c = BC.singleton c -serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex x, BC.singleton '\n'] -serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n'] -serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n'] -serializeRecItem name (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n'] - -lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c) -lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject - -ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c)) -ioLoadObject ref | isZeroRef ref = return $ return ZeroObject -ioLoadObject ref@(Ref st rhash) = do - file' <- ioLoadBytes ref - return $ do - file <- file' - let chash = hashToRefDigest file - when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -} - return $ case runExcept $ unsafeDeserializeObject st file of - Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -} - Right (x, rest) | BL.null rest -> x - | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -} - -lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString -lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString) -lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref - -unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except String (Object' c, BL.ByteString) -unsafeDeserializeObject _ bytes | BL.null bytes = return (ZeroObject, bytes) -unsafeDeserializeObject st bytes = - case BLC.break (=='\n') bytes of - (line, rest) | Just (otype, len) <- splitObjPrefix line -> do - let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest - guard $ B.length content == len - (,next) <$> case otype of - _ | otype == BC.pack "blob" -> return $ Blob content - | otype == BC.pack "rec" -> maybe (throwError $ "Malformed record item ") - (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content - | otherwise -> throwError $ "Unknown object type" - _ -> throwError $ "Malformed object" - where splitObjPrefix line = do - [otype, tlen] <- return $ BLC.words line - (len, rest) <- BLC.readInt tlen - guard $ BL.null rest - return (BL.toStrict otype, len) - - mergeCont cs (a:b:rest) | Just ('\t', b') <- BC.uncons b = mergeCont (b':BC.pack "\n":cs) (a:rest) - mergeCont cs (a:rest) = B.concat (a : reverse cs) : mergeCont [] rest - mergeCont _ [] = [] - - parseRecLine line = do - colon <- BC.elemIndex ':' line - space <- BC.elemIndex ' ' line - guard $ colon < space - let name = B.take colon line - itype = B.take (space-colon-1) $ B.drop (colon+1) line - content = B.drop (space+1) line - - val <- case BC.unpack itype of - "e" -> do guard $ B.null content - return RecEmpty - "i" -> do (num, rest) <- BC.readInteger content - guard $ B.null rest - return $ RecInt num - "n" -> RecNum <$> parseRatio content - "t" -> return $ RecText $ decodeUtf8With lenientDecode content - "b" -> RecBinary <$> readHex content - "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content) - "u" -> RecUUID <$> U.fromASCIIBytes content - "r" -> RecRef . Ref st <$> readRefDigest content - _ -> Nothing - return (name, val) - -deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString) -deserializeObject = unsafeDeserializeObject - -deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject] -deserializeObjects _ bytes | BL.null bytes = return [] -deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes - (obj:) <$> deserializeObjects st rest - - -collectObjects :: Object -> [Object] -collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj) - -collectStoredObjects :: Stored Object -> [Stored Object] -collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj) - -collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest) -collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items - where helper (RecRef ref) (xs, s) | r <- refDigest ref - , r `S.notMember` s - = let o = wrappedLoad ref - (xs', s') = collectOtherStored (S.insert r s) $ fromStored o - in ((o : xs') ++ xs, s') - helper _ (xs, s) = (xs, s) -collectOtherStored seen _ = ([], seen) - - -type Head = Head' Complete - -headId :: Head a -> HeadID -headId (Head uuid _) = uuid - -headStorage :: Head a -> Storage -headStorage = refStorage . headRef - -headRef :: Head a -> Ref -headRef (Head _ sx) = storedRef sx - -headObject :: Head a -> a -headObject (Head _ sx) = fromStored sx - -headStoredObject :: Head a -> Stored a -headStoredObject (Head _ sx) = sx - -deriving instance StorableUUID HeadID -deriving instance StorableUUID HeadTypeID - -mkHeadTypeID :: String -> HeadTypeID -mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString - -class Storable a => HeadType a where - headTypeID :: proxy a -> HeadTypeID - - -headTypePath :: FilePath -> HeadTypeID -> FilePath -headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid - -headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath -headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid - -loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a] -loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do - let hpath = headTypePath spath $ headTypeID @a Proxy - - files <- filterM (doesFileExist . (hpath </>)) =<< - handleJust (\e -> guard (isDoesNotExistError e)) (const $ return []) - (getDirectoryContents hpath) - fmap catMaybes $ forM files $ \hname -> do - case U.fromString hname of - Just hid -> do - (h:_) <- BC.lines <$> B.readFile (hpath </> hname) - Just ref <- readRef s h - return $ Just $ Head (HeadID hid) $ wrappedLoad ref - Nothing -> return Nothing -loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do - let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref - | otherwise = Nothing - catMaybes . map toHead <$> readMVar theads - -loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a)) -loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid - -loadHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> m (Maybe Ref) -loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do - handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do - (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid) - Just ref <- readRef s h - return $ Just ref -loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do - lookup (tid, hid) <$> readMVar theads - -reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) -reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid - -storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a) -storeHead st obj = do - let tid = headTypeID @a Proxy - stored <- wrappedStore st obj - hid <- storeHeadRaw st tid (storedRef stored) - return $ Head hid stored - -storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID -storeHeadRaw st tid ref = liftIO $ do - hid <- HeadID <$> U.nextRandom - case stBacking st of - StorageDir { dirPath = spath } -> do - Right () <- writeFileChecked (headPath spath tid hid) Nothing $ - showRef ref `B.append` BC.singleton '\n' - return () - StorageMemory { memHeads = theads } -> do - modifyMVar_ theads $ return . (((tid, hid), ref) :) - return hid - -replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a)) -replaceHead prev@(Head hid pobj) stored' = liftIO $ do - let st = headStorage prev - tid = headTypeID @a Proxy - stored <- copyStored st stored' - bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$> - replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored) - -replaceHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> Ref -> Ref -> m (Either (Maybe Ref) Ref) -replaceHeadRaw st tid hid prev new = liftIO $ do - case stBacking st of - StorageDir { dirPath = spath } -> do - let filename = headPath spath tid hid - showRefL r = showRef r `B.append` BC.singleton '\n' - - writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case - Left Nothing -> return $ Left Nothing - Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs - return $ Left $ Just oref - Right () -> return $ Right new - - StorageMemory { memHeads = theads, memWatchers = twatch } -> do - res <- modifyMVar theads $ \hs -> do - ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch - return $ case partition ((==(tid, hid)) . fst) hs of - ([] , _ ) -> (hs, Left Nothing) - ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs', - Right (new, ws)) - | otherwise -> (hs, Left $ Just r) - case res of - Right (r, ws) -> mapM_ ($ r) ws >> return (Right r) - Left x -> return $ Left x - -updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b) -updateHead h f = do - (o, x) <- f $ headStoredObject h - replaceHead h o >>= \case - Right h' -> return (Just h', x) - Left Nothing -> return (Nothing, x) - Left (Just h') -> updateHead h' f - -updateHead_ :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a)) -> m (Maybe (Head a)) -updateHead_ h = fmap fst . updateHead h . (fmap (,()) .) - - -data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a) - -watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead -watchHead h = watchHeadWith h id - -watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead -watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do - watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb - -watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead -watchHeadRaw st tid hid sel cb = do - memo <- newEmptyMVar - let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo) - where wl' = wl { wlNext = wlNext wl + 1 - , wlList = WatchListItem - { wlID = wlNext wl - , wlHead = (tid, hid) - , wlFun = \r -> do - let x = sel r - modifyMVar_ memo $ \prev -> do - when (Just x /= prev) $ cb x - return $ Just x - } : wlList wl - } - - watched <- case stBacking st of - StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do - manager <- maybe startManager return mbmanager - ilist' <- case tid `elem` ilist of - True -> return ilist - False -> do - void $ watchDir manager (headTypePath spath tid) (const True) $ \case - Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do - loadHeadRaw st tid ihid >>= \case - Just ref -> do - (_, _, iwl) <- readMVar mvar - mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl - Nothing -> return () - _ -> return () - return $ tid : ilist - return $ first ( Just manager, ilist', ) $ addWatcher wl - - StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher - - cur <- fmap sel <$> loadHeadRaw st tid hid - maybe (return ()) cb cur - putMVar memo cur - - return watched - -unwatchHead :: WatchedHead -> IO () -unwatchHead (WatchedHead st wid _) = do - let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl } - case stBacking st of - StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher - StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . delWatcher - - -class Monad m => MonadStorage m where - getStorage :: m Storage - mstore :: Storable a => a -> m (Stored a) - - default mstore :: MonadIO m => Storable a => a -> m (Stored a) - mstore x = do - st <- getStorage - wrappedStore st x - -instance MonadIO m => MonadStorage (ReaderT Storage m) where - getStorage = ask - -instance MonadIO m => MonadStorage (ReaderT (Head a) m) where - getStorage = asks $ headStorage - - -class Storable a where - store' :: a -> Store - load' :: Load a - - store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c) - store st = evalStore st . store' - load :: Ref -> a - load = evalLoad load' - -class Storable a => ZeroStorable a where - fromZero :: Storage -> a - -data Store = StoreBlob ByteString - | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]]) - | StoreZero - -evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c) -evalStore st = unsafeStoreObject st <=< evalStoreObject st - -evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c) -evalStoreObject _ (StoreBlob x) = return $ Blob x -evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s) -evalStoreObject _ StoreZero = return ZeroObject - -newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a) - deriving (Functor, Applicative, Monad) - -type StoreRec c = StoreRecM c () - -newtype Load a = Load (ReaderT (Ref, Object) (Except String) a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) - -evalLoad :: Load a -> Ref -> a -evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ")++)) id $ runExcept $ runReaderT f (ref, lazyLoadObject ref) - -loadCurrentRef :: Load Ref -loadCurrentRef = Load $ asks fst - -loadCurrentObject :: Load Object -loadCurrentObject = Load $ asks snd - -newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) - -loadRecCurrentRef :: LoadRec Ref -loadRecCurrentRef = LoadRec $ asks fst - -loadRecItems :: LoadRec [(ByteString, RecItem)] -loadRecItems = LoadRec $ asks snd - - -instance Storable Object where - store' (Blob bs) = StoreBlob bs - store' (Rec xs) = StoreRec $ \st -> return $ do - Rec xs' <- copyObject st (Rec xs) - return xs' - store' ZeroObject = StoreZero - - load' = loadCurrentObject - - store st = unsafeStoreObject st <=< copyObject st - load = lazyLoadObject - -instance Storable ByteString where - store' = storeBlob - load' = loadBlob id - -instance Storable a => Storable [a] where - store' [] = storeZero - store' (x:xs) = storeRec $ do - storeRef "i" x - storeRef "n" xs - - load' = loadCurrentObject >>= \case - ZeroObject -> return [] - _ -> loadRec $ (:) - <$> loadRef "i" - <*> loadRef "n" - -instance Storable a => ZeroStorable [a] where - fromZero _ = [] - - -storeBlob :: ByteString -> Store -storeBlob = StoreBlob - -storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store -storeRec sr = StoreRec $ do - let StoreRecM r = sr - execWriter . runReaderT r - -storeZero :: Store -storeZero = StoreZero - - -class StorableText a where - toText :: a -> Text - fromText :: MonadError String m => Text -> m a - -instance StorableText Text where - toText = id; fromText = return - -instance StorableText [Char] where - toText = T.pack; fromText = return . T.unpack - - -class StorableDate a where - toDate :: a -> ZonedTime - fromDate :: ZonedTime -> a - -instance StorableDate ZonedTime where - toDate = id; fromDate = id - -instance StorableDate UTCTime where - toDate = utcToZonedTime utc - fromDate = zonedTimeToUTC - -instance StorableDate Day where - toDate day = toDate $ UTCTime day 0 - fromDate = utctDay . fromDate - - -class StorableUUID a where - toUUID :: a -> UUID - fromUUID :: UUID -> a - -instance StorableUUID UUID where - toUUID = id; fromUUID = id - - -storeEmpty :: String -> StoreRec c -storeEmpty name = StoreRecM $ tell [return [(BC.pack name, RecEmpty)]] - -storeMbEmpty :: String -> Maybe () -> StoreRec c -storeMbEmpty name = maybe (return ()) (const $ storeEmpty name) - -storeInt :: Integral a => String -> a -> StoreRec c -storeInt name x = StoreRecM $ tell [return [(BC.pack name, RecInt $ toInteger x)]] - -storeMbInt :: Integral a => String -> Maybe a -> StoreRec c -storeMbInt name = maybe (return ()) (storeInt name) - -storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c -storeNum name x = StoreRecM $ tell [return [(BC.pack name, RecNum $ toRational x)]] - -storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c -storeMbNum name = maybe (return ()) (storeNum name) - -storeText :: StorableText a => String -> a -> StoreRec c -storeText name x = StoreRecM $ tell [return [(BC.pack name, RecText $ toText x)]] - -storeMbText :: StorableText a => String -> Maybe a -> StoreRec c -storeMbText name = maybe (return ()) (storeText name) - -storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c -storeBinary name x = StoreRecM $ tell [return [(BC.pack name, RecBinary $ BA.convert x)]] - -storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c -storeMbBinary name = maybe (return ()) (storeBinary name) - -storeDate :: StorableDate a => String -> a -> StoreRec c -storeDate name x = StoreRecM $ tell [return [(BC.pack name, RecDate $ toDate x)]] - -storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c -storeMbDate name = maybe (return ()) (storeDate name) - -storeUUID :: StorableUUID a => String -> a -> StoreRec c -storeUUID name x = StoreRecM $ tell [return [(BC.pack name, RecUUID $ toUUID x)]] - -storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c -storeMbUUID name = maybe (return ()) (storeUUID name) - -storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c -storeRef name x = StoreRecM $ do - s <- ask - tell $ (:[]) $ do - ref <- store s x - return [(BC.pack name, RecRef ref)] - -storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c -storeMbRef name = maybe (return ()) (storeRef name) - -storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c -storeRawRef name ref = StoreRecM $ do - st <- ask - tell $ (:[]) $ do - ref' <- copyRef st ref - return [(BC.pack name, RecRef ref')] - -storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c -storeMbRawRef name = maybe (return ()) (storeRawRef name) - -storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c -storeZRef name x = StoreRecM $ do - s <- ask - tell $ (:[]) $ do - ref <- store s x - return $ if isZeroRef ref then [] - else [(BC.pack name, RecRef ref)] - - -loadBlob :: (ByteString -> a) -> Load a -loadBlob f = loadCurrentObject >>= \case - Blob x -> return $ f x - _ -> throwError "Expecting blob" - -loadRec :: LoadRec a -> Load a -loadRec (LoadRec lrec) = loadCurrentObject >>= \case - Rec rs -> do - ref <- loadCurrentRef - either throwError return $ runExcept $ runReaderT lrec (ref, rs) - _ -> throwError "Expecting record" - -loadZero :: a -> Load a -loadZero x = loadCurrentObject >>= \case - ZeroObject -> return x - _ -> throwError "Expecting zero" - - -loadEmpty :: String -> LoadRec () -loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name - -loadMbEmpty :: String -> LoadRec (Maybe ()) -loadMbEmpty name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecEmpty) -> return (Just ()) - Just _ -> throwError $ "Expecting type int of record item '"++name++"'" - -loadInt :: Num a => String -> LoadRec a -loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name - -loadMbInt :: Num a => String -> LoadRec (Maybe a) -loadMbInt name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecInt x) -> return (Just $ fromInteger x) - Just _ -> throwError $ "Expecting type int of record item '"++name++"'" - -loadNum :: (Real a, Fractional a) => String -> LoadRec a -loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name - -loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a) -loadMbNum name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecNum x) -> return (Just $ fromRational x) - Just _ -> throwError $ "Expecting type number of record item '"++name++"'" - -loadText :: StorableText a => String -> LoadRec a -loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name - -loadMbText :: StorableText a => String -> LoadRec (Maybe a) -loadMbText name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecText x) -> Just <$> fromText x - Just _ -> throwError $ "Expecting type text of record item '"++name++"'" - -loadTexts :: StorableText a => String -> LoadRec [a] -loadTexts name = do - items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems - forM items $ \case RecText x -> fromText x - _ -> throwError $ "Expecting type text of record item '"++name++"'" - -loadBinary :: BA.ByteArray a => String -> LoadRec a -loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name - -loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a) -loadMbBinary name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecBinary x) -> return $ Just $ BA.convert x - Just _ -> throwError $ "Expecting type binary of record item '"++name++"'" - -loadBinaries :: BA.ByteArray a => String -> LoadRec [a] -loadBinaries name = do - items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems - forM items $ \case RecBinary x -> return $ BA.convert x - _ -> throwError $ "Expecting type binary of record item '"++name++"'" - -loadDate :: StorableDate a => String -> LoadRec a -loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name - -loadMbDate :: StorableDate a => String -> LoadRec (Maybe a) -loadMbDate name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecDate x) -> return $ Just $ fromDate x - Just _ -> throwError $ "Expecting type date of record item '"++name++"'" - -loadUUID :: StorableUUID a => String -> LoadRec a -loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name - -loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a) -loadMbUUID name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecUUID x) -> return $ Just $ fromUUID x - Just _ -> throwError $ "Expecting type UUID of record item '"++name++"'" - -loadRawRef :: String -> LoadRec Ref -loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name - -loadMbRawRef :: String -> LoadRec (Maybe Ref) -loadMbRawRef name = (lookup (BC.pack name) <$> loadRecItems) >>= \case - Nothing -> return Nothing - Just (RecRef x) -> return (Just x) - Just _ -> throwError $ "Expecting type ref of record item '"++name++"'" - -loadRawRefs :: String -> LoadRec [Ref] -loadRawRefs name = do - items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems - forM items $ \case RecRef x -> return x - _ -> throwError $ "Expecting type ref of record item '"++name++"'" - -loadRef :: Storable a => String -> LoadRec a -loadRef name = load <$> loadRawRef name - -loadMbRef :: Storable a => String -> LoadRec (Maybe a) -loadMbRef name = fmap load <$> loadMbRawRef name - -loadRefs :: Storable a => String -> LoadRec [a] -loadRefs name = map load <$> loadRawRefs name - -loadZRef :: ZeroStorable a => String -> LoadRec a -loadZRef name = loadMbRef name >>= \case - Nothing -> do Ref st _ <- loadRecCurrentRef - return $ fromZero st - Just x -> return x - - -type Stored a = Stored' Complete a - -instance Storable a => Storable (Stored a) where - store st = copyRef st . storedRef - store' (Stored _ x) = store' x - load' = Stored <$> loadCurrentRef <*> load' - -instance ZeroStorable a => ZeroStorable (Stored a) where - fromZero st = Stored (zeroRef st) $ fromZero st - -fromStored :: Stored a -> a -fromStored (Stored _ x) = x - -storedRef :: Stored a -> Ref -storedRef (Stored ref _) = ref - -wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a) -wrappedStore st x = do ref <- liftIO $ store st x - return $ Stored ref x - -wrappedLoad :: Storable a => Ref -> Stored a -wrappedLoad ref = Stored ref (load ref) - -copyStored :: forall c c' m a. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => - Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a)) -copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (flip Stored x) <$> copyRef' st ref' - --- |Passed function needs to preserve the object representation to be safe -unsafeMapStored :: (a -> b) -> Stored a -> Stored b -unsafeMapStored f (Stored ref x) = Stored ref (f x) - - -data StoreInfo = StoreInfo - { infoDate :: ZonedTime - , infoNote :: Maybe Text - } - deriving (Show) - -makeStoreInfo :: IO StoreInfo -makeStoreInfo = StoreInfo - <$> getZonedTime - <*> pure Nothing - -storeInfoRec :: StoreInfo -> StoreRec c -storeInfoRec info = do - storeDate "date" $ infoDate info - storeMbText "note" $ infoNote info - -loadInfoRec :: LoadRec StoreInfo -loadInfoRec = StoreInfo - <$> loadDate "date" - <*> loadMbText "note" - - -data History a = History StoreInfo (Stored a) (Maybe (StoredHistory a)) - deriving (Show) - -type StoredHistory a = Stored (History a) - -instance Storable a => Storable (History a) where - store' (History si x prev) = storeRec $ do - storeInfoRec si - storeMbRef "prev" prev - storeRef "item" x - - load' = loadRec $ History - <$> loadInfoRec - <*> loadRef "item" - <*> loadMbRef "prev" - -fromHistory :: StoredHistory a -> a -fromHistory = fromStored . storedFromHistory - -fromHistoryAt :: ZonedTime -> StoredHistory a -> Maybe a -fromHistoryAt zat = fmap (fromStored . snd) . listToMaybe . dropWhile ((at<) . zonedTimeToUTC . fst) . storedHistoryTimedList - where at = zonedTimeToUTC zat - -storedFromHistory :: StoredHistory a -> Stored a -storedFromHistory sh = let History _ item _ = fromStored sh - in item - -storedHistoryList :: StoredHistory a -> [Stored a] -storedHistoryList = map snd . storedHistoryTimedList - -storedHistoryTimedList :: StoredHistory a -> [(ZonedTime, Stored a)] -storedHistoryTimedList sh = let History hinfo item prev = fromStored sh - in (infoDate hinfo, item) : maybe [] storedHistoryTimedList prev - -beginHistory :: Storable a => Storage -> StoreInfo -> a -> IO (StoredHistory a) -beginHistory st si x = do sx <- wrappedStore st x - wrappedStore st $ History si sx Nothing - -modifyHistory :: Storable a => StoreInfo -> (a -> a) -> StoredHistory a -> IO (StoredHistory a) -modifyHistory si f prev@(Stored (Ref st _) _) = do - sx <- wrappedStore st $ f $ fromHistory prev - wrappedStore st $ History si sx (Just prev) - - -showRatio :: Rational -> String -showRatio r = case decimalRatio r of - Just (n, 1) -> show n - Just (n', d) -> let n = abs n' - in (if n' < 0 then "-" else "") ++ show (n `div` d) ++ "." ++ - (concatMap (show.(`mod` 10).snd) $ reverse $ takeWhile ((>1).fst) $ zip (iterate (`div` 10) d) (iterate (`div` 10) (n `mod` d))) - Nothing -> show (numerator r) ++ "/" ++ show (denominator r) - -decimalRatio :: Rational -> Maybe (Integer, Integer) -decimalRatio r = do - let n = numerator r - d = denominator r - (c2, d') = takeFactors 2 d - (c5, d'') = takeFactors 5 d' - guard $ d'' == 1 - let m = if c2 > c5 then 5 ^ (c2 - c5) - else 2 ^ (c5 - c2) - return (n * m, d * m) - -takeFactors :: Integer -> Integer -> (Integer, Integer) -takeFactors f n | n `mod` f == 0 = let (c, n') = takeFactors f (n `div` f) - in (c+1, n') - | otherwise = (0, n) - -parseRatio :: ByteString -> Maybe Rational -parseRatio bs = case BC.groupBy ((==) `on` isNumber) bs of - (m:xs) | m == BC.pack "-" -> negate <$> positive xs - xs -> positive xs - where positive = \case - [bx] -> fromInteger . fst <$> BC.readInteger bx - [bx, op, by] -> do - (x, _) <- BC.readInteger bx - (y, _) <- BC.readInteger by - case BC.unpack op of - "." -> return $ (x % 1) + (y % (10 ^ BC.length by)) - "/" -> return $ x % y - _ -> Nothing - _ -> Nothing +import Erebos.Object.Internal +import Erebos.Storage.Disk +import Erebos.Storage.Head +import Erebos.Storage.Memory diff --git a/src/Erebos/Storage/Backend.hs b/src/Erebos/Storage/Backend.hs new file mode 100644 index 0000000..620d423 --- /dev/null +++ b/src/Erebos/Storage/Backend.hs @@ -0,0 +1,28 @@ +{-| +Description: Implement custom storage backend + +Exports type class, which can be used to create custom 'Storage' backend. +-} + +module Erebos.Storage.Backend ( + StorageBackend(..), + Complete, Partial, + Storage, PartialStorage, + newStorage, + + WatchID, startWatchID, nextWatchID, +) where + +import Control.Concurrent.MVar + +import Data.HashTable.IO qualified as HT + +import Erebos.Object.Internal +import Erebos.Storage.Internal + + +newStorage :: StorageBackend bck => bck -> IO (Storage' (BackendCompleteness bck)) +newStorage stBackend = do + stRefGeneration <- newMVar =<< HT.new + stRefRoots <- newMVar =<< HT.new + return Storage {..} diff --git a/src/Erebos/Storage/Disk.hs b/src/Erebos/Storage/Disk.hs new file mode 100644 index 0000000..8e35940 --- /dev/null +++ b/src/Erebos/Storage/Disk.hs @@ -0,0 +1,230 @@ +module Erebos.Storage.Disk ( + openStorage, +) where + +import Codec.Compression.Zlib + +import Control.Arrow +import Control.Concurrent +import Control.Exception +import Control.Monad + +import Data.ByteArray qualified as BA +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.ByteString.Char8 qualified as BC +import Data.ByteString.Lazy qualified as BL +import Data.ByteString.Lazy.Char8 qualified as BLC +import Data.Function +import Data.List +import Data.Maybe + +import System.Directory +import System.FSNotify +import System.FilePath +import System.IO +import System.IO.Error + +import Erebos.Object +import Erebos.Storage.Backend +import Erebos.Storage.Head +import Erebos.Storage.Internal +import Erebos.Storage.Platform +import Erebos.UUID qualified as U + + +data DiskStorage = StorageDir + { dirPath :: FilePath + , dirWatchers :: MVar ( Maybe WatchManager, [ HeadTypeID ], WatchList ) + } + +instance Eq DiskStorage where + (==) = (==) `on` dirPath + +instance Show DiskStorage where + show StorageDir { dirPath = path } = "dir:" ++ path + +instance StorageBackend DiskStorage where + backendLoadBytes StorageDir {..} dgst = + handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ + Just . decompress . BL.fromChunks . (:[]) <$> (B.readFile $ refPath dirPath dgst) + backendStoreBytes StorageDir {..} dgst = writeFileOnce (refPath dirPath dgst) . compress + + + backendLoadHeads StorageDir {..} tid = do + let hpath = headTypePath dirPath tid + + files <- filterM (doesFileExist . (hpath </>)) =<< + handleJust (\e -> guard (isDoesNotExistError e)) (const $ return []) + (getDirectoryContents hpath) + fmap catMaybes $ forM files $ \hname -> do + case U.fromString hname of + Just hid -> do + content <- B.readFile (hpath </> hname) + return $ do + (h : _) <- Just (BC.lines content) + dgst <- readRefDigest h + Just $ ( HeadID hid, dgst ) + Nothing -> return Nothing + + backendLoadHead StorageDir {..} tid hid = do + handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do + (h:_) <- BC.lines <$> B.readFile (headPath dirPath tid hid) + return $ readRefDigest h + + backendStoreHead StorageDir {..} tid hid dgst = do + Right () <- writeFileChecked (headPath dirPath tid hid) Nothing $ + showRefDigest dgst `B.append` BC.singleton '\n' + return () + + backendReplaceHead StorageDir {..} tid hid expected new = do + let filename = headPath dirPath tid hid + showDgstL r = showRefDigest r `B.append` BC.singleton '\n' + + writeFileChecked filename (Just $ showDgstL expected) (showDgstL new) >>= \case + Left Nothing -> return $ Left Nothing + Left (Just bs) -> do Just cur <- return $ readRefDigest $ BC.takeWhile (/='\n') bs + return $ Left $ Just cur + Right () -> return $ Right new + + backendWatchHead st@StorageDir {..} tid hid cb = do + modifyMVar dirWatchers $ \( mbmanager, ilist, wl ) -> do + manager <- maybe startManager return mbmanager + ilist' <- case tid `elem` ilist of + True -> return ilist + False -> do + void $ watchDir manager (headTypePath dirPath tid) (const True) $ \case + ev@Added {} | Just ihid <- HeadID <$> U.fromString (takeFileName (eventPath ev)) -> do + backendLoadHead st tid ihid >>= \case + Just dgst -> do + (_, _, iwl) <- readMVar dirWatchers + mapM_ ($ dgst) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl + Nothing -> return () + _ -> return () + return $ tid : ilist + return $ first ( Just manager, ilist', ) $ watchListAdd tid hid cb wl + + backendUnwatchHead StorageDir {..} wid = do + modifyMVar_ dirWatchers $ \( mbmanager, ilist, wl ) -> do + return ( mbmanager, ilist, watchListDel wid wl ) + + + backendListKeys StorageDir {..} = do + catMaybes . map (readRefDigest . BC.pack) <$> + listDirectory (keyDirPath dirPath) + + backendLoadKey StorageDir {..} dgst = do + tryIOError (BC.readFile (keyFilePath dirPath dgst)) >>= \case + Right kdata -> return $ Just $ BA.convert kdata + Left _ -> return Nothing + + backendStoreKey StorageDir {..} dgst key = do + writeFileOnce (keyFilePath dirPath dgst) (BL.fromStrict $ BA.convert key) + + backendRemoveKey StorageDir {..} dgst = do + void $ tryIOError (removeFile $ keyFilePath dirPath dgst) + + +storageVersion :: String +storageVersion = "0.1" + +openStorage :: FilePath -> IO Storage +openStorage path = modifyIOError annotate $ do + let versionFileName = "erebos-storage" + let versionPath = path </> versionFileName + let writeVersionFile = writeFileOnce versionPath $ BLC.pack $ storageVersion <> "\n" + + maybeVersion <- handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ + Just <$> readFile versionPath + version <- case maybeVersion of + Just versionContent -> do + return $ takeWhile (/= '\n') versionContent + + Nothing -> do + files <- handleJust (guard . isDoesNotExistError) (const $ return []) $ + listDirectory path + when (not $ or + [ null files + , versionFileName `elem` files + , (versionFileName ++ ".lock") `elem` files + , "objects" `elem` files && "heads" `elem` files + ]) $ do + fail "directory is neither empty, nor an existing erebos storage" + + createDirectoryIfMissing True $ path + writeVersionFile + takeWhile (/= '\n') <$> readFile versionPath + + when (version /= storageVersion) $ do + fail $ "unsupported storage version " <> version + + createDirectoryIfMissing True $ path </> "objects" + createDirectoryIfMissing True $ path </> "heads" + watchers <- newMVar ( Nothing, [], WatchList startWatchID [] ) + newStorage $ StorageDir path watchers + where + annotate e = annotateIOError e "failed to open storage" Nothing (Just path) + + +refPath :: FilePath -> RefDigest -> FilePath +refPath spath rdgst = intercalate "/" [ spath, "objects", BC.unpack alg, pref, rest ] + where (alg, dgst) = showRefDigestParts rdgst + (pref, rest) = splitAt 2 $ BC.unpack dgst + +headTypePath :: FilePath -> HeadTypeID -> FilePath +headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid + +headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath +headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid + +keyDirPath :: FilePath -> FilePath +keyDirPath sdir = sdir </> "keys" + +keyFilePath :: FilePath -> RefDigest -> FilePath +keyFilePath sdir dgst = keyDirPath sdir </> (BC.unpack $ showRefDigest dgst) + + +openLockFile :: FilePath -> IO Handle +openLockFile path = do + createDirectoryIfMissing True (takeDirectory path) + retry 10 $ createFileExclusive path + where + retry :: Int -> IO a -> IO a + retry 0 act = act + retry n act = catchJust (\e -> if isAlreadyExistsError e then Just () else Nothing) + act (\_ -> threadDelay (100 * 1000) >> retry (n - 1) act) + +writeFileOnce :: FilePath -> BL.ByteString -> IO () +writeFileOnce file content = bracket (openLockFile locked) + hClose $ \h -> do + doesFileExist file >>= \case + True -> removeFile locked + False -> do BL.hPut h content + hClose h + renameFile locked file + where locked = file ++ ".lock" + +writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ()) +writeFileChecked file prev content = bracket (openLockFile locked) + hClose $ \h -> do + (prev,) <$> doesFileExist file >>= \case + (Nothing, True) -> do + current <- B.readFile file + removeFile locked + return $ Left $ Just current + (Nothing, False) -> do B.hPut h content + hClose h + renameFile locked file + return $ Right () + (Just expected, True) -> do + current <- B.readFile file + if current == expected then do B.hPut h content + hClose h + renameFile locked file + return $ return () + else do removeFile locked + return $ Left $ Just current + (Just _, False) -> do + removeFile locked + return $ Left Nothing + where locked = file ++ ".lock" diff --git a/src/Erebos/Storage/Head.hs b/src/Erebos/Storage/Head.hs new file mode 100644 index 0000000..285902d --- /dev/null +++ b/src/Erebos/Storage/Head.hs @@ -0,0 +1,258 @@ +{-| +Description: Define, use and watch heads + +Provides data types and functions for reading, writing or watching `Head's. +Type class `HeadType' is used to define custom new `Head' types. +-} + +module Erebos.Storage.Head ( + -- * Head type and accessors + Head, HeadType(..), + HeadID, HeadTypeID, mkHeadTypeID, + headId, headStorage, headRef, headObject, headStoredObject, + + -- * Loading and storing heads + loadHeads, loadHead, reloadHead, + storeHead, replaceHead, updateHead, updateHead_, + loadHeadRaw, storeHeadRaw, replaceHeadRaw, + + -- * Watching heads + WatchedHead, + watchHead, watchHeadWith, unwatchHead, + watchHeadRaw, +) where + +import Control.Concurrent +import Control.Monad +import Control.Monad.Reader + +import Data.Bifunctor +import Data.Typeable + +import Erebos.Object +import Erebos.Storable +import Erebos.Storage.Backend +import Erebos.Storage.Internal +import Erebos.UUID qualified as U + + +-- | Represents loaded Erebos storage head, along with the object it pointed to +-- at the time it was loaded. +-- +-- Each possible head type has associated unique ID, represented as +-- `HeadTypeID'. For each type, there can be multiple individual heads in given +-- storage, each also identified by unique ID (`HeadID'). +data Head a = Head HeadID (Stored a) + deriving (Eq, Show) + +-- | Instances of this class can be used as objects pointed to by heads in +-- Erebos storage. Each such type must be `Storable' and have a unique ID. +-- +-- To create a custom head type, generate a new UUID and assign it to the type using +-- `mkHeadTypeID': +-- +-- > instance HeadType MyType where +-- > headTypeID _ = mkHeadTypeID "86e8033d-c476-4f81-9b7c-fd36b9144475" +class Storable a => HeadType a where + headTypeID :: proxy a -> HeadTypeID + -- ^ Get the ID of the given head type; must be unique for each `HeadType' instance. + +instance MonadIO m => MonadStorage (ReaderT (Head a) m) where + getStorage = asks $ headStorage + + +-- | Get `HeadID' associated with given `Head'. +headId :: Head a -> HeadID +headId (Head uuid _) = uuid + +-- | Get storage from which the `Head' was loaded. +headStorage :: Head a -> Storage +headStorage = refStorage . headRef + +-- | Get `Ref' of the `Head'\'s associated object. +headRef :: Head a -> Ref +headRef (Head _ sx) = storedRef sx + +-- | Get the object the `Head' pointed to when it was loaded. +headObject :: Head a -> a +headObject (Head _ sx) = fromStored sx + +-- | Get the object the `Head' pointed to when it was loaded as a `Stored' value. +headStoredObject :: Head a -> Stored a +headStoredObject (Head _ sx) = sx + +-- | Create `HeadTypeID' from string representation of UUID. +mkHeadTypeID :: String -> HeadTypeID +mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString + + +-- | Load all `Head's of type @a@ from storage. +loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a] +loadHeads st@Storage {..} = + map (uncurry Head . fmap (wrappedLoad . Ref st)) + <$> liftIO (backendLoadHeads stBackend (headTypeID @a Proxy)) + +-- | Try to load a `Head' of type @a@ from storage. +loadHead + :: forall a m. (HeadType a, MonadIO m) + => Storage -- ^ Storage from which to load the head + -> HeadID -- ^ ID of the particular head + -> m (Maybe (Head a)) -- ^ Head object, or `Nothing' if not found +loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid + +-- | Try to load `Head' using a raw head and type IDs, getting `Ref' if found. +loadHeadRaw + :: forall m. MonadIO m + => Storage -- ^ Storage from which to load the head + -> HeadTypeID -- ^ ID of the head type + -> HeadID -- ^ ID of the particular head + -> m (Maybe Ref) -- ^ `Ref' pointing to the head object, or `Nothing' if not found +loadHeadRaw st@Storage {..} tid hid = do + fmap (Ref st) <$> liftIO (backendLoadHead stBackend tid hid) + +-- | Reload the given head from storage, returning `Head' with updated object, +-- or `Nothing' if there is no longer head with the particular ID in storage. +reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) +reloadHead (Head hid val) = loadHead (storedStorage val) hid + +-- | Store a new `Head' of type 'a' in the storage. +storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a) +storeHead st obj = do + let tid = headTypeID @a Proxy + stored <- wrappedStore st obj + hid <- storeHeadRaw st tid (storedRef stored) + return $ Head hid stored + +-- | Store a new `Head' in the storage, using the raw `HeadTypeID' and `Ref', +-- the function returns the assigned `HeadID' of the new head. +storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID +storeHeadRaw Storage {..} tid ref = liftIO $ do + hid <- HeadID <$> U.nextRandom + backendStoreHead stBackend tid hid (refDigest ref) + return hid + +-- | Try to replace existing `Head' of type @a@ in the storage. Function fails +-- if the head value in storage changed after being loaded here; for automatic +-- retry see `updateHead'. +replaceHead + :: forall a m. (HeadType a, MonadIO m) + => Head a -- ^ Existing head, associated object is supposed to match the one in storage + -> Stored a -- ^ Intended new value + -> m (Either (Maybe (Head a)) (Head a)) + -- ^ + -- [@`Left' `Nothing'@]: + -- Nothing was stored – the head no longer exists in storage. + -- [@`Left' (`Just' h)@]: + -- Nothing was stored – the head value in storage does not match + -- the first parameter, but is @h@ instead. + -- [@`Right' h@]: + -- Head value was updated in storage, the new head is @h@ (which is + -- the same as first parameter with associated object replaced by + -- the second parameter). +replaceHead prev@(Head hid pobj) stored' = liftIO $ do + let st = headStorage prev + tid = headTypeID @a Proxy + stored <- copyStored st stored' + bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$> + replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored) + +-- | Try to replace existing head using raw IDs and `Ref's. +replaceHeadRaw + :: forall m. MonadIO m + => Storage -- ^ Storage to use + -> HeadTypeID -- ^ ID of the head type + -> HeadID -- ^ ID of the particular head + -> Ref -- ^ Expected value in storage + -> Ref -- ^ Intended new value + -> m (Either (Maybe Ref) Ref) + -- ^ + -- [@`Left' `Nothing'@]: + -- Nothing was stored – the head no longer exists in storage. + -- [@`Left' (`Just' r)@]: + -- Nothing was stored – the head value in storage does not match + -- the expected value, but is @r@ instead. + -- [@`Right' r@]: + -- Head value was updated in storage, the new head value is @r@ + -- (which is the same as the indended value). +replaceHeadRaw st@Storage {..} tid hid prev new = liftIO $ do + _ <- copyRef st new + bimap (fmap $ Ref st) (Ref st) <$> backendReplaceHead stBackend tid hid (refDigest prev) (refDigest new) + +-- | Update existing existing `Head' of type @a@ in the storage, using a given +-- function. The update function may be called multiple times in case the head +-- content changes concurrently during evaluation. +updateHead + :: (HeadType a, MonadIO m) + => Head a -- ^ Existing head to be updated + -> (Stored a -> m ( Stored a, b )) + -- ^ Function that gets current value of the head and returns updated + -- value, along with a custom extra value to be returned from + -- `updateHead' call. The function may be called multiple times. + -> m ( Maybe (Head a), b ) + -- ^ First element contains either the new head as @`Just' h@, or + -- `Nothing' in case the head no longer exists in storage. Second + -- element is the value from last call to the update function. +updateHead h f = do + (o, x) <- f $ headStoredObject h + replaceHead h o >>= \case + Right h' -> return (Just h', x) + Left Nothing -> return (Nothing, x) + Left (Just h') -> updateHead h' f + +-- | Update existing existing `Head' of type @a@ in the storage, using a given +-- function. The update function may be called multiple times in case the head +-- content changes concurrently during evaluation. +updateHead_ + :: (HeadType a, MonadIO m) + => Head a -- ^ Existing head to be updated + -> (Stored a -> m (Stored a)) + -- ^ Function that gets current value of the head and returns updated + -- value; may be called multiple times. + -> m (Maybe (Head a)) + -- ^ The new head as @`Just' h@, or `Nothing' in case the head no + -- longer exists in storage. +updateHead_ h = fmap fst . updateHead h . (fmap (,()) .) + + +-- | Represents a handle of a watched head, which can be used to cancel the +-- watching. +data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a) + +-- | Watch the given head. The callback will be called with the current head +-- value, and then again each time the head changes. +watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead +watchHead h = watchHeadWith h id + +-- | Watch the given head using custom selector function. The callback will be +-- called with the value derived from current head state, and then again each +-- time the selected value changes according to its `Eq' instance. +watchHeadWith + :: forall a b. (HeadType a, Eq b) + => Head a -- ^ Head to watch + -> (Head a -> b) -- ^ Selector function + -> (b -> IO ()) -- ^ Callback + -> IO WatchedHead -- ^ Watched head handle +watchHeadWith (Head hid val) sel cb = do + watchHeadRaw (storedStorage val) (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb + +-- | Watch the given head using raw IDs and a selector from `Ref'. +watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead +watchHeadRaw st@Storage {..} tid hid sel cb = do + memo <- newEmptyMVar + let cb' dgst = do + let x = sel (Ref st dgst) + modifyMVar_ memo $ \prev -> do + when (Just x /= prev) $ cb x + return $ Just x + wid <- backendWatchHead stBackend tid hid cb' + + cur <- fmap sel <$> loadHeadRaw st tid hid + maybe (return ()) cb cur + putMVar memo cur + + return $ WatchedHead st wid memo + +-- | Stop watching previously watched head. +unwatchHead :: WatchedHead -> IO () +unwatchHead (WatchedHead Storage {..} wid _) = do + backendUnwatchHead stBackend wid diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs index 8b794d8..db211bb 100644 --- a/src/Erebos/Storage/Internal.hs +++ b/src/Erebos/Storage/Internal.hs @@ -1,88 +1,178 @@ -module Erebos.Storage.Internal where - -import Codec.Compression.Zlib +module Erebos.Storage.Internal ( + Storage'(..), Storage, PartialStorage, + Ref'(..), Ref, PartialRef, + RefDigest(..), + WatchID, startWatchID, nextWatchID, + WatchList(..), WatchListItem(..), watchListAdd, watchListDel, + + refStorage, + refDigest, refDigestFromByteString, + showRef, showRefDigest, showRefDigestParts, + readRefDigest, + hashToRefDigest, + + StorageCompleteness(..), + StorageBackend(..), + Complete, Partial, + + unsafeStoreRawBytes, + ioLoadBytesFromStorage, + + Generation(..), + HeadID(..), HeadTypeID(..), + Stored(..), storedStorage, +) where import Control.Arrow import Control.Concurrent import Control.DeepSeq import Control.Exception -import Control.Monad import Control.Monad.Identity import Crypto.Hash import Data.Bits -import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes) -import qualified Data.ByteArray as BA +import Data.ByteArray (ByteArrayAccess, ScrubbedBytes) +import Data.ByteArray qualified as BA import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import Data.Char +import Data.ByteString.Char8 qualified as BC +import Data.ByteString.Lazy qualified as BL import Data.Function +import Data.HashTable.IO qualified as HT import Data.Hashable -import qualified Data.HashTable.IO as HT import Data.Kind -import Data.List -import Data.Map (Map) -import qualified Data.Map as M -import Data.UUID (UUID) +import Data.Typeable import Foreign.Storable (peek) -import System.Directory -import System.FSNotify (WatchManager) -import System.FilePath -import System.IO -import System.IO.Error import System.IO.Unsafe (unsafePerformIO) -import Erebos.Storage.Platform +import Erebos.UUID (UUID) +import Erebos.Util -data Storage' c = Storage - { stBacking :: StorageBacking c - , stParent :: Maybe (Storage' Identity) +data Storage' c = forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => Storage + { stBackend :: bck , stRefGeneration :: MVar (HT.BasicHashTable RefDigest Generation) , stRefRoots :: MVar (HT.BasicHashTable RefDigest [RefDigest]) } +type Storage = Storage' Complete +type PartialStorage = Storage' Partial + instance Eq (Storage' c) where - (==) = (==) `on` (stBacking &&& stParent) + Storage { stBackend = b } == Storage { stBackend = b' } + | Just b'' <- cast b' = b == b'' + | otherwise = False instance Show (Storage' c) where - show st@(Storage { stBacking = StorageDir { dirPath = path }}) = "dir" ++ showParentStorage st ++ ":" ++ path - show st@(Storage { stBacking = StorageMemory {} }) = "mem" ++ showParentStorage st - -showParentStorage :: Storage' c -> String -showParentStorage Storage { stParent = Nothing } = "" -showParentStorage Storage { stParent = Just st } = "@" ++ show st - -data StorageBacking c - = StorageDir { dirPath :: FilePath - , dirWatchers :: MVar ( Maybe WatchManager, [ HeadTypeID ], WatchList c ) - } - | StorageMemory { memHeads :: MVar [((HeadTypeID, HeadID), Ref' c)] - , memObjs :: MVar (Map RefDigest BL.ByteString) - , memKeys :: MVar (Map RefDigest ScrubbedBytes) - , memWatchers :: MVar (WatchList c) - } - deriving (Eq) + show Storage { stBackend = b } = show b ++ showParentStorage b + +showParentStorage :: StorageBackend bck => bck -> String +showParentStorage bck + | Just (st :: Storage) <- cast (backendParent bck) = "@" ++ show st + | Just (st :: PartialStorage) <- cast (backendParent bck) = "@" ++ show st + | otherwise = "" + + +class (Eq bck, Show bck, Typeable bck, Typeable (BackendParent bck)) => StorageBackend bck where + type BackendCompleteness bck :: Type -> Type + type BackendCompleteness bck = Complete + + type BackendParent bck :: Type + type BackendParent bck = () + backendParent :: bck -> BackendParent bck + default backendParent :: BackendParent bck ~ () => bck -> BackendParent bck + backendParent _ = () + + + backendLoadBytes :: bck -> RefDigest -> IO (Maybe BL.ByteString) + default backendLoadBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe BL.ByteString) + backendLoadBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadBytes bck' + + backendStoreBytes :: bck -> RefDigest -> BL.ByteString -> IO () + default backendStoreBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> BL.ByteString -> IO () + backendStoreBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreBytes bck' + + + backendLoadHeads :: bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ] + default backendLoadHeads :: BackendParent bck ~ Storage => bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ] + backendLoadHeads bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHeads bck' + + backendLoadHead :: bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest) + default backendLoadHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest) + backendLoadHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHead bck' + + backendStoreHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> IO () + default backendStoreHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> IO () + backendStoreHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreHead bck' + + backendReplaceHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest) + default backendReplaceHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest) + backendReplaceHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendReplaceHead bck' + + backendWatchHead :: bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID + default backendWatchHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID + backendWatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendWatchHead bck' + + backendUnwatchHead :: bck -> WatchID -> IO () + default backendUnwatchHead :: BackendParent bck ~ Storage => bck -> WatchID -> IO () + backendUnwatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendUnwatchHead bck' + + + backendListKeys :: bck -> IO [ RefDigest ] + default backendListKeys :: BackendParent bck ~ Storage => bck -> IO [ RefDigest ] + backendListKeys bck = case backendParent bck of Storage { stBackend = bck' } -> backendListKeys bck' + + backendLoadKey :: bck -> RefDigest -> IO (Maybe ScrubbedBytes) + default backendLoadKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe ScrubbedBytes) + backendLoadKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadKey bck' + + backendStoreKey :: bck -> RefDigest -> ScrubbedBytes -> IO () + default backendStoreKey :: BackendParent bck ~ Storage => bck -> RefDigest -> ScrubbedBytes -> IO () + backendStoreKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreKey bck' + + backendRemoveKey :: bck -> RefDigest -> IO () + default backendRemoveKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO () + backendRemoveKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendRemoveKey bck' + + newtype WatchID = WatchID Int - deriving (Eq, Ord, Num) + deriving (Eq, Ord) + +startWatchID :: WatchID +startWatchID = WatchID 1 -data WatchList c = WatchList +nextWatchID :: WatchID -> WatchID +nextWatchID (WatchID n) = WatchID (n + 1) + +data WatchList = WatchList { wlNext :: WatchID - , wlList :: [WatchListItem c] + , wlList :: [ WatchListItem ] } -data WatchListItem c = WatchListItem +data WatchListItem = WatchListItem { wlID :: WatchID - , wlHead :: (HeadTypeID, HeadID) - , wlFun :: Ref' c -> IO () + , wlHead :: ( HeadTypeID, HeadID ) + , wlFun :: RefDigest -> IO () } +watchListAdd :: HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> WatchList -> ( WatchList, WatchID ) +watchListAdd tid hid cb wl = ( wl', wlNext wl ) + where + wl' = wl + { wlNext = nextWatchID (wlNext wl) + , wlList = WatchListItem + { wlID = wlNext wl + , wlHead = (tid, hid) + , wlFun = cb + } : wlList wl + } + +watchListDel :: WatchID -> WatchList -> WatchList +watchListDel wid wl = wl { wlList = filter ((/= wid) . wlID) $ wlList wl } + newtype RefDigest = RefDigest (Digest Blake2b_256) deriving (Eq, Ord, NFData, ByteArrayAccess) @@ -92,6 +182,9 @@ instance Show RefDigest where data Ref' c = Ref (Storage' c) RefDigest +type Ref = Ref' Complete +type PartialRef = Ref' Partial + instance Eq (Ref' c) where Ref _ d1 == Ref _ d2 = d1 == d2 @@ -126,65 +219,47 @@ showRefDigest = showRefDigestParts >>> \(alg, hex) -> alg <> BC.pack "#" <> hex readRefDigest :: ByteString -> Maybe RefDigest readRefDigest x = case BC.split '#' x of [alg, dgst] | BA.convert alg == BC.pack "blake2" -> - refDigestFromByteString =<< readHex @ByteString dgst + refDigestFromByteString =<< readHex dgst _ -> Nothing -refDigestFromByteString :: ByteArrayAccess ba => ba -> Maybe RefDigest +refDigestFromByteString :: ByteString -> Maybe RefDigest refDigestFromByteString = fmap RefDigest . digestFromByteString hashToRefDigest :: BL.ByteString -> RefDigest hashToRefDigest = RefDigest . hashFinalize . hashUpdates hashInit . BL.toChunks -showHex :: ByteArrayAccess ba => ba -> ByteString -showHex = B.concat . map showHexByte . BA.unpack - where showHexChar x | x < 10 = x + o '0' - | otherwise = x + o 'a' - 10 - showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ] - o = fromIntegral . ord - -readHex :: ByteArray ba => ByteString -> Maybe ba -readHex = return . BA.concat <=< readHex' - where readHex' bs | B.null bs = Just [] - readHex' bs = do (bx, bs') <- B.uncons bs - (by, bs'') <- B.uncons bs' - x <- hexDigit bx - y <- hexDigit by - (B.singleton (x * 16 + y) :) <$> readHex' bs'' - hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0' - | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10 - | otherwise = Nothing - o = fromIntegral . ord - newtype Generation = Generation Int deriving (Eq, Show) -data Head' c a = Head HeadID (Stored' c a) - deriving (Eq, Show) - +-- | UUID of individual Erebos storage head. newtype HeadID = HeadID UUID deriving (Eq, Ord, Show) +-- | UUID of Erebos storage head type. newtype HeadTypeID = HeadTypeID UUID deriving (Eq, Ord) -data Stored' c a = Stored (Ref' c) a +data Stored a = Stored + { storedRef' :: Ref + , storedObject' :: a + } deriving (Show) -instance Eq (Stored' c a) where - Stored r1 _ == Stored r2 _ = refDigest r1 == refDigest r2 +instance Eq (Stored a) where + (==) = (==) `on` (refDigest . storedRef') -instance Ord (Stored' c a) where - compare (Stored r1 _) (Stored r2 _) = compare (refDigest r1) (refDigest r2) +instance Ord (Stored a) where + compare = compare `on` (refDigest . storedRef') -storedStorage :: Stored' c a -> Storage' c -storedStorage (Stored (Ref st _) _) = st +storedStorage :: Stored a -> Storage +storedStorage = refStorage . storedRef' type Complete = Identity type Partial = Either RefDigest -class (Traversable compl, Monad compl) => StorageCompleteness compl where +class (Traversable compl, Monad compl, Typeable compl) => StorageCompleteness compl where type LoadResult compl a :: Type returnLoadResult :: compl a -> LoadResult compl a ioLoadBytes :: Ref' compl -> IO (compl BL.ByteString) @@ -201,71 +276,16 @@ instance StorageCompleteness Partial where ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c) -unsafeStoreRawBytes st raw = do - let dgst = hashToRefDigest raw - case stBacking st of - StorageDir { dirPath = sdir } -> writeFileOnce (refPath sdir dgst) $ compress raw - StorageMemory { memObjs = tobjs } -> - dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written - modifyMVar_ tobjs (return . M.insert dgst raw) +unsafeStoreRawBytes st@Storage {..} raw = do + dgst <- evaluate $ force $ hashToRefDigest raw + backendStoreBytes stBackend dgst raw return $ Ref st dgst ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString) -ioLoadBytesFromStorage st dgst = loadCurrent st >>= - \case Just bytes -> return $ Just bytes - Nothing | Just parent <- stParent st -> ioLoadBytesFromStorage parent dgst - | otherwise -> return Nothing - where loadCurrent Storage { stBacking = StorageDir { dirPath = spath } } = handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ - Just . decompress . BL.fromChunks . (:[]) <$> (B.readFile $ refPath spath dgst) - loadCurrent Storage { stBacking = StorageMemory { memObjs = tobjs } } = M.lookup dgst <$> readMVar tobjs - -refPath :: FilePath -> RefDigest -> FilePath -refPath spath rdgst = intercalate "/" [spath, "objects", BC.unpack alg, pref, rest] - where (alg, dgst) = showRefDigestParts rdgst - (pref, rest) = splitAt 2 $ BC.unpack dgst - - -openLockFile :: FilePath -> IO Handle -openLockFile path = do - createDirectoryIfMissing True (takeDirectory path) - retry 10 $ createFileExclusive path - where - retry :: Int -> IO a -> IO a - retry 0 act = act - retry n act = catchJust (\e -> if isAlreadyExistsError e then Just () else Nothing) - act (\_ -> threadDelay (100 * 1000) >> retry (n - 1) act) - -writeFileOnce :: FilePath -> BL.ByteString -> IO () -writeFileOnce file content = bracket (openLockFile locked) - hClose $ \h -> do - doesFileExist file >>= \case - True -> removeFile locked - False -> do BL.hPut h content - hClose h - renameFile locked file - where locked = file ++ ".lock" - -writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ()) -writeFileChecked file prev content = bracket (openLockFile locked) - hClose $ \h -> do - (prev,) <$> doesFileExist file >>= \case - (Nothing, True) -> do - current <- B.readFile file - removeFile locked - return $ Left $ Just current - (Nothing, False) -> do B.hPut h content - hClose h - renameFile locked file - return $ Right () - (Just expected, True) -> do - current <- B.readFile file - if current == expected then do B.hPut h content - hClose h - renameFile locked file - return $ return () - else do removeFile locked - return $ Left $ Just current - (Just _, False) -> do - removeFile locked - return $ Left Nothing - where locked = file ++ ".lock" +ioLoadBytesFromStorage Storage {..} dgst = + backendLoadBytes stBackend dgst >>= \case + Just bytes -> return $ Just bytes + Nothing + | Just (parent :: Storage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst + | Just (parent :: PartialStorage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst + | otherwise -> return Nothing diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs index 5da79e3..b615f16 100644 --- a/src/Erebos/Storage/Key.hs +++ b/src/Erebos/Storage/Key.hs @@ -4,21 +4,14 @@ module Erebos.Storage.Key ( moveKeys, ) where -import Control.Concurrent.MVar import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Data.ByteArray -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map as M +import Data.Typeable -import System.Directory -import System.FilePath -import System.IO.Error - -import Erebos.Storage +import Erebos.Storable import Erebos.Storage.Internal class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where @@ -28,59 +21,32 @@ class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where keyFromData :: ScrubbedBytes -> Stored pub -> Maybe sec -keyFilePath :: KeyPair sec pub => FilePath -> Stored pub -> FilePath -keyFilePath sdir pkey = sdir </> "keys" </> (BC.unpack $ showRef $ storedRef pkey) - storeKey :: KeyPair sec pub => sec -> IO () storeKey key = do let spub = keyGetPublic key - case stBacking $ storedStorage spub of - StorageDir { dirPath = dir } -> writeFileOnce (keyFilePath dir spub) (BL.fromStrict $ convert $ keyGetData key) - StorageMemory { memKeys = kstore } -> modifyMVar_ kstore $ return . M.insert (refDigest $ storedRef spub) (keyGetData key) + case storedStorage spub of + Storage {..} -> backendStoreKey stBackend (refDigest $ storedRef spub) (keyGetData key) -loadKey :: (KeyPair sec pub, MonadIO m, MonadError String m) => Stored pub -> m sec -loadKey pub = maybe (throwError $ "secret key not found for " <> show (storedRef pub)) return =<< loadKeyMb pub +loadKey :: (KeyPair sec pub, MonadIO m, MonadError e m, FromErebosError e) => Stored pub -> m sec +loadKey pub = maybe (throwOtherError $ "secret key not found for " <> show (storedRef pub)) return =<< loadKeyMb pub -loadKeyMb :: (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec) +loadKeyMb :: forall sec pub m. (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec) loadKeyMb spub = liftIO $ run $ storedStorage spub where - run st = tryOneLevel (stBacking st) >>= \case - key@Just {} -> return key - Nothing | Just parent <- stParent st -> run parent - | otherwise -> return Nothing - tryOneLevel = \case - StorageDir { dirPath = dir } -> tryIOError (BC.readFile (keyFilePath dir spub)) >>= \case - Right kdata -> return $ keyFromData (convert kdata) spub - Left _ -> return Nothing - StorageMemory { memKeys = kstore } -> (flip keyFromData spub <=< M.lookup (refDigest $ storedRef spub)) <$> readMVar kstore + run :: Storage' c -> IO (Maybe sec) + run Storage {..} = backendLoadKey stBackend (refDigest $ storedRef spub) >>= \case + Just bytes -> return $ keyFromData bytes spub + Nothing + | Just (parent :: Storage) <- cast (backendParent stBackend) -> run parent + | Just (parent :: PartialStorage) <- cast (backendParent stBackend) -> run parent + | otherwise -> return Nothing moveKeys :: MonadIO m => Storage -> Storage -> m () -moveKeys from to = liftIO $ do - case (stBacking from, stBacking to) of - (StorageDir { dirPath = fromPath }, StorageDir { dirPath = toPath }) -> do - files <- listDirectory (fromPath </> "keys") - forM_ files $ \file -> do - renameFile (fromPath </> "keys" </> file) (toPath </> "keys" </> file) - - (StorageDir { dirPath = fromPath }, StorageMemory { memKeys = toKeys }) -> do - let move m file - | Just dgst <- readRefDigest (BC.pack file) = do - let path = fromPath </> "keys" </> file - key <- convert <$> BC.readFile path - removeFile path - return $ M.insert dgst key m - | otherwise = return m - files <- listDirectory (fromPath </> "keys") - modifyMVar_ toKeys $ \keys -> foldM move keys files - - (StorageMemory { memKeys = fromKeys }, StorageDir { dirPath = toPath }) -> do - modifyMVar_ fromKeys $ \keys -> do - forM_ (M.assocs keys) $ \(dgst, key) -> - writeFileOnce (toPath </> "keys" </> (BC.unpack $ showRefDigest dgst)) (BL.fromStrict $ convert key) - return M.empty - - (StorageMemory { memKeys = fromKeys }, StorageMemory { memKeys = toKeys }) -> do - when (fromKeys /= toKeys) $ do - modifyMVar_ fromKeys $ \fkeys -> do - modifyMVar_ toKeys $ return . M.union fkeys - return M.empty +moveKeys Storage { stBackend = from } Storage { stBackend = to } = liftIO $ do + keys <- backendListKeys from + forM_ keys $ \key -> do + backendLoadKey from key >>= \case + Just sec -> do + backendStoreKey to key sec + backendRemoveKey from key + Nothing -> return () diff --git a/src/Erebos/Storage/Memory.hs b/src/Erebos/Storage/Memory.hs new file mode 100644 index 0000000..677e8c5 --- /dev/null +++ b/src/Erebos/Storage/Memory.hs @@ -0,0 +1,101 @@ +module Erebos.Storage.Memory ( + memoryStorage, + deriveEphemeralStorage, + derivePartialStorage, +) where + +import Control.Concurrent.MVar + +import Data.ByteArray (ScrubbedBytes) +import Data.ByteString.Lazy qualified as BL +import Data.Function +import Data.Kind +import Data.List +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe +import Data.Typeable + +import Erebos.Object +import Erebos.Storage.Backend +import Erebos.Storage.Head +import Erebos.Storage.Internal + + +data MemoryStorage p (c :: Type -> Type) = StorageMemory + { memParent :: p + , memHeads :: MVar [ (( HeadTypeID, HeadID ), RefDigest ) ] + , memObjs :: MVar (Map RefDigest BL.ByteString) + , memKeys :: MVar (Map RefDigest ScrubbedBytes) + , memWatchers :: MVar WatchList + } + +instance Eq (MemoryStorage p c) where + (==) = (==) `on` memObjs + +instance Show (MemoryStorage p c) where + show StorageMemory {} = "mem" + +instance (StorageCompleteness c, Typeable p) => StorageBackend (MemoryStorage p c) where + type BackendCompleteness (MemoryStorage p c) = c + type BackendParent (MemoryStorage p c) = p + backendParent = memParent + + backendLoadBytes StorageMemory {..} dgst = + M.lookup dgst <$> readMVar memObjs + + backendStoreBytes StorageMemory {..} dgst raw = + modifyMVar_ memObjs (return . M.insert dgst raw) + + + backendLoadHeads StorageMemory {..} tid = do + let toRes ( ( tid', hid ), dgst ) + | tid' == tid = Just ( hid, dgst ) + | otherwise = Nothing + catMaybes . map toRes <$> readMVar memHeads + + backendLoadHead StorageMemory {..} tid hid = + lookup (tid, hid) <$> readMVar memHeads + + backendStoreHead StorageMemory {..} tid hid dgst = + modifyMVar_ memHeads $ return . (( ( tid, hid ), dgst ) :) + + backendReplaceHead StorageMemory {..} tid hid expected new = do + res <- modifyMVar memHeads $ \hs -> do + ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar memWatchers + return $ case partition ((==(tid, hid)) . fst) hs of + ( [] , _ ) -> ( hs, Left Nothing ) + (( _, dgst ) : _, hs' ) + | dgst == expected -> ((( tid, hid ), new ) : hs', Right ( new, ws )) + | otherwise -> ( hs, Left $ Just dgst ) + case res of + Right ( dgst, ws ) -> mapM_ ($ dgst) ws >> return (Right dgst) + Left x -> return $ Left x + + backendWatchHead StorageMemory {..} tid hid cb = modifyMVar memWatchers $ return . watchListAdd tid hid cb + + backendUnwatchHead StorageMemory {..} wid = modifyMVar_ memWatchers $ return . watchListDel wid + + + backendListKeys StorageMemory {..} = M.keys <$> readMVar memKeys + backendLoadKey StorageMemory {..} dgst = M.lookup dgst <$> readMVar memKeys + backendStoreKey StorageMemory {..} dgst key = modifyMVar_ memKeys $ return . M.insert dgst key + backendRemoveKey StorageMemory {..} dgst = modifyMVar_ memKeys $ return . M.delete dgst + + +memoryStorage' :: (StorageCompleteness c, Typeable p) => p -> IO (Storage' c) +memoryStorage' memParent = do + memHeads <- newMVar [] + memObjs <- newMVar M.empty + memKeys <- newMVar M.empty + memWatchers <- newMVar (WatchList startWatchID []) + newStorage $ StorageMemory {..} + +memoryStorage :: IO Storage +memoryStorage = memoryStorage' () + +deriveEphemeralStorage :: Storage -> IO Storage +deriveEphemeralStorage parent = memoryStorage' parent + +derivePartialStorage :: Storage -> IO PartialStorage +derivePartialStorage parent = memoryStorage' parent diff --git a/src/Erebos/Storage/Merge.hs b/src/Erebos/Storage/Merge.hs index a3b0fd7..a41a65f 100644 --- a/src/Erebos/Storage/Merge.hs +++ b/src/Erebos/Storage/Merge.hs @@ -31,7 +31,8 @@ import Data.Set qualified as S import System.IO.Unsafe (unsafePerformIO) -import Erebos.Storage +import Erebos.Object +import Erebos.Storable import Erebos.Storage.Internal import Erebos.Util @@ -51,7 +52,7 @@ merge xs = mergeSorted $ filterAncestors xs storeMerge :: (Mergeable a, Storable a) => [Stored (Component a)] -> IO (Stored a) storeMerge [] = error "merge: empty list" -storeMerge xs@(Stored ref _ : _) = wrappedStore (refStorage ref) $ mergeSorted $ filterAncestors xs +storeMerge xs@(x : _) = wrappedStore (storedStorage x) $ mergeSorted $ filterAncestors xs previous :: Storable a => Stored a -> [Stored a] previous (Stored ref _) = case load ref of diff --git a/src/Erebos/Sync.hs b/src/Erebos/Sync.hs index 04b5f11..d837a14 100644 --- a/src/Erebos/Sync.hs +++ b/src/Erebos/Sync.hs @@ -10,7 +10,7 @@ import Data.List import Erebos.Identity import Erebos.Service import Erebos.State -import Erebos.Storage +import Erebos.Storable import Erebos.Storage.Merge data SyncService = SyncPacket (Stored SharedState) @@ -23,7 +23,7 @@ instance Service SyncService where pid <- asks svcPeerIdentity self <- svcSelf when (finalOwner pid `sameIdentity` finalOwner self) $ do - updateLocalHead_ $ \ls -> do + updateLocalState_ $ \ls -> do let current = sort $ lsShared $ fromStored ls updated = filterAncestors (added : current) if current /= updated diff --git a/src/Erebos/UUID.hs b/src/Erebos/UUID.hs new file mode 100644 index 0000000..128d450 --- /dev/null +++ b/src/Erebos/UUID.hs @@ -0,0 +1,24 @@ +module Erebos.UUID ( + UUID, + toString, fromString, + toText, fromText, + toASCIIBytes, fromASCIIBytes, + nextRandom, +) where + +import Crypto.Random.Entropy + +import Data.Bits +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Maybe +import Data.UUID.Types + +nextRandom :: IO UUID +nextRandom = do + [ b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, bc, bd, be, bf ] + <- BS.unpack <$> getEntropy 16 + let version = 4 + b6' = b6 .&. 0x0f .|. (version `shiftL` 4) + b8' = b8 .&. 0x3f .|. 0x80 + return $ fromJust $ fromByteString $ BSL.pack [ b0, b1, b2, b3, b4, b5, b6', b7, b8', b9, ba, bb, bc, bd, be, bf ] diff --git a/src/Erebos/Util.hs b/src/Erebos/Util.hs index ffca9c7..0381c3e 100644 --- a/src/Erebos/Util.hs +++ b/src/Erebos/Util.hs @@ -1,5 +1,14 @@ module Erebos.Util where +import Control.Monad + +import Data.ByteArray (ByteArray, ByteArrayAccess) +import Data.ByteArray qualified as BA +import Data.ByteString (ByteString) +import Data.ByteString qualified as B +import Data.Char + + uniq :: Eq a => [a] -> [a] uniq (x:y:xs) | x == y = uniq (x:xs) | otherwise = x : uniq (y:xs) @@ -35,3 +44,24 @@ intersectsSorted (x:xs) (y:ys) | x < y = intersectsSorted xs (y:ys) | x > y = intersectsSorted (x:xs) ys | otherwise = True intersectsSorted _ _ = False + + +showHex :: ByteArrayAccess ba => ba -> ByteString +showHex = B.concat . map showHexByte . BA.unpack + where showHexChar x | x < 10 = x + o '0' + | otherwise = x + o 'a' - 10 + showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ] + o = fromIntegral . ord + +readHex :: ByteArray ba => ByteString -> Maybe ba +readHex = return . BA.concat <=< readHex' + where readHex' bs | B.null bs = Just [] + readHex' bs = do (bx, bs') <- B.uncons bs + (by, bs'') <- B.uncons bs' + x <- hexDigit bx + y <- hexDigit by + (B.singleton (x * 16 + y) :) <$> readHex' bs'' + hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0' + | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10 + | otherwise = Nothing + o = fromIntegral . ord diff --git a/test/attach.test b/test/attach.test index 33a1483..afbdd0e 100644 --- a/test/attach.test +++ b/test/attach.test @@ -1,12 +1,14 @@ test: + let services = "attach,sync" + spawn as p1 spawn as p2 send "create-identity Device1 Owner" to p1 send "create-identity Device2" to p2 send "watch-local-identity" to p1 send "watch-local-identity" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /local-identity Device1 Owner/ /peer 1 addr ${p2.node.ip} 29665/ diff --git a/test/chatroom.test b/test/chatroom.test index 93de1ff..54f9b2a 100644 --- a/test/chatroom.test +++ b/test/chatroom.test @@ -1,4 +1,8 @@ +def refpat = /blake2#[0-9a-f]+/ + test ChatroomSetup: + let services = "chatroom" + # Local chatrooms spawn as p1 @@ -30,7 +34,7 @@ test ChatroomSetup: for p in [ p1, p2, p3 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" for p in [ p2, p3 ]: with p: @@ -97,6 +101,8 @@ test ChatroomSetup: test ChatroomMessages: + let services = "chatroom" + spawn as p1 spawn as p2 @@ -106,7 +112,7 @@ test ChatroomMessages: for p in [ p1, p2 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" send "chatroom-create first_room" to p1 expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 @@ -159,7 +165,7 @@ test ChatroomMessages: spawn as p3 send "create-identity Device3 Owner3" to p3 send "chatroom-watch-local" to p3 - send "start-server" to p3 + send "start-server services $services" to p3 expect /chatroom-watched-added ([a-z0-9#]+) first_room sub false/ from p3 capture room1_p3 expect /chatroom-watched-added ([a-z0-9#]+) second_room sub false/ from p3 capture room2_p3 expect /chatroom-watched-added ([a-z0-9#]+) third_room sub false/ from p3 capture room3_p3 @@ -242,6 +248,8 @@ test ChatroomMessages: test ChatroomSubscribedBeforeStart: + let services = "chatroom" + spawn as p1 spawn as p2 @@ -251,7 +259,7 @@ test ChatroomSubscribedBeforeStart: for p in [ p1, p2 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" send "chatroom-create first_room" to p1 expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 @@ -271,7 +279,7 @@ test ChatroomSubscribedBeforeStart: expect /stop-server-done/ for p in [p1, p2]: with p: - send "start-server" + send "start-server services $services" send "chatroom-message-send $room1_p1 message1" to p1 expect /chatroom-message-new $room1_p1 room first_room from Owner1 text message1/ from p1 @@ -283,6 +291,8 @@ test ChatroomSubscribedBeforeStart: test ParallelThreads: + let services = "chatroom" + spawn as p1 spawn as p2 @@ -292,7 +302,7 @@ test ParallelThreads: for p in [ p1, p2 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" send "chatroom-create first_room" to p1 expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 @@ -330,7 +340,7 @@ test ParallelThreads: for p in [p1, p2]: with p: - send "start-server" + send "start-server services $services" with p1: expect /chatroom-message-new $room1_p1 room first_room from Owner. text message(..)/ capture msg @@ -347,6 +357,8 @@ test ParallelThreads: test ChatroomMembers: + let services = "chatroom" + spawn as p1 spawn as p2 spawn as p3 @@ -358,7 +370,7 @@ test ChatroomMembers: for p in [ p1, p2, p3 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" send "chatroom-create first_room" to p1 expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 @@ -413,9 +425,12 @@ test ChatroomMembers: send "chatroom-leave $room1_p1" to p1 send "chatroom-leave $room1_p3" to p3 - for p in [ p1, p2, p3 ]: + for p in [ p1, p2 ]: with p: expect /chatroom-message-new [a-z0-9#]+ room first_room from Owner1 leave/ + + for p in [ p2, p3 ]: + with p: expect /chatroom-message-new [a-z0-9#]+ room first_room from Owner3 leave/ send "chatroom-members $room1_p1" to p1 @@ -426,3 +441,222 @@ test ChatroomMembers: expect /chatroom-members-item Owner2/ expect /chatroom-members-([a-z]+)/ capture done guard (done == "done") + + +test ChatroomIdentity: + let services = "chatroom" + + spawn as p1 + spawn as p2 + + send "create-identity Device1 Owner1" to p1 + send "create-identity Device2 Owner2" to p2 + + for p in [ p1, p2 ]: + with p: + send "chatroom-watch-local" + send "start-server services $services" + + send "chatroom-create first_room" to p1 + expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 + expect /chatroom-watched-added ([a-z0-9#]+) first_room sub false/ from p2 capture room1_p2 + + send "chatroom-join-as $room1_p1 Custom1" to p1 + expect /chatroom-join-as-done $room1_p1/ from p1 + send "chatroom-join-as $room1_p2 Custom2" to p2 + expect /chatroom-join-as-done $room1_p2/ from p2 + + send "chatroom-message-send $room1_p1 message1" to p1 + send "chatroom-message-send $room1_p2 message2" to p2 + + for p in [ p1, p2 ]: + with p: + expect /chatroom-message-new [a-z0-9#]+ room first_room from ([^ ]+) text message1/ capture name1 + guard (name1 == "Custom1") + expect /chatroom-message-new [a-z0-9#]+ room first_room from ([^ ]+) text message2/ capture name2 + guard (name2 == "Custom2") + + spawn as p1b on p1.node + spawn as p2b on p2.node + for p in [ p1b, p2b ]: + with p: + send "chatroom-watch-local" + + send "chatroom-message-send $room1_p1 message3" to p1b + send "chatroom-message-send $room1_p2 message4" to p2b + + for p in [ p1, p2, p1b, p2b ]: + with p: + expect /chatroom-message-new [a-z0-9#]+ room first_room from ([^ ]+) text message3/ capture name1 + guard (name1 == "Custom1") + expect /chatroom-message-new [a-z0-9#]+ room first_room from ([^ ]+) text message4/ capture name2 + guard (name2 == "Custom2") + + +test ChatroomDelete: + let services = "chatroom" + + node n1 + node n2 + node n3 + + # Create and sync chatrooms on n1 and sync to n2 + local: + spawn as p1 on n1 + with p1: + send "create-identity Device1 Owner1" + expect /create-identity-done .*/ + + send "chatroom-watch-local" + send "start-server services $services" + + send "chatroom-create first" + send "chatroom-create second" + expect /chatroom-create-done $refpat first.*/ + expect /chatroom-create-done $refpat second.*/ + + + spawn as p2 on n2 + with p2: + send "create-identity Device2 Owner2" + expect /create-identity-done .*/ + + send "chatroom-watch-local" + send "start-server services $services" + + expect /chatroom-watched-added ($refpat) first sub false/ capture first + expect /chatroom-watched-added ($refpat) second sub false/ capture second + + send "chatroom-subscribe $first" + send "chatroom-subscribe $second" + expect /chatroom-watched-updated $first first sub true .*/ + expect /chatroom-watched-updated $second second sub true .*/ + + local: + spawn as p3 on n3 + with p3: + send "create-identity Device3 Owner3" + expect /create-identity-done .*/ + + local: + spawn as p1 on n1 + spawn as p2 on n2 + spawn as p3 on n3 + + # Delete first chatroom from n1 + with p1: + send "chatroom-watch-local" + send "start-server services $services" + + send "chatroom-list-local" + expect /chatroom-list-item ($refpat) first sub true/ capture first + expect /chatroom-list-item $refpat second sub true/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + send "chatroom-delete $first" + expect /chatroom-delete-done .*/ + + # Setup n3 + with p3: + send "chatroom-watch-local" + send "start-server services $services" + + expect /chatroom-watched-added $refpat second sub false/ + + # Check that both n1 and n3 see only the second chatroom + for p in [ p1, p3 ]: + with p: + send "chatroom-list-local" + expect /chatroom-list-item $refpat second .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + # Reactive server on n2 and create third chatroom + with p2: + send "chatroom-watch-local" + send "start-server services $services" + + send "chatroom-create third" + expect /chatroom-create-done $refpat third.*/ + + # Verify that first chatroom appears only on n3 ... + with p3: + expect /chatroom-watched-added $refpat first sub false/ + expect /chatroom-watched-added $refpat third sub false/ + + send "chatroom-list-local" + expect /chatroom-list-item $refpat first .*/ + expect /chatroom-list-item $refpat second .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + # ... and not on n1 + with p1: + expect /chatroom-watched-added ($refpat) third sub false/ capture third + send "chatroom-subscribe $third" + expect /chatroom-watched-updated $third third sub true .*/ + + send "chatroom-list-local" + expect /chatroom-list-item $refpat second .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + # Delete second chatroom on n2 + with p2: + send "chatroom-list-local" + expect /chatroom-list-item $refpat first .*/ + expect /chatroom-list-item ($refpat) second .*/ capture second + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + send "chatroom-delete $second" + expect /chatroom-delete-done .*/ + + # Send messages + with p3: + send "chatroom-list-local" + expect /chatroom-list-item ($refpat) first .*/ capture first + expect /chatroom-list-item ($refpat) second .*/ capture second + expect /chatroom-list-item ($refpat) third .*/ capture third + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + send "chatroom-message-send $first message_first" + send "chatroom-message-send $second message_second" + send "chatroom-message-send $third message_third" + + # Receive only to non-deleted ones + with p1: + expect /chatroom-message-new $refpat room second from Owner3 text message_second/ + expect /chatroom-message-new $refpat room ([a-z]+) from Owner3 text ([a-z_]+)/ capture room, msg + guard (room == "third") + guard (msg == "message_third") + + send "chatroom-list-local" + expect /chatroom-list-item $refpat second .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + with p2: + expect /chatroom-message-new $refpat room first from Owner3 text message_first/ + expect /chatroom-message-new $refpat room ([a-z]+) from Owner3 text ([a-z_]+)/ capture room, msg + guard (room == "third") + guard (msg == "message_third") + + send "chatroom-list-local" + expect /chatroom-list-item $refpat first .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") diff --git a/test/common.test b/test/common.test new file mode 100644 index 0000000..89941f0 --- /dev/null +++ b/test/common.test @@ -0,0 +1,3 @@ +module common + +export def refpat = /blake2#[0-9a-f]*/ diff --git a/test/contact.test b/test/contact.test index 438aa1f..978f8a6 100644 --- a/test/contact.test +++ b/test/contact.test @@ -1,4 +1,6 @@ test Contact: + let services = "attach,contact,sync" + spawn as p1 spawn as p2 spawn as p3 @@ -9,10 +11,10 @@ test Contact: send "create-identity Device3 Owner3" to p3 send "create-identity Device4" to p4 - send "start-server" to p1 - send "start-server" to p2 - send "start-server" to p3 - send "start-server" to p4 + send "start-server services $services" to p1 + send "start-server services $services" to p2 + send "start-server services $services" to p3 + send "start-server services $services" to p4 expect from p1: /peer ([0-9]+) addr ${p2.node.ip} 29665/ capture peer1_2 diff --git a/test/discovery.test b/test/discovery.test new file mode 100644 index 0000000..3be6275 --- /dev/null +++ b/test/discovery.test @@ -0,0 +1,91 @@ +module discovery + +test ManualDiscovery: + let services = "discovery" + let refpat = /blake2#[0-9a-f]*/ + + subnet sd + subnet s1 + subnet s2 + + spawn as pd on sd + spawn as p1 on s1 + spawn as p2 on s2 + send "create-identity Discovery" to pd + send "create-identity Device1 Owner1" to p1 + send "create-identity Device2 Owner2" to p2 + + expect /create-identity-done ref ($refpat).*/ from p1 capture p1id + send "identity-info $p1id" to p1 + expect /identity-info ref $p1id base ($refpat) owner ($refpat).*/ from p1 capture p1base, p1owner + send "identity-info $p1owner" to p1 + expect /identity-info ref $p1owner base ($refpat).*/ from p1 capture p1obase + + expect /create-identity-done ref $refpat.*/ from p2 + expect /create-identity-done ref $refpat.*/ from pd + + # Test discovery using owner and device identities: + for id in [ p1obase, p1base ]: + for p in [ pd, p1, p2 ]: + send "start-server services $services" to p + + for p in [ p1, p2 ]: + with p: + send "peer-add ${pd.node.ip}" + expect: + /peer 1 addr ${pd.node.ip} 29665/ + /peer 1 id Discovery/ + expect from pd: + /peer [12] addr ${p.node.ip} 29665/ + /peer [12] id .*/ + + send "discovery-connect $id" to p2 + + expect from p1: + /peer [0-9]+ addr ${p2.node.ip} 29665/ + /peer [0-9]+ id Device2 Owner2/ + expect from p2: + /peer [0-9]+ addr ${p1.node.ip} 29665/ + /peer [0-9]+ id Device1 Owner1/ + + for p in [ pd, p1, p2 ]: + send "stop-server" to p + for p in [ pd, p1, p2 ]: + expect /stop-server-done/ from p + + # Test delayed discovery with new peer + for id in [ p1obase ]: + for p in [ pd, p1, p2 ]: + send "start-server services $services" to p + + with p1: + send "peer-add ${pd.node.ip}" + expect: + /peer 1 addr ${pd.node.ip} 29665/ + /peer 1 id Discovery/ + expect from pd: + /peer [12] addr ${p1.node.ip} 29665/ + /peer [12] id Device1 Owner1/ + + send "discovery-connect $id" to p2 + + with p2: + send "peer-add ${pd.node.ip}" + expect: + /peer 1 addr ${pd.node.ip} 29665/ + /peer 1 id Discovery/ + expect from pd: + /peer [12] addr ${p2.node.ip} 29665/ + /peer [12] id Device2 Owner2/ + + expect from p1: + /peer [0-9]+ addr ${p2.node.ip} 29665/ + /peer [0-9]+ id Device2 Owner2/ + expect from p2: + /peer [0-9]+ addr ${p1.node.ip} 29665/ + /peer [0-9]+ id Device1 Owner1/ + + for p in [ pd, p1, p2 ]: + send "stop-server" to p + for p in [ pd, p1, p2 ]: + expect /stop-server-done/ from p diff --git a/test/message.test b/test/message.test index 307f11a..2990d0f 100644 --- a/test/message.test +++ b/test/message.test @@ -1,10 +1,16 @@ +module message + +import common + test DirectMessage: + let services = "contact,dm" + spawn as p1 spawn as p2 send "create-identity Device1 Owner1" to p1 send "create-identity Device2 Owner2" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /peer ([0-9]+) addr ${p2.node.ip} 29665/ capture peer1_2 @@ -96,7 +102,7 @@ test DirectMessage: expect /stop-server-done/ for p in [p1, p2]: with p: - send "start-server" + send "start-server services $services" with p1: send "contact-list" @@ -126,10 +132,10 @@ test DirectMessage: for p in [p1, p2]: with p: expect /stop-server-done/ - send "start-server" to p2 + send "start-server services $services" to p2 send "dm-send-contact $c1_2 while_offline" to p1 - send "start-server" to p1 + send "start-server services $services" to p1 expect /dm-received from Owner1 text while_offline/ from p2 @@ -139,11 +145,121 @@ test DirectMessage: for p in [p1, p2]: with p: expect /stop-server-done/ - send "start-server" to p1 + send "start-server services $services" to p1 send "dm-send-contact $c1_2 while_peer_offline" to p1 # TODO: sync from p1 on peer p2 discovery not ensured without addition wait #wait - send "start-server" to p2 + send "start-server services $services" to p2 expect /dm-received from Owner1 text while_peer_offline/ from p2 + + +test DirectMessageDiscovery: + let services = "dm,discovery" + + subnet sd + subnet s1 + subnet s2 + subnet s3 + subnet s4 + + spawn on sd as pd + spawn on s1 as p1 + spawn on s2 as p2 + spawn on s3 as p3 + spawn on s4 as p4 + + send "create-identity Discovery" to pd + + send "create-identity Device1 Owner1" to p1 + expect /create-identity-done ref ($refpat)/ from p1 capture p1_id + send "identity-info $p1_id" to p1 + expect /identity-info ref $p1_id base ($refpat) owner ($refpat).*/ from p1 capture p1_base, p1_owner + + send "create-identity Device2 Owner2" to p2 + expect /create-identity-done ref ($refpat)/ from p2 capture p2_id + send "identity-info $p2_id" to p2 + expect /identity-info ref $p2_id base ($refpat) owner ($refpat).*/ from p2 capture p2_base, p2_owner + send "identity-info $p2_owner" to p2 + expect /identity-info ref $p2_owner base ($refpat).*/ from p2 capture p2_obase + + send "create-identity Device3 Owner3" to p3 + expect /create-identity-done ref ($refpat)/ from p3 capture p3_id + send "identity-info $p3_id" to p3 + expect /identity-info ref $p3_id base ($refpat) owner ($refpat).*/ from p3 capture p3_base, p3_owner + + send "create-identity Device4 Owner4" to p4 + expect /create-identity-done ref ($refpat)/ from p4 capture p4_id + send "identity-info $p4_id" to p4 + expect /identity-info ref $p4_id base ($refpat) owner ($refpat).*/ from p4 capture p4_base, p4_owner + + + for p in [ p1, p2, p3, p4 ]: + with p: + send "start-server services $services" + + for p in [ p2, p3, p4 ]: + with p1: + send "peer-add ${p.node.ip}" + expect: + /peer [0-9]+ addr ${p.node.ip} 29665/ + /peer [0-9]+ id Device. Owner./ + expect from p: + /peer 1 addr ${p1.node.ip} 29665/ + /peer 1 id Device1 Owner1/ + + # Make sure p1 has other identities in storage: + for i in [ 1 .. 3 ]: + send "dm-send-peer $i init1" to p1 + for p in [ p2, p3, p4 ]: + expect /dm-received from Owner1 text init1/ from p + send "dm-send-identity $p1_owner init2" to p + expect /dm-received from Owner. text init2/ from p1 + + # Restart servers to remove peers: + for p in [ p1, p2, p3, p4 ]: + with p: + send "stop-server" + for p in [ p1, p2, p3, p4 ]: + with p: + expect /stop-server-done/ + + # Prepare message before peers connect to discovery + send "dm-send-identity $p4_owner hello_to_p4" to p1 + + for p in [ p1, p2, p3, p4, pd ]: + with p: + send "start-server services $services" + + for p in [ p2, p3, p4, p1 ]: + with p: + send "peer-add ${pd.node.ip}" + expect: + /peer 1 addr ${pd.node.ip} 29665/ + /peer 1 id Discovery/ + expect from pd: + /peer [0-9]+ addr ${p.node.ip} 29665/ + /peer [0-9]+ id Device. Owner./ + + multiply_timeout by 2.0 + + # Connect via discovery manually, then send message + send "discovery-connect $p2_obase" to p1 + expect from p1: + /peer [0-9]+ addr ${p2.node.ip} 29665/ + /peer [0-9]+ id Device2 Owner2/ + send "dm-send-identity $p2_owner hello_to_p2" to p1 + expect /dm-received from Owner1 text hello_to_p2/ from p2 + + # Send message, expect automatic discovery + send "dm-send-identity $p3_owner hello_to_p3" to p1 + expect /dm-received from Owner1 text hello_to_p3/ from p3 + + # Verify the first message + expect /dm-received from Owner1 text hello_to_p4/ from p4 + + for p in [ p1, p2, p3, p4, pd ]: + send "stop-server" to p + for p in [ p1, p2, p3, p4, pd ]: + expect /stop-server-done/ from p diff --git a/test/network.test b/test/network.test index efd508f..0f49a1e 100644 --- a/test/network.test +++ b/test/network.test @@ -120,12 +120,14 @@ test Discovery: test LargeData: + let services = "test" + spawn as p1 spawn as p2 send "create-identity Device1" to p1 send "create-identity Device2" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /peer 1 addr ${p2.node.ip} 29665/ /peer 1 id Device2/ @@ -149,12 +151,14 @@ test LargeData: test ManyStreams: + let services = "test" + spawn as p1 spawn as p2 send "create-identity Device1" to p1 send "create-identity Device2" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /peer 1 addr ${p2.node.ip} 29665/ /peer 1 id Device2/ @@ -178,13 +182,67 @@ test ManyStreams: expect /test-message-received blob 100[2-4] $ref/ from p2 +test ServiceStreams: + let services = "test" + + spawn as p1 + spawn as p2 + send "create-identity Device1" to p1 + send "create-identity Device2" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 + expect from p1: + /peer 1 addr ${p2.node.ip} 29665/ + /peer 1 id Device2/ + expect from p2: + /peer 1 addr ${p1.node.ip} 29665/ + /peer 1 id Device1/ + + send "test-stream-open 1" to p1 + expect /test-stream-open-done 1 ([0-9]+)/ from p1 capture stream1 + expect /test-stream-open-from 1 $stream1/ from p2 + + send "test-stream-send 1 $stream1 hello" to p1 + expect /test-stream-send-done 1 $stream1/ from p1 + expect /test-stream-received 1 $stream1 0 hello/ from p2 + + send "test-stream-close 1 $stream1" to p1 + expect /test-stream-close-done 1 $stream1/ from p1 + expect /test-stream-closed-from 1 $stream1 1/ from p2 + + send "test-stream-open 1 8" to p2 + expect /test-stream-open-done 1 ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+) ([0-9]+)/ from p2 capture stream2_1, stream2_2, stream2_3, stream2_4, stream2_5, stream2_6, stream2_7, stream2_8 + expect /test-stream-open-from 1 $stream2_1 $stream2_2 $stream2_3 $stream2_4 $stream2_5 $stream2_6 $stream2_7 $stream2_8/ from p1 + + let streams2 = [ stream2_1, stream2_2, stream2_3, stream2_4, stream2_5, stream2_6, stream2_7, stream2_8 ] + with p2: + for i in [ 1..20 ]: + for s in streams2: + send "test-stream-send 1 $s hello$i" + for i in [ 1..20 ]: + for s in streams2: + expect /test-stream-send-done 1 $s/ + for s in streams2: + send "test-stream-close 1 $s" + for s in streams2: + expect /test-stream-close-done 1 $s/ + with p1: + for i in [ 1..20 ]: + for s in streams2: + expect /test-stream-received 1 $s ${i-1} hello$i/ + for s in streams2: + expect /test-stream-closed-from 1 $s 20/ + + test MultipleServiceRefs: + let services = "test" + spawn as p1 spawn as p2 send "create-identity Device1" to p1 send "create-identity Device2" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /peer 1 addr ${p2.node.ip} 29665/ /peer 1 id Device2/ @@ -235,16 +293,18 @@ test MultipleServiceRefs: test Reconnection: + let services = "test" + spawn as p1 with p1: send "create-identity Device1" - send "start-server" + send "start-server services $services" node n local: spawn as p2 on n send "create-identity Device2" to p2 - send "start-server" to p2 + send "start-server services $services" to p2 expect from p1: /peer 1 addr ${p2.node.ip} 29665/ @@ -272,7 +332,7 @@ test Reconnection: # Restart process on node 'n' local: spawn as p2 on n - send "start-server" to p2 + send "start-server services $services" to p2 send "peer-add ${p1.node.ip}" to p2 expect from p2: @@ -380,3 +440,64 @@ test Reconnection: guard (done == "done") expect /test-message-received blob [0-9]+ $message/ + + +test SendUnknownObjectType: + let services = "test" + let refpat = /blake2#[0-9a-f]*/ + + spawn as p1 + spawn as p2 + + with p1: + send "create-identity Device1" + send "start-server services $services" + with p2: + send "create-identity Device2" + send "start-server services $services" + + expect from p1: + /peer 1 addr ${p2.node.ip} 29665/ + /peer 1 id Device2/ + expect from p2: + /peer 1 addr ${p1.node.ip} 29665/ + /peer 1 id Device1/ + + with p1: + send: + "store test-unknown" + "TEST" + "" + expect /store-done ($refpat)/ capture r1 + + send: + "store rec" + "test:unknown TEST" + "" + expect /store-done ($refpat)/ capture r2 + + send "test-message-send 1 $r1" + expect /test-message-send done/ + + with p2: + expect /test-message-received test-unknown [0-9]+ $r1/ + + send "load $r1" + expect /load-type test-unknown 5/ + expect /load-line TEST/ + local: + expect /load-(.*)/ capture done + guard (done == "done") + + send "test-message-send 1 $r2" + expect /test-message-send done/ + + with p2: + expect /test-message-received rec [0-9]+ $r2/ + + send "load $r2" + expect /load-type rec [0-9]+/ + expect /load-line test:unknown TEST/ + local: + expect /load-(.*)/ capture done + guard (done == "done") diff --git a/test/storage.test b/test/storage.test index 0369807..2230eac 100644 --- a/test/storage.test +++ b/test/storage.test @@ -381,14 +381,16 @@ test StorageWatcher: test SharedStateWatcher: + let services = "attach,sync" + spawn as p1 spawn as p2 send "create-identity Device1 Owner" to p1 send "create-identity Device2" to p2 send "watch-local-identity" to p1 send "watch-local-identity" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /local-identity Device1 Owner/ /peer 1 addr ${p2.node.ip} 29665/ @@ -427,3 +429,95 @@ test SharedStateWatcher: send "shared-state-wait $s2" to p2 expect /shared-state-wait $s1/ from p2 expect /shared-state-wait $s2/ from p2 + + +test LocalStateKeepUnknown: + let refpat = /blake2#[0-9a-f]*/ + + spawn as p + with p: + send "create-identity Device" + send "watch-local-identity" + expect /local-identity Device/ + + send "local-state-get" + expect /local-state-get ($refpat)/ capture s1 + send "load $s1" + + expect /load-type rec [0-9]*/ + expect /load-line id:r ($refpat)/ capture id1 + local: + expect /load-(.*)/ capture done + guard (done == "done") + + send: + "store rec" + "id:r $id1" + "TEST:i 123" + "" + expect /store-done ($refpat)/ capture s2 + send "local-state-replace $s1 $s2" + expect /local-state-replace-done/ + + send "local-state-get" + expect /local-state-get $s2/ + + send "update-local-identity Device2" + expect /local-identity Device2/ + + send "local-state-get" + expect /local-state-get ($refpat)/ capture s3 + send "load $s3" + + expect /load-type rec [0-9]*/ + expect /load-line PREV:w $s2/ + expect /load-line id:r ($refpat)/ capture id2 + guard (id1 /= id2) + expect /load-line TEST:i 123/ + local: + expect /load-(.*)/ capture done + guard (done == "done") + + +test UnknownObjectType: + let refpat = /blake2#[0-9a-f]*/ + + spawn as p + spawn as p2 on p.node + + with p: + send: + "store test-unknown" + "TEST" + "" + expect /store-done ($refpat)/ capture r1 + + with p2: + send "load $r1" + expect /load-type test-unknown 5/ + expect /load-line TEST/ + local: + expect /load-(.*)/ capture done + guard (done == "done") + + +test UnknownRecordItemType: + let refpat = /blake2#[0-9a-f]*/ + + spawn as p + spawn as p2 on p.node + + with p: + send: + "store rec" + "test:unknown TEST" + "" + expect /store-done ($refpat)/ capture r1 + + with p2: + send "load $r1" + expect /load-type rec [0-9]+/ + expect /load-line test:unknown TEST/ + local: + expect /load-(.*)/ capture done + guard (done == "done") diff --git a/test/sync.test b/test/sync.test index ea9595d..d465b11 100644 --- a/test/sync.test +++ b/test/sync.test @@ -1,4 +1,6 @@ test: + let services = "attach,sync" + spawn as p1 spawn as p2 send "create-identity Device1 Owner" to p1 @@ -7,8 +9,8 @@ test: send "watch-local-identity" to p2 send "watch-shared-identity" to p1 send "watch-shared-identity" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /local-identity Device1 Owner/ /shared-identity Owner/ @@ -57,7 +59,7 @@ test: send "create-identity Device3" send "watch-local-identity" send "watch-shared-identity" - send "start-server" + send "start-server services $services" send "peer-add ${p1.node.ip}" |