Mergeable class with separate component type

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