From 61b04eb5fda0d1e94f673ad1c11f328a318bb09d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Fri, 11 Oct 2019 22:19:15 +0200 Subject: Identity merging and verification --- erebos.cabal | 1 + src/Channel.hs | 26 ++++---- src/Identity.hs | 195 +++++++++++++++++++++++++++++++++++++++++++++----------- src/Main.hs | 31 ++++----- src/Message.hs | 15 +++-- src/Network.hs | 26 ++++---- src/PubKey.hs | 5 +- 7 files changed, 215 insertions(+), 84 deletions(-) diff --git a/erebos.cabal b/erebos.cabal index cf50a74..8e35452 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -34,6 +34,7 @@ executable erebos MultiWayIf, RankNTypes, ScopedTypeVariables, + StandaloneDeriving, TupleSections, TypeFamilies 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 "") . 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 "") . 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 "" T.unpack $ idName . fromStored . signedData . fromStored . finalOwner <=< peerIdentity $ peer + Just peer -> maybe "" 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 "" T.unpack $ idName $ fromStored $ signedData $ fromStored $ msgFrom msg + , maybe "" 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