diff options
43 files changed, 2266 insertions, 955 deletions
@@ -137,6 +137,13 @@ are signed, so message author can not be forged. : Leave the chatroom. User will no longer be listed as a member and erebos tool will no longer collect message of this chatroom. +`/delete` +: Delete the chatroom; this action is only synchronized with devices belonging +to the current user and does not affect the chatroom state for others. Due to +the storage design, the chatroom data will not be purged from the local state +history, but the chatroom will no longer be listed as available and no futher +updates for this chatroom will be collected or shared with other peers. + ### Add contacts To ensure the identity of the contact and prevent man-in-the-middle attack, @@ -216,8 +223,11 @@ target device with `/<number>`. Storage ------- -Data are by default stored within `.erebos` subdirectory of the current working -directory. This can be overriden by `EREBOS_DIR` environment variable. +Data are by default stored under `XDG_DATA_HOME`, typically +`$HOME/.local/share/erebos`, unless there is an erebos storage already +in `.erebos` subdirectory of the current working directory, in which case the +latter one in used instead. This can be overriden by `EREBOS_DIR` environment +variable. Private keys are currently stored in plaintext under the `keys` subdirectory of the erebos directory. diff --git a/erebos.cabal b/erebos.cabal index ba00538..aa16899 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -40,11 +40,12 @@ Flag ci source-repository head type: git - location: git://erebosprotocol.net/erebos + location: https://code.erebosprotocol.net/erebos common common ghc-options: -Wall + -Wno-x-partial -fdefer-typed-holes if flag(ci) @@ -54,7 +55,7 @@ common common -Wno-error=unused-imports build-depends: - base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 }, + base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 }, default-extensions: DefaultSignatures @@ -98,6 +99,8 @@ library Erebos.Contact Erebos.Conversation Erebos.DirectMessage + Erebos.Discovery + Erebos.Error Erebos.Identity Erebos.Network Erebos.Network.Channel @@ -110,16 +113,18 @@ library 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.Object.Internal + Erebos.Storage.Disk + Erebos.Storage.Internal + Erebos.Storage.Memory Erebos.Storage.Platform Erebos.Util @@ -130,7 +135,6 @@ library if flag(ice) exposed-modules: - Erebos.Discovery Erebos.ICE c-sources: src/Erebos/ICE/pjproject.c @@ -146,21 +150,21 @@ library binary >=0.8 && <0.11, bytestring >=0.10 && <0.13, clock >=0.8 && < 0.9, - containers >= 0.6 && <0.8, - crypton ^>= { 1.0 }, + containers ^>= { 0.6, 0.7, 0.8 }, + crypton ^>= { 0.34, 1.0 }, deepseq >= 1.4 && <1.6, directory >= 1.3 && <1.4, filepath >=1.4 && <1.6, - fsnotify ^>= { 0.4 }, - hashable >=1.3 && <1.5, - hashtables >=1.2 && <1.4, + fsnotify ^>= { 0.3, 0.4 }, + hashable ^>= { 1.3, 1.4, 1.5 }, + hashtables ^>= { 1.2, 1.3, 1.4 }, iproute >=1.7.12 && <1.8, memory >=0.14 && <0.19, mtl >=2.2 && <2.4, - network >= 3.1 && <3.2, + network ^>= { 3.1, 3.2 }, stm >=2.5 && <2.6, text >= 1.2 && <2.2, - time >= 1.8 && <1.14, + time ^>= { 1.8, 1.9, 1.10, 1.11, 1.12, 1.13, 1.14 }, uuid >=1.3 && <1.4, zlib >=0.6 && <0.8 @@ -182,6 +186,8 @@ executable erebos main-is: Main.hs other-modules: Paths_erebos + State + Terminal Test Test.Service Version @@ -190,15 +196,16 @@ executable erebos Paths_erebos build-depends: + ansi-terminal ^>= { 0.11, 1.0, 1.1 }, bytestring, crypton, directory, erebos, - haskeline >=0.7 && <0.9, mtl, network, process >=1.6 && <1.7, - template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22 }, + stm, + template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 }, text, time, transformers >= 0.5 && <0.7, diff --git a/main/Main.hs b/main/Main.hs index 7f9250b..3f78db1 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -31,7 +31,7 @@ import Data.Typeable import Network.Socket import System.Console.GetOpt -import System.Console.Haskeline +import System.Directory import System.Environment import System.Exit import System.IO @@ -41,8 +41,8 @@ import Erebos.Contact import Erebos.Chatroom import Erebos.Conversation import Erebos.DirectMessage -#ifdef ENABLE_ICE_SUPPORT import Erebos.Discovery +#ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif import Erebos.Identity @@ -57,6 +57,8 @@ import Erebos.Storage import Erebos.Storage.Merge import Erebos.Sync +import State +import Terminal import Test import Version @@ -104,10 +106,8 @@ availableServices = True "create contacts with network peers" , ServiceOption "dm" (someService @DirectMessage Proxy) True "direct messages" -#ifdef ENABLE_ICE_SUPPORT , ServiceOption "discovery" (someService @DiscoveryService Proxy) True "peer discovery" -#endif ] options :: [OptDescr (Options -> Options)] @@ -127,6 +127,20 @@ options = , Option [] ["chatroom-auto-subscribe"] (ReqArg (\count -> \opts -> opts { optChatroomAutoSubscribe = Just (read count) }) "<count>") "automatically subscribe for up to <count> chatrooms" +#ifdef ENABLE_ICE_SUPPORT + , Option [] [ "discovery-stun-port" ] + (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunPort = Just (read value) }) "<port>") + "offer specified <port> to discovery peers for STUN protocol" + , Option [] [ "discovery-stun-server" ] + (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryStunServer = Just (read value) }) "<server>") + "offer <server> (domain name or IP address) to discovery peers for STUN protocol" + , Option [] [ "discovery-turn-port" ] + (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnPort = Just (read value) }) "<port>") + "offer specified <port> to discovery peers for TURN protocol" + , Option [] [ "discovery-turn-server" ] + (ReqArg (\value -> serviceAttr $ \attrs -> attrs { discoveryTurnServer = Just (read value) }) "<server>") + "offer <server> (domain name or IP address) to discovery peers for TURN protocol" +#endif , Option [] ["dm-bot-echo"] (ReqArg (\prefix -> \opts -> opts { optDmBotEcho = Just (T.pack prefix) }) "<prefix>") "automatically reply to direct messages with the same text prefixed with <prefix>" @@ -137,7 +151,16 @@ options = (NoArg $ \opts -> opts { optShowVersion = True }) "show version and exit" ] - where so f opts = opts { optServer = f $ optServer opts } + where + so f opts = opts { optServer = f $ optServer opts } + + updateService :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> SomeService -> SomeService + updateService f some@(SomeService proxy attrs) + | Just f' <- cast f = SomeService proxy (f' attrs) + | otherwise = some + + serviceAttr :: Service s => (ServiceAttributes s -> ServiceAttributes s) -> Options -> Options + serviceAttr f opts = opts { optServices = map (\sopt -> sopt { soptService = updateService f (soptService sopt) }) (optServices opts) } servicesOptions :: [OptDescr (Options -> Options)] servicesOptions = concatMap helper $ "all" : map soptName availableServices @@ -154,6 +177,14 @@ servicesOptions = concatMap helper $ "all" : map soptName availableServices | otherwise = s : change name f ss change _ _ [] = [] +getDefaultStorageDir :: IO FilePath +getDefaultStorageDir = do + lookupEnv "EREBOS_DIR" >>= \case + Just dir -> return dir + Nothing -> doesFileExist "./.erebos/erebos-storage" >>= \case + True -> return "./.erebos" + False -> getXdgDirectory XdgData "erebos" + main :: IO () main = do (opts, args) <- (getOpt RequireOrder (options ++ servicesOptions) <$> getArgs) >>= \case @@ -165,7 +196,7 @@ main = do exitFailure st <- liftIO $ case optStorage opts of - DefaultStorage -> openStorage . fromMaybe "./.erebos" =<< lookupEnv "EREBOS_DIR" + DefaultStorage -> openStorage =<< getDefaultStorageDir FilesystemStorage path -> openStorage path MemoryStorage -> memoryStorage @@ -205,17 +236,20 @@ main = do Nothing -> error "ref does not exist" Just ref -> print $ storedGeneration (wrappedLoad ref :: Stored Object) - ["update-identity"] -> either fail return <=< runExceptT $ do - runReaderT updateSharedIdentity =<< loadLocalStateHead st + ["update-identity"] -> do + withTerminal noCompletion $ \term -> do + either (fail . showErebosError) return <=< runExceptT $ do + runReaderT (updateSharedIdentity term) =<< loadLocalStateHead term st ("update-identity" : srefs) -> do - sequence <$> mapM (readRef st . BC.pack) srefs >>= \case - Nothing -> error "ref does not exist" - Just refs - | Just idt <- validateIdentityF $ map wrappedLoad refs -> do - BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< - (either fail return <=< runExceptT $ runReaderT (interactiveIdentityUpdate idt) st) - | otherwise -> error "invalid identity" + withTerminal noCompletion $ \term -> do + sequence <$> mapM (readRef st . BC.pack) srefs >>= \case + Nothing -> error "ref does not exist" + Just refs + | Just idt <- validateIdentityF $ map wrappedLoad refs -> do + BC.putStrLn . showRefDigest . refDigest . storedRef . idData =<< + (either (fail . showErebosError) return <=< runExceptT $ runReaderT (interactiveIdentityUpdate term idt) st) + | otherwise -> error "invalid identity" ["test"] -> runTestTool st @@ -245,22 +279,16 @@ main = do exitFailure -inputSettings :: Settings IO -inputSettings = setComplete commandCompletion $ defaultSettings - interactiveLoop :: Storage -> Options -> IO () -interactiveLoop st opts = runInputT inputSettings $ do - erebosHead <- liftIO $ loadLocalStateHead st - outputStrLn $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead - - tui <- haveTerminalUI - extPrint <- getExternalPrint - let extPrintLn str = do - let str' = case reverse str of ('\n':_) -> str - _ -> str ++ "\n"; - extPrint $! str' -- evaluate str before calling extPrint to avoid blinking - - let getInputLinesTui eprompt = do +interactiveLoop st opts = withTerminal commandCompletion $ \term -> do + erebosHead <- liftIO $ loadLocalStateHead term st + void $ printLine term $ T.unpack $ displayIdentity $ headLocalIdentity erebosHead + + let tui = hasTerminalUI term + let extPrintLn = void . printLine term + + let getInputLinesTui :: Either CommandState String -> MaybeT IO String + getInputLinesTui eprompt = do prompt <- case eprompt of Left cstate -> do pname <- case csContext cstate of @@ -274,11 +302,14 @@ interactiveLoop st opts = runInputT inputSettings $ do SelectedConversation conv -> return $ T.unpack $ conversationName conv return $ pname ++ "> " Right prompt -> return prompt - Just input <- lift $ getInputLine prompt - case reverse input of - _ | all isSpace input -> getInputLinesTui eprompt - '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ") - _ -> return input + lift $ setPrompt term prompt + join $ lift $ getInputLine term $ \case + Just input@('/' : _) -> KeepPrompt $ return input + Just input -> ErasePrompt $ case reverse input of + _ | all isSpace input -> getInputLinesTui eprompt + '\\':rest -> (reverse ('\n':rest) ++) <$> getInputLinesTui (Right ">> ") + _ -> return input + Nothing -> KeepPrompt mzero getInputCommandTui cstate = do input <- getInputLinesTui cstate @@ -291,7 +322,7 @@ interactiveLoop st opts = runInputT inputSettings $ do return (cmd, line) getInputLinesPipe = do - lift (getInputLine "") >>= \case + join $ lift $ getInputLine term $ KeepPrompt . \case Just input -> return input Nothing -> liftIO $ forever $ threadDelay 100000000 @@ -352,15 +383,16 @@ interactiveLoop st opts = runInputT inputSettings $ do when (Just shown /= op) $ extPrintLn $ "[" <> show idx <> "] PEER " <> updateType' <> " " <> shown _ -> return () - let process :: CommandState -> MaybeT (InputT IO) CommandState + let process :: CommandState -> MaybeT IO CommandState process cstate = do (cmd, line) <- getInputCommand cstate h <- liftIO (reloadHead $ csHead cstate) >>= \case Just h -> return h - Nothing -> do lift $ lift $ extPrintLn "current head deleted" + Nothing -> do lift $ extPrintLn "current head deleted" mzero res <- liftIO $ runExceptT $ flip execStateT cstate { csHead = h } $ runReaderT cmd CommandInput { ciServer = server + , ciTerminal = term , ciLine = line , ciPrint = extPrintLn , ciOptions = opts @@ -377,7 +409,7 @@ interactiveLoop st opts = runInputT inputSettings $ do | csQuit cstate' -> mzero | otherwise -> return cstate' Left err -> do - lift $ lift $ extPrintLn $ "Error: " ++ err + lift $ extPrintLn $ "Error: " ++ showErebosError err return cstate let loop (Just cstate) = runMaybeT (process cstate) >>= loop @@ -396,6 +428,7 @@ interactiveLoop st opts = runInputT inputSettings $ do data CommandInput = CommandInput { ciServer :: Server + , ciTerminal :: Terminal , ciLine :: String , ciPrint :: String -> IO () , ciOptions :: Options @@ -423,15 +456,15 @@ data CommandContext = NoContext | SelectedChatroom ChatroomState | SelectedConversation Conversation -newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError String) +newtype CommandM a = CommandM (ReaderT CommandInput (StateT CommandState (ExceptT ErebosError IO)) a) + deriving (Functor, Applicative, Monad, MonadReader CommandInput, MonadState CommandState, MonadError ErebosError) instance MonadFail CommandM where - fail = throwError + fail = throwOtherError instance MonadIO CommandM where liftIO act = CommandM (liftIO (try act)) >>= \case - Left (e :: SomeException) -> throwError (show e) + Left (e :: SomeException) -> throwOtherError (show e) Right x -> return x instance MonadRandom CommandM where @@ -452,27 +485,27 @@ type Command = CommandM () getSelectedPeer :: CommandM Peer getSelectedPeer = gets csContext >>= \case SelectedPeer peer -> return peer - _ -> throwError "no peer selected" + _ -> throwOtherError "no peer selected" getSelectedChatroom :: CommandM ChatroomState getSelectedChatroom = gets csContext >>= \case SelectedChatroom rstate -> return rstate - _ -> throwError "no chatroom selected" + _ -> throwOtherError "no chatroom selected" getSelectedConversation :: CommandM Conversation getSelectedConversation = gets csContext >>= \case SelectedPeer peer -> peerIdentity peer >>= \case PeerIdentityFull pid -> directMessageConversation $ finalOwner pid - _ -> throwError "incomplete peer identity" + _ -> throwOtherError "incomplete peer identity" SelectedContact contact -> case contactIdentity contact of Just cid -> directMessageConversation cid - Nothing -> throwError "contact without erebos identity" + Nothing -> throwOtherError "contact without erebos identity" SelectedChatroom rstate -> chatroomConversation rstate >>= \case Just conv -> return conv - Nothing -> throwError "invalid chatroom" + Nothing -> throwOtherError "invalid chatroom" SelectedConversation conv -> reloadConversation conv - _ -> throwError "no contact, peer or conversation selected" + _ -> throwOtherError "no contact, peer or conversation selected" commands :: [(String, Command)] commands = @@ -482,6 +515,7 @@ commands = , ("peer-add-public", cmdPeerAddPublic) , ("peer-drop", cmdPeerDrop) , ("send", cmdSend) + , ("delete", cmdDelete) , ("update-identity", cmdUpdateIdentity) , ("attach", cmdAttach) , ("attach-accept", cmdAttachAccept) @@ -494,9 +528,9 @@ commands = , ("contact-reject", cmdContactReject) , ("conversations", cmdConversations) , ("details", cmdDetails) -#ifdef ENABLE_ICE_SUPPORT , ("discovery-init", cmdDiscoveryInit) , ("discovery", cmdDiscovery) +#ifdef ENABLE_ICE_SUPPORT , ("ice-create", cmdIceCreate) , ("ice-destroy", cmdIceDestroy) , ("ice-show", cmdIceShow) @@ -519,8 +553,13 @@ commandCompletion = completeWordWithPrev Nothing [ ' ', '\t', '\n', '\r' ] $ cur sortedCommandNames = sort $ map fst commands +cmdPutStrLn :: String -> Command +cmdPutStrLn str = do + term <- asks ciTerminal + void $ liftIO $ printLine term str + cmdUnknown :: String -> Command -cmdUnknown cmd = liftIO $ putStrLn $ "Unknown command: " ++ cmd +cmdUnknown cmd = cmdPutStrLn $ "Unknown command: " ++ cmd cmdPeers :: Command cmdPeers = do @@ -528,7 +567,7 @@ cmdPeers = do set <- asks ciSetContextOptions set $ map (SelectedPeer . fst) peers forM_ (zip [1..] peers) $ \(i :: Int, (_, name)) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ name + cmdPutStrLn $ "[" ++ show i ++ "] " ++ name cmdPeerAdd :: Command cmdPeerAdd = void $ do @@ -536,7 +575,7 @@ cmdPeerAdd = void $ do (hostname, port) <- (words <$> asks ciLine) >>= \case hostname:p:_ -> return (hostname, p) [hostname] -> return (hostname, show discoveryPort) - [] -> throwError "missing peer address" + [] -> throwOtherError "missing peer address" addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) liftIO $ serverPeer server (addrAddress addr) @@ -587,7 +626,7 @@ cmdMembers :: Command cmdMembers = do Just room <- findChatroomByStateData . head . roomStateData =<< getSelectedChatroom forM_ (chatroomMembers room) $ \x -> do - liftIO $ putStrLn $ maybe "<unnamed>" T.unpack $ idName x + cmdPutStrLn $ maybe "<unnamed>" T.unpack $ idName x cmdSelectContext :: Command @@ -601,7 +640,7 @@ cmdSelectContext = do when (not (roomStateSubscribe rstate)) $ do chatroomSetSubscribe (head $ roomStateData rstate) True _ -> return () - | otherwise -> throwError "invalid index" + | otherwise -> throwOtherError "invalid index" cmdSend :: Command cmdSend = void $ do @@ -610,22 +649,28 @@ cmdSend = void $ do sendMessage conv (T.pack text) >>= \case Just msg -> do tzone <- liftIO $ getCurrentTimeZone - liftIO $ putStrLn $ formatMessage tzone msg + cmdPutStrLn $ formatMessage tzone msg Nothing -> return () +cmdDelete :: Command +cmdDelete = void $ do + deleteConversation =<< getSelectedConversation + modify $ \s -> s { csContext = NoContext } + cmdHistory :: Command cmdHistory = void $ do conv <- getSelectedConversation case conversationHistory conv of thread@(_:_) -> do tzone <- liftIO $ getCurrentTimeZone - liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 thread + mapM_ (cmdPutStrLn . formatMessage tzone) $ reverse $ take 50 thread [] -> do - liftIO $ putStrLn $ "<empty history>" + cmdPutStrLn $ "<empty history>" cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do - runReaderT updateSharedIdentity =<< gets csHead + term <- asks ciTerminal + runReaderT (updateSharedIdentity term) =<< gets csHead cmdAttach :: Command cmdAttach = attachToOwner =<< getSelectedPeer @@ -659,7 +704,7 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do watchChatrooms h $ \set -> \case Nothing -> do - let chatroomList = fromSetBy (comparing roomStateData) set + let chatroomList = filter (not . roomStateDeleted) $ fromSetBy (comparing roomStateData) set (subscribed, notSubscribed) = partition roomStateSubscribe chatroomList subscribedNum = length subscribed @@ -672,7 +717,7 @@ watchChatroomsForCli eprint h chatroomSetVar contextVar autoSubscribe = do forM_ (take (num - subscribedNum) notSubscribed) $ \rstate -> do (runExceptT $ flip runReaderT h $ chatroomSetSubscribe (head $ roomStateData rstate) True) >>= \case Right () -> return () - Left err -> eprint err + Left err -> eprint (showErebosError err) Just diff -> do modifyMVar_ chatroomSetVar $ return . const set @@ -719,20 +764,20 @@ cmdChatrooms :: Command cmdChatrooms = do ensureWatchedChatrooms chatroomSetVar <- asks ciChatroomSetVar - chatroomList <- fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) + chatroomList <- filter (not . roomStateDeleted) . fromSetBy (comparing roomStateData) <$> liftIO (readMVar chatroomSetVar) set <- asks ciSetContextOptions set $ map SelectedChatroom chatroomList forM_ (zip [1..] chatroomList) $ \(i :: Int, rstate) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate) + cmdPutStrLn $ "[" ++ show i ++ "] " ++ maybe "<unnamed>" T.unpack (roomName =<< roomStateRoom rstate) cmdChatroomCreatePublic :: Command cmdChatroomCreatePublic = do + term <- asks ciTerminal name <- asks ciLine >>= \case line | not (null line) -> return $ T.pack line _ -> liftIO $ do - T.putStr $ T.pack "Name: " - hFlush stdout - T.getLine + setPrompt term "Name: " + getInputLine term $ KeepPrompt . maybe T.empty T.pack ensureWatchedChatrooms void $ createChatroom @@ -748,8 +793,8 @@ cmdContacts = do verbose = "-v" `elem` args set <- asks ciSetContextOptions set $ map SelectedContact contacts - forM_ (zip [1..] contacts) $ \(i :: Int, c) -> liftIO $ do - T.putStrLn $ T.concat + forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do + cmdPutStrLn $ T.unpack $ T.concat [ "[", T.pack (show i), "] ", contactName c , case contactIdentity c of Just idt | cname <- displayIdentity idt @@ -775,36 +820,36 @@ cmdConversations = do set <- asks ciSetContextOptions set $ map SelectedConversation conversations forM_ (zip [1..] conversations) $ \(i :: Int, conv) -> do - liftIO $ putStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) + cmdPutStrLn $ "[" ++ show i ++ "] " ++ T.unpack (conversationName conv) cmdDetails :: Command cmdDetails = do gets csContext >>= \case SelectedPeer peer -> do - liftIO $ putStr $ unlines + cmdPutStrLn $ unlines [ "Network peer:" , " " <> show (peerAddress peer) ] peerIdentity peer >>= \case - PeerIdentityUnknown _ -> liftIO $ do - putStrLn $ "unknown identity" - PeerIdentityRef wref _ -> liftIO $ do - putStrLn $ "Identity ref:" - putStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref) + PeerIdentityUnknown _ -> do + cmdPutStrLn $ "unknown identity" + PeerIdentityRef wref _ -> do + cmdPutStrLn $ "Identity ref:" + cmdPutStrLn $ " " <> BC.unpack (showRefDigest $ wrDigest wref) PeerIdentityFull pid -> printContactOrIdentityDetails pid SelectedContact contact -> do printContactDetails contact SelectedChatroom rstate -> do - liftIO $ putStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate) + cmdPutStrLn $ "Chatroom: " <> (T.unpack $ fromMaybe (T.pack "<unnamed>") $ roomName =<< roomStateRoom rstate) SelectedConversation conv -> do case conversationPeer conv of Just pid -> printContactOrIdentityDetails pid - Nothing -> liftIO $ putStrLn $ "(conversation without peer)" + Nothing -> cmdPutStrLn $ "(conversation without peer)" - NoContext -> liftIO $ putStrLn "nothing selected" + NoContext -> cmdPutStrLn "nothing selected" where printContactOrIdentityDetails cid = do contacts <- fromSetBy (comparing contactName) . lookupSharedValue . lsShared . fromStored <$> getLocalHead @@ -812,11 +857,11 @@ cmdDetails = do Just contact -> printContactDetails contact Nothing -> printIdentityDetails cid - printContactDetails contact = liftIO $ do - putStrLn $ "Contact:" + printContactDetails contact = do + cmdPutStrLn $ "Contact:" prefix <- case contactCustomName contact of Just name -> do - putStrLn $ " " <> T.unpack name + cmdPutStrLn $ " " <> T.unpack name return $ Just "alias of" Nothing -> do return $ Nothing @@ -825,23 +870,21 @@ cmdDetails = do Just cid -> do printIdentityDetailsBody prefix cid Nothing -> do - putStrLn $ " (without erebos identity)" + cmdPutStrLn $ " (without erebos identity)" - printIdentityDetails identity = liftIO $ do - putStrLn $ "Identity:" + printIdentityDetails identity = do + cmdPutStrLn $ "Identity:" printIdentityDetailsBody Nothing identity printIdentityDetailsBody prefix identity = do forM_ (zip (False : repeat True) $ unfoldOwners identity) $ \(owned, cpid) -> do - putStrLn $ unwords $ concat + cmdPutStrLn $ unwords $ concat [ [ " " ] , if owned then [ "owned by" ] else maybeToList prefix , [ maybe "<unnamed>" T.unpack (idName cpid) ] , map (BC.unpack . showRefDigest . refDigest . storedRef) $ idExtDataF cpid ] -#ifdef ENABLE_ICE_SUPPORT - cmdDiscoveryInit :: Command cmdDiscoveryInit = void $ do server <- asks ciServer @@ -852,7 +895,7 @@ cmdDiscoveryInit = void $ do [] -> ("discovery.erebosprotocol.net", show discoveryPort) addr:_ <- liftIO $ getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just hostname) (Just port) peer <- liftIO $ serverPeer server (addrAddress addr) - sendToPeer peer $ DiscoverySelf (T.pack "ICE") 0 + sendToPeer peer $ DiscoverySelf [ T.pack "ICE" ] Nothing modify $ \s -> s { csIcePeer = Just peer } cmdDiscovery :: Command @@ -869,14 +912,39 @@ cmdDiscovery = void $ do Right _ -> return () Left err -> eprint err +#ifdef ENABLE_ICE_SUPPORT + cmdIceCreate :: Command cmdIceCreate = do - role <- asks ciLine >>= return . \case - 'm':_ -> PjIceSessRoleControlling - 's':_ -> PjIceSessRoleControlled - _ -> PjIceSessRoleUnknown + let getRole = \case + 'm':_ -> PjIceSessRoleControlling + 's':_ -> PjIceSessRoleControlled + _ -> PjIceSessRoleUnknown + + ( role, stun, turn ) <- asks (words . ciLine) >>= \case + [] -> return ( PjIceSessRoleControlling, Nothing, Nothing ) + [ role ] -> return + ( getRole role, Nothing, Nothing ) + [ role, server ] -> return + ( getRole role + , Just ( T.pack server, 0 ) + , Just ( T.pack server, 0 ) + ) + [ role, server, port ] -> return + ( getRole role + , Just ( T.pack server, read port ) + , Just ( T.pack server, read port ) + ) + [ role, stunServer, stunPort, turnServer, turnPort ] -> return + ( getRole role + , Just ( T.pack stunServer, read stunPort ) + , Just ( T.pack turnServer, read turnPort ) + ) + _ -> throwOtherError "invalid parameters" + eprint <- asks ciPrint - sess <- liftIO $ iceCreate role $ eprint <=< iceShow + Just cfg <- liftIO $ iceCreateConfig stun turn + sess <- liftIO $ iceCreateSession cfg role $ eprint <=< iceShow modify $ \s -> s { csIceSessions = sess : csIceSessions s } cmdIceDestroy :: Command @@ -897,11 +965,15 @@ cmdIceConnect :: Command cmdIceConnect = do s:_ <- gets csIceSessions server <- asks ciServer - let loadInfo = BC.getLine >>= \case line | BC.null line -> return [] - | otherwise -> (line:) <$> loadInfo + term <- asks ciTerminal + let loadInfo = + getInputLine term (KeepPrompt . maybe BC.empty BC.pack) >>= \case + line | BC.null line -> return [] + | otherwise -> (line :) <$> loadInfo Right remote <- liftIO $ do st <- memoryStorage pst <- derivePartialStorage st + setPrompt term "" rbytes <- (BL.fromStrict . BC.unlines) <$> loadInfo copyRef st =<< storeRawBytes pst (BL.fromChunks [ BC.pack "rec ", BC.pack (show (BL.length rbytes)), BC.singleton '\n' ] `BL.append` rbytes) liftIO $ iceConnect s (load remote) $ void $ serverPeerIce server s diff --git a/main/State.hs b/main/State.hs new file mode 100644 index 0000000..76441df --- /dev/null +++ b/main/State.hs @@ -0,0 +1,80 @@ +module State ( + loadLocalStateHead, + updateSharedIdentity, + interactiveIdentityUpdate, +) where + +import Control.Monad.Except +import Control.Monad.IO.Class + +import Data.Foldable +import Data.Maybe +import Data.Proxy +import Data.Text qualified as T + +import Erebos.Error +import Erebos.Identity +import Erebos.PubKey +import Erebos.State +import Erebos.Storable +import Erebos.Storage + +import Terminal + + +loadLocalStateHead :: MonadIO m => Terminal -> Storage -> m (Head LocalState) +loadLocalStateHead term st = loadHeads st >>= \case + (h:_) -> return h + [] -> liftIO $ do + setPrompt term "Name: " + name <- getInputLine term $ KeepPrompt . maybe T.empty T.pack + + setPrompt term "Device: " + devName <- getInputLine term $ KeepPrompt . maybe T.empty T.pack + + owner <- if + | T.null name -> return Nothing + | otherwise -> Just <$> createIdentity st (Just name) Nothing + + identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner + + shared <- wrappedStore st $ SharedState + { ssPrev = [] + , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy + , ssValue = [ storedRef $ idExtData $ fromMaybe identity owner ] + } + storeHead st $ LocalState + { lsIdentity = idExtData identity + , lsShared = [ shared ] + , lsOther = [] + } + + +updateSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Terminal -> m () +updateSharedIdentity term = updateLocalHead_ $ 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 identity = do + let public = idKeyIdentity identity + + 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 -> mergeIdentity identity + | otherwise -> do + secret <- loadKey public + maybe (throwOtherError "created invalid identity") return . validateIdentity =<< + mstore =<< sign secret =<< mstore (emptyIdentityData public) + { iddPrev = toList $ idDataF identity + , iddName = Just name + } diff --git a/main/Terminal.hs b/main/Terminal.hs new file mode 100644 index 0000000..5dc3612 --- /dev/null +++ b/main/Terminal.hs @@ -0,0 +1,346 @@ +{-# 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.IO +import System.Console.ANSI + + +data Terminal = Terminal + { termLock :: MVar () + , termAnsi :: Bool + , termCompletionFunc :: CompletionFunc IO + , termPrompt :: TVar String + , termShowPrompt :: TVar Bool + , termInput :: TVar ( String, String ) + , termBottomLines :: TVar [ String ] + } + +data TerminalLine = TerminalLine + { tlTerminal :: Terminal + } + +data Input + = InputChar Char + | InputMoveRight + | InputMoveLeft + | InputMoveEnd + | InputMoveStart + | InputBackspace + | InputClear + | InputBackWord + | InputEnd + | InputEscape String + deriving (Eq, Ord, Show) + + +data InputHandling a + = KeepPrompt a + | ErasePrompt a + + +hasTerminalUI :: Terminal -> Bool +hasTerminalUI = termAnsi + +initTerminal :: CompletionFunc IO -> IO Terminal +initTerminal termCompletionFunc = do + termLock <- newMVar () +#if MIN_VERSION_ansi_terminal(1, 0, 1) + termAnsi <- hNowSupportsANSI stdout +#else + termAnsi <- hSupportsANSI stdout +#endif + termPrompt <- newTVarIO "" + termShowPrompt <- newTVarIO False + termInput <- newTVarIO ( "", "" ) + termBottomLines <- newTVarIO [] + return Terminal {..} + +bracketSet :: IO a -> (a -> IO b) -> a -> IO c -> IO c +bracketSet get set val = bracket (get <* set val) set . const + +withTerminal :: CompletionFunc IO -> (Terminal -> IO a) -> IO a +withTerminal compl act = do + term <- initTerminal compl + + bracketSet (hGetEcho stdin) (hSetEcho stdin) False $ + bracketSet (hGetBuffering stdin) (hSetBuffering stdin) NoBuffering $ + bracketSet (hGetBuffering stdout) (hSetBuffering stdout) (BlockBuffering Nothing) $ + act term + + +termPutStr :: Terminal -> String -> IO () +termPutStr Terminal {..} str = do + withMVar termLock $ \_ -> do + putStr str + hFlush stdout + + +getInput :: IO Input +getInput = do + getChar >>= \case + '\ESC' -> do + esc <- readEsc + case parseEsc esc of + Just ( 'C' , [] ) -> return InputMoveRight + Just ( 'D' , [] ) -> return InputMoveLeft + _ -> return (InputEscape esc) + '\b' -> return InputBackspace + '\DEL' -> return InputBackspace + '\NAK' -> return InputClear + '\ETB' -> return InputBackWord + '\SOH' -> return InputMoveStart + '\ENQ' -> return InputMoveEnd + '\EOT' -> return InputEnd + c -> return (InputChar c) + where + readEsc = getChar >>= \case + c | c == '\ESC' || isAlpha c -> return [ c ] + | otherwise -> (c :) <$> readEsc + + parseEsc = \case + '[' : c : [] -> do + Just ( c, [] ) + _ -> Nothing + + +getInputLine :: Terminal -> (Maybe String -> InputHandling a) -> IO a +getInputLine term@Terminal {..} handleResult = do + withMVar termLock $ \_ -> do + prompt <- atomically $ do + writeTVar termShowPrompt True + readTVar termPrompt + putStr $ prompt <> "\ESC[K" + drawBottomLines term + hFlush stdout + (handleResult <$> go) >>= \case + KeepPrompt x -> do + termPutStr term "\n\ESC[J" + return x + ErasePrompt x -> do + termPutStr term "\r\ESC[J" + return x + where + go = getInput >>= \case + InputChar '\n' -> do + atomically $ do + ( pre, post ) <- readTVar termInput + writeTVar termInput ( "", "" ) + writeTVar termShowPrompt False + writeTVar termBottomLines [] + return $ Just $ pre ++ post + + InputChar '\t' -> do + options <- withMVar termLock $ const $ do + ( pre, post ) <- atomically $ readTVar termInput + let updatePrompt pre' = do + prompt <- atomically $ do + writeTVar termInput ( pre', post ) + getCurrentPromptLine term + putStr $ "\r" <> prompt + hFlush stdout + + termCompletionFunc ( T.pack pre, T.pack post ) >>= \case + + ( unused, [ compl ] ) -> do + updatePrompt $ T.unpack unused ++ T.unpack (replacement compl) ++ if isFinished compl then " " else "" + return [] + + ( unused, completions@(c : cs) ) -> do + let commonPrefixes' x y = fmap (\( common, _, _ ) -> common) $ T.commonPrefixes x y + case foldl' (\mbcommon cur -> commonPrefixes' cur =<< mbcommon) (Just $ replacement c) (fmap replacement cs) of + Just common -> updatePrompt $ T.unpack unused ++ T.unpack common + Nothing -> return () + return $ map replacement completions + + ( _, [] ) -> do + return [] + + printBottomLines term $ T.unpack $ T.unlines options + go + + InputChar c | isPrint c -> withInput $ \case + ( _, post ) -> do + writeTVar termInput . first (++ [ c ]) =<< readTVar termInput + return $ c : (if null post then "" else "\ESC[s" <> post <> "\ESC[u") + + InputChar _ -> go + + InputMoveRight -> withInput $ \case + ( pre, c : post ) -> do + writeTVar termInput ( pre ++ [ c ], post ) + return $ "\ESC[C" + _ -> return "" + + InputMoveLeft -> withInput $ \case + ( pre@(_ : _), post ) -> do + writeTVar termInput ( init pre, last pre : post ) + return $ "\ESC[D" + _ -> return "" + + InputBackspace -> withInput $ \case + ( pre@(_ : _), post ) -> do + writeTVar termInput ( init pre, post ) + return $ "\b\ESC[K" <> (if null post then "" else "\ESC[s" <> post <> "\ESC[u") + _ -> return "" + + InputClear -> withInput $ \_ -> do + writeTVar termInput ( "", "" ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + + InputBackWord -> withInput $ \( pre, post ) -> do + let pre' = reverse $ dropWhile (not . isSpace) $ dropWhile isSpace $ reverse pre + writeTVar termInput ( pre', post ) + ("\r\ESC[K" <>) <$> getCurrentPromptLine term + + InputMoveStart -> withInput $ \( pre, post ) -> do + writeTVar termInput ( "", pre <> post ) + return $ "\ESC[" <> show (length pre) <> "D" + + InputMoveEnd -> withInput $ \( pre, post ) -> do + writeTVar termInput ( pre <> post, "" ) + return $ "\ESC[" <> show (length post) <> "C" + + InputEnd -> do + atomically (readTVar termInput) >>= \case + ( "", "" ) -> return Nothing + _ -> go + + InputEscape _ -> go + + withInput f = do + withMVar termLock $ const $ do + str <- atomically $ f =<< readTVar termInput + when (not $ null str) $ do + putStr str + hFlush stdout + go + + +getCurrentPromptLine :: Terminal -> STM String +getCurrentPromptLine Terminal {..} = do + prompt <- readTVar termPrompt + ( pre, post ) <- readTVar termInput + return $ prompt <> pre <> "\ESC[s" <> post <> "\ESC[u" + +setPrompt :: Terminal -> String -> IO () +setPrompt term@Terminal {..} prompt = do + withMVar termLock $ \_ -> do + join $ atomically $ do + writeTVar termPrompt prompt + readTVar termShowPrompt >>= \case + True -> do + promptLine <- getCurrentPromptLine term + return $ do + putStr $ "\r\ESC[K" <> promptLine + hFlush stdout + False -> return $ return () + +printLine :: Terminal -> String -> IO TerminalLine +printLine tlTerminal@Terminal {..} str = do + withMVar termLock $ \_ -> do + promptLine <- atomically $ do + readTVar termShowPrompt >>= \case + True -> getCurrentPromptLine tlTerminal + False -> return "" + putStr $ "\r\ESC[K" <> str <> "\n\ESC[K" <> promptLine + drawBottomLines tlTerminal + hFlush stdout + return TerminalLine {..} + + +printBottomLines :: Terminal -> String -> IO () +printBottomLines term@Terminal {..} str = do + case lines str of + [] -> clearBottomLines term + blines -> do + withMVar termLock $ \_ -> do + atomically $ writeTVar termBottomLines blines + drawBottomLines term + hFlush stdout + +clearBottomLines :: Terminal -> IO () +clearBottomLines Terminal {..} = do + withMVar termLock $ \_ -> do + atomically (readTVar termBottomLines) >>= \case + [] -> return () + _:_ -> do + atomically $ writeTVar termBottomLines [] + putStr $ "\ESC[s\n\ESC[J\ESC[u" + hFlush stdout + +drawBottomLines :: Terminal -> IO () +drawBottomLines Terminal {..} = do + atomically (readTVar termBottomLines) >>= \case + blines@( firstLine : otherLines ) -> do + ( shift ) <- atomically $ do + readTVar termShowPrompt >>= \case + True -> do + prompt <- readTVar termPrompt + ( pre, _ ) <- readTVar termInput + return (displayWidth (prompt <> pre) + 1) + False -> do + return 0 + putStr $ concat + [ "\n\ESC[J", firstLine, concat (map ('\n' :) otherLines) + , "\ESC[", show (length blines), "F" + , "\ESC[", show shift, "G" + ] + [] -> return () + + +displayWidth :: String -> Int +displayWidth = \case + ('\ESC' : '[' : rest) -> displayWidth $ drop 1 $ dropWhile (not . isAlpha) rest + ('\ESC' : _ : rest) -> displayWidth rest + (_ : rest) -> 1 + displayWidth rest + [] -> 0 + + +type CompletionFunc m = ( Text, Text ) -> m ( Text, [ Completion ] ) + +data Completion = Completion + { replacement :: Text + , isFinished :: Bool + } + +noCompletion :: Monad m => CompletionFunc m +noCompletion ( l, _ ) = return ( l, [] ) + +completeWordWithPrev :: Monad m => Maybe Char -> [ Char ] -> (String -> String -> m [ Completion ]) -> CompletionFunc m +completeWordWithPrev _ spaceChars fun ( l, _ ) = do + let lastSpaceIndex = snd $ T.foldl' (\( i, found ) c -> if c `elem` spaceChars then ( i + 1, i ) else ( i + 1, found )) ( 1, 0 ) l + let ( pre, word ) = T.splitAt lastSpaceIndex l + ( pre, ) <$> fun (T.unpack pre) (T.unpack word) + +simpleCompletion :: String -> Completion +simpleCompletion str = Completion (T.pack str) True diff --git a/main/Test.hs b/main/Test.hs index 628e351..08ad880 100644 --- a/main/Test.hs +++ b/main/Test.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Test ( runTestTool, ) where @@ -35,6 +37,7 @@ import Erebos.Attach import Erebos.Chatroom import Erebos.Contact import Erebos.DirectMessage +import Erebos.Discovery import Erebos.Identity import Erebos.Network import Erebos.Object @@ -46,7 +49,6 @@ import Erebos.State import Erebos.Storable import Erebos.Storage import Erebos.Storage.Head -import Erebos.Storage.Internal (unsafeStoreRawBytes) import Erebos.Storage.Merge import Erebos.Sync @@ -101,7 +103,7 @@ runTestTool st = do Nothing -> return () runExceptT (evalStateT testLoop initTestState) >>= \case - Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack x + Left x -> B.hPutStr stderr $ (`BC.snoc` '\n') $ BC.pack (showErebosError x) Right () -> return () getLineMb :: MonadIO m => m (Maybe Text) @@ -173,7 +175,7 @@ pairingAttributes _ out peers prefix = PairingAttributes , pairingHookFailed = \case PairingUserRejected -> failed "user" PairingUnexpectedMessage pstate packet -> failed $ "unexpected " ++ strState pstate ++ " " ++ strPacket packet - PairingFailedOther str -> failed $ "other " ++ str + PairingFailedOther err -> failed $ "other " ++ showErebosError err , pairingHookVerifyFailed = failed "verify" , pairingHookRejected = failed "rejected" } @@ -224,11 +226,11 @@ dmReceivedWatcher out smsg = do ] -newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT String IO)) a) - deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError String) +newtype CommandM a = CommandM (ReaderT TestInput (StateT TestState (ExceptT ErebosError IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader TestInput, MonadState TestState, MonadError ErebosError) instance MonadFail CommandM where - fail = throwError + fail = throwOtherError instance MonadRandom CommandM where getRandomBytes = liftIO . getRandomBytes @@ -258,6 +260,7 @@ commands = map (T.pack *** id) , ("head-watch", cmdHeadWatch) , ("head-unwatch", cmdHeadUnwatch) , ("create-identity", cmdCreateIdentity) + , ("identity-info", cmdIdentityInfo) , ("start-server", cmdStartServer) , ("stop-server", cmdStopServer) , ("peer-add", cmdPeerAdd) @@ -286,6 +289,7 @@ commands = map (T.pack *** id) , ("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) @@ -296,17 +300,26 @@ commands = map (T.pack *** id) , ("chatroom-join-as", cmdChatroomJoinAs) , ("chatroom-leave", cmdChatroomLeave) , ("chatroom-message-send", cmdChatroomMessageSend) + , ("discovery-connect", cmdDiscoveryConnect) ] cmdStore :: Command cmdStore = do st <- asks tiStorage + pst <- liftIO $ derivePartialStorage st [otype] <- asks tiParams ls <- getLines let cnt = encodeUtf8 $ T.unlines ls - ref <- liftIO $ unsafeStoreRawBytes st $ BL.fromChunks [encodeUtf8 otype, BC.singleton ' ', BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] - cmdOut $ "store-done " ++ show (refDigest ref) + full = BL.fromChunks + [ encodeUtf8 otype + , BC.singleton ' ' + , BC.pack (show $ B.length cnt) + , BC.singleton '\n', cnt + ] + liftIO (copyRef st =<< storeRawBytes pst full) >>= \case + Right ref -> cmdOut $ "store-done " ++ show (refDigest ref) + Left _ -> cmdOut $ "store-failed" cmdLoad :: Command cmdLoad = do @@ -446,26 +459,52 @@ cmdCreateIdentity = do , lsOther = [] } initTestHead h + cmdOut $ unwords [ "create-identity-done", "ref", show $ refDigest $ storedRef $ lsIdentity $ headObject h ] + +cmdIdentityInfo :: Command +cmdIdentityInfo = do + st <- asks tiStorage + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + let sidata = wrappedLoad ref + idata = fromSigned sidata + cmdOut $ unwords $ concat + [ [ "identity-info" ] + , [ "ref", T.unpack tref ] + , [ "base", show $ refDigest $ storedRef $ eiddStoredBase sidata ] + , maybe [] (\owner -> [ "owner", show $ refDigest $ storedRef owner ]) $ eiddOwner idata + , maybe [] (\name -> [ "name", T.unpack name ]) $ eiddName idata + ] cmdStartServer :: Command cmdStartServer = do out <- asks tiOutput + let parseParams = \case + (name : value : rest) + | name == "services" -> T.splitOn "," value + | otherwise -> parseParams rest + _ -> [] + serviceNames <- parseParams <$> asks tiParams + h <- getOrLoadHead rsPeers <- liftIO $ newMVar (1, []) - rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) - [ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" - , someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" - , someServiceAttr $ directMessageAttributes out - , someService @SyncService Proxy - , someService @ChatroomService Proxy - , someServiceAttr $ (defaultServiceAttributes Proxy) + services <- forM serviceNames $ \case + "attach" -> return $ someServiceAttr $ pairingAttributes (Proxy @AttachService) out rsPeers "attach" + "chatroom" -> return $ someService @ChatroomService Proxy + "contact" -> return $ someServiceAttr $ pairingAttributes (Proxy @ContactService) out rsPeers "contact" + "discovery" -> return $ someService @DiscoveryService Proxy + "dm" -> return $ someServiceAttr $ directMessageAttributes out + "sync" -> return $ someService @SyncService Proxy + "test" -> return $ someServiceAttr $ (defaultServiceAttributes Proxy) { testMessageReceived = \obj otype len sref -> do liftIO $ do void $ store (headStorage h) obj outLine out $ unwords ["test-message-received", otype, len, sref] } - ] + sname -> throwOtherError $ "unknown service `" <> T.unpack sname <> "'" + + rsServer <- liftIO $ startServer defaultServerOptions h (B.hPutStr stderr . (`BC.snoc` '\n') . BC.pack) services rsPeerThread <- liftIO $ forkIO $ void $ forever $ do peer <- getNextPeerChange rsServer @@ -623,7 +662,7 @@ cmdUpdateSharedIdentity :: Command cmdUpdateSharedIdentity = do [name] <- asks tiParams updateLocalHead_ $ updateSharedState_ $ \case - Nothing -> throwError "no existing shared identity" + Nothing -> throwOtherError "no existing shared identity" Just identity -> do let public = idKeyIdentity identity secret <- loadKey public @@ -736,6 +775,13 @@ cmdChatroomCreate = do room <- createChatroom (Just name) Nothing cmdOut $ unwords $ "chatroom-create-done" : chatroomInfo room +cmdChatroomDelete :: Command +cmdChatroomDelete = do + [ cid ] <- asks tiParams + sdata <- getChatroomStateData cid + deleteChatroomByStateData sdata + cmdOut $ unwords [ "chatroom-delete-done", T.unpack cid ] + getChatroomStateData :: Text -> CommandM (Stored ChatroomStateData) getChatroomStateData tref = do st <- asks tiStorage @@ -838,3 +884,14 @@ cmdChatroomMessageSend = do [cid, msg] <- asks tiParams to <- getChatroomStateData cid void $ sendChatroomMessageByStateData to msg + +cmdDiscoveryConnect :: Command +cmdDiscoveryConnect = do + st <- asks tiStorage + [ tref ] <- asks tiParams + Just ref <- liftIO $ readRef st $ encodeUtf8 tref + + Just RunningServer {..} <- gets tsServer + peers <- liftIO $ getCurrentPeerList rsServer + forM_ peers $ \peer -> do + sendToPeer peer $ DiscoverySearch ref diff --git a/src/Erebos/Attach.hs b/src/Erebos/Attach.hs index aac7297..df61406 100644 --- a/src/Erebos/Attach.hs +++ b/src/Erebos/Attach.hs @@ -113,11 +113,11 @@ instance PairingResult AttachIdentity where svcPrint $ "Attachement failed" } -attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m () +attachToOwner :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachToOwner = pairingRequest @AttachIdentity Proxy -attachAccept :: (MonadIO m, MonadError String m) => Peer -> m () +attachAccept :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachAccept = pairingAccept @AttachIdentity Proxy -attachReject :: (MonadIO m, MonadError String m) => Peer -> m () +attachReject :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () attachReject = pairingReject @AttachIdentity Proxy diff --git a/src/Erebos/Chatroom.hs b/src/Erebos/Chatroom.hs index 814e1af..2d4f272 100644 --- a/src/Erebos/Chatroom.hs +++ b/src/Erebos/Chatroom.hs @@ -6,6 +6,7 @@ module Erebos.Chatroom ( ChatroomState(..), ChatroomStateData(..), createChatroom, + deleteChatroomByStateData, updateChatroomByStateData, listChatrooms, findChatroomByRoomData, @@ -180,17 +181,17 @@ threadToListSince since thread = helper (S.fromList since) thread cmpView msg = (zonedTimeToUTC $ mdTime $ fromSigned msg, msg) sendChatroomMessage - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => ChatroomState -> Text -> m () sendChatroomMessage rstate msg = sendChatroomMessageByStateData (head $ roomStateData rstate) msg sendChatroomMessageByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> Text -> m () sendChatroomMessageByStateData lookupData msg = sendRawChatroomMessageByStateData lookupData Nothing 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 @@ -207,9 +208,8 @@ sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave else [] mdata <- mstore =<< sign secret =<< mstore ChatMessageData {..} - mergeSorted . (:[]) <$> mstore ChatroomStateData + mergeSorted . (:[]) <$> mstore emptyChatroomStateData { rsdPrev = roomStateData cstate - , rsdRoom = [] , rsdSubscribe = Just (not mdLeave) , rsdIdentity = mbIdentity , rsdMessages = [ mdata ] @@ -219,15 +219,27 @@ sendRawChatroomMessageByStateData lookupData mbIdentity mdReplyTo mdText mdLeave data ChatroomStateData = ChatroomStateData { rsdPrev :: [Stored ChatroomStateData] , rsdRoom :: [Stored (Signed ChatroomData)] + , rsdDelete :: Bool , rsdSubscribe :: Maybe Bool , rsdIdentity :: Maybe UnifiedIdentity , rsdMessages :: [Stored (Signed ChatMessageData)] } +emptyChatroomStateData :: ChatroomStateData +emptyChatroomStateData = ChatroomStateData + { rsdPrev = [] + , rsdRoom = [] + , rsdDelete = False + , rsdSubscribe = Nothing + , rsdIdentity = Nothing + , rsdMessages = [] + } + data ChatroomState = ChatroomState { roomStateData :: [Stored ChatroomStateData] , roomStateRoom :: Maybe Chatroom , roomStateMessageData :: [Stored (Signed ChatMessageData)] + , roomStateDeleted :: Bool , roomStateSubscribe :: Bool , roomStateIdentity :: Maybe UnifiedIdentity , roomStateMessages :: [ChatMessage] @@ -237,6 +249,7 @@ instance Storable ChatroomStateData where store' ChatroomStateData {..} = storeRec $ do forM_ rsdPrev $ storeRef "PREV" forM_ rsdRoom $ storeRef "room" + when rsdDelete $ storeEmpty "delete" forM_ rsdSubscribe $ storeInt "subscribe" . bool @Int 0 1 forM_ rsdIdentity $ storeRef "id" . idExtData forM_ rsdMessages $ storeRef "msg" @@ -244,6 +257,7 @@ instance Storable ChatroomStateData where load' = loadRec $ do rsdPrev <- loadRefs "PREV" rsdRoom <- loadRefs "room" + rsdDelete <- isJust <$> loadMbEmpty "delete" rsdSubscribe <- fmap ((/=) @Int 0) <$> loadMbInt "subscribe" rsdIdentity <- loadMbUnifiedIdentity "id" rsdMessages <- loadRefs "msg" @@ -258,7 +272,8 @@ instance Mergeable ChatroomState where roomStateMessageData = filterAncestors $ concat $ flip findProperty roomStateData $ \case ChatroomStateData {..} | null rsdMessages -> Nothing | otherwise -> Just rsdMessages - roomStateSubscribe = fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData + roomStateDeleted = any (rsdDelete . fromStored) roomStateData + roomStateSubscribe = not roomStateDeleted && (fromMaybe False $ findPropertyFirst rsdSubscribe roomStateData) roomStateIdentity = findPropertyFirst rsdIdentity roomStateData roomStateMessages = threadToListSince [] $ concatMap (rsdMessages . fromStored) roomStateData in ChatroomState {..} @@ -268,17 +283,14 @@ instance Mergeable ChatroomState where instance SharedType (Set ChatroomState) where sharedTypeID _ = mkSharedTypeID "7bc71cbf-bc43-42b1-b413-d3a2c9a2aae0" -createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError String m) => Maybe Text -> Maybe Text -> m ChatroomState +createChatroom :: (MonadStorage m, MonadHead LocalState m, MonadIO m, MonadError e m, FromErebosError e) => Maybe Text -> Maybe Text -> m ChatroomState createChatroom rdName rdDescription = do (secret, rdKey) <- liftIO . generateKeys =<< getStorage let rdPrev = [] rdata <- mstore =<< sign secret =<< mstore ChatroomData {..} - cstate <- mergeSorted . (:[]) <$> mstore ChatroomStateData - { rsdPrev = [] - , rsdRoom = [ rdata ] + cstate <- mergeSorted . (:[]) <$> mstore emptyChatroomStateData + { rsdRoom = [ rdata ] , rsdSubscribe = Just True - , rsdIdentity = Nothing - , rsdMessages = [] } updateLocalHead $ updateSharedState $ \rooms -> do @@ -304,8 +316,19 @@ findAndUpdateChatroomState f = do return (roomSet, Just upd) [] -> return (roomSet, Nothing) +deleteChatroomByStateData + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) + => Stored ChatroomStateData -> m () +deleteChatroomByStateData lookupData = void $ findAndUpdateChatroomState $ \cstate -> do + guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate + Just $ do + mergeSorted . (:[]) <$> mstore emptyChatroomStateData + { rsdPrev = roomStateData cstate + , rsdDelete = True + } + updateChatroomByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> Maybe Text -> Maybe Text @@ -321,17 +344,16 @@ updateChatroomByStateData lookupData newName newDesc = findAndUpdateChatroomStat , rdDescription = newDesc , rdKey = roomKey room } - mergeSorted . (:[]) <$> mstore ChatroomStateData + mergeSorted . (:[]) <$> mstore emptyChatroomStateData { rsdPrev = roomStateData cstate , rsdRoom = [ rdata ] , rsdSubscribe = Just True - , rsdIdentity = Nothing - , rsdMessages = [] } listChatrooms :: MonadHead LocalState m => m [ChatroomState] -listChatrooms = fromSetBy (comparing $ roomName <=< roomStateRoom) . +listChatrooms = filter (not . roomStateDeleted) . + fromSetBy (comparing $ roomName <=< roomStateRoom) . lookupSharedValue . lsShared . fromStored <$> getLocalHead findChatroom :: MonadHead LocalState m => (ChatroomState -> Bool) -> m (Maybe ChatroomState) @@ -347,17 +369,14 @@ findChatroomByStateData :: MonadHead LocalState m => Stored ChatroomStateData -> findChatroomByStateData cdata = findChatroom $ any (cdata `precedesOrEquals`) . roomStateData chatroomSetSubscribe - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> Bool -> m () chatroomSetSubscribe lookupData subscribe = void $ findAndUpdateChatroomState $ \cstate -> do guard $ any (lookupData `precedesOrEquals`) $ roomStateData cstate Just $ do - mergeSorted . (:[]) <$> mstore ChatroomStateData + mergeSorted . (:[]) <$> mstore emptyChatroomStateData { rsdPrev = roomStateData cstate - , rsdRoom = [] , rsdSubscribe = Just subscribe - , rsdIdentity = Nothing - , rsdMessages = [] } chatroomMembers :: ChatroomState -> [ ComposedIdentity ] @@ -371,32 +390,32 @@ chatroomMembers ChatroomState {..} = toList $ ancestors $ roomStateMessageData joinChatroom - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => ChatroomState -> m () joinChatroom rstate = joinChatroomByStateData (head $ roomStateData rstate) joinChatroomByStateData - :: (MonadStorage m, MonadHead LocalState m, MonadError String m) + :: (MonadStorage m, MonadHead LocalState m, MonadError e m, FromErebosError e) => Stored ChatroomStateData -> m () joinChatroomByStateData lookupData = sendRawChatroomMessageByStateData lookupData Nothing Nothing 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 @@ -420,7 +439,7 @@ watchChatrooms h f = liftIO $ do return $ makeChatroomDiff lastList curList chatroomSetToList :: Set ChatroomState -> [(Stored ChatroomStateData, ChatroomState)] -chatroomSetToList = map (cmp &&& id) . fromSetBy (comparing cmp) +chatroomSetToList = map (cmp &&& id) . filter (not . roomStateDeleted) . fromSetBy (comparing cmp) where cmp :: ChatroomState -> Stored ChatroomStateData cmp = head . filterAncestors . concatMap storedRoots . toComponents @@ -518,12 +537,9 @@ instance Service ChatroomService where -- update local state only if we got roomInfo not present there if roomInfo `notElem` prevRoom && roomInfo `elem` room then do - sdata <- mstore ChatroomStateData + sdata <- mstore emptyChatroomStateData { rsdPrev = prev , rsdRoom = room - , rsdSubscribe = Nothing - , rsdIdentity = Nothing - , rsdMessages = [] } storeSetAddComponent sdata set else return set @@ -563,11 +579,8 @@ instance Service ChatroomService where -- update local state only if subscribed and we got some new messages if roomStateSubscribe prev && messages /= prevMessages then do - sdata <- mstore ChatroomStateData + sdata <- mstore emptyChatroomStateData { rsdPrev = prevData - , rsdRoom = [] - , rsdSubscribe = Nothing - , rsdIdentity = Nothing , rsdMessages = messages } storeSetAddComponent sdata set diff --git a/src/Erebos/Contact.hs b/src/Erebos/Contact.hs index 0e92e41..25239b9 100644 --- a/src/Erebos/Contact.hs +++ b/src/Erebos/Contact.hs @@ -155,13 +155,13 @@ instance PairingResult ContactAccepted where svcPrint $ "Contact failed" } -contactRequest :: (MonadIO m, MonadError String m) => Peer -> m () +contactRequest :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactRequest = pairingRequest @ContactAccepted Proxy -contactAccept :: (MonadIO m, MonadError String m) => Peer -> m () +contactAccept :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactAccept = pairingAccept @ContactAccepted Proxy -contactReject :: (MonadIO m, MonadError String m) => Peer -> m () +contactReject :: (MonadIO m, MonadError e m, FromErebosError e) => Peer -> m () contactReject = pairingReject @ContactAccepted Proxy finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m () diff --git a/src/Erebos/Conversation.hs b/src/Erebos/Conversation.hs index fce8780..dee6faa 100644 --- a/src/Erebos/Conversation.hs +++ b/src/Erebos/Conversation.hs @@ -18,6 +18,7 @@ module Erebos.Conversation ( conversationHistory, sendMessage, + deleteConversation, ) where import Control.Monad.Except @@ -100,6 +101,10 @@ conversationHistory (DirectMessageConversation thread) = map (\msg -> DirectMess conversationHistory (ChatroomConversation rstate) = map (\msg -> ChatroomMessage msg False) $ roomStateMessages rstate -sendMessage :: (MonadHead LocalState m, MonadError String m) => Conversation -> Text -> m (Maybe Message) +sendMessage :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> Text -> m (Maybe Message) sendMessage (DirectMessageConversation thread) text = fmap Just $ DirectMessageMessage <$> (fromStored <$> sendDirectMessage (msgPeer thread) text) <*> pure False sendMessage (ChatroomConversation rstate) text = sendChatroomMessage rstate text >> return Nothing + +deleteConversation :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => Conversation -> m () +deleteConversation (DirectMessageConversation _) = throwOtherError "deleting direct message conversation is not supported" +deleteConversation (ChatroomConversation rstate) = deleteChatroomByStateData (head $ roomStateData rstate) diff --git a/src/Erebos/DirectMessage.hs b/src/Erebos/DirectMessage.hs index 39d453c..28d8085 100644 --- a/src/Erebos/DirectMessage.hs +++ b/src/Erebos/DirectMessage.hs @@ -17,7 +17,6 @@ module Erebos.DirectMessage ( ) where import Control.Monad -import Control.Monad.Except import Control.Monad.Reader import Data.List @@ -157,7 +156,7 @@ findMsgProperty pid sel mss = concat $ flip findProperty mss $ \x -> do return $ sel x -sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m, MonadError String m) +sendDirectMessage :: (Foldable f, Applicative f, MonadHead LocalState m) => Identity f -> Text -> m (Stored DirectMessage) sendDirectMessage pid text = updateLocalHead $ \ls -> do let self = localIdentity $ fromStored ls diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs index 459af71..d900363 100644 --- a/src/Erebos/Discovery.hs +++ b/src/Erebos/Discovery.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE CPP #-} + module Erebos.Discovery ( DiscoveryService(..), + DiscoveryAttributes(..), DiscoveryConnection(..) ) where @@ -8,15 +11,19 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Reader +import Data.IP qualified as IP import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M +import Data.Map.Strict qualified as M import Data.Maybe import Data.Text (Text) -import qualified Data.Text as T +import Data.Text qualified as T +import Data.Word import Network.Socket +#ifdef ENABLE_ICE_SUPPORT import Erebos.ICE +#endif import Erebos.Identity import Erebos.Network import Erebos.Object @@ -24,39 +31,63 @@ import Erebos.Service import Erebos.Storable -keepaliveSeconds :: Int -keepaliveSeconds = 20 +data DiscoveryService + = DiscoverySelf [ Text ] (Maybe Int) + | DiscoveryAcknowledged [ Text ] (Maybe Text) (Maybe Word16) (Maybe Text) (Maybe Word16) + | DiscoverySearch Ref + | DiscoveryResult Ref [ Text ] + | DiscoveryConnectionRequest DiscoveryConnection + | DiscoveryConnectionResponse DiscoveryConnection +data DiscoveryAttributes = DiscoveryAttributes + { discoveryStunPort :: Maybe Word16 + , discoveryStunServer :: Maybe Text + , discoveryTurnPort :: Maybe Word16 + , discoveryTurnServer :: Maybe Text + } -data DiscoveryService = DiscoverySelf Text Int - | DiscoveryAcknowledged Text - | DiscoverySearch Ref - | DiscoveryResult Ref (Maybe Text) - | DiscoveryConnectionRequest DiscoveryConnection - | DiscoveryConnectionResponse DiscoveryConnection +defaultDiscoveryAttributes :: DiscoveryAttributes +defaultDiscoveryAttributes = DiscoveryAttributes + { discoveryStunPort = Nothing + , discoveryStunServer = Nothing + , discoveryTurnPort = Nothing + , discoveryTurnServer = Nothing + } data DiscoveryConnection = DiscoveryConnection { dconnSource :: Ref , dconnTarget :: Ref , dconnAddress :: Maybe Text - , dconnIceSession :: Maybe IceRemoteInfo +#ifdef ENABLE_ICE_SUPPORT + , dconnIceInfo :: Maybe IceRemoteInfo +#else + , dconnIceInfo :: Maybe (Stored Object) +#endif } emptyConnection :: Ref -> Ref -> DiscoveryConnection -emptyConnection source target = DiscoveryConnection source target Nothing Nothing +emptyConnection dconnSource dconnTarget = DiscoveryConnection {..} + where + dconnAddress = Nothing + dconnIceInfo = Nothing instance Storable DiscoveryService where store' x = storeRec $ do case x of - DiscoverySelf addr priority -> do - storeText "self" addr - storeInt "priority" priority - DiscoveryAcknowledged addr -> do - storeText "ack" addr + DiscoverySelf addrs priority -> do + mapM_ (storeText "self") addrs + mapM_ (storeInt "priority") priority + DiscoveryAcknowledged addrs stunServer stunPort turnServer turnPort -> do + if null addrs then storeEmpty "ack" + else mapM_ (storeText "ack") addrs + storeMbText "stun-server" stunServer + storeMbInt "stun-port" stunPort + storeMbText "turn-server" turnServer + storeMbInt "turn-port" turnPort DiscoverySearch ref -> storeRawRef "search" ref DiscoveryResult ref addr -> do storeRawRef "result" ref - storeMbText "address" addr + mapM_ (storeText "address") addr DiscoveryConnectionRequest conn -> storeConnection "request" conn DiscoveryConnectionResponse conn -> storeConnection "response" conn @@ -65,18 +96,28 @@ instance Storable DiscoveryService where storeRawRef "source" $ dconnSource conn storeRawRef "target" $ dconnTarget conn storeMbText "address" $ dconnAddress conn - storeMbRef "ice-session" $ dconnIceSession conn + storeMbRef "ice-info" $ dconnIceInfo conn load' = loadRec $ msum - [ DiscoverySelf - <$> loadText "self" - <*> loadInt "priority" - , DiscoveryAcknowledged - <$> loadText "ack" + [ do + addrs <- loadTexts "self" + guard (not $ null addrs) + DiscoverySelf addrs + <$> loadMbInt "priority" + , do + addrs <- loadTexts "ack" + mbEmpty <- loadMbEmpty "ack" + guard (not (null addrs) || isJust mbEmpty) + DiscoveryAcknowledged + <$> pure addrs + <*> loadMbText "stun-server" + <*> loadMbInt "stun-port" + <*> loadMbText "turn-server" + <*> loadMbInt "turn-port" , DiscoverySearch <$> loadRawRef "search" , DiscoveryResult <$> loadRawRef "result" - <*> loadMbText "address" + <*> loadTexts "address" , loadConnection "request" DiscoveryConnectionRequest , loadConnection "response" DiscoveryConnectionResponse ] @@ -87,109 +128,180 @@ instance Storable DiscoveryService where <$> loadRawRef "source" <*> loadRawRef "target" <*> loadMbText "address" - <*> loadMbRef "ice-session" + <*> loadMbRef "ice-info" data DiscoveryPeer = DiscoveryPeer { dpPriority :: Int , dpPeer :: Maybe Peer - , dpAddress :: Maybe Text + , dpAddress :: [ Text ] +#ifdef ENABLE_ICE_SUPPORT , dpIceSession :: Maybe IceSession +#endif } instance Service DiscoveryService where - serviceID _ = mkServiceID "dd59c89c-69cc-4703-b75b-4ddcd4b3c23b" + serviceID _ = mkServiceID "dd59c89c-69cc-4703-b75b-4ddcd4b3c23c" + + type ServiceAttributes DiscoveryService = DiscoveryAttributes + defaultServiceAttributes _ = defaultDiscoveryAttributes + +#ifdef ENABLE_ICE_SUPPORT + type ServiceState DiscoveryService = Maybe IceConfig + emptyServiceState _ = Nothing +#endif type ServiceGlobalState DiscoveryService = Map RefDigest DiscoveryPeer emptyServiceGlobalState _ = M.empty serviceHandler msg = case fromStored msg of - DiscoverySelf addr priority -> do + DiscoverySelf addrs priority -> do pid <- asks svcPeerIdentity peer <- asks svcPeer let insertHelper new old | dpPriority new > dpPriority old = new | otherwise = old - mbaddr <- case words (T.unpack addr) of - [ipaddr, port] | DatagramAddress paddr <- peerAddress peer -> do + matchedAddrs <- fmap catMaybes $ forM addrs $ \addr -> if + | addr == T.pack "ICE" -> do + return $ Just addr + + | [ ipaddr, port ] <- words (T.unpack addr) + , DatagramAddress paddr <- peerAddress peer -> do saddr <- liftIO $ head <$> getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) return $ if paddr == addrAddress saddr then Just addr else Nothing - _ -> return Nothing + + | otherwise -> return Nothing + forM_ (idDataF =<< unfoldOwners pid) $ \s -> - svcModifyGlobal $ M.insertWith insertHelper (refDigest $ storedRef s) $ - DiscoveryPeer priority (Just peer) mbaddr Nothing - replyPacket $ DiscoveryAcknowledged $ fromMaybe (T.pack "ICE") mbaddr - - DiscoveryAcknowledged addr -> do - when (addr == T.pack "ICE") $ do - -- keep-alive packet from behind NAT - peer <- asks svcPeer - liftIO $ void $ forkIO $ do - threadDelay (keepaliveSeconds * 1000 * 1000) - res <- runExceptT $ sendToPeer peer $ DiscoverySelf addr 0 - case res of - Right _ -> return () - Left err -> putStrLn $ "Discovery: failed to send keep-alive: " ++ err + svcModifyGlobal $ M.insertWith insertHelper (refDigest $ storedRef s) DiscoveryPeer + { dpPriority = fromMaybe 0 priority + , dpPeer = Just peer + , dpAddress = addrs +#ifdef ENABLE_ICE_SUPPORT + , dpIceSession = Nothing +#endif + } + attrs <- asks svcAttributes + replyPacket $ DiscoveryAcknowledged matchedAddrs + (discoveryStunServer attrs) + (discoveryStunPort attrs) + (discoveryTurnServer attrs) + (discoveryTurnPort attrs) + + DiscoveryAcknowledged _ stunServer stunPort turnServer turnPort -> do +#ifdef ENABLE_ICE_SUPPORT + paddr <- asks (peerAddress . svcPeer) >>= return . \case + (DatagramAddress saddr) -> case IP.fromSockAddr saddr of + Just (IP.IPv6 ipv6, _) + | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6 + -> Just $ T.pack $ show (IP.toIPv4w ipv4) + Just (addr, _) + -> Just $ T.pack $ show addr + _ -> Nothing + _ -> Nothing + + let toIceServer Nothing Nothing = Nothing + toIceServer Nothing (Just port) = ( , port) <$> paddr + toIceServer (Just server) Nothing = Just ( server, 0 ) + toIceServer (Just server) (Just port) = Just ( server, port ) + + cfg <- liftIO $ iceCreateConfig + (toIceServer stunServer stunPort) + (toIceServer turnServer turnPort) + svcSet cfg +#endif + return () DiscoverySearch ref -> do - addr <- M.lookup (refDigest ref) <$> svcGetGlobal - replyPacket $ DiscoveryResult ref $ fromMaybe (T.pack "ICE") . dpAddress <$> addr + dpeer <- M.lookup (refDigest ref) <$> svcGetGlobal + replyPacket $ DiscoveryResult ref $ maybe [] dpAddress dpeer - DiscoveryResult ref Nothing -> do + DiscoveryResult ref [] -> do svcPrint $ "Discovery: " ++ show (refDigest ref) ++ " not found" - DiscoveryResult ref (Just addr) -> do + DiscoveryResult ref addrs -> do -- TODO: check if we really requested that server <- asks svcServer - if addr == T.pack "ICE" - then do - self <- svcSelf - peer <- asks svcPeer - ice <- liftIO $ iceCreate PjIceSessRoleControlling $ \ice -> do + self <- svcSelf + mbIceConfig <- svcGet + discoveryPeer <- asks svcPeer + let runAsService = runPeerService @DiscoveryService discoveryPeer + + liftIO $ void $ forkIO $ forM_ addrs $ \addr -> if + | addr == T.pack "ICE" +#ifdef ENABLE_ICE_SUPPORT + , Just config <- mbIceConfig + -> do + ice <- iceCreateSession config PjIceSessRoleControlling $ \ice -> do rinfo <- iceRemoteInfo ice - res <- runExceptT $ sendToPeer peer $ - DiscoveryConnectionRequest (emptyConnection (storedRef $ idData self) ref) { dconnIceSession = Just rinfo } + 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 - svcModifyGlobal $ M.insert (refDigest ref) $ - DiscoveryPeer 0 Nothing Nothing (Just ice) - else do - case words (T.unpack addr) of - [ipaddr, port] -> do - saddr <- liftIO $ head <$> - getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) - peer <- liftIO $ serverPeer server (addrAddress saddr) - svcModifyGlobal $ M.insert (refDigest ref) $ - DiscoveryPeer 0 (Just peer) Nothing Nothing + runAsService $ do + svcModifyGlobal $ M.insert (refDigest ref) DiscoveryPeer + { dpPriority = 0 + , dpPeer = Nothing + , dpAddress = [] + , dpIceSession = Just ice + } +#else + -> do + return () +#endif + + | [ ipaddr, port ] <- words (T.unpack addr) -> do + saddr <- head <$> + getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) + peer <- serverPeer server (addrAddress saddr) + runAsService $ do + svcModifyGlobal $ M.insert (refDigest ref) DiscoveryPeer + { dpPriority = 0 + , dpPeer = Just peer + , dpAddress = [] +#ifdef ENABLE_ICE_SUPPORT + , dpIceSession = Nothing +#endif + } - _ -> svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr + | otherwise -> do + runAsService $ do + svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr DiscoveryConnectionRequest conn -> do self <- svcSelf let rconn = emptyConnection (dconnSource conn) (dconnTarget conn) if refDigest (dconnTarget conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self) then do +#ifdef ENABLE_ICE_SUPPORT -- request for us, create ICE sesssion server <- asks svcServer peer <- asks svcPeer - liftIO $ void $ iceCreate PjIceSessRoleControlled $ \ice -> do - rinfo <- iceRemoteInfo ice - res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionResponse rconn { dconnIceSession = Just rinfo } - case res of - Right _ -> do - case dconnIceSession conn of - Just prinfo -> iceConnect ice prinfo $ void $ serverPeerIce server ice - Nothing -> putStrLn $ "Discovery: connection request without ICE remote info" - Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err + svcGet >>= \case + Just config -> do + liftIO $ void $ iceCreateSession config PjIceSessRoleControlled $ \ice -> do + rinfo <- iceRemoteInfo ice + res <- runExceptT $ sendToPeer peer $ DiscoveryConnectionResponse rconn { dconnIceInfo = Just rinfo } + case res of + Right _ -> do + case dconnIceInfo conn of + Just prinfo -> iceConnect ice prinfo $ void $ serverPeerIce server ice + Nothing -> putStrLn $ "Discovery: connection request without ICE remote info" + Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err + Nothing -> do + svcPrint $ "Discovery: ICE request from peer without ICE configuration" +#else + return () +#endif else do -- request to some of our peers, relay mbdp <- M.lookup (refDigest $ dconnTarget conn) <$> svcGetGlobal case mbdp of Nothing -> replyPacket $ DiscoveryConnectionResponse rconn - Just dp | Just addr <- dpAddress dp -> do + Just dp | addr : _ <- dpAddress dp -> do replyPacket $ DiscoveryConnectionResponse rconn { dconnAddress = Just addr } | Just dpeer <- dpPeer dp -> do sendToPeer dpeer $ DiscoveryConnectionRequest conn @@ -201,6 +313,7 @@ instance Service DiscoveryService where if refDigest (dconnSource conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self) then do -- response to our request, try to connect to the peer +#ifdef ENABLE_ICE_SUPPORT server <- asks svcServer if | Just addr <- dconnAddress conn , [ipaddr, port] <- words (T.unpack addr) -> do @@ -208,17 +321,37 @@ instance Service DiscoveryService where getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port) peer <- liftIO $ serverPeer server (addrAddress saddr) svcModifyGlobal $ M.insert (refDigest $ dconnTarget conn) $ - DiscoveryPeer 0 (Just peer) Nothing Nothing + DiscoveryPeer 0 (Just peer) [] Nothing | Just dp <- M.lookup (refDigest $ dconnTarget conn) dpeers , Just ice <- dpIceSession dp - , Just rinfo <- dconnIceSession conn -> do + , Just rinfo <- dconnIceInfo conn -> do liftIO $ iceConnect ice rinfo $ void $ serverPeerIce server ice | otherwise -> svcPrint $ "Discovery: connection request failed" +#else + return () +#endif else do -- response to relayed request case M.lookup (refDigest $ dconnSource conn) dpeers of Just dp | Just dpeer <- dpPeer dp -> do sendToPeer dpeer $ DiscoveryConnectionResponse conn _ -> svcPrint $ "Discovery: failed to relay connection response" + + serviceNewPeer = do + server <- asks svcServer + peer <- asks svcPeer + + let addrToText saddr = do + ( addr, port ) <- IP.fromSockAddr saddr + Just $ T.pack $ show addr <> " " <> show port + addrs <- concat <$> sequence + [ catMaybes . map addrToText <$> liftIO (getServerAddresses server) +#ifdef ENABLE_ICE_SUPPORT + , return [ T.pack "ICE" ] +#endif + ] + + when (not $ null addrs) $ do + sendToPeer peer $ DiscoverySelf addrs Nothing diff --git a/src/Erebos/Error.hs b/src/Erebos/Error.hs new file mode 100644 index 0000000..3bb8736 --- /dev/null +++ b/src/Erebos/Error.hs @@ -0,0 +1,39 @@ +module Erebos.Error ( + ErebosError(..), + showErebosError, + + FromErebosError(..), + throwOtherError, +) where + +import Control.Monad.Except + + +data ErebosError + = ManyErrors [ ErebosError ] + | OtherError String + +showErebosError :: ErebosError -> String +showErebosError (ManyErrors errs) = unlines $ map showErebosError errs +showErebosError (OtherError str) = str + +instance Semigroup ErebosError where + ManyErrors [] <> b = b + a <> ManyErrors [] = a + ManyErrors a <> ManyErrors b = ManyErrors (a ++ b) + ManyErrors a <> b = ManyErrors (a ++ [ b ]) + a <> ManyErrors b = ManyErrors (a : b) + a@OtherError {} <> b@OtherError {} = ManyErrors [ a, b ] + +instance Monoid ErebosError where + mempty = ManyErrors [] + + +class FromErebosError e where + fromErebosError :: ErebosError -> e + +instance FromErebosError ErebosError where + fromErebosError = id + +throwOtherError :: (MonadError e m, FromErebosError e) => String -> m a +throwOtherError = throwError . fromErebosError . OtherError diff --git a/src/Erebos/ICE.chs b/src/Erebos/ICE.chs index 2d3177d..2c6f500 100644 --- a/src/Erebos/ICE.chs +++ b/src/Erebos/ICE.chs @@ -4,9 +4,11 @@ module Erebos.ICE ( IceSession, IceSessionRole(..), + IceConfig, IceRemoteInfo, - iceCreate, + iceCreateConfig, + iceCreateSession, iceDestroy, iceRemoteInfo, iceShow, @@ -17,23 +19,24 @@ module Erebos.ICE ( ) where import Control.Arrow -import Control.Concurrent.MVar +import Control.Concurrent import Control.Monad -import Control.Monad.Except import Control.Monad.Identity import Data.ByteString (ByteString, packCStringLen, useAsCString) -import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.ByteString.Lazy.Char8 qualified as BLC import Data.ByteString.Unsafe import Data.Function import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Read as T +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Read qualified as T import Data.Void +import Data.Word import Foreign.C.String import Foreign.C.Types +import Foreign.ForeignPtr import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Ptr @@ -48,6 +51,7 @@ import Erebos.Storage data IceSession = IceSession { isStrans :: PjIceStrans + , _isConfig :: IceConfig , isChan :: MVar (Either [ByteString] (Flow Void ByteString)) } @@ -113,19 +117,43 @@ instance StorableText IceCandidate where , icandPort = port , icandType = ctype } - _ -> throwError "failed to parse candidate" + _ -> throwOtherError "failed to parse candidate" {#enum pj_ice_sess_role as IceSessionRole {underscoreToCase} deriving (Show, Eq) #} +data PjIceStransCfg +newtype IceConfig = IceConfig (ForeignPtr PjIceStransCfg) + +foreign import ccall unsafe "pjproject.h &ice_cfg_free" + ice_cfg_free :: FunPtr (Ptr PjIceStransCfg -> IO ()) +foreign import ccall unsafe "pjproject.h ice_cfg_create" + ice_cfg_create :: CString -> Word16 -> CString -> Word16 -> IO (Ptr PjIceStransCfg) + +iceCreateConfig :: Maybe ( Text, Word16 ) -> Maybe ( Text, Word16 ) -> IO (Maybe IceConfig) +iceCreateConfig stun turn = + maybe ($ nullPtr) (withText . fst) stun $ \cstun -> + maybe ($ nullPtr) (withText . fst) turn $ \cturn -> do + cfg <- ice_cfg_create cstun (maybe 0 snd stun) cturn (maybe 0 snd turn) + if cfg == nullPtr + then return Nothing + else Just . IceConfig <$> newForeignPtr ice_cfg_free cfg + {#pointer *pj_ice_strans as ^ #} -iceCreate :: IceSessionRole -> (IceSession -> IO ()) -> IO IceSession -iceCreate role cb = do +iceCreateSession :: IceConfig -> IceSessionRole -> (IceSession -> IO ()) -> IO IceSession +iceCreateSession icfg@(IceConfig fcfg) role cb = do rec sptr <- newStablePtr sess - cbptr <- newStablePtr $ cb sess + cbptr <- newStablePtr $ do + -- The callback may be called directly from pj_ice_strans_create or later + -- from a different thread; make sure we use a different thread here + -- to avoid deadlock on accessing 'sess'. + forkIO $ cb sess sess <- IceSession - <$> {#call ice_create #} (fromIntegral $ fromEnum role) (castStablePtrToPtr sptr) (castStablePtrToPtr cbptr) + <$> (withForeignPtr fcfg $ \cfg -> + {#call ice_create #} (castPtr cfg) (fromIntegral $ fromEnum role) (castStablePtrToPtr sptr) (castStablePtrToPtr cbptr) + ) + <*> pure icfg <*> (newMVar $ Left []) return $ sess diff --git a/src/Erebos/ICE/pjproject.c b/src/Erebos/ICE/pjproject.c index d3037bf..e79fb9d 100644 --- a/src/Erebos/ICE/pjproject.c +++ b/src/Erebos/ICE/pjproject.c @@ -12,7 +12,6 @@ static struct { pj_caching_pool cp; pj_pool_t * pool; - pj_ice_strans_cfg cfg; pj_sockaddr def_addr; } ice; @@ -31,9 +30,9 @@ static void ice_perror(const char * msg, pj_status_t status) fprintf(stderr, "ICE: %s: %s\n", msg, err); } -static int ice_worker_thread(void * unused) +static int ice_worker_thread(void * vcfg) { - PJ_UNUSED_ARG(unused); + pj_ice_strans_cfg * cfg = (pj_ice_strans_cfg *) vcfg; while (true) { pj_time_val max_timeout = { 0, 0 }; @@ -41,7 +40,7 @@ static int ice_worker_thread(void * unused) max_timeout.msec = 500; - pj_timer_heap_poll(ice.cfg.stun_cfg.timer_heap, &timeout); + pj_timer_heap_poll(cfg->stun_cfg.timer_heap, &timeout); pj_assert(timeout.sec >= 0 && timeout.msec >= 0); if (timeout.msec >= 1000) @@ -50,7 +49,7 @@ static int ice_worker_thread(void * unused) if (PJ_TIME_VAL_GT(timeout, max_timeout)) timeout = max_timeout; - int c = pj_ioqueue_poll(ice.cfg.stun_cfg.ioqueue, &timeout); + int c = pj_ioqueue_poll(cfg->stun_cfg.ioqueue, &timeout); if (c < 0) pj_thread_sleep(PJ_TIME_VAL_MSEC(timeout)); } @@ -105,7 +104,7 @@ static void ice_init(void) if (done) { pthread_mutex_unlock(&mutex); - goto exit; + return; } pj_log_set_level(1); @@ -125,48 +124,88 @@ static void ice_init(void) pj_caching_pool_init(&ice.cp, NULL, 0); - pj_ice_strans_cfg_default(&ice.cfg); - ice.cfg.stun_cfg.pf = &ice.cp.factory; - ice.pool = pj_pool_create(&ice.cp.factory, "ice", 512, 512, NULL); - if (pj_timer_heap_create(ice.pool, 100, - &ice.cfg.stun_cfg.timer_heap) != PJ_SUCCESS) { - fprintf(stderr, "pj_timer_heap_create failed\n"); - goto exit; +exit: + done = true; + pthread_mutex_unlock(&mutex); +} + +pj_ice_strans_cfg * ice_cfg_create( const char * stun_server, uint16_t stun_port, + const char * turn_server, uint16_t turn_port ) +{ + ice_init(); + + pj_ice_strans_cfg * cfg = malloc( sizeof(pj_ice_strans_cfg) ); + pj_ice_strans_cfg_default( cfg ); + + cfg->stun_cfg.pf = &ice.cp.factory; + if( pj_timer_heap_create( ice.pool, 100, + &cfg->stun_cfg.timer_heap ) != PJ_SUCCESS ){ + fprintf( stderr, "pj_timer_heap_create failed\n" ); + goto fail; } - if (pj_ioqueue_create(ice.pool, 16, &ice.cfg.stun_cfg.ioqueue) != PJ_SUCCESS) { - fprintf(stderr, "pj_ioqueue_create failed\n"); - goto exit; + if( pj_ioqueue_create( ice.pool, 16, &cfg->stun_cfg.ioqueue ) != PJ_SUCCESS ){ + fprintf( stderr, "pj_ioqueue_create failed\n" ); + goto fail; } pj_thread_t * thread; - if (pj_thread_create(ice.pool, "ice", &ice_worker_thread, - NULL, 0, 0, &thread) != PJ_SUCCESS) { - fprintf(stderr, "pj_thread_create failed\n"); - goto exit; + if( pj_thread_create( ice.pool, NULL, &ice_worker_thread, + cfg, 0, 0, &thread ) != PJ_SUCCESS ){ + fprintf( stderr, "pj_thread_create failed\n" ); + goto fail; } - ice.cfg.af = pj_AF_INET(); - ice.cfg.opt.aggressive = PJ_TRUE; + cfg->af = pj_AF_INET(); + cfg->opt.aggressive = PJ_TRUE; - ice.cfg.stun.server.ptr = "discovery1.erebosprotocol.net"; - ice.cfg.stun.server.slen = strlen(ice.cfg.stun.server.ptr); - ice.cfg.stun.port = 29670; + if( stun_server ){ + cfg->stun.server.ptr = malloc( strlen( stun_server )); + pj_strcpy2( &cfg->stun.server, stun_server ); + if( stun_port ) + cfg->stun.port = stun_port; + } - ice.cfg.turn.server = ice.cfg.stun.server; - ice.cfg.turn.port = ice.cfg.stun.port; - ice.cfg.turn.auth_cred.type = PJ_STUN_AUTH_CRED_STATIC; - ice.cfg.turn.auth_cred.data.static_cred.data_type = PJ_STUN_PASSWD_PLAIN; - ice.cfg.turn.conn_type = PJ_TURN_TP_UDP; + if( turn_server ){ + cfg->turn.server.ptr = malloc( strlen( turn_server )); + pj_strcpy2( &cfg->turn.server, turn_server ); + if( turn_port ) + cfg->turn.port = turn_port; + cfg->turn.auth_cred.type = PJ_STUN_AUTH_CRED_STATIC; + cfg->turn.auth_cred.data.static_cred.data_type = PJ_STUN_PASSWD_PLAIN; + cfg->turn.conn_type = PJ_TURN_TP_UDP; + } -exit: - done = true; - pthread_mutex_unlock(&mutex); + return cfg; +fail: + ice_cfg_free( cfg ); + return NULL; +} + +void ice_cfg_free( pj_ice_strans_cfg * cfg ) +{ + if( ! cfg ) + return; + + if( cfg->turn.server.ptr ) + free( cfg->turn.server.ptr ); + + if( cfg->stun.server.ptr ) + free( cfg->stun.server.ptr ); + + if( cfg->stun_cfg.ioqueue ) + pj_ioqueue_destroy( cfg->stun_cfg.ioqueue ); + + if( cfg->stun_cfg.timer_heap ) + pj_timer_heap_destroy( cfg->stun_cfg.timer_heap ); + + free( cfg ); } -pj_ice_strans * ice_create(pj_ice_sess_role role, HsStablePtr sptr, HsStablePtr cb) +pj_ice_strans * ice_create( const pj_ice_strans_cfg * cfg, pj_ice_sess_role role, + HsStablePtr sptr, HsStablePtr cb ) { ice_init(); @@ -182,8 +221,8 @@ pj_ice_strans * ice_create(pj_ice_sess_role role, HsStablePtr sptr, HsStablePtr .on_ice_complete = cb_on_ice_complete, }; - pj_status_t status = pj_ice_strans_create(NULL, &ice.cfg, 1, - udata, &icecb, &res); + pj_status_t status = pj_ice_strans_create( NULL, cfg, 1, + udata, &icecb, &res ); if (status != PJ_SUCCESS) ice_perror("error creating ice", status); @@ -358,7 +397,7 @@ void ice_send(pj_ice_strans * strans, const char * data, size_t len) return; } - pj_status_t status = pj_ice_strans_sendto(strans, 1, data, len, + pj_status_t status = pj_ice_strans_sendto2(strans, 1, data, len, &ice.def_addr, pj_sockaddr_get_len(&ice.def_addr)); if (status != PJ_SUCCESS && status != PJ_EPENDING) ice_perror("error sending data", status); diff --git a/src/Erebos/ICE/pjproject.h b/src/Erebos/ICE/pjproject.h index e230e75..e4fcbdb 100644 --- a/src/Erebos/ICE/pjproject.h +++ b/src/Erebos/ICE/pjproject.h @@ -3,7 +3,12 @@ #include <pjnath.h> #include <HsFFI.h> -pj_ice_strans * ice_create(pj_ice_sess_role role, HsStablePtr sptr, HsStablePtr cb); +pj_ice_strans_cfg * ice_cfg_create( const char * stun_server, uint16_t stun_port, + const char * turn_server, uint16_t turn_port ); +void ice_cfg_free( pj_ice_strans_cfg * cfg ); + +pj_ice_strans * ice_create( const pj_ice_strans_cfg *, pj_ice_sess_role role, + HsStablePtr sptr, HsStablePtr cb ); void ice_destroy(pj_ice_strans * strans); ssize_t ice_encode_session(pj_ice_strans *, char * ufrag, char * pass, diff --git a/src/Erebos/Identity.hs b/src/Erebos/Identity.hs index e75999d..a3f17b5 100644 --- a/src/Erebos/Identity.hs +++ b/src/Erebos/Identity.hs @@ -280,13 +280,13 @@ validateExtendedIdentityFE mdata = do Just mk -> return mk loadIdentity :: String -> LoadRec ComposedIdentity -loadIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name +loadIdentity name = maybe (throwOtherError "identity validation failed") return . validateExtendedIdentityF =<< loadRefs name loadMbIdentity :: String -> LoadRec (Maybe ComposedIdentity) loadMbIdentity name = return . validateExtendedIdentityF =<< loadRefs name loadUnifiedIdentity :: String -> LoadRec UnifiedIdentity -loadUnifiedIdentity name = maybe (throwError "identity validation failed") return . validateExtendedIdentity =<< loadRef name +loadUnifiedIdentity name = maybe (throwOtherError "identity validation failed") return . validateExtendedIdentity =<< loadRef name loadMbUnifiedIdentity :: String -> LoadRec (Maybe UnifiedIdentity) loadMbUnifiedIdentity name = return . (validateExtendedIdentity =<<) =<< loadMbRef name @@ -322,7 +322,7 @@ lookupProperty sel topHeads = findResult propHeads findResult [] = Nothing findResult xs = sel $ fromSigned $ minimum xs -mergeIdentity :: (MonadStorage m, MonadError String m, MonadIO m) => Identity f -> m UnifiedIdentity +mergeIdentity :: (MonadStorage m, MonadError e m, FromErebosError e, MonadIO m) => Identity f -> m UnifiedIdentity mergeIdentity idt | Just idt' <- toUnifiedIdentity idt = return idt' mergeIdentity idt@Identity {..} = do (owner, ownerData) <- case idOwner_ of diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs index 364597f..54658de 100644 --- a/src/Erebos/Network.hs +++ b/src/Erebos/Network.hs @@ -6,6 +6,7 @@ module Erebos.Network ( stopServer, getCurrentPeerList, getNextPeerChange, + getServerAddresses, ServerOptions(..), serverIdentity, defaultServerOptions, Peer, peerServer, peerStorage, @@ -46,17 +47,18 @@ import Data.Maybe import Data.Typeable import Data.Word +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array import Foreign.Ptr -import Foreign.Storable +import Foreign.Storable as F import GHC.Conc.Sync (unsafeIOToSTM) import Network.Socket hiding (ControlMessage) import qualified Network.Socket.ByteString as S -import Foreign.C.Types -import Foreign.Marshal.Alloc - +import Erebos.Error #ifdef ENABLE_ICE_SUPPORT import Erebos.ICE #endif @@ -84,6 +86,7 @@ announceIntervalSeconds = 60 data Server = Server { serverStorage :: Storage + , serverOptions :: ServerOptions , serverOrigHead :: Head LocalState , serverIdentity_ :: MVar UnifiedIdentity , serverThreads :: MVar [ThreadId] @@ -91,7 +94,7 @@ data Server = Server , serverRawPath :: SymFlow (PeerAddress, BC.ByteString) , serverControlFlow :: Flow (ControlMessage PeerAddress) (ControlRequest PeerAddress) , serverDataResponse :: TQueue (Peer, Maybe PartialRef) - , serverIOActions :: TQueue (ExceptT String IO ()) + , serverIOActions :: TQueue (ExceptT ErebosError IO ()) , serverServices :: [SomeService] , serverServiceStates :: TMVar (M.Map ServiceID SomeServiceGlobalState) , serverPeers :: MVar (Map PeerAddress Peer) @@ -187,8 +190,8 @@ instance Ord PeerAddress where #endif -data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT String IO ()]) - | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT String IO ()]) +data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT ErebosError IO ()]) + | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT ErebosError IO ()]) | PeerIdentityFull UnifiedIdentity peerIdentity :: MonadIO m => Peer -> m PeerIdentity @@ -230,7 +233,7 @@ forkServerThread server act = do return (t:ts) startServer :: ServerOptions -> Head LocalState -> (String -> IO ()) -> [SomeService] -> IO Server -startServer opt serverOrigHead logd' serverServices = do +startServer serverOptions serverOrigHead logd' serverServices = do let serverStorage = headStorage serverOrigHead serverIdentity_ <- newMVar $ headLocalIdentity serverOrigHead serverThreads <- newMVar [] @@ -253,7 +256,7 @@ startServer opt serverOrigHead logd' serverServices = do forkServerThread server $ dataResponseWorker server forkServerThread server $ forever $ do - either (atomically . logd) return =<< runExceptT =<< + either (atomically . logd . showErebosError) return =<< runExceptT =<< atomically (readTQueue serverIOActions) let open addr = do @@ -266,7 +269,7 @@ startServer opt serverOrigHead logd' serverServices = do return sock loop sock = do - when (serverLocalDiscovery opt) $ forkServerThread server $ do + when (serverLocalDiscovery serverOptions) $ forkServerThread server $ do announceAddreses <- fmap concat $ sequence $ [ map (SockAddrInet6 discoveryPort 0 discoveryMulticastGroup) <$> joinMulticast sock , getBroadcastAddresses discoveryPort @@ -378,7 +381,7 @@ startServer opt serverOrigHead logd' serverServices = do , addrFamily = AF_INET6 , addrSocketType = Datagram } - addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort opt) + addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort serverOptions) bracket (open addr) close loop forkServerThread server $ forever $ do @@ -405,7 +408,7 @@ dataResponseWorker server = forever $ do Right ref -> do atomically (writeTVar tvar $ Right ref) forkServerThread server $ runExceptT (wrefAction wr ref) >>= \case - Left err -> atomically $ writeTQueue (serverErrorLog server) err + Left err -> atomically $ writeTQueue (serverErrorLog server) (showErebosError err) Right () -> return () return (Nothing, []) @@ -584,7 +587,7 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = liftSTM $ writeTQueue (serverIOActions server) $ void $ liftIO $ forkIO $ do (runExcept <$> readObjectsFromStream (peerInStorage peer) streamReader) >>= \case Left err -> atomically $ writeTQueue (serverErrorLog server) $ - "failed to receive object from stream: " <> err + "failed to receive object from stream: " <> showErebosError err Right objs -> do forM_ objs $ \obj -> do pref <- storeObject (peerInStorage peer) obj @@ -666,7 +669,7 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = _ -> 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:) @@ -722,7 +725,7 @@ handleChannelAccept identity accref = do sendToPeerS peer [] $ TransportPacket (TransportHeader [Acknowledged $ refDigest accref]) [] finalizedChannel peer ch identity - Left dgst -> throwError $ "missing accept data " ++ BC.unpack (showRefDigest dgst) + Left dgst -> throwOtherError $ "missing accept data " ++ BC.unpack (showRefDigest dgst) finalizedChannel :: Peer -> Channel -> UnifiedIdentity -> STM () @@ -880,7 +883,7 @@ sendToPeerS = sendToPeerS' EncryptedOnly sendToPeerPlain :: Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM () sendToPeerPlain = sendToPeerS' PlaintextAllowed -sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m () +sendToPeerWith :: forall s m e. (Service s, MonadIO m, MonadError e m, FromErebosError e) => Peer -> (ServiceState s -> ExceptT ErebosError IO (Maybe s, ServiceState s)) -> m () sendToPeerWith peer fobj = do let sproxy = Proxy @s sid = serviceID sproxy @@ -895,7 +898,7 @@ sendToPeerWith peer fobj = do case res of Right (Just obj) -> sendToPeer peer obj Right Nothing -> return () - Left err -> throwError err + Left err -> throwError $ fromErebosError err lookupService :: forall s. Service s => Proxy s -> [SomeService] -> Maybe (SomeService, ServiceAttributes s) @@ -955,17 +958,56 @@ runPeerServiceOn mbservice peer handler = liftIO $ do foreign import ccall unsafe "Network/ifaddrs.h join_multicast" cJoinMulticast :: CInt -> Ptr CSize -> IO (Ptr Word32) +foreign import ccall unsafe "Network/ifaddrs.h local_addresses" cLocalAddresses :: Ptr CSize -> IO (Ptr InetAddress) foreign import ccall unsafe "Network/ifaddrs.h broadcast_addresses" cBroadcastAddresses :: IO (Ptr Word32) -foreign import ccall unsafe "stdlib.h free" cFree :: Ptr Word32 -> IO () +foreign import ccall unsafe "stdlib.h free" cFree :: Ptr a -> IO () + +data InetAddress = InetAddress { fromInetAddress :: IP.IP } + +instance F.Storable InetAddress where + sizeOf _ = sizeOf (undefined :: CInt) + 16 + alignment _ = 8 + + peek ptr = (unpackFamily <$> peekByteOff ptr 0) >>= \case + AF_INET -> InetAddress . IP.IPv4 . IP.fromHostAddress <$> peekByteOff ptr (sizeOf (undefined :: CInt)) + AF_INET6 -> InetAddress . IP.IPv6 . IP.toIPv6b . map fromIntegral <$> peekArray 16 (ptr `plusPtr` sizeOf (undefined :: CInt) :: Ptr Word8) + _ -> fail "InetAddress: unknown family" + + poke ptr (InetAddress addr) = case addr of + IP.IPv4 ip -> do + pokeByteOff ptr 0 (packFamily AF_INET) + pokeByteOff ptr (sizeOf (undefined :: CInt)) (IP.toHostAddress ip) + IP.IPv6 ip -> do + pokeByteOff ptr 0 (packFamily AF_INET6) + pokeArray (ptr `plusPtr` sizeOf (undefined :: CInt) :: Ptr Word8) (map fromIntegral $ IP.fromIPv6b ip) joinMulticast :: Socket -> IO [ Word32 ] joinMulticast sock = withFdSocket sock $ \fd -> alloca $ \pcount -> do ptr <- cJoinMulticast fd pcount - count <- fromIntegral <$> peek pcount - forM [ 0 .. count - 1 ] $ \i -> - peekElemOff ptr i + if ptr == nullPtr + then do + return [] + else do + count <- fromIntegral <$> peek pcount + res <- forM [ 0 .. count - 1 ] $ \i -> + peekElemOff ptr i + cFree ptr + return res + +getServerAddresses :: Server -> IO [ SockAddr ] +getServerAddresses Server {..} = do + alloca $ \pcount -> do + ptr <- cLocalAddresses pcount + if ptr == nullPtr + then do + return [] + else do + count <- fromIntegral <$> peek pcount + res <- peekArray count ptr + cFree ptr + return $ map (IP.toSockAddr . (, serverPort serverOptions ) . fromInetAddress) res getBroadcastAddresses :: PortNumber -> IO [SockAddr] getBroadcastAddresses port = do diff --git a/src/Erebos/Network/Channel.hs b/src/Erebos/Network/Channel.hs index 17e1a37..d9679bd 100644 --- a/src/Erebos/Network/Channel.hs +++ b/src/Erebos/Network/Channel.hs @@ -78,23 +78,23 @@ instance Storable ChannelAcceptData where keySize :: Int keySize = 32 -createChannelRequest :: (MonadStorage m, MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> m (Stored ChannelRequest) +createChannelRequest :: (MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> m (Stored ChannelRequest) createChannelRequest self peer = do (_, xpublic) <- liftIO . generateKeys =<< getStorage skey <- loadKey $ idKeyMessage self mstore =<< sign skey =<< mstore ChannelRequest { crPeers = sort [idData self, idData peer], crKey = xpublic } -acceptChannelRequest :: (MonadStorage m, MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Channel) +acceptChannelRequest :: (MonadStorage m, MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> m (Stored ChannelAccept, Channel) acceptChannelRequest self peer req = do case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of - Nothing -> throwError $ "invalid peers in channel request" + Nothing -> throwOtherError $ "invalid peers in channel request" Just peers -> do when (not $ any (self `sameIdentity`) peers) $ - throwError $ "self identity missing in channel request peers" + throwOtherError $ "self identity missing in channel request peers" when (not $ any (peer `sameIdentity`) peers) $ - throwError $ "peer identity missing in channel request peers" + throwOtherError $ "peer identity missing in channel request peers" when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $ - throwError $ "channel requent not signed by peer" + throwOtherError $ "channel requent not signed by peer" (xsecret, xpublic) <- liftIO . generateKeys =<< getStorage skey <- loadKey $ idKeyMessage self @@ -110,20 +110,20 @@ acceptChannelRequest self peer req = do return (acc, Channel {..}) -acceptedChannel :: (MonadIO m, MonadError String m) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m Channel +acceptedChannel :: (MonadIO m, MonadError e m, FromErebosError e) => UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> m Channel acceptedChannel self peer acc = do let req = caRequest $ fromStored $ signedData $ fromStored acc case sequence $ map validateIdentity $ crPeers $ fromStored $ signedData $ fromStored req of - Nothing -> throwError $ "invalid peers in channel accept" + Nothing -> throwOtherError $ "invalid peers in channel accept" Just peers -> do when (not $ any (self `sameIdentity`) peers) $ - throwError $ "self identity missing in channel accept peers" + throwOtherError $ "self identity missing in channel accept peers" when (not $ any (peer `sameIdentity`) peers) $ - throwError $ "peer identity missing in channel accept peers" + throwOtherError $ "peer identity missing in channel accept peers" when (idKeyMessage peer `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)) $ - throwError $ "channel accept not signed by peer" + throwOtherError $ "channel accept not signed by peer" when (idKeyMessage self `notElem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)) $ - throwError $ "original channel request not signed by us" + throwOtherError $ "original channel request not signed by us" xsecret <- loadKey $ crKey $ fromStored $ signedData $ fromStored req let chPeers = crPeers $ fromStored $ signedData $ fromStored req @@ -137,23 +137,23 @@ acceptedChannel self peer acc = do return Channel {..} -channelEncrypt :: (ByteArray ba, MonadIO m, MonadError String m) => Channel -> ba -> m (ba, Word64) +channelEncrypt :: (ByteArray ba, MonadIO m, MonadError e m, FromErebosError e) => Channel -> ba -> m (ba, Word64) channelEncrypt Channel {..} plain = do count <- liftIO $ modifyMVar chCounterNextOut $ \c -> return (c + 1, c) let cbytes = convert $ BL.toStrict $ encode count nonce = nonce8 chNonceFixedOur cbytes state <- case initialize chKey =<< nonce of CryptoPassed state -> return state - CryptoFailed err -> throwError $ "failed to init chacha-poly1305 cipher: " <> show err + CryptoFailed err -> throwOtherError $ "failed to init chacha-poly1305 cipher: " <> show err let (ctext, state') = encrypt plain state tag = finalize state' return (BA.concat [ convert $ BA.drop 7 cbytes, ctext, convert tag ], count) -channelDecrypt :: (ByteArray ba, MonadIO m, MonadError String m) => Channel -> ba -> m (ba, Word64) +channelDecrypt :: (ByteArray ba, MonadIO m, MonadError e m, FromErebosError e) => Channel -> ba -> m (ba, Word64) channelDecrypt Channel {..} body = do when (BA.length body < 17) $ do - throwError $ "invalid encrypted data length" + throwOtherError $ "invalid encrypted data length" expectedCount <- liftIO $ readMVar chCounterNextIn let countByte = body `BA.index` 0 @@ -165,11 +165,11 @@ channelDecrypt Channel {..} body = do tag = BA.dropView body' blen state <- case initialize chKey =<< nonce of CryptoPassed state -> return state - CryptoFailed err -> throwError $ "failed to init chacha-poly1305 cipher: " <> show err + CryptoFailed err -> throwOtherError $ "failed to init chacha-poly1305 cipher: " <> show err let (plain, state') = decrypt (convert ctext) state when (not $ tag `BA.constEq` finalize state') $ do - throwError $ "tag validation falied" + throwOtherError $ "tag validation falied" liftIO $ modifyMVar_ chCounterNextIn $ return . max (guessedCount + 1) return (plain, guessedCount) diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs index c657759..c340503 100644 --- a/src/Erebos/Network/Protocol.hs +++ b/src/Erebos/Network/Protocol.hs @@ -323,7 +323,7 @@ connAddWriteStream conn@Connection {..} = do Right (ctext, counter) -> do let isAcked = True return $ Just (0x80 `B.cons` ctext, if isAcked then [ AcknowledgedSingle $ fromIntegral counter ] else []) - Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ err + Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ showErebosError err return Nothing Nothing | secure -> return Nothing | otherwise -> return $ Just (plain, plainAckedBy) @@ -402,16 +402,16 @@ readStreamToList stream = readFlowIO 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 @@ -434,7 +434,7 @@ data WaitingRef = WaitingRef , wrefStatus :: TVar (Either [RefDigest] Ref) } -type WaitingRefCallback = ExceptT String IO () +type WaitingRefCallback = ExceptT ErebosError IO () wrDigest :: WaitingRef -> RefDigest wrDigest = refDigest . wrefPartial @@ -571,7 +571,7 @@ processIncoming gs@GlobalState {..} = do let parse = case B.uncons msg of Just (b, enc) | b .&. 0xE0 == 0x80 -> do - ch <- maybe (throwError "unexpected encrypted packet") return mbch + ch <- maybe (throwOtherError "unexpected encrypted packet") return mbch (dec, counter) <- channelDecrypt ch enc case B.uncons dec of @@ -586,18 +586,18 @@ processIncoming gs@GlobalState {..} = do return $ Right (snum, seq8, content, counter) Just (_, _) -> do - throwError "unexpected stream header" + throwOtherError "unexpected stream header" Nothing -> do - throwError "empty decrypted content" + throwOtherError "empty decrypted content" | b .&. 0xE0 == 0x60 -> do objs <- deserialize msg return $ Left (False, objs, Nothing) - | otherwise -> throwError "invalid packet" + | otherwise -> throwOtherError "invalid packet" - Nothing -> throwError "empty packet" + Nothing -> throwOtherError "empty packet" now <- getTime Monotonic runExceptT parse >>= \case @@ -648,7 +648,7 @@ processIncoming gs@GlobalState {..} = do atomically $ gLog $ show addr <> ": stream packet without connection" Left err -> do - atomically $ gLog $ show addr <> ": failed to parse packet: " <> err + atomically $ gLog $ show addr <> ": failed to parse packet: " <> showErebosError err processPacket :: GlobalState addr -> Either addr (Connection addr) -> Bool -> TransportPacket a -> IO (Maybe (Connection addr, Maybe (TransportPacket a))) processPacket gs@GlobalState {..} econn secure packet@(TransportPacket (TransportHeader header) _) = if @@ -882,7 +882,7 @@ processOutgoing gs@GlobalState {..} = do Right (ctext, counter) -> do let isAcked = any isHeaderItemAcknowledged hitems return $ Just (0x80 `B.cons` ctext, if isAcked then [ AcknowledgedSingle $ fromIntegral counter ] else []) - Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ err + Left err -> do atomically $ gLog $ "Failed to encrypt data: " ++ showErebosError err return Nothing mbs <- case (secure, mbch) of diff --git a/src/Erebos/Network/ifaddrs.c b/src/Erebos/Network/ifaddrs.c index 637716e..ff4382a 100644 --- a/src/Erebos/Network/ifaddrs.c +++ b/src/Erebos/Network/ifaddrs.c @@ -9,6 +9,7 @@ #ifndef _WIN32 #include <arpa/inet.h> #include <net/if.h> +#include <netinet/in.h> #include <ifaddrs.h> #include <endian.h> #include <sys/types.h> @@ -85,8 +86,73 @@ uint32_t * join_multicast(int fd, size_t * count) return interfaces; } +static bool copy_local_address( struct InetAddress * dst, const struct sockaddr * src ) +{ + int family = src->sa_family; + + if( family == AF_INET ){ + struct in_addr * addr = & (( struct sockaddr_in * ) src)->sin_addr; + if (! ((ntohl( addr->s_addr ) & 0xff000000) == 0x7f000000) && // loopback + ! ((ntohl( addr->s_addr ) & 0xffff0000) == 0xa9fe0000) // link-local + ){ + dst->family = family; + memcpy( & dst->addr, addr, sizeof( * addr )); + return true; + } + } + + if( family == AF_INET6 ){ + struct in6_addr * addr = & (( struct sockaddr_in6 * ) src)->sin6_addr; + if (! IN6_IS_ADDR_LOOPBACK( addr ) && + ! IN6_IS_ADDR_LINKLOCAL( addr ) + ){ + dst->family = family; + memcpy( & dst->addr, addr, sizeof( * addr )); + return true; + } + } + + return false; +} + #ifndef _WIN32 +struct InetAddress * local_addresses( size_t * count ) +{ + struct ifaddrs * addrs; + if( getifaddrs( &addrs ) < 0 ) + return 0; + + * count = 0; + size_t capacity = 16; + struct InetAddress * ret = malloc( sizeof(* ret) * capacity ); + + for( struct ifaddrs * ifa = addrs; ifa; ifa = ifa->ifa_next ){ + if ( ifa->ifa_addr ){ + int family = ifa->ifa_addr->sa_family; + if( family == AF_INET || family == AF_INET6 ){ + if( (* count) >= capacity ){ + capacity *= 2; + struct InetAddress * nret = realloc( ret, sizeof(* ret) * capacity ); + if (nret) { + ret = nret; + } else { + free( ret ); + freeifaddrs( addrs ); + return 0; + } + } + + if( copy_local_address( & ret[ * count ], ifa->ifa_addr )) + (* count)++; + } + } + } + + freeifaddrs(addrs); + return ret; +} + uint32_t * broadcast_addresses(void) { struct ifaddrs * addrs; @@ -106,6 +172,7 @@ uint32_t * broadcast_addresses(void) ret = nret; } else { free(ret); + freeifaddrs(addrs); return 0; } } @@ -124,9 +191,52 @@ uint32_t * broadcast_addresses(void) #include <winsock2.h> #include <ws2tcpip.h> +#include <iptypes.h> +#include <iphlpapi.h> #pragma comment(lib, "ws2_32.lib") +struct InetAddress * local_addresses( size_t * count ) +{ + * count = 0; + struct InetAddress * ret = NULL; + + ULONG bufsize = 15000; + IP_ADAPTER_ADDRESSES * buf = NULL; + + DWORD rv = 0; + + do { + buf = realloc( buf, bufsize ); + rv = GetAdaptersAddresses( AF_UNSPEC, 0, NULL, buf, & bufsize ); + + if( rv == ERROR_BUFFER_OVERFLOW ) + continue; + } while (0); + + if( rv == NO_ERROR ){ + size_t capacity = 16; + ret = malloc( sizeof( * ret ) * capacity ); + + for( IP_ADAPTER_ADDRESSES * cur = (IP_ADAPTER_ADDRESSES *) buf; + cur && (* count) < capacity; + cur = cur->Next ){ + + for( IP_ADAPTER_UNICAST_ADDRESS * curAddr = cur->FirstUnicastAddress; + curAddr && (* count) < capacity; + curAddr = curAddr->Next ){ + + if( copy_local_address( & ret[ * count ], curAddr->Address.lpSockaddr )) + (* count)++; + } + } + } + +cleanup: + free( buf ); + return ret; +} + uint32_t * broadcast_addresses(void) { uint32_t * ret = NULL; diff --git a/src/Erebos/Network/ifaddrs.h b/src/Erebos/Network/ifaddrs.h index 8852ec6..2ee45a7 100644 --- a/src/Erebos/Network/ifaddrs.h +++ b/src/Erebos/Network/ifaddrs.h @@ -1,5 +1,18 @@ #include <stddef.h> #include <stdint.h> +#ifndef _WIN32 +#include <sys/socket.h> +#else +#include <winsock2.h> +#endif + +struct InetAddress +{ + int family; + uint8_t addr[16]; +} __attribute__((packed)); + uint32_t * join_multicast(int fd, size_t * count); +struct InetAddress * local_addresses( size_t * count ); uint32_t * broadcast_addresses(void); diff --git a/src/Erebos/Object/Internal.hs b/src/Erebos/Object/Internal.hs index 03ee83c..4bca49c 100644 --- a/src/Erebos/Object/Internal.hs +++ b/src/Erebos/Object/Internal.hs @@ -1,7 +1,5 @@ module Erebos.Object.Internal ( Storage, PartialStorage, StorageCompleteness, - openStorage, memoryStorage, - deriveEphemeralStorage, derivePartialStorage, Ref, PartialRef, RefDigest, refDigest, @@ -45,17 +43,9 @@ module Erebos.Object.Internal ( 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 @@ -72,8 +62,6 @@ 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 qualified Data.Map as M import Data.Maybe import Data.Ratio import Data.Set (Set) @@ -89,92 +77,12 @@ import Data.Time.LocalTime import Data.UUID (UUID) import qualified Data.UUID as U -import System.Directory -import System.FilePath -import System.IO.Error import System.IO.Unsafe +import Erebos.Error 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 @@ -308,7 +216,7 @@ ioLoadObject ref@(Ref st rhash) = do 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 -} + 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 -} @@ -316,7 +224,7 @@ lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.By 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 :: 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 @@ -325,10 +233,10 @@ unsafeDeserializeObject st bytes = 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 ") + | otype == BC.pack "rec" -> maybe (throwOtherError $ "malformed record item ") (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content | otherwise -> return $ UnknownObject otype content - _ -> throwError $ "Malformed object" + _ -> throwOtherError $ "malformed object" where splitObjPrefix line = do [otype, tlen] <- return $ BLC.words line (len, rest) <- BLC.readInt tlen @@ -363,10 +271,10 @@ unsafeDeserializeObject st bytes = _ -> Nothing return (name, val) -deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString) +deserializeObject :: PartialStorage -> BL.ByteString -> Except ErebosError (PartialObject, BL.ByteString) deserializeObject = unsafeDeserializeObject -deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject] +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 @@ -437,11 +345,12 @@ newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString type StoreRec c = StoreRecM c () -newtype Load a = Load (ReaderT (Ref, Object) (Except String) a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) +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) ++ ": ")++)) id $ runExcept $ runReaderT f (ref, lazyLoadObject ref) +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 @@ -449,8 +358,8 @@ 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) +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 @@ -506,7 +415,7 @@ storeZero = StoreZero class StorableText a where toText :: a -> Text - fromText :: MonadError String m => Text -> m a + fromText :: MonadError ErebosError m => Text -> m a instance StorableText Text where toText = id; fromText = return @@ -619,23 +528,23 @@ storeRecItems items = StoreRecM $ do loadBlob :: (ByteString -> a) -> Load a loadBlob f = loadCurrentObject >>= \case Blob x -> return $ f x - _ -> throwError "Expecting blob" + _ -> 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) - _ -> throwError "Expecting record" + _ -> throwOtherError "Expecting record" loadZero :: a -> Load a loadZero x = loadCurrentObject >>= \case ZeroObject -> return x - _ -> throwError "Expecting zero" + _ -> throwOtherError "Expecting zero" loadEmpty :: String -> LoadRec () -loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name +loadEmpty name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name loadMbEmpty :: String -> LoadRec (Maybe ()) loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems @@ -646,7 +555,7 @@ loadMbEmpty name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadInt :: Num a => String -> LoadRec a -loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name +loadInt name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbInt name loadMbInt :: Num a => String -> LoadRec (Maybe a) loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems @@ -657,7 +566,7 @@ loadMbInt name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadNum :: (Real a, Fractional a) => String -> LoadRec a -loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name +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 @@ -668,7 +577,7 @@ loadMbNum name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadText :: StorableText a => String -> LoadRec a -loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name +loadText name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbText name loadMbText :: StorableText a => String -> LoadRec (Maybe a) loadMbText name = listToMaybe <$> loadTexts name @@ -682,7 +591,7 @@ loadTexts name = sequence . mapMaybe p =<< loadRecItems p _ = Nothing loadBinary :: BA.ByteArray a => String -> LoadRec a -loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name +loadBinary name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbBinary name loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a) loadMbBinary name = listToMaybe <$> loadBinaries name @@ -696,7 +605,7 @@ loadBinaries name = mapMaybe p <$> loadRecItems p _ = Nothing loadDate :: StorableDate a => String -> LoadRec a -loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name +loadDate name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbDate name loadMbDate :: StorableDate a => String -> LoadRec (Maybe a) loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems @@ -707,7 +616,7 @@ loadMbDate name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadUUID :: StorableUUID a => String -> LoadRec a -loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name +loadUUID name = maybe (throwOtherError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a) loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems @@ -718,7 +627,7 @@ loadMbUUID name = listToMaybe . mapMaybe p <$> loadRecItems p _ = Nothing loadRawRef :: String -> LoadRec Ref -loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name +loadRawRef name = maybe (throwOtherError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name loadMbRawRef :: String -> LoadRec (Maybe Ref) loadMbRawRef name = listToMaybe <$> loadRawRefs name @@ -778,72 +687,6 @@ 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 diff --git a/src/Erebos/Pairing.hs b/src/Erebos/Pairing.hs index da6a9b4..703afcd 100644 --- a/src/Erebos/Pairing.hs +++ b/src/Erebos/Pairing.hs @@ -49,7 +49,7 @@ data PairingState a = NoPairing data PairingFailureReason a = PairingUserRejected | PairingUnexpectedMessage (PairingState a) (PairingService a) - | PairingFailedOther String + | PairingFailedOther ErebosError data PairingAttributes a = PairingAttributes { pairingHookRequest :: ServiceHandler (PairingService a) () @@ -116,16 +116,16 @@ instance PairingResult a => Service (PairingService a) where serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case (NoPairing, PairingRequest pdata sdata confirm) -> do - self <- maybe (throwError "failed to validate received identity") return $ validateIdentity sdata - self' <- maybe (throwError "failed to validate own identity") return . + self <- maybe (throwOtherError "failed to validate received identity") return $ validateIdentity sdata + self' <- maybe (throwOtherError "failed to validate own identity") return . validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal when (not $ self `sameIdentity` self') $ do - throwError "pairing request to different identity" + throwOtherError "pairing request to different identity" - peer <- maybe (throwError "failed to validate received peer identity") return $ validateIdentity pdata + peer <- maybe (throwOtherError "failed to validate received peer identity") return $ validateIdentity pdata peer' <- asks $ svcPeerIdentity when (not $ peer `sameIdentity` peer') $ do - throwError "pairing request from different identity" + throwOtherError "pairing request from different identity" join $ asks $ pairingHookRequest . svcAttributes nonce <- liftIO $ getRandomBytes 32 @@ -167,7 +167,7 @@ instance PairingResult a => Service (PairingService a) where svcSet $ PairingDone Nothing -> do join $ asks $ pairingHookVerifyFailed . svcAttributes - throwError "" + throwOtherError "" x@(OurRequestReady, _) -> reject $ uncurry PairingUnexpectedMessage x (PeerRequest peer self nonce dgst, PairingRequestNonce pnonce) -> do @@ -204,22 +204,22 @@ confirmationNumber dgst = _ -> "" where len = 6 -pairingRequest :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () +pairingRequest :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingRequest _ peer = do self <- liftIO $ serverIdentity $ peerServer peer nonce <- liftIO $ getRandomBytes 32 pid <- peerIdentity peer >>= \case PeerIdentityFull pid -> return pid - _ -> throwError "incomplete peer identity" + _ -> throwOtherError "incomplete peer identity" sendToPeerWith @(PairingService a) peer $ \case NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BA.empty), OurRequest self pid nonce) - _ -> throwError "already in progress" + _ -> 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 @@ -227,17 +227,17 @@ pairingAccept _ peer = runPeerService @(PairingService a) peer $ do join $ asks $ pairingHookAcceptedResponse . svcAttributes pairingFinalizeRequest verified svcSet PairingDone - OurRequestReady -> throwError $ "already accepted, waiting for peer" - PeerRequest {} -> throwError $ "waiting for peer" + OurRequestReady -> throwOtherError $ "already accepted, waiting for peer" + PeerRequest {} -> throwOtherError $ "waiting for peer" PeerRequestConfirm -> do join $ asks $ pairingHookAcceptedRequest . svcAttributes replyPacket . PairingAccept =<< pairingFinalizeResponse svcSet PairingDone - PairingDone -> throwError $ "already done" + PairingDone -> throwOtherError $ "already done" -pairingReject :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () +pairingReject :: forall a m e proxy. (PairingResult a, MonadIO m, MonadError e m, FromErebosError e) => proxy a -> Peer -> m () pairingReject _ peer = runPeerService @(PairingService a) peer $ do svcGet >>= \case - NoPairing -> throwError $ "none in progress" - PairingDone -> throwError $ "already done" + NoPairing -> throwOtherError $ "none in progress" + PairingDone -> throwOtherError $ "already done" _ -> reject PairingUserRejected diff --git a/src/Erebos/PubKey.hs b/src/Erebos/PubKey.hs index bea208b..a2ee519 100644 --- a/src/Erebos/PubKey.hs +++ b/src/Erebos/PubKey.hs @@ -11,7 +11,6 @@ module Erebos.PubKey ( ) where import Control.Monad -import Control.Monad.Except import Crypto.Error import qualified Crypto.PubKey.Ed25519 as ED @@ -70,7 +69,7 @@ instance Storable PublicKey where load' = loadRec $ do ktype <- loadText "type" guard $ ktype == "ed25519" - maybe (throwError "Public key decoding failed") (return . PublicKey) . + maybe (throwOtherError "public key decoding failed") (return . PublicKey) . maybeCryptoError . (ED.publicKey :: ByteString -> CryptoFailable ED.PublicKey) =<< loadBinary "pubkey" @@ -82,7 +81,7 @@ instance Storable Signature where load' = loadRec $ Signature <$> loadRef "key" <*> loadSignature "sig" - where loadSignature = maybe (throwError "Signature decoding failed") return . + where loadSignature = maybe (throwOtherError "signature decoding failed") return . maybeCryptoError . (ED.signature :: ByteString -> CryptoFailable ED.Signature) <=< loadBinary instance Storable a => Storable (Signed a) where @@ -96,7 +95,7 @@ instance Storable a => Storable (Signed a) where forM_ sigs $ \sig -> do let PublicKey pubkey = fromStored $ sigKey $ fromStored sig when (not $ ED.verify pubkey (storedRef sdata) $ sigSignature $ fromStored sig) $ - throwError "signature verification failed" + throwOtherError "signature verification failed" return $ Signed sdata sigs sign :: MonadStorage m => SecretKey -> Stored a -> m (Signed a) @@ -148,7 +147,7 @@ instance Storable PublicKexKey where load' = loadRec $ do ktype <- loadText "type" guard $ ktype == "x25519" - maybe (throwError "public key decoding failed") (return . PublicKexKey) . + maybe (throwOtherError "public key decoding failed") (return . PublicKexKey) . maybeCryptoError . (CX.publicKey :: ScrubbedBytes -> CryptoFailable CX.PublicKey) =<< loadBinary "pubkey" diff --git a/src/Erebos/Service.hs b/src/Erebos/Service.hs index f640feb..e95e700 100644 --- a/src/Erebos/Service.hs +++ b/src/Erebos/Service.hs @@ -38,7 +38,13 @@ import Erebos.State import Erebos.Storable import Erebos.Storage.Head -class (Typeable s, Storable s, Typeable (ServiceState s), Typeable (ServiceGlobalState s)) => Service s where +class ( + Typeable s, Storable s, + Typeable (ServiceAttributes s), + Typeable (ServiceState s), + Typeable (ServiceGlobalState s) + ) => Service s where + serviceID :: proxy s -> ServiceID serviceHandler :: Stored s -> ServiceHandler s () @@ -121,8 +127,8 @@ data ServiceHandlerState s = ServiceHandlerState , svcLocal :: Stored LocalState } -newtype ServiceHandler s a = ServiceHandler (ReaderT (ServiceInput s) (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT String IO))) a) - deriving (Functor, Applicative, Monad, MonadReader (ServiceInput s), MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError String, MonadIO) +newtype ServiceHandler s a = ServiceHandler (ReaderT (ServiceInput s) (WriterT [ServiceReply s] (StateT (ServiceHandlerState s) (ExceptT ErebosError IO))) a) + deriving (Functor, Applicative, Monad, MonadReader (ServiceInput s), MonadWriter [ServiceReply s], MonadState (ServiceHandlerState s), MonadError ErebosError, MonadIO) instance MonadStorage (ServiceHandler s) where getStorage = asks $ peerStorage . svcPeer @@ -139,7 +145,7 @@ runServiceHandler h input svc global shandler = do ServiceHandler handler = shandler (runExceptT $ flip runStateT sstate $ execWriterT $ flip runReaderT input $ handler) >>= \case Left err -> do - svcPrintOp input $ "service failed: " ++ err + svcPrintOp input $ "service failed: " ++ showErebosError err return ([], (svc, global)) Right (rsp, sstate') | svcLocal sstate' == svcLocal sstate -> return (rsp, (svcValue sstate', svcGlobal sstate')) @@ -172,7 +178,7 @@ svcSetLocal :: Stored LocalState -> ServiceHandler s () svcSetLocal x = modify $ \st -> st { svcLocal = x } svcSelf :: ServiceHandler s UnifiedIdentity -svcSelf = maybe (throwError "failed to validate own identity") return . +svcSelf = maybe (throwOtherError "failed to validate own identity") return . validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal svcPrint :: String -> ServiceHandler s () diff --git a/src/Erebos/State.hs b/src/Erebos/State.hs index 79f17b7..a2ecb9e 100644 --- a/src/Erebos/State.hs +++ b/src/Erebos/State.hs @@ -1,13 +1,12 @@ module Erebos.State ( LocalState(..), - SharedState, SharedType(..), + SharedState(..), SharedType(..), SharedTypeID, mkSharedTypeID, + MonadStorage(..), MonadHead(..), updateLocalHead_, - loadLocalStateHead, - updateSharedState, updateSharedState_, lookupSharedValue, makeSharedStateUpdate, @@ -15,8 +14,6 @@ module Erebos.State ( headLocalIdentity, mergeSharedIdentity, - updateSharedIdentity, - interactiveIdentityUpdate, ) where import Control.Monad.Except @@ -24,16 +21,10 @@ import Control.Monad.Reader 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 @@ -106,35 +97,6 @@ instance (HeadType a, MonadIO m) => MonadHead a (ReaderT (Head a) m) where snd <$> updateHead h f -loadLocalStateHead :: MonadIO m => Storage -> m (Head LocalState) -loadLocalStateHead st = loadHeads st >>= \case - (h:_) -> return h - [] -> liftIO $ do - putStr "Name: " - hFlush stdout - name <- T.getLine - - putStr "Device: " - hFlush stdout - devName <- T.getLine - - owner <- if - | T.null name -> return Nothing - | otherwise -> Just <$> createIdentity st (Just name) Nothing - - identity <- createIdentity st (if T.null devName then Nothing else Just devName) owner - - shared <- wrappedStore st $ SharedState - { ssPrev = [] - , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy - , ssValue = [storedRef $ idExtData $ fromMaybe identity owner] - } - storeHead st $ LocalState - { lsIdentity = idExtData identity - , lsShared = [ shared ] - , lsOther = [] - } - localIdentity :: LocalState -> UnifiedIdentity localIdentity ls = maybe (error "failed to verify local identity") (updateOwners $ maybe [] idExtDataF $ lookupSharedValue $ lsShared ls) @@ -172,39 +134,9 @@ makeSharedStateUpdate st val prev = liftIO $ wrappedStore st SharedState } -mergeSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m UnifiedIdentity +mergeSharedIdentity :: (MonadHead LocalState m, MonadError e m, FromErebosError e) => m UnifiedIdentity mergeSharedIdentity = updateLocalHead $ updateSharedState $ \case Just cidentity -> do identity <- mergeIdentity cidentity return (Just $ toComposedIdentity identity, identity) - Nothing -> throwError "no existing shared identity" - -updateSharedIdentity :: (MonadHead LocalState m, MonadError String m) => m () -updateSharedIdentity = updateLocalHead_ $ updateSharedState_ $ \case - Just identity -> do - Just . toComposedIdentity <$> interactiveIdentityUpdate identity - Nothing -> throwError "no existing shared identity" - -interactiveIdentityUpdate :: (Foldable f, MonadStorage m, MonadIO m, MonadError String m) => Identity f -> m UnifiedIdentity -interactiveIdentityUpdate identity = do - let public = idKeyIdentity identity - - name <- liftIO $ do - T.putStr $ T.concat $ concat - [ [ T.pack "Name" ] - , case idName identity of - Just name -> [T.pack " [", name, T.pack "]"] - Nothing -> [] - , [ T.pack ": " ] - ] - hFlush stdout - T.getLine - - if | T.null name -> mergeIdentity identity - | otherwise -> do - secret <- loadKey public - maybe (throwError "created invalid identity") return . validateIdentity =<< - mstore =<< sign secret =<< mstore (emptyIdentityData public) - { iddPrev = toList $ idDataF identity - , iddName = Just name - } + Nothing -> throwOtherError "no existing shared identity" diff --git a/src/Erebos/Storable.hs b/src/Erebos/Storable.hs index ee389ce..b0795f9 100644 --- a/src/Erebos/Storable.hs +++ b/src/Erebos/Storable.hs @@ -36,6 +36,9 @@ module Erebos.Storable ( unsafeMapStored, Storage, MonadStorage(..), + + module Erebos.Error, ) where +import Erebos.Error import Erebos.Object.Internal diff --git a/src/Erebos/Storage.hs b/src/Erebos/Storage.hs index 4344b75..f1cce84 100644 --- a/src/Erebos/Storage.hs +++ b/src/Erebos/Storage.hs @@ -24,4 +24,6 @@ module Erebos.Storage ( ) 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 index 0000000..620d423 --- /dev/null +++ b/src/Erebos/Storage/Backend.hs @@ -0,0 +1,28 @@ +{-| +Description: Implement custom storage backend + +Exports type class, which can be used to create custom 'Storage' backend. +-} + +module Erebos.Storage.Backend ( + StorageBackend(..), + Complete, Partial, + Storage, PartialStorage, + newStorage, + + WatchID, startWatchID, nextWatchID, +) where + +import Control.Concurrent.MVar + +import Data.HashTable.IO qualified as HT + +import Erebos.Object.Internal +import Erebos.Storage.Internal + + +newStorage :: StorageBackend bck => bck -> IO (Storage' (BackendCompleteness bck)) +newStorage stBackend = do + stRefGeneration <- newMVar =<< HT.new + stRefRoots <- newMVar =<< HT.new + return Storage {..} diff --git a/src/Erebos/Storage/Disk.hs b/src/Erebos/Storage/Disk.hs new file mode 100644 index 0000000..370c584 --- /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 Data.UUID qualified as U + +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 + + +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 index dc8b7bc..8f8e009 100644 --- a/src/Erebos/Storage/Head.hs +++ b/src/Erebos/Storage/Head.hs @@ -23,27 +23,17 @@ module Erebos.Storage.Head ( ) where import Control.Concurrent -import Control.Exception import Control.Monad -import Control.Monad.IO.Class import Control.Monad.Reader import Data.Bifunctor -import Data.ByteString qualified as B -import Data.ByteString.Char8 qualified as BC -import Data.List -import Data.Maybe import Data.Typeable import Data.UUID qualified as U import Data.UUID.V4 qualified as U -import System.Directory -import System.FSNotify -import System.FilePath -import System.IO.Error - import Erebos.Object import Erebos.Storable +import Erebos.Storage.Backend import Erebos.Storage.Internal @@ -97,31 +87,11 @@ mkHeadTypeID :: String -> HeadTypeID mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString -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 - -- | Load all `Head's of type @a@ from storage. 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 +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 @@ -138,13 +108,8 @@ loadHeadRaw -> 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 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 +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. @@ -162,15 +127,9 @@ storeHead st obj = do -- | 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 st tid ref = liftIO $ do +storeHeadRaw Storage {..} 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) :) + backendStoreHead stBackend tid hid (refDigest ref) return hid -- | Try to replace existing `Head' of type @a@ in the storage. Function fails @@ -216,29 +175,9 @@ replaceHeadRaw -- [@`Right' r@]: -- Head value was updated in storage, the new head value is @r@ -- (which is the same as the indended value). -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 +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 @@ -299,50 +238,22 @@ watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do -- | 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 tid hid sel cb = do +watchHeadRaw st@Storage {..} tid hid sel cb = do memo <- newEmptyMVar - let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo) - where wl' = wl { wlNext = wlNext wl + 1 - , wlList = WatchListItem - { wlID = wlNext wl - , wlHead = (tid, hid) - , wlFun = \r -> do - let x = sel r - modifyMVar_ memo $ \prev -> do - when (Just x /= prev) $ cb x - return $ Just x - } : wlList wl - } - - watched <- case stBacking st of - StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do - manager <- maybe startManager return mbmanager - ilist' <- case tid `elem` ilist of - True -> return ilist - False -> do - void $ watchDir manager (headTypePath spath tid) (const True) $ \case - Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do - loadHeadRaw st tid ihid >>= \case - Just ref -> do - (_, _, iwl) <- readMVar mvar - mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl - Nothing -> return () - _ -> return () - return $ tid : ilist - return $ first ( Just manager, ilist', ) $ addWatcher wl - - StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher + 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 watched + return $ WatchedHead st wid memo -- | Stop watching previously watched head. 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 +unwatchHead (WatchedHead Storage {..} wid _) = do + backendUnwatchHead stBackend wid diff --git a/src/Erebos/Storage/Internal.hs b/src/Erebos/Storage/Internal.hs index 3e8d8b6..6df1410 100644 --- a/src/Erebos/Storage/Internal.hs +++ b/src/Erebos/Storage/Internal.hs @@ -1,7 +1,5 @@ module Erebos.Storage.Internal where -import Codec.Compression.Zlib - import Control.Arrow import Control.Concurrent import Control.DeepSeq @@ -13,76 +11,145 @@ import Crypto.Hash import Data.Bits import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes) -import qualified Data.ByteArray as BA +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.ByteString qualified as B +import Data.ByteString.Char8 qualified as BC +import Data.ByteString.Lazy qualified as BL import Data.Char -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.Typeable import Data.UUID (UUID) 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 - -data Storage' c = Storage - { stBacking :: StorageBacking c - , stParent :: Maybe (Storage' Identity) +data Storage' c = forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => Storage + { stBackend :: bck , stRefGeneration :: MVar (HT.BasicHashTable RefDigest Generation) , stRefRoots :: MVar (HT.BasicHashTable RefDigest [RefDigest]) } +type Storage = Storage' Complete +type PartialStorage = Storage' Partial + instance Eq (Storage' c) where - (==) = (==) `on` (stBacking &&& stParent) + Storage { stBackend = b } == Storage { stBackend = b' } + | Just b'' <- cast b' = b == b'' + | otherwise = False instance Show (Storage' c) where - show st@(Storage { stBacking = StorageDir { dirPath = path }}) = "dir" ++ showParentStorage st ++ ":" ++ path - show st@(Storage { stBacking = StorageMemory {} }) = "mem" ++ showParentStorage st - -showParentStorage :: Storage' c -> String -showParentStorage Storage { stParent = Nothing } = "" -showParentStorage Storage { stParent = Just st } = "@" ++ show st - -data StorageBacking c - = StorageDir { dirPath :: FilePath - , dirWatchers :: MVar ( Maybe WatchManager, [ HeadTypeID ], WatchList c ) - } - | StorageMemory { memHeads :: MVar [((HeadTypeID, HeadID), Ref' c)] - , memObjs :: MVar (Map RefDigest BL.ByteString) - , memKeys :: MVar (Map RefDigest ScrubbedBytes) - , memWatchers :: MVar (WatchList c) - } - deriving (Eq) + show Storage { stBackend = b } = show b ++ showParentStorage b + +showParentStorage :: StorageBackend bck => bck -> String +showParentStorage bck + | Just (st :: Storage) <- cast (backendParent bck) = "@" ++ show st + | Just (st :: PartialStorage) <- cast (backendParent bck) = "@" ++ show st + | otherwise = "" + + +class (Eq bck, Show bck, Typeable bck, Typeable (BackendParent bck)) => StorageBackend bck where + type BackendCompleteness bck :: Type -> Type + type BackendCompleteness bck = Complete + + type BackendParent bck :: Type + type BackendParent bck = () + backendParent :: bck -> BackendParent bck + default backendParent :: BackendParent bck ~ () => bck -> BackendParent bck + backendParent _ = () + + + backendLoadBytes :: bck -> RefDigest -> IO (Maybe BL.ByteString) + default backendLoadBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe BL.ByteString) + backendLoadBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadBytes bck' + + backendStoreBytes :: bck -> RefDigest -> BL.ByteString -> IO () + default backendStoreBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> BL.ByteString -> IO () + backendStoreBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreBytes bck' + + + backendLoadHeads :: bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ] + default backendLoadHeads :: BackendParent bck ~ Storage => bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ] + backendLoadHeads bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHeads bck' + + backendLoadHead :: bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest) + default backendLoadHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest) + backendLoadHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHead bck' + + backendStoreHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> IO () + default backendStoreHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> IO () + backendStoreHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreHead bck' + + backendReplaceHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest) + default backendReplaceHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest) + backendReplaceHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendReplaceHead bck' + + backendWatchHead :: bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID + default backendWatchHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID + backendWatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendWatchHead bck' + + backendUnwatchHead :: bck -> WatchID -> IO () + default backendUnwatchHead :: BackendParent bck ~ Storage => bck -> WatchID -> IO () + backendUnwatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendUnwatchHead bck' + + + backendListKeys :: bck -> IO [ RefDigest ] + default backendListKeys :: BackendParent bck ~ Storage => bck -> IO [ RefDigest ] + backendListKeys bck = case backendParent bck of Storage { stBackend = bck' } -> backendListKeys bck' + + backendLoadKey :: bck -> RefDigest -> IO (Maybe ScrubbedBytes) + default backendLoadKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe ScrubbedBytes) + backendLoadKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadKey bck' + + backendStoreKey :: bck -> RefDigest -> ScrubbedBytes -> IO () + default backendStoreKey :: BackendParent bck ~ Storage => bck -> RefDigest -> ScrubbedBytes -> IO () + backendStoreKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreKey bck' + + backendRemoveKey :: bck -> RefDigest -> IO () + default backendRemoveKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO () + backendRemoveKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendRemoveKey bck' + + newtype WatchID = WatchID Int - deriving (Eq, Ord, Num) + deriving (Eq, Ord) + +startWatchID :: WatchID +startWatchID = WatchID 1 -data WatchList c = WatchList +nextWatchID :: WatchID -> WatchID +nextWatchID (WatchID n) = WatchID (n + 1) + +data WatchList = WatchList { wlNext :: WatchID - , wlList :: [WatchListItem c] + , wlList :: [ WatchListItem ] } -data WatchListItem c = WatchListItem +data WatchListItem = WatchListItem { wlID :: WatchID - , wlHead :: (HeadTypeID, HeadID) - , wlFun :: Ref' c -> IO () + , wlHead :: ( HeadTypeID, HeadID ) + , wlFun :: RefDigest -> IO () } +watchListAdd :: HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> WatchList -> ( WatchList, WatchID ) +watchListAdd tid hid cb wl = ( wl', wlNext wl ) + where + wl' = wl + { wlNext = nextWatchID (wlNext wl) + , wlList = WatchListItem + { wlID = wlNext wl + , wlHead = (tid, hid) + , wlFun = cb + } : wlList wl + } + +watchListDel :: WatchID -> WatchList -> WatchList +watchListDel wid wl = wl { wlList = filter ((/= wid) . wlID) $ wlList wl } + newtype RefDigest = RefDigest (Digest Blake2b_256) deriving (Eq, Ord, NFData, ByteArrayAccess) @@ -92,6 +159,9 @@ instance Show RefDigest where data Ref' c = Ref (Storage' c) RefDigest +type Ref = Ref' Complete +type PartialRef = Ref' Partial + instance Eq (Ref' c) where Ref _ d1 == Ref _ d2 = d1 == d2 @@ -183,7 +253,7 @@ storedStorage (Stored (Ref st _) _) = st 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) @@ -200,71 +270,16 @@ instance StorageCompleteness Partial where ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c) -unsafeStoreRawBytes st raw = do - let dgst = hashToRefDigest raw - case stBacking st of - StorageDir { dirPath = sdir } -> writeFileOnce (refPath sdir dgst) $ compress raw - StorageMemory { memObjs = tobjs } -> - dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written - modifyMVar_ tobjs (return . M.insert dgst raw) +unsafeStoreRawBytes st@Storage {..} raw = do + dgst <- evaluate $ force $ hashToRefDigest raw + backendStoreBytes stBackend dgst raw return $ Ref st dgst ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString) -ioLoadBytesFromStorage st dgst = loadCurrent st >>= - \case Just bytes -> return $ Just bytes - Nothing | Just parent <- stParent st -> ioLoadBytesFromStorage parent dgst - | otherwise -> return Nothing - where loadCurrent Storage { stBacking = StorageDir { dirPath = spath } } = handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ - Just . decompress . BL.fromChunks . (:[]) <$> (B.readFile $ refPath spath dgst) - loadCurrent Storage { stBacking = StorageMemory { memObjs = tobjs } } = M.lookup dgst <$> readMVar tobjs - -refPath :: FilePath -> RefDigest -> FilePath -refPath spath rdgst = intercalate "/" [spath, "objects", BC.unpack alg, pref, rest] - where (alg, dgst) = showRefDigestParts rdgst - (pref, rest) = splitAt 2 $ BC.unpack dgst - - -openLockFile :: FilePath -> IO Handle -openLockFile path = do - createDirectoryIfMissing True (takeDirectory path) - retry 10 $ createFileExclusive path - where - retry :: Int -> IO a -> IO a - retry 0 act = act - retry n act = catchJust (\e -> if isAlreadyExistsError e then Just () else Nothing) - act (\_ -> threadDelay (100 * 1000) >> retry (n - 1) act) - -writeFileOnce :: FilePath -> BL.ByteString -> IO () -writeFileOnce file content = bracket (openLockFile locked) - hClose $ \h -> do - doesFileExist file >>= \case - True -> removeFile locked - False -> do BL.hPut h content - hClose h - renameFile locked file - where locked = file ++ ".lock" - -writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ()) -writeFileChecked file prev content = bracket (openLockFile locked) - hClose $ \h -> do - (prev,) <$> doesFileExist file >>= \case - (Nothing, True) -> do - current <- B.readFile file - removeFile locked - return $ Left $ Just current - (Nothing, False) -> do B.hPut h content - hClose h - renameFile locked file - return $ Right () - (Just expected, True) -> do - current <- B.readFile file - if current == expected then do B.hPut h content - hClose h - renameFile locked file - return $ return () - else do removeFile locked - return $ Left $ Just current - (Just _, False) -> do - removeFile locked - return $ Left Nothing - where locked = file ++ ".lock" +ioLoadBytesFromStorage Storage {..} dgst = + backendLoadBytes stBackend dgst >>= \case + Just bytes -> return $ Just bytes + Nothing + | Just (parent :: Storage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst + | Just (parent :: PartialStorage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst + | otherwise -> return Nothing diff --git a/src/Erebos/Storage/Key.hs b/src/Erebos/Storage/Key.hs index 626d684..b615f16 100644 --- a/src/Erebos/Storage/Key.hs +++ b/src/Erebos/Storage/Key.hs @@ -4,19 +4,12 @@ module Erebos.Storage.Key ( moveKeys, ) where -import Control.Concurrent.MVar import Control.Monad import Control.Monad.Except import Control.Monad.IO.Class import Data.ByteArray -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map as M - -import System.Directory -import System.FilePath -import System.IO.Error +import Data.Typeable import Erebos.Storable import Erebos.Storage.Internal @@ -28,59 +21,32 @@ class Storable pub => KeyPair sec pub | sec -> pub, pub -> sec where keyFromData :: ScrubbedBytes -> Stored pub -> Maybe sec -keyFilePath :: KeyPair sec pub => FilePath -> Stored pub -> FilePath -keyFilePath sdir pkey = sdir </> "keys" </> (BC.unpack $ showRef $ storedRef pkey) - storeKey :: KeyPair sec pub => sec -> IO () storeKey key = do let spub = keyGetPublic key - case stBacking $ storedStorage spub of - StorageDir { dirPath = dir } -> writeFileOnce (keyFilePath dir spub) (BL.fromStrict $ convert $ keyGetData key) - StorageMemory { memKeys = kstore } -> modifyMVar_ kstore $ return . M.insert (refDigest $ storedRef spub) (keyGetData key) + case storedStorage spub of + Storage {..} -> backendStoreKey stBackend (refDigest $ storedRef spub) (keyGetData key) -loadKey :: (KeyPair sec pub, MonadIO m, MonadError String m) => Stored pub -> m sec -loadKey pub = maybe (throwError $ "secret key not found for " <> show (storedRef pub)) return =<< loadKeyMb pub +loadKey :: (KeyPair sec pub, MonadIO m, MonadError e m, FromErebosError e) => Stored pub -> m sec +loadKey pub = maybe (throwOtherError $ "secret key not found for " <> show (storedRef pub)) return =<< loadKeyMb pub -loadKeyMb :: (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec) +loadKeyMb :: forall sec pub m. (KeyPair sec pub, MonadIO m) => Stored pub -> m (Maybe sec) loadKeyMb spub = liftIO $ run $ storedStorage spub where - run st = tryOneLevel (stBacking st) >>= \case - key@Just {} -> return key - Nothing | Just parent <- stParent st -> run parent - | otherwise -> return Nothing - tryOneLevel = \case - StorageDir { dirPath = dir } -> tryIOError (BC.readFile (keyFilePath dir spub)) >>= \case - Right kdata -> return $ keyFromData (convert kdata) spub - Left _ -> return Nothing - StorageMemory { memKeys = kstore } -> (flip keyFromData spub <=< M.lookup (refDigest $ storedRef spub)) <$> readMVar kstore + run :: Storage' c -> IO (Maybe sec) + run Storage {..} = backendLoadKey stBackend (refDigest $ storedRef spub) >>= \case + Just bytes -> return $ keyFromData bytes spub + Nothing + | Just (parent :: Storage) <- cast (backendParent stBackend) -> run parent + | Just (parent :: PartialStorage) <- cast (backendParent stBackend) -> run parent + | otherwise -> return Nothing moveKeys :: MonadIO m => Storage -> Storage -> m () -moveKeys from to = liftIO $ do - case (stBacking from, stBacking to) of - (StorageDir { dirPath = fromPath }, StorageDir { dirPath = toPath }) -> do - files <- listDirectory (fromPath </> "keys") - forM_ files $ \file -> do - renameFile (fromPath </> "keys" </> file) (toPath </> "keys" </> file) - - (StorageDir { dirPath = fromPath }, StorageMemory { memKeys = toKeys }) -> do - let move m file - | Just dgst <- readRefDigest (BC.pack file) = do - let path = fromPath </> "keys" </> file - key <- convert <$> BC.readFile path - removeFile path - return $ M.insert dgst key m - | otherwise = return m - files <- listDirectory (fromPath </> "keys") - modifyMVar_ toKeys $ \keys -> foldM move keys files - - (StorageMemory { memKeys = fromKeys }, StorageDir { dirPath = toPath }) -> do - modifyMVar_ fromKeys $ \keys -> do - forM_ (M.assocs keys) $ \(dgst, key) -> - writeFileOnce (toPath </> "keys" </> (BC.unpack $ showRefDigest dgst)) (BL.fromStrict $ convert key) - return M.empty - - (StorageMemory { memKeys = fromKeys }, StorageMemory { memKeys = toKeys }) -> do - when (fromKeys /= toKeys) $ do - modifyMVar_ fromKeys $ \fkeys -> do - modifyMVar_ toKeys $ return . M.union fkeys - return M.empty +moveKeys Storage { stBackend = from } Storage { stBackend = to } = liftIO $ do + keys <- backendListKeys from + forM_ keys $ \key -> do + backendLoadKey from key >>= \case + Just sec -> do + backendStoreKey to key sec + backendRemoveKey from key + Nothing -> return () diff --git a/src/Erebos/Storage/Memory.hs b/src/Erebos/Storage/Memory.hs new file mode 100644 index 0000000..677e8c5 --- /dev/null +++ b/src/Erebos/Storage/Memory.hs @@ -0,0 +1,101 @@ +module Erebos.Storage.Memory ( + memoryStorage, + deriveEphemeralStorage, + derivePartialStorage, +) where + +import Control.Concurrent.MVar + +import Data.ByteArray (ScrubbedBytes) +import Data.ByteString.Lazy qualified as BL +import Data.Function +import Data.Kind +import Data.List +import Data.Map (Map) +import Data.Map qualified as M +import Data.Maybe +import Data.Typeable + +import Erebos.Object +import Erebos.Storage.Backend +import Erebos.Storage.Head +import Erebos.Storage.Internal + + +data MemoryStorage p (c :: Type -> Type) = StorageMemory + { memParent :: p + , memHeads :: MVar [ (( HeadTypeID, HeadID ), RefDigest ) ] + , memObjs :: MVar (Map RefDigest BL.ByteString) + , memKeys :: MVar (Map RefDigest ScrubbedBytes) + , memWatchers :: MVar WatchList + } + +instance Eq (MemoryStorage p c) where + (==) = (==) `on` memObjs + +instance Show (MemoryStorage p c) where + show StorageMemory {} = "mem" + +instance (StorageCompleteness c, Typeable p) => StorageBackend (MemoryStorage p c) where + type BackendCompleteness (MemoryStorage p c) = c + type BackendParent (MemoryStorage p c) = p + backendParent = memParent + + backendLoadBytes StorageMemory {..} dgst = + M.lookup dgst <$> readMVar memObjs + + backendStoreBytes StorageMemory {..} dgst raw = + modifyMVar_ memObjs (return . M.insert dgst raw) + + + backendLoadHeads StorageMemory {..} tid = do + let toRes ( ( tid', hid ), dgst ) + | tid' == tid = Just ( hid, dgst ) + | otherwise = Nothing + catMaybes . map toRes <$> readMVar memHeads + + backendLoadHead StorageMemory {..} tid hid = + lookup (tid, hid) <$> readMVar memHeads + + backendStoreHead StorageMemory {..} tid hid dgst = + modifyMVar_ memHeads $ return . (( ( tid, hid ), dgst ) :) + + backendReplaceHead StorageMemory {..} tid hid expected new = do + res <- modifyMVar memHeads $ \hs -> do + ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar memWatchers + return $ case partition ((==(tid, hid)) . fst) hs of + ( [] , _ ) -> ( hs, Left Nothing ) + (( _, dgst ) : _, hs' ) + | dgst == expected -> ((( tid, hid ), new ) : hs', Right ( new, ws )) + | otherwise -> ( hs, Left $ Just dgst ) + case res of + Right ( dgst, ws ) -> mapM_ ($ dgst) ws >> return (Right dgst) + Left x -> return $ Left x + + backendWatchHead StorageMemory {..} tid hid cb = modifyMVar memWatchers $ return . watchListAdd tid hid cb + + backendUnwatchHead StorageMemory {..} wid = modifyMVar_ memWatchers $ return . watchListDel wid + + + backendListKeys StorageMemory {..} = M.keys <$> readMVar memKeys + backendLoadKey StorageMemory {..} dgst = M.lookup dgst <$> readMVar memKeys + backendStoreKey StorageMemory {..} dgst key = modifyMVar_ memKeys $ return . M.insert dgst key + backendRemoveKey StorageMemory {..} dgst = modifyMVar_ memKeys $ return . M.delete dgst + + +memoryStorage' :: (StorageCompleteness c, Typeable p) => p -> IO (Storage' c) +memoryStorage' memParent = do + memHeads <- newMVar [] + memObjs <- newMVar M.empty + memKeys <- newMVar M.empty + memWatchers <- newMVar (WatchList startWatchID []) + newStorage $ StorageMemory {..} + +memoryStorage :: IO Storage +memoryStorage = memoryStorage' () + +deriveEphemeralStorage :: Storage -> IO Storage +deriveEphemeralStorage parent = memoryStorage' parent + +derivePartialStorage :: Storage -> IO PartialStorage +derivePartialStorage parent = memoryStorage' parent diff --git a/test/attach.test b/test/attach.test index 33a1483..afbdd0e 100644 --- a/test/attach.test +++ b/test/attach.test @@ -1,12 +1,14 @@ test: + let services = "attach,sync" + spawn as p1 spawn as p2 send "create-identity Device1 Owner" to p1 send "create-identity Device2" to p2 send "watch-local-identity" to p1 send "watch-local-identity" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /local-identity Device1 Owner/ /peer 1 addr ${p2.node.ip} 29665/ diff --git a/test/chatroom.test b/test/chatroom.test index 4dda21e..54f9b2a 100644 --- a/test/chatroom.test +++ b/test/chatroom.test @@ -1,4 +1,8 @@ +def refpat = /blake2#[0-9a-f]+/ + test ChatroomSetup: + let services = "chatroom" + # Local chatrooms spawn as p1 @@ -30,7 +34,7 @@ test ChatroomSetup: for p in [ p1, p2, p3 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" for p in [ p2, p3 ]: with p: @@ -97,6 +101,8 @@ test ChatroomSetup: test ChatroomMessages: + let services = "chatroom" + spawn as p1 spawn as p2 @@ -106,7 +112,7 @@ test ChatroomMessages: for p in [ p1, p2 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" send "chatroom-create first_room" to p1 expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 @@ -159,7 +165,7 @@ test ChatroomMessages: spawn as p3 send "create-identity Device3 Owner3" to p3 send "chatroom-watch-local" to p3 - send "start-server" to p3 + send "start-server services $services" to p3 expect /chatroom-watched-added ([a-z0-9#]+) first_room sub false/ from p3 capture room1_p3 expect /chatroom-watched-added ([a-z0-9#]+) second_room sub false/ from p3 capture room2_p3 expect /chatroom-watched-added ([a-z0-9#]+) third_room sub false/ from p3 capture room3_p3 @@ -242,6 +248,8 @@ test ChatroomMessages: test ChatroomSubscribedBeforeStart: + let services = "chatroom" + spawn as p1 spawn as p2 @@ -251,7 +259,7 @@ test ChatroomSubscribedBeforeStart: for p in [ p1, p2 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" send "chatroom-create first_room" to p1 expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 @@ -271,7 +279,7 @@ test ChatroomSubscribedBeforeStart: expect /stop-server-done/ for p in [p1, p2]: with p: - send "start-server" + send "start-server services $services" send "chatroom-message-send $room1_p1 message1" to p1 expect /chatroom-message-new $room1_p1 room first_room from Owner1 text message1/ from p1 @@ -283,6 +291,8 @@ test ChatroomSubscribedBeforeStart: test ParallelThreads: + let services = "chatroom" + spawn as p1 spawn as p2 @@ -292,7 +302,7 @@ test ParallelThreads: for p in [ p1, p2 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" send "chatroom-create first_room" to p1 expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 @@ -330,7 +340,7 @@ test ParallelThreads: for p in [p1, p2]: with p: - send "start-server" + send "start-server services $services" with p1: expect /chatroom-message-new $room1_p1 room first_room from Owner. text message(..)/ capture msg @@ -347,6 +357,8 @@ test ParallelThreads: test ChatroomMembers: + let services = "chatroom" + spawn as p1 spawn as p2 spawn as p3 @@ -358,7 +370,7 @@ test ChatroomMembers: for p in [ p1, p2, p3 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" send "chatroom-create first_room" to p1 expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 @@ -432,6 +444,8 @@ test ChatroomMembers: test ChatroomIdentity: + let services = "chatroom" + spawn as p1 spawn as p2 @@ -441,7 +455,7 @@ test ChatroomIdentity: for p in [ p1, p2 ]: with p: send "chatroom-watch-local" - send "start-server" + send "start-server services $services" send "chatroom-create first_room" to p1 expect /chatroom-create-done ([a-z0-9#]+) first_room.*/ from p1 capture room1_p1 @@ -477,3 +491,172 @@ test ChatroomIdentity: guard (name1 == "Custom1") expect /chatroom-message-new [a-z0-9#]+ room first_room from ([^ ]+) text message4/ capture name2 guard (name2 == "Custom2") + + +test ChatroomDelete: + let services = "chatroom" + + node n1 + node n2 + node n3 + + # Create and sync chatrooms on n1 and sync to n2 + local: + spawn as p1 on n1 + with p1: + send "create-identity Device1 Owner1" + expect /create-identity-done .*/ + + send "chatroom-watch-local" + send "start-server services $services" + + send "chatroom-create first" + send "chatroom-create second" + expect /chatroom-create-done $refpat first.*/ + expect /chatroom-create-done $refpat second.*/ + + + spawn as p2 on n2 + with p2: + send "create-identity Device2 Owner2" + expect /create-identity-done .*/ + + send "chatroom-watch-local" + send "start-server services $services" + + expect /chatroom-watched-added ($refpat) first sub false/ capture first + expect /chatroom-watched-added ($refpat) second sub false/ capture second + + send "chatroom-subscribe $first" + send "chatroom-subscribe $second" + expect /chatroom-watched-updated $first first sub true .*/ + expect /chatroom-watched-updated $second second sub true .*/ + + local: + spawn as p3 on n3 + with p3: + send "create-identity Device3 Owner3" + expect /create-identity-done .*/ + + local: + spawn as p1 on n1 + spawn as p2 on n2 + spawn as p3 on n3 + + # Delete first chatroom from n1 + with p1: + send "chatroom-watch-local" + send "start-server services $services" + + send "chatroom-list-local" + expect /chatroom-list-item ($refpat) first sub true/ capture first + expect /chatroom-list-item $refpat second sub true/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + send "chatroom-delete $first" + expect /chatroom-delete-done .*/ + + # Setup n3 + with p3: + send "chatroom-watch-local" + send "start-server services $services" + + expect /chatroom-watched-added $refpat second sub false/ + + # Check that both n1 and n3 see only the second chatroom + for p in [ p1, p3 ]: + with p: + send "chatroom-list-local" + expect /chatroom-list-item $refpat second .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + # Reactive server on n2 and create third chatroom + with p2: + send "chatroom-watch-local" + send "start-server services $services" + + send "chatroom-create third" + expect /chatroom-create-done $refpat third.*/ + + # Verify that first chatroom appears only on n3 ... + with p3: + expect /chatroom-watched-added $refpat first sub false/ + expect /chatroom-watched-added $refpat third sub false/ + + send "chatroom-list-local" + expect /chatroom-list-item $refpat first .*/ + expect /chatroom-list-item $refpat second .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + # ... and not on n1 + with p1: + expect /chatroom-watched-added ($refpat) third sub false/ capture third + send "chatroom-subscribe $third" + expect /chatroom-watched-updated $third third sub true .*/ + + send "chatroom-list-local" + expect /chatroom-list-item $refpat second .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + # Delete second chatroom on n2 + with p2: + send "chatroom-list-local" + expect /chatroom-list-item $refpat first .*/ + expect /chatroom-list-item ($refpat) second .*/ capture second + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + send "chatroom-delete $second" + expect /chatroom-delete-done .*/ + + # Send messages + with p3: + send "chatroom-list-local" + expect /chatroom-list-item ($refpat) first .*/ capture first + expect /chatroom-list-item ($refpat) second .*/ capture second + expect /chatroom-list-item ($refpat) third .*/ capture third + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + + send "chatroom-message-send $first message_first" + send "chatroom-message-send $second message_second" + send "chatroom-message-send $third message_third" + + # Receive only to non-deleted ones + with p1: + expect /chatroom-message-new $refpat room second from Owner3 text message_second/ + expect /chatroom-message-new $refpat room ([a-z]+) from Owner3 text ([a-z_]+)/ capture room, msg + guard (room == "third") + guard (msg == "message_third") + + send "chatroom-list-local" + expect /chatroom-list-item $refpat second .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") + with p2: + expect /chatroom-message-new $refpat room first from Owner3 text message_first/ + expect /chatroom-message-new $refpat room ([a-z]+) from Owner3 text ([a-z_]+)/ capture room, msg + guard (room == "third") + guard (msg == "message_third") + + send "chatroom-list-local" + expect /chatroom-list-item $refpat first .*/ + expect /chatroom-list-item $refpat third .*/ + local: + expect /chatroom-list-(.*)/ capture done + guard (done == "done") diff --git a/test/contact.test b/test/contact.test index 438aa1f..978f8a6 100644 --- a/test/contact.test +++ b/test/contact.test @@ -1,4 +1,6 @@ test Contact: + let services = "attach,contact,sync" + spawn as p1 spawn as p2 spawn as p3 @@ -9,10 +11,10 @@ test Contact: send "create-identity Device3 Owner3" to p3 send "create-identity Device4" to p4 - send "start-server" to p1 - send "start-server" to p2 - send "start-server" to p3 - send "start-server" to p4 + send "start-server services $services" to p1 + send "start-server services $services" to p2 + send "start-server services $services" to p3 + send "start-server services $services" to p4 expect from p1: /peer ([0-9]+) addr ${p2.node.ip} 29665/ capture peer1_2 diff --git a/test/discovery.test b/test/discovery.test new file mode 100644 index 0000000..f2dddb7 --- /dev/null +++ b/test/discovery.test @@ -0,0 +1,75 @@ +module discovery + +test ManualDiscovery: + let services = "discovery,test" + let refpat = /blake2#[0-9a-f]*/ + + subnet sd + subnet s1 + subnet s2 + + spawn as pd on sd + spawn as p1 on s1 + spawn as p2 on s2 + send "create-identity Discovery" to pd + send "create-identity Device1 Owner1" to p1 + send "create-identity Device2 Owner2" to p2 + + expect /create-identity-done ref ($refpat).*/ from p1 capture p1id + send "identity-info $p1id" to p1 + expect /identity-info ref $p1id base ($refpat) owner ($refpat).*/ from p1 capture p1base, p1owner + send "identity-info $p1owner" to p1 + expect /identity-info ref $p1owner base ($refpat).*/ from p1 capture p1obase + + expect /create-identity-done ref $refpat.*/ from p2 + expect /create-identity-done ref $refpat.*/ from pd + + # TODO: avoid the need to send identity objects with weak refs + for p in [ p1, p2 ]: + with p: + send "start-server services $services" + send "peer-add ${p2.node.ip}" to p1 + expect from p1: + /peer 1 addr ${p2.node.ip} 29665/ + /peer 1 id Device2 Owner2/ + expect from p2: + /peer 1 addr ${p1.node.ip} 29665/ + /peer 1 id Device1 Owner1/ + for r in [ p1base, p1obase ]: + with p1: + send "test-message-send 1 $r" + expect /test-message-send done/ + with p2: + expect /test-message-received rec [0-9]+ $r/ + for p in [ p1, p2 ]: + send "stop-server" to p + expect /stop-server-done/ from p + + # Test discovery using owner and device identities: + for id in [ p1obase, p1base ]: + for p in [ pd, p1, p2 ]: + send "start-server services $services" to p + + for p in [ p1, p2 ]: + with p: + send "peer-add ${pd.node.ip}" + expect: + /peer 1 addr ${pd.node.ip} 29665/ + /peer 1 id Discovery/ + expect from pd: + /peer [12] addr ${p.node.ip} 29665/ + /peer [12] id .*/ + + send "discovery-connect $id" to p2 + + expect from p1: + /peer [0-9]+ addr ${p2.node.ip} 29665/ + /peer [0-9]+ id Device2 Owner2/ + expect from p2: + /peer [0-9]+ addr ${p1.node.ip} 29665/ + /peer [0-9]+ id Device1 Owner1/ + + for p in [ pd, p1, p2 ]: + send "stop-server" to p + for p in [ pd, p1, p2 ]: + expect /stop-server-done/ from p diff --git a/test/message.test b/test/message.test index 307f11a..c0e251b 100644 --- a/test/message.test +++ b/test/message.test @@ -1,10 +1,12 @@ test DirectMessage: + let services = "contact,dm" + spawn as p1 spawn as p2 send "create-identity Device1 Owner1" to p1 send "create-identity Device2 Owner2" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /peer ([0-9]+) addr ${p2.node.ip} 29665/ capture peer1_2 @@ -96,7 +98,7 @@ test DirectMessage: expect /stop-server-done/ for p in [p1, p2]: with p: - send "start-server" + send "start-server services $services" with p1: send "contact-list" @@ -126,10 +128,10 @@ test DirectMessage: for p in [p1, p2]: with p: expect /stop-server-done/ - send "start-server" to p2 + send "start-server services $services" to p2 send "dm-send-contact $c1_2 while_offline" to p1 - send "start-server" to p1 + send "start-server services $services" to p1 expect /dm-received from Owner1 text while_offline/ from p2 @@ -139,11 +141,11 @@ test DirectMessage: for p in [p1, p2]: with p: expect /stop-server-done/ - send "start-server" to p1 + send "start-server services $services" to p1 send "dm-send-contact $c1_2 while_peer_offline" to p1 # TODO: sync from p1 on peer p2 discovery not ensured without addition wait #wait - send "start-server" to p2 + send "start-server services $services" to p2 expect /dm-received from Owner1 text while_peer_offline/ from p2 diff --git a/test/network.test b/test/network.test index 40190f4..52fcbee 100644 --- a/test/network.test +++ b/test/network.test @@ -120,12 +120,14 @@ test Discovery: test LargeData: + let services = "test" + spawn as p1 spawn as p2 send "create-identity Device1" to p1 send "create-identity Device2" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /peer 1 addr ${p2.node.ip} 29665/ /peer 1 id Device2/ @@ -149,12 +151,14 @@ test LargeData: test ManyStreams: + let services = "test" + spawn as p1 spawn as p2 send "create-identity Device1" to p1 send "create-identity Device2" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /peer 1 addr ${p2.node.ip} 29665/ /peer 1 id Device2/ @@ -179,12 +183,14 @@ test ManyStreams: test MultipleServiceRefs: + let services = "test" + spawn as p1 spawn as p2 send "create-identity Device1" to p1 send "create-identity Device2" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /peer 1 addr ${p2.node.ip} 29665/ /peer 1 id Device2/ @@ -235,16 +241,18 @@ test MultipleServiceRefs: test Reconnection: + let services = "test" + spawn as p1 with p1: send "create-identity Device1" - send "start-server" + send "start-server services $services" node n local: spawn as p2 on n send "create-identity Device2" to p2 - send "start-server" to p2 + send "start-server services $services" to p2 expect from p1: /peer 1 addr ${p2.node.ip} 29665/ @@ -272,7 +280,7 @@ test Reconnection: # Restart process on node 'n' local: spawn as p2 on n - send "start-server" to p2 + send "start-server services $services" to p2 send "peer-add ${p1.node.ip}" to p2 expect from p2: @@ -383,6 +391,7 @@ test Reconnection: test SendUnknownObjectType: + let services = "test" let refpat = /blake2#[0-9a-f]*/ spawn as p1 @@ -390,10 +399,10 @@ test SendUnknownObjectType: with p1: send "create-identity Device1" - send "start-server" + send "start-server services $services" with p2: send "create-identity Device2" - send "start-server" + send "start-server services $services" expect from p1: /peer 1 addr ${p2.node.ip} 29665/ diff --git a/test/storage.test b/test/storage.test index db9e0a1..a5cca7f 100644 --- a/test/storage.test +++ b/test/storage.test @@ -381,14 +381,16 @@ test StorageWatcher: test SharedStateWatcher: + let services = "attach,sync" + spawn as p1 spawn as p2 send "create-identity Device1 Owner" to p1 send "create-identity Device2" to p2 send "watch-local-identity" to p1 send "watch-local-identity" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /local-identity Device1 Owner/ /peer 1 addr ${p2.node.ip} 29665/ diff --git a/test/sync.test b/test/sync.test index ea9595d..d465b11 100644 --- a/test/sync.test +++ b/test/sync.test @@ -1,4 +1,6 @@ test: + let services = "attach,sync" + spawn as p1 spawn as p2 send "create-identity Device1 Owner" to p1 @@ -7,8 +9,8 @@ test: send "watch-local-identity" to p2 send "watch-shared-identity" to p1 send "watch-shared-identity" to p2 - send "start-server" to p1 - send "start-server" to p2 + send "start-server services $services" to p1 + send "start-server services $services" to p2 expect from p1: /local-identity Device1 Owner/ /shared-identity Owner/ @@ -57,7 +59,7 @@ test: send "create-identity Device3" send "watch-local-identity" send "watch-shared-identity" - send "start-server" + send "start-server services $services" send "peer-add ${p1.node.ip}" |