diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +### 0.1 + +* initial release diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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" diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/muesli.cabal b/muesli.cabal new file mode 100644 --- /dev/null +++ b/muesli.cabal @@ -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 + + + 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 +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 diff --git a/src/Database/Muesli/Allocator.hs b/src/Database/Muesli/Allocator.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/Allocator.hs @@ -0,0 +1,79 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Database.Muesli.Allocator +-- Copyright : (c) 2015 Călin Ardelean +-- License : MIT +-- +-- Maintainer : Călin Ardelean +-- 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 diff --git a/src/Database/Muesli/Backend/File.hs b/src/Database/Muesli/Backend/File.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/Backend/File.hs @@ -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 +-- 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 "" diff --git a/src/Database/Muesli/Backend/Types.hs b/src/Database/Muesli/Backend/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/Backend/Types.hs @@ -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 +-- 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) diff --git a/src/Database/Muesli/Cache.hs b/src/Database/Muesli/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/Cache.hs @@ -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 +-- Stability : experimental +-- Portability : portable +-- +-- LRU cache implementation using the +-- 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) diff --git a/src/Database/Muesli/Commit.hs b/src/Database/Muesli/Commit.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/Commit.hs @@ -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 +-- 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 diff --git a/src/Database/Muesli/GC.hs b/src/Database/Muesli/GC.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/GC.hs @@ -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 +-- 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) diff --git a/src/Database/Muesli/Handle.hs b/src/Database/Muesli/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/Handle.hs @@ -0,0 +1,177 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Database.Muesli.Handle +-- Copyright : (c) 2015 Călin Ardelean +-- License : MIT +-- +-- Maintainer : Călin Ardelean +-- 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" #-} diff --git a/src/Database/Muesli/IdSupply.hs b/src/Database/Muesli/IdSupply.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/IdSupply.hs @@ -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 +-- 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) diff --git a/src/Database/Muesli/Indexes.hs b/src/Database/Muesli/Indexes.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/Indexes.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Database.Muesli.Indexes +-- Copyright : (c) 2015 Călin Ardelean +-- License : MIT +-- +-- Maintainer : Călin Ardelean +-- 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] diff --git a/src/Database/Muesli/Query.hs b/src/Database/Muesli/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/Query.hs @@ -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 +-- 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 diff --git a/src/Database/Muesli/State.hs b/src/Database/Muesli/State.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/State.hs @@ -0,0 +1,231 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Database.Muesli.State +-- Copyright : (c) 2015 Călin Ardelean +-- License : MIT +-- +-- Maintainer : Călin Ardelean +-- 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 +-- . +-- +-- 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 +-- . +-- +-- 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 +-- . +-- +-- 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) diff --git a/src/Database/Muesli/Types.hs b/src/Database/Muesli/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Muesli/Types.hs @@ -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 +-- 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)