Commit 6a5b3c3cb2d6a2ea9d1330d17ee1a3519bdc84c9 - tansu

+28

-0

Database/Tansu/Backend/Ephemeral.hs less more

	1	module Database.Tansu.Backend.Ephemeral where
	2
	3	import Control.Concurrent.MVar
	4	import Data.ByteString (ByteString)
	5	import Data.IORef
	6	import qualified Data.Map.Strict as M
	7	import Database.Tansu.Internal (Database(..))
	8
	9	type Table = M.Map ByteString ByteString
	10
	11	ephemeralRunTransaction :: MVar () -> IO a -> IO a
	12	ephemeralRunTransaction lock comp = withMVar lock $ \ () -> comp
	13
	14	ephemeralSet :: IORef Table -> ByteString -> ByteString -> IO ()
	15	ephemeralSet table key val = modifyIORef table (M.insert key val)
	16
	17	ephemeralGet :: IORef Table -> ByteString -> IO (Maybe ByteString)
	18	ephemeralGet table key = M.lookup key `fmap` readIORef table
	19
	20	withEphemeralDatabase :: (Database -> IO a) -> IO a
	21	withEphemeralDatabase comp = do
	22	lock <- newMVar ()
	23	table <- newIORef M.empty
	24	comp $ Database
	25	{ dbRunTransaction = ephemeralRunTransaction lock
	26	, dbSet = ephemeralSet table
	27	, dbGet = ephemeralGet table
	28	}

+26

-0

Database/Tansu/Backend/Filesystem.hs less more

	1	module Database.Tansu.Backend.Filesystem (withFilesystemDb) where
	2
	3	import Data.ByteString (ByteString)
	4	import Data.ByteString.Base64
	5	import qualified Data.ByteString.Char8 as BS
	6	import Database.Tansu.Internal (Database(..))
	7	import System.Directory (createDirectoryIfMissing)
	8	import System.FilePath.Posix ((</>))
	9
	10	filePathSet :: FilePath -> ByteString -> ByteString -> IO ()
	11	filePathSet path key val = do
	12	let keyPath = path </> BS.unpack (encode key)
	13	BS.writeFile keyPath val
	14
	15	filePathGet :: FilePath -> ByteString -> IO (Maybe ByteString)
	16	filePathGet path key = do
	17	let keyPath = path </> BS.unpack (encode key)
	18	fmap Just $ BS.readFile keyPath
	19
	20	withFilesystemDb :: FilePath -> (Database -> IO a) -> IO a
	21	withFilesystemDb path comp = do
	22	createDirectoryIfMissing True path
	23	comp $ Database { dbSet = filePathSet path
	24	, dbGet = filePathGet path
	25	, dbRunTransaction = id
	26	}

+18

-0

Database/Tansu/Internal.hs less more

	1	{-# LANGUAGE Rank2Types #-}
	2
	3	module Database.Tansu.Internal ( Database(..)
	4	, TansuError(..)
	5	) where
	6
	7	import Data.ByteString (ByteString)
	8
	9	data TansuError
	10	= KeyNotFound ByteString
	11	\| DecodeError String
	12	deriving (Eq, Show)
	13
	14	data Database = Database
	15	{ dbSet :: ByteString -> ByteString -> IO ()
	16	, dbGet :: ByteString -> IO (Maybe ByteString)
	17	, dbRunTransaction :: forall a. IO a -> IO a
	18	}

+64

-0

Database/Tansu.hs less more

	1	module Database.Tansu ( Tansu
	2	, Database
	3	, TansuError(..)
	4	, get
	5	, getMb
	6	, set
	7	, (=:)
	8	, run
	9	) where
	10
	11	import Data.ByteString (ByteString)
	12	import Data.Serialize (Serialize, encode, decode)
	13	import MonadLib ( ReaderT
	14	, ExceptionT
	15	, ask
	16	, raise
	17	, inBase
	18	, runExceptionT
	19	, runReaderT
	20	)
	21	import Database.Tansu.Internal
	22
	23	type TansuM a = ReaderT Database (ExceptionT TansuError IO) a
	24
	25	newtype Tansu a = Tansu { runTansu :: TansuM a }
	26
	27	instance Functor Tansu where
	28	fmap f (Tansu t) = Tansu (fmap f t)
	29
	30	instance Applicative Tansu where
	31	pure = Tansu . pure
	32	Tansu f <> Tansu x = Tansu (f <> x)
	33
	34	instance Monad Tansu where
	35	Tansu x >>= f = Tansu (x >>= runTansu . f)
	36
	37	set :: (Serialize k, Serialize v) => k -> v -> Tansu ()
	38	set key val = do
	39	db <- Tansu ask
	40	Tansu $ inBase $ dbSet db (encode key) (encode val)
	41
	42	(=:) :: (Serialize k, Serialize v) => k -> v -> Tansu ()
	43	(=:) = set
	44
	45	get :: (Serialize k, Serialize v) => k -> Tansu v
	46	get key = do
	47	result <- getMb key
	48	case result of
	49	Just val -> return val
	50	Nothing -> Tansu (raise (KeyNotFound (encode key)))
	51
	52	getMb :: (Serialize k, Serialize v) => k -> Tansu (Maybe v)
	53	getMb key = do
	54	db <- Tansu ask
	55	result <- Tansu $ inBase $ dbGet db (encode key)
	56	case result of
	57	Nothing -> return Nothing
	58	Just bs -> case decode bs of
	59	Right val' -> return (Just val')
	60	Left err -> Tansu (raise (DecodeError err))
	61
	62	run :: Database -> Tansu a -> IO (Either TansuError a)
	63	run db (Tansu comp) =
	64	dbRunTransaction db (runExceptionT (runReaderT db comp))

+0

-0

LICENSE less more

(New empty file)

+2

-0

Setup.hs less more

	1	import Distribution.Simple
	2	main = defaultMain

+28

-0

tansu.cabal less more

	1	name: tansu
	2	version: 0.1.0.0
	3	-- synopsis:
	4	-- description:
	5	license: BSD3
	6	license-file: LICENSE
	7	author: Getty Ritter
	8	maintainer: gettylefou@gmail.com
	9	-- copyright:
	10	category: Database
	11	build-type: Simple
	12	extra-source-files: ChangeLog.md
	13	cabal-version: >=1.10
	14
	15	library
	16	exposed-modules: Database.Tansu,
	17	Database.Tansu.Internal,
	18	Database.Tansu.Backend.Filesystem,
	19	Database.Tansu.Backend.Ephemeral
	20	build-depends: base >=4.8 && <4.9,
	21	bytestring,
	22	cereal,
	23	monadLib,
	24	directory,
	25	filepath,
	26	base64-bytestring,
	27	containers
	28	default-language: Haskell2010