Identity merging and verification

6 files changed, 214 insertions, 84 deletions

diff --git a/src/Channel.hs b/src/Channel.hs
index 4627d70..50e1b81 100644
--- a/src/Channel.hs
+++ b/src/Channel.hs
@@ -32,7 +32,7 @@ import PubKey
 import Storage
 
 data Channel = Channel
-    { chPeers :: [Stored Identity]
+    { chPeers :: [Stored (Signed IdentityData)]
     , chKey :: ScrubbedBytes
     }
     deriving (Show)
@@ -40,7 +40,7 @@ data Channel = Channel
 type ChannelRequest = Signed ChannelRequestData
 
 data ChannelRequestData = ChannelRequest
-    { crPeers :: [Stored Identity]
+    { crPeers :: [Stored (Signed IdentityData)]
     , crKey :: Stored PublicKexKey
     }
 
@@ -88,22 +88,22 @@ instance Storable ChannelAcceptData where
             <*> loadRef "key"
 
 
-createChannelRequest :: Storage -> Stored Identity -> Stored Identity -> IO (Stored ChannelRequest)
+createChannelRequest :: Storage -> UnifiedIdentity -> UnifiedIdentity -> IO (Stored ChannelRequest)
 createChannelRequest st self peer = do
     (_, xpublic) <- generateKeys st
-    Just skey <- loadKey $ idKeyMessage $ fromStored $ signedData $ fromStored self
-    wrappedStore st =<< sign skey =<< wrappedStore st ChannelRequest { crPeers = sort [self, peer], crKey = xpublic }
+    Just skey <- loadKey $ idKeyMessage self
+    wrappedStore st =<< sign skey =<< wrappedStore st ChannelRequest { crPeers = sort [idData self, idData peer], crKey = xpublic }
 
-acceptChannelRequest :: Stored Identity -> Stored Identity -> Stored ChannelRequest -> ExceptT [String] IO (Stored ChannelAccept, Stored Channel)
+acceptChannelRequest :: UnifiedIdentity -> UnifiedIdentity -> Stored ChannelRequest -> ExceptT [String] IO (Stored ChannelAccept, Stored Channel)
 acceptChannelRequest self peer req = do
-    guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort [self, peer]
-    guard $ (idKeyMessage $ fromStored $ signedData $ fromStored peer) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)
+    guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort (map idData [self, peer])
+    guard $ (idKeyMessage peer) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)
 
     let st = storedStorage req
         KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
     liftIO $ do
         (xsecret, xpublic) <- generateKeys st
-        Just skey <- loadKey $ idKeyMessage $ fromStored $ signedData $ fromStored self
+        Just skey <- loadKey $ idKeyMessage self
         acc <- wrappedStore st =<< sign skey =<< wrappedStore st ChannelAccept { caRequest = req, caKey = xpublic }
         ch <- wrappedStore st Channel
             { chPeers = crPeers $ fromStored $ signedData $ fromStored req
@@ -112,15 +112,15 @@ acceptChannelRequest self peer req = do
             }
         return (acc, ch)
 
-acceptedChannel :: Stored Identity -> Stored Identity -> Stored ChannelAccept -> ExceptT [String] IO (Stored Channel)
+acceptedChannel :: UnifiedIdentity -> UnifiedIdentity -> Stored ChannelAccept -> ExceptT [String] IO (Stored Channel)
 acceptedChannel self peer acc = do
     let st = storedStorage acc
         req = caRequest $ fromStored $ signedData $ fromStored acc
         KeySizeFixed ksize = cipherKeySize (undefined :: AES128)
 
-    guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort [self, peer]
-    guard $ (idKeyMessage $ fromStored $ signedData $ fromStored peer) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)
-    guard $ (idKeyMessage $ fromStored $ signedData $ fromStored self) `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)
+    guard $ (crPeers $ fromStored $ signedData $ fromStored req) == sort (map idData [self, peer])
+    guard $ idKeyMessage peer `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored acc)
+    guard $ idKeyMessage self `elem` (map (sigKey . fromStored) $ signedSignature $ fromStored req)
 
     Just xsecret <- liftIO $ loadKey $ crKey $ fromStored $ signedData $ fromStored req
     liftIO $ wrappedStore st Channel
