From b8e55c64a68763b0953945476cc75206f5354023 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Tue, 17 May 2022 22:06:01 +0200
Subject: Mergeable class with separate component type

---
 src/State.hs | 32 +++++++++++++++-----------------
 1 file changed, 15 insertions(+), 17 deletions(-)

(limited to 'src/State.hs')

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
-- 
cgit v1.2.3