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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

module Erebos.Object.Deferred (
    Deferred,
    DeferredSize(..),
    DeferredResult(..),

    deferredRef,
    deferredLoad,

    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


data Deferred a = Deferred
    { deferredRef_ :: RefDigest
    , deferredSize :: DeferredSize
    , deferredServer :: Server
    , deferredPeers :: [ RefDigest ]
    }

data DeferredSize
    = DeferredExactSize Word64
    | DeferredMaximumSize Word64

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
            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 mvar

deferLoadWithServer :: Storable a => RefDigest -> DeferredSize -> Server -> [ RefDigest ] -> IO (Deferred a)
deferLoadWithServer deferredRef_ deferredSize deferredServer deferredPeers = return Deferred {..}


identityDigests :: Foldable f => Identity f -> [ RefDigest ]
identityDigests pid = map (refDigest . storedRef) $ idDataF =<< unfoldOwners pid