diff --git a/src/Identity.hs b/src/Identity.hs
index 96346d8..5a7f8fc 100644
--- a/src/Identity.hs
+++ b/src/Identity.hs
@@ -1,62 +1,185 @@
+{-# LANGUAGE UndecidableInstances #-}
+
 module Identity (
-    Identity, IdentityData(..),
-    emptyIdentity,
+    Identity, ComposedIdentity, UnifiedIdentity, IdentityData(..),
+    idData, idDataF, idName, idOwner, idKeyIdentity, idKeyMessage,
+
+    emptyIdentityData,
+    verifyIdentity, verifyIdentityF,
+    mergeIdentity, toComposedIdentity,
+
     finalOwner,
     displayIdentity,
 ) where
 
+import Control.Monad
+import qualified Control.Monad.Identity as I
+
+import Data.Foldable
+import Data.Function
+import Data.List
 import Data.Maybe
+import Data.Ord
+import Data.Set (Set)
+import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T
 
 import PubKey
 import Storage
 
-type Identity = Signed IdentityData
-
-data IdentityData = Identity
-    { idName :: Maybe Text
-    , idPrev :: Maybe (Stored Identity)
-    , idOwner :: Maybe (Stored Identity)
-    , idKeyIdentity :: Stored PublicKey
-    , idKeyMessage :: Stored PublicKey
+data Identity m = Identity
+    { idData_ :: m (Stored (Signed IdentityData))
+    , idName_ :: Maybe Text
+    , idOwner_ :: Maybe UnifiedIdentity
+    , idKeyIdentity_ :: Stored PublicKey
+    , idKeyMessage_ :: Stored PublicKey
     }
-    deriving (Show)
 
-emptyIdentity :: Stored PublicKey -> Stored PublicKey -> IdentityData
-emptyIdentity key kmsg = Identity
-    { idName = Nothing
-    , idPrev = Nothing
-    , idOwner = Nothing
-    , idKeyIdentity = key
-    , idKeyMessage = kmsg
+deriving instance Show (m (Stored (Signed IdentityData))) => Show (Identity m)
+
+type ComposedIdentity = Identity []
+type UnifiedIdentity = Identity I.Identity
+
+instance Eq UnifiedIdentity where
+    (==) = (==) `on` idData
+
+data IdentityData = IdentityData
+    { iddPrev :: [Stored (Signed IdentityData)]
+    , iddName :: Maybe Text
+    , iddOwner :: Maybe (Stored (Signed IdentityData))
+    , iddKeyIdentity :: Stored PublicKey
+    , iddKeyMessage :: Maybe (Stored PublicKey)
     }
+    deriving (Show)
 
 instance Storable IdentityData where
     store' idt = storeRec $ do
-        storeMbText "name" $ idName idt
-        storeMbRef "prev" $ idPrev idt
-        storeMbRef "owner" $ idOwner idt
-        storeRef "key-id" $ idKeyIdentity idt
-        storeRef "key-msg" $ idKeyMessage idt
-
-    load' = loadRec $ Identity
-        <$> loadMbText "name"
-        <*> loadMbRef "prev"
+        mapM_ (storeRef "PREV") $ 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"
+        <*> loadMbText "name"
         <*> loadMbRef "owner"
         <*> loadRef "key-id"
-        <*> loadRef "key-msg"
+        <*> loadMbRef "key-msg"
+
+idData :: UnifiedIdentity -> Stored (Signed IdentityData)
+idData = I.runIdentity . idDataF
+
+idDataF :: Identity m -> m (Stored (Signed IdentityData))
+idDataF = idData_
+
+idName :: Identity m -> Maybe Text
+idName = idName_
+
+idOwner :: Identity m -> Maybe UnifiedIdentity
+idOwner = idOwner_
+
+idKeyIdentity :: Identity m -> Stored PublicKey
+idKeyIdentity = idKeyIdentity_
+
+idKeyMessage :: Identity m -> Stored PublicKey
+idKeyMessage = idKeyMessage_
+
+
+emptyIdentityData :: Stored PublicKey -> IdentityData
+emptyIdentityData key = IdentityData
+    { iddName = Nothing
+    , iddPrev = []
+    , iddOwner = Nothing
+    , iddKeyIdentity = key
+    , iddKeyMessage = Nothing
+    }
+
+verifyIdentity :: Stored (Signed IdentityData) -> Maybe UnifiedIdentity
+verifyIdentity = verifyIdentityF . I.Identity
+
+verifyIdentityF :: Foldable m => m (Stored (Signed IdentityData)) -> Maybe (Identity m)
+verifyIdentityF mdata = do
+    let idata = toList mdata -- TODO: eliminate ancestors
+    guard $ not $ null idata
+    mapM_ verifySignatures $ gatherPrevious S.empty idata
+    Identity
+        <$> pure mdata
+        <*> pure (lookupProperty iddName idata)
+        <*> case lookupProperty iddOwner idata of
+                 Nothing    -> return Nothing
+                 Just owner -> Just <$> verifyIdentity owner
+        <*> pure (iddKeyIdentity $ fromStored $ signedData $ fromStored $ minimum idata)
+        <*> lookupProperty iddKeyMessage idata
+
+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
+gatherPrevious res [] = res
+
+verifySignatures :: Stored (Signed IdentityData) -> Maybe ()
+verifySignatures sidd = do
+    let idd = fromStored $ signedData $ fromStored sidd
+        required = concat
+            [ [ iddKeyIdentity idd ]
+            , map (iddKeyIdentity . fromStored . signedData . fromStored) $ iddPrev idd
+            , map (iddKeyIdentity . fromStored . signedData . fromStored) $ toList $ iddOwner idd
+            ]
+    guard $ all (fromStored sidd `isSignedBy`) required
+
+lookupProperty :: forall a. (IdentityData -> Maybe a) -> [Stored (Signed IdentityData)] -> Maybe a
+lookupProperty sel topHeads = findResult filteredLayers
+    where findPropHeads :: Stored (Signed IdentityData) -> [(Stored (Signed IdentityData), a)]
+          findPropHeads sobj | Just x <- sel $ fromStored $ signedData $ fromStored sobj = [(sobj, x)]
+                             | otherwise = findPropHeads =<< (iddPrev $ fromStored $ signedData $ fromStored sobj)
+
+          propHeads :: [(Stored (Signed IdentityData), a)]
+          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))
+
+          filteredLayers :: [[(Stored (Signed IdentityData), a)]]
+          filteredLayers = scanl (\cur obsolete -> filter ((`S.notMember` obsolete) . fst) cur) propHeads historyLayers
+
+          findResult ([(_, x)] : _) = Just x
+          findResult ([] : _) = Nothing
+          findResult [] = Nothing
+          findResult [xs] = Just $ snd $ minimumBy (comparing fst) xs
+          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 = do
+    (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 }
+
+
+toComposedIdentity :: Foldable m => Identity m -> ComposedIdentity
+toComposedIdentity idt = idt { idData_ = toList $ idDataF idt }
+
 
-unfoldOwners :: Stored Identity -> [Stored Identity]
-unfoldOwners cur = cur : case idOwner $ fromStored $ signedData $ fromStored cur of
+unfoldOwners :: (Foldable m, Applicative m) => Identity m -> [Identity m]
+unfoldOwners cur = cur : case idOwner cur of
                               Nothing   -> []
-                              Just prev -> unfoldOwners prev
+                              Just owner@Identity { idData_ = I.Identity pid } ->
+                                  unfoldOwners owner { idData_ = pure pid }
 
-finalOwner :: Stored Identity -> Stored Identity
+finalOwner :: (Foldable m, Applicative m) => Identity m -> Identity m
 finalOwner = last . unfoldOwners
 
-displayIdentity :: Stored Identity -> Text
-displayIdentity sidentity = T.concat
-    [ T.intercalate (T.pack " / ") $ map (fromMaybe (T.pack "<unnamed>") . idName . fromStored . signedData . fromStored) owners
+displayIdentity :: (Foldable m, Applicative m) => Identity m -> Text
+displayIdentity identity = T.concat
+    [ T.intercalate (T.pack " / ") $ map (fromMaybe (T.pack "<unnamed>") . idName) owners
     ]
-    where owners = reverse $ unfoldOwners sidentity
+    where owners = reverse $ unfoldOwners identity
diff --git a/src/Main.hs b/src/Main.hs
index 4a6d3cd..1785581 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -28,7 +28,7 @@ import Storage
 
 
 data Erebos = Erebos
-    { erbIdentity :: Stored Identity
+    { erbIdentity :: Stored (Signed IdentityData)
     , erbMessages :: StoredList DirectMessageThread
     }
 
@@ -53,9 +53,10 @@ loadErebosHead st = loadHeadDef st "erebos" $ do
     (devSecret, devPublic) <- generateKeys st
     (_devSecretMsg, devPublicMsg) <- generateKeys st
 
-    owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentity public publicMsg) { idName = Just name }
-    identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<<
-        wrappedStore st (emptyIdentity devPublic devPublicMsg) { idOwner = Just owner }
+    owner <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
+        { iddName = Just name, iddKeyMessage = Just publicMsg }
+    identity <- wrappedStore st =<< signAdd devSecret =<< sign secret =<< wrappedStore st (emptyIdentityData devPublic)
+        { iddOwner = Just owner, iddKeyMessage = Just devPublicMsg }
 
     msgs <- emptySList st
     return $ Erebos
@@ -101,7 +102,7 @@ interactiveLoop :: Storage -> String -> IO ()
 interactiveLoop st bhost = runInputT defaultSettings $ do
     erebosHead <- liftIO $ loadErebosHead st
     let serebos = wrappedLoad (headRef erebosHead) :: Stored Erebos
-        self = erbIdentity $ fromStored serebos
+        Just self = verifyIdentity $ erbIdentity $ fromStored serebos
     outputStrLn $ T.unpack $ displayIdentity self
 
     haveTerminalUI >>= \case True -> return ()
@@ -109,7 +110,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
     extPrint <- getExternalPrint
     let extPrintLn str = extPrint $ str ++ "\n";
     (chanPeer, chanSvc) <- liftIO $
-        startServer extPrintLn bhost $ erbIdentity $ fromStored serebos
+        startServer extPrintLn bhost self
 
     peers <- liftIO $ newMVar []
 
@@ -131,9 +132,9 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
                     msg = fromStored smsg
                 extPrintLn $ formatMessage tzone msg
                 if | Just powner <- finalOwner <$> peerIdentity peer
-                   , powner == msgFrom msg
+                   , idData powner == msgFrom msg
                    -> updateErebosHead_ st $ \erb -> do
-                          slist <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
+                          slist <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
                                         Just thread -> do thread' <- wrappedStore st (fromStored thread) { msgHead = smsg : msgHead (fromStored thread) }
                                                           slistReplaceS thread thread' $ erbMessages $ fromStored erb
                                         Nothing -> slistAdd (emptyDirectThread powner) { msgHead = [smsg] } $ erbMessages $ fromStored erb
@@ -151,7 +152,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
     let process cstate = do
             let pname = case csPeer cstate of
                              Nothing -> ""
-                             Just peer -> maybe "<unnamed>" T.unpack $ idName . fromStored . signedData . fromStored . finalOwner <=< peerIdentity $ peer
+                             Just peer -> maybe "<unnamed>" T.unpack $ idName . finalOwner <=< peerIdentity $ peer
             input <- getInputLines $ pname ++ "> "
             let (cmd, line) = case input of
                     '/':rest -> let (scmd, args) = dropWhile isSpace <$> span isAlphaNum rest
@@ -171,7 +172,7 @@ interactiveLoop st bhost = runInputT defaultSettings $ do
 
 
 data CommandInput = CommandInput
-    { ciSelf :: Stored Identity
+    { ciSelf :: UnifiedIdentity
     , ciLine :: String
     , ciPeers :: CommandM [Peer]
     }
@@ -207,13 +208,13 @@ cmdSetPeer n | n < 1     = liftIO $ putStrLn "Invalid peer index"
 cmdSend :: Command
 cmdSend = void $ runMaybeT $ do
     self <- asks ciSelf
-    let st = storedStorage self
+    let st = storedStorage $ idData self
     Just peer <- gets csPeer
     Just powner <- return $ finalOwner <$> peerIdentity peer
     _:_ <- return $ peerChannels peer
     text <- asks ciLine
     smsg <- liftIO $ updateErebosHead st $ \erb -> do
-        (slist, smsg) <- case find ((== powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
+        (slist, smsg) <- case find ((== idData powner) . msgPeer . fromStored) (storedFromSList $ erbMessages $ fromStored erb) of
             Just thread -> do
                 (smsg, thread') <- createDirectMessage self (fromStored thread) (T.pack text)
                 (,smsg) <$> slistReplaceS thread thread' (erbMessages $ fromStored erb)
@@ -230,13 +231,13 @@ cmdSend = void $ runMaybeT $ do
 cmdHistory :: Command
 cmdHistory = void $ runMaybeT $ do
     self <- asks ciSelf
-    let st = storedStorage self
+    let st = storedStorage $ idData self
     Just peer <- gets csPeer
     Just powner <- return $ finalOwner <$> peerIdentity peer
 
     Just erebosHead <- liftIO $ loadHead st "erebos"
     let erebos = wrappedLoad (headRef erebosHead)
-    Just thread <- return $ find ((==powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos
+    Just thread <- return $ find ((== idData powner) . msgPeer) $ fromSList $ erbMessages $ fromStored erebos
     tzone <- liftIO $ getCurrentTimeZone
     liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread
 
@@ -244,7 +245,7 @@ cmdHistory = void $ runMaybeT $ do
 formatMessage :: TimeZone -> DirectMessage -> String
 formatMessage tzone msg = concat
     [ formatTime defaultTimeLocale "[%H:%M] " $ utcToLocalTime tzone $ zonedTimeToUTC $ msgTime msg
-    , maybe "<unnamed>" T.unpack $ idName $ fromStored $ signedData $ fromStored $ msgFrom msg
+    , maybe "<unnamed>" T.unpack $ iddName $ fromStored $ signedData $ fromStored $ msgFrom msg
     , ": "
     , T.unpack $ msgText msg
     ]
diff --git a/src/Message.hs b/src/Message.hs
index 0a1a70e..8892edb 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -11,17 +11,18 @@ import Data.Text (Text)
 import Data.Time.LocalTime
 
 import Identity
+import PubKey
 import Storage
 
 data DirectMessage = DirectMessage
-    { msgFrom :: Stored Identity
+    { msgFrom :: Stored (Signed IdentityData)
     , msgPrev :: [Stored DirectMessage]
     , msgTime :: ZonedTime
     , msgText :: Text
     }
 
 data DirectMessageThread = DirectMessageThread
-    { msgPeer :: Stored Identity
+    { msgPeer :: Stored (Signed IdentityData)
     , msgHead :: [Stored DirectMessage]
     , msgSeen :: [Stored DirectMessage]
     }
@@ -51,15 +52,15 @@ instance Storable DirectMessageThread where
         <*> loadRefs "seen"
 
 
-emptyDirectThread :: Stored Identity -> DirectMessageThread
-emptyDirectThread peer = DirectMessageThread peer [] []
+emptyDirectThread :: UnifiedIdentity -> DirectMessageThread
+emptyDirectThread peer = DirectMessageThread (idData peer) [] []
 
-createDirectMessage :: Stored Identity -> DirectMessageThread -> Text -> IO (Stored DirectMessage, Stored DirectMessageThread)
+createDirectMessage :: UnifiedIdentity -> DirectMessageThread -> Text -> IO (Stored DirectMessage, Stored DirectMessageThread)
 createDirectMessage self thread msg = do
-    let st = storedStorage self
+    let st = storedStorage $ idData self
     time <- getZonedTime
     smsg <- wrappedStore st DirectMessage
-        { msgFrom = finalOwner self
+        { msgFrom = idData $ finalOwner self
         , msgPrev = msgHead thread
         , msgTime = time
         , msgText = msg
diff --git a/src/Network.hs b/src/Network.hs
index eb72ed2..053dbe5 100644
--- a/src/Network.hs
+++ b/src/Network.hs
@@ -30,7 +30,7 @@ discoveryPort = "29665"
 
 data Peer = Peer
     { peerAddress :: PeerAddress
-    , peerIdentity :: Maybe (Stored Identity)
+    , peerIdentity :: Maybe UnifiedIdentity
     , peerChannels :: [Channel]
     , peerSocket :: Socket
     , peerStorage :: Storage
@@ -113,8 +113,9 @@ serviceFromObject (Rec items)
 serviceFromObject _ = Nothing
 
 
-startServer :: (String -> IO ()) -> String -> Stored Identity -> IO (Chan Peer, Chan (Peer, T.Text, Ref))
-startServer logd bhost sidentity = do
+startServer :: (String -> IO ()) -> String -> UnifiedIdentity -> IO (Chan Peer, Chan (Peer, T.Text, Ref))
+startServer logd bhost identity = do
+    let sidentity = idData identity
     chanPeer <- newChan
     chanSvc <- newChan
     peers <- newMVar M.empty
@@ -174,14 +175,15 @@ startServer logd bhost sidentity = do
                then do forM_ objs $ storeObject ist
                        copyRef pst from >>= \case
                            Nothing -> logd $ "Incomplete peer identity"
-                           Just sfrom -> do
-                               let peer = Peer (DatagramAddress paddr) (Just $ wrappedLoad sfrom) [] sock pst ist
+                           Just sfrom | Just pidentity <- verifyIdentity (wrappedLoad sfrom) -> do
+                               let peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock pst ist
                                modifyMVar_ peers $ return . M.insert paddr peer
                                writeChan chanPeer peer
                                void $ sendTo sock (BL.toStrict $ BL.concat
                                    [ serializeObject $ transportToObject $ IdentityResponse (partialRef ist $ storedRef sidentity)
                                    , BL.concat $ map (lazyLoadBytes . storedRef) $ collectStoredObjects $ wrappedLoad $ storedRef sidentity
                                    ]) paddr
+                           Just _ -> logd $ "Peer identity verification failed"
                else logd $ "Mismatched content"
 
         packet _ paddr (IdentityResponse ref) [] _ _ = do
@@ -195,12 +197,11 @@ startServer logd bhost sidentity = do
                then do forM_ objs $ storeObject ist
                        copyRef pst ref >>= \case
                            Nothing -> logd $ "Incomplete peer identity"
-                           Just sref -> do
-                               let pidentity = wrappedLoad sref
-                                   peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock pst ist
+                           Just sref | Just pidentity <- verifyIdentity (wrappedLoad sref) -> do
+                               let peer = Peer (DatagramAddress paddr) (Just pidentity) [] sock pst ist
                                modifyMVar_ peers $ return . M.insert paddr peer
                                writeChan chanPeer peer
-                               req <- createChannelRequest pst sidentity pidentity
+                               req <- createChannelRequest pst identity pidentity
                                void $ sendTo sock (BL.toStrict $ BL.concat
                                    [ serializeObject $ transportToObject $ TrChannelRequest (partialRef ist $ storedRef req)
                                    , lazyLoadBytes $ storedRef req
@@ -208,6 +209,7 @@ startServer logd bhost sidentity = do
                                    , lazyLoadBytes $ storedRef $ crKey $ fromStored $ signedData $ fromStored req
                                    , BL.concat $ map (lazyLoadBytes . storedRef) $ signedSignature $ fromStored req
                                    ]) paddr
+                           Just _ -> logd $ "Peer identity verification failed"
                else logd $ "Mismatched content"
 
         packet _ paddr (TrChannelRequest _) [] _ _ = do
@@ -225,7 +227,7 @@ startServer logd bhost sidentity = do
                                let request = wrappedLoad sref :: Stored ChannelRequest
                                modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
                                    Just peer | Just pid <- peerIdentity peer ->
-                                       runExceptT (acceptChannelRequest sidentity pid request) >>= \case
+                                       runExceptT (acceptChannelRequest identity pid request) >>= \case
                                            Left errs -> do mapM_ logd ("Invalid channel request" : errs)
                                                            return pval
                                            Right (acc, channel) -> do
@@ -260,7 +262,7 @@ startServer logd bhost sidentity = do
                                let accepted = wrappedLoad sref :: Stored ChannelAccept
                                modifyMVar_ peers $ \pval -> case M.lookup paddr pval of
                                    Just peer | Just pid <- peerIdentity peer ->
-                                       runExceptT (acceptedChannel sidentity pid accepted) >>= \case
+                                       runExceptT (acceptedChannel identity pid accepted) >>= \case
                                            Left errs -> do mapM_ logd ("Invalid channel accept" : errs)
                                                            return pval
                                            Right channel -> do
@@ -284,7 +286,7 @@ startServer logd bhost sidentity = do
     return (chanPeer, chanSvc)
 
 
-sendToPeer :: Storable a => Stored Identity -> Peer -> T.Text -> a -> IO ()
+sendToPeer :: Storable a => UnifiedIdentity -> Peer -> T.Text -> a -> IO ()
 sendToPeer _ peer@Peer { peerChannels = ch:_ } svc obj = do
     let st = peerInStorage peer
     ref <- store st obj
diff --git a/src/PubKey.hs b/src/PubKey.hs
index 6dc8080..d7134c8 100644
--- a/src/PubKey.hs
+++ b/src/PubKey.hs
@@ -2,7 +2,7 @@ module PubKey (
     PublicKey, SecretKey,
     KeyPair(generateKeys), loadKey,
     Signature(sigKey), Signed, signedData, signedSignature,
-    sign, signAdd,
+    sign, signAdd, isSignedBy,
 
     PublicKexKey, SecretKexKey,
     dhSecret,
@@ -103,6 +103,9 @@ signAdd (SecretKey secret spublic) (Signed val sigs) = do
     ssig <- wrappedStore (storedStorage val) $ Signature spublic sig
     return $ Signed val (ssig : sigs)
 
+isSignedBy :: Signed a -> Stored PublicKey -> Bool
+isSignedBy sig key = key `elem` map (sigKey . fromStored) (signedSignature sig)
+
 
 data PublicKexKey = PublicKexKey CX.PublicKey
     deriving (Show)