Skip to content

Commit b24a324

Browse files
dcouttsdcoutts
authored
Merge pull request #9 from input-output-hk/model-io
Model IO
2 parents 93a2cf6 + 3cbb97f commit b24a324

File tree

9 files changed

+540
-2
lines changed

9 files changed

+540
-2
lines changed

‎lsm-tree.cabal

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -62,10 +62,14 @@ test-suite lsm-tree-test
6262
hs-source-dirs: test
6363
main-is: Main.hs
6464
other-modules:
65+
Database.LSMTree.ModelIO.Normal
66+
Database.LSMTree.ModelIO.Session
6567
Test.Database.LSMTree
6668
Test.Database.LSMTree.Common
6769
Test.Database.LSMTree.Model.Monoidal
6870
Test.Database.LSMTree.Model.Normal
71+
Test.Database.LSMTree.ModelIO.Class
72+
Test.Database.LSMTree.ModelIO.Normal
6973
Test.Database.LSMTree.Normal.StateMachine
7074
Test.Database.LSMTree.Normal.StateMachine.Op
7175
Test.Util.Orphans

‎src/Database/LSMTree/Common.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE FlexibleContexts #-}
12
{-# LANGUAGE StandaloneKindSignatures #-}
23

34
-- TODO: remove once the API is implemented.
@@ -22,6 +23,7 @@ module Database.LSMTree.Common (
2223
) where
2324

2425
import Control.Concurrent.Class.MonadMVar (MonadMVar)
26+
import Control.Concurrent.Class.MonadSTM (MonadSTM, STM)
2527
import Control.Monad.Class.MonadThrow (MonadCatch, MonadThrow)
2628
import Data.Bits (shiftR, (.&.))
2729
import qualified Data.ByteString as BS
@@ -36,7 +38,7 @@ import System.FS.API (FsPath, SomeHasFS)
3638
-------------------------------------------------------------------------------}
3739

3840
-- | Utility class for grouping @io-classes@ constraints.
39-
class (MonadMVar m, MonadThrow m, MonadCatch m) => IOLike m where
41+
class (MonadMVar m, MonadSTM m, MonadThrow (STM m), MonadThrow m, MonadCatch m) => IOLike m where
4042
instance IOLike IO
4143

