Load and announce identity updates

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]