summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2019-11-25 22:15:05 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2019-11-26 22:16:35 +0100
commita70628457a5ceccd37d1ba2e1791d4493b5a0502 (patch)
tree1daddb314ae7284f7e5c0c1e6308c19c681aedd1 /src
parentdd4c6aeae1cf30035f3c7c3d52e58082f6b7aa36 (diff)
Load and announce identity updates
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs8
-rw-r--r--src/Identity.hs94
-rw-r--r--src/Main.hs49
-rw-r--r--src/Message.hs19
-rw-r--r--src/Message/Service.hs9
-rw-r--r--src/Network.hs102
-rw-r--r--src/PubKey.hs4
-rw-r--r--src/Service.hs3
-rw-r--r--src/State.hs34
-rw-r--r--src/Storage.hs10
-rw-r--r--src/Storage/Internal.hs9
-rw-r--r--src/Storage/Merge.hs40
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]