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
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
module Erebos.Storage.Internal (
Storage'(..), Storage, PartialStorage,
RefDigest(..),
WatchID, startWatchID, nextWatchID,
WatchList(..), WatchListItem(..), watchListAdd, watchListDel,
refDigestFromByteString,
showRefDigest, showRefDigestParts,
readRefDigest,
hashToRefDigest,
StorageCompleteness(..),
StorageBackend(..),
Complete, Partial,
ioLoadBytesFromStorage,
Generation(..),
HeadID(..), HeadTypeID(..),
) where
import Control.Arrow
import Control.Concurrent
import Control.DeepSeq
import Control.Monad.Identity
import Crypto.Hash
import Data.Bits
import Data.ByteArray (ByteArrayAccess, ScrubbedBytes)
import Data.ByteArray qualified as BA
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BC
import Data.ByteString.Lazy qualified as BL
import Data.HashTable.IO qualified as HT
import Data.Hashable
import Data.Kind
import Data.Typeable
import Foreign.Storable (peek)
import System.IO.Unsafe (unsafePerformIO)
import Erebos.UUID (UUID)
import Erebos.Util
data Storage' c = forall bck. (StorageBackend bck, BackendCompleteness bck ~ c) => Storage
{ stBackend :: bck
, stRefGeneration :: MVar (HT.BasicHashTable RefDigest Generation)
, stRefRoots :: MVar (HT.BasicHashTable RefDigest [RefDigest])
}
type Storage = Storage' Complete
type PartialStorage = Storage' Partial
instance Eq (Storage' c) where
Storage { stBackend = b } == Storage { stBackend = b' }
| Just b'' <- cast b' = b == b''
| otherwise = False
instance Show (Storage' c) where
show Storage { stBackend = b } = show b ++ showParentStorage b
showParentStorage :: StorageBackend bck => bck -> String
showParentStorage bck
| Just (st :: Storage) <- cast (backendParent bck) = "@" ++ show st
| Just (st :: PartialStorage) <- cast (backendParent bck) = "@" ++ show st
| otherwise = ""
class (Eq bck, Show bck, Typeable bck, Typeable (BackendParent bck)) => StorageBackend bck where
type BackendCompleteness bck :: Type -> Type
type BackendCompleteness bck = Complete
type BackendParent bck :: Type
type BackendParent bck = ()
backendParent :: bck -> BackendParent bck
default backendParent :: BackendParent bck ~ () => bck -> BackendParent bck
backendParent _ = ()
backendLoadBytes :: bck -> RefDigest -> IO (Maybe BL.ByteString)
default backendLoadBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe BL.ByteString)
backendLoadBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadBytes bck'
backendStoreBytes :: bck -> RefDigest -> BL.ByteString -> IO ()
default backendStoreBytes :: BackendParent bck ~ Storage => bck -> RefDigest -> BL.ByteString -> IO ()
backendStoreBytes bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreBytes bck'
backendLoadHeads :: bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ]
default backendLoadHeads :: BackendParent bck ~ Storage => bck -> HeadTypeID -> IO [ ( HeadID, RefDigest ) ]
backendLoadHeads bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHeads bck'
backendLoadHead :: bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest)
default backendLoadHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> IO (Maybe RefDigest)
backendLoadHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadHead bck'
backendStoreHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> IO ()
default backendStoreHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> IO ()
backendStoreHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreHead bck'
backendReplaceHead :: bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest)
default backendReplaceHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> RefDigest -> RefDigest -> IO (Either (Maybe RefDigest) RefDigest)
backendReplaceHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendReplaceHead bck'
backendWatchHead :: bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID
default backendWatchHead :: BackendParent bck ~ Storage => bck -> HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> IO WatchID
backendWatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendWatchHead bck'
backendUnwatchHead :: bck -> WatchID -> IO ()
default backendUnwatchHead :: BackendParent bck ~ Storage => bck -> WatchID -> IO ()
backendUnwatchHead bck = case backendParent bck of Storage { stBackend = bck' } -> backendUnwatchHead bck'
backendListKeys :: bck -> IO [ RefDigest ]
default backendListKeys :: BackendParent bck ~ Storage => bck -> IO [ RefDigest ]
backendListKeys bck = case backendParent bck of Storage { stBackend = bck' } -> backendListKeys bck'
backendLoadKey :: bck -> RefDigest -> IO (Maybe ScrubbedBytes)
default backendLoadKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO (Maybe ScrubbedBytes)
backendLoadKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendLoadKey bck'
backendStoreKey :: bck -> RefDigest -> ScrubbedBytes -> IO ()
default backendStoreKey :: BackendParent bck ~ Storage => bck -> RefDigest -> ScrubbedBytes -> IO ()
backendStoreKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendStoreKey bck'
backendRemoveKey :: bck -> RefDigest -> IO ()
default backendRemoveKey :: BackendParent bck ~ Storage => bck -> RefDigest -> IO ()
backendRemoveKey bck = case backendParent bck of Storage { stBackend = bck' } -> backendRemoveKey bck'
newtype WatchID = WatchID Int
deriving (Eq, Ord)
startWatchID :: WatchID
startWatchID = WatchID 1
nextWatchID :: WatchID -> WatchID
nextWatchID (WatchID n) = WatchID (n + 1)
data WatchList = WatchList
{ wlNext :: WatchID
, wlList :: [ WatchListItem ]
}
data WatchListItem = WatchListItem
{ wlID :: WatchID
, wlHead :: ( HeadTypeID, HeadID )
, wlFun :: RefDigest -> IO ()
}
watchListAdd :: HeadTypeID -> HeadID -> (RefDigest -> IO ()) -> WatchList -> ( WatchList, WatchID )
watchListAdd tid hid cb wl = ( wl', wlNext wl )
where
wl' = wl
{ wlNext = nextWatchID (wlNext wl)
, wlList = WatchListItem
{ wlID = wlNext wl
, wlHead = (tid, hid)
, wlFun = cb
} : wlList wl
}
watchListDel :: WatchID -> WatchList -> WatchList
watchListDel wid wl = wl { wlList = filter ((/= wid) . wlID) $ wlList wl }
newtype RefDigest = RefDigest (Digest Blake2b_256)
deriving (Eq, Ord, NFData, ByteArrayAccess)
instance Show RefDigest where
show = BC.unpack . showRefDigest
instance Hashable RefDigest where
hashWithSalt salt ref = salt `xor` unsafePerformIO (BA.withByteArray ref peek)
showRefDigestParts :: RefDigest -> (ByteString, ByteString)
showRefDigestParts x = (BC.pack "blake2", showHex x)
showRefDigest :: RefDigest -> ByteString
showRefDigest = showRefDigestParts >>> \(alg, hex) -> alg <> BC.pack "#" <> hex
readRefDigest :: ByteString -> Maybe RefDigest
readRefDigest x = case BC.split '#' x of
[alg, dgst] | BA.convert alg == BC.pack "blake2" ->
refDigestFromByteString =<< readHex dgst
_ -> Nothing
refDigestFromByteString :: ByteString -> Maybe RefDigest
refDigestFromByteString = fmap RefDigest . digestFromByteString
hashToRefDigest :: BL.ByteString -> RefDigest
hashToRefDigest = RefDigest . hashFinalize . hashUpdates hashInit . BL.toChunks
newtype Generation = Generation Int
deriving (Eq, Show)
-- | UUID of individual Erebos storage head.
newtype HeadID = HeadID UUID
deriving (Eq, Ord, Show)
-- | UUID of Erebos storage head type.
newtype HeadTypeID = HeadTypeID UUID
deriving (Eq, Ord)
type Complete = Identity
type Partial = Either RefDigest
class (Traversable compl, Monad compl, Typeable compl) => StorageCompleteness compl where
type LoadResult compl a :: Type
returnLoadResult :: compl a -> LoadResult compl a
unsafeLoadBytes :: Storage' compl -> RefDigest -> IO (compl BL.ByteString)
instance StorageCompleteness Complete where
type LoadResult Complete a = a
returnLoadResult = runIdentity
unsafeLoadBytes st dgst = maybe (error $ "Ref not found in complete storage: "++show dgst) Identity
<$> ioLoadBytesFromStorage st dgst
instance StorageCompleteness Partial where
type LoadResult Partial a = Either RefDigest a
returnLoadResult = id
unsafeLoadBytes st dgst = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst
ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString)
ioLoadBytesFromStorage Storage {..} dgst =
backendLoadBytes stBackend dgst >>= \case
Just bytes -> return $ Just bytes
Nothing
| Just (parent :: Storage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst
| Just (parent :: PartialStorage) <- cast (backendParent stBackend) -> ioLoadBytesFromStorage parent dgst
| otherwise -> return Nothing
|