muesli (empty) → 0.1.0.0
raw patch · 17 files changed
+2445/−0 lines, 17 filesdep +basedep +bytestringdep +cerealsetup-changed
Dependencies added: base, bytestring, cereal, containers, directory, filepath, hashable, mtl, psqueues, time
Files
- CHANGELOG.md +3/−0
- LICENSE.md +20/−0
- README.md +196/−0
- Setup.hs +2/−0
- muesli.cabal +62/−0
- src/Database/Muesli/Allocator.hs +79/−0
- src/Database/Muesli/Backend/File.hs +239/−0
- src/Database/Muesli/Backend/Types.hs +90/−0
- src/Database/Muesli/Cache.hs +121/−0
- src/Database/Muesli/Commit.hs +233/−0
- src/Database/Muesli/GC.hs +160/−0
- src/Database/Muesli/Handle.hs +177/−0
- src/Database/Muesli/IdSupply.hs +71/−0
- src/Database/Muesli/Indexes.hs +95/−0
- src/Database/Muesli/Query.hs +324/−0
- src/Database/Muesli/State.hs +231/−0
- src/Database/Muesli/Types.hs +342/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+### 0.1++* initial release
+ LICENSE.md view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Călin Ardelean++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,196 @@+muesli+======++A simple [document-oriented database][nosql] engine for Haskell.++Use cases+---------+* backing store for p2p / cloud nodes, mobile apps, etc.+* higher capacity replacement for *acid-state* (only indexes are held in memory).+* no dependency substitute for *SQLite*.+* *ACID*ic replacement for *CouchDB* and the like.++Features+--------+* **ACID transactions** implemented on the [MVCC][] model.+* **automatic index management** based on tags prepended to fields' types+(see example below).+* **minimal boilerplate**: instead of *TemplateHaskell* we use+[`GHC.Generics`][gen] and [`deriving`][der].+* **simple monad for writing queries**, with standard primitive operations like:+`lookup`, `insert`, `update`, `delete`, `range`, `filter`.+* range queries (`filter` and `range`) afford efficient **cursor-like+navigation** (paging) through large datasets. For example this is the+equivalent SQL for `filter`:+```SQL+SELECT TOP page * FROM table+WHERE (filterFld = filterVal) AND+ (sortVal = NULL OR sortFld < sortVal) AND+ (sortKey = NULL OR ID < sortKey)+ORDER BY field, ID DESC+```+* **easy to reason about performance**: all primitive queries run in **O(log n)**.+* **type safety**: impossible to attempt deserializing a record at a wrong type+(or address), and risk getting bogus data with no error thrown.+References are tagged with a phantom type and created only by the database.+There are also `Num`/`Integral` instances to support more generic apps,+but normally those are not needed.+* **multiple backends** supported: currently *file*, and soon (:tm:)+*in-memory*, *remote*.+* **portability**: it should work on all platforms, including mobile.+* **replication**: soon (:tm:)++*Note: some of these features become misfeatures for certain scenarios which+would make either a pure in-memory cache, or a real database more appropriate.*++Example use+-----------+First, mark up your types. You must use the record syntax to name the+accessors so they'll be queryable. You can filter on `Reference` fields, sort and+range on `Sortable`s, and reverse lookup `Unique`s. The database will extract+these keys using the `Indexable` and `Document` instances with the help of+`GHC.Generics`, including from deep inside any `Foldable`.++```Haskell+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}++import Database.Muesli.Types++data Person = Person+ { personName :: Unique (Sortable String)+ , personEmail :: String+ } deriving (Show, Generic, Serialize)++instance Document Person++data Content = Text String | HTML String | XHTML String+ deriving (Show, Generic, Serialize, Indexable)++data BlogPost = BlogPost+ { postURI :: Unique String+ , postTitle :: Sortable String+ , postAuthor :: Maybe (Reference Person)+ , postContributors :: [Reference Person]+ , postTags :: [Sortable String]+ , postContent :: Content+ , publishedDate :: Sortable DateTime+ } deriving (Show, Generic, Serialize)++instance Document BlogPost+```++Then, write some queries (`updateUnique` searches by unique key, and either+inserts or updates depending on result):++```Haskell+{-# LANGUAGE OverloadedStrings #-}++import Database.Muesli.Query++updatePerson :: String -> String -> Transaction l m (Reference Person, Person)+updatePerson name email = do+ let name' = Sortable name+ let p = Person name' email+ pid <- updateUnique "personName" (Unique name') p+ return (pid, p)++postsByContrib :: Reference Person -> Transaction l m [(Reference BlogPost, BlogPost)]+postsByContrib pid =+ filter (Just pid) Nothing Nothing "postContributors" "postTitle" 1000++flagContributor :: Reference Person -> Transaction l m ()+flagContributor pid = do+ is <- postsByContributor pid+ forM_ is $ \(bpid, bp) ->+ update bpid bp { postTags = postTags bp ++ Sortable "stolen" }+```++Then you can run these transactions with `runQuery` inside some `MonadIO` context.+Note that `Transaction` itself is an instance of `MonadIO`, so you can do+arbitrary IO inside.+The `l` parameter specifies which storage backend you use.+Currently only a portable binary file backend is implemented, used with+`Handle FileLogState`.++```Haskell+import Database.Muesli.Query+import Database.Muesli.Handle++flagIt :: (MonadIO m, LogState l) => Handle l -> String -> String ->+ m (Either TransactionAbort ())+flagIt h name email = runQuery h $ do+ (pid, _) <- updatePerson name email+ flagContributor pid++main :: IO ()+main = bracket+ (putStrLn "opening DB..." >>+ open (Just "blog.log") (Just "blog.dat") Nothing Nothing)+ (\(h :: Handle FileLogState) -> putStrLn "closing DB..." >> close h)+ (\h -> flagIt h "Bender Bending Rodríguez" "bender@ilovebender.com")++```++TODO+----+- [ ] expose the inverted index+- [x] queries that only return keys (no data file IO)+- [ ] blocking version of `runQuery`+- [ ] testing it on mobile devices+- [ ] in-memory backend compatible with `mmap`; also, a remote backend+- [ ] static property names, but no ugly `Proxy :: Proxy "FieldName"` stuff+- [ ] support for extensible records ("lax" `Serialize` instance),+live up to the "document-oriented" label, but this should be optional+- [ ] better migration story+- [ ] radix tree / PATRICIA implementation for proper full-text search+(currently indexing strings just takes first 4/8 chars and turnes them into an int,+which is good enough for simple sorting)+- [ ] replication+- [ ] more advanced & flexible index system supporting complex indexes, joins, etc.+- [ ] fancy query language+- [ ] optimize reads: faster cache, mainIdx (hastable maybe?)+- [x] waiting for [`OverloadedRecordFields`][orf]++Implementation+--------------+* 2 files, one for transactions/indexes, and another for serialized data+* same file format for transactions and indexes, loading indexes is+the same as replaying transactions+* transaction file only contains int keys extracted from tagged fields+* processing a record (updating indexes) while loading the log is **O(log n)**+* previous 2 points make the initial loading much faster and using significantly+less memory then *acid-state*, which serializes entire records, including+potentially very large string fields, typical in "document-oriented" scenarios.+It was suggested that in such cases you should store this data in external files.+But then, if you want to regain the ACID property, and already have some indexes+laying aroung, you are well on your way of creating *muesli*.+* data file only contains serialized records and gaps, no metadata+* LRU cache holds deserialized objects wrapped in `Data.Dynamic`.+On SSDs deserialization is far more costly than file IO,+so having our own cache is a better solution than just memory mapping the file.+* :recycle: GC creates asynchronously new copies of both files, doing cleanup and+compaction, and only locks the world at the end+* :lock: all locks are held for at most **O(log n)** time+* `Reference`, `Unique` and `Sortable` are `newtype`s that have a set of general+instances for `Indexable` and `Document` which are used by a [generic function][gen]+* transactions defer updates by collecting IDs and serialized data,+which are checked (under lock) for consistency at the end++Change log+----------+Available [here][changes].++License+-------+Copyright © 2015 Călin Ardelean++MIT license. See the [license file][MIT] for details.++[nosql]: https://en.wikipedia.org/wiki/Document-oriented_database "Document-oriented database - Wikipedia"+[MVCC]: https://en.wikipedia.org/wiki/Multiversion_concurrency_control "Multiversion concurrency control - Wikipedia"+[gen]: https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/generic-programming.html "Generic Programming - GHC User's Guide"+[der]: https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/deriving.html "Extensions to the deriving mechanism - GHC User's Guide"+[orf]: https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields "Overloaded Record Fields - GHC Wiki"+[changes]: https://github.com/clnx/muesli/blob/master/CHANGELOG.md "Muesli change log"+[MIT]: https://github.com/clnx/muesli/blob/master/LICENSE.md "MIT License File"
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ muesli.cabal view
@@ -0,0 +1,62 @@+name: muesli+category: Database+version: 0.1.0.0+synopsis: A simple document-oriented database+description:+ @muesli@ is an easy to use+ <https://en.wikipedia.org/wiki/Multiversion_concurrency_control MVCC>+ <https://en.wikipedia.org/wiki/Document-oriented_database document-oriented database>+ featuring ACID transactions, automatic index management and minimal boilerplate.+ .+ Import the "Database.Muesli.Types" module to mark up your types for indexing,+ "Database.Muesli.Query" for writing and running queries,+ and "Database.Muesli.Handle" for database management.+ The rest of the modules are internal, but exposed just in case.+ .+ See the README.md file for an usage example.+homepage: https://github.com/clnx/muesli+bug-reports: https://github.com/clnx/muesli/issues+author: Călin Ardelean+maintainer: Călin Ardelean <calinucs@gmail.com>+copyright: Copyright (C) 2015 Călin Ardelean+license: MIT+license-file: LICENSE.md+stability: experimental+build-type: Simple+cabal-version: >=1.10+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/clnx/muesli.git++library+ ghc-options: -O2 -Wall+ exposed-modules:+ Database.Muesli.Types,+ Database.Muesli.Backend.Types,+ Database.Muesli.Backend.File,+ Database.Muesli.Query,+ Database.Muesli.Handle,+ Database.Muesli.State,+ Database.Muesli.IdSupply,+ Database.Muesli.Allocator,+ Database.Muesli.Cache,+ Database.Muesli.Indexes,+ Database.Muesli.Commit,+ Database.Muesli.GC+ build-depends:+ base >= 4.8 && < 5,+ mtl,+ time,+ containers,+ psqueues,+ bytestring,+ cereal,+ hashable,+ filepath,+ directory+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Database/Muesli/Allocator.hs view
@@ -0,0 +1,79 @@+-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.Allocator+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Document data allocator.+--+-- This module should be imported qualified.+----------------------------------------------------------------------------++module Database.Muesli.Allocator+ ( empty+ , add+ , build+ , buildExtra+ , alloc+ ) where++import Control.Exception (throw)+import qualified Data.IntMap.Strict as IntMap+import Data.List (foldl', sortOn)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Database.Muesli.Backend.Types (LogRecord (..))+import Database.Muesli.State (GapsIndex, MainIndex)+import Database.Muesli.Types (DatabaseError (..), DocAddress,+ DocSize)++-- | Creates an index holding a single gap starting at the given address.+empty :: DocAddress -> GapsIndex+empty addr = Map.singleton (maxBound - addr) [addr]++-- | Adds a gap to the index.+add :: DocSize -> DocAddress -> GapsIndex -> GapsIndex+add sz addr gs = Map.insert sz (addr:as) gs+ where as = fromMaybe [] $ Map.lookup sz gs++-- | Builds the index from the 'LogRecord' data held in an 'MainIndex'.+--+-- __O(n*log(n))__ operation used by 'Database.Muesli.Handle.open' after+-- loading the log.+build :: MainIndex -> GapsIndex+build idx = addTail . foldl' f (Map.empty, 0) . sortOn recAddress .+ filter (not . recDeleted) . map head $ IntMap.elems idx+ where+ f (gs, addr) r = (gs', recAddress r + recSize r)+ where gs' = if addr == recAddress r then gs+ else add sz addr gs+ sz = recAddress r - addr+ addTail (gs, addr) = add (maxBound - addr) addr gs++-- | Builds the index from a set of 'LogRecord's, with all space before the+-- given address considered reserved.+--+-- Used by the garbage collector (see module "Database.Muesli.GC").+buildExtra :: DocAddress -> [LogRecord] -> GapsIndex+buildExtra pos = foldl' f (empty pos)+ where f gs r = add (recSize r) (recAddress r) gs++-- | Allocates a new slot of the given size.+-- The smallest available size in the index is preferred.+--+-- Throws 'DataAllocationError' if no gap big enough is found.+alloc :: GapsIndex -> DocSize -> (DocAddress, GapsIndex)+alloc gs sz =+ case Map.lookupGE sz gs of+ Nothing -> throw $ DataAllocationError sz (fst <$> Map.lookupLT maxBound gs)+ "Data allocation error."+ Just (gsz, a:as) ->+ if delta == 0 then (a, gs')+ else (a, add delta (a + sz) gs')+ where gs' = if null as then Map.delete gsz gs+ else Map.insert gsz as gs+ delta = gsz - sz
+ src/Database/Muesli/Backend/File.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.Backend.File+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Binary seekable file backend that uses 'Prelude' functions.+----------------------------------------------------------------------------++module Database.Muesli.Backend.File+ ( FileHandle+ , FileLogState (..)+ ) where++import Control.Exception (throw)+import Control.Monad (forM_, replicateM, unless, when)+import Control.Monad.Trans (MonadIO (liftIO))+import Data.ByteString (hGet, hPut)+import Data.Word (Word16, Word8)+import Database.Muesli.Backend.Types+import Database.Muesli.Types+import Foreign (Storable, alloca, peek, sizeOf,+ with)+import System.Directory (renameFile)+import System.IO (BufferMode (..), Handle,+ IOMode (..), SeekMode (..),+ hClose, hFileSize, hGetBuf,+ hPutBuf, hSeek, hSetBuffering,+ hSetFileSize, hTell,+ openBinaryFile, withBinaryFile)++-- | @newtype@ wrapper around 'Handle', so that we can accomodate other instances.+newtype FileHandle = FileHandle { unIOHandle :: Handle }+ deriving (Eq, Show)++instance DbHandle FileHandle where+ openDb path = liftIO $ do+ hnd <- openBinaryFile path ReadWriteMode+ hSetBuffering hnd NoBuffering+ return $ FileHandle hnd++ closeDb hnd = liftIO . hClose $ unIOHandle hnd++ withDb path f = liftIO . withBinaryFile path ReadWriteMode $ f . FileHandle++ swapDb oldPath path = liftIO (renameFile path oldPath) >> openDb path++instance DataHandle FileHandle where+ readDocument hnd r = do+ liftIO . hSeek (unIOHandle hnd) AbsoluteSeek . fromIntegral $ recAddress r+ liftIO . hGet (unIOHandle hnd) . fromIntegral $ recSize r++ writeDocument r bs hnd = unless (recDeleted r) . liftIO $ do+ let sz = fromIntegral $ recAddress r + recSize r+ let h = unIOHandle hnd+ osz <- hFileSize h+ when (osz < sz) $ do+ let nsz = max sz $ osz + 4096+ hSetFileSize h nsz+ hSeek h AbsoluteSeek . fromIntegral $ recAddress r+ hPut h bs++-- | Implements a stateful binary log file backend.+--+-- It uses a 'FileHandle' for both the log and data files.+data FileLogState = FileLogState+ {+-- | The 'Handle' for the log file+ flogHandle :: FileHandle+-- | Current valid position in the (quasi)append-only log file.+-- Located at address 0 of the log file, it is the last write performd as+-- part of a batch 'logAppend' operation, which makes it atomic.+ , flogPos :: DocAddress+-- | Current size of the log file. 'logAppend' first checks the file size+-- and increases it with minimum 4KB if necessary, then writes the records,+-- and then updates the 'flogPos'.+ , flogSize :: DocSize+ } deriving (Show)++instance LogState FileLogState where+ type LogHandleOf FileLogState = FileHandle+ type DataHandleOf FileLogState = FileHandle++ logHandle = flogHandle++ logInit hnd = do+ (pos, sz) <- readLogPos (unIOHandle hnd)+ return $ FileLogState hnd pos sz++ logAppend l rs = do+ let hnd = unIOHandle $ logHandle l+ let pos = flogPos l+ let pos' = pos + sum (map sizeTransRecord rs)+ sz <- checkFileSize hnd (flogSize l) pos'+ liftIO . hSeek hnd AbsoluteSeek $ fromIntegral pos+ forM_ rs $ writeTransRecord hnd+ writeLogPos hnd $ fromIntegral pos'+ return l { flogPos = pos', flogSize = sz }++ logRead l = do+ let hnd = unIOHandle $ logHandle l+ pos <- liftIO $ hTell hnd+ if flogSize l == 0 || pos >= fromIntegral (flogPos l) - 1+ then return Nothing+ else do+ r <- readTransRecord hnd+ return $ Just r++sizeTransRecord :: TransRecord -> DocSize+sizeTransRecord r = fromIntegral $ case r of+ Pending dr -> 16 + ws * (3 + 2 * (length (recUniques dr) ++ length (recSortables dr) ++ length (recReferences dr)))+ Completed _ -> 9+ where ws = sizeOf (0 :: IxKey)++readBits :: forall a m. (Storable a, MonadIO m) => Handle -> m a+readBits h = liftIO . alloca $ \ptr ->+ hGetBuf h ptr (sizeOf (undefined :: a)) >> peek ptr++writeBits :: (Storable a, MonadIO m) => Handle -> a -> m ()+writeBits h w = liftIO . with w $ \ptr ->+ hPutBuf h ptr (sizeOf w)++readLogPos :: MonadIO m => Handle -> m (DocAddress, DocSize)+readLogPos h = liftIO $ do+ sz <- hFileSize h+ if sz >= fromIntegral (sizeOf (0 :: DocAddress)) then do+ hSeek h AbsoluteSeek 0+ w <- readBits h+ return (w, fromIntegral sz)+ else+ return (fromIntegral $ sizeOf (0 :: DocAddress), 0)++writeLogPos :: MonadIO m => Handle -> DocAddress -> m ()+writeLogPos h p = liftIO $ do+ hSeek h AbsoluteSeek 0+ writeBits h p++checkFileSize :: MonadIO m => Handle -> DocSize -> DocAddress -> m DocSize+checkFileSize hnd osz pos =+ if pos > osz then do+ let sz = max pos $ osz + 4096+ liftIO . hSetFileSize hnd $ fromIntegral sz+ return sz+ else return osz++readTransRecord :: MonadIO m => Handle -> m TransRecord+readTransRecord h = do+ tag <- readBits h+ case tag of+ x | x == pndTag -> do+ tid <- readBits h+ did <- readBits h+ adr <- readBits h+ siz <- readBits h+ del <- readBits h+ dlb <- case del of+ y | y == truTag -> return True+ y | y == flsTag -> return False+ _ -> logError h $+ showString "True ('T') or False ('F') tag expected but " .+ shows del . showString " found."+ us <- readWordList h+ is <- readWordList h+ ds <- readWordList h+ return $ Pending LogRecord { recDocumentKey = did+ , recTransactionId = tid+ , recUniques = us+ , recSortables = is+ , recReferences = ds+ , recAddress = adr+ , recSize = siz+ , recDeleted = dlb+ }+ x | x == cmpTag -> do+ tid <- readBits h+ return $ Completed tid+ _ -> logError h $ showString "Pending ('p') or Completed ('c') tag expected but " .+ shows tag . showString " found."++readWordList :: MonadIO m => Handle -> m [(PropertyKey, IxKey)]+readWordList h = do+ sz <- readBits h+ replicateM (fromIntegral (sz :: Word16)) $ do+ pid <- readBits h+ val <- readBits h+ return (pid, val)++writeTransRecord :: MonadIO m => Handle -> TransRecord -> m ()+writeTransRecord h t =+ case t of+ Pending doc -> do+ writeBits h pndTag+ writeBits h $ recTransactionId doc+ writeBits h $ recDocumentKey doc+ writeBits h $ recAddress doc+ writeBits h $ recSize doc+ writeBits h $ if recDeleted doc then truTag else flsTag+ writeWordList h $ recUniques doc+ writeWordList h $ recSortables doc+ writeWordList h $ recReferences doc+ Completed tid -> do+ writeBits h cmpTag+ writeBits h tid++writeWordList :: MonadIO m => Handle -> [(PropertyKey, IxKey)] -> m ()+writeWordList h rs = do+ writeBits h (fromIntegral (length rs) :: Word16)+ forM_ rs $ \(pid, val) -> do+ writeBits h pid+ writeBits h val++pndTag :: Word8+pndTag = 0x70 -- ASCII 'p'++cmpTag :: Word8+cmpTag = 0x63 -- ASCII 'c'++truTag :: Word8+truTag = 0x54 -- ASCII 'T'++flsTag :: Word8+flsTag = 0x46 -- ASCII 'F'++logError :: MonadIO m => Handle -> ShowS -> m a+logError h err = liftIO $ do+ pos <- hTell h+ throw . LogParseError . showString "Log corrupted at position " . shows pos .+ showString ". " $ err ""
+ src/Database/Muesli/Backend/Types.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.Backend.Types+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Generic backend interface types and classes.+--+-- This module is re-exported by other modules, like "Database.Muesli.Handle".+----------------------------------------------------------------------------++module Database.Muesli.Backend.Types+ (+-- * Transaction log records+ TransRecord (..)+ , LogRecord (..)+-- * Generic backend interface+-- | These classes are used by the machinary in "Database.Muesli.State".+--+-- For an implementation, see the "Database.Muesli.Backend.File" module.+ , LogState (..)+ , DataHandle (..)+ , DbPath+ , DbHandle (..)+ ) where++import Control.Monad.Trans (MonadIO)+import Data.ByteString (ByteString)+import Database.Muesli.Types (DocAddress, DocSize, DocumentKey,+ PropertyKey, SortableKey, TransactionId,+ UniqueKey)++-- | Holds the metadata for a given document version.+--+-- Keys collected by the generic scrapper are stored in 'recReferences',+-- 'recSortables', and 'recUniques'. The 'recDocumentKey' is generated by an+-- 'Database.Muesli.IdSupply.IdSupply', while the 'recAddress' and 'recSize'+-- are allocated by 'Database.Muesli.Allocator.alloc'.+-- This work is done either by the primitive queries in "Database.Muesli.Query",+-- or by 'Database.Muesli.Commit.runQuery'.+data LogRecord = LogRecord+ { recTransactionId :: !TransactionId+ , recDocumentKey :: !DocumentKey+ , recReferences :: ![(PropertyKey, DocumentKey)]+ , recSortables :: ![(PropertyKey, SortableKey)]+ , recUniques :: ![(PropertyKey, UniqueKey)]+ , recAddress :: !DocAddress+ , recSize :: !DocSize+ , recDeleted :: !Bool+ } deriving (Show)++-- | This type represents a line in the transaction log file.+-- There can be multiple lines for a single transaction, and the last one+-- must be a 'Completed' one. Other than that, the lines from multiple+-- transactions can be mixed.+data TransRecord = Pending LogRecord | Completed TransactionId+ deriving (Show)++-- | Generic path type. For instance, this can be a file path or an url.+type DbPath = String++-- | Generic handle interface.+class DbHandle a where+ openDb :: MonadIO m => DbPath -> m a+ closeDb :: MonadIO m => a -> m ()+ withDb :: MonadIO m => DbPath -> (a -> IO b) -> m b+ swapDb :: MonadIO m => DbPath -> DbPath -> m a++-- | Handle used to access serialized document data in the generic data file.+class DbHandle a => DataHandle a where+ readDocument :: MonadIO m => a -> LogRecord -> m ByteString+ writeDocument :: MonadIO m => LogRecord -> ByteString -> a -> m ()++-- | Provides stateful access to an abstract log file handle.+class (Show a, DbHandle (LogHandleOf a), DataHandle (DataHandleOf a)) => LogState a where+ type LogHandleOf a :: *+ type DataHandleOf a :: *+ logHandle :: a -> LogHandleOf a+ logInit :: MonadIO m => LogHandleOf a -> m a+ logAppend :: MonadIO m => a -> [TransRecord] -> m a+ logRead :: MonadIO m => a -> m (Maybe TransRecord)
+ src/Database/Muesli/Cache.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.Cache+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- LRU cache implementation using the+-- <http://hackage.haskell.org/package/psqueues psqueues> package.+--+-- This module should be imported qualified.+----------------------------------------------------------------------------++module Database.Muesli.Cache+ ( DynValue (..)+ , LRUCache (..)+ , empty+ , insert+ , lookup+ , delete+ , trim+ ) where++import Data.Dynamic (Dynamic, fromDynamic, toDyn)+import Data.IntPSQ (IntPSQ)+import qualified Data.IntPSQ as PQ+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)+import Data.Typeable (Typeable)+import Prelude hiding (lookup)++-- | Holds a 'Dynamic' and the size of the corresponding serialized data.+data DynValue = DynValue+ { dynValue :: !Dynamic+ , dynSize :: !Int+ } deriving (Show)++-- | A LRU cache that uses a lower capacity in periods of inactivity.+-- This behaviour would be useful for things like long lived Android services.+data LRUCache = LRUCache+ { minCapacity :: !Int -- ^ Minimum capacity under which 'maxAge' is ignored+ , maxCapacity :: !Int -- ^ Maximum capacity above which oldest items are removed+ , maxAge :: !NominalDiffTime+ , size :: !Int -- ^ Current size (in bytes) of the cache+ , queue :: !(IntPSQ UTCTime DynValue)+ }++-- | Creates an empty cache.+empty :: Int -- ^ Minimum capacity (in bytes)+ -> Int -- ^ Maximum capacity (in bytes)+ -> NominalDiffTime -- ^ Maximum age (in seconds)+ -> LRUCache+empty minc maxc age = LRUCache { minCapacity = minc+ , maxCapacity = maxc+ , maxAge = age+ , size = 0+ , queue = PQ.empty+ }++-- | Apply cache's policy and removes items if necessary.+trim :: UTCTime -- ^ Current time+ -> LRUCache+ -> LRUCache+trim now c =+ if size c < minCapacity c then c+ else case PQ.findMin (queue c) of+ Nothing -> c+ Just (_, p, v) ->+ if (size c < maxCapacity c) && (diffUTCTime now p < maxAge c)+ then c+ else trim now $! c { size = size c - dynSize v+ , queue = PQ.deleteMin (queue c)+ }++-- | Adds a new item to the cache, and 'trim's.+insert :: Typeable a+ => UTCTime -- ^ Current time+ -> Int -- ^ Key+ -> a -- ^ Value+ -> Int -- ^ Size (in bytes)+ -> LRUCache+ -> LRUCache+insert now k a sz c = trim now $! c { size = size c + sz -+ maybe 0 (dynSize . snd) mbv+ , queue = q+ }+ where (mbv, q) = PQ.insertView k now v (queue c)+ v = DynValue { dynValue = toDyn a+ , dynSize = sz+ }++-- | Looks up an item into the cache.+-- If found, it updates the access time for the item, and then 'trim's.+lookup :: Typeable a+ => UTCTime -- ^ Current time+ -> Int -- ^ Key+ -> LRUCache+ -> Maybe (a, Int, LRUCache)+lookup now k c =+ case PQ.alter f k (queue c) of+ (Nothing, _) -> Nothing+ (Just v, q) -> (, dynSize v, c') <$> fromDynamic (dynValue v)+ where !c' = trim now $ c { queue = q }+ where f = maybe (Nothing, Nothing) (\(_, v) -> (Just v, Just (now, v)))++-- | Deletes an item from the cache.+delete :: Int -- ^ Key+ -> LRUCache+ -> LRUCache+delete k c = maybe c+ (\(_, v) -> c { size = size c - dynSize v+ , queue = PQ.delete k (queue c)+ }) $+ PQ.lookup k (queue c)
+ src/Database/Muesli/Commit.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.Commit+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- 'Transaction' evaluation inside 'MonadIO'.+----------------------------------------------------------------------------++module Database.Muesli.Commit+ ( Transaction (..)+ , TransactionState (..)+ , runQuery+ , TransactionAbort (..)+ , commitThread+ ) where++import Control.Concurrent (threadDelay)+import Control.Exception (Exception)+import Control.Monad (forM_, liftM, unless, when)+import Control.Monad.State (StateT)+import qualified Control.Monad.State as S+import Control.Monad.Trans (MonadIO (liftIO))+import Data.ByteString (ByteString)+import Data.Function (on)+import qualified Data.IntMap.Strict as IntMap+import Data.List (foldl')+import qualified Data.List as L+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import qualified Database.Muesli.Allocator as GapsIndex+import qualified Database.Muesli.Cache as Cache+import Database.Muesli.Indexes+import Database.Muesli.State+import Database.Muesli.Types+import Prelude hiding (filter, lookup)++-- | Abstract monad for writing and evaluating queries under ACID semantics.+--+-- The @l@ parameter stands for a 'LogState' backend, @m@ is a 'MonadIO' that gets+-- lifted, so users can run arbitrary IO inside queries, and @a@ is the result.+newtype Transaction l m a = Transaction+ { unTransaction :: StateT (TransactionState l) m a }+ deriving (Functor, Applicative, Monad)++instance MonadIO m => MonadIO (Transaction l m) where+ liftIO = Transaction . liftIO++-- | State held inside a 'Transaction'.+--+-- Note: The 'Transaction' type is internally 'StateT' ('TransactionState' l) m a.+data TransactionState l = TransactionState+ { transHandle :: !(Handle l)+-- | Allocated by 'runQuery' with 'mkNewTransactionId' (auto-incremental)+ , transId :: !TransactionId+-- | Accumulates all documents' keys that have been read as part of the+-- transaction. It is considered that all updates in the transaction may depend+-- of these, so the transaction is aborted if concurrent transactions update+-- any of them.+ , transReadList :: ![DocumentKey]+-- | Accumulates all updated or deleted documents' keys.+ , transUpdateList :: ![(LogRecord, ByteString)]+ }++-- | Error returned by 'runQuery' for aborted transactions.+--+-- It is an instance of 'Exception' solely for user convenience,+-- as the database never throws it.+data TransactionAbort+ -- | Returned when trying to update an 'Unique' field with a preexisting value.+ = AbortUnique String+ -- | Returned when there is a conflict with concurrent transactions.+ -- This happenes when the 'transUpdateList' of transactions in 'logPend' or+ -- 'logComp' with 'transId' > then our own 'transId' has any keys that we also+ -- have in either 'transReadList', or 'transUpdateList'.+ --+ -- The second part could be relaxed in the future based on a user policy,+ -- since overwriting updates are sometimes acceptable.+ | AbortConflict String+ -- | Returned when trying to delete a document that is still referenced by+ -- other documents.+ --+ -- TODO: Current implementation is not completely safe in this regard, as updates+ -- should also be checked. The reason is that the check is performed on indexes+ -- and on the pending log. So there is a small window in which it is possible+ -- for a concurrent transaction to update a record deleted by the current one,+ -- before adding it to the pending log, without any error.+ | AbortDelete String+ deriving (Show)++instance Exception TransactionAbort++-- | 'Transaction' evaluation inside a 'MonadIO'.+--+-- Lookups are executed directly, targeting a specific version ('TransactionId')+-- , while the keys of both read and written documents are collected in the+-- 'TransactionState'.+--+-- At the end various consistency checks are performed, and the transaction is+-- aborted in case any fails. See 'TransactionAbort' for details.+--+-- Otherwise, under master lock, space in the data (abstract) file is allocated+-- with 'GapsIndex.alloc', and the transaction records are written in the+-- 'logPend', and also in the log file, with 'logAppend'.+--+-- Writing the serialized data to the data file, updating indexes and completing+-- the transaction is then left for the 'commitThread'.+-- Note that transactions are only durable after 'commitThread' finishes.+-- In the future we may add a blocking version of 'runQuery'.+runQuery :: (MonadIO m, LogState l) => Handle l -> Transaction l m a ->+ m (Either TransactionAbort a)+runQuery h (Transaction t) = do+ tid <- mkNewTransactionId h+ (a, q, u) <- runUserCode tid+ if null u then return $ Right a+ else withMaster h $ \m ->+ if | not $ checkUnique u (unqIdx m) (logPend m) -> return (m, Left $+ AbortUnique "Transaction aborted: uniqueness check failed.")+ | not $ checkConflict tid (logPend m) (logComp m) q u -> return (m, Left $+ AbortConflict "Transaction aborted: conflict with concurrent transactions.")+ | not $ checkDelete m u -> return (m, Left $+ AbortDelete "Document cannot be deleted. Other documents still point to it.")+ | otherwise -> do+ let (ts, gs) = L.foldl' allocFold ([], gaps m) u+ st <- logAppend (logState m) (Pending . fst <$> ts)+ let m' = m { logState = st+ , gaps = gs+ , logPend = Map.insert tid ts $ logPend m+ }+ return (m', Right a)+ where+ runUserCode tid = do+ (a, TransactionState _ _ q u) <- S.runStateT t+ TransactionState+ { transHandle = h+ , transId = tid+ , transReadList = []+ , transUpdateList = []+ }+ let u' = L.nubBy ((==) `on` recDocumentKey . fst) u+ return (a, q, u')++ checkUnique u idx logp = all ck u+ where ck (d, _) = recDeleted d || all (cku $ recDocumentKey d) (recUniques d)+ cku did (pid, val) =+ cku' did (liftM fromIntegral $ IntMap.lookup (fromIntegral pid) idx >>=+ IntMap.lookup (fromIntegral val)) &&+ cku' did (findUnique pid val (concat $ Map.elems logp))+ cku' did = maybe True (== did)++ checkConflict tid logp logc q u = ck qs && ck us+ where+ us = (\(d,_) -> (fromIntegral (recDocumentKey d), ())) <$> u+ qs = (\k -> (fromIntegral k, ())) <$> q+ ck lst = Map.null (Map.intersection newPs ml) &&+ Map.null (Map.intersection newCs ml)+ where ml = Map.fromList lst+ newPs = snd $ Map.split tid logp+ newCs = snd $ Map.split tid logc++ checkDelete m u = all ck . L.filter recDeleted $ map fst u+ where ck d = all (ckEmpty $ fromIntegral did) lst && all (ckPnd did) rs+ where did = recDocumentKey d+ lst = IntMap.elems $ refIdx m+ ckEmpty did idx =+ case IntMap.lookup did idx of+ Nothing -> True+ Just ss -> all null $ IntMap.elems ss+ rs = L.filter (not . recDeleted) . map fst . concat . Map.elems $ logPend m+ ckPnd did r = not . any ((did ==) . snd) $ recReferences r++ allocFold (ts, gs) (r, bs) =+ if recDeleted r then ((r, bs):ts, gs)+ else ((r', bs):ts, gs')+ where (a, gs') = GapsIndex.alloc gs $ recSize r+ r' = r { recAddress = a }++-- | Code for the commit thread forked by 'Database.Muesli.Handle.open'.+--+-- It periodically checks for new records in the 'logPend', and processes them,+-- by adding a 'Completed' record to the log file with 'logAppend', and+-- updating indexes with 'updateMainIdx', 'updateRefIdx', 'updateSortIdx' and+-- 'updateUnqIdx', after writing (without master lock) the serialized documents+-- in the data file with 'writeDocument'.+-- It also moves the records from 'logPend' to 'logComp'.+commitThread :: LogState l => Handle l -> Bool -> IO ()+commitThread h w = do+ (kill, wait) <- withCommitSgn h $ \kill -> do+ wait <- if kill then return True else do+ when w . threadDelay . commitDelay $ unHandle h+ withMasterLock h $ \m ->+ let lgp = logPend m in+ if null lgp then return Nothing+ else return . Just $ Map.findMin lgp+ >>=+ maybe (return True) (\(tid, rs) -> do+ withData h $ \(DataState hnd cache) -> do+ forM_ rs $ \(r, bs) -> writeDocument r bs hnd+ let cache' = foldl' (\c (r, _) -> Cache.delete (fromIntegral $ recAddress r) c)+ cache rs+ return (DataState hnd cache', ())+ withMaster h $ \m -> do+ let rs' = fst <$> rs+ let trec = Completed tid+ st <- logAppend (logState m) [trec]+ let (lgp, lgc) = updateLog tid (keepTrans m) (logPend m) (logComp m)+ let m' = m { logState = st+ , logPend = lgp+ , logComp = lgc+ , mainIdx = updateMainIdx (mainIdx m) rs'+ , unqIdx = updateUnqIdx (unqIdx m) rs'+ , sortIdx = updateSortIdx (sortIdx m) rs'+ , refIdx = updateRefIdx (refIdx m) rs'+ }+ return (m', null lgp))+ return (kill, (kill, wait))+ unless kill $ commitThread h wait+ where updateLog tid keep lgp lgc = (lgp', lgc')+ where ors = map fst . fromMaybe [] $ Map.lookup tid lgp+ lgp' = Map.delete tid lgp+ lc = if not keep && null lgp'+ then Map.empty else lgc+ lgc' = if keep || not (null lgp')+ then Map.insert tid ors lc else lc
+ src/Database/Muesli/GC.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.GC+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Asynchronous garbage collector for the database.+--+-- The GC creates fresh copies of both the log and the data (abstract) files,+-- fully /cleaned/, respectively /compacted/, and finally takes a master lock,+-- appends the transaction data that was added in the mean time, and uses the+-- 'swapDb' function to make the new files current. No expensive lock needs+-- to be taken in the beginning, since all indexes are purely functional and+-- we just take some pointers.+--+-- /Cleaning/ means removal of all versions of deleted records, and all but the+-- most recent version for the rest.+--+-- /Compacting/ means all records are reallocated contiguously starting from+-- 'DocAddress' 0. In particular, it creates a fresh empty 'gaps' index with the+-- help of 'Gaps.buildExtra'.+--+-- The complete operation takes __O(n*log(n))__ time, but the lock is held only+-- for __O(k*log(n))__ at the end, where k represents the number of new records,+-- which is similar to a normal query.+-- For this reason it is safe to run the GC at any time.+--+-- The database does not call 'Database.Muesli.Handle.performGC' by itself,+-- but leaves this to the user. Programs that only rarely+-- 'Database.Muesli.Query.delete' or 'Database.Muesli.Query.update' records+-- don't even need to run the GC, or they can make it an admin action.+----------------------------------------------------------------------------++module Database.Muesli.GC+ ( gcThread ) where++import Control.Concurrent (threadDelay)+import Control.Monad (forM_, unless, when)+import Control.Monad.Trans (MonadIO)+import Data.Function (on)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.List (foldl', groupBy, sortOn)+import Data.Map.Strict ((\\))+import qualified Data.Map.Strict as Map+import qualified Database.Muesli.Allocator as Gaps+import qualified Database.Muesli.IdSupply as Ids+import Database.Muesli.Indexes+import Database.Muesli.State+import Database.Muesli.Types++-- | Code for the GC thread forked by 'Database.Muesli.Handle.open'.+--+-- It listens for messages sent by 'Database.Muesli.Handle.performGC' through+-- 'gcState', and performs the GC operation.+gcThread :: forall l. LogState l => Handle l -> IO ()+gcThread h = do+ sgn <- withGC h $ \sgn -> do+ when (sgn == PerformGC) $ do+ (mainIdxOld, logCompOld) <- withMaster h $ \m ->+ return (m { keepTrans = True }, (mainIdx m, logComp m))+ let rs = map head . filter (not . any recDeleted) $ IntMap.elems mainIdxOld+ let (rs2, dpos) = realloc 0 rs+ let rs' = sortOn recTransactionId $ map fst rs2+ let ts = concatMap toTransRecord $ groupBy ((==) `on` recTransactionId) rs'+ let ids = foldl' (\s r -> Ids.reserve (recDocumentKey r) s) Ids.empty .+ map fromPending $ filter isPending ts+ let logPath = logDbPath (unHandle h)+ let logPathNew = logPath ++ ".new"+ withDb logPathNew $ \hnd -> do+ st <- logInit hnd+ logAppend (st :: l) ts+ let dataPath = dataDbPath (unHandle h)+ let dataPathNew = dataPath ++ ".new"+ buildDataFile dataPathNew rs2 h+ let mIdx = updateMainIdx IntMap.empty rs'+ let uIdx = updateUnqIdx IntMap.empty rs'+ let iIdx = updateSortIdx IntMap.empty rs'+ let rIdx = updateRefIdx IntMap.empty rs'+ when (forceEval mIdx iIdx rIdx) $ withCommitSgn h $ \kill -> do+ withMaster h $ \nm -> do+ let (ncrs', dpos') = realloc dpos . concat . Map.elems $+ logComp nm \\ logCompOld+ let (logp', dpos'') = realloc' dpos' $ logPend nm+ let ncrs = fst <$> ncrs'+ unless (null ncrs) . withDb logPathNew $ \hnd -> do+ st <- logInit hnd+ logAppend (st :: l) (toTransRecord ncrs)+ return ()+ st <- swapDb logPath logPathNew >>= logInit+ buildDataFile dataPathNew ncrs' h+ let gs = Gaps.buildExtra dpos'' . filter recDeleted $+ ncrs ++ (map fst . concat $ Map.elems logp')+ let m = MasterState { logState = st+ , topTid = topTid nm+ , idSupply = ids+ , keepTrans = False+ , gaps = gs+ , logPend = logp'+ , logComp = Map.empty+ , mainIdx = updateMainIdx mIdx ncrs+ , unqIdx = updateUnqIdx uIdx ncrs+ , sortIdx = updateSortIdx iIdx ncrs+ , refIdx = updateRefIdx rIdx ncrs+ }+ return (m, ())+ withData h $ \(DataState _ cache) -> do+ hnd' <- swapDb dataPath dataPathNew+ return (DataState hnd' cache, ())+ return (kill, ())+ let sgn' = if sgn == PerformGC then IdleGC else sgn+ return (sgn', sgn')+ unless (sgn == KillGC) $ do+ threadDelay $ 1000 * 1000+ gcThread h++isPending :: TransRecord -> Bool+isPending (Pending _) = True+isPending (Completed _) = False++fromPending :: TransRecord -> LogRecord+fromPending (Pending r) = r++toTransRecord :: [LogRecord] -> [TransRecord]+toTransRecord rs = foldl' (\ts r -> Pending r : ts)+ [Completed . recTransactionId $ head rs] rs++realloc :: DocAddress -> [LogRecord] -> ([(LogRecord, LogRecord)], DocAddress)+realloc st = foldl' f ([], st)+ where f (nrs, pos) r =+ if recDeleted r then ((r, r) : nrs, pos)+ else ((r { recAddress = pos }, r) : nrs, pos + recSize r)++realloc' :: DocAddress -> PendingIndex -> (PendingIndex, DocAddress)+realloc' st idx = (Map.fromList l, pos)+ where (l, pos) = foldl' f ([], st) $ Map.toList idx+ f (lst, p) (tid, rs) = ((tid, rs') : lst, p')+ where (rss', p') = realloc p $ fst <$> rs+ rs' = (fst <$> rss') `zip` (snd <$> rs)++forceEval :: IntMap a -> IntMap b -> IntMap c -> Bool+forceEval mIdx iIdx rIdx = IntMap.notMember (-1) mIdx &&+ IntMap.size iIdx > (-1) &&+ IntMap.size rIdx > (-1)++buildDataFile :: forall m l. (MonadIO m, LogState l) => FilePath ->+ [(LogRecord, LogRecord)] -> Handle l -> m ()+buildDataFile path rs h =+ withDb path $ \hnd ->+ forM_ rs $ \(r, oldr) -> do+ bs <- withDataLock h $ \(DataState dh _) -> readDocument dh oldr+ writeDocument r bs (hnd :: DataHandleOf l)
+ src/Database/Muesli/Handle.hs view
@@ -0,0 +1,177 @@+-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.Handle+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Database resource management.+----------------------------------------------------------------------------++module Database.Muesli.Handle+ ( module Database.Muesli.Types+ , module Database.Muesli.Backend.Types+ , module Database.Muesli.Backend.File+ , Handle+ , open+ , close+ , performGC+ , debug+ ) where++import Control.Concurrent (forkIO, newMVar)+import Control.Exception (throw)+import Control.Monad.Trans (MonadIO (liftIO))+import qualified Data.ByteString as B+import qualified Data.IntMap.Strict as IntMap+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Time ()+import Data.Time.Clock (NominalDiffTime)+import qualified Database.Muesli.Allocator as GapsIndex+import Database.Muesli.Backend.File+import Database.Muesli.Backend.Types+import qualified Database.Muesli.Cache as Cache+import Database.Muesli.Commit+import Database.Muesli.GC+import qualified Database.Muesli.IdSupply as Ids+import Database.Muesli.Indexes+import Database.Muesli.State+import Database.Muesli.Types+import System.FilePath ((</>))++-- | Opens a database, reads the transaction log and builds the in-memory indexes.+--+-- The @l@ parameter of the resulting 'Handle' should be instantiated by the user+-- in order to specify a backend. For example, to use the file backend:+--+-- @+-- import qualified Database.Muesli.Handle as DB+--+-- openDataBase :: FilePath -> FilePath -> IO (DB.Handle DB.FileLogState)+-- openDataBase logPath dataPath = open (Just logPath) (Just dataPath) Nothing Nothing+-- @+open :: (MonadIO m, LogState l)+ => Maybe DbPath -- ^ Log path. Default is @data/docdb.log@.+ -> Maybe DbPath -- ^ Data path. Default is @data/docdb.dat@.+ -> Maybe (Int, Int, NominalDiffTime) -- ^ 'Cache.LRUCache' parameters:+-- (min cap in bytes, max cap in bytes, max age in seconds).+-- Defaults are: (1MB, 10MB, 1min).+ -> Maybe Int -- ^ Commit delay in microseconds. Default is 100ms.+ -> m (Handle l)+open lf df mbc mbcd = do+ let logPath = fromMaybe ("data" </> "docdb.log") lf+ let datPath = fromMaybe ("data" </> "docdb.dat") df+ let (minc, maxc, maxa) = fromMaybe (0x100000, 0x100000 * 10, 60) mbc+ let coDel = fromMaybe (100 * 1000) mbcd+ dh <- openDb datPath+ st <- openDb logPath >>= logInit+ let m = MasterState { logState = st+ , topTid = 0+ , idSupply = Ids.empty+ , keepTrans = False+ , gaps = GapsIndex.empty 0+ , logPend = Map.empty+ , logComp = Map.empty+ , mainIdx = IntMap.empty+ , unqIdx = IntMap.empty+ , sortIdx = IntMap.empty+ , refIdx = IntMap.empty+ }+ m' <- readLog m+ let m'' = m' { gaps = GapsIndex.build $ mainIdx m' }+ mv <- liftIO $ newMVar m''+ let d = DataState { dataHandle = dh+ , dataCache = Cache.empty minc maxc maxa+ }+ dv <- liftIO $ newMVar d+ um <- liftIO $ newMVar False+ gc <- liftIO $ newMVar IdleGC+ let h = Handle DBState { logDbPath = logPath+ , dataDbPath = datPath+ , commitDelay = coDel+ , masterState = mv+ , dataState = dv+ , commitSgn = um+ , gcState = gc+ }+ liftIO . forkIO $ commitThread h True+ liftIO . forkIO $ gcThread h+ return h++readLog :: (MonadIO m, LogState l) => MasterState l -> m (MasterState l)+readLog m = do+ let logp = logPend m+ mbln <- logRead (logState m)+ case mbln of+ Nothing -> return m+ Just ln -> readLog $ case ln of+ Pending r ->+ let tid = recTransactionId r in+ let ids = Ids.reserve (recDocumentKey r) (idSupply m) in+ case Map.lookup tid logp of+ Nothing -> m { topTid = max tid (topTid m)+ , idSupply = ids+ , logPend = Map.insert tid [(r, B.empty)] logp }+ Just rs -> m { topTid = max tid (topTid m)+ , idSupply = ids+ , logPend = Map.insert tid ((r, B.empty):rs) logp }+ Completed tid ->+ case Map.lookup tid logp of+ Nothing -> throw . LogParseError . showString "Completed TransactionId:" $+ shows tid " found for nonexisting transaction."+ Just rps -> let rs = fst <$> rps in+ m { logPend = Map.delete tid logp+ , mainIdx = updateMainIdx (mainIdx m) rs+ , unqIdx = updateUnqIdx (unqIdx m) rs+ , sortIdx = updateSortIdx (sortIdx m) rs+ , refIdx = updateRefIdx (refIdx m) rs+ }++-- | Sends a message to the 'Database.Muesli.GC.gcThread' requesting GC.+performGC :: MonadIO m => Handle l -> m ()+performGC h = withGC h . const $ return (PerformGC, ())++-- | A debug function that traces the internal 'DBState'.+debug :: (MonadIO m, LogState l)+ => Handle l+ -> Bool -- ^ Dump indexes.+ -> Bool -- ^ Dump the cache.+ -> m String+debug h sIdx sCache = do+ mstr <- withMasterLock h $ \m -> return $+ showsH "logState : " (logState m) .+ showsH "\ntopTid : " (topTid m) .+ showsH "\nidSupply :\n " (idSupply m) .+ showsH "\nlogPend :\n " (logPend m) .+ showsH "\nlogComp :\n " (logComp m) .+ if sIdx then+ showsH "\nmainIdx :\n " (mainIdx m) .+ showsH "\nunqIdx :\n " (unqIdx m) .+ showsH "\nsortIdx :\n " (sortIdx m) .+ showsH "\nrefIdx :\n " (refIdx m) .+ showsH "\ngaps :\n " (gaps m)+ else showString ""+ dstr <- withDataLock h $ \d -> return $+ showsH "\ncacheSize : " (Cache.size $ dataCache d) .+ if sCache then+ showsH "\ncache :\n " (Cache.queue $ dataCache d)+ else showString ""+ return $ mstr . dstr $ ""+ where showsH s a = showString s . shows a++-- | Closes the database.+--+-- Since the database is ACID, calling 'close' is not really necessary for+-- consistency purposes.+close :: (MonadIO m, LogState l) => Handle l -> m ()+close h = do+ withGC h . const $ return (KillGC, ())+ withCommitSgn h . const $ return (True, ())+ withMasterLock h $ \m -> closeDb $ logHandle (logState m)+ withDataLock h $ \(DataState d _) -> closeDb d++{-# ANN module "HLint: ignore Use import/export shortcut" #-}
+ src/Database/Muesli/IdSupply.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE MultiWayIf #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.IdSupply+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Unique 'DocumentKey' allocation functions.+--+-- Since we use 'IntMap's for our indexes, a (faster) auto-incremented key+-- will be exhausted on 32 bit machines before we reach a 'maxBound' number+-- of documents, because deleted keys cannot be reused.+--+-- This module should be imported qualified.+----------------------------------------------------------------------------++module Database.Muesli.IdSupply+ ( IdSupply+ , empty+ , reserve+ , alloc+ ) where++import Control.Exception (throw)+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as Map+import Database.Muesli.Types (DatabaseError (..), DocumentKey)++-- | A map from keys to gap sizes.+type IdSupply = IntMap Int++-- | Holds a single gap of size 'maxBound' - 1, starting at address 1.+empty :: IdSupply+empty = Map.singleton 1 (maxBound - 1)++-- | Removes a key from the supply. Used during log loading.+reserve :: DocumentKey -> IdSupply -> IdSupply+reserve didb s = maybe s+ (\(st, sz) ->+ let delta = did - st in+ if | did >= st + sz -> s+ | did == st && sz == 1 -> Map.delete st s+ | did == st -> Map.insert (did + 1) (sz - 1) $+ Map.delete st s+ | did == st + sz - 1 -> Map.insert st (sz - 1) s+ | otherwise -> Map.insert (did + 1) (sz - delta - 1) $+ Map.insert st delta s)+ (Map.lookupLE did s)+ where did = fromIntegral didb++-- | Allocates a fresh key from the supply.+--+-- Favours smallest numbers. For instance, after a document is deleted and+-- garbage collected, the 'DocumentKey' of that document typically becomes+-- the smallest, and thus the first available.+-- For this reason, 'IdSupply' will normally be small and efficient.+alloc :: IdSupply -> (DocumentKey, IdSupply)+alloc s =+ case Map.lookupGE 0 s of+ Nothing -> throw $ IdAllocationError "Key allocation error: supply empty."+ Just (st, sz) ->+ let did = fromIntegral st in+ if sz == 1 then (did, Map.delete st s)+ else (did, Map.insert (st + 1) (sz - 1) $ Map.delete st s)
+ src/Database/Muesli/Indexes.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.Indexes+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Incremental database index update functions.+--+-- Used during loading, query evaluation, and GC.+----------------------------------------------------------------------------++module Database.Muesli.Indexes+ ( updateMainIdx+ , updateRefIdx+ , updateSortIdx+ , updateUnqIdx+ ) where++import qualified Data.IntMap.Strict as Map+import qualified Data.IntSet as Set+import Data.List (foldl')+import Database.Muesli.State++-- | Updates the 'MainIndex' (allocation table).+updateMainIdx :: MainIndex -> [LogRecord] -> MainIndex+updateMainIdx = foldl' f+ where f idx r = let did = fromIntegral (recDocumentKey r) in+ let rs' = maybe [r] (r:) (Map.lookup did idx) in+ Map.insert did rs' idx++-- | Updates the 'UniqueIndex'.+updateUnqIdx :: UniqueIndex -> [LogRecord] -> UniqueIndex+updateUnqIdx = foldl' f+ where f idx r = foldl' g idx (recUniques r)+ where+ did = fromIntegral (recDocumentKey r)+ del = recDeleted r+ g idx' lnk =+ let rpid = fromIntegral (fst lnk) in+ let rval = fromIntegral (snd lnk) in+ case Map.lookup rpid idx' of+ Nothing -> if del then idx'+ else Map.insert rpid (Map.singleton rval did) idx'+ Just is -> Map.insert rpid is' idx'+ where is' = if del then Map.delete rval is+ else Map.insert rval did is++-- | Updates the main 'SortIndex', and also the 'SortIndex'es inside a 'FilterIndex'.+updateSortIdx :: SortIndex -> [LogRecord] -> SortIndex+updateSortIdx = foldl' f+ where f idx r = foldl' g idx (recSortables r)+ where+ did = fromIntegral (recDocumentKey r)+ del = recDeleted r+ g idx' lnk =+ let rpid = fromIntegral (fst lnk) in+ let rval = fromIntegral (snd lnk) in+ let sng = Set.singleton did in+ case Map.lookup rpid idx' of+ Nothing -> if del then idx'+ else Map.insert rpid (Map.singleton rval sng) idx'+ Just is -> Map.insert rpid is' idx'+ where is' = case Map.lookup rval is of+ Nothing -> if del then is+ else Map.insert rval sng is+ Just ss -> if Set.null ss' then Map.delete rval is+ else Map.insert rval ss' is+ where ss' = if del then Set.delete did ss+ else Set.insert did ss++-- | Updates the 'FilterIndex'.+--+-- Calls 'updateSortIdx' for the internal sorted indexes.+updateRefIdx :: FilterIndex -> [LogRecord] -> FilterIndex+updateRefIdx = foldl' f+ where f idx r = foldl' g idx (recReferences r)+ where+ del = recDeleted r+ g idx' lnk =+ let rpid = fromIntegral (fst lnk) in+ let rval = fromIntegral (snd lnk) in+ let sng = updateSortIdx Map.empty [r] in+ case Map.lookup rpid idx' of+ Nothing -> if del then idx'+ else Map.insert rpid (Map.singleton rval sng) idx'+ Just is -> Map.insert rpid is' idx'+ where is' = case Map.lookup rval is of+ Nothing -> if del then is+ else Map.insert rval sng is+ Just ss -> Map.insert rval ss' is+ where ss' = updateSortIdx ss [r]
+ src/Database/Muesli/Query.hs view
@@ -0,0 +1,324 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.Query+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- The 'Transaction' monad and its primitive queries.+--+-- All queries in this module are run on indexes and perform an+-- __O(log n)__ worst case operation.+----------------------------------------------------------------------------++module Database.Muesli.Query+ ( module Database.Muesli.Types+ , module Database.Muesli.Backend.Types+-- * The Transaction monad+ , Transaction+ , runQuery+ , TransactionAbort (..)+-- * Primitive queries+-- ** CRUD operations+ , lookup+ , insert+ , update+ , delete+-- ** Range queries+ , range+ , rangeK+ , filter+-- ** Queries on unique fields+ , lookupUnique+ , updateUnique+-- ** Other+ , size+ ) where++import Control.Applicative ((<|>))+import Control.Exception (throw)+import Control.Monad (forM, liftM)+import qualified Control.Monad.State as S+import Control.Monad.Trans (MonadIO)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.IntSet (IntSet)+import qualified Data.IntSet as Set+import qualified Data.List as L+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Serialize (Serialize (..), decode, encode)+import Data.String (IsString (..))+import Data.Time.Clock (getCurrentTime)+import Data.Typeable (Typeable)+import Database.Muesli.Backend.Types+import qualified Database.Muesli.Cache as Cache+import Database.Muesli.Commit+import Database.Muesli.State+import Database.Muesli.Types+import Prelude hiding (filter, lookup)++-- | Dereferences the given key. Returns 'Nothing' if the key is not found.+lookup :: (Document a, LogState l, MonadIO m) => Reference a ->+ Transaction l m (Maybe (Reference a, a))+lookup (Reference did) = Transaction $ do+ t <- S.get+ mbr <- withMasterLock (transHandle t) $ \m ->+ return $ findFirstDoc m t did+ mba <- maybe (return Nothing) (\(r, mbs) -> do+ a <- getDocument (transHandle t) r mbs+ return $ Just (Reference did, a))+ mbr+ S.put t { transReadList = did : transReadList t }+ return mba++findFirstDoc :: MasterState l -> TransactionState l -> DocumentKey ->+ Maybe (LogRecord, Maybe ByteString)+findFirstDoc m t did = do+ (r, mbs) <- liftM (fmap Just)+ (L.find ((== did) . recDocumentKey . fst) (transUpdateList t))+ <|> liftM (, Nothing)+ (IntMap.lookup (fromIntegral did) (mainIdx m) >>=+ L.find ((<= transId t) . recTransactionId))+ if recDeleted r then Nothing else Just (r, mbs)++-- | Returns a 'Reference' to a document uniquely determined by the given+-- 'Unique' key value, or 'Nothing' if the key is not found.+lookupUnique :: (ToKey (Unique b), MonadIO m) =>+ Property a -> Unique b -> Transaction l m (Maybe (Reference a))+lookupUnique p ub = Transaction $ do+ t <- S.get+ let u = toKey ub+ withMasterLock (transHandle t) $ \m -> return . liftM Reference $+ findUnique pp u (transUpdateList t)+ <|> (findUnique pp u . concat . Map.elems $ logPend m)+ <|> liftM fromIntegral (IntMap.lookup (fromIntegral pp) (unqIdx m) >>=+ IntMap.lookup (fromIntegral u))+ where pp = fst $ unProperty p++-- | Performs a 'lookupUnique' and then, depending whether the key exists or not,+-- either 'insert's or 'update's the respective document.+updateUnique :: (Document a, ToKey (Unique b), MonadIO m) =>+ Property a -> Unique b -> a -> Transaction l m (Reference a)+updateUnique p u a = do+ mdid <- lookupUnique p u+ case mdid of+ Nothing -> insert a+ Just did -> update did a >> return did++-- | Updates a document.+--+-- Note that since @muesli@ is a MVCC database, this means inserting a new+-- version of the document. The version number is the 'TransactionId' of the+-- current transaction. This fact is transparent to the user though.+update :: forall a l m. (Document a, MonadIO m) =>+ Reference a -> a -> Transaction l m ()+update did a = Transaction $ do+ t <- S.get+ let bs = encode a+ let is = getIndexables a+ let r = LogRecord { recDocumentKey = unReference did+ , recTransactionId = transId t+ , recUniques = p2k <$> ixUniques is+ , recSortables = p2k <$> ixSortables is+ , recReferences = p2k <$> ixReferences is+ , recAddress = 0+ , recSize = fromIntegral $ B.length bs+ , recDeleted = False+ }+ S.put t { transUpdateList = (r, bs) : transUpdateList t }+ where+ p2k (p, val) = (getP p, val)+ getP p = fst $ unProperty (fromString p :: Property a)++-- | Inserts a new document and returns its key.+--+-- The primary key is generated with 'mkNewDocumentKey'.+insert :: (Document a, MonadIO m) => a -> Transaction l m (Reference a)+insert a = Transaction $ do+ t <- S.get+ did <- mkNewDocumentKey $ transHandle t+ unTransaction $ update (Reference did) a+ return $ Reference did++-- | Deletes a document.+--+-- Note that since @muesli@ is a MVCC database, this means inserting a new+-- version with the 'recDeleted' flag set to 'True'.+-- But this fact is transparent to the user, since the indexes are updated+-- as if the record was really deleted.+--+-- It will be the job of the 'Database.Muesli.GC.gcThread' to actually+-- clean the transaction log and compact the data file.+delete :: MonadIO m => Reference a -> Transaction l m ()+delete (Reference did) = Transaction $ do+ t <- S.get+ mb <- withMasterLock (transHandle t) $ \m -> return $ findFirstDoc m t did+ let r = LogRecord { recDocumentKey = did+ , recTransactionId = transId t+ , recUniques = maybe [] (recUniques . fst) mb+ , recSortables = maybe [] (recSortables . fst) mb+ , recReferences = maybe [] (recReferences . fst) mb+ , recAddress = maybe 0 (recAddress . fst) mb+ , recSize = maybe 0 (recSize . fst) mb+ , recDeleted = True+ }+ S.put t { transUpdateList = (r, B.empty) : transUpdateList t }++page_ :: (Document a, ToKey (Sortable b), LogState l, MonadIO m) =>+ (Int -> MasterState l -> [Int]) -> Maybe (Sortable b) ->+ Transaction l m [(Reference a, a)]+page_ f mdid = Transaction $ do+ t <- S.get+ dds <- withMasterLock (transHandle t) $ \m -> do+ let ds = f (ival mdid) m+ let mbds = findFirstDoc m t . fromIntegral <$> ds+ return $ concatMap (foldMap pure) mbds+ dds' <- forM (reverse dds) $ \(d, mbs) -> do+ a <- getDocument (transHandle t) d mbs+ return (Reference $ recDocumentKey d, a)+ S.put t { transReadList = (unReference . fst <$> dds') ++ transReadList t }+ return dds'++-- | Runs a range query on a 'Sortable' field.+--+-- It can be used as a cursor, for precise and efficient paging through a+-- large dataset. For this purpose you should remember the last 'Reference'+-- from the previous page and give it as the /sortKey/ argument below.+-- This is needed since the sortable field may not have unique values, so+-- remembering just the /sortVal/ is insufficient.+--+-- The corresponding SQL is:+--+-- @+-- SELECT TOP page * FROM table+-- WHERE (sortVal = NULL OR sortFld < sortVal) AND (sortKey = NULL OR ID < sortKey)+-- ORDER BY field, ID DESC+-- @+range :: (Document a, ToKey (Sortable b), LogState l, MonadIO m)+ => Maybe (Sortable b) -- ^ The @sortVal@ in the below SQL.+ -> Maybe (Reference a) -- ^ The @sortKey@ below.+ -> Property a -- ^ The @sortFld@ and @table@ below.+ -> Int -- ^ The @page@ below.+ -> Transaction l m [(Reference a, a)]+range mst msti p pg = page_ f mst+ where f st m = fromMaybe [] $ do+ ds <- IntMap.lookup (prop2Int p) (sortIdx m)+ return $ getPage st (rval msti) pg ds++-- | Runs a filter-and-range query on a 'Reference' field, with results sorted+-- on a different 'Sortable' field.+--+-- Sending 'Nothing' for @filterVal@ filters for @NULL@ values, which correspond+-- to a 'Nothing' in a field of type 'Maybe' ('Reference' a). This uses the+-- special 'Maybe' instance mentioned at the 'Indexable' documentation.+--+-- The paging behaviour is the same as for 'range'.+--+-- The corresponding SQL is:+--+-- @+-- SELECT TOP page * FROM table+-- WHERE (filterFld = filterVal) AND+-- (sortVal = NULL OR sortFld < sortVal) AND (sortKey = NULL OR ID < sortKey)+-- ORDER BY field, ID DESC+-- @+filter :: (Document a, ToKey (Sortable b), LogState l, MonadIO m)+ => Maybe (Reference c) -- ^ The @filterVal@ in the below SQL.+ -> Maybe (Sortable b) -- ^ The @sortVal@ below.+ -> Maybe (Reference a) -- ^ The @sortKey@ below.+ -> Property a -- ^ The @sortFld@ and @table@ below.+ -> Property a -- ^ The @filterFld@ and @table@ below.+ -> Int -- ^ The @page@ below.+ -> Transaction l m [(Reference a, a)]+filter mdid mst msti fprop sprop pg = page_ f mst+ where f _ m = fromMaybe [] . liftM (getPage (ival mst) (rval msti) pg) $+ IntMap.lookup (fromIntegral . fst . unProperty $ fprop) (refIdx m) >>=+ IntMap.lookup (fromIntegral $ maybe 0 unReference mdid) >>=+ IntMap.lookup (prop2Int sprop)++pageK_ :: (MonadIO m, ToKey (Sortable b)) => (Int -> MasterState l -> [Int]) ->+ Maybe (Sortable b) -> Transaction l m [Reference a]+pageK_ f mdid = Transaction $ do+ t <- S.get+ dds <- withMasterLock (transHandle t) $ \m -> return $+ concatMap (map (recDocumentKey . fst) . foldMap pure . findFirstDoc m t .+ fromIntegral) $ f (ival mdid) m+ S.put t { transReadList = dds ++ transReadList t }+ return (Reference <$> dds)++-- | Like 'range', but only returns the keys and does not touch the data file.+-- This may be used for implementing a faster deleteRange query, for example.+rangeK :: (Document a, ToKey (Sortable b), MonadIO m)+ => Maybe (Sortable b)+ -> Maybe (Reference a)+ -> Property a+ -> Int+ -> Transaction l m [Reference a]+rangeK mst msti p pg = pageK_ f mst+ where f st m = fromMaybe [] $ getPage st (rval msti) pg <$>+ IntMap.lookup (prop2Int p) (sortIdx m)++getPage :: Int -> Int -> Int -> IntMap IntSet -> [Int]+getPage sta sti pg idx = go sta pg []+ where go st p acc =+ if p == 0 then acc+ else case IntMap.lookupLT st idx of+ Nothing -> acc+ Just (n, is) ->+ let (p', ids) = getPage2 sti p is in+ if p' == 0 then ids ++ acc+ else go n p' $ ids ++ acc++getPage2 :: Int -> Int -> IntSet -> (Int, [Int])+getPage2 sta pg idx = go sta pg []+ where go st p acc =+ if p == 0 then (0, acc)+ else case Set.lookupLT st idx of+ Nothing -> (p, acc)+ Just a -> go a (p - 1) (a:acc)++-- | Returns the number of documents of type @a@ in the database.+size :: (Document a, MonadIO m) => Property a -> Transaction l m Int+size p = Transaction $ do+ t <- S.get+ withMasterLock (transHandle t) $ \m -> return . fromMaybe 0 $+ (sum . map (Set.size . snd) . IntMap.toList) <$>+ IntMap.lookup (prop2Int p) (sortIdx m)++rval :: Maybe (Reference a) -> Int+rval = fromIntegral . unReference . fromMaybe maxBound++ival :: ToKey (Sortable a) => Maybe (Sortable a) -> Int+ival = fromIntegral . maybe maxBound toKey++prop2Int :: Document a => Property a -> Int+prop2Int = fromIntegral . fst . unProperty++getDocument :: (Typeable a, Serialize a, LogState l, MonadIO m) =>+ Handle l -> LogRecord -> Maybe ByteString -> m a+getDocument h r mbs =+ withData h $ \(DataState hnd cache) -> do+ now <- getCurrentTime+ let k = fromIntegral $ recAddress r+ let decodeBs bs =+ either (throw . DataParseError (recAddress r) (recSize r) .+ showString "Deserialization error: ")+ (\a -> return (DataState hnd $ Cache.insert now k a (B.length bs) cache, a))+ (decode bs)+ case mbs of+ Just bs -> decodeBs bs+ Nothing -> case Cache.lookup now k cache of+ Just (a, _, cache') -> return (DataState hnd cache', a)+ Nothing -> readDocument hnd r >>= decodeBs
+ src/Database/Muesli/State.hs view
@@ -0,0 +1,231 @@+-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.State+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- The internal state of the database.+----------------------------------------------------------------------------++module Database.Muesli.State+ ( module Database.Muesli.Backend.Types+ -- * Database state+ , Handle (..)+ , DBState (..)+ , MasterState (..)+ , DataState (..)+ , GCState (..)+ -- ** Allocation table+ , MainIndex+ , GapsIndex+ -- ** Inverted indexes+ , SortIndex+ , FilterIndex+ , UniqueIndex+ -- ** Transaction log+ , PendingIndex+ , CompletedIndex+ -- * Bracket functions+ , withMasterLock+ , withMaster+ , withDataLock+ , withData+ , withGC+ , withCommitSgn+ -- * Utilities+ , mkNewTransactionId+ , mkNewDocumentKey+ , findUnique+ ) where++import Control.Concurrent (MVar, putMVar, takeMVar)+import Control.Exception (bracket, bracketOnError)+import Control.Monad.Trans (MonadIO (liftIO))+import Data.ByteString (ByteString)+import Data.IntMap.Strict (IntMap)+import Data.IntSet (IntSet)+import Data.List (find)+import Data.Map.Strict (Map)+import Database.Muesli.Backend.Types+import Database.Muesli.Cache (LRUCache)+import Database.Muesli.IdSupply (IdSupply)+import qualified Database.Muesli.IdSupply as Ids+import Database.Muesli.Types++-- | Handle used for database management operations.+--+-- The @l@ parameter stands for a 'LogState' backend.+newtype Handle l = Handle { unHandle :: DBState l } deriving (Eq)++instance Show (Handle l) where+ showsPrec p = showsPrec p . logDbPath . unHandle++-- | The internal state of the database.+data DBState l = DBState+ { logDbPath :: DbPath+ , dataDbPath :: DbPath+ , commitDelay :: Int+ , masterState :: MVar (MasterState l)+ , dataState :: MVar (DataState l)+ , commitSgn :: MVar Bool -- ^ Used to send the kill signal to the+-- 'Database.Muesli.Commit.commitThread'+ , gcState :: MVar GCState -- ^ Used to communicate with the+-- 'Database.Muesli.GC.gcThread'+ }++instance Eq (DBState l) where+ s == s' = logDbPath s == logDbPath s'++-- | Type of the allocation table of the database.+--+-- The key of the 'IntMap' is the 'DocumentKey' of the corresponding document.+type MainIndex = IntMap [LogRecord]++-- | Type of the sort index, which an+-- <https://en.wikipedia.org/wiki/Inverted_index inverted index>.+--+-- First key is 'PropertyKey', second is 'SortableKey', and the 'IntSet'+-- contains all 'DocumentKey's for the documents whose fields have the values+-- specified by the first two keys.+type SortIndex = IntMap (IntMap IntSet)++-- | Type of the filter index, which is a 2-level nested+-- <https://en.wikipedia.org/wiki/Inverted_index inverted index>.+--+-- First key is the 'PropertyKey' for the filter field, second is the+-- 'DocumentKey' of the filter field value, and then an entire 'SortIndex'+-- containing the ordered subset for all sortable fields.+type FilterIndex = IntMap (IntMap SortIndex)++-- | Type of the unique index, which is a simpler+-- <https://en.wikipedia.org/wiki/Inverted_index inverted index>.+--+-- First key is 'PropertyKey', second is the 'UniqueKey', and then the unique+-- 'DocumentKey' corresponding to that 'UniqueKey'.+type UniqueIndex = IntMap (IntMap Int)++-- | A map from gap size to a list of addresses where gaps of that size start.+type GapsIndex = Map DocSize [DocAddress]++-- | The type of the pending transaction log.+--+-- 'Database.Muesli.Query.update' serializes the document before adding it to+-- 'Database.Muesli.Commit.transUpdateList', and later+-- 'Database.Muesli.Commit.commitThread' moves it in the pending log.+type PendingIndex = Map TransactionId [(LogRecord, ByteString)]++-- | The type of the completed transaction log.+type CompletedIndex = Map TransactionId [LogRecord]++-- | Type of the master state, holding all indexes.+--+-- When talking about /master lock/ in other parts, we mean taking the+-- 'masterState' 'MVar'.+data MasterState l = MasterState+ {+ -- | The 'LogState' backend.+ logState :: !l+ -- | Auto-incremented global value for generating 'TransactionId's.+ , topTid :: !TransactionId+ -- | Suppy for generating unique 'DocumentKey's.+ , idSupply :: !IdSupply+ -- | This flag is set during GC, so that 'logComp' is not cleared as normal,+ -- since we need at the end of the GC to find the transactions that completed+ -- in the mean time, and we don't want to do log file IO for that.+ , keepTrans :: !Bool+ , gaps :: !GapsIndex+ , logPend :: !PendingIndex+ , logComp :: !CompletedIndex+ , mainIdx :: !MainIndex+ , unqIdx :: !UniqueIndex+ , sortIdx :: !SortIndex+ , refIdx :: !FilterIndex+ }++-- | The state coresponding to the data file.+data DataState l = DataState+ { dataHandle :: !(DataHandleOf l)+ , dataCache :: !LRUCache+ }++-- | Type for the state of the GC thread used for messaging.+data GCState = IdleGC | PerformGC | KillGC deriving (Eq)++-- | Generates a new 'TransactionId' by incrementing the 'topTid' under+-- master lock.+mkNewTransactionId :: MonadIO m => Handle l -> m TransactionId+mkNewTransactionId h = withMaster h $ \m ->+ let tid = topTid m + 1 in+ return (m { topTid = tid }, tid)++-- | Generates a new 'DocumentKey' by calling 'Ids.alloc' under master lock.+mkNewDocumentKey :: MonadIO m => Handle l -> m DocumentKey+mkNewDocumentKey h = withMaster h $ \m ->+ let (tid, s) = Ids.alloc (idSupply m) in+ return (m { idSupply = s }, tid)++-- | Utility function for searching into a list of 'LogRecord's and into their+-- 'recUniques' for a particular 'UniqueKey'.+findUnique :: PropertyKey -> UniqueKey -> [(LogRecord, a)] -> Maybe DocumentKey+findUnique p u rs = fmap recDocumentKey . find findR $ map fst rs+ where findR = elem (p, u) . recUniques++-- | Standard 'bracket' function for the 'masterState' lock.+withMasterLock :: MonadIO m => Handle l -> (MasterState l -> IO a) -> m a+withMasterLock h = liftIO . bracket+ (takeMVar . masterState $ unHandle h)+ (putMVar . masterState $ unHandle h)++-- | Standard 'bracket' function for the 'masterState' lock that also allows+-- updating the 'MasterState'.+withMaster :: MonadIO m => Handle l -> (MasterState l -> IO (MasterState l, a)) -> m a+withMaster h f = liftIO $ bracketOnError+ (takeMVar . masterState $ unHandle h)+ (putMVar . masterState $ unHandle h)+ (\m -> do+ (m', a) <- f m+ putMVar (masterState $ unHandle h) m'+ return a)++-- | Standard 'bracket' function for the 'dataState' lock.+withDataLock :: MonadIO m => Handle l -> (DataState l -> IO a) -> m a+withDataLock h = liftIO . bracket+ (takeMVar . dataState $ unHandle h)+ (putMVar . dataState $ unHandle h)++-- | Standard 'bracket' function for the 'dataState' lock that also allows+-- updating the 'DataState'.+withData :: MonadIO m => Handle l -> (DataState l -> IO (DataState l, a)) -> m a+withData h f = liftIO $ bracketOnError+ (takeMVar . dataState $ unHandle h)+ (putMVar . dataState $ unHandle h)+ (\d -> do+ (d', a) <- f d+ putMVar (dataState $ unHandle h) d'+ return a)++-- | Standard 'bracket' function for the 'commitSgn' lock that also allows+-- updating the 'Bool'.+withCommitSgn :: MonadIO m => Handle l -> (Bool -> IO (Bool, a)) -> m a+withCommitSgn h f = liftIO $ bracketOnError+ (takeMVar . commitSgn $ unHandle h)+ (putMVar . commitSgn $ unHandle h)+ (\kill -> do+ (kill', a) <- f kill+ putMVar (commitSgn $ unHandle h) kill'+ return a)++-- | Standard 'bracket' function for the 'gcState' lock that also allows+-- updating the 'GCState'.+withGC :: MonadIO m => Handle l -> (GCState -> IO (GCState, a)) -> m a+withGC h f = liftIO $ bracketOnError+ (takeMVar . gcState $ unHandle h)+ (putMVar . gcState $ unHandle h)+ (\s -> do+ (s', a) <- f s+ putMVar (gcState $ unHandle h) s'+ return a)
+ src/Database/Muesli/Types.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_HADDOCK show-extensions #-}++-----------------------------------------------------------------------------+-- |+-- Module : Database.Muesli.Types+-- Copyright : (c) 2015 Călin Ardelean+-- License : MIT+--+-- Maintainer : Călin Ardelean <calinucs@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Muesli markup types and typeclasses.+--+-- Normally, with the @DeriveAnyClass@ and @DeriveGeneric@ extensions enabled,+-- types can be marked up as documents with a+--+-- @+-- deriving (Generic, Serialize)+-- @+--+-- clause, and a separate empty 'Document' instance.+--+-- For structured field types, the following will suffice:+--+-- @+-- deriving (Generic, Serialize, Indexable)+-- @+--+-- Then 'Reference', 'Sortable' and 'Unique' can be used inside document types+-- to mark up the fields that should be automatically indexed, becoming queryable+-- with the primitives in "Database.Muesli.Query".+--+-- The record syntax must be used, and the accesor name will become the+-- 'Property' name used in queries.+----------------------------------------------------------------------------++module Database.Muesli.Types+ (+-- * Indexable value wrappers+ Reference (..)+ , Sortable (..)+ , Unique (..)+-- * Indexable value classes+ , Indexable (..)+ , Document (..)+ , Indexables (..)+-- * Index keyes+ , IxKey (..)+ , ToKey (..)+ , DocumentKey+ , SortableKey+ , UniqueKey+ , PropertyKey+-- * Other+ , Property (..)+ , DateTime (..)+ , DatabaseError (..)+ , TransactionId+ , DocAddress+ , DocSize+ ) where++import Control.Exception (Exception)+import Control.Monad (liftM)+import Data.Bits (Bits, FiniteBits)+import Data.Data (Data)+import Data.Hashable (Hashable, hash)+import Data.List (foldl')+import Data.Serialize (Serialize (..))+import Data.String (IsString (..))+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime,+ utcTimeToPOSIXSeconds)+import Data.Time.Format (FormatTime, ParseTime)+import Data.Typeable (Proxy (..), Typeable, typeRep)+import Data.Word (Word64, Word8)+import Foreign (Storable, sizeOf)+import GHC.Generics ((:*:) (..), (:+:) (..), C, D, Generic,+ K1 (..), M1 (..), Rep, S, Selector,+ U1 (..), from, selName)+import Numeric (showHex)++-- | Transaction ids are auto-incremented globally.+-- See 'Database.Muesli.State.mkNewTransactionId'.+type TransactionId = Word64+-- | Address in the abstract data file of a serialized document's data.+--+-- These addresses are allocated by functions in the module+-- "Database.Muesli.Allocator".+type DocAddress = Word64+-- | Size of a serialized document's data.+type DocSize = Word64++-- | A @newtype@ wrapper around 'UTCTime' that has 'Show', 'Serialize' and+-- 'ToKey' instances.+newtype DateTime = DateTime { unDateTime :: UTCTime }+ deriving (Eq, Ord, Data, ParseTime, FormatTime)++instance Show DateTime where+ showsPrec p = showsPrec p . unDateTime++instance Serialize DateTime where+ put = put . toRational . utcTimeToPOSIXSeconds . unDateTime+ get = liftM (DateTime . posixSecondsToUTCTime . fromRational) get++-- | Type for exceptions thrown by the database.+-- During normal operation these should never be thrown.+data DatabaseError+ -- | Thrown when the log file is corrupted.+ = LogParseError String+ -- | Thrown after deserialization errors.+ -- Holds starting position, size, and a message.+ | DataParseError DocAddress DocSize String+ -- | ID allocation failure. For instance, full address space on a 32 bit machine.+ | IdAllocationError String+ -- | Data allocation failure.+ -- Containes the size requested, the biggest available gap, and a message.+ | DataAllocationError DocSize (Maybe DocSize) String+ deriving (Show)++instance Exception DatabaseError++-- | Used inside indexes and as arguments to query primitives.+newtype IxKey = IxKey { unIxKey :: Int }+ deriving (Eq, Ord, Bounded, Num, Enum, Real, Integral,+ Bits, FiniteBits, Storable, Serialize)++instance Show IxKey where+ showsPrec _ (IxKey k) = showString "0x" . showHex k++-- | Class used to convert indexable field & query argument values to keys.+--+-- It is possibly needed for users to write instances for 'IxKey'-convertible+-- primitive types, other then the provided 'Bool', 'Int' and 'DateTime'.+class ToKey a where+ toKey :: a -> IxKey++-- | Primary key for a document.+--+-- Allocated by functions in the "Database.Muesli.IdSupply" module.+type DocumentKey = IxKey+-- | Key extracted from non-reference fields for building a+-- 'Database.Muesli.State.SortIndex'.+type SortableKey = IxKey+-- | Key extracted from unique fields for building a+-- 'Database.Muesli.State.UniqueIndex'+type UniqueKey = IxKey+-- | Key generated by 'Property' for building a+-- 'Database.Muesli.State.SortIndex' or a 'Database.Muesli.State.FilterIndex'.+type PropertyKey = IxKey++-- | With the @OverloadedStrings@ extension, or directly using the 'IsString'+-- instance, field names specified in query arguments are converted to+-- 'Property'. An 'IxKey' is computed by hashing the property name together+-- with the 'Data.Typeable.TypeRep' of the phantom argument.+-- This key is used in indexes.+newtype Property a = Property { unProperty :: (PropertyKey, String) }++instance Eq (Property a) where+ Property (pid, _) == Property (pid', _) = pid == pid'++instance Show (Property a) where+ showsPrec p (Property (pid, s)) = showString s . showString "[" .+ showsPrec p pid . showString "]"++instance Typeable a => IsString (Property a) where+ fromString s = Property (pid, s)+ where pid = fromIntegral $ hash (show $ typeRep (Proxy :: Proxy a), s)++-- | 'Reference' fields are pointers to other 'Document's. They are+-- indexed automatically and can be queried with 'Database.Muesli.Query.filter'.+--+-- To ensure type safety, use and store only references returned by the+-- primitive queries, like 'Database.Muesli.Query.insert',+-- 'Database.Muesli.Query.range' or 'Database.Muesli.Query.filter'.+-- Numerical instances like 'Num' or 'Integral' are provided to support+-- generic database programs that take the responsibility of maintaining+-- invariants upon themselves. In this context, type safety means that it is+-- impossible in normal operation to try and deserialize a document at a wrong+-- type or address (note that all primitive query functions are polymorphic),+-- and risk getting bogus data without errors being reported.+newtype Reference a = Reference { unReference :: IxKey }+ deriving (Eq, Ord, Bounded, Num, Enum, Real, Integral, Serialize)++instance Show (Reference a) where+ showsPrec p = showsPrec p . unReference++-- | Marks a field available for sorting and 'range' queries.+--+-- Indexing requires a 'ToKey' instance. Apart from the provided 'Bool', 'Int'+-- and 'DateTime' instances, there is an overlappable fallback instance based on+-- converting the 'Show' string representation to an 'IxKey' by taking the first+-- 4 or 8 bytes. This is good enough for primitive string sorting.+newtype Sortable a = Sortable { unSortable :: a }+ deriving (Eq, Ord, Bounded, Serialize)++instance Show a => Show (Sortable a) where+ showsPrec p = showsPrec p . unSortable++instance ToKey (Sortable IxKey) where+ toKey (Sortable w) = w++instance ToKey (Sortable Bool) where+ toKey (Sortable b) = if b then 1 else 0++instance ToKey (Sortable Int) where+ toKey (Sortable a) = fromIntegral a++instance ToKey (Sortable DateTime) where+ toKey (Sortable (DateTime t)) = round $ utcTimeToPOSIXSeconds t++instance {-# OVERLAPPABLE #-} Show a => ToKey (Sortable a) where+ toKey (Sortable a) = snd $ foldl' f (ws - 1, 0) bytes+ where bytes = (fromIntegral . fromEnum <$> take ws str) :: [Word8]+ f (n, v) b = (n - 1, if n >= 0 then v + fromIntegral b * 2 ^ (8 * n) else v)+ ws = sizeOf (0 :: IxKey)+ str = case show a of+ '"':as -> as+ ss -> ss++-- | 'Unique' fields act as primary keys, and can be queried with+-- 'Database.Muesli.Query.lookupUnique' and 'Database.Muesli.Query.updateUnique'.+-- The 'Hashable' instance is used to generate the key.+--+-- For fields that need to be both unique and sortable, use+-- 'Unique' ('Sortable' a) rather then the other way around.+newtype Unique a = Unique { unUnique :: a }+ deriving (Eq, Serialize)++instance Show a => Show (Unique a) where+ showsPrec p = showsPrec p . unUnique++instance Hashable a => ToKey (Unique (Sortable a)) where+ toKey (Unique (Sortable a)) = fromIntegral $ hash a++instance {-# OVERLAPPABLE #-} Hashable a => ToKey (Unique a) where+ toKey (Unique a) = fromIntegral $ hash a++-- | This class is used by the generic scrapper to extract indexable keys from+-- the fields of a 'Document'. There are instances for 'Reference', 'Sortable'+-- and 'Unique', a general 'Foldable' instance, and a special one for 'Maybe'+-- that converts 'Nothing' into 0, such that null values will be indexed too,+-- and become queryable with 'Database.Muesli.Query.filter'.+--+-- Users are not expected to need writing instances for this class.+-- They can rather be generated automatically with the @DeriveAnyClass@+-- extension.+class Indexable a where+ getIxValues :: a -> [IxKey]+ getIxValues _ = []++ isReference :: Proxy a -> Bool+ isReference _ = False++ getUnique :: a -> Maybe UniqueKey+ getUnique _ = Nothing++instance Indexable (Reference a) where+ getIxValues (Reference did) = [ did ]+ isReference _ = True++instance Indexable (Maybe (Reference a)) where+ getIxValues mb = [ maybe 0 unReference mb ]+ isReference _ = True++instance {-# OVERLAPPABLE #-} (Indexable a, Foldable f) => Indexable (f a) where+ getIxValues = foldMap getIxValues+ isReference _ = isReference (Proxy :: Proxy a)++instance Indexable Bool+instance Indexable Int+instance Indexable String++instance ToKey (Sortable a) => Indexable (Sortable a) where+ getIxValues s = [ toKey s ]+ isReference _ = False++instance (Hashable a, Indexable (Sortable a)) => Indexable (Unique (Sortable a)) where+ getUnique (Unique (Sortable a)) = Just . fromIntegral $ hash a+ getIxValues = getIxValues . unUnique+ isReference _ = isReference (Proxy :: Proxy (Sortable a))++instance {-# OVERLAPPABLE #-} Hashable a => Indexable (Unique a) where+ getUnique (Unique a) = Just . fromIntegral $ hash a++-- | Data type used by the key scrapper to collect keys while traversing+-- generically user types.+data Indexables = Indexables+ { ixReferences :: [(String, DocumentKey)]+ , ixSortables :: [(String, SortableKey)]+ , ixUniques :: [(String, UniqueKey)]+ } deriving (Show)++-- | Class used by the generic key scrapper to extract indexing information+-- from user types. Only an empty instance needs to be added in user code.+class (Typeable a, Generic a, Serialize a) => Document a where+ getIndexables :: a -> Indexables+ default getIndexables :: (GetIndexables (Rep a)) => a -> Indexables+ getIndexables = ggetIndexables "" . from++class GetIndexables f where+ ggetIndexables :: String -> f a -> Indexables++instance GetIndexables U1 where+ ggetIndexables _ U1 = Indexables [] [] []++instance (GetIndexables a, GetIndexables b) => GetIndexables (a :*: b) where+ ggetIndexables _ (x :*: y) = Indexables (xrs ++ yrs) (xis ++ yis) (xus ++ yus)+ where (Indexables xrs xis xus) = ggetIndexables "" x+ (Indexables yrs yis yus) = ggetIndexables "" y++instance (GetIndexables a, GetIndexables b) => GetIndexables (a :+: b) where+ ggetIndexables _ (L1 x) = ggetIndexables "" x+ ggetIndexables _ (R1 x) = ggetIndexables "" x++instance GetIndexables a => GetIndexables (M1 D c a) where+ ggetIndexables _ (M1 x) = ggetIndexables "" x++instance GetIndexables a => GetIndexables (M1 C c a) where+ ggetIndexables _ (M1 x) = ggetIndexables "" x++instance (GetIndexables a, Selector c) => GetIndexables (M1 S c a) where+ ggetIndexables _ m1@(M1 x) = ggetIndexables (selName m1) x++instance Indexable a => GetIndexables (K1 i a) where+ ggetIndexables n (K1 x) =+ if isReference (Proxy :: Proxy a)+ then Indexables { ixReferences = vs, ixSortables = [], ixUniques = us }+ else Indexables { ixReferences = [], ixSortables = vs, ixUniques = us }+ where vs = (\did -> (n, did)) <$> getIxValues x+ us = maybe [] (pure . (n,)) (getUnique x)