From 61b04eb5fda0d1e94f673ad1c11f328a318bb09d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Fri, 11 Oct 2019 22:19:15 +0200
Subject: Identity merging and verification
---
src/Channel.hs | 26 ++++----
src/Identity.hs | 195 +++++++++++++++++++++++++++++++++++++++++++++-----------
src/Main.hs | 31 ++++-----
src/Message.hs | 15 +++--
src/Network.hs | 26 ++++----
src/PubKey.hs | 5 +-
6 files changed, 214 insertions(+), 84 deletions(-)
(limited to 'src')
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)
--
cgit v1.2.3