Commit ebc29387d0fbc40cbcc97eda79f5b4d3b79289ca - tansu

+41

-0

Database/Tansu/Monad.hs less more

	1	module Database.Tansu.Monad where
	2
	3	import Data.ByteString (ByteString)
	4	import MonadLib ( ReaderT
	5	, ExceptionT
	6	, ask
	7	, raise
	8	, try
	9	, inBase
	10	, runExceptionT
	11	, runReaderT
	12	)
	13	import Database.Tansu.Internal
	14
	15	type TansuM a = ReaderT TansuDb (ExceptionT TansuError IO) a
	16
	17	propagate :: IO (Either TansuError a) -> TansuM a
	18	propagate mote = do
	19	rs <- inBase $ mote
	20	case rs of
	21	Left err -> raise err
	22	Right x -> return x
	23
	24	setInternal :: ByteString -> ByteString -> TansuM ()
	25	setInternal key val = do
	26	db <- ask
	27	propagate $ dbSet db key val
	28
	29	getInternal :: ByteString -> TansuM ByteString
	30	getInternal key = do
	31	db <- ask
	32	propagate $ dbGet db key
	33
	34	delInternal :: ByteString -> TansuM ()
	35	delInternal key = do
	36	db <- ask
	37	propagate $ dbDel db key
	38
	39	runInternal :: TansuDb -> TansuM a -> IO (Either TansuError a)
	40	runInternal db mote =
	41	dbRunTransaction db (runExceptionT (runReaderT db mote))

+81

-0

