Shared state with arbitrary types

3 files changed, 67 insertions, 41 deletions

diff --git a/src/Attach.hs b/src/Attach.hs
index 298ed29..f3a98b3 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -224,11 +224,7 @@ finalizeAttach st identity skeys = do
         pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
         mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- skeys, pub <- pkeys ]
 
-        mshared <- mergeSharedStates (lsShared $ fromStored slocal)
-        shared <- wrappedStore st $ (fromStored mshared)
-            { ssPrev = lsShared $ fromStored slocal
-            , ssIdentity = idDataF owner
-            }
+        shared <- makeSharedStateUpdate st (idDataF owner) (lsShared $ fromStored slocal)
         wrappedStore st (fromStored slocal)
             { lsIdentity = idData identity
             , lsShared = [ shared ]
diff --git a/src/State.hs b/src/State.hs
index f3bd2d9..bb7c570 100644
--- a/src/State.hs
+++ b/src/State.hs
@@ -1,11 +1,13 @@
 module State (
     LocalState(..),
-    SharedState(..),
+    SharedState, SharedType(..),
+    SharedTypeID, mkSharedTypeID,
 
     loadLocalState, loadLocalStateHead,
     updateLocalState, updateLocalState_,
+
     updateSharedState, updateSharedState_,
-    mergeSharedStates,
+    lookupSharedValue, makeSharedStateUpdate,
 
     loadLocalIdentity, headLocalIdentity,
 
@@ -17,10 +19,12 @@ module State (
 import Control.Monad
 
 import Data.Foldable
-import Data.List
 import Data.Maybe
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
+import Data.Typeable
+import Data.UUID (UUID)
+import qualified Data.UUID as U
 
 import System.IO
 
@@ -29,7 +33,7 @@ import Message
 import PubKey
 import Storage
 import Storage.List
-import Util
+import Storage.Merge
 
 data LocalState = LocalState
     { lsIdentity :: Stored (Signed IdentityData)
@@ -39,9 +43,19 @@ data LocalState = LocalState
 
 data SharedState = SharedState
     { ssPrev :: [Stored SharedState]
-    , ssIdentity :: [Stored (Signed IdentityData)]
+    , ssType :: Maybe SharedTypeID
+    , ssValue :: [Ref]
     }
 
+newtype SharedTypeID = SharedTypeID UUID
+    deriving (Eq, Ord, StorableUUID)
+
+mkSharedTypeID :: String -> SharedTypeID
+mkSharedTypeID = maybe (error "Invalid shared type ID") SharedTypeID . U.fromString
+
+class Storable a => SharedType a where
+    sharedTypeID :: proxy a -> SharedTypeID
+
 instance Storable LocalState where
     store' st = storeRec $ do
         storeRef "id" $ lsIdentity st
@@ -56,11 +70,16 @@ instance Storable LocalState where
 instance Storable SharedState where
     store' st = storeRec $ do
         mapM_ (storeRef "PREV") $ ssPrev st
-        mapM_ (storeRef "id") $ ssIdentity st
+        storeMbUUID "type" $ ssType st
+        mapM_ (storeRawRef "value") $ ssValue st
 
     load' = loadRec $ SharedState
         <$> loadRefs "PREV"
-        <*> loadRefs "id"
+        <*> loadMbUUID "type"
+        <*> loadRawRefs "value"
+
+instance SharedType (Signed IdentityData) where
+    sharedTypeID _ = mkSharedTypeID "0c6c1fe0-f2d7-4891-926b-c332449f7871"
 
 
 loadLocalState :: Storage -> IO (Stored LocalState)
@@ -99,7 +118,8 @@ loadLocalStateHead st = loadHeadDef st "erebos" $ do
 
     shared <- wrappedStore st $ SharedState
         { ssPrev = []
-        , ssIdentity = [fromMaybe identity owner]
+        , ssType = Just $ sharedTypeID @(Signed IdentityData) Proxy
+        , ssValue = [storedRef $ fromMaybe identity owner]
         }
     return $ LocalState
         { lsIdentity = identity
@@ -114,7 +134,7 @@ headLocalIdentity :: Head -> UnifiedIdentity
 headLocalIdentity h =
     let ls = load $ headRef h
      in maybe (error "failed to verify local identity")
-            (updateOwners (ssIdentity . fromStored =<< lsShared ls))
+            (updateOwners (lookupSharedValue $ lsShared ls))
             (validateIdentity $ lsIdentity ls)
 
 
@@ -122,43 +142,53 @@ updateLocalState_ :: Storage -> (Stored LocalState -> IO (Stored LocalState)) ->
 updateLocalState_ st f = updateLocalState st (fmap (,()) . f)
 
 updateLocalState :: Storage -> (Stored LocalState -> IO (Stored LocalState, a)) -> IO a
-updateLocalState ls f = do
-    Just erebosHead <- loadHead ls "erebos"
-    (st, x) <- f $ wrappedLoad (headRef erebosHead)
-    Right _ <- replaceHead st (Right erebosHead)
+updateLocalState st f = do
+    Just erebosHead <- loadHead st "erebos"
+    let ls = wrappedLoad (headRef erebosHead)
+    (ls', x) <- f ls
+    when (ls' /= ls) $ do
+        Right _ <- replaceHead ls' (Right erebosHead)
+        return ()
     return x
 
-updateSharedState_ :: Storage -> (Stored SharedState -> IO (Stored SharedState)) -> IO ()
+
+updateSharedState_ :: SharedType a => Storage -> ([Stored a] -> IO ([Stored a])) -> IO ()
 updateSharedState_ st f = updateSharedState st (fmap (,()) . f)
 
-updateSharedState :: Storage -> (Stored SharedState -> IO (Stored SharedState, a)) -> IO a
+updateSharedState :: forall a b. SharedType a => Storage -> ([Stored a] -> IO ([Stored a], b)) -> IO b
 updateSharedState st f = updateLocalState st $ \ls -> do
-    (shared, x) <- f =<< mergeSharedStates (lsShared $ fromStored ls)
-    (,x) <$> wrappedStore st (fromStored ls) { lsShared = [shared] }
-
-mergeSharedStates :: [(Stored SharedState)] -> IO (Stored SharedState)
-mergeSharedStates [s] = return s
-mergeSharedStates ss@(s:_) = wrappedStore (storedStorage s) $ SharedState
-        { ssPrev = ss
-        , ssIdentity = uniq $ sort $ concatMap (ssIdentity . fromStored) $ ss -- TODO: ancestor elimination
-        }
-mergeSharedStates [] = error "mergeSharedStates: empty list"
+    let shared = lsShared $ fromStored ls
+        val = lookupSharedValue shared
+    (val', x) <- f val
+    (,x) <$> if val' == 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
+    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 st val prev = wrappedStore st SharedState
+    { ssPrev = prev
+    , ssType = Just $ sharedTypeID @a Proxy
+    , ssValue = storedRef <$> val
+    }
 
 
 mergeSharedIdentity :: Storage -> IO UnifiedIdentity
-mergeSharedIdentity st = updateSharedState st $ \sshared -> do
-    let shared = fromStored sshared
-        Just cidentity = validateIdentityF $ ssIdentity shared
+mergeSharedIdentity st = updateSharedState st $ \sdata -> do
+    let Just cidentity = validateIdentityF sdata
     identity <- mergeIdentity cidentity
-    sshared' <- wrappedStore st $ shared { ssIdentity = [idData identity] }
-    return (sshared', identity)
+    return ([idData identity], identity)
 
 updateSharedIdentity :: Storage -> IO ()
-updateSharedIdentity st = updateSharedState_ st $ \sshared -> do
-    let shared = fromStored sshared
-        Just identity = validateIdentityF $ ssIdentity shared
-    identity' <- interactiveIdentityUpdate identity
-    wrappedStore st shared { ssIdentity = [idData identity'] }
+updateSharedIdentity st = updateSharedState_ st $ \sdata -> do
+    let Just identity = validateIdentityF sdata
+    (:[]) . idData <$> interactiveIdentityUpdate identity
 
 interactiveIdentityUpdate :: Foldable m => Identity m -> IO UnifiedIdentity
 interactiveIdentityUpdate identity = do
diff --git a/src/Storage.hs b/src/Storage.hs
index a9a5e3a..2e78c2f 100644
--- a/src/Storage.hs
+++ b/src/Storage.hs
@@ -32,7 +32,7 @@ module Storage (
     loadBlob, loadRec, loadZero,
     loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadJson, loadRef, loadRawRef,
     loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbJson, loadMbRef, loadMbRawRef,
-    loadBinaries, loadRefs,
+    loadBinaries, loadRefs, loadRawRefs,
     loadZRef,
 
     Stored,