Deferred object loading

1 files changed, 57 insertions, 0 deletions

diff --git a/src/Erebos/Object/Deferred.hs b/src/Erebos/Object/Deferred.hs
new file mode 100644
index 0000000..1faa85b
--- /dev/null
+++ b/src/Erebos/Object/Deferred.hs
@@ -0,0 +1,57 @@
+module Erebos.Object.Deferred (
+    Deferred,
+    DeferredResult(..),
+
+    deferredRef,
+    deferredLoad,
+
+    deferLoadWithServer,
+) where
+
+import Control.Concurrent.MVar
+import Control.Monad.IO.Class
+
+import Erebos.Identity
+import Erebos.Network
+import Erebos.Object
+import Erebos.Storable
+
+
+data Deferred a = Deferred
+    { deferredRef_ :: RefDigest
+    , deferredServer :: Server
+    , deferredPeers :: [ RefDigest ]
+    }
+
+data DeferredResult a
+    = DeferredLoaded (Stored a)
+    | DeferredInvalid
+    | DeferredFailed
+
+deferredRef :: Deferred a -> RefDigest
+deferredRef = deferredRef_
+
+deferredLoad :: MonadIO m => Storable a => Deferred a -> m (MVar (DeferredResult a))
+deferredLoad Deferred {..} = liftIO $ do
+    mvar <- newEmptyMVar
+    let matchPeer peer =
+            getPeerIdentity peer >>= \case
+                PeerIdentityFull pid -> do
+                    return $ any (`elem` identityDigests pid) deferredPeers
+                _ -> return False
+
+    liftIO (findPeer deferredServer matchPeer) >>= \case
+        Just peer -> do
+            requestDataFromPeer peer deferredRef_ $ liftIO . \case
+                DataRequestFulfilled ref -> putMVar mvar $ DeferredLoaded $ wrappedLoad ref
+                DataRequestRejected -> putMVar mvar DeferredFailed
+                DataRequestInvalid -> putMVar mvar DeferredInvalid
+        Nothing -> putMVar mvar DeferredFailed
+    return mvar
+
+deferLoadWithServer :: Storable a => RefDigest -> Server -> [ RefDigest ] -> IO (Deferred a)
+deferLoadWithServer deferredRef_ deferredServer deferredPeers = return Deferred {..}
+
+
+identityDigests :: Foldable f => Identity f -> [ RefDigest ]
+identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid