diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,33 @@ # Revision history for erebos +## 0.2.0 -- 2025-08-06 + +* Weak references in records +* Use XDG data directory for default storage path +* Added `/identity` command to show details of current identity +* Support tunnel for peers in discovery service +* New CLI prompt implementation providing cleaner interface + * Avoids displaying sent messages twice – both in previous prompt and in message history + * Print received messages only for selected conversation + * Clear tab completion options after use + +* API + * Split `Erebos.Storage` into multiple modules + * Removed deprecated `Message.formatMessage` alias + * Renamed `Erebos.Message` module to `Erebos.DirectMessage` + * Added `StorageBackend` type class to allow custom storage implementation + * `MonadError` constraints use generic error type + * Replaced `Erebos.Network.peerAddress` with `getPeerAddress` and added `getPeerAddresses` + * Renamed `Erebos.Network.peerIdentity` to `getPeerIdentity` + * Renamed some functions in `Erebos.DirectMessage` module to make clear they are related only to direct messages + * `Erebos.Storage.Merge.generations`/`generationsBy` return `NonEmpty` + * Replaced `watchReceivedDirectMessages` with `watchDirectMessageThreads` + * Return type of `sendMessage` and `sendDirectMessage` is now `()` + * Some functions use `MonadStorage` instead of explicit `Storage` parameter: + * `Erebos.Set.storeSetAdd` + * `Erebos.State.makeSharedStateUpdate` + * `Erebos.Identity.createIdentity` + ## 0.1.9 -- 2025-07-08 * Option to show details or delete a conversation by giving index parameter without first selecting it diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -216,6 +216,9 @@ : Drop the currently selected peer. Afterwards, the connection can be re-established by either side. +`/identity` +: Show details of current identity + `/update-identity` : Interactively update current identity information @@ -226,8 +229,11 @@ 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 --- a/erebos.cabal +++ b/erebos.cabal @@ -1,7 +1,7 @@ Cabal-Version: 3.0 Name: erebos -Version: 0.1.9 +Version: 0.2.0 Synopsis: Decentralized messaging and synchronization Description: Library and simple CLI interface implementing the Erebos identity @@ -100,30 +100,40 @@ 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.Address + 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: @@ -134,7 +144,7 @@ src/Erebos/Network/ifaddrs.h if flag(ice) - exposed-modules: + other-modules: Erebos.ICE c-sources: src/Erebos/ICE/pjproject.c @@ -164,7 +174,7 @@ stm >=2.5 && <2.6, text >= 1.2 && <2.2, time ^>= { 1.8, 1.9, 1.10, 1.11, 1.12, 1.13, 1.14 }, - uuid >=1.3 && <1.4, + uuid-types ^>= { 1.0.4 }, zlib >=0.6 && <0.8 if !flag(cryptonite) @@ -192,26 +202,31 @@ 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, directory, erebos, - haskeline >=0.7 && <0.9, mtl, network, process >=1.6 && <1.7, + 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: diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Arrow (first) import Control.Concurrent import Control.Exception import Control.Monad @@ -11,11 +9,13 @@ import Control.Monad.Reader import Control.Monad.State import Control.Monad.Trans.Maybe +import Control.Monad.Writer import Crypto.Random -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL +import Data.Bifunctor +import Data.ByteString.Char8 qualified as BC +import Data.ByteString.Lazy qualified as BL import Data.Char import Data.List import Data.Maybe @@ -31,7 +31,7 @@ import Network.Socket import System.Console.GetOpt -import System.Console.Haskeline +import System.Directory import System.Environment import System.Exit import System.IO @@ -40,30 +40,34 @@ import Erebos.Contact import Erebos.Chatroom import Erebos.Conversation +import Erebos.DirectMessage import Erebos.Discovery -#ifdef ENABLE_ICE_SUPPORT -import Erebos.ICE -#endif import Erebos.Identity -import Erebos.Message hiding (formatMessage) import Erebos.Network +import Erebos.Object import Erebos.PubKey import Erebos.Service import Erebos.Set import Erebos.State +import Erebos.Storable import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync +import State +import Terminal import Test import Version +import WebSocket data Options = Options { optServer :: ServerOptions , optServices :: [ServiceOption] , optStorage :: StorageOption + , optCreateIdentity :: Maybe ( Maybe Text, [ Maybe Text ] ) , optChatroomAutoSubscribe :: Maybe Int , optDmBotEcho :: Maybe Text + , optWebSocketServer :: Maybe Int , optShowHelp :: Bool , optShowVersion :: Bool } @@ -84,8 +88,10 @@ { optServer = defaultServerOptions , optServices = availableServices , optStorage = DefaultStorage + , optCreateIdentity = Nothing , optChatroomAutoSubscribe = Nothing , optDmBotEcho = Nothing + , optWebSocketServer = Nothing , optShowHelp = False , optShowVersion = False } @@ -106,7 +112,7 @@ True "peer discovery" ] -options :: [OptDescr (Options -> Options)] +options :: [ OptDescr (Options -> Writer [ String ] Options) ] options = [ Option ['p'] ["port"] (ReqArg (\p -> so $ \opts -> opts { serverPort = read p }) "") @@ -115,57 +121,92 @@ (NoArg (so $ \opts -> opts { serverLocalDiscovery = False })) "do not send announce packets for local discovery" , Option [] [ "storage" ] - (ReqArg (\path -> \opts -> opts { optStorage = FilesystemStorage path }) "") + (ReqArg (\path -> \opts -> return opts { optStorage = FilesystemStorage path }) "") "use storage in " , Option [] [ "memory-storage" ] - (NoArg (\opts -> opts { optStorage = MemoryStorage })) + (NoArg (\opts -> return opts { optStorage = MemoryStorage })) "use memory storage" + , Option [] [ "create-identity" ] + (OptArg (\value -> \opts -> return opts + { optCreateIdentity = + let devName = T.pack <$> value + in maybe (Just ( devName, [] )) (Just . first (const devName)) (optCreateIdentity opts) + }) "") + "create a new (device) identity in a new local state" + , Option [] [ "create-owner" ] + (OptArg (\value -> \opts -> return opts + { optCreateIdentity = + let ownerName = T.pack <$> value + in maybe (Just ( Nothing, [ ownerName ] )) (Just . second (ownerName :)) (optCreateIdentity opts) + }) "") + "create owner for a new device identity" , Option [] ["chatroom-auto-subscribe"] - (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "") + (ReqArg (\count -> \opts -> return opts { optChatroomAutoSubscribe = Just (read count) }) "") "automatically subscribe for up to chatrooms" -#ifdef ENABLE_ICE_SUPPORT , Option [] [ "discovery-stun-port" ] - (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunPort = Just (read value) }) "") + (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryStunPort = Just (read value) }) "") "offer specified to discovery peers for STUN protocol" , Option [] [ "discovery-stun-server" ] - (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunServer = Just (read value) }) "") + (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryStunServer = Just (read value) }) "") "offer (domain name or IP address) to discovery peers for STUN protocol" , Option [] [ "discovery-turn-port" ] - (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnPort = Just (read value) }) "") + (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnPort = Just (read value) }) "") "offer specified to discovery peers for TURN protocol" , Option [] [ "discovery-turn-server" ] - (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnServer = Just (read value) }) "") + (ReqArg (\value -> serviceAttr $ \attrs -> return attrs { discoveryTurnServer = Just (read value) }) "") "offer (domain name or IP address) to discovery peers for TURN protocol" -#endif + , Option [] [ "discovery-tunnel" ] + (OptArg (\value -> \opts -> do + fun <- provideTunnelFun value + serviceAttr (\attrs -> return attrs { discoveryProvideTunnel = fun }) opts) "") + "offer to provide tunnel for peers of given , possible values: all, none, websocket" , Option [] ["dm-bot-echo"] - (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "") + (ReqArg (\prefix -> \opts -> return opts { optDmBotEcho = Just (T.pack prefix) }) "") "automatically reply to direct messages with the same text prefixed with " + , Option [] [ "websocket-server" ] + (ReqArg (\value -> \opts -> return opts { optWebSocketServer = Just (read value) }) "") + "start WebSocket server on given port" , Option ['h'] ["help"] - (NoArg $ \opts -> opts { optShowHelp = True }) + (NoArg $ \opts -> return opts { optShowHelp = True }) "show this help and exit" , Option ['V'] ["version"] - (NoArg $ \opts -> opts { optShowVersion = True }) + (NoArg $ \opts -> return opts { optShowVersion = True }) "show version and exit" ] where - so f opts = opts { optServer = f $ optServer opts } + so f opts = return opts { optServer = f $ optServer opts } - updateService :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> SomeService -> SomeService + updateService :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> SomeService -> m SomeService updateService f some@(SomeService proxy attrs) - | Just f' <- cast f = SomeService proxy (f' attrs) - | otherwise = some + | Just f' <- cast f = SomeService proxy <$> f' attrs + | otherwise = return 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) } + serviceAttr :: (Service s, Monad m, Typeable m) => (ServiceAttributes s -> m (ServiceAttributes s)) -> Options -> m Options + serviceAttr f opts = do + services' <- forM (optServices opts) $ \sopt -> do + service <- updateService f (soptService sopt) + return sopt { soptService = service } + return opts { optServices = services' } -servicesOptions :: [OptDescr (Options -> Options)] + provideTunnelFun :: Maybe String -> Writer [ String ] (Peer -> PeerAddress -> Bool) + provideTunnelFun Nothing = return $ \_ _ -> True + provideTunnelFun (Just "all") = return $ \_ _ -> True + provideTunnelFun (Just "none") = return $ \_ _ -> False + provideTunnelFun (Just "websocket") = return $ \_ -> \case + CustomPeerAddress addr | Just WebSocketAddress {} <- cast addr -> True + _ -> False + provideTunnelFun (Just name) = do + tell [ "Invalid value of --discovery-tunnel: ‘" <> name <> "’\n" ] + return $ \_ _ -> False + +servicesOptions :: [ OptDescr (Options -> Writer [ String ] Options) ] servicesOptions = concatMap helper $ "all" : map soptName availableServices where helper name = - [ Option [] ["enable-" <> name] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = True }) "" - , Option [] ["disable-" <> name] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = False }) "" + [ Option [] [ "enable-" <> name ] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = True }) "" + , Option [] [ "disable-" <> name ] (NoArg $ so $ change name $ \sopt -> sopt { soptEnabled = False }) "" ] - so f opts = opts { optServices = f $ optServices opts } + so f opts = return opts { optServices = f $ optServices opts } change :: String -> (ServiceOption -> ServiceOption) -> [ServiceOption] -> [ServiceOption] change name f (s : ss) | soptName s == name || name == "all" @@ -173,18 +214,29 @@ | 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 - (o, args, []) -> do - return (foldl (flip id) defaultOptions o, args) - (_, _, errs) -> do + let printErrors errs = do progName <- getProgName hPutStrLn stderr $ concat errs <> "Try `" <> progName <> " --help' for more information." exitFailure + (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case + (wo, args, []) -> + case runWriter (foldM (flip ($)) defaultOptions wo) of + ( o, [] ) -> return ( o, args ) + ( _, errs ) -> printErrors errs + (_, _, errs) -> printErrors errs st <- liftIO $ case optStorage opts of - DefaultStorage -> openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR" + DefaultStorage -> openStorage =<< getDefaultStorageDir FilesystemStorage path -> openStorage path MemoryStorage -> memoryStorage @@ -224,17 +276,28 @@ 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 + [ "identity" ] -> do + loadHeads st >>= \case + (h : _) -> do + T.putStr $ showIdentityDetails $ headLocalIdentity h + [] -> do + T.putStrLn "no local state head" + exitFailure + ["update-identity"] -> do + withTerminal noCompletion $ \term -> do + either (fail . showErebosError) return <=< runExceptT $ do + runReaderT (updateSharedIdentity term) =<< runReaderT (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 @@ -264,27 +327,24 @@ 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 +interactiveLoop st opts = withTerminal commandCompletion $ \term -> do + erebosHead <- either (fail . showErebosError) return <=< runExceptT . flip runReaderT st $ do + case optCreateIdentity opts of + Nothing -> loadLocalStateHead term + Just ( devName, names ) -> createLocalStateHead (names ++ [ devName ]) + void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead - 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 tui = hasTerminalUI term + let extPrintLn = void . printLine term - let getInputLinesTui eprompt = do + let getInputLinesTui :: Either CommandState String -> MaybeT IO String + getInputLinesTui eprompt = do prompt <- case eprompt of Left cstate -> do pname <- case csContext cstate of NoContext -> return "" - SelectedPeer peer -> peerIdentity peer >>= return . \case + SelectedPeer peer -> getPeerIdentity peer >>= return . \case PeerIdentityFull pid -> maybe "" T.unpack $ idName $ finalOwner pid PeerIdentityRef wref _ -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">" PeerIdentityUnknown _ -> "" @@ -293,69 +353,92 @@ 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 + | tui -> KeepPrompt mzero + | otherwise -> KeepPrompt $ liftIO $ forever $ threadDelay 100000000 getInputCommandTui cstate = do - input <- getInputLinesTui cstate - let (CommandM cmd, line) = case input of - '/':rest -> let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') rest - in if not (null scmd) && all isDigit scmd - then (cmdSelectContext, scmd) - else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args) - _ -> (cmdSend, input) - return (cmd, line) + let parseCommand cmdline = + case dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') cmdline of + ( scmd, args ) + | not (null scmd) && all isDigit scmd + -> ( cmdSelectContext, scmd ) - getInputLinesPipe = do - lift (getInputLine "") >>= \case - Just input -> return input - Nothing -> liftIO $ forever $ threadDelay 100000000 + | otherwise + -> ( fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args ) - getInputCommandPipe _ = do - input <- getInputLinesPipe - let (scmd, args) = dropWhile isSpace <$> span (\c -> isAlphaNum c || c == '-') input - let (CommandM cmd, line) = (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args) - return (cmd, line) + ( CommandM cmd, line ) <- getInputLinesTui cstate >>= return . \case + '/' : input -> parseCommand input + input | not tui -> parseCommand input + input -> ( cmdSend, input ) + return ( cmd, line ) - let getInputCommand = if tui then getInputCommandTui . Left - else getInputCommandPipe + let getInputCommand = getInputCommandTui . Left + contextVar <- liftIO $ newMVar NoContext + _ <- liftIO $ do tzone <- getCurrentTimeZone - watchReceivedMessages erebosHead $ \smsg -> do - let msg = fromStored smsg - extPrintLn $ formatDirectMessage tzone msg - case optDmBotEcho opts of - Nothing -> return () - Just prefix -> do - res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg) - case res of - Right reply -> extPrintLn $ formatDirectMessage tzone $ fromStored reply - Left err -> extPrintLn $ "Failed to send dm echo: " <> err + let self = finalOwner $ headLocalIdentity erebosHead + watchDirectMessageThreads erebosHead $ \prev cur -> do + forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do + withMVar contextVar $ \ctx -> do + mbpid <- case ctx of + SelectedPeer peer -> getPeerIdentity peer >>= return . \case + PeerIdentityFull pid -> Just $ finalOwner pid + _ -> Nothing + SelectedContact contact + | Just cid <- contactIdentity contact -> return (Just cid) + SelectedConversation conv -> return $ conversationPeer conv + _ -> return Nothing + when (not tui || maybe False (msgPeer cur `sameIdentity`) mbpid) $ do + extPrintLn $ formatDirectMessage tzone msg + case optDmBotEcho opts of + Just prefix + | not (msgFrom msg `sameIdentity` self) + -> do + void $ forkIO $ do + res <- runExceptT $ flip runReaderT erebosHead $ sendDirectMessage (msgFrom msg) (prefix <> msgText msg) + case res of + Right _ -> return () + Left err -> extPrintLn $ "Failed to send dm echo: " <> err + _ -> return () + peers <- liftIO $ newMVar [] - contextOptions <- liftIO $ newMVar [] + contextOptions <- liftIO $ newMVar ( Nothing, [] ) chatroomSetVar <- liftIO $ newEmptyMVar let autoSubscribe = optChatroomAutoSubscribe opts chatroomList = fromSetBy (comparing roomStateData) . lookupSharedValue . lsShared . headObject $ erebosHead watched <- if isJust autoSubscribe || any roomStateSubscribe chatroomList - then fmap Just $ liftIO $ watchChatroomsForCli extPrintLn erebosHead chatroomSetVar contextOptions autoSubscribe - else return Nothing + then do + fmap Just $ liftIO $ watchChatroomsForCli tui extPrintLn erebosHead + chatroomSetVar contextVar contextOptions autoSubscribe + else do + return Nothing server <- liftIO $ do startServer (optServer opts) erebosHead extPrintLn $ 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 + getPeerIdentity peer >>= \case pid@(PeerIdentityFull _) -> do dropped <- isPeerDropped peer - let shown = showPeer pid $ peerAddress peer + shown <- showPeer pid <$> getPeerAddress peer let update [] = ([(peer, shown)], (Nothing, "NEW")) update ((p,s):ps) | p == peer && dropped = (ps, (Nothing, "DEL")) @@ -367,36 +450,47 @@ | otherwise = first (ctx:) $ ctxUpdate (n + 1) ctxs (op, updateType) <- modifyMVar peers (return . update) let updateType' = if dropped then "DEL" else updateType - idx <- modifyMVar contextOptions (return . ctxUpdate (1 :: Int)) - when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown + modifyMVar_ contextOptions $ \case + ( watch, clist ) + | watch == Just WatchPeers || not tui + -> do + let ( clist', idx ) = ctxUpdate (1 :: Int) clist + when (Just shown /= op) $ do + extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown + return ( Just WatchPeers, clist' ) + cur -> return cur _ -> return () - let process :: CommandState -> MaybeT (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 - , ciLine = line - , ciPrint = extPrintLn - , ciOptions = opts - , ciPeers = liftIO $ modifyMVar peers $ \ps -> do - ps' <- filterM (fmap not . isPeerDropped . fst) ps - return (ps', ps') - , ciContextOptions = liftIO $ readMVar contextOptions - , ciSetContextOptions = \ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ctxs - , ciContextOptionsVar = contextOptions - , ciChatroomSetVar = chatroomSetVar - } + res <- liftIO $ modifyMVar contextVar $ \ctx -> do + res <- runExceptT $ flip execStateT cstate { csHead = h, csContext = ctx } $ runReaderT cmd CommandInput + { ciServer = server + , ciTerminal = term + , ciLine = line + , ciPrint = extPrintLn + , ciOptions = opts + , ciPeers = liftIO $ modifyMVar peers $ \ps -> do + ps' <- filterM (fmap not . isPeerDropped . fst) ps + return (ps', ps') + , ciContextOptions = liftIO $ snd <$> readMVar contextOptions + , ciSetContextOptions = \watch ctxs -> liftIO $ modifyMVar_ contextOptions $ const $ return ( Just watch, ctxs ) + , ciContextVar = contextVar + , ciContextOptionsVar = contextOptions + , ciChatroomSetVar = chatroomSetVar + } + return ( either (const ctx) csContext res, res ) case res of Right cstate' | csQuit cstate' -> mzero | 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 @@ -404,10 +498,6 @@ loop $ Just $ CommandState { csHead = erebosHead , csContext = NoContext -#ifdef ENABLE_ICE_SUPPORT - , csIceSessions = [] -#endif - , csIcePeer = Nothing , csWatchChatrooms = watched , csQuit = False } @@ -415,42 +505,48 @@ data CommandInput = CommandInput { ciServer :: Server + , ciTerminal :: Terminal , ciLine :: String , ciPrint :: String -> IO () , ciOptions :: Options , ciPeers :: CommandM [(Peer, String)] - , ciContextOptions :: CommandM [CommandContext] - , ciSetContextOptions :: [CommandContext] -> Command - , ciContextOptionsVar :: MVar [ CommandContext ] + , ciContextOptions :: CommandM [ CommandContext ] + , ciSetContextOptions :: ContextWatchOptions -> [ CommandContext ] -> Command + , ciContextVar :: MVar CommandContext + , ciContextOptionsVar :: MVar ( Maybe ContextWatchOptions, [ CommandContext ] ) , ciChatroomSetVar :: MVar (Set ChatroomState) } data CommandState = CommandState { csHead :: Head LocalState , csContext :: CommandContext -#ifdef ENABLE_ICE_SUPPORT - , csIceSessions :: [IceSession] -#endif - , csIcePeer :: Maybe Peer , csWatchChatrooms :: Maybe WatchedHead , csQuit :: Bool } -data CommandContext = NoContext - | SelectedPeer Peer - | SelectedContact Contact - | SelectedChatroom ChatroomState - | SelectedConversation Conversation +data CommandContext + = NoContext + | SelectedPeer Peer + | SelectedContact Contact + | SelectedChatroom ChatroomState + | SelectedConversation Conversation -newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String) +data ContextWatchOptions + = WatchPeers + | WatchContacts + | WatchChatrooms + | WatchConversations + deriving (Eq) +newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a) + deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError) + 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 @@ -471,41 +567,42 @@ 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 >>= getConversationFromContext getConversationFromContext :: CommandContext -> CommandM Conversation getConversationFromContext = \case - SelectedPeer peer -> peerIdentity peer >>= \case + SelectedPeer peer -> getPeerIdentity 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) - _ -> throwError "invalid index" + str | all isDigit str -> getContextByIndex id (read str) + _ -> throwOtherError "invalid index" commands :: [(String, Command)] commands = [ ("history", cmdHistory) + , ("identity", cmdIdentity) , ("peers", cmdPeers) , ("peer-add", cmdPeerAdd) , ("peer-add-public", cmdPeerAddPublic) @@ -524,15 +621,7 @@ , ("contact-reject", cmdContactReject) , ("conversations", cmdConversations) , ("details", cmdDetails) - , ("discovery-init", cmdDiscoveryInit) , ("discovery", cmdDiscovery) -#ifdef ENABLE_ICE_SUPPORT - , ("ice-create", cmdIceCreate) - , ("ice-destroy", cmdIceDestroy) - , ("ice-show", cmdIceShow) - , ("ice-connect", cmdIceConnect) - , ("ice-send", cmdIceSend) -#endif , ("join", cmdJoin) , ("join-as", cmdJoinAs) , ("leave", cmdLeave) @@ -549,16 +638,21 @@ 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 peers <- join $ asks ciPeers set <- asks ciSetContextOptions - set $ map (SelectedPeer . fst) peers + set WatchPeers $ map (SelectedPeer . fst) peers forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ name + cmdPutStrLn $ "[" ++ show i ++ "] " ++ name cmdPeerAdd :: Command cmdPeerAdd = void $ do @@ -566,13 +660,17 @@ (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) + contextOptsVar <- asks ciContextOptionsVar + liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers) liftIO $ serverPeer server (addrAddress addr) cmdPeerAddPublic :: Command cmdPeerAddPublic = do server <- asks ciServer + contextOptsVar <- asks ciContextOptionsVar + liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchPeers) liftIO $ mapM_ (serverPeer server . addrAddress) =<< gather 'a' where gather c @@ -606,8 +704,7 @@ cmdJoinAs :: Command cmdJoinAs = do name <- asks ciLine - st <- getStorage - identity <- liftIO $ createIdentity st (Just $ T.pack name) Nothing + identity <- createIdentity (Just $ T.pack name) Nothing joinChatroomAs identity =<< getSelectedChatroom cmdLeave :: Command @@ -617,18 +714,22 @@ cmdMembers = do Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom forM_ (chatroomMembers room) $ \x -> do - liftIO $ putStrLn $ maybe "" T.unpack $ idName x + cmdPutStrLn $ maybe "" 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 -> throwError "invalid index" +getContextByIndex :: (Maybe ContextWatchOptions -> Maybe ContextWatchOptions) -> Int -> CommandM CommandContext +getContextByIndex f n = do + contextOptsVar <- asks ciContextOptionsVar + join $ liftIO $ modifyMVar contextOptsVar $ \cur@( watch, ctxs ) -> if + | n > 0, (ctx : _) <- drop (n - 1) ctxs + -> return ( ( f watch, ctxs ), return ctx ) + | otherwise + -> return ( cur, throwOtherError "invalid index" ) + cmdSelectContext :: Command cmdSelectContext = do n <- read <$> asks ciLine - ctx <- getContextByIndex n + ctx <- getContextByIndex (const Nothing) n modify $ \s -> s { csContext = ctx } case ctx of SelectedChatroom rstate -> do @@ -640,11 +741,7 @@ cmdSend = void $ do text <- asks ciLine conv <- getSelectedConversation - sendMessage conv (T.pack text) >>= \case - Just msg -> do - tzone <- liftIO $ getCurrentTimeZone - liftIO $ putStrLn $ formatMessage tzone msg - Nothing -> return () + sendMessage conv (T.pack text) cmdDelete :: Command cmdDelete = void $ do @@ -657,13 +754,32 @@ 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 $ "" + cmdPutStrLn $ "" +showIdentityDetails :: Foldable f => Identity f -> Text +showIdentityDetails identity = T.unlines $ go $ reverse $ unfoldOwners identity + where + go (i : is) = concat + [ maybeToList $ ("Name: " <>) <$> idName i + , map (("Ref: " <>) . T.pack . show . refDigest . storedRef) $ idDataF i + , map (("ExtRef: " <>) . T.pack . show . refDigest . storedRef) $ filter isExtension $ idExtDataF i + , do guard $ not (null is) + "" : "Device:" : map (" " <>) (go is) + ] + go [] = [] + isExtension x = case fromSigned x of BaseIdentityData {} -> False + _ -> True + +cmdIdentity :: Command +cmdIdentity = do + cmdPutStrLn . T.unpack . showIdentityDetails . localIdentity . fromStored =<< getLocalHead + cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do - runReaderT updateSharedIdentity =<< gets csHead + term <- asks ciTerminal + runReaderT (updateSharedIdentity term) =<< gets csHead cmdAttach :: Command cmdAttach = attachToOwner =<< getSelectedPeer @@ -674,8 +790,11 @@ cmdAttachReject :: Command cmdAttachReject = attachReject =<< getSelectedPeer -watchChatroomsForCli :: (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) -> MVar [ CommandContext ] -> Maybe Int -> IO WatchedHead -watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do +watchChatroomsForCli + :: Bool -> (String -> IO ()) -> Head LocalState -> MVar (Set ChatroomState) + -> MVar CommandContext -> MVar ( Maybe ContextWatchOptions, [ CommandContext ] ) + -> Maybe Int -> IO WatchedHead +watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe = do subscribedNumVar <- newEmptyMVar let ctxUpdate updateType (idx :: Int) rstate = \case @@ -710,32 +829,48 @@ 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 + modifyMVar_ contextOptsVar $ \case + ( watch, clist ) + | watch == Just WatchChatrooms || not tui + -> do + let upd c = \case + AddedChatroom rstate -> ctxUpdate "NEW" 1 rstate c + RemovedChatroom rstate -> ctxUpdate "DEL" 1 rstate c + UpdatedChatroom _ rstate + | any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate) + -> do + ctxUpdate "UPD" 1 rstate c + | otherwise -> return c + ( watch, ) <$> foldM upd clist diff + cur -> return cur + forM_ diff $ \case AddedChatroom rstate -> do - modifyMVar_ contextVar $ ctxUpdate "NEW" 1 rstate modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then (+ 1) else id RemovedChatroom rstate -> do - modifyMVar_ contextVar $ ctxUpdate "DEL" 1 rstate modifyMVar_ subscribedNumVar $ return . if roomStateSubscribe rstate then subtract 1 else id UpdatedChatroom oldroom rstate -> do - when (any ((\rsd -> not (null (rsdRoom rsd))) . fromStored) (roomStateData rstate)) $ do - modifyMVar_ contextVar $ ctxUpdate "UPD" 1 rstate when (any (not . null . rsdMessages . fromStored) (roomStateData rstate)) $ do - tzone <- getCurrentTimeZone - forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do - eprint $ concat $ - [ maybe "" T.unpack $ roomName =<< cmsgRoom msg - , formatTime defaultTimeLocale " [%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg - , maybe "" T.unpack $ idName $ cmsgFrom msg - , if cmsgLeave msg then " left" else "" - , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg - ] + withMVar contextVar $ \ctx -> do + isSelected <- case ctx of + SelectedChatroom rstate' -> return $ isSameChatroom rstate' rstate + SelectedConversation conv -> return $ isChatroomStateConversation rstate conv + _ -> return False + when (not tui || isSelected) $ do + tzone <- getCurrentTimeZone + forM_ (reverse $ getMessagesSinceState rstate oldroom) $ \msg -> do + eprint $ concat $ + [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ cmsgTime msg + , maybe "" T.unpack $ idName $ cmsgFrom msg + , if cmsgLeave msg then " left" else "" + , maybe (if cmsgLeave msg then "" else " joined") ((": " ++) . T.unpack) $ cmsgText msg + ] modifyMVar_ subscribedNumVar $ return . (if roomStateSubscribe rstate then (+ 1) else id) . (if roomStateSubscribe oldroom then subtract 1 else id) @@ -747,9 +882,11 @@ eprint <- asks ciPrint h <- gets csHead chatroomSetVar <- asks ciChatroomSetVar - contextVar <- asks ciContextOptionsVar + contextVar <- asks ciContextVar + contextOptsVar <- asks ciContextOptionsVar autoSubscribe <- asks $ optChatroomAutoSubscribe . ciOptions - watched <- liftIO $ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe + tui <- asks $ hasTerminalUI . ciTerminal + watched <- liftIO $ watchChatroomsForCli tui eprint h chatroomSetVar contextVar contextOptsVar autoSubscribe modify $ \s -> s { csWatchChatrooms = Just watched } Just _ -> return () @@ -759,20 +896,22 @@ chatroomSetVar <- asks ciChatroomSetVar chatroomList <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) set <- asks ciSetContextOptions - set $ map SelectedChatroom chatroomList + set WatchChatrooms $ map SelectedChatroom chatroomList forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ maybe "" T.unpack (roomName =<< roomStateRoom rstate) + cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "" 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 + contextOptsVar <- asks ciContextOptionsVar + liftIO $ modifyMVar_ contextOptsVar $ return . first (const $ Just WatchChatrooms) void $ createChatroom (if T.null name then Nothing else Just name) Nothing @@ -785,9 +924,9 @@ let contacts = fromSetBy (comparing contactName) $ lookupSharedValue $ lsShared $ headObject ehead verbose = "-v" `elem` args set <- asks ciSetContextOptions - set $ map SelectedContact contacts - forM_ (zip [1..] contacts) $ \(i :: Int, c) -> liftIO $ do - T.putStrLn $ T.concat + set WatchContacts $ map SelectedContact contacts + 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 @@ -811,38 +950,39 @@ cmdConversations = do conversations <- lookupConversations set <- asks ciSetContextOptions - set $ map SelectedConversation conversations + set WatchConversations $ 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 getSelectedOrManualContext >>= \case SelectedPeer peer -> do - liftIO $ putStr $ unlines + paddr <- getPeerAddress peer + cmdPutStrLn $ unlines [ "Network peer:" - , " " <> show (peerAddress peer) + , " " <> show paddr ] - peerIdentity peer >>= \case - PeerIdentityUnknown _ -> liftIO $ do - putStrLn $ "unknown identity" - PeerIdentityRef wref _ -> liftIO $ do - putStrLn $ "Identity ref:" - putStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref) + getPeerIdentity peer >>= \case + 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 "") $ roomName =<< roomStateRoom rstate) + cmdPutStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "") $ 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 @@ -850,11 +990,11 @@ 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 @@ -863,117 +1003,28 @@ 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 "" T.unpack (idName cpid) ] , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid ] -cmdDiscoveryInit :: Command -cmdDiscoveryInit = void $ do - server <- asks ciServer - - (hostname, port) <- (words <$> asks ciLine) >>= return . \case - hostname:p:_ -> (hostname, p) - [hostname] -> (hostname, show discoveryPort) - [] -> ("discovery.erebosprotocol.net", show discoveryPort) - addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) - peer <- liftIO $ serverPeer server (addrAddress addr) - sendToPeer peer $ DiscoverySelf [ T.pack "ICE" ] Nothing - modify $ \s -> s { csIcePeer = Just peer } - cmdDiscovery :: Command cmdDiscovery = void $ do server <- asks ciServer - st <- getStorage sref <- asks ciLine - eprint <- asks ciPrint - liftIO $ readRef st (BC.pack sref) >>= \case - Nothing -> error "ref does not exist" - Just ref -> do - res <- runExceptT $ discoverySearch server ref - case res of - Right _ -> return () - Left err -> eprint err - -#ifdef ENABLE_ICE_SUPPORT - -cmdIceCreate :: Command -cmdIceCreate = do - let getRole = \case - 'm':_ -> PjIceSessRoleControlling - 's':_ -> PjIceSessRoleControlled - _ -> PjIceSessRoleUnknown - - ( role, stun, turn ) <- asks (words . ciLine) >>= \case - [] -> return ( PjIceSessRoleControlling, Nothing, Nothing ) - [ role ] -> return - ( getRole role, Nothing, Nothing ) - [ role, server ] -> return - ( getRole role - , Just ( T.pack server, 0 ) - , Just ( T.pack server, 0 ) - ) - [ role, server, port ] -> return - ( getRole role - , Just ( T.pack server, read port ) - , Just ( T.pack server, read port ) - ) - [ role, stunServer, stunPort, turnServer, turnPort ] -> return - ( getRole role - , Just ( T.pack stunServer, read stunPort ) - , Just ( T.pack turnServer, read turnPort ) - ) - _ -> throwError "invalid parameters" - - eprint <- asks ciPrint - Just cfg <- liftIO $ iceCreateConfig stun turn - sess <- liftIO $ iceCreateSession cfg role $ eprint <=< iceShow - modify $ \s -> s { csIceSessions = sess : csIceSessions s } - -cmdIceDestroy :: Command -cmdIceDestroy = do - s:ss <- gets csIceSessions - modify $ \st -> st { csIceSessions = ss } - liftIO $ iceDestroy s - -cmdIceShow :: Command -cmdIceShow = do - sess <- gets csIceSessions - eprint <- asks ciPrint - liftIO $ forM_ (zip [1::Int ..] sess) $ \(i, s) -> do - eprint $ "[" ++ show i ++ "]" - eprint =<< iceShow s - -cmdIceConnect :: Command -cmdIceConnect = do - s:_ <- gets csIceSessions - server <- asks ciServer - let loadInfo = BC.getLine >>= \case line | BC.null line -> return [] - | otherwise -> (line:) <$> loadInfo - Right remote <- liftIO $ do - st <- memoryStorage - pst <- derivePartialStorage st - rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo - copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes) - liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s - -cmdIceSend :: Command -cmdIceSend = void $ do - s:_ <- gets csIceSessions - server <- asks ciServer - liftIO $ serverPeerIce server s - -#endif + case readRefDigest (BC.pack sref) of + Nothing -> throwOtherError "failed to parse ref" + Just dgst -> discoverySearch server dgst cmdQuit :: Command cmdQuit = modify $ \s -> s { csQuit = True } diff --git a/main/State.hs b/main/State.hs new file mode 100644 --- /dev/null +++ b/main/State.hs @@ -0,0 +1,115 @@ +module State ( + loadLocalStateHead, + createLocalStateHead, + updateSharedIdentity, + interactiveIdentityUpdate, +) where + +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class + +import Data.Foldable +import Data.Proxy +import Data.Text (Text) +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 + :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m) + => Terminal -> m (Head LocalState) +loadLocalStateHead term = getStorage >>= loadHeads >>= \case + (h : _) -> return h + [] -> do + name <- liftIO $ do + setPrompt term "Name: " + getInputLine term $ KeepPrompt . maybe T.empty T.pack + + devName <- liftIO $ do + setPrompt term "Device: " + getInputLine term $ KeepPrompt . maybe T.empty T.pack + + ( owner, shared ) <- if + | T.null name -> do + return ( Nothing, [] ) + | otherwise -> do + owner <- createIdentity (Just name) Nothing + shared <- mstore SharedState + { ssPrev = [] + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy + , ssValue = [ storedRef $ idExtData owner ] + } + return ( Just owner, [ shared ] ) + + identity <- createIdentity (if T.null devName then Nothing else Just devName) owner + + st <- getStorage + storeHead st $ LocalState + { lsPrev = Nothing + , lsIdentity = idExtData identity + , lsShared = shared + , lsOther = [] + } + +createLocalStateHead + :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m) + => [ Maybe Text ] -> m (Head LocalState) +createLocalStateHead [] = throwOtherError "createLocalStateHead: empty name list" +createLocalStateHead ( ownerName : names ) = do + owner <- createIdentity ownerName Nothing + identity <- foldM createSingleIdentity owner names + shared <- case names of + [] -> return [] + _ : _ -> do + fmap (: []) $ mstore SharedState + { ssPrev = [] + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy + , ssValue = [ storedRef $ idExtData owner ] + } + st <- getStorage + storeHead st $ LocalState + { lsPrev = Nothing + , lsIdentity = idExtData identity + , lsShared = shared + , lsOther = [] + } + where + createSingleIdentity owner name = createIdentity name (Just owner) + + +updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m () +updateSharedIdentity term = updateLocalState_ $ updateSharedState_ $ \case + 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 --- /dev/null +++ b/main/Terminal.hs @@ -0,0 +1,421 @@ +{-# 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 ] + , termHistory :: TVar [ String ] + , termHistoryPos :: TVar Int + , termHistoryStash :: TVar ( String, String ) + } + +data TerminalLine = TerminalLine + { tlTerminal :: Terminal + , tlLineCount :: Int + } + +data Input + = InputChar Char + | InputMoveUp + | InputMoveDown + | InputMoveRight + | InputMoveLeft + | InputMoveEnd + | 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 [] + termHistory <- newTVarIO [] + termHistoryPos <- newTVarIO 0 + termHistoryStash <- 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 ( 'A' , [] ) -> return InputMoveUp + Just ( 'B' , [] ) -> return InputMoveDown + Just ( 'C' , [] ) -> return InputMoveRight + Just ( 'D' , [] ) -> return InputMoveLeft + _ -> return (InputEscape esc) + '\b' -> return InputBackspace + '\DEL' -> return InputBackspace + '\NAK' -> return InputClear + '\ETB' -> return InputBackWord + '\DLE' -> return InputMoveUp + '\SO' -> return InputMoveDown + '\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 + when termAnsi $ do + withMVar termLock $ \_ -> do + prompt <- atomically $ do + writeTVar termShowPrompt True + readTVar termPrompt + putStr $ prompt <> "\ESC[K" + drawBottomLines term + hFlush stdout + + mbLine <- go + forM_ mbLine $ \line -> do + let addLine xs + | null line = xs + | (x : _) <- xs, x == line = xs + | otherwise = line : xs + atomically $ do + writeTVar termHistory . addLine =<< readTVar termHistory + writeTVar termHistoryPos 0 + + case handleResult mbLine of + KeepPrompt x -> do + when termAnsi $ do + termPutStr term "\n\ESC[J" + return x + ErasePrompt x -> do + when termAnsi $ do + termPutStr term "\r\ESC[J" + return x + where + go = getInput >>= \case + InputChar '\n' -> do + atomically $ do + ( pre, post ) <- readTVar termInput + writeTVar termInput ( "", "" ) + when termAnsi $ do + writeTVar termShowPrompt False + writeTVar termBottomLines [] + return $ Just $ pre ++ post + + InputChar '\t' | termAnsi -> 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 | T.unpack common /= pre -> do + updatePrompt $ T.unpack unused ++ T.unpack common + return [] + _ -> do + 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 + + InputMoveUp -> withInput $ \prepost -> do + hist <- readTVar termHistory + pos <- readTVar termHistoryPos + case drop pos hist of + ( h : _ ) -> do + when (pos == 0) $ do + writeTVar termHistoryStash prepost + writeTVar termHistoryPos (pos + 1) + writeTVar termInput ( h, "" ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + [] -> do + return "" + + InputMoveDown -> withInput $ \_ -> do + readTVar termHistoryPos >>= \case + 0 -> do + return "" + 1 -> do + writeTVar termHistoryPos 0 + writeTVar termInput =<< readTVar termHistoryStash + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + pos -> do + writeTVar termHistoryPos (pos - 1) + hist <- readTVar termHistory + case drop (pos - 2) hist of + ( h : _ ) -> do + writeTVar termInput ( h, "" ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + [] -> do + return "" + + InputMoveRight -> withInput $ \case + ( pre, c : post ) -> do + writeTVar termInput ( pre ++ [ c ], post ) + 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 (termAnsi && 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 Terminal { termAnsi = False } _ = do + return () +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 + let strLines = lines str + tlLineCount = length strLines + if termAnsi + then do + promptLine <- atomically $ do + readTVar termShowPrompt >>= \case + True -> getCurrentPromptLine tlTerminal + False -> return "" + putStr $ "\r\ESC[K" <> unlines strLines <> "\ESC[K" <> promptLine + drawBottomLines tlTerminal + else do + putStr $ unlines strLines + + hFlush stdout + return TerminalLine {..} + + +printBottomLines :: Terminal -> String -> IO () +printBottomLines Terminal { termAnsi = False } _ = do + return () +printBottomLines term@Terminal {..} str = do + case lines str of + [] -> clearBottomLines term + blines -> do + withMVar termLock $ \_ -> do + atomically $ writeTVar termBottomLines blines + drawBottomLines term + hFlush stdout + +clearBottomLines :: Terminal -> IO () +clearBottomLines Terminal { termAnsi = False } = do + return () +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 --- a/main/Test.hs +++ b/main/Test.hs @@ -26,7 +26,7 @@ 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 @@ -36,17 +36,20 @@ 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 @@ -64,10 +67,17 @@ 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 @@ -101,7 +111,7 @@ 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) @@ -135,17 +145,20 @@ 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 () @@ -173,7 +186,7 @@ , 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" } @@ -214,21 +227,28 @@ { dmOwnerMismatch = afterCommit $ outLine out "dm-owner-mismatch" } -dmReceivedWatcher :: Output -> Stored DirectMessage -> IO () -dmReceivedWatcher out smsg = do - let msg = fromStored smsg - outLine out $ unwords - [ "dm-received" - , "from", maybe "" T.unpack $ idName $ msgFrom msg - , "text", T.unpack $ msgText msg - ] +discoveryAttributes :: DiscoveryAttributes +discoveryAttributes = (defaultServiceAttributes Proxy) + { discoveryProvideTunnel = \_ _ -> False + } +dmThreadWatcher :: ComposedIdentity -> Output -> DirectMessageThread -> DirectMessageThread -> IO () +dmThreadWatcher self out prev cur = do + forM_ (reverse $ dmThreadToListSince prev cur) $ \msg -> do + outLine out $ unwords + [ if sameIdentity self (msgFrom msg) + then "dm-sent" + else "dm-received" + , "from", maybe "" T.unpack $ idName $ msgFrom msg + , "text", T.unpack $ msgText msg + ] -newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String) +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 @@ -245,72 +265,85 @@ type Command = CommandM () -commands :: [(Text, Command)] -commands = map (T.pack *** id) - [ ("store", cmdStore) - , ("load", cmdLoad) - , ("stored-generation", cmdStoredGeneration) - , ("stored-roots", cmdStoredRoots) - , ("stored-set-add", cmdStoredSetAdd) - , ("stored-set-list", cmdStoredSetList) - , ("head-create", cmdHeadCreate) - , ("head-replace", cmdHeadReplace) - , ("head-watch", cmdHeadWatch) - , ("head-unwatch", cmdHeadUnwatch) - , ("create-identity", cmdCreateIdentity) - , ("identity-info", cmdIdentityInfo) - , ("start-server", cmdStartServer) - , ("stop-server", cmdStopServer) - , ("peer-add", cmdPeerAdd) - , ("peer-drop", cmdPeerDrop) - , ("peer-list", cmdPeerList) - , ("test-message-send", cmdTestMessageSend) - , ("local-state-get", cmdLocalStateGet) - , ("local-state-replace", cmdLocalStateReplace) - , ("local-state-wait", cmdLocalStateWait) - , ("shared-state-get", cmdSharedStateGet) - , ("shared-state-wait", cmdSharedStateWait) - , ("watch-local-identity", cmdWatchLocalIdentity) - , ("watch-shared-identity", cmdWatchSharedIdentity) - , ("update-local-identity", cmdUpdateLocalIdentity) - , ("update-shared-identity", cmdUpdateSharedIdentity) - , ("attach-to", cmdAttachTo) - , ("attach-accept", cmdAttachAccept) - , ("attach-reject", cmdAttachReject) - , ("contact-request", cmdContactRequest) - , ("contact-accept", cmdContactAccept) - , ("contact-reject", cmdContactReject) - , ("contact-list", cmdContactList) - , ("contact-set-name", cmdContactSetName) - , ("dm-send-peer", cmdDmSendPeer) - , ("dm-send-contact", cmdDmSendContact) - , ("dm-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) - , ("chatroom-subscribe", cmdChatroomSubscribe) - , ("chatroom-unsubscribe", cmdChatroomUnsubscribe) - , ("chatroom-members", cmdChatroomMembers) - , ("chatroom-join", cmdChatroomJoin) - , ("chatroom-join-as", cmdChatroomJoinAs) - , ("chatroom-leave", cmdChatroomLeave) - , ("chatroom-message-send", cmdChatroomMessageSend) - , ("discovery-connect", cmdDiscoveryConnect) +commands :: [ ( Text, Command ) ] +commands = + [ ( "store", cmdStore ) + , ( "load", cmdLoad ) + , ( "stored-generation", cmdStoredGeneration ) + , ( "stored-roots", cmdStoredRoots ) + , ( "stored-set-add", cmdStoredSetAdd ) + , ( "stored-set-list", cmdStoredSetList ) + , ( "stored-difference", cmdStoredDifference ) + , ( "head-create", cmdHeadCreate ) + , ( "head-replace", cmdHeadReplace ) + , ( "head-watch", cmdHeadWatch ) + , ( "head-unwatch", cmdHeadUnwatch ) + , ( "create-identity", cmdCreateIdentity ) + , ( "identity-info", cmdIdentityInfo ) + , ( "start-server", cmdStartServer ) + , ( "stop-server", cmdStopServer ) + , ( "peer-add", cmdPeerAdd ) + , ( "peer-drop", cmdPeerDrop ) + , ( "peer-list", cmdPeerList ) + , ( "test-message-send", cmdTestMessageSend ) + , ( "test-stream-open", cmdTestStreamOpen ) + , ( "test-stream-close", cmdTestStreamClose ) + , ( "test-stream-send", cmdTestStreamSend ) + , ( "local-state-get", cmdLocalStateGet ) + , ( "local-state-replace", cmdLocalStateReplace ) + , ( "local-state-wait", cmdLocalStateWait ) + , ( "shared-state-get", cmdSharedStateGet ) + , ( "shared-state-wait", cmdSharedStateWait ) + , ( "watch-local-identity", cmdWatchLocalIdentity ) + , ( "watch-shared-identity", cmdWatchSharedIdentity ) + , ( "update-local-identity", cmdUpdateLocalIdentity ) + , ( "update-shared-identity", cmdUpdateSharedIdentity ) + , ( "attach-to", cmdAttachTo ) + , ( "attach-accept", cmdAttachAccept ) + , ( "attach-reject", cmdAttachReject ) + , ( "contact-request", cmdContactRequest ) + , ( "contact-accept", cmdContactAccept ) + , ( "contact-reject", cmdContactReject ) + , ( "contact-list", cmdContactList ) + , ( "contact-set-name", cmdContactSetName ) + , ( "dm-send-peer", cmdDmSendPeer ) + , ( "dm-send-contact", cmdDmSendContact ) + , ( "dm-send-identity", cmdDmSendIdentity ) + , ( "dm-list-peer", cmdDmListPeer ) + , ( "dm-list-contact", cmdDmListContact ) + , ( "chatroom-create", cmdChatroomCreate ) + , ( "chatroom-delete", cmdChatroomDelete ) + , ( "chatroom-list-local", cmdChatroomListLocal ) + , ( "chatroom-watch-local", cmdChatroomWatchLocal ) + , ( "chatroom-set-name", cmdChatroomSetName ) + , ( "chatroom-subscribe", cmdChatroomSubscribe ) + , ( "chatroom-unsubscribe", cmdChatroomUnsubscribe ) + , ( "chatroom-members", cmdChatroomMembers ) + , ( "chatroom-join", cmdChatroomJoin ) + , ( "chatroom-join-as", cmdChatroomJoinAs ) + , ( "chatroom-leave", cmdChatroomLeave ) + , ( "chatroom-message-send", cmdChatroomMessageSend ) + , ( "discovery-connect", cmdDiscoveryConnect ) + , ( "discovery-tunnel", cmdDiscoveryTunnel ) ] 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 @@ -345,7 +378,7 @@ [Just iref, Just sref] -> return (wrappedLoad iref, loadSet @[Stored Object] sref) [Just iref] -> return (wrappedLoad iref, emptySet) _ -> fail "unexpected parameters" - set' <- storeSetAdd st [item] set + set' <- storeSetAdd [ item ] set cmdOut $ "stored-set-add" ++ concatMap ((' ':) . show . refDigest . storedRef) (toComponents set') cmdStoredSetList :: Command @@ -358,6 +391,19 @@ cmdOut $ "stored-set-item" ++ concatMap ((' ':) . show . refDigest . storedRef) item cmdOut $ "stored-set-done" +cmdStoredDifference :: Command +cmdStoredDifference = do + st <- asks tiStorage + ( trefs1, "|" : trefs2 ) <- span (/= "|") <$> asks tiParams + + let loadObjs = mapM (maybe (fail "invalid ref") (return . wrappedLoad @Object) <=< liftIO . readRef st . encodeUtf8) + objs1 <- loadObjs trefs1 + objs2 <- loadObjs trefs2 + + forM_ (storedDifference objs1 objs2) $ \item -> do + cmdOut $ "stored-difference-item " ++ (show $ refDigest $ storedRef item) + cmdOut $ "stored-difference-done" + cmdHeadCreate :: Command cmdHeadCreate = do [ ttid, tref ] <- asks tiParams @@ -412,7 +458,8 @@ initTestHead :: Head LocalState -> Command initTestHead h = do - _ <- liftIO . watchReceivedMessages h . dmReceivedWatcher =<< asks tiOutput + let self = finalOwner $ headLocalIdentity h + _ <- liftIO . watchDirectMessageThreads h . dmThreadWatcher self =<< asks tiOutput modify $ \s -> s { tsHead = Just h } loadTestHead :: CommandM (Head LocalState) @@ -435,17 +482,18 @@ st <- asks tiStorage names <- asks tiParams - h <- liftIO $ do + h <- do Just identity <- if null names - then Just <$> createIdentity st Nothing Nothing - else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names + then Just <$> createIdentity Nothing Nothing + else foldrM (\n o -> Just <$> createIdentity (Just n) o) Nothing names shared <- case names of - _:_:_ -> (:[]) <$> makeSharedStateUpdate st (Just $ finalOwner identity) [] + _:_:_ -> (: []) <$> makeSharedStateUpdate (Just $ finalOwner identity) [] _ -> return [] storeHead st $ LocalState - { lsIdentity = idExtData identity + { lsPrev = Nothing + , lsIdentity = idExtData identity , lsShared = shared , lsOther = [] } @@ -473,43 +521,79 @@ let parseParams = \case (name : value : rest) - | name == "services" -> T.splitOn "," value + | name == "services" -> second ( map splitServiceParams (T.splitOn "," value) ++ ) (parseParams rest) + (name : rest) + | name == "test-log" -> first (\o -> o { serverTestLog = True }) (parseParams rest) | otherwise -> parseParams rest - _ -> [] - serviceNames <- parseParams <$> asks tiParams + _ -> ( defaultServerOptions { serverErrorPrefix = "server-error-message " }, [] ) + splitServiceParams svc = + case T.splitOn ":" svc of + name : params -> ( name, params ) + _ -> ( svc, [] ) + + ( serverOptions, serviceNames ) <- parseParams <$> asks tiParams + h <- getOrLoadHead rsPeers <- liftIO $ newMVar (1, []) services <- forM serviceNames $ \case - "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" - "chatroom" -> return $ someService @ChatroomService Proxy - "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" - "discovery" -> return $ someService @DiscoveryService Proxy - "dm" -> return $ someServiceAttr $ directMessageAttributes out - "sync" -> return $ someService @SyncService Proxy - "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) + ( "attach", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" + ( "chatroom", _ ) -> return $ someService @ChatroomService Proxy + ( "contact", _ ) -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" + ( "discovery", params ) -> return $ someServiceAttr $ discoveryAttributes + { discoveryProvideTunnel = \_ _ -> "tunnel" `elem` params + } + ( "dm", _ ) -> return $ someServiceAttr $ directMessageAttributes out + ( "sync", _ ) -> return $ someService @SyncService Proxy + ( "test", _ ) -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) { testMessageReceived = \obj otype len sref -> do liftIO $ do void $ store (headStorage h) obj - outLine out $ unwords ["test-message-received", otype, len, sref] + outLine out $ unwords [ "test-message-received", otype, len, sref ] + , testStreamsReceived = \streams -> do + pidx <- getPeerIndex rsPeers + liftIO $ do + nums <- mapM getStreamReaderNumber streams + outLine out $ unwords $ "test-stream-open-from" : show pidx : map show nums + forM_ (zip nums streams) $ \( num, stream ) -> void $ forkIO $ do + let go = readStreamPacket stream >>= \case + StreamData seqNum bytes -> do + outLine out $ unwords [ "test-stream-received", show pidx, show num, show seqNum, BC.unpack bytes ] + go + StreamClosed seqNum -> do + outLine out $ unwords [ "test-stream-closed-from", show pidx, show num, show seqNum ] + go } - sname -> throwError $ "unknown service `" <> T.unpack sname <> "'" + ( sname, _ ) -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" - rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services + let logPrint str = do BC.hPutStrLn stdout (BC.pack str) + hFlush stdout + rsServer <- liftIO $ startServer serverOptions h logPrint services rsPeerThread <- liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange rsServer - let printPeer (idx, p) = do - params <- peerIdentity p >>= return . \case - PeerIdentityFull pid -> ("id":) $ map (maybe "" T.unpack . idName) (unfoldOwners pid) - _ -> [ "addr", show (peerAddress p) ] - outLine out $ unwords $ [ "peer", show idx ] ++ params + let printPeer TestPeer {..} = do + params <- getPeerIdentity tpPeer >>= \case + PeerIdentityFull pid -> do + return $ ("id":) $ map (maybe "" T.unpack . idName) (unfoldOwners pid) + _ -> do + paddr <- getPeerAddress tpPeer + return $ [ "addr", show paddr ] + outLine out $ unwords $ [ "peer", show tpIndex ] ++ params - update (nid, []) = printPeer (nid, peer) >> return (nid + 1, [(nid, peer)]) - update cur@(nid, p:ps) | snd p == peer = printPeer p >> return cur - | otherwise = fmap (p:) <$> update (nid, ps) + update ( tpIndex, [] ) = do + tpPeer <- return peer + tpStreamReaders <- newMVar [] + tpStreamWriters <- newMVar [] + let tp = TestPeer {..} + printPeer tp + return ( tpIndex + 1, [ tp ] ) + update cur@( nid, p : ps ) + | tpPeer p == peer = printPeer p >> return cur + | otherwise = fmap (p :) <$> update ( nid, ps ) + modifyMVar_ rsPeers update modify $ \s -> s { tsServer = Just RunningServer {..} } @@ -545,11 +629,12 @@ peers <- liftIO $ getCurrentPeerList rsServer tpeers <- liftIO $ readMVar rsPeers forM_ peers $ \peer -> do - Just (n, _) <- return $ find ((peer==).snd) . snd $ tpeers - mbpid <- peerIdentity peer + Just tp <- return $ find ((peer ==) . tpPeer) . snd $ tpeers + mbpid <- getPeerIdentity peer + paddr <- getPeerAddress peer cmdOut $ unwords $ concat - [ [ "peer-list-item", show n ] - , [ "addr", show (peerAddress peer) ] + [ [ "peer-list-item", show (tpIndex tp) ] + , [ "addr", show paddr ] , case mbpid of PeerIdentityFull pid -> ("id":) $ map (maybe "" T.unpack . idName) (unfoldOwners pid) _ -> [] ] @@ -565,6 +650,40 @@ sendManyToPeer peer $ map (TestMessage . wrappedLoad) refs cmdOut "test-message-send done" +cmdTestStreamOpen :: Command +cmdTestStreamOpen = do + spidx : rest <- asks tiParams + tp <- getTestPeer spidx + count <- case rest of + [] -> return 1 + tcount : _ -> return $ read $ T.unpack tcount + + out <- asks tiOutput + runPeerService (tpPeer tp) $ do + streams <- openTestStreams count + afterCommit $ do + nums <- mapM getStreamWriterNumber streams + modifyMVar_ (tpStreamWriters tp) $ return . (++ zip nums streams) + outLine out $ unwords $ "test-stream-open-done" + : T.unpack spidx + : map show nums + +cmdTestStreamClose :: Command +cmdTestStreamClose = do + [ spidx, sid ] <- asks tiParams + tp <- getTestPeer spidx + Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp)) + liftIO $ closeStream stream + cmdOut $ unwords [ "test-stream-close-done", T.unpack spidx, T.unpack sid ] + +cmdTestStreamSend :: Command +cmdTestStreamSend = do + [ spidx, sid, content ] <- asks tiParams + tp <- getTestPeer spidx + Just stream <- lookup (read $ T.unpack sid) <$> liftIO (readMVar (tpStreamWriters tp)) + liftIO $ writeStream stream $ encodeUtf8 content + cmdOut $ unwords [ "test-stream-send-done", T.unpack spidx, T.unpack sid ] + cmdLocalStateGet :: Command cmdLocalStateGet = do h <- getHead @@ -637,7 +756,7 @@ cmdUpdateLocalIdentity :: Command cmdUpdateLocalIdentity = do [name] <- asks tiParams - updateLocalHead_ $ \ls -> do + updateLocalState_ $ \ls -> do Just identity <- return $ validateExtendedIdentity $ lsIdentity $ fromStored ls let public = idKeyIdentity identity @@ -652,8 +771,8 @@ 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 @@ -722,13 +841,13 @@ 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 cmdDmSendPeer = do [spidx, msg] <- asks tiParams - PeerIdentityFull to <- peerIdentity =<< getPeer spidx + PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx void $ sendDirectMessage to msg cmdDmSendContact :: Command @@ -747,10 +866,10 @@ dmList :: Foldable f => Identity f -> Command dmList peer = do - threads <- toThreadList . lookupSharedValue . lsShared . headObject <$> getHead + threads <- dmThreadList . lookupSharedValue . lsShared . headObject <$> getHead case find (sameIdentity peer . msgPeer) threads of Just thread -> do - forM_ (reverse $ threadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item" + forM_ (reverse $ dmThreadToList thread) $ \DirectMessage {..} -> cmdOut $ "dm-list-item" <> " from " <> (maybe "" T.unpack $ idName msgFrom) <> " text " <> (T.unpack msgText) Nothing -> return () @@ -759,7 +878,7 @@ cmdDmListPeer :: Command cmdDmListPeer = do [spidx] <- asks tiParams - PeerIdentityFull to <- peerIdentity =<< getPeer spidx + PeerIdentityFull to <- getPeerIdentity =<< getPeer spidx dmList to cmdDmListContact :: Command @@ -867,8 +986,7 @@ cmdChatroomJoinAs :: Command cmdChatroomJoinAs = do [ cid, name ] <- asks tiParams - st <- asks tiStorage - identity <- liftIO $ createIdentity st (Just name) Nothing + identity <- createIdentity (Just name) Nothing joinChatroomAsByStateData identity =<< getChatroomStateData cid cmdOut $ unwords [ "chatroom-join-as-done", T.unpack cid ] @@ -886,8 +1004,14 @@ cmdDiscoveryConnect :: Command cmdDiscoveryConnect = do - st <- asks tiStorage [ tref ] <- asks tiParams - Just ref <- liftIO $ readRef st $ encodeUtf8 tref + Just dgst <- return $ readRefDigest $ encodeUtf8 tref Just RunningServer {..} <- gets tsServer - discoverySearch rsServer ref + discoverySearch rsServer dgst + +cmdDiscoveryTunnel :: Command +cmdDiscoveryTunnel = do + [ tvia, ttarget ] <- asks tiParams + via <- getPeer tvia + Just target <- return $ readRefDigest $ encodeUtf8 ttarget + liftIO $ discoverySetupTunnel via target diff --git a/main/Test/Service.hs b/main/Test/Service.hs --- 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 :: Object -> String -> String -> String -> ServiceHandler TestMessage () + , testStreamsReceived :: [ StreamReader ] -> ServiceHandler TestMessage () } instance Storable TestMessage where @@ -25,7 +31,10 @@ 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 @@ -35,3 +44,14 @@ cb <- asks $ testMessageReceived . svcAttributes cb obj otype len (show $ refDigest $ storedRef sobj) _ -> return () + + streams <- receivedStreams + when (not $ null streams) $ do + cb <- asks $ testStreamsReceived . svcAttributes + cb streams + + +openTestStreams :: Int -> ServiceHandler TestMessage [ StreamWriter ] +openTestStreams count = do + replyPacket . TestMessage =<< mstore (Rec []) + replicateM count openStream diff --git a/main/WebSocket.hs b/main/WebSocket.hs new file mode 100644 --- /dev/null +++ b/main/WebSocket.hs @@ -0,0 +1,48 @@ +module WebSocket ( + WebSocketAddress(..), + 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 + connectionToAddressClosed (WebSocketAddress _ conn) = do + WS.sendClose conn BL.empty + +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 --- a/src/Erebos/Attach.hs +++ b/src/Erebos/Attach.hs @@ -20,7 +20,7 @@ import Erebos.PubKey import Erebos.Service import Erebos.State -import Erebos.Storage +import Erebos.Storable import Erebos.Storage.Key type AttachService = PairingService AttachIdentity @@ -52,14 +52,14 @@ 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 ] liftIO $ mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- keys, pub <- pkeys ] identity' <- mergeIdentity $ updateIdentity [ lsIdentity $ fromStored slocal ] identity - shared <- makeSharedStateUpdate st (Just owner) (lsShared $ fromStored slocal) + shared <- makeSharedStateUpdate (Just owner) (lsShared $ fromStored slocal) mstore (fromStored slocal) { lsIdentity = idExtData identity' , lsShared = [ shared ] @@ -113,11 +113,11 @@ 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/Channel.hs b/src/Erebos/Channel.hs deleted file mode 100644 --- a/src/Erebos/Channel.hs +++ /dev/null @@ -1,175 +0,0 @@ -module Erebos.Channel ( - Channel, - ChannelRequest, ChannelRequestData(..), - ChannelAccept, ChannelAcceptData(..), - - createChannelRequest, - acceptChannelRequest, - acceptedChannel, - - channelEncrypt, - channelDecrypt, -) where - -import Control.Concurrent.MVar -import Control.Monad -import Control.Monad.Except -import Control.Monad.IO.Class - -import Crypto.Cipher.ChaChaPoly1305 -import Crypto.Error - -import Data.Binary -import Data.ByteArray (ByteArray, Bytes, ScrubbedBytes, convert) -import Data.ByteArray qualified as BA -import Data.ByteString.Lazy qualified as BL -import Data.List - -import Erebos.Identity -import Erebos.PubKey -import Erebos.Storage - -data Channel = Channel - { chPeers :: [Stored (Signed IdentityData)] - , chKey :: ScrubbedBytes - , chNonceFixedOur :: Bytes - , chNonceFixedPeer :: Bytes - , chCounterNextOut :: MVar Word64 - , chCounterNextIn :: MVar Word64 - } - -type ChannelRequest = Signed ChannelRequestData - -data ChannelRequestData = ChannelRequest - { crPeers :: [Stored (Signed IdentityData)] - , crKey :: Stored PublicKexKey - } - deriving (Show) - -type ChannelAccept = Signed ChannelAcceptData - -data ChannelAcceptData = ChannelAccept - { caRequest :: Stored ChannelRequest - , caKey :: Stored PublicKexKey - } - - -instance Storable ChannelRequestData where - store' cr = storeRec $ do - mapM_ (storeRef "peer") $ crPeers cr - storeRef "key" $ crKey cr - - load' = loadRec $ do - ChannelRequest - <$> loadRefs "peer" - <*> loadRef "key" - -instance Storable ChannelAcceptData where - store' ca = storeRec $ do - storeRef "req" $ caRequest ca - storeRef "key" $ caKey ca - - load' = loadRec $ do - ChannelAccept - <$> loadRef "req" - <*> loadRef "key" - - -keySize :: Int -keySize = 32 - -createChannelRequest :: (MonadStorage m, MonadIO m, MonadError String m) => 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 self peer req = do - case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of - Nothing -> throwError $ "invalid peers in channel request" - Just peers -> do - when (not $ any (self `sameIdentity`) peers) $ - throwError $ "self identity missing in channel request peers" - when (not $ any (peer `sameIdentity`) peers) $ - throwError $ "peer identity missing in channel request peers" - when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $ - throwError $ "channel requent not signed by peer" - - (xsecret, xpublic) <- liftIO . generateKeys =<< getStorage - skey <- loadKey $ idKeyMessage self - acc <- mstore =<< sign skey =<< mstore ChannelAccept { caRequest = req, caKey = xpublic } - liftIO $ do - let chPeers = crPeers $ fromStored $ signedData $ fromStored req - chKey = BA.take keySize $ dhSecret xsecret $ - fromStored $ crKey $ fromStored $ signedData $ fromStored req - chNonceFixedOur = BA.pack [ 2, 0, 0, 0 ] - chNonceFixedPeer = BA.pack [ 1, 0, 0, 0 ] - chCounterNextOut <- newMVar 0 - chCounterNextIn <- newMVar 0 - - return (acc, Channel {..}) - -acceptedChannel :: (MonadIO m, MonadError String m) => 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" - Just peers -> do - when (not $ any (self `sameIdentity`) peers) $ - throwError $ "self identity missing in channel accept peers" - when (not $ any (peer `sameIdentity`) peers) $ - throwError $ "peer identity missing in channel accept peers" - when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)) $ - throwError $ "channel accept not signed by peer" - when (idKeyMessage self `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $ - throwError $ "original channel request not signed by us" - - xsecret <- loadKey $ crKey $ fromStored $ signedData $ fromStored req - let chPeers = crPeers $ fromStored $ signedData $ fromStored req - chKey = BA.take keySize $ dhSecret xsecret $ - fromStored $ caKey $ fromStored $ signedData $ fromStored acc - chNonceFixedOur = BA.pack [ 1, 0, 0, 0 ] - chNonceFixedPeer = BA.pack [ 2, 0, 0, 0 ] - chCounterNextOut <- liftIO $ newMVar 0 - chCounterNextIn <- liftIO $ newMVar 0 - - return Channel {..} - - -channelEncrypt :: (ByteArray ba, MonadIO m, MonadError String m) => 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 - - 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 Channel {..} body = do - when (BA.length body < 17) $ do - throwError $ "invalid encrypted data length" - - expectedCount <- liftIO $ readMVar chCounterNextIn - let countByte = body `BA.index` 0 - body' = BA.dropView body 1 - guessedCount = expectedCount - 128 + fromIntegral (countByte - fromIntegral expectedCount + 128 :: Word8) - nonce = nonce8 chNonceFixedPeer $ convert $ BL.toStrict $ encode guessedCount - blen = BA.length body' - 16 - ctext = BA.takeView body' blen - 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 - - let (plain, state') = decrypt (convert ctext) state - when (not $ tag `BA.constEq` finalize state') $ do - throwError $ "tag validation falied" - - liftIO $ modifyMVar_ chCounterNextIn $ return . max (guessedCount + 1) - return (plain, guessedCount) diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -17,6 +17,7 @@ joinChatroomAs, joinChatroomAsByStateData, leaveChatroom, leaveChatroomByStateData, getMessagesSinceState, + isSameChatroom, ChatroomSetChange(..), watchChatrooms, @@ -54,7 +55,8 @@ 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 @@ -180,17 +182,17 @@ 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 Nothing (Just msg) False sendRawChatroomMessageByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (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 @@ -282,7 +284,7 @@ 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 = [] @@ -292,31 +294,29 @@ , rsdSubscribe = Just True } - updateLocalHead $ updateSharedState $ \rooms -> do - st <- getStorage - (, cstate) <$> storeSetAdd st cstate rooms + updateLocalState $ updateSharedState $ \rooms -> do + (, cstate) <$> storeSetAdd cstate rooms findAndUpdateChatroomState :: (MonadStorage m, MonadHead LocalState m) => (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 upd <- act if roomStateData orig /= roomStateData upd then do - st <- getStorage - roomSet' <- storeSetAdd st upd roomSet + roomSet' <- storeSetAdd upd roomSet return (roomSet', Just upd) else do return (roomSet, Just upd) [] -> return (roomSet, Nothing) deleteChatroomByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (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 @@ -327,7 +327,7 @@ } 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 @@ -368,7 +368,7 @@ 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 @@ -389,39 +389,44 @@ 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 Nothing False joinChatroomAs - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (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 String m) + :: (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 Nothing True getMessagesSinceState :: ChatroomState -> ChatroomState -> [ChatMessage] getMessagesSinceState cur old = threadToListSince (roomStateMessageData old) (roomStateMessageData cur) +isSameChatroom :: ChatroomState -> ChatroomState -> Bool +isSameChatroom rstate rstate' = + let roots = filterAncestors . concatMap storedRoots . roomStateData + in intersectsSorted (roots rstate) (roots rstate') + data ChatroomSetChange = AddedChatroom ChatroomState | RemovedChatroom ChatroomState | UpdatedChatroom ChatroomState ChatroomState @@ -522,7 +527,7 @@ } 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 @@ -561,7 +566,7 @@ 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 diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs --- a/src/Erebos/Contact.hs +++ b/src/Erebos/Contact.hs @@ -28,7 +28,7 @@ import Erebos.Service import Erebos.Set import Erebos.State -import Erebos.Storage +import Erebos.Storable import Erebos.Storage.Merge data Contact = Contact @@ -83,13 +83,12 @@ contactSetName :: MonadHead LocalState m => Contact -> Text -> Set Contact -> m (Set Contact) contactSetName contact name set = do - st <- getStorage - cdata <- wrappedStore st ContactData + cdata <- mstore ContactData { cdPrev = toComponents contact , cdIdentity = [] , cdName = Just name } - storeSetAdd st (mergeSorted @Contact [cdata]) set + storeSetAdd (mergeSorted @Contact [cdata]) set type ContactService = PairingService ContactAccepted @@ -155,21 +154,20 @@ 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 - st <- getStorage - cdata <- wrappedStore st ContactData +finalizeContact identity = updateLocalState_ $ updateSharedState_ $ \contacts -> do + cdata <- mstore ContactData { cdPrev = [] , cdIdentity = idExtDataF $ finalOwner identity , cdName = Nothing } - storeSetAdd st (mergeSorted @Contact [cdata]) contacts + storeSetAdd (mergeSorted @Contact [cdata]) contacts diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs --- a/src/Erebos/Conversation.hs +++ b/src/Erebos/Conversation.hs @@ -7,9 +7,11 @@ formatMessage, Conversation, + isSameConversation, directMessageConversation, chatroomConversation, chatroomConversationByStateData, + isChatroomStateConversation, reloadConversation, lookupConversations, @@ -30,11 +32,11 @@ 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 @@ -64,12 +66,20 @@ ] -data Conversation = DirectMessageConversation DirectMessageThread - | ChatroomConversation ChatroomState +data Conversation + = DirectMessageConversation DirectMessageThread + | ChatroomConversation ChatroomState +isSameConversation :: Conversation -> Conversation -> Bool +isSameConversation (DirectMessageConversation t) (DirectMessageConversation t') + = sameIdentity (msgPeer t) (msgPeer t') +isSameConversation (ChatroomConversation rstate) (ChatroomConversation rstate') = isSameChatroom rstate rstate' +isSameConversation _ _ = False + directMessageConversation :: MonadHead LocalState m => ComposedIdentity -> m Conversation directMessageConversation peer = do - (find (sameIdentity peer . msgPeer) . toThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead) >>= \case + createOrUpdateDirectMessagePeer peer + (find (sameIdentity peer . msgPeer) . dmThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead) >>= \case Just thread -> return $ DirectMessageConversation thread Nothing -> return $ DirectMessageConversation $ DirectMessageThread peer [] [] [] [] @@ -79,13 +89,17 @@ chatroomConversationByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> m (Maybe Conversation) chatroomConversationByStateData sdata = fmap ChatroomConversation <$> findChatroomByStateData sdata +isChatroomStateConversation :: ChatroomState -> Conversation -> Bool +isChatroomStateConversation rstate (ChatroomConversation rstate') = isSameChatroom rstate rstate' +isChatroomStateConversation _ _ = False + reloadConversation :: MonadHead LocalState m => Conversation -> m Conversation reloadConversation (DirectMessageConversation thread) = directMessageConversation (msgPeer thread) reloadConversation cur@(ChatroomConversation rstate) = fromMaybe cur <$> chatroomConversation rstate -lookupConversations :: MonadHead LocalState m => m [Conversation] -lookupConversations = map DirectMessageConversation . toThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead +lookupConversations :: MonadHead LocalState m => m [ Conversation ] +lookupConversations = map DirectMessageConversation . dmThreadList . lookupSharedValue . lsShared . fromStored <$> getLocalHead conversationName :: Conversation -> Text @@ -96,15 +110,15 @@ conversationPeer (DirectMessageConversation thread) = Just $ msgPeer thread conversationPeer (ChatroomConversation _) = Nothing -conversationHistory :: Conversation -> [Message] -conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMessageMessage msg False) $ threadToList thread +conversationHistory :: Conversation -> [ Message ] +conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMessageMessage msg False) $ dmThreadToList thread conversationHistory (ChatroomConversation rstate) = map (\msg -> ChatroomMessage msg False) $ roomStateMessages rstate -sendMessage :: (MonadHead LocalState m, MonadError String m) => 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 +sendMessage :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> Text -> m () +sendMessage (DirectMessageConversation thread) text = sendDirectMessage (msgPeer thread) text +sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text -deleteConversation :: (MonadHead LocalState m, MonadError String m) => Conversation -> m () -deleteConversation (DirectMessageConversation _) = throwError "deleting direct message conversation is not supported" +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/DirectMessage.hs b/src/Erebos/DirectMessage.hs new file mode 100644 --- /dev/null +++ b/src/Erebos/DirectMessage.hs @@ -0,0 +1,345 @@ +module Erebos.DirectMessage ( + DirectMessage(..), + sendDirectMessage, + updateDirectMessagePeer, + createOrUpdateDirectMessagePeer, + + DirectMessageAttributes(..), + defaultDirectMessageAttributes, + + DirectMessageThreads, + dmThreadList, + + DirectMessageThread(..), + dmThreadToList, dmThreadToListSince, + dmThreadView, + + watchDirectMessageThreads, + formatDirectMessage, +) where + +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader + +import Data.List +import Data.Ord +import Data.Set (Set) +import Data.Set qualified as S +import Data.Text (Text) +import Data.Text qualified 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.Storable +import Erebos.Storage.Head +import Erebos.Storage.Merge + +data DirectMessage = DirectMessage + { msgFrom :: ComposedIdentity + , msgPrev :: [ Stored DirectMessage ] + , msgTime :: ZonedTime + , msgText :: Text + } + +instance Storable DirectMessage where + store' msg = storeRec $ do + mapM_ (storeRef "from") $ idExtDataF $ msgFrom msg + mapM_ (storeRef "PREV") $ msgPrev msg + storeDate "time" $ msgTime msg + storeText "text" $ msgText msg + + load' = loadRec $ DirectMessage + <$> loadIdentity "from" + <*> loadRefs "PREV" + <*> loadDate "time" + <*> loadText "text" + +data DirectMessageAttributes = DirectMessageAttributes + { dmOwnerMismatch :: ServiceHandler DirectMessage () + } + +defaultDirectMessageAttributes :: DirectMessageAttributes +defaultDirectMessageAttributes = DirectMessageAttributes + { dmOwnerMismatch = svcPrint "Owner mismatch" + } + +instance Service DirectMessage where + serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d" + + type ServiceAttributes DirectMessage = DirectMessageAttributes + defaultServiceAttributes _ = defaultDirectMessageAttributes + + serviceHandler smsg = do + let msg = fromStored smsg + powner <- asks $ finalOwner . svcPeerIdentity + erb <- svcGetLocal + let DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb + sent = findMsgProperty powner msSent prev + received = findMsgProperty powner msReceived prev + received' = filterAncestors $ smsg : received + if powner `sameIdentity` msgFrom msg || + filterAncestors sent == filterAncestors (smsg : sent) + then do + when (received' /= received) $ do + next <- mstore MessageState + { msPrev = prev + , msPeer = powner + , msReady = [] + , msSent = [] + , msReceived = received' + , msSeen = [] + } + let threads = DirectMessageThreads [ next ] (dmThreadView [ next ]) + shared <- makeSharedStateUpdate threads (lsShared $ fromStored erb) + svcSetLocal =<< mstore (fromStored erb) { lsShared = [ shared ] } + + when (powner `sameIdentity` msgFrom msg) $ do + replyStoredRef smsg + + else join $ asks $ dmOwnerMismatch . svcAttributes + + serviceNewPeer = do + syncDirectMessageToPeer . lookupSharedValue . lsShared . fromStored =<< svcGetLocal + + serviceUpdatedPeer = do + updateDirectMessagePeer . finalOwner =<< asks svcPeerIdentity + + serviceStorageWatchers _ = + [ SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer + , GlobalStorageWatcher (lookupSharedValue . lsShared . fromStored) findMissingPeers + ] + + +data MessageState = MessageState + { msPrev :: [ Stored MessageState ] + , msPeer :: ComposedIdentity + , msReady :: [ Stored DirectMessage ] + , msSent :: [ Stored DirectMessage ] + , msReceived :: [ Stored DirectMessage ] + , msSeen :: [ Stored DirectMessage ] + } + +data DirectMessageThreads = DirectMessageThreads [ Stored MessageState ] [ DirectMessageThread ] + +instance Eq DirectMessageThreads where + DirectMessageThreads mss _ == DirectMessageThreads mss' _ = mss == mss' + +dmThreadList :: DirectMessageThreads -> [ DirectMessageThread ] +dmThreadList (DirectMessageThreads _ threads) = threads + +instance Storable MessageState where + store' MessageState {..} = storeRec $ do + mapM_ (storeRef "PREV") msPrev + mapM_ (storeRef "peer") $ idExtDataF msPeer + mapM_ (storeRef "ready") msReady + mapM_ (storeRef "sent") msSent + mapM_ (storeRef "received") msReceived + mapM_ (storeRef "seen") msSeen + + load' = loadRec $ do + msPrev <- loadRefs "PREV" + msPeer <- loadIdentity "peer" + msReady <- loadRefs "ready" + msSent <- loadRefs "sent" + msReceived <- loadRefs "received" + msSeen <- loadRefs "seen" + return MessageState {..} + +instance Mergeable DirectMessageThreads where + type Component DirectMessageThreads = MessageState + mergeSorted mss = DirectMessageThreads mss (dmThreadView mss) + toComponents (DirectMessageThreads mss _) = mss + +instance SharedType DirectMessageThreads where + sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade" + +findMsgProperty :: Foldable m => Identity m -> (MessageState -> [ a ]) -> [ Stored MessageState ] -> [ a ] +findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do + guard $ msPeer x `sameIdentity` pid + guard $ not $ null $ sel x + return $ sel x + + +sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m) + => Identity f -> Text -> m () +sendDirectMessage pid text = updateLocalState_ $ \ls -> do + let self = localIdentity $ fromStored ls + powner = finalOwner pid + flip updateSharedState_ ls $ \(DirectMessageThreads prev _) -> do + let ready = findMsgProperty powner msReady prev + received = findMsgProperty powner msReceived prev + + time <- liftIO getZonedTime + smsg <- mstore DirectMessage + { msgFrom = toComposedIdentity $ finalOwner self + , msgPrev = filterAncestors $ ready ++ received + , msgTime = time + , msgText = text + } + next <- mstore MessageState + { msPrev = prev + , msPeer = powner + , msReady = [ smsg ] + , msSent = [] + , msReceived = [] + , msSeen = [] + } + return $ DirectMessageThreads [ next ] (dmThreadView [ next ]) + +updateDirectMessagePeer + :: (Foldable f, Applicative f, MonadHead LocalState m) + => Identity f -> m () +updateDirectMessagePeer = createOrUpdateDirectMessagePeer' False + +createOrUpdateDirectMessagePeer + :: (Foldable f, Applicative f, MonadHead LocalState m) + => Identity f -> m () +createOrUpdateDirectMessagePeer = createOrUpdateDirectMessagePeer' True + +createOrUpdateDirectMessagePeer' + :: (Foldable f, Applicative f, MonadHead LocalState m) + => Bool -> Identity f -> m () +createOrUpdateDirectMessagePeer' create pid = do + let powner = finalOwner pid + updateLocalState_ $ updateSharedState_ $ \old@(DirectMessageThreads prev threads) -> do + let updatePeerThread = do + next <- mstore MessageState + { msPrev = prev + , msPeer = powner + , msReady = [] + , msSent = [] + , msReceived = [] + , msSeen = [] + } + return $ DirectMessageThreads [ next ] (dmThreadView [ next ]) + case find (sameIdentity powner . msgPeer) threads of + Nothing + | create + -> updatePeerThread + + Just thread + | oldPeer <- msgPeer thread + , newPeer <- updateIdentity (idExtDataF powner) oldPeer + , oldPeer /= newPeer + -> updatePeerThread + + _ -> return old + + +syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage () +syncDirectMessageToPeer (DirectMessageThreads mss _) = do + pid <- finalOwner <$> asks svcPeerIdentity + peer <- asks svcPeer + let thread = messageThreadFor pid mss + mapM_ (sendToPeerStored peer) $ msgHead thread + updateLocalState_ $ \ls -> do + let powner = finalOwner pid + flip updateSharedState_ ls $ \unchanged@(DirectMessageThreads prev _) -> do + let ready = findMsgProperty powner msReady prev + sent = findMsgProperty powner msSent prev + sent' = filterAncestors (ready ++ sent) + + if sent' /= sent + then do + next <- mstore MessageState + { msPrev = prev + , msPeer = powner + , msReady = [] + , msSent = sent' + , msReceived = [] + , msSeen = [] + } + return $ DirectMessageThreads [ next ] (dmThreadView [ next ]) + else do + return unchanged + +findMissingPeers :: Server -> DirectMessageThreads -> ExceptT ErebosError IO () +findMissingPeers server threads = do + forM_ (dmThreadList 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 ] + , msgReceived :: [ Stored DirectMessage ] + } + +dmThreadToList :: DirectMessageThread -> [ DirectMessage ] +dmThreadToList thread = threadToListHelper S.empty $ msgHead thread + +dmThreadToListSince :: DirectMessageThread -> DirectMessageThread -> [ DirectMessage ] +dmThreadToListSince since thread = threadToListHelper (S.fromAscList $ msgHead since) (msgHead thread) + +threadToListHelper :: Set (Stored DirectMessage) -> [ Stored DirectMessage ] -> [ DirectMessage ] +threadToListHelper seen msgs + | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs = + fromStored msg : threadToListHelper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg)) + | otherwise = [] + where + cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg) + +dmThreadView :: [ Stored MessageState ] -> [ DirectMessageThread ] +dmThreadView = helper [] + where helper used ms' = case filterAncestors ms' of + mss@(sms : rest) + | any (sameIdentity $ msPeer $ fromStored sms) used -> + helper used $ msPrev (fromStored sms) ++ rest + | otherwise -> + let peer = msPeer $ fromStored sms + in messageThreadFor peer mss : helper (peer : used) (msPrev (fromStored sms) ++ rest) + _ -> [] + +messageThreadFor :: ComposedIdentity -> [ Stored MessageState ] -> DirectMessageThread +messageThreadFor peer mss = + let ready = findMsgProperty peer msReady mss + sent = findMsgProperty peer msSent mss + received = findMsgProperty peer msReceived mss + seen = findMsgProperty peer msSeen mss + + in DirectMessageThread + { msgPeer = peer + , msgHead = filterAncestors $ ready ++ received + , msgSent = filterAncestors $ sent ++ received + , msgSeen = filterAncestors $ ready ++ seen + , msgReceived = filterAncestors $ received + } + + +watchDirectMessageThreads :: Head LocalState -> (DirectMessageThread -> DirectMessageThread -> IO ()) -> IO WatchedHead +watchDirectMessageThreads h f = do + prevVar <- newMVar Nothing + watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \(DirectMessageThreads sms _) -> do + modifyMVar_ prevVar $ \case + Just prev -> do + let addPeer (p : ps) p' + | p `sameIdentity` p' = p : ps + | otherwise = p : addPeer ps p' + addPeer [] p' = [ p' ] + + let peers = foldl' addPeer [] $ map (msPeer . fromStored) $ storedDifference prev sms + forM_ peers $ \peer -> do + f (messageThreadFor peer prev) (messageThreadFor peer sms) + return (Just sms) + + Nothing -> do + return (Just sms) + +formatDirectMessage :: TimeZone -> DirectMessage -> String +formatDirectMessage tzone msg = concat + [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg + , maybe "" T.unpack $ idName $ msgFrom msg + , ": " + , T.unpack $ msgText msg + ] diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Erebos.Discovery ( DiscoveryService(..), @@ -6,6 +7,7 @@ DiscoveryConnection(..), discoverySearch, + discoverySetupTunnel, ) where import Control.Concurrent @@ -13,7 +15,6 @@ import Control.Monad.Except import Control.Monad.Reader -import Data.IP qualified as IP import Data.List import Data.Map.Strict (Map) import Data.Map.Strict qualified as M @@ -25,15 +26,18 @@ import Data.Text qualified as T import Data.Word -import Network.Socket +import Text.Read #ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif import Erebos.Identity import Erebos.Network +import Erebos.Network.Address +import Erebos.Object import Erebos.Service -import Erebos.Storage +import Erebos.Service.Stream +import Erebos.Storable #ifndef ENABLE_ICE_SUPPORT @@ -44,18 +48,25 @@ data DiscoveryService - = DiscoverySelf [ Text ] (Maybe Int) - | DiscoveryAcknowledged [ Text ] (Maybe Text) (Maybe Word16) (Maybe Text) (Maybe Word16) - | DiscoverySearch Ref - | DiscoveryResult Ref [ Text ] + = DiscoverySelf [ DiscoveryAddress ] (Maybe Int) + | DiscoveryAcknowledged [ DiscoveryAddress ] (Maybe Text) (Maybe Word16) (Maybe Text) (Maybe Word16) + | DiscoverySearch (Either Ref RefDigest) + | DiscoveryResult (Either Ref RefDigest) [ DiscoveryAddress ] | DiscoveryConnectionRequest DiscoveryConnection | DiscoveryConnectionResponse DiscoveryConnection +data DiscoveryAddress + = DiscoveryIP InetAddress PortNumber + | DiscoveryICE + | DiscoveryTunnel + | DiscoveryOther Text + data DiscoveryAttributes = DiscoveryAttributes { discoveryStunPort :: Maybe Word16 , discoveryStunServer :: Maybe Text , discoveryTurnPort :: Maybe Word16 , discoveryTurnServer :: Maybe Text + , discoveryProvideTunnel :: Peer -> PeerAddress -> Bool } defaultDiscoveryAttributes :: DiscoveryAttributes @@ -64,19 +75,22 @@ , discoveryStunServer = Nothing , discoveryTurnPort = Nothing , discoveryTurnServer = Nothing + , discoveryProvideTunnel = \_ _ -> False } data DiscoveryConnection = DiscoveryConnection - { dconnSource :: Ref - , dconnTarget :: Ref + { dconnSource :: Either Ref RefDigest + , dconnTarget :: Either Ref RefDigest , dconnAddress :: Maybe Text + , dconnTunnel :: Bool , dconnIceInfo :: Maybe IceRemoteInfo } -emptyConnection :: Ref -> Ref -> DiscoveryConnection +emptyConnection :: Either Ref RefDigest -> Either Ref RefDigest -> DiscoveryConnection emptyConnection dconnSource dconnTarget = DiscoveryConnection {..} where dconnAddress = Nothing + dconnTunnel = False dconnIceInfo = Nothing instance Storable DiscoveryService where @@ -92,19 +106,20 @@ storeMbInt "stun-port" stunPort storeMbText "turn-server" turnServer storeMbInt "turn-port" turnPort - DiscoverySearch ref -> storeRawRef "search" ref - DiscoveryResult ref addr -> do - storeRawRef "result" ref + 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 DiscoveryConnection {..} = do + storeConnection (ctype :: Text) DiscoveryConnection {..} = do storeText "connection" $ ctype - storeRawRef "source" dconnSource - storeRawRef "target" dconnTarget + either (storeRawRef "source") (storeRawWeak "source") dconnSource + either (storeRawRef "target") (storeRawWeak "target") dconnTarget storeMbText "address" dconnAddress + when dconnTunnel $ storeEmpty "tunnel" storeMbRef "ice-info" dconnIceInfo load' = loadRec $ msum @@ -123,27 +138,63 @@ <*> loadMbInt "stun-port" <*> loadMbText "turn-server" <*> loadMbInt "turn-port" - , DiscoverySearch <$> loadRawRef "search" + , DiscoverySearch <$> msum + [ Left <$> loadRawRef "search" + , Right <$> loadRawWeak "search" + ] , DiscoveryResult - <$> loadRawRef "result" + <$> msum + [ Left <$> loadRawRef "result" + , Right <$> loadRawWeak "result" + ] <*> loadTexts "address" , loadConnection "request" DiscoveryConnectionRequest , loadConnection "response" DiscoveryConnectionResponse ] where - loadConnection ctype ctor = do + loadConnection (ctype :: Text) ctor = do ctype' <- loadText "connection" guard $ ctype == ctype' - dconnSource <- loadRawRef "source" - dconnTarget <- loadRawRef "target" + dconnSource <- msum + [ Left <$> loadRawRef "source" + , Right <$> loadRawWeak "source" + ] + dconnTarget <- msum + [ Left <$> loadRawRef "target" + , Right <$> loadRawWeak "target" + ] dconnAddress <- loadMbText "address" + dconnTunnel <- isJust <$> loadMbEmpty "tunnel" dconnIceInfo <- loadMbRef "ice-info" return $ ctor DiscoveryConnection {..} +instance StorableText DiscoveryAddress where + toText = \case + DiscoveryIP addr port -> T.unwords [ T.pack $ show addr, T.pack $ show port ] + DiscoveryICE -> "ICE" + DiscoveryTunnel -> "tunnel" + DiscoveryOther str -> str + + fromText str = return $ if + | [ addrStr, portStr ] <- T.words str + , Just addr <- readMaybe $ T.unpack addrStr + , Just port <- readMaybe $ T.unpack portStr + -> DiscoveryIP addr port + + | "ice" <- T.toLower str + -> DiscoveryICE + + | "tunnel" <- str + -> DiscoveryTunnel + + | otherwise + -> DiscoveryOther str + + data DiscoveryPeer = DiscoveryPeer { dpPriority :: Int , dpPeer :: Maybe Peer - , dpAddress :: [ Text ] + , dpAddress :: [ DiscoveryAddress ] , dpIceSession :: Maybe IceSession } @@ -156,7 +207,11 @@ } data DiscoveryPeerState = DiscoveryPeerState - { dpsStunServer :: Maybe ( Text, Word16 ) + { dpsOurTunnelRequests :: [ ( RefDigest, StreamWriter ) ] + -- ( original target, our write stream ) + , dpsRelayedTunnelRequests :: [ ( RefDigest, ( StreamReader, StreamWriter )) ] + -- ( original source, ( from source, to target )) + , dpsStunServer :: Maybe ( Text, Word16 ) , dpsTurnServer :: Maybe ( Text, Word16 ) , dpsIceConfig :: Maybe IceConfig } @@ -174,7 +229,9 @@ type ServiceState DiscoveryService = DiscoveryPeerState emptyServiceState _ = DiscoveryPeerState - { dpsStunServer = Nothing + { dpsOurTunnelRequests = [] + , dpsRelayedTunnelRequests = [] + , dpsStunServer = Nothing , dpsTurnServer = Nothing , dpsIceConfig = Nothing } @@ -189,26 +246,22 @@ DiscoverySelf addrs priority -> do pid <- asks svcPeerIdentity peer <- asks svcPeer + paddrs <- getPeerAddresses peer + let insertHelper new old | dpPriority new > dpPriority old = new | otherwise = old - 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 - - | otherwise -> return Nothing + let matchedAddrs = flip filter addrs $ \case + DiscoveryICE -> True + DiscoveryIP ipaddr port -> + DatagramAddress (inetToSockAddr ( ipaddr, port )) `elem` paddrs + _ -> False forM_ (idDataF =<< unfoldOwners pid) $ \sdata -> do let dp = DiscoveryPeer { dpPriority = fromMaybe 0 priority , dpPeer = Just peer - , dpAddress = addrs + , dpAddress = matchedAddrs , dpIceSession = Nothing } svcModifyGlobal $ \s -> s { dgsPeers = M.insertWith insertHelper (refDigest $ storedRef sdata) dp $ dgsPeers s } @@ -220,14 +273,8 @@ (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 + paddr <- asks svcPeerAddress >>= return . \case + (DatagramAddress saddr) -> T.pack . show . fst <$> inetFromSockAddr saddr _ -> Nothing let toIceServer Nothing Nothing = Nothing @@ -240,65 +287,105 @@ , dpsTurnServer = toIceServer turnServer turnPort } - DiscoverySearch ref -> do - dpeer <- M.lookup (refDigest ref) . dgsPeers <$> svcGetGlobal - replyPacket $ DiscoveryResult ref $ maybe [] dpAddress dpeer + DiscoverySearch edgst -> do + dpeer <- M.lookup (either refDigest id edgst) . dgsPeers <$> svcGetGlobal + peer <- asks svcPeer + paddr <- asks svcPeerAddress + attrs <- asks svcAttributes + let offerTunnel + | discoveryProvideTunnel attrs peer paddr = (++ [ DiscoveryTunnel ]) + | otherwise = id + replyPacket $ DiscoveryResult edgst $ maybe [] (offerTunnel . dpAddress) dpeer DiscoveryResult _ [] -> do -- not found return () - DiscoveryResult ref addrs -> do - let dgst = refDigest ref + DiscoveryResult edgst addrs -> do + let dgst = either refDigest id edgst -- TODO: check if we really requested that server <- asks svcServer + st <- getStorage self <- svcSelf discoveryPeer <- asks svcPeer let runAsService = runPeerService @DiscoveryService discoveryPeer - forM_ addrs $ \addr -> if - | addr == T.pack "ICE" - -> do + let tryAddresses = \case + DiscoveryIP ipaddr port : _ -> do + void $ liftIO $ forkIO $ do + let saddr = inetToSockAddr ( ipaddr, port ) + peer <- serverPeer server saddr + runAsService $ do + let upd dp = dp { dpPeer = Just peer } + svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) dgst $ dgsPeers s } + + DiscoveryICE : rest -> do #ifdef ENABLE_ICE_SUPPORT - getIceConfig >>= \case - Just config -> void $ liftIO $ forkIO $ do - ice <- iceCreateSession config PjIceSessRoleControlling $ \ice -> do - rinfo <- iceRemoteInfo ice + getIceConfig >>= \case + Just config -> do + void $ liftIO $ forkIO $ do + ice <- iceCreateSession config PjIceSessRoleControlling $ \ice -> do + rinfo <- iceRemoteInfo ice - res <- runExceptT $ sendToPeer discoveryPeer $ - DiscoveryConnectionRequest (emptyConnection (storedRef $ idData self) ref) { dconnIceInfo = Just rinfo } - case res of - Right _ -> return () - Left err -> putStrLn $ "Discovery: failed to send connection request: " ++ err + -- 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) - runAsService $ do - let upd dp = dp { dpIceSession = Just ice } - svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) dgst $ dgsPeers s } + 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 - Nothing -> do - return () + runAsService $ do + let upd dp = dp { dpIceSession = Just ice } + svcModifyGlobal $ \s -> s { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) dgst $ dgsPeers s } + + Nothing -> do #endif - return () + tryAddresses rest - | [ 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 } + DiscoveryTunnel : _ -> do + discoverySetupTunnelResponse dgst - | otherwise -> do - svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr + addr : rest -> do + svcPrint $ "Discovery: unsupported address in result: " ++ T.unpack (toText addr) + tryAddresses rest + [] -> svcPrint $ "Discovery: no (supported) address received for " <> show dgst + + tryAddresses addrs + DiscoveryConnectionRequest conn -> do self <- svcSelf + attrs <- asks svcAttributes let rconn = emptyConnection (dconnSource conn) (dconnTarget conn) - if refDigest (dconnTarget conn) `elem` identityDigests self + if either refDigest id (dconnTarget conn) `elem` identityDigests self then if + -- request for us, create ICE sesssion or tunnel + | dconnTunnel conn -> do + receivedStreams >>= \case + (tunnelReader : _) -> do + tunnelWriter <- openStream + replyPacket $ DiscoveryConnectionResponse rconn + { dconnTunnel = True + } + tunnelVia <- asks svcPeer + tunnelIdentity <- asks svcPeerIdentity + server <- asks svcServer + void $ liftIO $ forkIO $ do + tunnelStreamNumber <- getStreamWriterNumber tunnelWriter + let addr = TunnelAddress {..} + void $ serverPeerCustom server addr + receiveFromTunnel server addr + + [] -> do + svcPrint $ "Discovery: missing stream on tunnel request (endpoint)" + #ifdef ENABLE_ICE_SUPPORT - -- request for us, create ICE sesssion | Just prinfo <- dconnIceInfo conn -> do server <- asks svcServer peer <- asks svcPeer @@ -318,58 +405,123 @@ svcPrint $ "Discovery: unsupported connection request" else do - -- request to some of our peers, relay - mbdp <- M.lookup (refDigest $ dconnTarget conn) . dgsPeers <$> svcGetGlobal - case mbdp of + -- request to some of our peers, relay + peer <- asks svcPeer + paddr <- asks svcPeerAddress + mbdp <- M.lookup (either refDigest id $ dconnTarget conn) . dgsPeers <$> svcGetGlobal + streams <- receivedStreams + case mbdp of Nothing -> replyPacket $ DiscoveryConnectionResponse rconn Just dp - | Just dpeer <- dpPeer dp -> do - sendToPeer dpeer $ DiscoveryConnectionRequest conn + | Just dpeer <- dpPeer dp -> if + | dconnTunnel conn -> if + | not (discoveryProvideTunnel attrs peer paddr) -> do + replyPacket $ DiscoveryConnectionResponse rconn + | fromSource : _ <- streams -> do + void $ liftIO $ forkIO $ runPeerService @DiscoveryService dpeer $ do + toTarget <- openStream + svcModify $ \s -> s { dpsRelayedTunnelRequests = + ( either refDigest id $ dconnSource conn, ( fromSource, toTarget )) : dpsRelayedTunnelRequests s } + replyPacket $ DiscoveryConnectionRequest conn + | otherwise -> do + svcPrint $ "Discovery: missing stream on tunnel request (relay)" + | otherwise -> do + sendToPeer dpeer $ DiscoveryConnectionRequest conn | otherwise -> svcPrint $ "Discovery: failed to relay connection request" DiscoveryConnectionResponse conn -> do self <- svcSelf + dps <- svcGet dpeers <- dgsPeers <$> svcGetGlobal - if refDigest (dconnSource conn) `elem` identityDigests self - then do + + if either refDigest id (dconnSource conn) `elem` identityDigests self + then do -- response to our request, try to connect to the peer server <- asks svcServer - if | Just addr <- dconnAddress conn - , [ipaddr, port] <- words (T.unpack addr) -> do - saddr <- liftIO $ head <$> - getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) - peer <- liftIO $ serverPeer server (addrAddress saddr) + if + | Just addr <- dconnAddress conn + , [ addrStr, portStr ] <- words (T.unpack addr) + , Just ipaddr <- readMaybe addrStr + , Just port <- readMaybe portStr + -> do + let saddr = inetToSockAddr ( ipaddr, port ) + peer <- liftIO $ serverPeer server saddr let upd dp = dp { dpPeer = Just peer } svcModifyGlobal $ \s -> s - { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) (refDigest $ dconnTarget conn) $ dgsPeers s } + { dgsPeers = M.alter (Just . upd . fromMaybe emptyPeer) (either refDigest id $ dconnTarget conn) $ dgsPeers s } + | dconnTunnel conn + , Just tunnelWriter <- lookup (either refDigest id (dconnTarget conn)) (dpsOurTunnelRequests dps) + -> do + receivedStreams >>= \case + tunnelReader : _ -> do + tunnelVia <- asks svcPeer + tunnelIdentity <- asks svcPeerIdentity + void $ liftIO $ forkIO $ do + tunnelStreamNumber <- getStreamWriterNumber tunnelWriter + let addr = TunnelAddress {..} + void $ serverPeerCustom server addr + receiveFromTunnel server addr + [] -> do + svcPrint $ "Discovery: missing stream in tunnel response" + liftIO $ closeStream tunnelWriter + + | Just tunnelWriter <- lookup (either refDigest id (dconnTarget conn)) (dpsOurTunnelRequests dps) + -> do + svcPrint $ "Discovery: tunnel request failed" + liftIO $ closeStream tunnelWriter + #ifdef ENABLE_ICE_SUPPORT - | Just dp <- M.lookup (refDigest $ dconnTarget conn) dpeers + | Just dp <- M.lookup (either refDigest id $ dconnTarget conn) dpeers , Just ice <- dpIceSession dp , 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 - Just dp | Just dpeer <- dpPeer dp -> do + else do + -- response to relayed request + streams <- receivedStreams + svcModify $ \s -> s { dpsRelayedTunnelRequests = + filter ((either refDigest id (dconnSource conn) /=) . fst) (dpsRelayedTunnelRequests s) } + + case M.lookup (either refDigest id $ dconnSource conn) dpeers of + Just dp | Just dpeer <- dpPeer dp -> if + -- successful tunnel request + | dconnTunnel conn + , Just ( fromSource, toTarget ) <- lookup (either refDigest id (dconnSource conn)) (dpsRelayedTunnelRequests dps) + , fromTarget : _ <- streams + -> liftIO $ do + toSourceVar <- newEmptyMVar + void $ forkIO $ runPeerService @DiscoveryService dpeer $ do + liftIO . putMVar toSourceVar =<< openStream + svcModify $ \s -> s { dpsRelayedTunnelRequests = + ( either refDigest id $ dconnSource conn, ( fromSource, toTarget )) : dpsRelayedTunnelRequests s } + replyPacket $ DiscoveryConnectionResponse conn + void $ forkIO $ do + relayStream fromSource toTarget + void $ forkIO $ do + toSource <- readMVar toSourceVar + relayStream fromTarget toSource + + -- failed tunnel request + | Just ( _, toTarget ) <- lookup (either refDigest id (dconnSource conn)) (dpsRelayedTunnelRequests dps) + -> do + liftIO $ closeStream toTarget sendToPeer dpeer $ DiscoveryConnectionResponse conn - _ -> svcPrint $ "Discovery: failed to relay connection response" + | otherwise -> do + sendToPeer dpeer $ DiscoveryConnectionResponse conn + _ -> svcPrint $ "Discovery: failed to relay connection response" + serviceNewPeer = do server <- asks svcServer peer <- asks svcPeer - st <- getStorage - 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) + [ catMaybes . map (fmap (uncurry DiscoveryIP) . inetFromSockAddr) <$> liftIO (getServerAddresses server) #ifdef ENABLE_ICE_SUPPORT - , return [ T.pack "ICE" ] + , return [ DiscoveryICE ] #endif ] @@ -381,9 +533,7 @@ when (not $ null addrs) $ do sendToPeer peer $ DiscoverySelf addrs Nothing forM_ searchingFor $ \dgst -> do - liftIO (refFromDigest st dgst) >>= \case - Just ref -> sendToPeer peer $ DiscoverySearch ref - Nothing -> return () + sendToPeer peer $ DiscoverySearch (Right dgst) #ifdef ENABLE_ICE_SUPPORT serviceStopServer _ _ _ pstates = do @@ -416,17 +566,84 @@ #endif -discoverySearch :: (MonadIO m, MonadError String m) => Server -> Ref -> m () -discoverySearch server ref = do +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 + getPeerIdentity peer >>= \case PeerIdentityFull pid -> do - return $ refDigest ref `elem` identityDigests pid + return $ dgst `elem` identityDigests pid _ -> return False when (not $ or match) $ do modifyServiceGlobalState server (Proxy @DiscoveryService) $ \s -> (, ()) s - { dgsSearchingFor = S.insert (refDigest ref) $ dgsSearchingFor s + { dgsSearchingFor = S.insert dgst $ dgsSearchingFor s } forM_ peers $ \peer -> do - sendToPeer peer $ DiscoverySearch ref + sendToPeer peer $ DiscoverySearch $ Right dgst + + +data TunnelAddress = TunnelAddress + { tunnelVia :: Peer + , tunnelIdentity :: UnifiedIdentity + , tunnelStreamNumber :: Int + , tunnelReader :: StreamReader + , tunnelWriter :: StreamWriter + } + +instance Eq TunnelAddress where + x == y = (==) + (idData (tunnelIdentity x), tunnelStreamNumber x) + (idData (tunnelIdentity y), tunnelStreamNumber y) + +instance Ord TunnelAddress where + compare x y = compare + (idData (tunnelIdentity x), tunnelStreamNumber x) + (idData (tunnelIdentity y), tunnelStreamNumber y) + +instance Show TunnelAddress where + show tunnel = concat + [ "tunnel@" + , show $ refDigest $ storedRef $ idData $ tunnelIdentity tunnel + , "/" <> show (tunnelStreamNumber tunnel) + ] + +instance PeerAddressType TunnelAddress where + sendBytesToAddress TunnelAddress {..} bytes = do + writeStream tunnelWriter bytes + + connectionToAddressClosed TunnelAddress {..} = do + closeStream tunnelWriter + +relayStream :: StreamReader -> StreamWriter -> IO () +relayStream r w = do + p <- readStreamPacket r + writeStreamPacket w p + case p of + StreamClosed {} -> return () + _ -> relayStream r w + +receiveFromTunnel :: Server -> TunnelAddress -> IO () +receiveFromTunnel server taddr = do + p <- readStreamPacket (tunnelReader taddr) + case p of + StreamData {..} -> do + receivedFromCustomAddress server taddr stpData + receiveFromTunnel server taddr + StreamClosed {} -> do + return () + + +discoverySetupTunnel :: Peer -> RefDigest -> IO () +discoverySetupTunnel via target = do + runPeerService via $ do + discoverySetupTunnelResponse target + +discoverySetupTunnelResponse :: RefDigest -> ServiceHandler DiscoveryService () +discoverySetupTunnelResponse target = do + self <- refDigest . storedRef . idData <$> svcSelf + stream <- openStream + svcModify $ \s -> s { dpsOurTunnelRequests = ( target, stream ) : dpsOurTunnelRequests s } + replyPacket $ DiscoveryConnectionRequest + (emptyConnection (Right self) (Right target)) + { dconnTunnel = True + } diff --git a/src/Erebos/Error.hs b/src/Erebos/Error.hs new file mode 100644 --- /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/ICE.chs b/src/Erebos/ICE.chs --- a/src/Erebos/ICE.chs +++ b/src/Erebos/ICE.chs @@ -16,13 +16,12 @@ iceConnect, iceSend, - iceSetChan, + serverPeerIce, ) where import Control.Arrow import Control.Concurrent import Control.Monad -import Control.Monad.Except import Control.Monad.Identity import Data.ByteString (ByteString, packCStringLen, useAsCString) @@ -33,7 +32,6 @@ 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 @@ -44,7 +42,9 @@ import Foreign.Ptr import Foreign.StablePtr -import Erebos.Flow +import Erebos.Network +import Erebos.Object +import Erebos.Storable import Erebos.Storage #include "pjproject.h" @@ -52,7 +52,7 @@ data IceSession = IceSession { isStrans :: PjIceStrans , _isConfig :: IceConfig - , isChan :: MVar (Either [ByteString] (Flow Void ByteString)) + , isChan :: MVar (Either [ ByteString ] (ByteString -> IO ())) } instance Eq IceSession where @@ -64,7 +64,11 @@ instance Show IceSession where show _ = "" +instance PeerAddressType IceSession where + sendBytesToAddress = iceSend + connectionToAddressClosed = iceDestroy + data IceRemoteInfo = IceRemoteInfo { iriUsernameFrament :: Text , iriPassword :: Text @@ -117,7 +121,7 @@ , 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) #} @@ -125,9 +129,9 @@ data PjIceStransCfg newtype IceConfig = IceConfig (ForeignPtr PjIceStransCfg) -foreign import ccall unsafe "pjproject.h &ice_cfg_free" +foreign import ccall unsafe "pjproject.h &erebos_ice_cfg_free" ice_cfg_free :: FunPtr (Ptr PjIceStransCfg -> IO ()) -foreign import ccall unsafe "pjproject.h ice_cfg_create" +foreign import ccall unsafe "pjproject.h erebos_ice_cfg_create" ice_cfg_create :: CString -> Word16 -> CString -> Word16 -> IO (Ptr PjIceStransCfg) iceCreateConfig :: Maybe ( Text, Word16 ) -> Maybe ( Text, Word16 ) -> IO (Maybe IceConfig) @@ -139,7 +143,7 @@ then return Nothing else Just . IceConfig <$> newForeignPtr ice_cfg_free cfg -foreign import ccall unsafe "pjproject.h ice_cfg_stop_thread" +foreign import ccall unsafe "pjproject.h erebos_ice_cfg_stop_thread" ice_cfg_stop_thread :: Ptr PjIceStransCfg -> IO () iceStopThread :: IceConfig -> IO () @@ -157,13 +161,13 @@ forkIO $ cb sess sess <- IceSession <$> (withForeignPtr fcfg $ \cfg -> - {#call ice_create #} (castPtr cfg) (fromIntegral $ fromEnum role) (castStablePtrToPtr sptr) (castStablePtrToPtr cbptr) + {#call erebos_ice_create #} (castPtr cfg) (fromIntegral $ fromEnum role) (castStablePtrToPtr sptr) (castStablePtrToPtr cbptr) ) <*> pure icfg <*> (newMVar $ Left []) return $ sess -{#fun ice_destroy as ^ { isStrans `IceSession' } -> `()' #} +{#fun erebos_ice_destroy as iceDestroy { isStrans `IceSession' } -> `()' #} iceRemoteInfo :: IceSession -> IO IceRemoteInfo iceRemoteInfo sess = do @@ -178,7 +182,7 @@ let cptrs = take maxcand $ iterate (`plusPtr` maxlen) bytes pokeArray carr $ take maxcand cptrs - ncand <- {#call ice_encode_session #} (isStrans sess) ufrag pass def carr (fromIntegral maxlen) (fromIntegral maxcand) + ncand <- {#call erebos_ice_encode_session #} (isStrans sess) ufrag pass def carr (fromIntegral maxlen) (fromIntegral maxcand) if ncand < 0 then fail "failed to generate ICE remote info" else IceRemoteInfo <$> (T.pack <$> peekCString ufrag) @@ -195,13 +199,13 @@ iceConnect :: IceSession -> IceRemoteInfo -> (IO ()) -> IO () iceConnect sess remote cb = do cbptr <- newStablePtr $ cb - ice_connect sess cbptr + erebos_ice_connect sess cbptr (iriUsernameFrament remote) (iriPassword remote) (iriDefaultCandidate remote) (iriCandidates remote) -{#fun ice_connect { isStrans `IceSession', castStablePtrToPtr `StablePtr (IO ())', +{#fun erebos_ice_connect { isStrans `IceSession', castStablePtrToPtr `StablePtr (IO ())', withText* `Text', withText* `Text', withText* `Text', withTextArray* `[Text]'& } -> `()' #} withText :: Text -> (Ptr CChar -> IO a) -> IO a @@ -217,19 +221,19 @@ withByteStringLen :: Num n => ByteString -> ((Ptr CChar, n) -> IO a) -> IO a withByteStringLen t f = unsafeUseAsCStringLen t (f . (id *** fromIntegral)) -{#fun ice_send as ^ { isStrans `IceSession', withByteStringLen* `ByteString'& } -> `()' #} +{#fun erebos_ice_send as iceSend { isStrans `IceSession', withByteStringLen* `ByteString'& } -> `()' #} foreign export ccall ice_call_cb :: StablePtr (IO ()) -> IO () ice_call_cb :: StablePtr (IO ()) -> IO () ice_call_cb = join . deRefStablePtr -iceSetChan :: IceSession -> Flow Void ByteString -> IO () -iceSetChan sess chan = do +iceSetServer :: IceSession -> Server -> IO () +iceSetServer sess server = do modifyMVar_ (isChan sess) $ \orig -> do case orig of - Left buf -> mapM_ (writeFlowIO chan) $ reverse buf + Left buf -> mapM_ (receivedFromCustomAddress server sess) $ reverse buf Right _ -> return () - return $ Right chan + return $ Right $ receivedFromCustomAddress server sess foreign export ccall ice_rx_data :: StablePtr IceSession -> Ptr CChar -> Int -> IO () ice_rx_data :: StablePtr IceSession -> Ptr CChar -> Int -> IO () @@ -237,5 +241,12 @@ sess <- deRefStablePtr sptr bs <- packCStringLen (buf, len) modifyMVar_ (isChan sess) $ \case - mc@(Right chan) -> writeFlowIO chan bs >> return mc - Left bss -> return $ Left (bs:bss) + mc@(Right sendToServer) -> sendToServer bs >> return mc + Left bss -> return $ Left (bs : bss) + + +serverPeerIce :: Server -> IceSession -> IO Peer +serverPeerIce server ice = do + peer <- serverPeerCustom server ice + iceSetServer ice server + return peer diff --git a/src/Erebos/ICE/pjproject.c b/src/Erebos/ICE/pjproject.c --- a/src/Erebos/ICE/pjproject.c +++ b/src/Erebos/ICE/pjproject.c @@ -78,7 +78,7 @@ { if (status != PJ_SUCCESS) { ice_perror("cb_on_ice_complete", status); - ice_destroy(strans); + erebos_ice_destroy(strans); return; } @@ -139,7 +139,7 @@ pthread_mutex_unlock(&mutex); } -struct erebos_ice_cfg * ice_cfg_create( const char * stun_server, uint16_t stun_port, +struct erebos_ice_cfg * erebos_ice_cfg_create( const char * stun_server, uint16_t stun_port, const char * turn_server, uint16_t turn_port ) { ice_init(); @@ -189,11 +189,11 @@ return ecfg; fail: - ice_cfg_free( ecfg ); + erebos_ice_cfg_free( ecfg ); return NULL; } -void ice_cfg_free( struct erebos_ice_cfg * ecfg ) +void erebos_ice_cfg_free( struct erebos_ice_cfg * ecfg ) { if( ! ecfg ) return; @@ -216,14 +216,14 @@ free( ecfg ); } -void ice_cfg_stop_thread( struct erebos_ice_cfg * ecfg ) +void erebos_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, +pj_ice_strans * erebos_ice_create( const struct erebos_ice_cfg * ecfg, pj_ice_sess_role role, HsStablePtr sptr, HsStablePtr cb ) { ice_init(); @@ -249,7 +249,7 @@ return res; } -void ice_destroy(pj_ice_strans * strans) +void erebos_ice_destroy(pj_ice_strans * strans) { struct user_data * udata = pj_ice_strans_get_user_data(strans); if (udata->sptr) @@ -264,7 +264,7 @@ pj_ice_strans_destroy(strans); } -ssize_t ice_encode_session(pj_ice_strans * strans, char * ufrag, char * pass, +ssize_t erebos_ice_encode_session(pj_ice_strans * strans, char * ufrag, char * pass, char * def, char * candidates[], size_t maxlen, size_t maxcand) { int n; @@ -318,7 +318,7 @@ return cand_cnt; } -void ice_connect(pj_ice_strans * strans, HsStablePtr cb, +void erebos_ice_connect(pj_ice_strans * strans, HsStablePtr cb, const char * ufrag, const char * pass, const char * defcand, const char * tcandidates[], size_t ncand) { @@ -409,7 +409,7 @@ } } -void ice_send(pj_ice_strans * strans, const char * data, size_t len) +void erebos_ice_send(pj_ice_strans * strans, const char * data, size_t len) { if (!pj_ice_strans_sess_is_complete(strans)) { fprintf(stderr, "ICE: negotiation has not been started or is in progress\n"); diff --git a/src/Erebos/ICE/pjproject.h b/src/Erebos/ICE/pjproject.h --- a/src/Erebos/ICE/pjproject.h +++ b/src/Erebos/ICE/pjproject.h @@ -3,18 +3,18 @@ #include #include -struct erebos_ice_cfg * ice_cfg_create( const char * stun_server, uint16_t stun_port, +struct erebos_ice_cfg * erebos_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 ); +void erebos_ice_cfg_free( struct erebos_ice_cfg * cfg ); +void erebos_ice_cfg_stop_thread( struct erebos_ice_cfg * cfg ); -pj_ice_strans * ice_create( const struct erebos_ice_cfg *, pj_ice_sess_role role, +pj_ice_strans * erebos_ice_create( const struct erebos_ice_cfg *, pj_ice_sess_role role, HsStablePtr sptr, HsStablePtr cb ); -void ice_destroy(pj_ice_strans * strans); +void erebos_ice_destroy(pj_ice_strans * strans); -ssize_t ice_encode_session(pj_ice_strans *, char * ufrag, char * pass, +ssize_t erebos_ice_encode_session(pj_ice_strans *, char * ufrag, char * pass, char * def, char * candidates[], size_t maxlen, size_t maxcand); -void ice_connect(pj_ice_strans * strans, HsStablePtr cb, +void erebos_ice_connect(pj_ice_strans * strans, HsStablePtr cb, const char * ufrag, const char * pass, const char * defcand, const char * candidates[], size_t ncand); -void ice_send(pj_ice_strans *, const char * data, size_t len); +void erebos_ice_send(pj_ice_strans *, const char * data, size_t len); diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs --- a/src/Erebos/Identity.hs +++ b/src/Erebos/Identity.hs @@ -41,7 +41,7 @@ import qualified Data.Text as T import Erebos.PubKey -import Erebos.Storage +import Erebos.Storable import Erebos.Storage.Merge import Erebos.Util @@ -214,29 +214,33 @@ _ -> True -createIdentity :: Storage -> Maybe Text -> Maybe UnifiedIdentity -> IO UnifiedIdentity -createIdentity st name owner = do - (secret, public) <- generateKeys st - (_secretMsg, publicMsg) <- generateKeys st +createIdentity + :: forall m e. (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m) + => Maybe Text -> Maybe UnifiedIdentity -> m UnifiedIdentity +createIdentity name owner = do + st <- getStorage + ( secret, public ) <- liftIO $ generateKeys st + ( _secretMsg, publicMsg ) <- liftIO $ generateKeys st - let signOwner :: Signed a -> ReaderT Storage IO (Signed a) + let signOwner :: Signed a -> m (Signed a) signOwner idd | Just o <- owner = do - Just ownerSecret <- loadKeyMb (iddKeyIdentity $ fromSigned $ idData o) + ownerSecret <- maybe (throwOtherError "failed to load private key") return =<< + loadKeyMb (iddKeyIdentity $ fromSigned $ idData o) signAdd ownerSecret idd | otherwise = return idd - Just identity <- flip runReaderT st $ do - baseData <- mstore =<< signOwner =<< sign secret =<< - mstore (emptyIdentityData public) - { iddOwner = idData <$> owner - , iddKeyMessage = Just publicMsg - } - let extOwner = do - odata <- idExtData <$> owner - guard $ isExtension odata - return odata + baseData <- mstore =<< signOwner =<< sign secret =<< + mstore (emptyIdentityData public) + { iddOwner = idData <$> owner + , iddKeyMessage = Just publicMsg + } + let extOwner = do + odata <- idExtData <$> owner + guard $ isExtension odata + return odata + maybe (throwOtherError "created invalid identity") return =<< do validateExtendedIdentityF . I.Identity <$> if isJust name || isJust extOwner then mstore =<< signOwner =<< sign secret =<< @@ -245,7 +249,6 @@ , ideOwner = extOwner } else return $ baseToExtended baseData - return identity validateIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity validateIdentity = validateIdentityF . I.Identity @@ -280,13 +283,13 @@ 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 @@ -322,7 +325,7 @@ 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/Message.hs b/src/Erebos/Message.hs deleted file mode 100644 --- a/src/Erebos/Message.hs +++ /dev/null @@ -1,283 +0,0 @@ -module Erebos.Message ( - DirectMessage(..), - sendDirectMessage, - - DirectMessageAttributes(..), - defaultDirectMessageAttributes, - - DirectMessageThreads, - toThreadList, - - DirectMessageThread(..), - threadToList, - messageThreadView, - - watchReceivedMessages, - formatMessage, - formatDirectMessage, -) where - -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader - -import Data.List -import Data.Ord -import qualified Data.Set as S -import Data.Text (Text) -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.Service -import Erebos.State -import Erebos.Storage -import Erebos.Storage.Merge - -data DirectMessage = DirectMessage - { msgFrom :: ComposedIdentity - , msgPrev :: [Stored DirectMessage] - , msgTime :: ZonedTime - , msgText :: Text - } - -instance Storable DirectMessage where - store' msg = storeRec $ do - mapM_ (storeRef "from") $ idExtDataF $ msgFrom msg - mapM_ (storeRef "PREV") $ msgPrev msg - storeDate "time" $ msgTime msg - storeText "text" $ msgText msg - - load' = loadRec $ DirectMessage - <$> loadIdentity "from" - <*> loadRefs "PREV" - <*> loadDate "time" - <*> loadText "text" - -data DirectMessageAttributes = DirectMessageAttributes - { dmOwnerMismatch :: ServiceHandler DirectMessage () - } - -defaultDirectMessageAttributes :: DirectMessageAttributes -defaultDirectMessageAttributes = DirectMessageAttributes - { dmOwnerMismatch = svcPrint "Owner mismatch" - } - -instance Service DirectMessage where - serviceID _ = mkServiceID "c702076c-4928-4415-8b6b-3e839eafcb0d" - - type ServiceAttributes DirectMessage = DirectMessageAttributes - defaultServiceAttributes _ = defaultDirectMessageAttributes - - serviceHandler smsg = do - let msg = fromStored smsg - powner <- asks $ finalOwner . svcPeerIdentity - erb <- svcGetLocal - st <- getStorage - let DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb - sent = findMsgProperty powner msSent prev - received = findMsgProperty powner msReceived prev - received' = filterAncestors $ smsg : received - if powner `sameIdentity` msgFrom msg || - filterAncestors sent == filterAncestors (smsg : sent) - then do - when (received' /= received) $ do - next <- wrappedStore st $ MessageState - { msPrev = prev - , msPeer = powner - , msReady = [] - , msSent = [] - , msReceived = received' - , msSeen = [] - } - let threads = DirectMessageThreads [next] (messageThreadView [next]) - shared <- makeSharedStateUpdate st threads (lsShared $ fromStored erb) - svcSetLocal =<< wrappedStore st (fromStored erb) { lsShared = [shared] } - - when (powner `sameIdentity` msgFrom msg) $ do - replyStoredRef smsg - - else join $ asks $ dmOwnerMismatch . svcAttributes - - serviceNewPeer = syncDirectMessageToPeer . lookupSharedValue . lsShared . fromStored =<< svcGetLocal - - serviceStorageWatchers _ = - [ SomeStorageWatcher (lookupSharedValue . lsShared . fromStored) syncDirectMessageToPeer - , GlobalStorageWatcher (lookupSharedValue . lsShared . fromStored) findMissingPeers - ] - - -data MessageState = MessageState - { msPrev :: [Stored MessageState] - , msPeer :: ComposedIdentity - , msReady :: [Stored DirectMessage] - , msSent :: [Stored DirectMessage] - , msReceived :: [Stored DirectMessage] - , msSeen :: [Stored DirectMessage] - } - -data DirectMessageThreads = DirectMessageThreads [Stored MessageState] [DirectMessageThread] - -instance Eq DirectMessageThreads where - DirectMessageThreads mss _ == DirectMessageThreads mss' _ = mss == mss' - -toThreadList :: DirectMessageThreads -> [DirectMessageThread] -toThreadList (DirectMessageThreads _ threads) = threads - -instance Storable MessageState where - store' MessageState {..} = storeRec $ do - mapM_ (storeRef "PREV") msPrev - mapM_ (storeRef "peer") $ idExtDataF msPeer - mapM_ (storeRef "ready") msReady - mapM_ (storeRef "sent") msSent - mapM_ (storeRef "received") msReceived - mapM_ (storeRef "seen") msSeen - - load' = loadRec $ do - msPrev <- loadRefs "PREV" - msPeer <- loadIdentity "peer" - msReady <- loadRefs "ready" - msSent <- loadRefs "sent" - msReceived <- loadRefs "received" - msSeen <- loadRefs "seen" - return MessageState {..} - -instance Mergeable DirectMessageThreads where - type Component DirectMessageThreads = MessageState - mergeSorted mss = DirectMessageThreads mss (messageThreadView mss) - toComponents (DirectMessageThreads mss _) = mss - -instance SharedType DirectMessageThreads where - sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade" - -findMsgProperty :: Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a] -findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do - guard $ msPeer x `sameIdentity` pid - guard $ not $ null $ sel x - return $ sel x - - -sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m) - => Identity f -> Text -> m (Stored DirectMessage) -sendDirectMessage pid text = updateLocalHead $ \ls -> do - let self = localIdentity $ fromStored ls - powner = finalOwner pid - flip updateSharedState ls $ \(DirectMessageThreads prev _) -> do - let ready = findMsgProperty powner msReady prev - received = findMsgProperty powner msReceived prev - - time <- liftIO getZonedTime - smsg <- mstore DirectMessage - { msgFrom = toComposedIdentity $ finalOwner self - , msgPrev = filterAncestors $ ready ++ received - , msgTime = time - , msgText = text - } - next <- mstore MessageState - { msPrev = prev - , msPeer = powner - , msReady = [smsg] - , msSent = [] - , msReceived = [] - , msSeen = [] - } - return (DirectMessageThreads [next] (messageThreadView [next]), smsg) - -syncDirectMessageToPeer :: DirectMessageThreads -> ServiceHandler DirectMessage () -syncDirectMessageToPeer (DirectMessageThreads mss _) = do - pid <- finalOwner <$> asks svcPeerIdentity - peer <- asks svcPeer - let thread = messageThreadFor pid mss - mapM_ (sendToPeerStored peer) $ msgHead thread - updateLocalHead_ $ \ls -> do - let powner = finalOwner pid - flip updateSharedState_ ls $ \unchanged@(DirectMessageThreads prev _) -> do - let ready = findMsgProperty powner msReady prev - sent = findMsgProperty powner msSent prev - sent' = filterAncestors (ready ++ sent) - - if sent' /= sent - then do - next <- mstore MessageState - { msPrev = prev - , msPeer = powner - , msReady = [] - , msSent = sent' - , msReceived = [] - , msSeen = [] - } - return $ DirectMessageThreads [next] (messageThreadView [next]) - else do - return unchanged - -findMissingPeers :: Server -> DirectMessageThreads -> ExceptT String IO () -findMissingPeers server threads = do - forM_ (toThreadList threads) $ \thread -> do - when (msgHead thread /= msgReceived thread) $ do - mapM_ (discoverySearch server) $ map storedRef $ idDataF $ msgPeer thread - - -data DirectMessageThread = DirectMessageThread - { msgPeer :: ComposedIdentity - , msgHead :: [ Stored DirectMessage ] - , msgSent :: [ Stored DirectMessage ] - , msgSeen :: [ Stored DirectMessage ] - , msgReceived :: [ Stored DirectMessage ] - } - -threadToList :: DirectMessageThread -> [DirectMessage] -threadToList thread = helper S.empty $ msgHead thread - where helper seen msgs - | msg : msgs' <- filter (`S.notMember` seen) $ reverse $ sortBy (comparing cmpView) msgs = - fromStored msg : helper (S.insert msg seen) (msgs' ++ msgPrev (fromStored msg)) - | otherwise = [] - cmpView msg = (zonedTimeToUTC $ msgTime $ fromStored msg, msg) - -messageThreadView :: [Stored MessageState] -> [DirectMessageThread] -messageThreadView = helper [] - where helper used ms' = case filterAncestors ms' of - mss@(sms : rest) - | any (sameIdentity $ msPeer $ fromStored sms) used -> - helper used $ msPrev (fromStored sms) ++ rest - | otherwise -> - let peer = msPeer $ fromStored sms - in messageThreadFor peer mss : helper (peer : used) (msPrev (fromStored sms) ++ rest) - _ -> [] - -messageThreadFor :: ComposedIdentity -> [Stored MessageState] -> DirectMessageThread -messageThreadFor peer mss = - let ready = findMsgProperty peer msReady mss - sent = findMsgProperty peer msSent mss - received = findMsgProperty peer msReceived mss - seen = findMsgProperty peer msSeen mss - - in DirectMessageThread - { msgPeer = peer - , msgHead = filterAncestors $ ready ++ received - , msgSent = filterAncestors $ sent ++ received - , msgSeen = filterAncestors $ ready ++ seen - , msgReceived = filterAncestors $ received - } - - -watchReceivedMessages :: Head LocalState -> (Stored DirectMessage -> IO ()) -> IO WatchedHead -watchReceivedMessages h f = do - let self = finalOwner $ localIdentity $ headObject h - watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \(DirectMessageThreads sms _) -> 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 - , maybe "" T.unpack $ idName $ msgFrom msg - , ": " - , T.unpack $ msgText msg - ] diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs --- a/src/Erebos/Network.hs +++ b/src/Erebos/Network.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module Erebos.Network ( Server, startServer, @@ -10,14 +8,17 @@ ServerOptions(..), serverIdentity, defaultServerOptions, Peer, peerServer, peerStorage, - PeerAddress(..), peerAddress, - PeerIdentity(..), peerIdentity, + PeerAddress(..), getPeerAddress, getPeerAddresses, + PeerIdentity(..), getPeerIdentity, WaitingRef, wrDigest, Service(..), + + PeerAddressType(..), + receivedFromCustomAddress, + serverPeer, -#ifdef ENABLE_ICE_SUPPORT - serverPeerIce, -#endif + serverPeerCustom, + findPeer, dropPeer, isPeerDropped, sendToPeer, sendManyToPeer, @@ -37,13 +38,14 @@ 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 @@ -57,14 +59,14 @@ import GHC.Conc.Sync (unsafeIOToSTM) import Network.Socket hiding (ControlMessage) -import qualified Network.Socket.ByteString as S +import Network.Socket.ByteString qualified as S -import Erebos.Channel -#ifdef ENABLE_ICE_SUPPORT -import Erebos.ICE -#endif +import Erebos.Error import Erebos.Identity +import Erebos.Network.Address +import Erebos.Network.Channel import Erebos.Network.Protocol +import Erebos.Object.Internal import Erebos.PubKey import Erebos.Service import Erebos.State @@ -93,7 +95,7 @@ , 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) @@ -113,12 +115,16 @@ data ServerOptions = ServerOptions { serverPort :: PortNumber , serverLocalDiscovery :: Bool + , serverErrorPrefix :: String + , serverTestLog :: Bool } defaultServerOptions :: ServerOptions defaultServerOptions = ServerOptions { serverPort = discoveryPort , serverLocalDiscovery = True + , serverErrorPrefix = "" + , serverTestLog = False } @@ -133,6 +139,14 @@ , peerWaitingRefs :: TMVar [WaitingRef] } +-- | Get current main address of the peer (used to send new packets). +getPeerAddress :: MonadIO m => Peer -> m PeerAddress +getPeerAddress = liftIO . return . peerAddress + +-- | Get all known addresses of given peer. +getPeerAddresses :: MonadIO m => Peer -> m [ PeerAddress ] +getPeerAddresses = fmap (: []) . getPeerAddress + peerServer :: Peer -> Server peerServer = peerServer_ @@ -156,50 +170,52 @@ instance Eq Peer where (==) = (==) `on` peerIdentityVar -data PeerAddress = DatagramAddress SockAddr -#ifdef ENABLE_ICE_SUPPORT - | PeerIceSession IceSession -#endif +class (Eq addr, Ord addr, Show addr, Typeable addr) => PeerAddressType addr where + sendBytesToAddress :: addr -> ByteString -> IO () + connectionToAddressClosed :: addr -> IO () +data PeerAddress + = forall addr. PeerAddressType addr => CustomPeerAddress addr + | DatagramAddress SockAddr + instance Show PeerAddress where - show (DatagramAddress saddr) = unwords $ case IP.fromSockAddr saddr of - Just (IP.IPv6 ipv6, port) - | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6 - -> [show (IP.toIPv4w ipv4), show port] - Just (addr, port) - -> [show addr, show port] - _ -> [show saddr] -#ifdef ENABLE_ICE_SUPPORT - show (PeerIceSession ice) = show ice -#endif + show (CustomPeerAddress addr) = show addr + show (DatagramAddress saddr) = + case inetFromSockAddr saddr of + Just ( addr, port ) -> unwords [ show addr, show port ] + _ -> show saddr + 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 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 ()]) - | PeerIdentityFull UnifiedIdentity +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 +-- | Get currently known identity of the given peer +getPeerIdentity :: MonadIO m => Peer -> m PeerIdentity +getPeerIdentity = 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 @@ -251,11 +267,20 @@ let logd = writeTQueue serverErrorLog forkServerThread server $ forever $ do - logd' =<< atomically (readTQueue serverErrorLog) + logd' . (serverErrorPrefix serverOptions <>) =<< atomically (readTQueue serverErrorLog) + logt <- if + | serverTestLog serverOptions -> do + serverTestLog <- newTQueueIO + forkServerThread server $ forever $ do + logd' =<< atomically (readTQueue serverTestLog) + return $ writeTQueue serverTestLog + | otherwise -> do + return $ \_ -> return () + 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 @@ -320,12 +345,10 @@ 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 -#endif forkServerThread server $ forever $ do readFlowIO serverControlFlow >>= \case @@ -367,9 +390,13 @@ prefs <- forM objs $ storeObject $ peerInStorage peer identity <- readMVar serverIdentity_ let svcs = map someServiceID serverServices - handlePacket identity secure peer chanSvc svcs header prefs + handlePacket paddr identity secure peer chanSvc svcs header prefs peerLoop Nothing -> do + case paddr of + DatagramAddress _ -> return () + CustomPeerAddress caddr -> connectionToAddressClosed caddr + dropPeer peer atomically $ writeTChan serverChanPeer peer peerLoop @@ -377,7 +404,7 @@ ReceivedAnnounce addr _ -> do void $ serverPeer' server addr - erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd protocolRawPath protocolControlFlow + erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd logt protocolRawPath protocolControlFlow forkServerThread server $ withSocketsDo $ do let hints = defaultHints @@ -389,9 +416,9 @@ bracket (open addr) close loop forkServerThread server $ forever $ do - (peer, svc, ref) <- atomically $ readTQueue chanSvc + ( peer, paddr, 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 paddr peer (serviceHandler $ wrappedLoad @s ref) _ -> atomically $ logd $ "unhandled service '" ++ show (toUUID svc) ++ "'" return server @@ -425,7 +452,7 @@ 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, []) @@ -519,9 +546,7 @@ 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 @@ -540,10 +565,10 @@ | otherwise = y : appendDistinct x ys appendDistinct x [] = [x] -handlePacket :: UnifiedIdentity -> Bool - -> Peer -> TQueue (Peer, ServiceID, Ref) -> [ServiceID] - -> TransportHeader -> [PartialRef] -> IO () -handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = atomically $ do +handlePacket :: PeerAddress -> UnifiedIdentity -> Bool + -> Peer -> TQueue ( Peer, PeerAddress, ServiceID, Ref, [ RawStreamReader ] ) -> [ ServiceID ] + -> TransportHeader -> [ PartialRef ] -> IO () +handlePacket paddr identity secure peer chanSvc svcs (TransportHeader headers) prefs = atomically $ do let server = peerServer peer ochannel <- getPeerChannel peer let sidentity = idData identity @@ -604,7 +629,7 @@ 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 @@ -676,17 +701,18 @@ | 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, paddr, 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:) @@ -742,7 +768,7 @@ 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 () @@ -758,7 +784,7 @@ -- Notify services about new peer readTVar peerIdentityVar >>= \case - PeerIdentityFull _ -> notifyServicesOfPeer peer + PeerIdentityFull _ -> notifyServicesOfPeer True peer _ -> return () @@ -784,7 +810,7 @@ PeerIdentityFull pid | idData pid `precedes` wrappedLoad ref -> validateAndUpdate (idUpdates pid) $ \_ -> do - notifyServicesOfPeer peer + notifyServicesOfPeer False peer _ -> return () @@ -796,17 +822,24 @@ -> do writeTVar (peerIdentityVar peer) $ PeerIdentityFull pid' writeTChan (serverChanPeer $ peerServer peer) peer - when (idData pid /= idData pid') $ notifyServicesOfPeer peer + when (pid /= pid') $ do + notifyServicesOfPeer False peer | otherwise -> return () -notifyServicesOfPeer :: Peer -> STM () -notifyServicesOfPeer peer@Peer { peerServer_ = Server {..} } = do +notifyServicesOfPeer :: Bool -> Peer -> STM () +notifyServicesOfPeer new peer@Peer { peerServer_ = Server {..} } = do writeTQueue serverIOActions $ do + paddr <- getPeerAddress peer forM_ serverServices $ \service@(SomeService _ attrs) -> - runPeerServiceOn (Just (service, attrs)) peer serviceNewPeer + runPeerServiceOn (Just ( service, attrs )) [] paddr peer $ + if new then serviceNewPeer else serviceUpdatedPeer +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 []) @@ -825,14 +858,8 @@ _ -> paddr serverPeer' server (DatagramAddress paddr') -#ifdef ENABLE_ICE_SUPPORT -serverPeerIce :: Server -> IceSession -> IO Peer -serverPeerIce server@Server {..} ice = do - let paddr = PeerIceSession ice - peer <- serverPeer' server paddr - iceSetChan ice $ mapFlow undefined (paddr,) serverRawPath - return peer -#endif +serverPeerCustom :: PeerAddressType addr => Server -> addr -> IO Peer +serverPeerCustom server addr = serverPeer' server (CustomPeerAddress addr) serverPeer' :: Server -> PeerAddress -> IO Peer serverPeer' server paddr = do @@ -846,6 +873,13 @@ writeFlow (serverControlFlow server) (RequestConnection paddr) return peer +findPeer :: Server -> (Peer -> IO Bool) -> IO (Maybe Peer) +findPeer server test = withMVar (serverPeers server) (helper . M.elems) + where + helper (p : ps) = test p >>= \case True -> return (Just p) + False -> helper ps + helper [] = return Nothing + dropPeer :: MonadIO m => Peer -> m () dropPeer peer = liftIO $ do modifyMVar_ (serverPeers $ peerServer peer) $ \pvalue -> do @@ -873,20 +907,50 @@ 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 readTVar peerState >>= \case @@ -900,7 +964,7 @@ 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 @@ -915,7 +979,7 @@ case res of Right (Just obj) -> sendToPeer peer obj Right Nothing -> return () - Left err -> throwError err + Left err -> throwError $ fromErebosError err lookupService :: forall s proxy. Service s => proxy s -> [SomeService] -> Maybe (SomeService, ServiceAttributes s) @@ -925,10 +989,12 @@ lookupService _ [] = Nothing runPeerService :: forall s m. (Service s, MonadIO m) => Peer -> ServiceHandler s () -> m () -runPeerService = runPeerServiceOn Nothing +runPeerService peer handler = do + paddr <- getPeerAddress peer + runPeerServiceOn Nothing [] paddr peer handler -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 ] -> PeerAddress -> Peer -> ServiceHandler s () -> m () +runPeerServiceOn mbservice newStreams paddr peer handler = liftIO $ do let server = peerServer peer proxy = Proxy @s svc = serviceID proxy @@ -950,9 +1016,11 @@ let inp = ServiceInput { svcAttributes = attr , svcPeer = peer + , svcPeerAddress = paddr , svcPeerIdentity = peerId , svcServer = server , svcPrintOp = atomically . logd + , svcNewStreams = newStreams } reloadHead (serverOrigHead server) >>= \case Nothing -> atomically $ do @@ -968,13 +1036,13 @@ putTMVar (peerServiceState peer) $ M.insert svc (SomeServiceState proxy s') svcs putTMVar (serverServiceStates server) $ M.insert svc (SomeServiceGlobalState proxy gs') global _ -> do - atomically $ logd $ "can't run service handler on peer with incomplete identity " ++ show (peerAddress peer) + atomically $ logd $ "can't run service handler on peer with incomplete identity " ++ show paddr _ -> atomically $ do logd $ "unhandled service '" ++ show (toUUID svc) ++ "'" modifyServiceGlobalState - :: forall s a m proxy. (Service s, MonadIO m, MonadError String m) + :: 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 @@ -992,33 +1060,14 @@ putTMVar (serverServiceStates server) global' return res Nothing -> do - throwError $ "unhandled service '" ++ show (toUUID svc) ++ "'" + 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 "Network/ifaddrs.h erebos_join_multicast" cJoinMulticast :: CInt -> Ptr CSize -> IO (Ptr Word32) +foreign import ccall unsafe "Network/ifaddrs.h erebos_local_addresses" cLocalAddresses :: Ptr CSize -> IO (Ptr InetAddress) +foreign import ccall unsafe "Network/ifaddrs.h erebos_broadcast_addresses" cBroadcastAddresses :: IO (Ptr Word32) 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 -> @@ -1045,7 +1094,7 @@ count <- fromIntegral <$> peek pcount res <- peekArray count ptr cFree ptr - return $ map (IP.toSockAddr . (, serverPort serverOptions ) . fromInetAddress) res + return $ map (inetToSockAddr . (, serverPort serverOptions )) res getBroadcastAddresses :: PortNumber -> IO [SockAddr] getBroadcastAddresses port = do diff --git a/src/Erebos/Network.hs-boot b/src/Erebos/Network.hs-boot --- a/src/Erebos/Network.hs-boot +++ b/src/Erebos/Network.hs-boot @@ -1,8 +1,9 @@ module Erebos.Network where -import Erebos.Storage +import Erebos.Object.Internal data Server data Peer +data PeerAddress peerStorage :: Peer -> Storage diff --git a/src/Erebos/Network/Address.hs b/src/Erebos/Network/Address.hs new file mode 100644 --- /dev/null +++ b/src/Erebos/Network/Address.hs @@ -0,0 +1,65 @@ +module Erebos.Network.Address ( + InetAddress(..), + inetFromSockAddr, + inetToSockAddr, + + SockAddr, PortNumber, +) where + +import Data.Bifunctor +import Data.IP qualified as IP +import Data.Word + +import Foreign.C.Types +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable as F + +import Network.Socket + +import Text.Read + + +newtype InetAddress = InetAddress { fromInetAddress :: IP.IP } + deriving (Eq, Ord) + +instance Show InetAddress where + show (InetAddress ipaddr) + | IP.IPv6 ipv6 <- ipaddr + , ( 0, 0, 0xffff, ipv4 ) <- IP.fromIPv6w ipv6 + = show (IP.toIPv4w ipv4) + + | otherwise + = show ipaddr + +instance Read InetAddress where + readPrec = do + readPrec >>= return . InetAddress . \case + IP.IPv4 ipv4 -> IP.IPv6 $ IP.toIPv6w ( 0, 0, 0xffff, IP.fromIPv4w ipv4 ) + ipaddr -> ipaddr + + readListPrec = readListPrecDefault + +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) + + +inetFromSockAddr :: SockAddr -> Maybe ( InetAddress, PortNumber ) +inetFromSockAddr saddr = first InetAddress <$> IP.fromSockAddr saddr + +inetToSockAddr :: ( InetAddress, PortNumber ) -> SockAddr +inetToSockAddr = IP.toSockAddr . first fromInetAddress diff --git a/src/Erebos/Network/Channel.hs b/src/Erebos/Network/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Erebos/Network/Channel.hs @@ -0,0 +1,175 @@ +module Erebos.Network.Channel ( + Channel, + ChannelRequest, ChannelRequestData(..), + ChannelAccept, ChannelAcceptData(..), + + createChannelRequest, + acceptChannelRequest, + acceptedChannel, + + channelEncrypt, + channelDecrypt, +) where + +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class + +import Crypto.Cipher.ChaChaPoly1305 +import Crypto.Error + +import Data.Binary +import Data.ByteArray (ByteArray, Bytes, ScrubbedBytes, convert) +import Data.ByteArray qualified as BA +import Data.ByteString.Lazy qualified as BL +import Data.List + +import Erebos.Identity +import Erebos.PubKey +import Erebos.Storable + +data Channel = Channel + { chPeers :: [Stored (Signed IdentityData)] + , chKey :: ScrubbedBytes + , chNonceFixedOur :: Bytes + , chNonceFixedPeer :: Bytes + , chCounterNextOut :: MVar Word64 + , chCounterNextIn :: MVar Word64 + } + +type ChannelRequest = Signed ChannelRequestData + +data ChannelRequestData = ChannelRequest + { crPeers :: [Stored (Signed IdentityData)] + , crKey :: Stored PublicKexKey + } + deriving (Show) + +type ChannelAccept = Signed ChannelAcceptData + +data ChannelAcceptData = ChannelAccept + { caRequest :: Stored ChannelRequest + , caKey :: Stored PublicKexKey + } + + +instance Storable ChannelRequestData where + store' cr = storeRec $ do + mapM_ (storeRef "peer") $ crPeers cr + storeRef "key" $ crKey cr + + load' = loadRec $ do + ChannelRequest + <$> loadRefs "peer" + <*> loadRef "key" + +instance Storable ChannelAcceptData where + store' ca = storeRec $ do + storeRef "req" $ caRequest ca + storeRef "key" $ caKey ca + + load' = loadRec $ do + ChannelAccept + <$> loadRef "req" + <*> loadRef "key" + + +keySize :: Int +keySize = 32 + +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 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 -> throwOtherError $ "invalid peers in channel request" + Just peers -> do + when (not $ any (self `sameIdentity`) peers) $ + throwOtherError $ "self identity missing in channel request peers" + when (not $ any (peer `sameIdentity`) peers) $ + throwOtherError $ "peer identity missing in channel request peers" + when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $ + throwOtherError $ "channel requent not signed by peer" + + (xsecret, xpublic) <- liftIO . generateKeys =<< getStorage + skey <- loadKey $ idKeyMessage self + acc <- mstore =<< sign skey =<< mstore ChannelAccept { caRequest = req, caKey = xpublic } + liftIO $ do + let chPeers = crPeers $ fromStored $ signedData $ fromStored req + chKey = BA.take keySize $ dhSecret xsecret $ + fromStored $ crKey $ fromStored $ signedData $ fromStored req + chNonceFixedOur = BA.pack [ 2, 0, 0, 0 ] + chNonceFixedPeer = BA.pack [ 1, 0, 0, 0 ] + chCounterNextOut <- newMVar 0 + chCounterNextIn <- newMVar 0 + + return (acc, 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 -> throwOtherError $ "invalid peers in channel accept" + Just peers -> do + when (not $ any (self `sameIdentity`) peers) $ + throwOtherError $ "self identity missing in channel accept peers" + when (not $ any (peer `sameIdentity`) peers) $ + throwOtherError $ "peer identity missing in channel accept peers" + when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)) $ + throwOtherError $ "channel accept not signed by peer" + when (idKeyMessage self `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $ + throwOtherError $ "original channel request not signed by us" + + xsecret <- loadKey $ crKey $ fromStored $ signedData $ fromStored req + let chPeers = crPeers $ fromStored $ signedData $ fromStored req + chKey = BA.take keySize $ dhSecret xsecret $ + fromStored $ caKey $ fromStored $ signedData $ fromStored acc + chNonceFixedOur = BA.pack [ 1, 0, 0, 0 ] + chNonceFixedPeer = BA.pack [ 2, 0, 0, 0 ] + chCounterNextOut <- liftIO $ newMVar 0 + chCounterNextIn <- liftIO $ newMVar 0 + + return Channel {..} + + +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 -> 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 e m, FromErebosError e) => Channel -> ba -> m (ba, Word64) +channelDecrypt Channel {..} body = do + when (BA.length body < 17) $ do + throwOtherError $ "invalid encrypted data length" + + expectedCount <- liftIO $ readMVar chCounterNextIn + let countByte = body `BA.index` 0 + body' = BA.dropView body 1 + guessedCount = expectedCount - 128 + fromIntegral (countByte - fromIntegral expectedCount + 128 :: Word8) + nonce = nonce8 chNonceFixedPeer $ convert $ BL.toStrict $ encode guessedCount + blen = BA.length body' - 16 + ctext = BA.takeView body' blen + tag = BA.dropView body' blen + state <- case initialize chKey =<< nonce of + CryptoPassed state -> return state + 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 + 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 --- a/src/Erebos/Network/Protocol.hs +++ b/src/Erebos/Network/Protocol.hs @@ -3,6 +3,7 @@ transportToObject, TransportHeader(..), TransportHeaderItem(..), + ServiceID(..), SecurityRequirement(..), WaitingRef(..), @@ -22,7 +23,8 @@ connSetChannel, connClose, - RawStreamReader, RawStreamWriter, + RawStreamReader(..), RawStreamWriter(..), + StreamPacket(..), connAddWriteStream, connAddReadStream, readStreamToList, @@ -65,11 +67,13 @@ 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 @@ -106,6 +110,9 @@ | StreamOpen Word8 deriving (Eq, Show) +newtype ServiceID = ServiceID UUID + deriving (Eq, Ord, Show, StorableUUID) + newtype Cookie = Cookie ByteString deriving (Eq, Show) @@ -206,6 +213,7 @@ , gControlFlow :: Flow (ControlRequest addr) (ControlMessage addr) , gNextUp :: TMVar (Connection addr, (Bool, TransportPacket PartialObject)) , gLog :: String -> STM () + , gTestLog :: String -> STM () , gStorage :: PartialStorage , gStartTime :: TimeSpec , gNowVar :: TVar TimeSpec @@ -242,6 +250,12 @@ connAddress :: Connection addr -> addr connAddress = cAddress +showConnAddress :: forall addr. Connection addr -> String +showConnAddress Connection {..} = helper cGlobalState cAddress + where + helper :: GlobalState addr -> addr -> String + helper GlobalState {} = show + connData :: Connection addr -> Flow (Maybe (Bool, TransportPacket PartialObject)) (SecurityRequirement, TransportPacket Ref, [TransportHeaderItem]) @@ -266,6 +280,7 @@ connAddWriteStream :: Connection addr -> STM (Either String (TransportHeaderItem, RawStreamWriter, IO ())) connAddWriteStream conn@Connection {..} = do + let GlobalState {..} = cGlobalState outStreams <- readTVar cOutStreams let doInsert :: Word8 -> [(Word8, Stream)] -> ExceptT String STM ((Word8, Stream), [(Word8, Stream)]) doInsert n (s@(n', _) : rest) | n == n' = @@ -282,10 +297,16 @@ runExceptT $ do ((streamNumber, stream), outStreams') <- doInsert 1 outStreams lift $ writeTVar cOutStreams outStreams' - return (StreamOpen streamNumber, sFlowIn stream, go cGlobalState streamNumber stream) + lift $ gTestLog $ "net-ostream-open " <> showConnAddress conn <> " " <> show streamNumber <> " " <> show (length outStreams') + return + ( StreamOpen streamNumber + , RawStreamWriter (fromIntegral streamNumber) (sFlowIn stream) + , go streamNumber stream + ) where - go gs@GlobalState {..} streamNumber stream = do + go streamNumber stream = do + let GlobalState {..} = cGlobalState (reserved, msg) <- atomically $ do readTVar (sState stream) >>= \case StreamRunning -> return () @@ -298,6 +319,8 @@ return (stpData, True, return ()) StreamClosed {} -> do atomically $ do + gTestLog $ "net-ostream-close-send " <> showConnAddress conn <> " " <> show streamNumber + atomically $ do -- wait for ack on all sent stream data waits <- readTVar (sWaitingForAck stream) when (waits > 0) retry @@ -322,7 +345,7 @@ 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) @@ -341,7 +364,7 @@ sendBytes conn mbReserved' bs Nothing -> return () - when cont $ go gs streamNumber stream + when cont $ go streamNumber stream connAddReadStream :: Connection addr -> Word8 -> STM RawStreamReader connAddReadStream Connection {..} streamNumber = do @@ -355,15 +378,22 @@ 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) -type RawStreamReader = Flow StreamPacket Void -type RawStreamWriter = Flow Void StreamPacket +data RawStreamReader = RawStreamReader + { rsrNum :: Int + , rsrFlow :: Flow StreamPacket Void + } +data RawStreamWriter = RawStreamWriter + { rswNum :: Int + , rswFlow :: Flow Void StreamPacket + } + data Stream = Stream { sState :: TVar StreamState , sFlowIn :: Flow Void StreamPacket @@ -393,24 +423,26 @@ Nothing -> return () streamClosed :: Connection addr -> Word8 -> IO () -streamClosed Connection {..} snum = atomically $ do - modifyTVar' cOutStreams $ filter ((snum /=) . fst) +streamClosed conn@Connection {..} snum = atomically $ do + streams <- filter ((snum /=) . fst) <$> readTVar cOutStreams + writeTVar cOutStreams streams + gTestLog cGlobalState $ "net-ostream-close-ack " <> showConnAddress conn <> " " <> show snum <> " " <> show (length streams) 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 @@ -419,10 +451,10 @@ 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 @@ -433,7 +465,7 @@ , wrefStatus :: TVar (Either [RefDigest] Ref) } -type WaitingRefCallback = ExceptT String IO () +type WaitingRefCallback = ExceptT ErebosError IO () wrDigest :: WaitingRef -> RefDigest wrDigest = refDigest . wrefPartial @@ -476,10 +508,11 @@ erebosNetworkProtocol :: (Eq addr, Ord addr, Show addr) => UnifiedIdentity -> (String -> STM ()) + -> (String -> STM ()) -> SymFlow (addr, ByteString) -> Flow (ControlRequest addr) (ControlMessage addr) -> IO () -erebosNetworkProtocol initialIdentity gLog gDataFlow gControlFlow = do +erebosNetworkProtocol initialIdentity gLog gTestLog gDataFlow gControlFlow = do gIdentity <- newTVarIO (initialIdentity, []) gConnections <- newTVarIO [] gNextUp <- newEmptyTMVarIO @@ -543,6 +576,7 @@ cOutStreams <- newTVar [] let conn = Connection {..} + gTestLog $ "net-conn-new " <> show cAddress writeTVar gConnections (conn : conns) return conn @@ -572,7 +606,7 @@ 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 @@ -587,18 +621,18 @@ 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 @@ -649,7 +683,7 @@ 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 @@ -883,7 +917,7 @@ 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 @@ -899,7 +933,10 @@ , rsOnAck = rsOnAck rs >> onAck }) <$> mbReserved sendBytes conn mbReserved' bs - Nothing -> return () + Nothing -> do + when (isJust mbReserved) $ do + atomically $ do + modifyTVar' cReservedPackets (subtract 1) let waitUntil :: TimeSpec -> TimeSpec -> STM () waitUntil now till = do diff --git a/src/Erebos/Network/ifaddrs.c b/src/Erebos/Network/ifaddrs.c --- a/src/Erebos/Network/ifaddrs.c +++ b/src/Erebos/Network/ifaddrs.c @@ -22,7 +22,7 @@ #define DISCOVERY_MULTICAST_GROUP "ff12:b6a4:6b1f:969:caee:acc2:5c93:73e1" -uint32_t * join_multicast(int fd, size_t * count) +uint32_t * erebos_join_multicast(int fd, size_t * count) { size_t capacity = 16; *count = 0; @@ -117,7 +117,7 @@ #ifndef _WIN32 -struct InetAddress * local_addresses( size_t * count ) +struct InetAddress * erebos_local_addresses( size_t * count ) { struct ifaddrs * addrs; if( getifaddrs( &addrs ) < 0 ) @@ -153,7 +153,7 @@ return ret; } -uint32_t * broadcast_addresses(void) +uint32_t * erebos_broadcast_addresses(void) { struct ifaddrs * addrs; if (getifaddrs(&addrs) < 0) @@ -196,7 +196,7 @@ #pragma comment(lib, "ws2_32.lib") -struct InetAddress * local_addresses( size_t * count ) +struct InetAddress * erebos_local_addresses( size_t * count ) { * count = 0; struct InetAddress * ret = NULL; @@ -237,7 +237,7 @@ return ret; } -uint32_t * broadcast_addresses(void) +uint32_t * erebos_broadcast_addresses(void) { uint32_t * ret = NULL; SOCKET wsock = INVALID_SOCKET; diff --git a/src/Erebos/Network/ifaddrs.h b/src/Erebos/Network/ifaddrs.h --- a/src/Erebos/Network/ifaddrs.h +++ b/src/Erebos/Network/ifaddrs.h @@ -13,6 +13,6 @@ 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); +uint32_t * erebos_join_multicast(int fd, size_t * count); +struct InetAddress * erebos_local_addresses( size_t * count ); +uint32_t * erebos_broadcast_addresses(void); diff --git a/src/Erebos/Object.hs b/src/Erebos/Object.hs new file mode 100644 --- /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 --- /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 --- a/src/Erebos/Pairing.hs +++ b/src/Erebos/Pairing.hs @@ -17,9 +17,10 @@ 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 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ _ -> "" 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 + pid <- getPeerIdentity 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 @@ 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 --- a/src/Erebos/PubKey.hs +++ b/src/Erebos/PubKey.hs @@ -11,7 +11,6 @@ ) where import Control.Monad -import Control.Monad.Except import Crypto.Error import qualified Crypto.PubKey.Ed25519 as ED @@ -21,7 +20,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 --- a/src/Erebos/Service.hs +++ b/src/Erebos/Service.hs @@ -29,13 +29,14 @@ 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, @@ -50,6 +51,9 @@ serviceNewPeer :: ServiceHandler s () serviceNewPeer = return () + serviceUpdatedPeer :: ServiceHandler s () + serviceUpdatedPeer = return () + type ServiceAttributes s = attr | attr -> s type ServiceAttributes s = Proxy s defaultServiceAttributes :: proxy s -> ServiceAttributes s @@ -105,25 +109,26 @@ 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 String IO ()) + | 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 data ServiceInput s = ServiceInput { svcAttributes :: ServiceAttributes s , svcPeer :: Peer + , svcPeerAddress :: PeerAddress , 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 @@ -131,8 +136,8 @@ , 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 @@ -149,7 +154,7 @@ 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')) @@ -182,7 +187,7 @@ 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 --- /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 --- a/src/Erebos/Set.hs +++ b/src/Erebos/Set.hs @@ -10,7 +10,6 @@ ) where import Control.Arrow -import Control.Monad.IO.Class import Data.Function import Data.List @@ -19,7 +18,8 @@ import Data.Maybe import Data.Ord -import Erebos.Storage +import Erebos.Object +import Erebos.Storable import Erebos.Storage.Merge import Erebos.Util @@ -52,14 +52,14 @@ loadSet :: Mergeable a => Ref -> Set a loadSet = mergeSorted . (:[]) . wrappedLoad -storeSetAdd :: (Mergeable a, MonadIO m) => Storage -> a -> Set a -> m (Set a) -storeSetAdd st x (Set prev) = Set . (:[]) <$> wrappedStore st SetItem +storeSetAdd :: (Mergeable a, MonadStorage m) => a -> Set a -> m (Set a) +storeSetAdd x (Set prev) = Set . (: []) <$> mstore SetItem { siPrev = prev , siItem = toComponents x } -storeSetAddComponent :: (Mergeable a, MonadStorage m, MonadIO m) => Stored (Component a) -> Set a -> m (Set a) -storeSetAddComponent component (Set prev) = Set . (:[]) <$> mstore SetItem +storeSetAddComponent :: (Mergeable a, MonadStorage m) => Stored (Component a) -> Set a -> m (Set a) +storeSetAddComponent component (Set prev) = Set . (: []) <$> mstore SetItem { siPrev = prev , siItem = [ component ] } diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs --- a/src/Erebos/State.hs +++ b/src/Erebos/State.hs @@ -1,13 +1,14 @@ module Erebos.State ( LocalState(..), - SharedState, SharedType(..), + SharedState(..), SharedType(..), SharedTypeID, mkSharedTypeID, + MonadStorage(..), MonadHead(..), updateLocalHead_, - - loadLocalStateHead, + LocalHeadT(..), + updateLocalState, updateLocalState_, updateSharedState, updateSharedState_, lookupSharedValue, makeSharedStateUpdate, @@ -15,32 +16,29 @@ headLocalIdentity, mergeSharedIdentity, - updateSharedIdentity, - interactiveIdentityUpdate, ) where +import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Data.Bifunctor import Data.ByteString (ByteString) import Data.ByteString.Char8 qualified as BC -import Data.Foldable -import Data.Maybe -import Data.Text qualified as T -import Data.Text.IO qualified as T import Data.Typeable -import Data.UUID (UUID) -import Data.UUID qualified 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 ) ] } @@ -62,14 +60,16 @@ instance Storable LocalState where 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 + lsOther <- filter ((`notElem` [ BC.pack "PREV", BC.pack "id", BC.pack "shared" ]) . fst) <$> loadRecItems return LocalState {..} instance HeadType LocalState where @@ -104,35 +104,35 @@ 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 +newtype LocalHeadT h m a = LocalHeadT { runLocalHeadT :: Storage -> Stored h -> m ( a, Stored h ) } - putStr "Device: " - hFlush stdout - devName <- T.getLine +instance Functor m => Functor (LocalHeadT h m) where + fmap f (LocalHeadT act) = LocalHeadT $ \st h -> first f <$> act st h - owner <- if - | T.null name -> return Nothing - | otherwise -> Just <$> createIdentity st (Just name) Nothing +instance Monad m => Applicative (LocalHeadT h m) where + pure x = LocalHeadT $ \_ h -> pure ( x, h ) + (<*>) = ap - identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner +instance Monad m => Monad (LocalHeadT h m) where + return = pure + LocalHeadT act >>= f = LocalHeadT $ \st h -> do + ( x, h' ) <- act st h + let (LocalHeadT act') = f x + act' st h' - 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 ] - , lsOther = [] - } +instance MonadIO m => MonadIO (LocalHeadT h m) where + liftIO act = LocalHeadT $ \_ h -> ( , h ) <$> liftIO act +instance MonadIO m => MonadStorage (LocalHeadT h m) where + getStorage = LocalHeadT $ \st h -> return ( st, h ) + +instance (HeadType h, MonadIO m) => MonadHead h (LocalHeadT h m) where + updateLocalHead f = LocalHeadT $ \st h -> do + let LocalHeadT act = f h + ( ( h', x ), _ ) <- act st h + return ( x, h' ) + + localIdentity :: LocalState -> UnifiedIdentity localIdentity ls = maybe (error "failed to verify local identity") (updateOwners $ maybe [] idExtDataF $ lookupSharedValue $ lsShared ls) @@ -142,6 +142,17 @@ 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) @@ -149,12 +160,11 @@ updateSharedState f = \ls -> do let shared = lsShared $ fromStored ls val = lookupSharedValue shared - st <- getStorage (val', x) <- f val (,x) <$> if toComponents val' == toComponents val then return ls - else do shared' <- makeSharedStateUpdate st val' shared - wrappedStore st (fromStored ls) { lsShared = [shared'] } + else do shared' <- makeSharedStateUpdate val' shared + mstore (fromStored ls) { lsShared = [shared'] } lookupSharedValue :: forall a. SharedType a => [Stored SharedState] -> a lookupSharedValue = mergeSorted . filterAncestors . map wrappedLoad . concatMap (ssValue . fromStored) . filterAncestors . helper @@ -162,46 +172,17 @@ | otherwise = helper $ ssPrev (fromStored x) ++ xs helper [] = [] -makeSharedStateUpdate :: forall a m. MonadIO m => SharedType a => Storage -> a -> [Stored SharedState] -> m (Stored SharedState) -makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState +makeSharedStateUpdate :: forall a m. (SharedType a, MonadStorage m) => a -> [ Stored SharedState ] -> m (Stored SharedState) +makeSharedStateUpdate val prev = mstore SharedState { ssPrev = prev , ssType = Just $ sharedTypeID @a Proxy , ssValue = storedRef <$> toComponents val } -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 fidentity = do - identity <- mergeIdentity fidentity - 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 -> return identity - | otherwise -> do - secret <- loadKey $ idKeyIdentity identity - maybe (throwError "created invalid identity") return . validateExtendedIdentity =<< - mstore =<< sign secret =<< mstore . ExtendedIdentityData =<< return (emptyIdentityExtension $ idData identity) - { idePrev = toList $ idExtDataF identity - , ideName = Just name - } + Nothing -> throwOtherError "no existing shared identity" diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs new file mode 100644 --- /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 --- a/src/Erebos/Storage.hs +++ b/src/Erebos/Storage.hs @@ -1,1087 +1,29 @@ -module Erebos.Storage ( - Storage, PartialStorage, StorageCompleteness, - openStorage, memoryStorage, - deriveEphemeralStorage, derivePartialStorage, - - Ref, PartialRef, RefDigest, - refDigest, refFromDigest, - 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, - 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, - storeRecItems, - - 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 = 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 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 - -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 - 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) - | 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 (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 $ 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 -> return $ UnknownObject otype content - _ -> 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 - - 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 - _ -> 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 - ev@Added {} | Just ihid <- HeadID <$> U.fromString (takeFileName (eventPath ev)) -> 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 - | 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 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 - 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 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)] - -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 - _ -> 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 = 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 (throwError $ "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 (throwError $ "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 (throwError $ "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 (throwError $ "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 (throwError $ "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 (throwError $ "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 (throwError $ "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 - - -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 +{-| +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, + openStorage, memoryStorage, + deriveEphemeralStorage, derivePartialStorage, + + Head, HeadType, + HeadID, HeadTypeID, + headId, headStorage, headRef, headObject, headStoredObject, + loadHeads, loadHead, reloadHead, + storeHead, replaceHead, updateHead, updateHead_, + + WatchedHead, + watchHead, watchHeadWith, unwatchHead, + watchHeadRaw, + + MonadStorage(..), +) where + +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 --- /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 --- /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 --- /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 --- a/src/Erebos/Storage/Internal.hs +++ b/src/Erebos/Storage/Internal.hs @@ -1,89 +1,179 @@ -module Erebos.Storage.Internal where +module Erebos.Storage.Internal ( + Storage'(..), Storage, PartialStorage, + Ref'(..), Ref, PartialRef, + RefDigest(..), + WatchID, startWatchID, nextWatchID, + WatchList(..), WatchListItem(..), watchListAdd, watchListDel, -import Codec.Compression.Zlib + 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 + show Storage { stBackend = b } = show b ++ showParentStorage b -showParentStorage :: Storage' c -> String -showParentStorage Storage { stParent = Nothing } = "" -showParentStorage Storage { stParent = Just st } = "@" ++ show st +showParentStorage :: StorageBackend bck => bck -> String +showParentStorage bck + | Just (st :: Storage) <- cast (backendParent bck) = "@" ++ show st + | Just (st :: PartialStorage) <- cast (backendParent bck) = "@" ++ show st + | otherwise = "" -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) +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) -data WatchList c = WatchList +startWatchID :: WatchID +startWatchID = WatchID 1 + +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 @@ 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 @@ 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 @@ 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 --- a/src/Erebos/Storage/Key.hs +++ b/src/Erebos/Storage/Key.hs @@ -4,21 +4,14 @@ 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 System.Directory -import System.FilePath -import System.IO.Error +import Data.Typeable -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 @@ 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 --- /dev/null +++ b/src/Erebos/Storage/Memory.hs @@ -0,0 +1,107 @@ +module Erebos.Storage.Memory ( + memoryStorage, + deriveEphemeralStorage, + derivePartialStorage, +) where + +import Control.Concurrent +import Control.Monad + +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 + case partition ((==(tid, hid)) . fst) hs of + ( [] , _ ) -> return ( hs, Left Nothing ) + (( _, dgst ) : _, hs' ) + | dgst == expected -> do + ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar memWatchers + return ((( tid, hid ), new ) : hs', Right ( new, ws )) + | otherwise -> do + return ( hs, Left $ Just dgst ) + case res of + Right ( dgst, ws ) -> do + void $ forkIO $ do + 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 --- a/src/Erebos/Storage/Merge.hs +++ b/src/Erebos/Storage/Merge.hs @@ -7,7 +7,7 @@ compareGeneration, generationMax, storedGeneration, - generations, + generations, generationsBy, ancestors, precedes, precedesOrEquals, @@ -17,6 +17,8 @@ findProperty, findPropertyFirst, + + storedDifference, ) where import Control.Concurrent.MVar @@ -25,13 +27,16 @@ import Data.HashTable.IO qualified as HT import Data.Kind import Data.List +import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty qualified as NE import Data.Maybe import Data.Set (Set) 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 +56,7 @@ 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 @@ -99,16 +104,24 @@ -- |Returns list of sets starting with the set of given objects and -- intcrementally adding parents. -generations :: Storable a => [Stored a] -> [Set (Stored a)] -generations = unfoldr gen . (,S.empty) - where gen (hs, cur) = case filter (`S.notMember` cur) hs of - [] -> Nothing - added -> let next = foldr S.insert cur added - in Just (next, (previous =<< added, next)) +generations :: Storable a => [ Stored a ] -> NonEmpty (Set (Stored a)) +generations = generationsBy previous +-- |Returns list of sets starting with the set of given objects and +-- intcrementally adding parents, with the first parameter being +-- a function to get all the parents of given object. +generationsBy :: Ord a => (a -> [ a ]) -> [ a ] -> NonEmpty (Set a) +generationsBy parents xs = NE.unfoldr gen ( xs, S.fromList xs ) + where + gen ( hs, cur ) = ( cur, ) $ + case filter (`S.notMember` cur) (parents =<< hs) of + [] -> Nothing + added -> let next = foldr S.insert cur added + in Just ( added, next ) + -- |Returns set containing all given objects and their ancestors ancestors :: Storable a => [Stored a] -> Set (Stored a) -ancestors = last . (S.empty:) . generations +ancestors = NE.last . generations precedes :: Storable a => Stored a -> Stored a -> Bool precedes x y = not $ x `elem` filterAncestors [x, y] @@ -161,3 +174,18 @@ findPropHeads :: forall a b. Storable a => (a -> Maybe b) -> Stored a -> [Stored a] findPropHeads sel sobj | Just _ <- sel $ fromStored sobj = [sobj] | otherwise = findPropHeads sel =<< previous sobj + + +-- | Compute symmetrict difference between two stored histories. In other +-- words, return all 'Stored a' objects reachable (via 'previous') from first +-- given set, but not from the second; and vice versa. +storedDifference :: Storable a => [ Stored a ] -> [ Stored a ] -> [ Stored a ] +storedDifference xs' ys' = + let xs = filterAncestors xs' + ys = filterAncestors ys' + + filteredPrevious blocked zs = filterAncestors (previous zs ++ blocked) `diffSorted` blocked + xg = S.toAscList $ NE.last $ generationsBy (filteredPrevious ys) $ filterAncestors (xs ++ ys) `diffSorted` ys + yg = S.toAscList $ NE.last $ generationsBy (filteredPrevious xs) $ filterAncestors (ys ++ xs) `diffSorted` xs + + in xg `mergeUniq` yg diff --git a/src/Erebos/Sync.hs b/src/Erebos/Sync.hs --- a/src/Erebos/Sync.hs +++ b/src/Erebos/Sync.hs @@ -10,7 +10,7 @@ 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 @@ 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 @@ -31,6 +31,7 @@ else return ls serviceNewPeer = notifyPeer . lsShared . fromStored =<< svcGetLocal + serviceUpdatedPeer = serviceNewPeer serviceStorageWatchers _ = (:[]) $ SomeStorageWatcher (lsShared . fromStored) notifyPeer instance Storable SyncService where diff --git a/src/Erebos/UUID.hs b/src/Erebos/UUID.hs new file mode 100644 --- /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 --- 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) @@ -13,15 +22,16 @@ mergeBy _ xs [] = xs mergeBy _ [] ys = ys -mergeUniqBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] -mergeUniqBy cmp (x : xs) (y : ys) = case cmp x y of - LT -> x : mergeBy cmp xs (y : ys) - EQ -> x : mergeBy cmp xs ys - GT -> y : mergeBy cmp (x : xs) ys +mergeUniqBy :: (a -> a -> Ordering) -> [ a ] -> [ a ] -> [ a ] +mergeUniqBy cmp (x : xs) (y : ys) = + case cmp x y of + LT -> x : mergeUniqBy cmp xs (y : ys) + EQ -> x : mergeUniqBy cmp xs ys + GT -> y : mergeUniqBy cmp (x : xs) ys mergeUniqBy _ xs [] = xs mergeUniqBy _ [] ys = ys -mergeUniq :: Ord a => [a] -> [a] -> [a] +mergeUniq :: Ord a => [ a ] -> [ a ] -> [ a ] mergeUniq = mergeUniqBy compare diffSorted :: Ord a => [a] -> [a] -> [a] @@ -35,3 +45,24 @@ | 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