4244
{-------------------------------------------------------------------------------

‎test/Database/LSMTree/ModelIO/Normal.hs

Lines changed: 290 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,290 @@
1+
{-# LANGUAGE ConstraintKinds #-}
2+
{-# LANGUAGE GADTs #-}
3+
{-# LANGUAGE RecordWildCards #-}
4+
{-# LANGUAGE ScopedTypeVariables #-}
5+
{-# LANGUAGE StandaloneDeriving #-}
6+
{-# LANGUAGE StandaloneKindSignatures #-}
7+
{-# LANGUAGE TupleSections #-}
8+
{-# LANGUAGE TypeApplications #-}
9+
10+
-- Model's 'open' and 'snapshot' have redundant constraints.
11+
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
12+
13+
-- | IO-based model implementation.
14+
--
15+
-- Differences from the (current) real API:
16+
--
17+
-- * `newSession` doesn't take file-system arguments.
18+
--
19+
-- * `snapshot` and `open` require `Typeable` constraints
20+
--
21+
module Database.LSMTree.ModelIO.Normal (
22+
-- * Temporary placeholder types
23+
Model.SomeSerialisationConstraint (..)
24+
-- * Utility types
25+
, IOLike
26+
-- * Sessions
27+
, Session
28+
, newSession
29+
, closeSession
30+
-- * Tables
31+
, TableHandle
32+
, TableConfig (..)
33+
, new
34+
, close
35+
-- * Table querying and updates
36+
-- ** Queries
37+
, Model.Range (..)
38+
, Model.LookupResult (..)
39+
, lookups
40+
, Model.RangeLookupResult (..)
41+
, rangeLookup
42+
-- ** Updates
43+
, Model.Update (..)
44+
, updates
45+
, inserts
46+
, deletes
47+
-- ** Blobs
48+
, Model.BlobRef
49+
, retrieveBlobs
50+
-- * Snapshots
51+
, SnapshotName
52+
, snapshot
53+
, open
54+
-- * Multiple writable table handles
55+
, duplicate
56+
) where
57+
58+
import Control.Concurrent.Class.MonadSTM
59+
import Control.Monad (unless, void)
60+
import Data.Dynamic (fromDynamic, toDyn)
61+
import Data.Kind (Type)
62+
import qualified Data.Map.Strict as Map
63+
import Data.Typeable (Typeable)
64+
import Database.LSMTree.Common (IOLike, SnapshotName,
65+
SomeSerialisationConstraint)
66+
import qualified Database.LSMTree.Model.Normal as Model
67+
import Database.LSMTree.ModelIO.Session
68+
import Database.LSMTree.Normal (LookupResult (..),
69+
RangeLookupResult (..), Update (..))
70+
import GHC.IO.Exception (IOErrorType (..), IOException (..))
71+
72+
{-------------------------------------------------------------------------------
73+
Tables
74+
-------------------------------------------------------------------------------}
75+
76+
-- | A handle to a table.
77+
type TableHandle :: (Type -> Type) -> Type -> Type -> Type -> Type
78+
data TableHandle m k v blob = TableHandle {
79+
thSession :: !(Session m)
80+
, thId :: !Int
81+
, thRef :: !(TMVar m (Model.Table k v blob))
82+
}
83+
84+
data TableConfig = TableConfig
85+
86+
-- | Configs should be comparable, because only tables with the same config
87+
-- options are __compatible__.
88+
deriving instance Eq TableConfig
89+
90+
-- | Create a new table referenced by a table handle.
91+
new ::
92+
IOLike m
93+
=> Session m
94+
-> TableConfig
95+
-> m (TableHandle m k v blob)
96+
new session _config = atomically $ do
97+
ref <- newTMVar Model.empty
98+
i <- new_handle session ref
99+
return TableHandle {thSession = session, thId = i, thRef = ref }
100+
101+
-- | Close a table handle.
102+
close ::
103+
IOLike m
104+
=> TableHandle m k v blob
105+
-> m ()
106+
close TableHandle {..} = atomically $ do
107+
close_handle thSession thId
108+
void $ tryTakeTMVar thRef
109+
110+
{-------------------------------------------------------------------------------
111+
Table querying and updates
112+
-------------------------------------------------------------------------------}
113+
114+
-- | Perform a batch of lookups.
115+
lookups ::
116+
(IOLike m, SomeSerialisationConstraint k, SomeSerialisationConstraint v)
117+
=> [k]
118+
-> TableHandle m k v blob
119+
-> m [LookupResult k v (Model.BlobRef blob)]
120+
lookups ks TableHandle {..} = atomically $
121+
withModel "lookups" thSession thRef $ \tbl ->
122+
return $ Model.lookups ks tbl
123+
124+
-- | Perform a range lookup.
125+
rangeLookup ::
126+
(IOLike m, SomeSerialisationConstraint k, SomeSerialisationConstraint v)
127+
=> Model.Range k
128+
-> TableHandle m k v blob
129+
-> m [RangeLookupResult k v (Model.BlobRef blob)]
130+
rangeLookup r TableHandle {..} = atomically $
131+
withModel "rangeLookup" thSession thRef $ \tbl ->
132+
return $ Model.rangeLookup r tbl
133+
134+
-- | Perform a mixed batch of inserts and deletes.
135+
updates ::
136+
( IOLike m
137+
, SomeSerialisationConstraint k
138+
, SomeSerialisationConstraint v
139+
, SomeSerialisationConstraint blob
140+
)
141+
=> [(k, Update v blob)]
142+
-> TableHandle m k v blob
143+
-> m ()
144+
updates ups TableHandle {..} = atomically $
145+
withModel "updates" thSession thRef $ \tbl ->
146+
writeTMVar thRef $ Model.updates ups tbl
147+
148+
149+
-- | Perform a batch of inserts.
150+
inserts ::
151+
( IOLike m
152+
, SomeSerialisationConstraint k
153+
, SomeSerialisationConstraint v
154+
, SomeSerialisationConstraint blob
155+
)
156+
=> [(k, v, Maybe blob)]
157+
-> TableHandle m k v blob
158+
-> m ()
159+
inserts = updates . fmap (\(k, v, blob) -> (k, Model.Insert v blob))
160+
161+
-- | Perform a batch of deletes.
162+
deletes ::
163+
( IOLike m
164+
, SomeSerialisationConstraint k
165+
, SomeSerialisationConstraint v
166+
, SomeSerialisationConstraint blob
167+
)
168+
=> [k]
169+
-> TableHandle m k v blob
170+
-> m ()
171+
deletes = updates . fmap (,Model.Delete)
172+
173+
-- | Perform a batch of blob retrievals.
174+
retrieveBlobs ::
175+
(IOLike m, SomeSerialisationConstraint blob)
176+
=> TableHandle m k v blob
177+
-> [Model.BlobRef blob]
178+
-> m [blob]
179+
retrieveBlobs TableHandle {..} brefs = atomically $
180+
withModel "retrieveBlobs" thSession thRef $ \tbl ->
181+
return $ Model.retrieveBlobs tbl brefs
182+
183+
{-------------------------------------------------------------------------------
184+
Snapshots
185+
-------------------------------------------------------------------------------}
186+
187+
-- | Take a snapshot.
188+
snapshot ::
189+
( IOLike m
190+
, SomeSerialisationConstraint k
191+
, SomeSerialisationConstraint v
192+
, SomeSerialisationConstraint blob
193+
, Typeable k
194+
, Typeable v
195+
, Typeable blob
196+
)
197+
=> SnapshotName
198+
-> TableHandle m k v blob
199+
-> m ()
200+
snapshot n TableHandle {..} = atomically $
201+
withModel "snapshot" thSession thRef $ \tbl ->
202+
modifyTVar' (snapshots thSession) (Map.insert n (toDyn tbl))
203+
204+
-- | Open a table through a snapshot, returning a new table handle.
205+
open ::
206+
( IOLike m
207+
, SomeSerialisationConstraint k
208+
, SomeSerialisationConstraint v
209+
, SomeSerialisationConstraint blob
210+
, Typeable k
211+
, Typeable v
212+
, Typeable blob
213+
)
214+
=> Session m
215+
-> SnapshotName
216+
-> m (TableHandle m k v blob)
217+
open s n = atomically $ do
218+
ss <- readTVar (snapshots s)
219+
case Map.lookup n ss of
220+
Nothing -> throwSTM IOError
221+
{ ioe_handle = Nothing
222+
, ioe_type = NoSuchThing
223+
, ioe_location = "open"
224+
, ioe_description = "no such snapshotd"
225+
, ioe_errno = Nothing
226+
, ioe_filename = Nothing
227+
}
228+
229+
Just dyn -> case fromDynamic dyn of
230+
Nothing -> throwSTM IOError
231+
{ ioe_handle = Nothing
232+
, ioe_type = InappropriateType
233+
, ioe_location = "open"
234+
, ioe_description = "table type mismatch"
235+
, ioe_errno = Nothing
236+
, ioe_filename = Nothing
237+
}
238+
239+
Just tbl' -> do
240+
ref <- newTMVar tbl'
241+
i <- new_handle s ref
242+
return TableHandle { thRef = ref, thId = i, thSession = s }
243+
244+
{-------------------------------------------------------------------------------
245+
Mutiple writable table handles
246+
-------------------------------------------------------------------------------}
247+
248+
-- | Create a cheap, independent duplicate of a table handle. This returns a new
249+
-- table handle.
250+
duplicate ::
251+
IOLike m
252+
=> TableHandle m k v blob
253+
-> m (TableHandle m k v blob)
254+
duplicate TableHandle {..} = atomically $
255+
withModel "duplicate" thSession thRef $ \tbl -> do
256+
thRef' <- newTMVar tbl
257+
i <- new_handle thSession thRef'
258+
return TableHandle { thRef = thRef', thId = i, thSession = thSession }
259+
260+
{-------------------------------------------------------------------------------
261+
Internal helpers
262+
-------------------------------------------------------------------------------}
263+
264+
withModel :: IOLike m => String -> Session m -> TMVar m a -> (a -> STM m r) -> STM m r
265+
withModel fun s ref kont = do
266+
m <- tryReadTMVar ref
267+
case m of
268+
Nothing -> throwSTM IOError
269+
{ ioe_handle = Nothing
270+
, ioe_type = IllegalOperation
271+
, ioe_location = fun
272+
, ioe_description = "table handle closed"
273+
, ioe_errno = Nothing
274+
, ioe_filename = Nothing
275+
}
276+
Just m' -> do
277+
sok <- readTVar (session_open s)
278+
unless sok $ throwSTM IOError
279+
{ ioe_handle = Nothing
280+
, ioe_type = IllegalOperation
281+
, ioe_location = fun
282+
, ioe_description = "session closed"
283+
, ioe_errno = Nothing
284+
, ioe_filename = Nothing
285+
}
286+
287+
kont m'
288+
289+
writeTMVar :: MonadSTM m => TMVar m a -> a -> STM m ()
290+
writeTMVar t n = tryTakeTMVar t >> putTMVar t n

0 commit comments

Comments
 (0)