higher-leveldb (empty) → 0.1.0.0
raw patch · 5 files changed
+589/−0 lines, 5 filesdep +basedep +bytestringdep +cerealsetup-changed
Dependencies added: base, bytestring, cereal, data-default, higher-leveldb, hspec, leveldb-haskell, lifted-base, monad-control, mtl, process, resourcet, transformers, transformers-base
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- higher-leveldb.cabal +53/−0
- src/Database/LevelDB/Higher.hs +503/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Jeremy Huffman++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jeremy Huffman nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ higher-leveldb.cabal view
@@ -0,0 +1,53 @@+-- Initial higher-leveldb.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: higher-leveldb+version: 0.1.0.0+synopsis: A rich monadic API for working with leveldb databases.+description: A rich monadic API for working with leveldb databases.+homepage: https://github.com/jeremyjh/higher-leveldb+license: BSD3+license-file: LICENSE+author: Jeremy Huffman+maintainer: jeremy@jeremyhuffman.com+-- copyright: +category: Database+build-type: Simple+cabal-version: >=1.8++library++ ghc-options: -Wall+ exposed-modules: Database.LevelDB.Higher+ -- other-modules: + hs-source-dirs: src+ build-depends: base == 4.* + , cereal + , lifted-base+ , leveldb-haskell == 0.2.*+ , bytestring+ , resourcet+ , transformers-base+ , mtl+ , monad-control+ , data-default+ , transformers+++test-suite spec+ ghc-options: -optl-Wl,-rpath,/usr/local/lib,-enable-new-dtags+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base == 4.*+ , higher-leveldb+ , hspec >= 1.5+ , resourcet+ , leveldb-haskell+ , bytestring+ , process+ , monad-control+ , transformers-base+ , mtl+ , transformers+ , lifted-base
+ src/Database/LevelDB/Higher.hs view
@@ -0,0 +1,503 @@+-- |+-- Higher LevelDB provides a rich monadic API for working with leveldb (<http://code.google.com/p/leveldb>) databases. It uses+-- the leveldb-haskell bindings to the C++ library. The LevelDBT transformer is+-- a Reader that maintains a database context with the open database as well as+-- default read and write options. It also manages a concept called a KeySpace, which is a bucket+-- scheme that provides a low (storage) overhead named identifier to segregate data. Finally it wraps a 'ResourceT'+-- which is required for use of leveldb-haskell functions.+--+-- The other major feature is the scan function and its ScanQuery structure that provides a+-- map / fold abstraction over the Iterator exposed by leveldb-haskell.+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}++module Database.LevelDB.Higher+ (+ -- * Introduction+ -- $intro++ -- * Basic types+ Key, Value, Item, KeySpace, KeySpaceId+ -- * Basic operations+ , get, put, delete+ -- * Batch operations+ , runBatch, putB, deleteB+ -- * Scans+ , scan, ScanQuery(..), queryItems, queryList, queryBegins, queryCount+ -- * Context modifiers+ , withKeySpace, withOptions, withSnapshot+ , forkLevelDB+ -- * Monadic Types and Operations+ , MonadLevelDB(..), LevelDBT, LevelDB+ , mapLevelDBT+ , runLevelDB, runLevelDB', runCreateLevelDB+ -- * Re-exports+ , runResourceT+ , Options(..), ReadOptions(..), WriteOptions(..), RWOptions+ , WriteBatch, def+ , MonadUnsafeIO, MonadThrow, MonadResourceBase+ ) where+++import Control.Monad.Reader+import Control.Monad.Writer+import Data.Word (Word32)++import Control.Applicative (Applicative)+import Control.Monad.Base (MonadBase(..))++import Control.Concurrent.MVar.Lifted+import Control.Concurrent (ThreadId)++import qualified Data.ByteString as BS+import Data.ByteString (ByteString)+import Data.Serialize (encode, decode)++import Data.Default (def)+import qualified Database.LevelDB as LDB+import Database.LevelDB+ hiding (put, get, delete, write, withSnapshot)+import Control.Monad.Trans.Resource+import Control.Monad.Trans.Control+++import qualified Control.Monad.Trans.Cont as Cont+import qualified Control.Monad.Trans.Identity as Identity+import qualified Control.Monad.Trans.List as List+import qualified Control.Monad.Trans.Maybe as Maybe+import qualified Control.Monad.Trans.Error as Error+import qualified Control.Monad.Trans.State as State+import qualified Control.Monad.Trans.Writer as Writer+import qualified Control.Monad.Trans.RWS as RWS+import qualified Control.Monad.Trans.RWS.Strict as Strict+import qualified Control.Monad.Trans.State.Strict as Strict+import qualified Control.Monad.Trans.Writer.Strict as Strict++-- $intro+-- Operations take place within a 'MonadLevelDB' which is built with the LevelDBT transformer; the most+-- basic type would be 'LevelDBT' 'IO' which is type aliased as 'LevelDB'. The basic operations are+-- the same as the underlying leveldb-haskell versions except that the DB and Options arguments are+-- passed along by the LevelDB Reader, and the keys are automatically qualified with the KeySpaceId.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Database.LevelDB.Higher+-- >+-- > runCreateLevelDB "/tmp/mydb" "MyKeySpace" $ do+-- > put "key:1" "this is a value"+-- > get "key:1"+-- >+-- >Just "this is a value"+--++type Key = ByteString+type Value = ByteString+-- | A KeySpace is similar concept to a \"bucket\" in other libraries and database systems.+-- The ByteString for KeySpace can be arbitrarily long without performance impact because+-- the system maps the KeySpace name to a 4-byte KeySpaceId internally which is preprended to each Key.+-- KeySpaces are cheap and plentiful and indeed with this library you cannot escape them+-- (you can supply an empty ByteString to use a default KeySpace, but it is still used).+-- One intended use case is to use the full+-- Key of a "parent" as the KeySpace of its children (instance data in a time-series for example).+-- This lets you scan over a range-based key without passing over any unneeded items.+type KeySpace = ByteString+type KeySpaceId = ByteString+-- | The basic unit of storage is a Key/Value pair.+type Item = (Key, Value)++type RWOptions = (ReadOptions, WriteOptions)+-- | Reader-based data context API+--+-- Context contains database handle and KeySpace+data DBContext = DBC { dbcDb :: DB+ , dbcKsId :: KeySpaceId+ , dbcSyncMV :: MVar Word32+ , dbcRWOptions :: RWOptions+ }+instance Show (DBContext) where+ show = (<>) "KeySpaceID: " . show . dbcKsId++-- | LevelDBT Transformer provides a context for database operations+-- provided in this module.+--+-- This transformer has the same constraints as 'ResourceT' as it wraps+-- 'ResourceT' along with a 'DBContext' 'Reader'.+--+-- If you aren't building a custom monad stack you can just use the 'LevelDB' alias.+newtype LevelDBT m a+ = LevelDBT { unLevelDBT :: ReaderT DBContext (ResourceT m) a }+ deriving ( Functor, Applicative, Monad, MonadIO, MonadThrow)++instance (MonadBase b m) => MonadBase b (LevelDBT m) where+ liftBase = lift . liftBase++instance MonadTrans LevelDBT where+ lift = LevelDBT . lift . lift++instance (MonadResourceBase m) => MonadResource (LevelDBT m) where+ liftResourceT = LevelDBT . liftResourceT++-- TODO: figure out what this does+instance MonadTransControl LevelDBT where+ newtype StT LevelDBT a = StLevelDBT+ {unStLevelDBT :: StT ResourceT (StT (ReaderT DBContext) a) }+ liftWith f =+ LevelDBT $ liftWith $ \run ->+ liftWith $ \run' ->+ f $ liftM StLevelDBT . run' . run . unLevelDBT+ restoreT = LevelDBT . restoreT . restoreT . liftM unStLevelDBT++instance (MonadBaseControl b m) => MonadBaseControl b (LevelDBT m) where+ newtype StM (LevelDBT m) a = StMT {unStMT :: ComposeSt LevelDBT m a}+ liftBaseWith = defaultLiftBaseWith StMT+ restoreM = defaultRestoreM unStMT++-- | MonadLevelDB class used by all the public functions in this module.+class ( Monad m+ , MonadThrow m+ , MonadUnsafeIO m+ , MonadIO m+ , Applicative m+ , MonadResource m+ , MonadBase IO m )+ => MonadLevelDB m where+ -- | Override context for an action - only usable internally for functions+ -- like 'withKeySpace' and 'withOptions'.+ withDBContext :: (DBContext -> DBContext) -> m a -> m a+ -- | Lift a LevelDBT IO action into the current monad.+ liftLevelDB :: LevelDBT IO a -> m a++instance (MonadResourceBase m) => MonadLevelDB (LevelDBT m) where+ liftLevelDB = mapLevelDBT liftIO+ withDBContext = localLDB++-- transformer instances boilerplate; "inspired" by ResourceT+#define INST(M,T, F) \+instance (M, MonadLevelDB m) => MonadLevelDB (T m) \+ where \+ liftLevelDB = lift . liftLevelDB ; \+ withDBContext f = F (withDBContext f) ; \++INST(Monad m,ReaderT r, mapReaderT) --Monad m is a no-op to save another define+INST(Monad m,Maybe.MaybeT, Maybe.mapMaybeT)+INST(Monad m,Identity.IdentityT, Identity.mapIdentityT)+INST(Monad m,List.ListT, List.mapListT)+INST(Monad m,Cont.ContT r, Cont.mapContT)+INST(Monad m,State.StateT s, State.mapStateT )+INST(Monad m,Strict.StateT s, Strict.mapStateT )+INST(Error.Error e, Error.ErrorT e, Error.mapErrorT)+INST(Monoid w, Writer.WriterT w, Writer.mapWriterT)+INST(Monoid w, Strict.WriterT w, Strict.mapWriterT)+INST(Monoid w, RWS.RWST r w s, RWS.mapRWST)+INST(Monoid w, Strict.RWST r w s, Strict.mapRWST)+#undef INST+-- | alias for LevelDBT IO - useful if you aren't building a custom stack.+type LevelDB a = LevelDBT IO a++-- |Build a context and execute the actions; uses a 'ResourceT' internally.+--+-- tip: you can use the Data.Default (def) method to specify default options e.g.+--+-- > runLevelDB "/tmp/mydb" def (def, def{sync = true}) "My Keyspace" $ do+runLevelDB :: (MonadResourceBase m)+ => FilePath -- ^ path to DB to open/create+ -> Options -- ^ database options to use+ -> RWOptions -- ^ default read/write ops; use 'withOptions' to override+ -> KeySpace -- ^ "Bucket" in which Keys will be unique+ -> LevelDBT m a -- ^ The actions to execute+ -> m a+runLevelDB path dbopt rwopt ks ma = runResourceT $ runLevelDB' path dbopt rwopt ks ma++-- |Same as 'runLevelDB' but doesn't call 'runResourceT'. This gives you the option+-- to manage that yourself+runLevelDB' :: (MonadResourceBase m)+ => FilePath -- ^ path to DB to open/create+ -> Options -- ^ database options to use+ -> RWOptions -- ^ default read/write ops; use 'withOptions' to override+ -> KeySpace -- ^ "Bucket" in which Keys will be unique+ -> LevelDBT m a -- ^ The actions to execute+ -> ResourceT m a+runLevelDB' path dbopt rwopt ks ma = do+ db <- openDB+ mv <- newMVar 0+ ksId <- withSystemContext db mv $ getKeySpaceId ks+ runReaderT (unLevelDBT ma) (DBC db ksId mv rwopt)+ where+ openDB = LDB.open path dbopt+ withSystemContext db mv sctx =+ runReaderT (unLevelDBT sctx) $ DBC db systemKeySpaceId mv rwopt++-- | A helper for runLevelDB using default 'Options' except createIfMissing=True+runCreateLevelDB :: (MonadResourceBase m)+ => FilePath -- ^ path to DB to open/create+ -> KeySpace -- ^ "Bucket" in which Keys will be unique+ -> LevelDBT m a -- ^ The actions to execute+ -> m a+runCreateLevelDB path ks ma = runLevelDB path def{createIfMissing=True} def ks ma+++-- | Fork a LevelDBT IO action and return ThreadId into the current monad.+-- This uses 'resourceForkIO' to handle the reference counting and cleanup resources+-- when the last thread exits.+forkLevelDB :: (MonadLevelDB m)+ => LevelDB ()+ -> m ThreadId+forkLevelDB ma = liftLevelDB $ LevelDBT $+ mapReaderT+ (\rt -> resourceForkIO rt) $+ unLevelDBT ma++-- | Use a local keyspace for the operation. e.g.:+--+-- > runCreateLevelDB "/tmp/mydb" "MyKeySpace" $ do+-- > put "somekey" "somevalue"+-- > withKeySpace "Other KeySpace" $ do+-- > put "somekey" "someother value"+-- > get "somekey"+-- >+-- > Just "somevalue"+withKeySpace :: (MonadLevelDB m) => KeySpace -> m a -> m a+withKeySpace ks ma = do+ ksId <- getKeySpaceId ks+ withDBContext (\dbc -> dbc { dbcKsId = ksId}) ma++-- | Local Read/Write Options for the action.+withOptions :: (MonadLevelDB m) => RWOptions -> m a -> m a+withOptions opts =+ withDBContext (\dbc -> dbc { dbcRWOptions = opts })++-- | Run a block of get operations based on a single snapshot taken at+-- the beginning of the action. The snapshot will be automatically+-- released when complete.+--+-- This means that you can do put operations in the same block, but you will not see+-- those changes inside this computation.+withSnapshot :: (MonadLevelDB m) => m a -> m a+withSnapshot ma = do+ (db, _, _) <- getDB+ LDB.withSnapshot db $ \ss ->+ withDBContext (\dbc -> dbc {dbcRWOptions = setSnap dbc ss}) ma+ where+ setSnap dbc ss =+ let (ropts, wopts) = dbcRWOptions dbc in+ (ropts {useSnapshot = Just ss}, wopts)+++-- | Put a value in the current DB and KeySpace.+put :: (MonadLevelDB m) => Key -> Value -> m ()+put k v = do+ (db, ksId, (_, wopt)) <- getDB+ let packed = ksId <> k+ LDB.put db wopt packed v++-- | Get a value from the current DB and KeySpace.+get :: (MonadLevelDB m) => Key -> m (Maybe Value)+get k = do+ (db, ksId, (ropt, _)) <- getDB+ let packed = ksId <> k+ LDB.get db ropt packed++-- | Delete an entry from the current DB and KeySpace.+delete :: (MonadLevelDB m) => Key -> m ()+delete k = do+ (db, ksId, (_, wopt)) <- getDB+ let packed = ksId <> k+ LDB.delete db wopt packed++-- | Write a batch of operations - use the 'write' and 'deleteB' functions to+-- add operations to the batch list.+runBatch :: (MonadLevelDB m)+ => WriterT WriteBatch m ()+ -> m ()+runBatch wb = do+ (db, _, (_, wopt)) <- getDB+ (_, ops) <- runWriterT wb+ LDB.write db wopt ops++-- | Add a "Put" operation to a WriteBatch -- for use with 'runBatch'.+putB :: (MonadLevelDB m) => Key -> Value -> WriterT WriteBatch m ()+putB k v = do+ (_, ksId, _) <- getDB+ tell [Put (ksId <> k) v]+ return ()++-- | Add a "Del" operation to a WriteBatch -- for use with 'runBatch'.+deleteB :: (MonadLevelDB m) => Key -> WriterT WriteBatch m ()+deleteB k = do+ (_, ksId, _) <- getDB+ tell [Del (ksId <> k)]+ return ()+++-- | Scan the keyspace, applying functions and returning results.+-- Look at the documentation for 'ScanQuery' for more information.+--+-- This is essentially a fold left that will run until the 'scanWhile'+-- condition is met or the iterator is exhausted. All the results will be+-- copied into memory before the function returns.+scan :: (MonadLevelDB m)+ => Key -- ^ Key at which to start the scan.+ -> ScanQuery a b -- ^ query functions to execute -- see 'ScanQuery' docs.+ -> m b+scan k scanQuery = do+ (db, ksId, (ropt,_)) <- getDB+ withIterator db ropt $ doScan (ksId <> k)+ where+ doScan prefix iter = do+ iterSeek iter prefix+ applyIterate initV+ where+ readItem = do+ nk <- iterKey iter+ nv <- iterValue iter+ return (fmap (BS.drop 4) nk, nv) --unkeyspace+ applyIterate acc = do+ item <- readItem+ case item of+ (Just nk, Just nv) ->+ if whileFn (nk, nv) acc then do+ iterNext iter+ items <- applyIterate acc+ return $ if filterFn (nk, nv) then+ reduceFn (mapFn (nk, nv)) items+ else items+ else return acc+ _ -> return acc+ initV = scanInit scanQuery+ whileFn = scanWhile scanQuery k+ mapFn = scanMap scanQuery+ filterFn = scanFilter scanQuery+ reduceFn = scanFold scanQuery++-- | Structure containing functions used within the 'scan' function. You may want to start+-- with one of the builder/helper funcions such as 'queryItems', which is defined as:+--+-- >queryItems = queryBegins { scanInit = []+-- > , scanMap = id+-- > , scanFold = (:)+-- > }+data ScanQuery a b = ScanQuery {+ -- | starting value for fold/reduce+ scanInit :: b++ -- | scan will continue until this returns false+ , scanWhile :: Key -> Item -> b -> Bool++ -- | map or transform an item before it is reduced/accumulated+ , scanMap :: Item -> a++ -- | filter function - return 'False' to leave+ -- this 'Item' out of the result+ , scanFilter :: Item -> Bool++ -- | accumulator/fold function e.g. (:)+ , scanFold :: a -> b -> b+ }++-- | A partial ScanQuery helper; this query will find all keys that begin with the Key argument+-- supplied to scan.+--+-- Requires an 'scanInit', a 'scanMap' and a 'scanFold' function.+queryBegins :: ScanQuery a b+queryBegins = ScanQuery+ { scanWhile = \ prefix (nk, _) _ ->+ BS.length nk >= BS.length prefix+ && BS.take (BS.length prefix) nk == prefix+ , scanInit = error "No scanInit provided."+ , scanMap = error "No scanMap provided."+ , scanFilter = const True+ , scanFold = error "No scanFold provided."+ }++-- | A basic ScanQuery helper; this query will find all keys that begin the Key argument+-- supplied to scan, and returns them in a list of 'Item'.+--+-- Does not require any function overrides.+queryItems :: ScanQuery Item [Item]+queryItems = queryBegins { scanInit = []+ , scanMap = id+ , scanFold = (:)+ }++-- | a ScanQuery helper with defaults for queryBegins and a list result; requires a map function e.g.:+--+-- > scan "encoded-values:" queryList { scanMap = \(_, v) -> decode v }+queryList :: ScanQuery a [a]+queryList = queryBegins { scanInit = []+ , scanFilter = const True+ , scanFold = (:)+ }++-- | a ScanQuery helper to count items beginning with Key argument.+queryCount :: (Num a) => ScanQuery a a+queryCount = queryBegins { scanInit = 0+ , scanMap = const 1+ , scanFold = (+) }++-- | Map/transform the monad below the LevelDBT+mapLevelDBT :: (m a -> n b) -> LevelDBT m a -> LevelDBT n b+mapLevelDBT f ma = LevelDBT $+ mapReaderT (transResourceT f) $ unLevelDBT ma++getDB :: (MonadLevelDB m) => m (DB, KeySpaceId, RWOptions)+getDB = liftLevelDB $ asksLDB (\dbc ->+ (dbcDb dbc, dbcKsId dbc, dbcRWOptions dbc))+++-- | This little dance with asksLDB & localLDB let's us get away from+-- exposing MonadReader DBContext in LevelDBT.+asksLDB :: (MonadResourceBase m) => (DBContext -> a) -> LevelDBT m a+asksLDB = LevelDBT . asks++localLDB :: (MonadResourceBase m)+ => (DBContext -> DBContext)+ -> LevelDBT m a -> LevelDBT m a+localLDB f ma = LevelDBT $ local f (unLevelDBT ma)+++defaultKeySpaceId :: KeySpaceId+defaultKeySpaceId = "\0\0\0\0"++systemKeySpaceId :: KeySpaceId+systemKeySpaceId = "\0\0\0\1"++getKeySpaceId :: (MonadLevelDB m) => KeySpace -> m KeySpaceId+getKeySpaceId ks+ | ks == "" = return defaultKeySpaceId+ | ks == "system" = return systemKeySpaceId+ | otherwise = liftLevelDB $ do+ findKS <- get $ "keyspace:" <> ks+ case findKS of+ (Just foundId) -> return foundId+ Nothing -> do -- define new KS+ nextId <- incr "max-keyspace-id"+ put ("keyspace:" <> ks) nextId+ return nextId+ where+ incr k = do+ mv <- takeMVarDBC+ curId <- case mv of+ 0 -> initKeySpaceIdMV k >> takeMVarDBC+ n -> return n+ let nextId = curId + 1+ put k $ encode nextId+ putMVarDBC nextId+ return $ encode curId+ initKeySpaceIdMV k = do+ findMaxId <- get k+ case findMaxId of+ (Just found) -> putMVarDBC $ decodeKsId found+ Nothing -> putMVarDBC 2 -- first user keyspace+ putMVarDBC v = asksLDB dbcSyncMV >>= flip putMVar v+ takeMVarDBC = asksLDB dbcSyncMV >>= takeMVar+ decodeKsId bs =+ case decode bs of+ Left e -> error $+ "Error decoding Key Space ID: " <> show bs <> "\n" <> e+ Right i -> i :: Word32
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}