summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Attach.hs2
-rw-r--r--src/Contact.hs30
-rw-r--r--src/Identity.hs9
-rw-r--r--src/Main.hs4
-rw-r--r--src/Message.hs24
-rw-r--r--src/State.hs32
-rw-r--r--src/Storage/List.hs7
-rw-r--r--src/Storage/Merge.hs13
-rw-r--r--src/Test.hs13
9 files changed, 80 insertions, 54 deletions
diff --git a/src/Attach.hs b/src/Attach.hs
index 90c9900..c27b383 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -58,7 +58,7 @@ instance PairingResult AttachIdentity where
pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- keys, pub <- pkeys ]
- shared <- makeSharedStateUpdate st (idDataF owner) (lsShared $ fromStored slocal)
+ shared <- makeSharedStateUpdate st (Just owner) (lsShared $ fromStored slocal)
wrappedStore st (fromStored slocal)
{ lsIdentity = idData identity
, lsShared = [ shared ]
diff --git a/src/Contact.hs b/src/Contact.hs
index 73a179f..f7cd3d3 100644
--- a/src/Contact.hs
+++ b/src/Contact.hs
@@ -2,6 +2,9 @@ module Contact (
Contact(..),
contactView,
+ Contacts,
+ toContactList,
+
ContactService,
contactRequest,
contactAccept,
@@ -38,6 +41,11 @@ data ContactData = ContactData
, cdName :: Maybe Text
}
+data Contacts = Contacts [Stored ContactData] [Contact]
+
+toContactList :: Contacts -> [Contact]
+toContactList (Contacts _ list) = list
+
instance Storable ContactData where
store' x = storeRec $ do
mapM_ (storeRef "PREV") $ cdPrev x
@@ -49,7 +57,12 @@ instance Storable ContactData where
<*> loadRefs "identity"
<*> loadMbText "name"
-instance SharedType ContactData where
+instance Mergeable Contacts where
+ type Component Contacts = ContactData
+ mergeSorted cdata = Contacts cdata $ contactView cdata
+ toComponents (Contacts cdata _) = cdata
+
+instance SharedType Contacts where
sharedTypeID _ = mkSharedTypeID "34fbb61e-6022-405f-b1b3-a5a1abecd25e"
contactView :: [Stored ContactData] -> [Contact]
@@ -91,11 +104,11 @@ instance PairingResult ContactAccepted where
pairingFinalizeRequest ContactAccepted = do
pid <- asks svcPeerIdentity
- updateLocalState_ $ finalizeContact pid
+ finalizeContact pid
pairingFinalizeResponse = do
pid <- asks svcPeerIdentity
- updateLocalState_ $ finalizeContact pid
+ finalizeContact pid
return ContactAccepted
defaultPairingAttributes _ = PairingAttributes
@@ -145,13 +158,12 @@ contactAccept = pairingAccept @ContactAccepted Proxy
contactReject :: (MonadIO m, MonadError String m) => Peer -> m ()
contactReject = pairingReject @ContactAccepted Proxy
-finalizeContact :: MonadIO m => UnifiedIdentity -> Stored LocalState -> m (Stored LocalState)
-finalizeContact identity slocal = liftIO $ do
- let st = storedStorage slocal
+finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m ()
+finalizeContact identity = updateSharedState_ $ \(Contacts prev _) -> do
+ let st = storedStorage $ idData identity
contact <- wrappedStore st ContactData
- { cdPrev = lookupSharedValue $ lsShared $ fromStored slocal
+ { cdPrev = prev
, cdIdentity = idDataF $ finalOwner identity
, cdName = Nothing
}
- shared <- makeSharedStateUpdate st [contact] (lsShared $ fromStored slocal)
- wrappedStore st (fromStored slocal) { lsShared = [shared] }
+ return $ Contacts [contact] (contactView [contact])
diff --git a/src/Identity.hs b/src/Identity.hs
index b81228f..834e5ee 100644
--- a/src/Identity.hs
+++ b/src/Identity.hs
@@ -52,8 +52,8 @@ deriving instance Show (m (Stored (Signed IdentityData))) => Show (Identity m)
type ComposedIdentity = Identity []
type UnifiedIdentity = Identity I.Identity
-instance Eq UnifiedIdentity where
- (==) = (==) `on` (idData &&& idUpdates)
+instance Eq (m (Stored (Signed IdentityData))) => Eq (Identity m) where
+ (==) = (==) `on` (idData_ &&& idUpdates_)
data IdentityData = IdentityData
{ iddPrev :: [Stored (Signed IdentityData)]
@@ -79,6 +79,11 @@ instance Storable IdentityData where
<*> loadRef "key-id"
<*> loadMbRef "key-msg"
+instance Mergeable (Maybe ComposedIdentity) where
+ type Component (Maybe ComposedIdentity) = Signed IdentityData
+ mergeSorted = validateIdentityF
+ toComponents = maybe [] idDataF
+
idData :: UnifiedIdentity -> Stored (Signed IdentityData)
idData = I.runIdentity . idDataF
diff --git a/src/Main.hs b/src/Main.hs
index 7fb6ff3..d764fe0 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -286,7 +286,7 @@ cmdHistory = void $ do
let powner = finalOwner pid
case find (sameIdentity powner . msgPeer) $
- messageThreadView $ lookupSharedValue $ lsShared $ headObject ehead of
+ toThreadList $ lookupSharedValue $ lsShared $ headObject ehead of
Just thread -> do
tzone <- liftIO $ getCurrentTimeZone
liftIO $ mapM_ (putStrLn . formatMessage tzone) $ reverse $ take 50 $ threadToList thread
@@ -313,7 +313,7 @@ cmdContacts :: Command
cmdContacts = do
args <- words <$> asks ciLine
ehead <- asks ciHead
- let contacts = contactView $ lookupSharedValue $ lsShared $ headObject ehead
+ let contacts = toContactList $ lookupSharedValue $ lsShared $ headObject ehead
verbose = "-v" `elem` args
forM_ (zip [1..] contacts) $ \(i :: Int, c) -> do
liftIO $ putStrLn $ show i ++ ": " ++ T.unpack (displayIdentity $ contactIdentity c) ++
diff --git a/src/Message.hs b/src/Message.hs
index 1dadc29..46d75f1 100644
--- a/src/Message.hs
+++ b/src/Message.hs
@@ -2,6 +2,9 @@ module Message (
DirectMessage(..),
sendDirectMessage,
+ DirectMessageThreads,
+ toThreadList,
+
DirectMessageThread(..),
threadToList,
messageThreadView,
@@ -56,7 +59,7 @@ instance Service DirectMessage where
tzone <- liftIO $ getCurrentTimeZone
erb <- svcGetLocal
let st = storedStorage erb
- prev = lookupSharedValue $ lsShared $ fromStored erb
+ DirectMessageThreads prev _ = lookupSharedValue $ lsShared $ fromStored erb
sent = findMsgProperty powner msSent prev
received = findMsgProperty powner msReceived prev
if powner `sameIdentity` msgFrom msg ||
@@ -70,7 +73,8 @@ instance Service DirectMessage where
, msReceived = filterAncestors $ smsg : received
, msSeen = []
}
- shared <- makeSharedStateUpdate st [next] (lsShared $ fromStored erb)
+ let threads = DirectMessageThreads [next] (messageThreadView [next])
+ shared <- makeSharedStateUpdate st threads (lsShared $ fromStored erb)
wrappedStore st (fromStored erb) { lsShared = [shared] }
svcSetLocal erb'
when (powner `sameIdentity` msgFrom msg) $ do
@@ -88,6 +92,11 @@ data MessageState = MessageState
, msSeen :: [Stored DirectMessage]
}
+data DirectMessageThreads = DirectMessageThreads [Stored MessageState] [DirectMessageThread]
+
+toThreadList :: DirectMessageThreads -> [DirectMessageThread]
+toThreadList (DirectMessageThreads _ threads) = threads
+
instance Storable MessageState where
store' ms = storeRec $ do
mapM_ (storeRef "PREV") $ msPrev ms
@@ -103,7 +112,12 @@ instance Storable MessageState where
<*> loadRefs "received"
<*> loadRefs "seen"
-instance SharedType MessageState where
+instance Mergeable DirectMessageThreads where
+ type Component DirectMessageThreads = MessageState
+ mergeSorted mss = DirectMessageThreads mss (messageThreadView mss)
+ toComponents (DirectMessageThreads mss _) = mss
+
+instance SharedType DirectMessageThreads where
sharedTypeID _ = mkSharedTypeID "ee793681-5976-466a-b0f0-4e1907d3fade"
findMsgProperty :: Foldable m => Identity m -> (MessageState -> [a]) -> [Stored MessageState] -> [a]
@@ -121,7 +135,7 @@ sendDirectMessage h peer text = do
self = headLocalIdentity h
powner = finalOwner pid
- smsg <- flip runReaderT h $ updateSharedState $ \prev -> do
+ smsg <- flip runReaderT h $ updateSharedState $ \(DirectMessageThreads prev _) -> do
let sent = findMsgProperty powner msSent prev
received = findMsgProperty powner msReceived prev
@@ -139,7 +153,7 @@ sendDirectMessage h peer text = do
, msReceived = []
, msSeen = []
}
- return ([next], smsg)
+ return (DirectMessageThreads [next] (messageThreadView [next]), smsg)
sendToPeerStored peer smsg
return smsg
diff --git a/src/State.hs b/src/State.hs
index a715f8a..358d958 100644
--- a/src/State.hs
+++ b/src/State.hs
@@ -51,7 +51,7 @@ newtype SharedTypeID = SharedTypeID UUID
mkSharedTypeID :: String -> SharedTypeID
mkSharedTypeID = maybe (error "Invalid shared type ID") SharedTypeID . U.fromString
-class Storable a => SharedType a where
+class Mergeable a => SharedType a where
sharedTypeID :: proxy a -> SharedTypeID
instance Storable LocalState where
@@ -77,7 +77,7 @@ instance Storable SharedState where
<*> loadMbUUID "type"
<*> loadRawRefs "value"
-instance SharedType (Signed IdentityData) where
+instance SharedType (Maybe ComposedIdentity) where
sharedTypeID _ = mkSharedTypeID "0c6c1fe0-f2d7-4891-926b-c332449f7871"
@@ -110,7 +110,7 @@ loadLocalStateHead st = loadHeads st >>= \case
shared <- wrappedStore st $ SharedState
{ ssPrev = []
- , ssType = Just $ sharedTypeID @(Signed IdentityData) Proxy
+ , ssType = Just $ sharedTypeID @(Maybe ComposedIdentity) Proxy
, ssValue = [storedRef $ idData $ fromMaybe identity owner]
}
storeHead st $ LocalState
@@ -122,7 +122,7 @@ headLocalIdentity :: Head LocalState -> UnifiedIdentity
headLocalIdentity h =
let ls = headObject h
in maybe (error "failed to verify local identity")
- (updateOwners (lookupSharedValue $ lsShared ls))
+ (updateOwners $ maybe [] idDataF $ lookupSharedValue $ lsShared ls)
(validateIdentity $ lsIdentity ls)
@@ -132,44 +132,42 @@ updateLocalState_ f = updateLocalState (fmap (,()) . f)
updateLocalState :: MonadHead LocalState m => (Stored LocalState -> IO (Stored LocalState, a)) -> m a
updateLocalState = updateLocalHead
-updateSharedState_ :: (SharedType a, MonadHead LocalState m) => ([Stored a] -> IO ([Stored a])) -> m ()
+updateSharedState_ :: (SharedType a, MonadHead LocalState m) => (a -> IO a) -> m ()
updateSharedState_ f = updateSharedState (fmap (,()) . f)
-updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => ([Stored a] -> IO ([Stored a], b)) -> m b
+updateSharedState :: forall a b m. (SharedType a, MonadHead LocalState m) => (a -> IO (a, b)) -> m b
updateSharedState f = updateLocalHead $ \ls -> do
let shared = lsShared $ fromStored ls
val = lookupSharedValue shared
st = storedStorage ls
(val', x) <- f val
- (,x) <$> if val' == val
+ (,x) <$> if toComponents val' == toComponents val
then return ls
else do shared' <- makeSharedStateUpdate st val' shared
wrappedStore st (fromStored ls) { lsShared = [shared'] }
-lookupSharedValue :: forall a. SharedType a => [Stored SharedState] -> [Stored a]
-lookupSharedValue = map wrappedLoad . concatMap (ssValue . fromStored) . filterAncestors . helper
+lookupSharedValue :: forall a. SharedType a => [Stored SharedState] -> a
+lookupSharedValue = mergeSorted . filterAncestors . map wrappedLoad . concatMap (ssValue . fromStored) . filterAncestors . helper
where helper (x:xs) | Just sid <- ssType (fromStored x), sid == sharedTypeID @a Proxy = x : helper xs
| otherwise = helper $ ssPrev (fromStored x) ++ xs
helper [] = []
-makeSharedStateUpdate :: forall a. SharedType a => Storage -> [Stored a] -> [Stored SharedState] -> IO (Stored SharedState)
+makeSharedStateUpdate :: forall a. SharedType a => Storage -> a -> [Stored SharedState] -> IO (Stored SharedState)
makeSharedStateUpdate st val prev = wrappedStore st SharedState
{ ssPrev = prev
, ssType = Just $ sharedTypeID @a Proxy
- , ssValue = storedRef <$> val
+ , ssValue = storedRef <$> toComponents val
}
mergeSharedIdentity :: MonadHead LocalState m => m UnifiedIdentity
-mergeSharedIdentity = updateSharedState $ \sdata -> do
- let Just cidentity = validateIdentityF sdata
+mergeSharedIdentity = updateSharedState $ \(Just cidentity) -> do
identity <- mergeIdentity cidentity
- return ([idData identity], identity)
+ return (Just $ toComposedIdentity identity, identity)
updateSharedIdentity :: MonadHead LocalState m => m ()
-updateSharedIdentity = updateSharedState_ $ \sdata -> do
- let Just identity = validateIdentityF sdata
- (:[]) . idData <$> interactiveIdentityUpdate identity
+updateSharedIdentity = updateSharedState_ $ \(Just identity) -> do
+ Just . toComposedIdentity <$> interactiveIdentityUpdate identity
interactiveIdentityUpdate :: Foldable m => Identity m -> IO UnifiedIdentity
interactiveIdentityUpdate identity = do
diff --git a/src/Storage/List.hs b/src/Storage/List.hs
index e112b46..2bef401 100644
--- a/src/Storage/List.hs
+++ b/src/Storage/List.hs
@@ -44,9 +44,6 @@ instance Storable a => Storable (List a) where
instance Storable a => ZeroStorable (List a) where
fromZero _ = ListNil
-instance Storable a => Mergeable (List a) where
- mergeSorted xs = ListItem xs Nothing Nothing
-
emptySList :: Storable a => Storage -> IO (StoredList a)
emptySList st = wrappedStore st ListNil
@@ -78,10 +75,10 @@ groupsFromSLists = helperSelect S.empty . (:[])
filterRemoved :: S.Set (StoredList a) -> [StoredList a] -> [StoredList a]
filterRemoved rs = filter (S.null . S.intersection rs . ancestors . (:[]))
-fromSList :: Mergeable a => StoredList a -> [a]
+fromSList :: Mergeable a => StoredList (Component a) -> [a]
fromSList = map merge . groupsFromSLists
-storedFromSList :: Mergeable a => StoredList a -> IO [Stored a]
+storedFromSList :: (Mergeable a, Storable a) => StoredList (Component a) -> IO [Stored a]
storedFromSList = mapM storeMerge . groupsFromSLists
slistAdd :: Storable a => a -> StoredList a -> IO (StoredList a)
diff --git a/src/Storage/Merge.hs b/src/Storage/Merge.hs
index a6ed3ba..6353dad 100644
--- a/src/Storage/Merge.hs
+++ b/src/Storage/Merge.hs
@@ -18,6 +18,7 @@ import Control.Concurrent.MVar
import qualified Data.ByteString.Char8 as BC
import qualified Data.HashTable.IO as HT
+import Data.Kind
import Data.List
import Data.Maybe
import Data.Set (Set)
@@ -29,17 +30,17 @@ import Storage
import Storage.Internal
import Util
-class Storable a => Mergeable a where
- mergeSorted :: [Stored a] -> a
+class Storable (Component a) => Mergeable a where
+ type Component a :: Type
+ mergeSorted :: [Stored (Component a)] -> a
+ toComponents :: a -> [Stored (Component a)]
-merge :: Mergeable a => [Stored a] -> a
+merge :: Mergeable a => [Stored (Component a)] -> a
merge [] = error "merge: empty list"
-merge [x] = fromStored x
merge xs = mergeSorted $ filterAncestors xs
-storeMerge :: Mergeable a => [Stored a] -> IO (Stored a)
+storeMerge :: (Mergeable a, Storable a) => [Stored (Component a)] -> IO (Stored a)
storeMerge [] = error "merge: empty list"
-storeMerge [x] = return x
storeMerge xs@(Stored ref _ : _) = wrappedStore (refStorage ref) $ mergeSorted $ filterAncestors xs
previous :: Storable a => Stored a -> [Stored a]
diff --git a/src/Test.hs b/src/Test.hs
index 8155bdb..455eed5 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -181,7 +181,7 @@ cmdCreateIdentity = do
else foldrM (\n o -> Just <$> createIdentity st (Just n) o) Nothing names
shared <- case names of
- _:_:_ -> (:[]) <$> makeSharedStateUpdate st (idDataF $ finalOwner identity) []
+ _:_:_ -> (:[]) <$> makeSharedStateUpdate st (Just $ finalOwner identity) []
_ -> return []
storeHead st $ LocalState
@@ -239,8 +239,8 @@ cmdWatchSharedIdentity = do
Nothing <- gets tsWatchedSharedIdentity
out <- asks tiOutput
- w <- liftIO $ watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \sdata -> case validateIdentityF sdata of
- Just idt -> do
+ w <- liftIO $ watchHeadWith h (lookupSharedValue . lsShared . headObject) $ \case
+ Just (idt :: ComposedIdentity) -> do
outLine out $ unwords $ "shared-identity" : map (maybe "<unnamed>" T.unpack . idName) (unfoldOwners idt)
Nothing -> do
outLine out $ "shared-identity-failed"
@@ -265,13 +265,12 @@ cmdUpdateLocalIdentity = do
cmdUpdateSharedIdentity :: Command
cmdUpdateSharedIdentity = do
[name] <- asks tiParams
- updateSharedState_ $ \sdata -> do
- let Just identity = validateIdentityF sdata
- st = storedStorage $ head sdata
+ updateSharedState_ $ \(Just identity) -> do
+ let st = storedStorage $ head $ idDataF identity
public = idKeyIdentity identity
Just secret <- loadKey public
- maybe (error "created invalid identity") (return . (:[]) . idData) . validateIdentity =<<
+ maybe (error "created invalid identity") (return . Just . toComposedIdentity) . validateIdentity =<<
wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData public)
{ iddPrev = toList $ idDataF identity
, iddName = Just name
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-07 21:17:42 +0000