src/Erebos/Object/Deferred.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
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