1 files changed, 108 insertions, 0 deletions
diff --git a/src/Erebos/Object/Deferred.hs b/src/Erebos/Object/Deferred.hs
new file mode 100644
index 0000000..31ff0f9
--- /dev/null
+++ b/src/Erebos/Object/Deferred.hs
@@ -0,0 +1,108 @@
+module Erebos.Object.Deferred (
+    Deferred,
+    DeferredSize(..),
+    DeferredResult(..),
+
+    deferredRef,
+    deferredLoad,
+    deferredWait,
+    deferredCheck,
+
+    deferLoadWithServer,
+) where
+
+import Control.Concurrent.MVar
+import Control.Monad.IO.Class
+
+import Data.Word
+
+import Erebos.Identity
+import Erebos.Network
+import Erebos.Object
+import Erebos.Storable
+
+
+-- | Deffered value, which can be loaded on request. Holds a reference (digest)
+-- to an object and information about suitable network peers, from which the
+-- data can be requested.
+data Deferred a = Deferred
+    { deferredRef_ :: RefDigest
+    , deferredSize :: DeferredSize
+    , deferredServer :: Server
+    , deferredPeers :: [ RefDigest ]
+    , deferredStatus :: MVar (Maybe (MVar (DeferredResult a)))
+    }
+
+-- | Size constraint for the deferred object.
+data DeferredSize
+    = DeferredExactSize Word64 -- ^ Component size of the referred data must be exactly the given value.
+    | DeferredMaximumSize Word64 -- ^ Component size of the referred data must not exceed the given value.
+
+-- | Result of the deferred load request.
+data DeferredResult a
+    = DeferredLoaded (Stored a) -- ^ Deferred object was sucessfully loaded.
+    | DeferredInvalid -- ^ Deferred object was (partially) loaded, but failed to meet the size constraint or was an invalid object.
+    | DeferredFailed -- ^ Failure to load the object, e.g. no suitable peer was found.
+
+-- | Get the digest of the deferred object.
+deferredRef :: Deferred a -> RefDigest
+deferredRef = deferredRef_
+
+-- | Request the deferred object to be loaded. Does nothing if that was already
+-- requested before. The result can be received using `deferredWait` or
+-- `deferredCheck` functions.
+deferredLoad :: (Storable a, MonadIO m) => Deferred a -> m ()
+deferredLoad Deferred {..} = liftIO $ do
+    modifyMVar_ deferredStatus $ \case
+        Nothing -> 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
+                    let bound = case deferredSize of
+                            DeferredExactSize s -> s
+                            DeferredMaximumSize s -> s
+
+                        checkSize ref = case deferredSize of
+                            DeferredExactSize s -> componentSize ref == s
+                            DeferredMaximumSize s -> componentSize ref <= s
+
+                    requestDataFromPeer peer deferredRef_ bound $ liftIO . \case
+                        DataRequestFulfilled ref
+                            | checkSize ref -> putMVar mvar $ DeferredLoaded $ wrappedLoad ref
+                            | otherwise -> putMVar mvar DeferredInvalid
+                        DataRequestRejected -> putMVar mvar DeferredFailed
+                        DataRequestBrokenBound -> putMVar mvar DeferredInvalid
+
+                Nothing -> putMVar mvar DeferredFailed
+            return $ Just mvar
+        cur@Just {} -> return cur
+
+-- | Wait for a `Deferred` value to be loaded and return the result. Requests
+-- the value to be loaded if that was not already done.
+deferredWait :: (Storable a, MonadIO m) => Deferred a -> m (DeferredResult a)
+deferredWait d@Deferred {..} = liftIO $ readMVar deferredStatus >>= \case
+    Nothing -> deferredLoad d >> deferredWait d
+    Just mvar -> readMVar mvar
+
+-- | Check if a `Deferred` value has already been loaded and return it in
+-- `Just` if so, otherwise return `Nothing`. Requests the value to be loaded if
+-- that was not already done.
+deferredCheck :: (Storable a, MonadIO m) => Deferred a -> m (Maybe (DeferredResult a))
+deferredCheck d@Deferred {..} = liftIO $ readMVar deferredStatus >>= \case
+    Nothing -> deferredLoad d >> deferredCheck d
+    Just mvar -> tryReadMVar mvar
+
+deferLoadWithServer :: (Storable a, MonadIO m) => RefDigest -> DeferredSize -> Server -> [ RefDigest ] -> m (Deferred a)
+deferLoadWithServer deferredRef_ deferredSize deferredServer deferredPeers = do
+    deferredStatus <- liftIO $ newMVar Nothing
+    return Deferred {..}
+
+
+identityDigests :: Foldable f => Identity f -> [ RefDigest ]
+identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid