blob: 9be59c2ce4d5315dd8c823b2f0ba4dd540235cac (
plain)
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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
module Storage.Cache (
cacheStorage,
) where
import Control.Concurrent
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as BL
import Data.Function
import Data.Map (Map)
import Data.Map qualified as M
import Erebos.Object
import Erebos.Storage.Backend
import Erebos.Storage.Head
import Storage.WatchList
data CacheStorage = StorageCache
{ cacheParent :: Storage
, cacheHeads :: MVar [ (( HeadTypeID, HeadID ), RefDigest ) ]
, cacheObjs :: MVar (Map RefDigest BL.ByteString)
, cacheKeys :: MVar (Map RefDigest B.ByteString)
, cacheWatchers :: MVar WatchList
}
instance Eq CacheStorage where
(==) = (==) `on` cacheObjs
instance Show CacheStorage where
show StorageCache {} = "cache"
instance StorageBackend CacheStorage where
backendLoadBytes StorageCache {..} dgst =
(M.lookup dgst <$> readMVar cacheObjs) >>= \case
x@Just {} -> return x
Nothing -> withStorageBackend cacheParent $ \bck -> do
backendLoadBytes bck dgst >>= \case
x@(Just raw) -> do
modifyMVar_ cacheObjs (return . M.insert dgst raw)
return x
Nothing -> return Nothing
backendStoreBytes StorageCache {..} dgst raw = do
modifyMVar_ cacheObjs (return . M.insert dgst raw)
withStorageBackend cacheParent $ \bck ->
backendStoreBytes bck dgst raw
backendLoadHeads StorageCache {..} tid = do
withStorageBackend cacheParent $ \bck ->
backendLoadHeads bck tid
backendLoadHead StorageCache {..} tid hid =
withStorageBackend cacheParent $ \bck ->
backendLoadHead bck tid hid
backendStoreHead StorageCache {..} tid hid dgst =
withStorageBackend cacheParent $ \bck ->
backendStoreHead bck tid hid dgst
backendReplaceHead StorageCache {..} tid hid expected new = do
withStorageBackend cacheParent $ \bck ->
backendReplaceHead bck tid hid expected new
backendWatchHead StorageCache {..} tid hid cb = do
withStorageBackend cacheParent $ \bck ->
backendWatchHead bck tid hid cb
backendUnwatchHead StorageCache {..} wid = do
withStorageBackend cacheParent $ \bck ->
backendUnwatchHead bck wid
backendListKeys StorageCache {..} = do
withStorageBackend cacheParent $ \bck ->
backendListKeys bck
backendLoadKey StorageCache {..} dgst = do
withStorageBackend cacheParent $ \bck ->
backendLoadKey bck dgst
backendStoreKey StorageCache {..} dgst key = do
withStorageBackend cacheParent $ \bck ->
backendStoreKey bck dgst key
backendRemoveKey StorageCache {..} dgst = do
withStorageBackend cacheParent $ \bck ->
backendRemoveKey bck dgst
cacheStorage :: Storage -> IO Storage
cacheStorage cacheParent = do
cacheHeads <- newMVar []
cacheObjs <- newMVar M.empty
cacheKeys <- newMVar M.empty
cacheWatchers <- newMVar (WatchList startWatchID [])
newStorage $ StorageCache {..}
|