diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Attach.hs | 8 | ||||
| -rw-r--r-- | src/Identity.hs | 94 | ||||
| -rw-r--r-- | src/Main.hs | 49 | ||||
| -rw-r--r-- | src/Message.hs | 19 | ||||
| -rw-r--r-- | src/Message/Service.hs | 9 | ||||
| -rw-r--r-- | src/Network.hs | 102 | ||||
| -rw-r--r-- | src/PubKey.hs | 4 | ||||
| -rw-r--r-- | src/Service.hs | 3 | ||||
| -rw-r--r-- | src/State.hs | 34 | ||||
| -rw-r--r-- | src/Storage.hs | 10 | ||||
| -rw-r--r-- | src/Storage/Internal.hs | 9 | ||||
| -rw-r--r-- | src/Storage/Merge.hs | 40 |
12 files changed, 253 insertions, 128 deletions
diff --git a/src/Attach.hs b/src/Attach.hs index bf4d61e..9861f15 100644 --- a/src/Attach.hs +++ b/src/Attach.hs @@ -87,7 +87,7 @@ instance Service AttachService where (OurRequest nonce, AttachResponse pnonce) -> do peer <- asks $ svcPeer self <- maybe (throwError "failed to verify own identity") return =<< - gets (verifyIdentity . lsIdentity . fromStored . svcLocal) + gets (validateIdentity . lsIdentity . fromStored . svcLocal) svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest self peer nonce pnonce) svcSet $ OurRequestConfirm Nothing return $ Just $ AttachRequestNonce nonce @@ -127,7 +127,7 @@ instance Service AttachService where (PeerRequest nonce dgst, AttachRequestNonce pnonce) -> do peer <- asks $ svcPeer self <- maybe (throwError "failed to verify own identity") return =<< - gets (verifyIdentity . lsIdentity . fromStored . svcLocal) + gets (validateIdentity . lsIdentity . fromStored . svcLocal) if dgst == nonceDigest peer self pnonce BA.empty then do svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest peer self pnonce nonce) svcSet PeerRequestConfirm @@ -209,7 +209,7 @@ verifyAttachedIdentity sdata = do return $ do guard $ iddKeyIdentity (fromStored $ signedData $ fromStored sdata) == iddKeyIdentity (fromStored $ signedData $ fromStored curid) - identity <- verifyIdentity sdata' + identity <- validateIdentity sdata' guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid] return identity @@ -224,7 +224,7 @@ finalizeAttach st identity skeys = do mshared <- mergeSharedStates (lsShared $ fromStored slocal) shared <- wrappedStore st $ (fromStored mshared) { ssPrev = lsShared $ fromStored slocal - , ssIdentity = [idData owner] + , ssIdentity = idDataF owner } wrappedStore st (fromStored slocal) { lsIdentity = idData identity diff --git a/src/Identity.hs b/src/Identity.hs index 5a7f8fc..ce987b2 100644 --- a/src/Identity.hs +++ b/src/Identity.hs @@ -2,17 +2,22 @@ module Identity ( Identity, ComposedIdentity, UnifiedIdentity, IdentityData(..), - idData, idDataF, idName, idOwner, idKeyIdentity, idKeyMessage, + idData, idDataF, idName, idOwner, idUpdates, idKeyIdentity, idKeyMessage, emptyIdentityData, - verifyIdentity, verifyIdentityF, - mergeIdentity, toComposedIdentity, + validateIdentity, validateIdentityF, + loadIdentity, + + mergeIdentity, toUnifiedIdentity, toComposedIdentity, + updateIdentity, updateOwners, + sameIdentity, finalOwner, displayIdentity, ) where import Control.Monad +import Control.Monad.Except import qualified Control.Monad.Identity as I import Data.Foldable @@ -27,11 +32,13 @@ import qualified Data.Text as T import PubKey import Storage +import Storage.Merge data Identity m = Identity { idData_ :: m (Stored (Signed IdentityData)) , idName_ :: Maybe Text - , idOwner_ :: Maybe UnifiedIdentity + , idOwner_ :: Maybe ComposedIdentity + , idUpdates_ :: [Stored (Signed IdentityData)] , idKeyIdentity_ :: Stored PublicKey , idKeyMessage_ :: Stored PublicKey } @@ -55,14 +62,14 @@ data IdentityData = IdentityData instance Storable IdentityData where store' idt = storeRec $ do - mapM_ (storeRef "PREV") $ iddPrev idt + mapM_ (storeRef "SPREV") $ iddPrev idt storeMbText "name" $ iddName idt storeMbRef "owner" $ iddOwner idt storeRef "key-id" $ iddKeyIdentity idt storeMbRef "key-msg" $ iddKeyMessage idt load' = loadRec $ IdentityData - <$> loadRefs "PREV" + <$> loadRefs "SPREV" <*> loadMbText "name" <*> loadMbRef "owner" <*> loadRef "key-id" @@ -77,9 +84,12 @@ idDataF = idData_ idName :: Identity m -> Maybe Text idName = idName_ -idOwner :: Identity m -> Maybe UnifiedIdentity +idOwner :: Identity m -> Maybe ComposedIdentity idOwner = idOwner_ +idUpdates :: Identity m -> [Stored (Signed IdentityData)] +idUpdates = idUpdates_ + idKeyIdentity :: Identity m -> Stored PublicKey idKeyIdentity = idKeyIdentity_ @@ -96,11 +106,11 @@ emptyIdentityData key = IdentityData , iddKeyMessage = Nothing } -verifyIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity -verifyIdentity = verifyIdentityF . I.Identity +validateIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity +validateIdentity = validateIdentityF . I.Identity -verifyIdentityF :: Foldable m => m (Stored (Signed IdentityData)) -> Maybe (Identity m) -verifyIdentityF mdata = do +validateIdentityF :: Foldable m => m (Stored (Signed IdentityData)) -> Maybe (Identity m) +validateIdentityF mdata = do let idata = toList mdata -- TODO: eliminate ancestors guard $ not $ null idata mapM_ verifySignatures $ gatherPrevious S.empty idata @@ -109,10 +119,15 @@ verifyIdentityF mdata = do <*> pure (lookupProperty iddName idata) <*> case lookupProperty iddOwner idata of Nothing -> return Nothing - Just owner -> Just <$> verifyIdentity owner + Just owner -> Just <$> validateIdentityF [owner] + <*> pure [] <*> pure (iddKeyIdentity $ fromStored $ signedData $ fromStored $ minimum idata) <*> lookupProperty iddKeyMessage idata +loadIdentity :: String -> LoadRec ComposedIdentity +loadIdentity name = maybe (throwError "identity validation failed") return . validateIdentityF =<< loadRefs name + + gatherPrevious :: Set (Stored (Signed IdentityData)) -> [Stored (Signed IdentityData)] -> Set (Stored (Signed IdentityData)) gatherPrevious res (n:ns) | n `S.member` res = gatherPrevious res ns | otherwise = gatherPrevious (S.insert n res) $ (iddPrev $ fromStored $ signedData $ fromStored n) ++ ns @@ -138,11 +153,7 @@ lookupProperty sel topHeads = findResult filteredLayers propHeads = findPropHeads =<< topHeads historyLayers :: [Set (Stored (Signed IdentityData))] - historyLayers = flip unfoldr (map fst propHeads, S.empty) $ \(hs, cur) -> - case filter (`S.notMember` cur) $ (iddPrev . fromStored . signedData . fromStored) =<< hs of - [] -> Nothing - added -> let next = foldr S.insert cur added - in Just (next, (added, next)) + historyLayers = generations $ map fst propHeads filteredLayers :: [[(Stored (Signed IdentityData), a)]] filteredLayers = scanl (\cur obsolete -> filter ((`S.notMember` obsolete) . fst) cur) propHeads historyLayers @@ -154,28 +165,57 @@ lookupProperty sel topHeads = findResult filteredLayers findResult (_:rest) = findResult rest mergeIdentity :: Foldable m => Identity m -> IO UnifiedIdentity -mergeIdentity idt | [sdata] <- toList $ idDataF idt = return $ idt { idData_ = I.Identity sdata } +mergeIdentity idt | Just idt' <- toUnifiedIdentity idt = return idt' mergeIdentity idt = do + (owner, ownerData) <- case idOwner_ idt of + Nothing -> return (Nothing, Nothing) + Just cowner | Just owner <- toUnifiedIdentity cowner -> return (Just owner, Nothing) + | otherwise -> do owner <- mergeIdentity cowner + return (Just owner, Just $ idData owner) + (sid:_) <- return $ toList $ idDataF idt let st = storedStorage sid public = idKeyIdentity idt Just secret <- loadKey public sdata <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public) - { iddPrev = toList $ idDataF idt } - return $ idt { idData_ = I.Identity sdata } + { iddPrev = toList $ idDataF idt, iddOwner = ownerData } + return $ idt { idData_ = I.Identity sdata, idOwner_ = toComposedIdentity <$> owner } +toUnifiedIdentity :: Foldable m => Identity m -> Maybe UnifiedIdentity +toUnifiedIdentity idt + | [sdata] <- toList $ idDataF idt = Just idt { idData_ = I.Identity sdata } + | otherwise = Nothing toComposedIdentity :: Foldable m => Identity m -> ComposedIdentity -toComposedIdentity idt = idt { idData_ = toList $ idDataF idt } +toComposedIdentity idt = idt { idData_ = toList $ idDataF idt + , idOwner_ = toComposedIdentity <$> idOwner_ idt + } + + +updateIdentitySets :: Foldable m => [(Stored (Signed IdentityData), Set (Stored (Signed IdentityData)))] -> Identity m -> ComposedIdentity +updateIdentitySets updates orig@Identity { idData_ = idata } = + case validateIdentityF $ map update $ toList idata of + Just updated -> updated { idOwner_ = updateIdentitySets updates <$> idOwner_ updated } + Nothing -> toComposedIdentity orig + where update x = foldl (\y (y', set) -> if y `S.member` set then y' else y) x updates + +updateIdentity :: Foldable m => [Stored (Signed IdentityData)] -> Identity m -> ComposedIdentity +updateIdentity = updateIdentitySets . map (\u -> (u, ancestors [u])) + +updateOwners :: [Stored (Signed IdentityData)] -> Identity m -> Identity m +updateOwners updates orig@Identity { idOwner_ = Just owner, idUpdates_ = cupdates } = + orig { idOwner_ = Just $ updateIdentity updates owner, idUpdates_ = updates ++ cupdates {- TODO: eliminate ancestors -} } +updateOwners _ orig@Identity { idOwner_ = Nothing } = orig + +sameIdentity :: (Foldable m, Foldable m') => Identity m -> Identity m' -> Bool +sameIdentity x y = not $ S.null $ S.intersection (refset x) (refset y) + where refset idt = foldr S.insert (ancestors $ toList $ idDataF idt) (idDataF idt) -unfoldOwners :: (Foldable m, Applicative m) => Identity m -> [Identity m] -unfoldOwners cur = cur : case idOwner cur of - Nothing -> [] - Just owner@Identity { idData_ = I.Identity pid } -> - unfoldOwners owner { idData_ = pure pid } +unfoldOwners :: (Foldable m) => Identity m -> [ComposedIdentity] +unfoldOwners = unfoldr (fmap (\i -> (i, idOwner i))) . Just . toComposedIdentity -finalOwner :: (Foldable m, Applicative m) => Identity m -> Identity m +finalOwner :: (Foldable m, Applicative m) => Identity m -> ComposedIdentity finalOwner = last . unfoldOwners displayIdentity :: (Foldable m, Applicative m) => Identity m -> Text diff --git a/src/Main.hs b/src/Main.hs index 5ce9f86..1e8736b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -52,37 +52,38 @@ main = do forM_ (signedSignature signed) $ \sig -> do putStr $ "SIG " BC.putStrLn $ showRef $ storedRef $ sigKey $ fromStored sig - "identity" -> case verifyIdentity (wrappedLoad ref) of + "identity" -> case validateIdentity (wrappedLoad ref) of Just identity -> do - let disp idt = do + let disp :: Identity m -> IO () + disp idt = do maybe (return ()) (T.putStrLn . (T.pack "Name: " `T.append`)) $ idName idt BC.putStrLn . (BC.pack "KeyId: " `BC.append`) . showRefDigest . refDigest . storedRef $ idKeyIdentity idt BC.putStrLn . (BC.pack "KeyMsg: " `BC.append`) . showRefDigest . refDigest . storedRef $ idKeyMessage idt case idOwner idt of Nothing -> return () Just owner -> do - putStrLn $ "OWNER " ++ BC.unpack (showRefDigest $ refDigest $ storedRef $ idData owner) + mapM_ (putStrLn . ("OWNER " ++) . BC.unpack . showRefDigest . refDigest . storedRef) $ idDataF owner disp owner disp identity Nothing -> putStrLn $ "Identity verification failed" _ -> error $ "unknown object type '" ++ objtype ++ "'" - ["update-identity"] -> updateIdentity st + ["update-identity"] -> updateSharedIdentity st [bhost] -> interactiveLoop st bhost _ -> error "Expecting broadcast address" interactiveLoop :: Storage -> String -> IO () interactiveLoop st bhost = runInputT defaultSettings $ do - erebosHead <- liftIO $ loadLocalState st - outputStrLn $ T.unpack $ maybe (error "failed to verify local identity") displayIdentity $ - verifyIdentity $ lsIdentity $ fromStored $ wrappedLoad $ headRef erebosHead + origIdentity <- liftIO $ loadLocalIdentity st + outputStrLn $ T.unpack $ displayIdentity origIdentity haveTerminalUI >>= \case True -> return () False -> error "Requires terminal" extPrint <- getExternalPrint let extPrintLn str = extPrint $ str ++ "\n"; - chanPeer <- liftIO $ + chanPeer <- liftIO $ do + erebosHead <- loadLocalStateHead st startServer erebosHead extPrintLn bhost [ (T.pack "attach", SomeService (emptyServiceState :: AttachService)) , (T.pack "dmsg", SomeService (emptyServiceState :: DirectMessageService)) @@ -92,14 +93,15 @@ interactiveLoop st bhost = runInputT defaultSettings $ do void $ liftIO $ forkIO $ void $ forever $ do peer <- readChan chanPeer - let update [] = ([peer], Nothing) - update (p:ps) | peerIdentityRef p == peerIdentityRef peer = (peer : ps, Just p) - | otherwise = first (p:) $ update ps - if | PeerIdentityUnknown <- peerIdentity peer -> return () - | otherwise -> do + if | PeerIdentityFull pid <- peerIdentity peer -> do + let update [] = ([peer], Nothing) + update (p:ps) | PeerIdentityFull pid' <- peerIdentity p + , pid' `sameIdentity` pid = (peer : ps, Just p) + | otherwise = first (p:) $ update ps op <- modifyMVar peers (return . update) let shown = showPeer peer when (Just shown /= (showPeer <$> op)) $ extPrint shown + | otherwise -> return () let getInputLines prompt = do Just input <- lift $ getInputLine prompt @@ -111,8 +113,8 @@ interactiveLoop st bhost = runInputT defaultSettings $ do process cstate = do let pname = case csPeer cstate of Nothing -> "" - Just peer -> case peerOwner peer of - PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName pid + Just peer -> case peerIdentity peer of + PeerIdentityFull pid -> maybe "<unnamed>" T.unpack $ idName $ finalOwner pid PeerIdentityRef wref -> "<" ++ BC.unpack (showRefDigest $ wrDigest wref) ++ ">" PeerIdentityUnknown -> "<unknown>" input <- getInputLines $ pname ++ "> " @@ -122,10 +124,9 @@ interactiveLoop st bhost = runInputT defaultSettings $ do then (cmdSetPeer $ read scmd, args) else (fromMaybe (cmdUnknown scmd) $ lookup scmd commands, args) _ -> (cmdSend, input) - curHead <- liftIO $ loadLocalState st + curIdentity <- liftIO $ loadLocalIdentity st res <- liftIO $ runExceptT $ flip execStateT cstate $ runReaderT cmd CommandInput - { ciSelf = fromMaybe (error "failed to verify local identity") $ - verifyIdentity $ lsIdentity $ fromStored $ wrappedLoad $ headRef curHead + { ciSelf = curIdentity , ciLine = line , ciPrint = extPrintLn , ciPeers = liftIO $ readMVar peers @@ -200,10 +201,11 @@ cmdSend = void $ do self <- asks ciSelf let st = storedStorage $ idData self Just peer <- gets csPeer - PeerIdentityFull powner <- return $ peerOwner peer + PeerIdentityFull pid <- return $ peerIdentity peer + let powner = finalOwner pid :: ComposedIdentity text <- asks ciLine smsg <- liftIO $ updateLocalState st $ \erb -> do - (slist, smsg) <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of + (slist, smsg) <- case find (sameIdentity powner . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of Just thread -> do (smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text) (,smsg) <$> slistReplaceS thread thread' (lsMessages $ fromStored erb) @@ -222,18 +224,19 @@ cmdHistory = void $ do self <- asks ciSelf let st = storedStorage $ idData self Just peer <- gets csPeer - PeerIdentityFull powner <- return $ peerOwner peer + PeerIdentityFull pid <- return $ peerIdentity peer + let powner = finalOwner pid Just erebosHead <- liftIO $ loadHead st "erebos" let erebos = wrappedLoad (headRef erebosHead) - Just thread <- return $ find ((== idData powner) . msgPeer) $ fromSList $ lsMessages $ fromStored erebos + Just thread <- return $ find (sameIdentity powner . msgPeer) $ fromSList $ lsMessages $ fromStored erebos tzone <- liftIO $ getCurrentTimeZone liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread cmdUpdateIdentity :: Command cmdUpdateIdentity = void $ do st <- asks $ storedStorage . idData . ciSelf - liftIO $ updateIdentity st + liftIO $ updateSharedIdentity st cmdAttach :: Command cmdAttach = join $ attachToOwner diff --git a/src/Message.hs b/src/Message.hs index 8892edb..61d882c 100644 --- a/src/Message.hs +++ b/src/Message.hs @@ -11,56 +11,55 @@ import Data.Text (Text) import Data.Time.LocalTime import Identity -import PubKey import Storage data DirectMessage = DirectMessage - { msgFrom :: Stored (Signed IdentityData) + { msgFrom :: ComposedIdentity , msgPrev :: [Stored DirectMessage] , msgTime :: ZonedTime , msgText :: Text } data DirectMessageThread = DirectMessageThread - { msgPeer :: Stored (Signed IdentityData) + { msgPeer :: ComposedIdentity , msgHead :: [Stored DirectMessage] , msgSeen :: [Stored DirectMessage] } instance Storable DirectMessage where store' msg = storeRec $ do - storeRef "from" $ msgFrom msg + mapM_ (storeRef "from") $ idDataF $ msgFrom msg mapM_ (storeRef "prev") $ msgPrev msg storeDate "time" $ msgTime msg storeText "text" $ msgText msg load' = loadRec $ DirectMessage - <$> loadRef "from" + <$> loadIdentity "from" <*> loadRefs "prev" <*> loadDate "time" <*> loadText "text" instance Storable DirectMessageThread where store' msg = storeRec $ do - storeRef "peer" $ msgPeer msg + mapM_ (storeRef "peer") $ idDataF $ msgPeer msg mapM_ (storeRef "head") $ msgHead msg mapM_ (storeRef "seen") $ msgSeen msg load' = loadRec $ DirectMessageThread - <$> loadRef "peer" + <$> loadIdentity "peer" <*> loadRefs "head" <*> loadRefs "seen" -emptyDirectThread :: UnifiedIdentity -> DirectMessageThread -emptyDirectThread peer = DirectMessageThread (idData peer) [] [] +emptyDirectThread :: ComposedIdentity -> DirectMessageThread +emptyDirectThread peer = DirectMessageThread peer [] [] createDirectMessage :: UnifiedIdentity -> DirectMessageThread -> Text -> IO (Stored DirectMessage, Stored DirectMessageThread) createDirectMessage self thread msg = do let st = storedStorage $ idData self time <- getZonedTime smsg <- wrappedStore st DirectMessage - { msgFrom = idData $ finalOwner self + { msgFrom = toComposedIdentity $ finalOwner self , msgPrev = msgHead thread , msgTime = time , msgText = msg diff --git a/src/Message/Service.hs b/src/Message/Service.hs index 37aa3ab..3c3946d 100644 --- a/src/Message/Service.hs +++ b/src/Message/Service.hs @@ -13,7 +13,6 @@ import Data.Time.LocalTime import Identity import Message -import PubKey import Service import State import Storage @@ -25,14 +24,14 @@ instance Service DirectMessageService where emptyServiceState = DirectMessageService serviceHandler smsg = do let msg = fromStored smsg - powner <- asks svcPeerOwner + powner <- asks $ finalOwner . svcPeer tzone <- liftIO $ getCurrentTimeZone svcPrint $ formatMessage tzone msg - if | idData powner == msgFrom msg + if | powner `sameIdentity` msgFrom msg -> do erb <- gets svcLocal let st = storedStorage erb erb' <- liftIO $ do - slist <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of + slist <- case find (sameIdentity powner . msgPeer . fromStored) (storedFromSList $ lsMessages $ fromStored erb) of Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) } slistReplaceS thread thread' $ lsMessages $ fromStored erb Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ lsMessages $ fromStored erb @@ -46,7 +45,7 @@ instance Service DirectMessageService where formatMessage :: TimeZone -> DirectMessage -> String formatMessage tzone msg = concat [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg - , maybe "<unnamed>" T.unpack $ iddName $ fromStored $ signedData $ fromStored $ msgFrom msg + , maybe "<unnamed>" T.unpack $ idName $ msgFrom msg , ": " , T.unpack $ msgText msg ] diff --git a/src/Network.hs b/src/Network.hs index 0209853..b7d3c2f 100644 --- a/src/Network.hs +++ b/src/Network.hs @@ -1,7 +1,7 @@ module Network ( Peer(..), PeerAddress(..), - PeerIdentity(..), peerIdentityRef, + PeerIdentity(..), PeerChannel(..), WaitingRef, wrDigest, Service(..), @@ -17,6 +17,7 @@ import Control.Monad.State import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL +import Data.Either import qualified Data.Map as M import Data.Maybe import qualified Data.Text as T @@ -42,7 +43,7 @@ announceIntervalSeconds = 60 data Peer = Peer { peerAddress :: PeerAddress , peerIdentity :: PeerIdentity - , peerOwner :: PeerIdentity + , peerIdentityUpdate :: [WaitingRef] , peerChannel :: PeerChannel , peerSocket :: Socket , peerStorage :: Storage @@ -59,12 +60,6 @@ data PeerIdentity = PeerIdentityUnknown | PeerIdentityRef WaitingRef | PeerIdentityFull UnifiedIdentity -peerIdentityRef :: Peer -> Maybe PartialRef -peerIdentityRef peer = case peerIdentity peer of - PeerIdentityUnknown -> Nothing - PeerIdentityRef (WaitingRef _ pref _) -> Just pref - PeerIdentityFull idt -> Just $ partialRef (peerInStorage peer) $ storedRef $ idData idt - data PeerChannel = ChannelWait | ChannelOurRequest (Stored ChannelRequest) | ChannelPeerRequest WaitingRef @@ -77,6 +72,7 @@ data TransportHeaderItem | DataRequest PartialRef | DataResponse PartialRef | AnnounceSelf PartialRef + | AnnounceUpdate PartialRef | TrChannelRequest PartialRef | TrChannelAccept PartialRef | ServiceType T.Text @@ -91,6 +87,7 @@ transportToObject (TransportHeader items) = Rec $ map single items DataRequest ref -> (BC.pack "REQ", RecRef ref) DataResponse ref -> (BC.pack "RSP", RecRef ref) AnnounceSelf ref -> (BC.pack "ANN", RecRef ref) + AnnounceUpdate ref -> (BC.pack "ANU", RecRef ref) TrChannelRequest ref -> (BC.pack "CRQ", RecRef ref) TrChannelAccept ref -> (BC.pack "CAC", RecRef ref) ServiceType stype -> (BC.pack "STP", RecText stype) @@ -105,6 +102,7 @@ transportFromObject (Rec items) = case catMaybes $ map single items of | name == BC.pack "REQ", RecRef ref <- content -> Just $ DataRequest ref | name == BC.pack "RSP", RecRef ref <- content -> Just $ DataResponse ref | name == BC.pack "ANN", RecRef ref <- content -> Just $ AnnounceSelf ref + | name == BC.pack "ANU", RecRef ref <- content -> Just $ AnnounceUpdate ref | name == BC.pack "CRQ", RecRef ref <- content -> Just $ TrChannelRequest ref | name == BC.pack "CAC", RecRef ref <- content -> Just $ TrChannelAccept ref | name == BC.pack "STP", RecText stype <- content -> Just $ ServiceType stype @@ -160,10 +158,7 @@ startServer origHead logd bhost services = do chanPeer <- newChan chanSvc <- newChan peers <- newMVar M.empty - - Just self <- return $ verifyIdentity $ lsIdentity $ - fromStored $ wrappedLoad $ headRef origHead - midentity <- newMVar $ self + midentity <- newMVar $ headLocalIdentity origHead let open addr = do sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) @@ -184,9 +179,8 @@ startServer origHead logd bhost services = do threadDelay $ announceIntervalSeconds * 1000 * 1000 watchHead origHead $ \h -> do - idt <- modifyMVar midentity $ \cur -> do - return $ (\x -> (x,x)) $ fromMaybe cur $ verifyIdentity $ lsIdentity $ - fromStored $ wrappedLoad $ headRef h + let idt = headLocalIdentity h + modifyMVar_ midentity $ \_ -> return idt announce idt forever $ do @@ -208,7 +202,7 @@ startServer origHead logd bhost services = do let peer = Peer { peerAddress = DatagramAddress paddr , peerIdentity = PeerIdentityUnknown - , peerOwner = PeerIdentityUnknown + , peerIdentityUpdate = [] , peerChannel = ChannelWait , peerSocket = sock , peerStorage = pst @@ -247,14 +241,13 @@ startServer origHead logd bhost services = do void $ forkIO $ forever $ readChan chanSvc >>= \case (peer, svc, ref) | PeerIdentityFull peerId <- peerIdentity peer - , PeerIdentityFull peerOwnerId <- peerOwner peer -> modifyMVar_ (peerServiceState peer) $ \svcs -> case maybe (lookup svc services) Just $ M.lookup svc svcs of Nothing -> do logd $ "unhandled service '" ++ T.unpack svc ++ "'" return svcs Just (SomeService s) -> do let inp = ServiceInput - { svcPeer = peerId, svcPeerOwner = peerOwnerId + { svcPeer = peerId , svcPrintOp = logd } (rsp, s') <- handleServicePacket storage inp s (wrappedLoad ref) @@ -295,6 +288,7 @@ handlePacket logd identity secure opeer chanSvc (TransportHeader headers) = do DatagramAddress paddr = peerAddress opeer plaintextRefs = map (refDigest . storedRef) $ concatMap (collectStoredObjects . wrappedLoad) $ concat [ [ storedRef sidentity ] + , map storedRef $ idUpdates identity , case peerChannel opeer of ChannelOurRequest req -> [ storedRef req ] ChannelOurAccept acc _ -> [ storedRef acc ] @@ -305,8 +299,9 @@ handlePacket logd identity secure opeer chanSvc (TransportHeader headers) = do forM_ headers $ \case Acknowledged ref -> do gets (peerChannel . phPeer) >>= \case - ChannelOurAccept acc ch | refDigest (storedRef acc) == refDigest ref -> + ChannelOurAccept acc ch | refDigest (storedRef acc) == refDigest ref -> do updatePeer $ \p -> p { peerChannel = ChannelEstablished (fromStored ch) } + sendIdentityUpdate identity _ -> return () DataRequest ref @@ -329,18 +324,28 @@ handlePacket logd identity secure opeer chanSvc (TransportHeader headers) = do AnnounceSelf ref -> do peer <- gets phPeer - if | Just ref' <- peerIdentityRef peer, refDigest ref' == refDigest ref -> return () + if | PeerIdentityRef wref <- peerIdentity peer, wrDigest wref == refDigest ref -> return () + | PeerIdentityFull pid <- peerIdentity peer, refDigest ref == (refDigest $ storedRef $ idData pid) -> return () | refDigest ref == refDigest (storedRef sidentity) -> return () | otherwise -> do copyOrRequestRef (peerStorage peer) ref >>= \case Right pref - | Just idt <- verifyIdentity (wrappedLoad pref) -> do - updatePeer $ \p -> p { peerIdentity = PeerIdentityFull idt - , peerOwner = PeerIdentityFull $ finalOwner idt - } + | Just idt <- validateIdentity $ wrappedLoad pref -> + case peerIdentity peer of + PeerIdentityFull prev | not (prev `sameIdentity` idt) -> + throwError $ "peer identity does not follow" + _ -> updatePeer $ \p -> p { peerIdentity = PeerIdentityFull idt } | otherwise -> throwError $ "broken identity " ++ show pref Left wref -> updatePeer $ \p -> p { peerIdentity = PeerIdentityRef wref } + AnnounceUpdate ref -> do + peer <- gets phPeer + case peerIdentity peer of + PeerIdentityFull pid -> copyOrRequestRef (peerStorage peer) ref >>= \case + Right upd -> updatePeer $ \p -> p { peerIdentity = PeerIdentityFull $ updateOwners [wrappedLoad upd] pid } + Left wref -> updatePeer $ \p -> p { peerIdentityUpdate = wref : peerIdentityUpdate p } + _ -> return () + TrChannelRequest reqref -> do addHeader $ Acknowledged reqref pst <- gets $ peerStorage . phPeer @@ -378,6 +383,7 @@ handlePacket logd identity secure opeer chanSvc (TransportHeader headers) = do | otherwise -> throwError $ "service ref without type" setupChannel identity + handleIdentityUpdate handleServices chanSvc case res of @@ -405,7 +411,7 @@ getOrRequestIdentity :: PeerIdentity -> PacketHandler (Maybe UnifiedIdentity) getOrRequestIdentity = \case PeerIdentityUnknown -> return Nothing PeerIdentityRef wref -> checkWaitingRef wref >>= \case - Just ref -> case verifyIdentity $ wrappedLoad ref of + Just ref -> case validateIdentity (wrappedLoad ref) of Nothing -> throwError $ "broken identity" Just idt -> return $ Just idt Nothing -> return Nothing @@ -416,14 +422,14 @@ setupChannel :: UnifiedIdentity -> PacketHandler () setupChannel identity = gets phPeer >>= \case peer@Peer { peerChannel = ChannelWait } -> do getOrRequestIdentity (peerIdentity peer) >>= \case - Just pid -> do + Just pid | Just upid <- toUnifiedIdentity pid -> do let ist = peerInStorage peer - req <- createChannelRequest (peerStorage peer) identity pid + req <- createChannelRequest (peerStorage peer) identity upid updatePeer $ \p -> p { peerChannel = ChannelOurRequest req } addHeader $ TrChannelRequest $ partialRef ist $ storedRef req addHeader $ AnnounceSelf $ partialRef ist $ storedRef $ idData identity addBody $ storedRef req - Nothing -> return () + _ -> return () Peer { peerChannel = ChannelPeerRequest wref } -> do handleChannelRequest identity wref @@ -439,16 +445,15 @@ handleChannelRequest identity reqref = do PeerIdentityFull pid -> return pid PeerIdentityRef wref -> do Just idref <- checkWaitingRef wref - Just pid <- return $ verifyIdentity $ wrappedLoad idref + Just pid <- return $ validateIdentity $ wrappedLoad idref return pid PeerIdentityUnknown -> throwError $ "unknown peer identity" - (acc, ch) <- acceptChannelRequest identity pid (wrappedLoad req) + (acc, ch) <- case toUnifiedIdentity pid of + Just upid -> acceptChannelRequest identity upid (wrappedLoad req) + Nothing -> throwError $ "non-unified peer identity" updatePeer $ \p -> p { peerIdentity = PeerIdentityFull pid - , peerOwner = case peerOwner p of - PeerIdentityUnknown -> PeerIdentityFull $ finalOwner pid - owner -> owner , peerChannel = ChannelOurAccept acc ch } addHeader $ TrChannelAccept (partialRef ist $ storedRef acc) @@ -470,21 +475,42 @@ handleChannelAccept identity accref = do PeerIdentityFull pid -> return pid PeerIdentityRef wref -> do Just idref <- checkWaitingRef wref - Just pid <- return $ verifyIdentity $ wrappedLoad idref + Just pid <- return $ validateIdentity $ wrappedLoad idref return pid PeerIdentityUnknown -> throwError $ "unknown peer identity" - ch <- acceptedChannel identity pid (wrappedLoad acc) + ch <- case toUnifiedIdentity pid of + Just upid -> acceptedChannel identity upid (wrappedLoad acc) + Nothing -> throwError $ "non-unified peer identity" updatePeer $ \p -> p { peerIdentity = PeerIdentityFull pid - , peerOwner = case peerOwner p of - PeerIdentityUnknown -> PeerIdentityFull $ finalOwner pid - owner -> owner , peerChannel = ChannelEstablished $ fromStored ch } + sendIdentityUpdate identity Left dgst -> throwError $ "missing accept data " ++ BC.unpack (showRefDigest dgst) +sendIdentityUpdate :: UnifiedIdentity -> PacketHandler () +sendIdentityUpdate self = do + ist <- gets $ peerInStorage . phPeer + mapM_ addHeader . map (AnnounceUpdate . partialRef ist . storedRef) . idUpdates $ self + + +handleIdentityUpdate :: PacketHandler () +handleIdentityUpdate = do + peer <- gets phPeer + case (peerIdentity peer, peerIdentityUpdate peer) of + (PeerIdentityFull pid, wrefs@(_:_)) -> do + (wrefs', upds) <- fmap partitionEithers $ forM wrefs $ \wref -> checkWaitingRef wref >>= \case + Just upd -> return $ Right $ wrappedLoad upd + Nothing -> return $ Left wref + updatePeer $ \p -> p + { peerIdentity = PeerIdentityFull $ updateOwners upds pid + , peerIdentityUpdate = wrefs' + } + _ -> return () + + handleServices :: Chan (Peer, T.Text, Ref) -> PacketHandler () handleServices chan = gets (peerServiceQueue . phPeer) >>= \case [] -> return () diff --git a/src/PubKey.hs b/src/PubKey.hs index 8f39bf1..483a94b 100644 --- a/src/PubKey.hs +++ b/src/PubKey.hs @@ -85,11 +85,11 @@ instance Storable Signature where instance Storable a => Storable (Signed a) where store' sig = storeRec $ do - storeRef "data" $ signedData sig + storeRef "SDATA" $ signedData sig mapM_ (storeRef "sig") $ signedSignature sig load' = loadRec $ do - sdata <- loadRef "data" + sdata <- loadRef "SDATA" sigs <- loadRefs "sig" forM_ sigs $ \sig -> do let PublicKey pubkey = fromStored $ sigKey $ fromStored sig diff --git a/src/Service.hs b/src/Service.hs index f08a7a2..6b490ff 100644 --- a/src/Service.hs +++ b/src/Service.hs @@ -32,7 +32,6 @@ fromService (SomeService s) = cast s data ServiceInput = ServiceInput { svcPeer :: UnifiedIdentity - , svcPeerOwner :: UnifiedIdentity , svcPrintOp :: String -> IO () } @@ -46,7 +45,7 @@ newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (Servi handleServicePacket :: Service s => Storage -> ServiceInput -> s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), s) handleServicePacket st input svc packet = do - herb <- loadLocalState st + herb <- loadLocalStateHead st let erb = wrappedLoad $ headRef herb sstate = ServiceState { svcValue = svc, svcLocal = erb } ServiceHandler handler = serviceHandler packet diff --git a/src/State.hs b/src/State.hs index 515391d..bb193a3 100644 --- a/src/State.hs +++ b/src/State.hs @@ -2,15 +2,19 @@ module State ( LocalState(..), SharedState(..), - loadLocalState, + loadLocalState, loadLocalStateHead, updateLocalState, updateLocalState_, updateSharedState, updateSharedState_, mergeSharedStates, + loadLocalIdentity, headLocalIdentity, + mergeSharedIdentity, - updateIdentity, + updateSharedIdentity, ) where +import Control.Monad + import Data.List import Data.Maybe import qualified Data.Text as T @@ -56,8 +60,11 @@ instance Storable SharedState where <*> loadRefs "id" -loadLocalState :: Storage -> IO Head -loadLocalState st = loadHeadDef st "erebos" $ do +loadLocalState :: Storage -> IO (Stored LocalState) +loadLocalState = return . wrappedLoad . headRef <=< loadLocalStateHead + +loadLocalStateHead :: Storage -> IO Head +loadLocalStateHead st = loadHeadDef st "erebos" $ do putStr "Name: " hFlush stdout name <- T.getLine @@ -97,6 +104,17 @@ loadLocalState st = loadHeadDef st "erebos" $ do , lsMessages = msgs } +loadLocalIdentity :: Storage -> IO UnifiedIdentity +loadLocalIdentity = return . headLocalIdentity <=< loadLocalStateHead + +headLocalIdentity :: Head -> UnifiedIdentity +headLocalIdentity h = + let ls = load $ headRef h + in maybe (error "failed to verify local identity") + (updateOwners (ssIdentity . fromStored =<< lsShared ls)) + (validateIdentity $ lsIdentity ls) + + updateLocalState_ :: Storage -> (Stored LocalState -> IO (Stored LocalState)) -> IO () updateLocalState_ st f = updateLocalState st (fmap (,()) . f) @@ -127,15 +145,15 @@ mergeSharedStates [] = error "mergeSharedStates: empty list" mergeSharedIdentity :: Storage -> IO UnifiedIdentity mergeSharedIdentity st = updateSharedState st $ \sshared -> do let shared = fromStored sshared - Just cidentity = verifyIdentityF $ ssIdentity shared + Just cidentity = validateIdentityF $ ssIdentity shared identity <- mergeIdentity cidentity sshared' <- wrappedStore st $ shared { ssIdentity = [idData identity] } return (sshared', identity) -updateIdentity :: Storage -> IO () -updateIdentity st = updateSharedState_ st $ \sshared -> do +updateSharedIdentity :: Storage -> IO () +updateSharedIdentity st = updateSharedState_ st $ \sshared -> do let shared = fromStored sshared - Just identity = verifyIdentityF $ ssIdentity shared + Just identity = validateIdentityF $ ssIdentity shared public = idKeyIdentity identity T.putStr $ T.concat $ concat diff --git a/src/Storage.hs b/src/Storage.hs index 1cf5cd4..fbccefc 100644 --- a/src/Storage.hs +++ b/src/Storage.hs @@ -28,6 +28,7 @@ module Storage ( storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbJson, storeMbRef, storeZRef, + LoadRec, loadBlob, loadRec, loadZero, loadInt, loadNum, loadText, loadBinary, loadDate, loadJson, loadRef, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbJson, loadMbRef, @@ -719,17 +720,8 @@ loadZRef name = loadMbRef name >>= \case Just x -> return x -data Stored' c a = Stored (Ref' c) a - deriving (Show) - type Stored a = Stored' Complete a -instance Eq (Stored a) where - Stored r1 _ == Stored r2 _ = refDigest r1 == refDigest r2 - -instance Ord (Stored a) where - compare (Stored r1 _) (Stored r2 _) = compare (refDigest r1) (refDigest r2) - instance Storable a => Storable (Stored a) where store st = copyRef st . storedRef store' (Stored _ x) = store' x diff --git a/src/Storage/Internal.hs b/src/Storage/Internal.hs index 88741e0..76adaab 100644 --- a/src/Storage/Internal.hs +++ b/src/Storage/Internal.hs @@ -86,6 +86,15 @@ showRefDigest = B.concat . map showHexByte . BA.unpack data Head' c = Head String (Ref' c) deriving (Show) +data Stored' c a = Stored (Ref' c) a + deriving (Show) + +instance Eq (Stored' c a) where + Stored r1 _ == Stored r2 _ = refDigest r1 == refDigest r2 + +instance Ord (Stored' c a) where + compare (Stored r1 _) (Stored r2 _) = compare (refDigest r1) (refDigest r2) + type Complete = Identity type Partial = Either RefDigest diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs new file mode 100644 index 0000000..ac80c96 --- /dev/null +++ b/src/Storage/Merge.hs @@ -0,0 +1,40 @@ +module Storage.Merge ( + generations, + ancestors, + precedes, +) where + +import qualified Data.ByteString.Char8 as BC +import Data.List +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as S + +import Storage +import Storage.Internal + +previous :: Storable a => Stored a -> [Stored a] +previous (Stored ref _) = case load ref of + Rec items | Just (RecRef dref) <- lookup (BC.pack "SDATA") items + , Rec ditems <- load dref -> + map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $ + map snd $ filter ((== BC.pack "SPREV") . fst) ditems + + | otherwise -> + map wrappedLoad $ catMaybes $ map (\case RecRef r -> Just r; _ -> Nothing) $ + map snd $ filter ((== BC.pack "PREV") . fst) items + _ -> [] + + +generations :: Storable a => [Stored a] -> [Set (Stored a)] +generations = unfoldr gen . (,S.empty) + where gen (hs, cur) = case filter (`S.notMember` cur) $ previous =<< hs of + [] -> Nothing + added -> let next = foldr S.insert cur added + in Just (next, (added, next)) + +ancestors :: Storable a => [Stored a] -> Set (Stored a) +ancestors = last . (S.empty:) . generations + +precedes :: Storable a => Stored a -> Stored a -> Bool +precedes x y = x `S.member` ancestors [y] |