Database/Tansu/Serialize.hs less more

	1	{-# LANGUAGE RankNTypes #-}
	2
	3	module Database.Tansu.Serialize
	4	( -- * The 'TansuS' monad
	5	TansuS
	6	, TansuDbS
	7	, TansuError(..)
	8	-- * 'TansuS' Operations
	9	, get
	10	, getMb
	11	, set
	12	, (=:)
	13	, del
	14	-- * Running a 'TansuS' operation
	15	, runS
	16	, serialized
	17	) where
	18
	19	import Data.ByteString (ByteString)
	20	import Data.Serialize (Serialize, encode, decode)
	21	import MonadLib (raise, try)
	22
	23	import Database.Tansu.Monad
	24	import Database.Tansu.Internal
	25
	26	newtype TansuDbS k v = TansuDbS TansuDb
	27
	28	serialized :: (TansuDbS k v -> r) -> (TansuDb -> r)
	29	serialized func = func . TansuDbS
	30
	31	newtype TansuS k v a = TansuS { runTansuS :: TansuM a }
	32
	33	instance Functor (TansuS k v) where
	34	fmap f (TansuS t) = TansuS (fmap f t)
	35
	36	instance Applicative (TansuS k v) where
	37	pure = TansuS . pure
	38	TansuS f <> TansuS x = TansuS (f <> x)
	39
	40	instance Monad (TansuS k v) where
	41	TansuS x >>= f = TansuS (x >>= runTansuS . f)
	42
	43	-- \| Sets the value for a key to a value.
	44	set :: (Serialize k, Serialize v) => k -> v -> TansuS k v ()
	45	set key val = TansuS $ setInternal (encode key) (encode val)
	46
	47	-- \| Sets the value for a key to a value. A convenience operator
	48	-- that is identical to 'set'.
	49	(=:) :: (Serialize k, Serialize v) => k -> v -> TansuS k v ()
	50	(=:) = set
	51
	52	-- \| Gets a value for a given key. The resulting 'Tansu' computation
	53	-- will fail if the key is not present in the storage backend.
	54	get :: (Serialize k, Serialize v) => k -> TansuS k v v
	55	get key = do
	56	bs <- TansuS $ getInternal (encode key)
	57	case (decode bs) of
	58	Left err -> TansuS (raise (DecodeError err))
	59	Right val -> return val
	60
	61	-- \| Gets a value for a given key. If the key is not present, this
	62	-- computation will return 'Nothing' instead. Other errors, such
	63	-- as problems decoding the serialized value or difficulties
	64	-- communicating with the storage backend, will still cause the
	65	-- 'Tansu' computation to fail.
	66	getMb :: (Serialize k, Serialize v) => k -> TansuS k v (Maybe v)
	67	getMb key = do
	68	rs <- TansuS $ try $ runTansuS $ get key
	69	case rs of
	70	Left (KeyNotFound _) -> return Nothing
	71	Left err -> TansuS (raise err)
	72	Right val -> return (Just val)
	73
	74	del :: (Serialize k) => k -> TansuS k v ()
	75	del key = TansuS $ delInternal (encode key)
	76
	77	-- \| Given a storage backend and a 'Tansu' computation, execute the
	78	-- sequence of 'get' and 'set' commands and produce either the value
	79	-- or the error encountered while running the computation.
	80	runS :: TansuDbS k v -> TansuS k v a -> IO (Either TansuError a)
	81	runS (TansuDbS db) (TansuS mote) = runInternal db mote

+0

-35

~~sample/Main.hs~~ less more

1		module Main where
2
3		import Control.Monad (void)
4		import Database.Tansu
5		import Database.Tansu.Backend.Filesystem
6		import Database.Tansu.Backend.Ephemeral
7
8		main :: IO ()
9		main = do
10		putStrLn "Testing filesystem db"
11		withFilesystemDb "sample.db" sample
12
13		putStrLn "Testing ephemeral db"
14		withNewEphemeralDb sample
15
16		sample :: TansuDb String String -> IO ()
17		sample db = do
18		putStrLn "Populating test database"
19		run db $ do
20		"one" =: "un"
21		"two" =: "du"
22		"three" =: "tri"
23		"four" =: "kvar"
24
25		putStr "looking up key 'three': "
26		rs <- run db $ get "three"
27		case rs of
28		Right val -> putStrLn val
29		Left _ -> putStrLn "...not in the database."
30
31		putStr "looking up key 'five': "
32		rs <- run db $ get "five"
33		case rs of
34		Right val -> putStrLn val
35		Left _ -> putStrLn "...not in the database."

+35

-0

sample1/Main.hs less more

	1	module Main where
	2
	3	import Control.Monad (void)
	4	import Database.Tansu
	5	import Database.Tansu.Backend.Filesystem
	6	import Database.Tansu.Backend.Ephemeral
	7
	8	main :: IO ()
	9	main = do
	10	putStrLn "Testing filesystem db"
	11	withFilesystemDb "sample.db" sample
	12
	13	putStrLn "Testing ephemeral db"
	14	withNewEphemeralDb sample
	15
	16	sample :: TansuDb String String -> IO ()
	17	sample db = do
	18	putStrLn "Populating test database"
	19	run db $ do
	20	"one" =: "un"
	21	"two" =: "du"
	22	"three" =: "tri"
	23	"four" =: "kvar"
	24
	25	putStr "looking up key 'three': "
	26	rs <- run db $ get "three"
	27	case rs of
	28	Right val -> putStrLn val
	29	Left _ -> putStrLn "...not in the database."
	30
	31	putStr "looking up key 'five': "
	32	rs <- run db $ get "five"
	33	case rs of
	34	Right val -> putStrLn val
	35	Left _ -> putStrLn "...not in the database."

+23

-0

sample2/Main.hs less more

	1	{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
	2
	3	module Main where
	4
	5	import Data.Serialize (Serialize)
	6	import GHC.Generics (Generic)
	7
	8	import Database.Tansu.Serialize ((=:), get, runS, serialized)
	9	import Database.Tansu.Backend.Filesystem (withFilesystemDb)
	10
	11	data Person = Person
	12	{ name :: String
	13	, age :: Int
	14	} deriving (Eq, Show, Generic, Serialize)
	15
	16	main :: IO ()
	17	main = withFilesystemDb "sample.db" $ serialized $ \ db -> do
	18	runS db $ do
	19	"alex" =: Person "alex" 33
	20	"blake" =: Person "blake" 22
	21
	22	Right age <- runS db (age `fmap` get "blake")
	23	putStrLn $ "Blake's age is " ++ show age