packages feed

lmdb-high-level (empty) → 0.1

raw patch · 10 files changed

+1773/−0 lines, 10 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bytestring, containers, directory, ghc-prim, lmdb, lmdb-high-level, pipes, primitive, random, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Andrew Martin (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Andrew Martin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lmdb-high-level.cabal view
@@ -0,0 +1,59 @@+name:                lmdb-high-level+version:             0.1+synopsis:            Higher level API for working with LMDB+description:         Please see README.md+homepage:            https://github.com/andrewthad/lmdb-high-level+license:             BSD3+license-file:        LICENSE+author:              Andrew Martin+maintainer:          andrew.thaddeus@gmail.com+copyright:           2016 Andrew Martin+category:            web+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:+    Lmdb.Connection+    Lmdb.Map+    Lmdb.Multimap+    Lmdb.Types+    Lmdb.Codec+    Lmdb.Internal+  build-depends:+      base >= 4.7 && < 5+    , text+    , bytestring+    , pipes+    , lmdb+    , transformers+    , ghc-prim+    , vector+    , primitive+  default-language:    Haskell2010++test-suite lmbd-high-level-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:+      base+    , lmdb-high-level+    , test-framework+    , pipes+    , HUnit+    , QuickCheck+    , test-framework-hunit+    , test-framework-quickcheck2+    , random+    , directory+    , text+    , bytestring+    , containers+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/andrewthad/lmdb-high-level
+ src/Lmdb/Codec.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Lmdb.Codec where++import Data.Word+import Control.Monad+import Lmdb.Types+import Foreign.Storable (peek,poke,sizeOf)+import Foreign.Ptr (Ptr,castPtr,plusPtr)+import Foreign.C.Types (CSize(..))+import Data.Text.Internal (Text(..))+import GHC.Int (Int64(I64#))+import GHC.Ptr (Ptr(Ptr))+import GHC.Types (IO(IO),Int(I#))+import Data.Bits (unsafeShiftR,unsafeShiftL)+import qualified Data.Text.Array as TextArray+import GHC.Prim (newByteArray#,copyAddrToByteArray#,unsafeFreezeByteArray#,copyByteArrayToAddr#)+import Data.ByteString.Internal (ByteString(PS))+import Foreign.Marshal.Utils (copyBytes)+import Foreign.ForeignPtr (withForeignPtr,mallocForeignPtrBytes)+import qualified Data.Vector.Unboxed as UVector+import qualified Data.Vector.Unboxed.Mutable as MUVector+import qualified Data.Vector.Primitive as PVector+import Data.Primitive.Types (Prim)+import Data.Vector.Unboxed (Unbox)+import Foreign.Storable (Storable,sizeOf,peekElemOff)+import Control.Monad.Trans.State.Strict (StateT(runStateT),get,put)+import Control.Monad.Trans.Class++text :: Codec 'Variable Text+text = Codec encodeText (Decoding decodeText)++word :: Codec 'MachineWord Word+word = Codec unsafeEncodePaddedIntegral unsafeDecodePaddedIntegral++int :: Codec 'MachineWord Int+int = Codec unsafeEncodePaddedIntegral unsafeDecodePaddedIntegral++word32Padded :: Codec 'MachineWord Word32+word32Padded = Codec unsafeEncodePaddedIntegral unsafeDecodePaddedIntegral++word64 :: Codec 'Fixed Word64+word64 = Codec encodeStorable (decodeStorable "Word64")++word16 :: Codec 'Fixed Word16+word16 = Codec encodeStorable (decodeStorable "Word16")++-- multiWord :: MultiEncoding 'Fixed Word+-- multiWord = MultiEncodingIndexedTraversal 8++plusPtrTyped :: Ptr a -> Int -> Ptr a+plusPtrTyped = plusPtr++-- -- | Nothing checks to make sure that @a@ is represented as a machine word.+-- unsafeMachineUVectorEncoding :: forall a. (Storable a, Unbox a) => MultiEncoding 'MachineWord a+-- unsafeMachineUVectorEncoding =+--   MultiEncodingUnboxedVector SomeFixedSizeMachineWord slowCopyUVectorToPtr+--+-- -- | Nothing checks to make sure that @a@ is represented as a machine word.+-- unsafeMachineUVectorDecoding :: forall a. (Storable a, Unbox a) => MultiDecoding 'MachineWord a+-- unsafeMachineUVectorDecoding =+--   MultiDecodingUnboxedVector SomeFixedSizeMachineWord slowCopyPtrToUVector+--+-- storableUVectorEncoding :: forall a. (Storable a, Unbox a) => MultiEncoding 'Fixed a+-- storableUVectorEncoding =+--   MultiEncodingUnboxedVector (SomeFixedSizeFixed (fromIntegral $ sizeOf (undefined :: a))) slowCopyUVectorToPtr+--+-- storableUVectorDecoding :: forall a. (Storable a, Unbox a) => MultiDecoding 'Fixed a+-- storableUVectorDecoding =+--   MultiDecodingUnboxedVector (SomeFixedSizeFixed (fromIntegral $ sizeOf (undefined :: a))) slowCopyPtrToUVector+--+-- unsafePaddedUVectorEncoding :: forall a. (Integral a, Unbox a) => MultiEncoding 'MachineWord a+-- unsafePaddedUVectorEncoding = MultiEncodingUnboxedVector SomeFixedSizeMachineWord $ \v ptrWord8 -> do+--   let ptr = castPtr ptrWord8 :: Ptr Word+--       sz = sizeOf (undefined :: Word)+--   UVector.imapM_ (\ix a -> poke (plusPtrTyped ptr (ix * sz)) (fromIntegral a)) v+--+-- unsafePaddedUVectorDecoding :: forall a. (Integral a, Unbox a) => MultiDecoding 'MachineWord a+-- unsafePaddedUVectorDecoding = MultiDecodingUnboxedVector SomeFixedSizeMachineWord $ \len ptrWord8 -> do+--   let ptr = castPtr ptrWord8 :: Ptr Word+--   mv <- MUVector.new len+--   _ <- flip runStateT 0 $ whileM_ (fmap (< len) get) $ do+--     ix <- get+--     put (ix + 1)+--     w <- lift $ peekElemOff ptr ix+--     let a = fromIntegral w+--         highBitsSet = w /= fromIntegral a+--     when highBitsSet $ lift $ fail $ concat+--       [ "LMDB unsafePaddedUVectorDecoding: high bits were set in small integral type. "+--       , "Using a padded representation for values is not advised."+--       ]+--     lift $ MUVector.write mv ix a+--   UVector.unsafeFreeze mv+--+-- slowCopyUVectorToPtr :: forall a. (Storable a, Unbox a) => UVector.Vector a -> Ptr Word8 -> IO ()+-- slowCopyUVectorToPtr v ptrWord8 = do+--   let ptr = castPtr ptrWord8 :: Ptr a+--       sz = sizeOf (undefined :: a)+--   UVector.imapM_ (\ix a -> poke (plusPtrTyped ptr (ix * sz)) a) v+--+-- slowCopyPtrToUVector :: forall a. (Storable a, Unbox a) => Int -> Ptr Word8 -> IO (UVector.Vector a)+-- slowCopyPtrToUVector len ptrWord8 = do+--   let ptr = castPtr ptrWord8 :: Ptr a+--   mv <- MUVector.new len+--   _ <- flip runStateT 0 $ whileM_ (fmap (< len) get) $ do+--     ix <- get+--     put (ix + 1)+--     a <- lift $ peekElemOff ptr ix+--     lift $ MUVector.write mv ix a+--   UVector.unsafeFreeze mv++-- constCopyPtrToUVector :: forall a.+--   Word8 -> a -> Int -> Ptr Word8 -> IO ByteArray+-- constCopyPtrToUVector _expected a len _ = return (PVector.replicate len a)+--+-- constCopyUVectorToPtr :: forall a.+--   Word8 -> PVector.Vector a -> Ptr Word8 -> IO ()+-- constCopyUVectorToPtr w8 v ptr = do+--   let v2 = PVector.imap (\ix _ -> ix) v+--   PVector.mapM_ (\ix -> poke (plusPtrTyped ptr ix) w8) v2++-- multiWordEncoding :: ((Word -> IO b) -> f Word -> IO ()) -> f Word -> Ptr Word8 -> IO ()+-- multiWordEncoding theMapM_ t ptrWord8 = do+--   let ptrWord = castPtr ptrWord8 :: Ptr Word+--   theMapM_ (\ix w -> ) t++-- multiWordEncoding :: ((Word -> IO b) -> f Word -> IO ()) -> f Word -> Ptr Word8 -> IO ()+-- multiWordEncoding theMapM_ t ptrWord8 = do+--   let ptrWord = castPtr ptrWord8 :: Ptr Word+--   theMapM_ (\ix w -> ) t++-- int :: Codec Int+-- int = Codec encodeIntegral decodeIntegral+--+-- int64 :: Codec Int64+-- int64 = Codec encodeIntegral decodeIntegral++byteString :: Codec 'Variable ByteString+byteString = Codec encodeByteString (Decoding decodeByteString)++-- | This may only be used for the value. LMDB does not support+--   zero-length keys.+unit :: Codec 'Fixed ()+unit = Codec encodeEmpty (decodeConst ())++encodeEmpty :: Encoding 'Fixed a+encodeEmpty = EncodingFixed 0 $ \_ -> FixedPoke $ \_ -> return ()++-- multiEncodeEmpty :: MultiEncoding 'Fixed a+-- multiEncodeEmpty = MultiEncodingUnboxedVector (SomeFixedSizeFixed 1) (constCopyUVectorToPtr 0)+--+-- multiDecodeEmpty :: a -> MultiDecoding 'Fixed a+-- multiDecodeEmpty a = MultiDecodingUnboxedVector (SomeFixedSizeFixed 1) (constCopyPtrToUVector 0 a)++decodeConst :: a -> Decoding a+decodeConst a = Decoding $ \sz _ -> if sz == 0+  then return a+  else fail "decodeConst: encountered a non-zero size"++throughByteString :: (a -> ByteString) -> (ByteString -> Maybe a) -> Codec 'Variable a+throughByteString encode decode = Codec+  (encodeThroughByteString encode)+  (Decoding+    (\sz ptr -> do+      bs <- decodeByteString sz ptr+      case decode bs of+        Just a -> return a+        Nothing -> fail "throughByteString: failed while decoding LMDB data"+    )+  )++encodeByteString :: Encoding 'Variable ByteString+encodeByteString = encodeThroughByteString id++encodeThroughByteString :: (a -> ByteString) -> Encoding 'Variable a+encodeThroughByteString f =+  EncodingVariable $ \a -> let (PS fptr off len) = f a in SizedPoke+    (fromIntegral len)+    (\targetPtr -> withForeignPtr fptr $ \sourcePtr ->+        fastMemcpyBytePtr sourcePtr targetPtr off len+    )+{-# INLINE encodeThroughByteString #-}++decodeByteString :: CSize -> Ptr Word8 -> IO ByteString+decodeByteString sz source = do+  let szInt = fromIntegral sz+  fptr <- mallocForeignPtrBytes szInt+  withForeignPtr fptr $ \target -> do+    fastMemcpyBytePtr source target 0 szInt+  return (PS fptr 0 szInt)++-- decodeThroughByteString :: (ByteString -> Maybe a) -> Decoding ByteString+-- decodeThroughByteString f = Decoding $ \sz source = do+--   let szInt = fromIntegral sz+--   fptr <- mallocForeignPtrBytes szInt+--   withForeignPtr fptr $ \target -> do+--     fastMemcpyBytePtr source target 0 szInt+--   return (PS fptr 0 szInt)++decodeText :: CSize -> Ptr Word8 -> IO Text+decodeText (CSize szWord64) (Ptr addr) =+  let !szInt@(I# sz) = fromIntegral szWord64+   in IO (\ s1 ->+          case newByteArray# sz s1 of+            (# s2, mutByteArr #) -> case copyAddrToByteArray# addr mutByteArr 0# sz s2 of+              s3 -> case unsafeFreezeByteArray# mutByteArr s3 of+                (# s4, byteArr #) -> (# s4, Text (TextArray.Array byteArr) 0 (unsafeShiftR szInt 1) #)+          )++encodeText :: Encoding 'Variable Text+encodeText = EncodingVariable $ \(Text arr off len) -> SizedPoke+  (CSize $ fromIntegral $ unsafeShiftL len 1)+  (\ptr -> fastMemcpyTextArray arr (castPtr ptr) off len)++fastMemcpyBytePtr :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> IO ()+fastMemcpyBytePtr source target off len =+  copyBytes target (plusPtr source off :: Ptr Word8) len++fastMemcpyTextArray :: TextArray.Array -> Ptr Word8 -> Int -> Int -> IO ()+fastMemcpyTextArray (TextArray.Array byteArr) (Ptr addr) off len =+  let !(I# offWord8) = unsafeShiftL off 1+      !(I# lenWord8) = unsafeShiftL len 1+   in IO (\ s1 -> case copyByteArrayToAddr# byteArr offWord8 addr lenWord8 s1 of+        s2 -> (# s2, () #)+      )++slowMemcpyTextArray :: TextArray.Array -> Ptr Word16 -> Int -> Int -> IO ()+slowMemcpyTextArray arr ptr off len = go off+  where+  end = off + len+  go !ix+    | ix >= end = return ()+    | otherwise = do+        let w16 = TextArray.unsafeIndex arr ix+        poke (plusPtr ptr (unsafeShiftL ix 1) :: Ptr Word16) w16+        go (ix + 1)++-- unsafeEncodePaddedIntegral :: Integral a => Encoding 'MachineWord a+-- unsafeEncodePaddedIntegral = encodeWord . fromIntegral+-- {-# INLINE unsafeEncodePaddedIntegral #-}++unsafeEncodePaddedIntegral :: Integral a => Encoding 'MachineWord a+unsafeEncodePaddedIntegral = EncodingMachineWord $ \w -> FixedPoke $ \ptr ->+  poke (castPtr ptr :: Ptr Word) (fromIntegral w :: Word)+{-# INLINE unsafeEncodePaddedIntegral #-}++unsafeDecodePaddedIntegral :: Integral a => Decoding a+unsafeDecodePaddedIntegral = Decoding $ \sz ptr -> if sz == sizeOfMachineWord+  then fmap fromIntegral (peek (castPtr ptr :: Ptr Word))+  else fail "lmdb failure decoding machine sized word or integral"+{-# INLINE unsafeDecodePaddedIntegral #-}++decodeIntegral :: Integral a => CSize -> Ptr Word8 -> IO a+decodeIntegral sz = fmap fromIntegral . decodeWord64 sz+{-# INLINE decodeIntegral #-}++encodePaddedWord32 :: Encoding 'MachineWord Word32+encodePaddedWord32 = EncodingMachineWord $ \w -> FixedPoke $ \ptr ->+  poke (castPtr ptr :: Ptr Word) (fromIntegral w :: Word)+{-# INLINE encodePaddedWord32 #-}++encodeWord :: Encoding 'MachineWord Word+encodeWord = EncodingMachineWord $ \w -> FixedPoke $ \ptr ->+  poke (castPtr ptr :: Ptr Word) w+{-# INLINE encodeWord #-}++encodeStorable :: forall a. Storable a => Encoding 'Fixed a+encodeStorable = EncodingFixed (fromIntegral $ sizeOf (undefined :: a)) $ \a -> FixedPoke $ \ptr ->+  poke (castPtr ptr :: Ptr a) a+{-# INLINE encodeStorable #-}++encodeWord64 :: Encoding 'Fixed Word64+encodeWord64 = EncodingFixed 8 $ \w -> FixedPoke $ \ptr ->+  poke (castPtr ptr :: Ptr Word64) w+{-# INLINE encodeWord64 #-}++decodeWord64 :: CSize -> Ptr Word8 -> IO Word64+decodeWord64 sz ptr = if sz == 8+  then peek (castPtr ptr :: Ptr Word64)+  else fail "lmdb failure decoding 64-bit integral type"+{-# INLINE decodeWord64 #-}++decodeStorable :: forall a. Storable a => String -> Decoding a+decodeStorable descr = Decoding $ \sz ptr -> if fromIntegral sz == sizeOf (undefined :: a)+  then peek (castPtr ptr :: Ptr a)+  else fail $ "lmdb failure decoding " ++ descr ++ " storable type due to mismatched size"+{-# INLINE decodeStorable #-}++sizeOfMachineWord :: CSize+sizeOfMachineWord = fromIntegral (sizeOf (undefined :: Word))++whileM_ :: (Monad m) => m Bool -> m a -> m ()+whileM_ p f = go+    where go = do+            x <- p+            if x+                then f >> go+                else return ()++
+ src/Lmdb/Connection.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE BangPatterns #-}++module Lmdb.Connection where++import Database.LMDB.Raw+import Lmdb.Types+import Lmdb.Internal+import Data.Word+import Foreign.Storable+import Data.Coerce+import Data.Functor+import Data.Bits+import Control.Concurrent (runInBoundThread,isCurrentThreadBound)+import Data.Bool (bool)+import System.IO (withFile,IOMode(ReadMode))+import Foreign.C.Types (CSize(..))+import Foreign.Ptr (Ptr,plusPtr)+import Foreign.Marshal.Alloc (allocaBytes,alloca)+import Control.Monad+import Control.Exception (finally, bracketOnError)++withCursor ::+     Transaction e+  -> Database k v+  -> (Cursor e k v -> IO a)+  -> IO a+withCursor (Transaction txn) (Database dbi settings) f = do+  cur <- mdb_cursor_open_X txn dbi+  a <- f (Cursor cur settings)+  mdb_cursor_close_X cur+  return a++withMultiCursor ::+     Transaction e+  -> MultiDatabase k v+  -> (MultiCursor e k v -> IO a)+  -> IO a+withMultiCursor (Transaction txn) (MultiDatabase dbi settings) f = do+  cur <- mdb_cursor_open_X txn dbi+  a <- f (MultiCursor cur settings)+  mdb_cursor_close_X cur+  return a++withAbortableTransaction ::+     ModeBool e+  => Environment e+  -> (Transaction e -> IO (Maybe a))+  -> IO (Maybe a)+withAbortableTransaction e@(Environment env) f = do+  let isReadOnly = modeIsReadOnly e+  txn <- mdb_txn_begin env Nothing isReadOnly+  ma <- f (Transaction txn)+  case ma of+    Nothing -> do+      mdb_txn_abort txn+      return Nothing+    Just a -> do+      mdb_txn_commit txn+      return (Just a)++withTransaction ::+     ModeBool e+  => Environment e+  -> (Transaction e -> IO a)+  -> IO a+withTransaction e@(Environment env) f = do+  let isReadOnly = modeIsReadOnly e+  bool runInBoundThread id isReadOnly $ bracketOnError+    (mdb_txn_begin env Nothing isReadOnly)+    mdb_txn_abort+    $ \txn -> do+      a <- f (Transaction txn)+      mdb_txn_commit txn+      return a++withNestedTransaction ::+     Environment 'ReadWrite+  -> Transaction 'ReadWrite+  -> (Transaction 'ReadWrite -> IO a)+  -> IO a+withNestedTransaction e@(Environment env) (Transaction parentTxn) f = do+  txn <- mdb_txn_begin env (Just parentTxn) True+  a <- f (Transaction txn)+  mdb_txn_commit txn+  return a++-- This function can be improved to handle custom sorting.+openDatabase ::+     ModeBool e+  => Transaction e+  -> Maybe String -- ^ Database name+  -> DatabaseSettings k v+  -> IO (Database k v)+openDatabase t@(Transaction txn) name settings = do+  let rwOpts = if modeIsReadOnly t then [] else [MDB_CREATE]+      (keySafeFfi, keyExtraCmd, sortOpts) = case settings of+        DatabaseSettings keySort _ keyDec _ _ -> case keySort of+          SortNative s -> (,,) False (\_ -> return ()) $ case s of+            NativeSortLexographic -> []+            NativeSortLexographicBackward -> [MDB_REVERSEKEY]+            NativeSortInteger -> [MDB_INTEGERKEY]+          SortCustom s -> customSortConfig True keyDec t s+      opts = rwOpts ++ sortOpts+  dbi <- mdb_dbi_open_X keySafeFfi txn name opts+  keyExtraCmd dbi+  return (Database dbi settings)++customSortConfig :: Bool -> Decoding a -> Transaction e -> CustomSort a -> (Bool, DbiByFfi -> IO (), [MDB_DbFlag])+customSortConfig isKey (Decoding decode) (Transaction txn) s = (,,) True (\dbiOuter -> case dbiOuter of+  DbiSafe dbi -> case s of+    CustomSortUnsafe f -> setCmp txn dbi f+    CustomSortSafe f -> (setCmp txn dbi =<<) $ wrapCmpFn $ \aPtr bPtr -> do+      MDB_val aSize aData <- peek aPtr+      MDB_val bSize bData <- peek bPtr+      a <- decode aSize aData+      b <- decode bSize bData+      return $ case f a b of+        GT -> 1+        EQ -> 0+        LT -> (-1)+  DbiUnsafe _ -> fail "customSortConfig: logical error in sorting. Open an issue if this happens."+  ) []+  where setCmp = if isKey then mdb_set_compare else mdb_set_dupsort++-- This function can be improved to handle custom sorting.+openMultiDatabase ::+     ModeBool e+  => Transaction e+  -> Maybe String -- ^ Database name+  -> MultiDatabaseSettings k v+  -> IO (MultiDatabase k v)+openMultiDatabase t@(Transaction txn) name settings = do+  let rwOpts = if modeIsReadOnly t then [] else [MDB_CREATE]+      (keySafeFfi,keyExtraCmd,keySortOpts) = case settings of+        MultiDatabaseSettings keySort _ _ keyDec _ _ -> case keySort of+          SortNative s -> (,,) False (\_ -> return ()) $ case s of+            NativeSortLexographic -> []+            NativeSortLexographicBackward -> [MDB_REVERSEKEY]+            NativeSortInteger -> [MDB_INTEGERKEY]+          SortCustom s -> customSortConfig True keyDec t s+      (valSafeFfi,valExtraCmd,valSortOpts) = case settings of+        MultiDatabaseSettings _ valSort _ _ _ valDec -> case valSort of+          SortNative s -> (,,) False (\_ -> return ()) $ case s of+            NativeSortLexographic -> []+            NativeSortLexographicBackward -> [MDB_REVERSEDUP]+            NativeSortInteger -> [MDB_INTEGERDUP]+          SortCustom s -> customSortConfig False valDec t s+      multiOpts = case settings of+        MultiDatabaseSettings _ _ _ _ valEnc _ -> case valEnc of+          EncodingVariable _ -> []+          EncodingMachineWord _ -> [MDB_DUPFIXED]+          EncodingFixed _ _ -> [MDB_DUPFIXED]+      baseOpts = [MDB_DUPSORT]+      safeFfi = keySafeFfi || valSafeFfi+      opts = rwOpts ++ keySortOpts ++ valSortOpts ++ multiOpts ++ baseOpts+  dbi <- mdb_dbi_open_X safeFfi txn name opts+  keyExtraCmd dbi+  valExtraCmd dbi+  return (MultiDatabase dbi settings)++-- | This should not normally be used.+withDatabase ::+     ModeBool e+  => Environment e+  -> Transaction e+  -> Maybe String+  -> DatabaseSettings k v+  -> (Database k v -> IO a)+  -> IO a+withDatabase env txn mname settings f = do+  dbi <- openDatabase txn mname settings+  finally (f dbi) (closeDatabase env dbi)++-- | This should not normally be used.+withMultiDatabase ::+     ModeBool e+  => Environment e+  -> Transaction e+  -> Maybe String+  -> MultiDatabaseSettings k v+  -> (MultiDatabase k v -> IO a)+  -> IO a+withMultiDatabase env txn mname settings f = do+  dbi <- openMultiDatabase txn mname settings+  finally (f dbi) (closeMultiDatabase env dbi)++-- | Internally, this calls @mdb_env_create@ and @mdb_env_open@.+initializeReadOnlyEnvironment ::+     Int -- ^ Map size in bytes+  -> Int -- ^ Maximum number of readers (recommended: 126)+  -> Int -- ^ Maximum number of databases+  -> FilePath -- ^ Directory for lmdb data and locks+  -> IO (Environment 'ReadOnly)+initializeReadOnlyEnvironment =+  initializeEnvironmentInternal [MDB_RDONLY]++withReadOnlyEnvironment ::+     Int -- ^ Map size in bytes+  -> Int -- ^ Maximum number of readers (recommended: 126)+  -> Int -- ^ Maximum number of databases+  -> FilePath -- ^ Directory for lmdb data and locks+  -> (Environment 'ReadOnly -> IO a) -- ^ Computation requiring an 'Environment'+  -> IO a+withReadOnlyEnvironment a b c d f = do+  env <- initializeReadOnlyEnvironment a b c d+  finally (f env) (closeEnvironment env)++-- | Internally, this calls @mdb_env_create@ and @mdb_env_open@.+initializeReadWriteEnvironment ::+     Int -- ^ Map size in bytes+  -> Int -- ^ Maximum number of readers (recommended: 126)+  -> Int -- ^ Maximum number of databases+  -> FilePath -- ^ Directory for lmdb data and locks+  -> IO (Environment 'ReadWrite)+initializeReadWriteEnvironment = initializeEnvironmentInternal []++-- | It is not clear whether or not it is actually neccessary+--   to use 'runInBoundThread' here. It is done just as an extra+--   precaution.+initializeEnvironmentInternal ::+     [MDB_EnvFlag] -- ^ Flags+  -> Int -- ^ Map size in bytes+  -> Int -- ^ Maximum number of readers (recommended: 126)+  -> Int -- ^ Maximum number of databases+  -> FilePath -- ^ Directory for lmdb data and locks+  -> IO (Environment e)+initializeEnvironmentInternal flags maxSize maxReaders maxDbs dir =+  runInBoundThread $ do+    env <- mdb_env_create+    mdb_env_set_mapsize env maxSize+    mdb_env_set_maxreaders env maxReaders+    mdb_env_set_maxdbs env maxDbs+    mdb_env_open env dir flags+    return (Environment env)++closeDatabase :: Environment e -> Database k v -> IO ()+closeDatabase (Environment env) (Database dbi _) =+  mdb_dbi_close_X env dbi++closeMultiDatabase :: Environment e -> MultiDatabase k v -> IO ()+closeMultiDatabase (Environment env) (MultiDatabase dbi _) =+  mdb_dbi_close_X env dbi++closeEnvironment :: Environment e -> IO ()+closeEnvironment (Environment env) =+  runInBoundThread $ mdb_env_close env++makeSettings ::+     Sort s k -- ^ Key sorting function+  -> Codec s k -- ^ Key codec+  -> Codec sv v -- ^ Value codec+  -> DatabaseSettings k v+makeSettings sort (Codec kEnc kDec) (Codec vEnc vDec) =+  DatabaseSettings sort kEnc kDec vEnc vDec++makeMultiSettings ::+     Sort sk k -- ^ Key sorting function+  -> Sort sv v -- ^ Value sorting function+  -> Codec sk k -- ^ Key codec+  -> Codec sv v -- ^ Value codec+  -> MultiDatabaseSettings k v+makeMultiSettings ksort vsort (Codec kEnc kDec) (Codec vEnc vDec) =+  MultiDatabaseSettings ksort vsort kEnc kDec vEnc vDec++readonly :: Transaction 'ReadWrite -> Transaction 'ReadOnly+readonly = coerce++readonlyEnvironment :: Environment 'ReadWrite -> Environment 'ReadOnly+readonlyEnvironment = coerce++-- csvsToLmdb ::+--      FilePath -- ^ Geolite IPv4 Blocks+--   -> FilePath -- ^ Geolite City Locations+--   -> FilePath -- ^ Directory for LMDB+--   -> IO ()+-- csvsToLmdb geoBlocksPath geoCitiesPath lmdbDir = do+--   env <- mdb_env_create+--   mdb_env_set_mapsize env (2 ^ 31)+--   mdb_env_set_maxreaders env 1+--   mdb_env_set_maxdbs env 2+--   mdb_env_open env lmdbDir []+--   txn <- mdb_txn_begin env Nothing True+--   dbiBlocks <- mdb_dbi_open' txn (Just "blocks") [MDB_INTEGERKEY,MDB_CREATE]+--   let appendFlag = compileWriteFlags [MDB_APPEND]+--   r <- withFile filename ReadMode $ \h -> runEffect $+--         fmap (SD.convertDecodeError "utf-8") (PT.decode (PT.utf8 . PT.eof) $ PB.fromHandle h)+--     >-> fmap Just blocks+--     >-> Pipes.mapM_ (\block -> do+--           alloca $ \(w64Ptr :: Ptr Word64) -> do+--             poke w64Ptr (fromIntegral w32)+--             let IPv4Range (IPv4 w32) _ = blockNetwork block+--                 w8Ptr = (castPtr :: Ptr Word64 -> Ptr Word8) w64Ptr+--             mdb_put' appendFlag txn dbiBlocks+--               (MDB_val (CSize 8) w8Ptr)+--               (MDB_val (CSize 8) w8Ptr)+--         )+--   case r of+--     Nothing -> assertBool "impossible" True+--     Just err -> assertFailure (Decoding.prettyError Text.unpack err)++-- putBlock :: Block -> Put+-- putBlock (Block network geonameId registered represented isAnon isSat postal lat lon accuracy)++
+ src/Lmdb/Internal.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Lmdb.Internal where++import Database.LMDB.Raw+import Lmdb.Types+import Data.Word+import Foreign.Storable+import Data.Coerce+import Data.Functor+import Data.Bits+import Control.Concurrent (runInBoundThread,isCurrentThreadBound)+import Data.Bool (bool)+import System.IO (withFile,IOMode(ReadMode))+import Foreign.C.Types (CSize(..))+import Foreign.Ptr (Ptr,plusPtr)+import Foreign.Marshal.Alloc (allocaBytes,alloca)+import Control.Monad+import Control.Exception (finally, bracketOnError)++-- | Alternative to 'withKVPtrs' that allows us to not initialize the key or the+--   value.+withKVPtrsNoInit :: (Ptr MDB_val -> Ptr MDB_val -> IO a) -> IO a+withKVPtrsNoInit fn =+  allocaBytes (unsafeShiftL mdb_val_size 1) $ \pK ->+    let pV = pK `plusPtr` mdb_val_size+     in fn pK pV+{-# INLINE withKVPtrsNoInit #-}++withKVPtrsInitKey :: MDB_val -> (Ptr MDB_val -> Ptr MDB_val -> IO a) -> IO a+withKVPtrsInitKey k fn =+  allocaBytes (unsafeShiftL mdb_val_size 1) $ \pK ->+    let pV = pK `plusPtr` mdb_val_size+     in poke pK k >> fn pK pV+{-# INLINE withKVPtrsInitKey #-}+++sizeOfMachineWord :: CSize+sizeOfMachineWord = fromIntegral (sizeOf (undefined :: Word))++mdb_val_size :: Int+mdb_val_size = sizeOf (undefined :: MDB_val)++runEncoding :: Encoding s a -> a -> SizedPoke+runEncoding x a = case x of+  EncodingVariable f -> f a+  EncodingFixed sz f -> SizedPoke sz (getFixedPoke (f a))+  EncodingMachineWord f -> SizedPoke sizeOfMachineWord (getFixedPoke (f a))++mdb_cursor_put_X :: MDB_WriteFlags -> CursorByFfi -> MDB_val -> MDB_val -> IO Bool+mdb_cursor_put_X flags x k v = case x of+  CursorSafe cur -> mdb_cursor_put flags cur k v+  CursorUnsafe cur -> mdb_cursor_put' flags cur k v++mdb_put_X :: MDB_WriteFlags -> MDB_txn -> DbiByFfi -> MDB_val -> MDB_val -> IO Bool+mdb_put_X flags txn x k v = case x of+  DbiSafe dbi -> mdb_put flags txn dbi k v+  DbiUnsafe dbi -> mdb_put' flags txn dbi k v++mdb_get_X :: MDB_txn -> DbiByFfi -> MDB_val -> IO (Maybe MDB_val)+mdb_get_X txn x k = case x of+  DbiSafe dbi -> mdb_get txn dbi k+  DbiUnsafe dbi -> mdb_get' txn dbi k++mdb_cursor_get_X :: MDB_cursor_op -> CursorByFfi -> Ptr MDB_val -> Ptr MDB_val -> IO Bool+mdb_cursor_get_X op x k v = case x of+  CursorSafe cur -> mdb_cursor_get op cur k v+  CursorUnsafe cur -> mdb_cursor_get' op cur k v++mdb_dbi_close_X :: MDB_env -> DbiByFfi -> IO ()+mdb_dbi_close_X env x = case x of+  DbiSafe dbi -> mdb_dbi_close env dbi+  DbiUnsafe dbi -> mdb_dbi_close' env dbi++mdb_cursor_open_X :: MDB_txn -> DbiByFfi -> IO CursorByFfi+mdb_cursor_open_X txn x = case x of+  DbiSafe dbi -> fmap CursorSafe $ mdb_cursor_open txn dbi+  DbiUnsafe dbi -> fmap CursorUnsafe $ mdb_cursor_open' txn dbi++mdb_cursor_close_X :: CursorByFfi -> IO ()+mdb_cursor_close_X x = case x of+  CursorSafe cur -> mdb_cursor_close cur+  CursorUnsafe cur -> mdb_cursor_close' cur++-- | This one is a little different. The first argument is a 'Bool'+--   that is 'True' if we want we use safe FFI calls and 'False'+--   if we want unsafe FFI calls.+mdb_dbi_open_X :: Bool -> MDB_txn -> Maybe String -> [MDB_DbFlag] -> IO DbiByFfi+mdb_dbi_open_X safeFfi txn mname flags = if safeFfi+  then fmap DbiSafe $ mdb_dbi_open txn mname flags+  else fmap DbiUnsafe $ mdb_dbi_open' txn mname flags++doesSortRequireSafety :: Sort s a -> Bool+doesSortRequireSafety x = case x of+  SortNative _ -> False+  _ -> True++isEncodingDupFixed :: Encoding s a -> Bool+isEncodingDupFixed x = case x of+  EncodingVariable _ -> False+  _ -> True++downgradeSettings :: MultiDatabaseSettings k v -> DatabaseSettings k v+downgradeSettings (MultiDatabaseSettings a b c d e f) = DatabaseSettings a c d e f+{-# INLINE downgradeSettings #-}++downgradeCursor :: MultiCursor s k v -> Cursor s k v+downgradeCursor (MultiCursor ref settings) = Cursor ref (downgradeSettings settings)+{-# INLINE downgradeCursor #-}++insertInternalCursorNeutral :: MDB_WriteFlags -> (Either (Transaction 'ReadWrite,Database k v) (Cursor 'ReadWrite k v)) -> k -> v -> IO Bool+insertInternalCursorNeutral flags e k v = do+  let settings = case e of+        Left (_,Database _ s) -> s+        Right (Cursor _ s) -> s+      (SizedPoke keyCSize@(CSize keySize) keyPoke, SizedPoke valCSize@(CSize valSize) valPoke) =+        case settings of+          DatabaseSettings _ keyEncoding _ valEncoding _ ->+            ( runEncoding keyEncoding k+            , runEncoding valEncoding v+            )+  -- Consider writing a function to improve performance of+  -- double allocations like this.+  allocaBytes (fromIntegral keySize) $ \keyPtr -> do+    allocaBytes (fromIntegral valSize) $ \valPtr -> do+      keyPoke keyPtr+      valPoke valPtr+      let kdata = MDB_val keyCSize keyPtr+          vdata = MDB_val valCSize valPtr+      case e of+        Left (Transaction txn, Database dbi _) -> mdb_put_X flags txn dbi kdata vdata+        Right (Cursor cur _) -> mdb_cursor_put_X flags cur kdata vdata+{-# INLINE insertInternalCursorNeutral #-}++lookupInternal :: Transaction 'ReadOnly -> Database k v -> k -> IO (Maybe v)+lookupInternal (Transaction txn) (Database dbi settings) k = do+  let Decoding decodeValue = databaseSettingsDecodeValue settings+  case settings of+    DatabaseSettings _ keyEncoding _ _ _ -> do+      let SizedPoke (CSize keySize) keyPoke = runEncoding keyEncoding k+      m <- allocaBytes (fromIntegral keySize) $ \keyPtr -> do+        keyPoke keyPtr+        mdb_get_X txn dbi (MDB_val (CSize $ fromIntegral keySize) keyPtr)+      case m of+        Nothing -> return Nothing+        Just (MDB_val valSize valPtr) -> fmap Just $ decodeValue valSize valPtr++insertInternal :: MDB_WriteFlags -> Transaction 'ReadWrite -> Database k v -> k -> v -> IO Bool+insertInternal flags txn db k v =+  insertInternalCursorNeutral flags (Left (txn,db)) k v++insertInternal' :: MDB_WriteFlags -> Transaction 'ReadWrite -> Database k v -> k -> v -> IO ()+insertInternal' a b c d e = insertInternal a b c d e $> ()+++noWriteFlags :: MDB_WriteFlags+noWriteFlags = compileWriteFlags []++noOverwriteFlags :: MDB_WriteFlags+noOverwriteFlags = compileWriteFlags [MDB_NOOVERWRITE]++appendFlags :: MDB_WriteFlags+appendFlags = compileWriteFlags [MDB_APPEND]++noDupDataFlags :: MDB_WriteFlags+noDupDataFlags = compileWriteFlags [MDB_NODUPDATA]++decodeOne :: (CSize -> Ptr Word8 -> IO a) -> Bool -> Ptr MDB_val -> IO (Maybe a)+decodeOne decode success keyPtr = if success+  then do+    MDB_val aSize aWordPtr <- peek keyPtr+    a <- decode aSize aWordPtr+    return (Just a)+  else return Nothing+{-# INLINE decodeOne #-}++decodeOne' :: (CSize -> Ptr Word8 -> IO a) -> Bool -> Ptr MDB_val -> Ptr MDB_val -> IO (Maybe a)+decodeOne' a b _ c = decodeOne a b c+{-# INLINE decodeOne' #-}+++-- getWithKey :: MDB_cursor_op -> Cursor e k v -> k -> IO (Maybe (KeyValue k v))+-- getWithKey op (Cursor cur settings) k = do+--   let SizedPoke keySize keyPoke = case settings of+--         DatabaseSettings _ keyEncoding _ _ _ -> runEncoding keyEncoding k+--   allocaBytes (fromIntegral keySize) $ \(keyDataPtr :: Ptr Word8) -> do+--     keyPoke keyDataPtr+--     withKVPtrsInitKey (MDB_val keySize keyDataPtr) $ \keyPtr valPtr -> do+--       success <- mdb_cursor_get_X op cur keyPtr valPtr+--       decodeResults success settings keyPtr valPtr++getWithKey :: MDB_cursor_op -> Cursor e k v -> k -> IO (Maybe (KeyValue k v))+getWithKey op c@(Cursor cur settings) = getWithKeyGeneral (decodeResults settings) op c++getValueWithKey :: MDB_cursor_op -> Cursor e k v -> k -> IO (Maybe v)+getValueWithKey op c@(Cursor cur settings) = getWithKeyGeneral (decodeOne' $ getDecoding $ databaseSettingsDecodeValue settings) op c++getWithKeyGeneral :: (Bool -> Ptr MDB_val -> Ptr MDB_val -> IO a) -> MDB_cursor_op -> Cursor e k v -> k -> IO a+getWithKeyGeneral extractResult op (Cursor cur settings) k = do+  let SizedPoke keySize keyPoke = case settings of+        DatabaseSettings _ keyEncoding _ _ _ -> runEncoding keyEncoding k+  allocaBytes (fromIntegral keySize) $ \(keyDataPtr :: Ptr Word8) -> do+    keyPoke keyDataPtr+    withKVPtrsInitKey (MDB_val keySize keyDataPtr) $ \keyPtr valPtr -> do+      success <- mdb_cursor_get_X op cur keyPtr valPtr+      extractResult success keyPtr valPtr++getValueWithoutKey :: MDB_cursor_op -> Cursor e k v -> IO (Maybe v)+getValueWithoutKey op (Cursor cur settings) = do+  withKVPtrsNoInit $ \(keyPtr :: Ptr MDB_val) (valPtr :: Ptr MDB_val) -> do+    success <- mdb_cursor_get_X op cur keyPtr valPtr+    decodeOne (getDecoding $ databaseSettingsDecodeValue settings) success valPtr++decodeResults :: DatabaseSettings k v -> Bool -> Ptr MDB_val -> Ptr MDB_val -> IO (Maybe (KeyValue k v))+decodeResults settings success keyPtr valPtr = if success+  then do+    MDB_val keySize keyWordPtr <- peek keyPtr+    MDB_val valSize valWordPtr <- peek valPtr+    key <- getDecoding (databaseSettingsDecodeKey settings) keySize keyWordPtr+    val <- getDecoding (databaseSettingsDecodeValue settings) valSize valWordPtr+    return (Just (KeyValue key val))+  else return Nothing+{-# INLINE decodeResults #-}+
+ src/Lmdb/Map.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE BangPatterns #-}++module Lmdb.Map+  ( -- * Cursor Operations+    -- ** Movements+    -- *** Key and Value+    move+  , first+  , last+  , next+  , prev+  , lookup+  , lookupGte+  , current+    -- *** Only Key+  , nextKey+  , lookupGteKey+  , currentKey+    -- *** Only Value+  , nextValue+  , currentValue+    -- *** No Data+  , first_+  , next_+    -- ** Streaming+  , forward+  , backward+  , firstForward+  , lastBackward+  , lookupForward+  , lookupGteForward+  , serverRequired+  , serverOptional+    -- ** Writing+  , insert+  , insertSuccess+  , repsert+    -- * Cursorless Operations+    -- ** Reading+  , lookup'+    -- ** Writing+  , insert'+  , insertSuccess'+  , repsert'+  ) where++import Prelude hiding (last,lookup)+import Foreign.Ptr (Ptr)+import Lmdb.Internal+import Lmdb.Types+import Foreign.Storable+import Database.LMDB.Raw+import Data.Word+import Control.Monad.Trans.Class+import Pipes (yield, Producer')+import Pipes.Core (respond,Server',(\>\),(/>/),(>+>),(>~>),request,pull,push)+import Foreign.Marshal.Alloc (allocaBytes,alloca)+import Foreign.C.Types (CSize(..))+import Control.Monad+import qualified Pipes.Internal as Pipes++move :: Cursor e k v -> Movement k -> IO (Maybe (KeyValue k v))+move cursor m = case m of+  MovementNext -> next cursor+  MovementPrev -> prev cursor+  MovementFirst -> first cursor+  MovementLast -> last cursor+  MovementAt k -> lookup cursor k+  MovementAtGte k -> lookupGte cursor k+  MovementCurrent -> currentMaybe cursor+++first :: Cursor e k v -> IO (Maybe (KeyValue k v))+first = getWithoutKey MDB_FIRST++first_ :: Cursor e k v -> IO Bool+first_ = getWithoutKey_ MDB_FIRST++last :: Cursor e k v -> IO (Maybe (KeyValue k v))+last = getWithoutKey MDB_LAST++next :: Cursor e k v -> IO (Maybe (KeyValue k v))+next = getWithoutKey MDB_NEXT++next_ :: Cursor e k v -> IO Bool+next_ = getWithoutKey_ MDB_NEXT++nextKey :: Cursor e k v -> IO (Maybe k)+nextKey = getKeyWithoutKey MDB_NEXT++nextValue :: Cursor e k v -> IO (Maybe v)+nextValue = getValueWithoutKey MDB_NEXT++prev :: Cursor e k v -> IO (Maybe (KeyValue k v))+prev = getWithoutKey MDB_PREV++prevKey :: Cursor e k v -> IO (Maybe k)+prevKey = getKeyWithoutKey MDB_PREV++current :: Cursor e k v -> IO (KeyValue k v)+current cursor = do+  m <- getWithoutKey MDB_GET_CURRENT cursor+  maybe (fail currentErr) return m++currentValue :: Cursor e k v -> IO v+currentValue cursor = do+  m <- getValueWithoutKey MDB_GET_CURRENT cursor+  maybe (fail currentErr) return m++currentKey :: Cursor e k v -> IO k+currentKey cursor = do+  m <- getKeyWithoutKey MDB_GET_CURRENT cursor+  maybe (fail currentErr) return m++currentMaybe :: Cursor e k v -> IO (Maybe (KeyValue k v))+currentMaybe = getWithoutKey MDB_GET_CURRENT++currentErr :: String+currentErr = concat+  [ "current: Do not call *current* on an LMDB cursor when "+  , "it is in an invalid position. Do not call it before "+  , "calling something like *first* or *at* on the cursor."+  ]++-- | Uses @MDB_SET_KEY@+lookup :: Cursor e k v -> k -> IO (Maybe (KeyValue k v))+lookup = getWithKey MDB_SET_KEY++-- | Uses @MDB_SET_RANGE@+lookupGte :: Cursor e k v -> k -> IO (Maybe (KeyValue k v))+lookupGte = getWithKey MDB_SET_RANGE++-- | Uses @MDB_SET_RANGE@+lookupGteKey :: Cursor e k v -> k -> IO (Maybe k)+lookupGteKey = getKeyWithKey MDB_SET_RANGE++yieldMaybeThen ::+     (Cursor e k v -> IO (Maybe (KeyValue k v)))+  -> (Cursor e k v -> Producer' (KeyValue k v) IO ())+  -> Cursor e k v+  -> Producer' (KeyValue k v) IO ()+yieldMaybeThen f p cursor = do+  m <- lift (f cursor)+  case m of+    Nothing -> return ()+    Just kv -> yield kv >> p cursor++repeatedly :: forall e k v. (Cursor e k v -> IO (Maybe (KeyValue k v))) -> Cursor e k v -> Producer' (KeyValue k v) IO ()+repeatedly f = go+  where+  go :: Cursor e k v -> Producer' (KeyValue k v) IO ()+  go = yieldMaybeThen f go++forward :: Cursor e k v -> Producer' (KeyValue k v) IO ()+forward = repeatedly next++backward :: Cursor e k v -> Producer' (KeyValue k v) IO ()+backward = repeatedly prev++firstForward :: Cursor e k v -> Producer' (KeyValue k v) IO ()+firstForward = yieldMaybeThen first forward++lastBackward :: Cursor e k v -> Producer' (KeyValue k v) IO ()+lastBackward = yieldMaybeThen last backward++lookupForward :: Cursor e k v -> k -> Producer' (KeyValue k v) IO ()+lookupForward cursor k = yieldMaybeThen (flip lookup k) forward cursor++lookupGteForward :: Cursor e k v -> k -> Producer' (KeyValue k v) IO ()+lookupGteForward cursor k = yieldMaybeThen (flip lookupGte k) forward cursor++serverRaw :: forall e k v.+     Cursor e k v+  -> (Cursor e k v -> IO (Maybe (KeyValue k v)))+  -> Server' (Cursor e k v -> IO (Maybe (KeyValue k v))) (KeyValue k v) IO ()+serverRaw cursor initialAction = lift (initialAction cursor) >>= go+  where+  go :: Maybe (KeyValue k v)+     -> Server' (Cursor e k v -> IO (Maybe (KeyValue k v))) (KeyValue k v) IO ()+  go Nothing = return ()+  go (Just kv) = do+    action <- respond kv+    m <- lift (action cursor)+    go m++serverRequired :: forall e k v.+     Cursor e k v+  -> Movement k+  -> Server' (Movement k) (KeyValue k v) IO ()+serverRequired cursor initialMovement = lift (move cursor initialMovement) >>= go+  where+  go :: Maybe (KeyValue k v)+     -> Server' (Movement k) (KeyValue k v) IO ()+  go Nothing = return ()+  go (Just kv) = do+    movement <- respond kv+    m <- lift (move cursor movement)+    go m++-- serverOptional :: forall e k v a.+--      Cursor e k v+--   -> Movement k+--   -> Server' (Movement k) (Maybe (KeyValue k v)) IO a+-- serverOptional cursor initialMovement = lift (move cursor initialMovement) >>= go+--   where+--   go :: Maybe (KeyValue k v) -> Server' (Movement k) (Maybe (KeyValue k v)) IO a+--   go = go <=< lift . move cursor <=< respond++serverOptional :: Cursor e k v -> Movement k -> Server' (Movement k) (Maybe (KeyValue k v)) IO a+serverOptional cursor initialMovement =+  lift (move cursor initialMovement) >>= iterateM (lift . move cursor <=< respond)++iterateM :: Monad m => (a -> m a) -> a -> m b+iterateM f = let f' = f' <=< f in f'++contramapUpstreamAlt :: Monad m => (c -> a) -> (a -> Pipes.Proxy a' a b' b m r) -> c -> Pipes.Proxy a' c b' b m r+contramapUpstreamAlt f k = contramapUpstream f . (k . f)++-- mapDownstream :: Monad m => (b -> c) -> (b -> Pipes.Proxy a' a b' b m r) -> c -> Pipes.Proxy a' a b' c m r+-- mapDownstream f k = k />/ respond . f++-- contramapUpstreamAlt f k = contramapUpstream f . (k . f)++contramapUpstream :: Monad m => (c -> a) -> Pipes.Proxy a' a b' b m r -> Pipes.Proxy a' c b' b m r+contramapUpstream f = go where+  go (Pipes.Request a' g) = Pipes.Request a' (go . g . f)+  go (Pipes.Respond b g) = Pipes.Respond b (go . g)+  go (Pipes.M m) = Pipes.M (m >>= return . go)+  go (Pipes.Pure r) = Pipes.Pure r++contramapUpstreamM :: Monad m => (c -> m a) -> Pipes.Proxy a' a b' b m r -> Pipes.Proxy a' c b' b m r+contramapUpstreamM f = go where+  go (Pipes.Request a' g) = Pipes.Request a' (Pipes.M . (return . go . g <=< f))+  go (Pipes.Respond b g) = Pipes.Respond b (go . g)+  go (Pipes.M m) = Pipes.M (m >>= return . go)+  go (Pipes.Pure r) = Pipes.Pure r++contramapDownstreamM :: Monad m => (c -> m b') -> Pipes.Proxy a' a b' b m r -> Pipes.Proxy a' a c b m r+contramapDownstreamM f = go where+  go (Pipes.Request a' g) = Pipes.Request a' (go . g)+  go (Pipes.Respond b g) = Pipes.Respond b (Pipes.M . (return . go . g <=< f))+  go (Pipes.M m) = Pipes.M (m >>= return . go)+  go (Pipes.Pure r) = Pipes.Pure r++getKeyWithKey :: MDB_cursor_op -> Cursor e k v -> k -> IO (Maybe k)+getKeyWithKey op (Cursor cur settings) k = do+  let SizedPoke keySize keyPoke = case settings of+        DatabaseSettings _ keyEncoding _ _ _ -> runEncoding keyEncoding k+  allocaBytes (fromIntegral keySize) $ \(keyDataPtr :: Ptr Word8) -> do+    keyPoke keyDataPtr+    withKVPtrsInitKey (MDB_val keySize keyDataPtr) $ \keyPtr valPtr -> do+      success <- mdb_cursor_get_X op cur keyPtr valPtr+      decodeOne (getDecoding $ databaseSettingsDecodeKey settings) success keyPtr++getWithoutKey :: MDB_cursor_op -> Cursor e k v -> IO (Maybe (KeyValue k v))+getWithoutKey op (Cursor cur settings) = do+  withKVPtrsNoInit $ \(keyPtr :: Ptr MDB_val) (valPtr :: Ptr MDB_val) -> do+    success <- mdb_cursor_get_X op cur keyPtr valPtr+    decodeResults settings success keyPtr valPtr++getWithoutKey_ :: MDB_cursor_op -> Cursor e k v -> IO Bool+getWithoutKey_ op (Cursor cur settings) = do+  withKVPtrsNoInit $ \(keyPtr :: Ptr MDB_val) (valPtr :: Ptr MDB_val) -> do+    mdb_cursor_get_X op cur keyPtr valPtr++getKeyWithoutKey :: MDB_cursor_op -> Cursor e k v -> IO (Maybe k)+getKeyWithoutKey op (Cursor cur settings) = do+  withKVPtrsNoInit $ \(keyPtr :: Ptr MDB_val) (valPtr :: Ptr MDB_val) -> do+    success <- mdb_cursor_get_X op cur keyPtr valPtr+    decodeOne (getDecoding $ databaseSettingsDecodeKey settings) success keyPtr++lookup' :: Transaction 'ReadOnly -> Database k v -> k -> IO (Maybe v)+lookup' = lookupInternal++impossibleFailure :: String -> IO a+impossibleFailure funcName = fail $ concat+  [ "LMDB "+  , funcName+  , ": This operation failed, although this should not "+  , "be possible unless the datastore has filled up."+  ]++-- | Insert a value at the given key, replacing a previously existing value.+repsert' :: Transaction 'ReadWrite -> Database k v -> k -> v -> IO ()+repsert' a b c d = do+  success <- insertInternal noWriteFlags a b c d+  when (not success) $ impossibleFailure "repsert'"++-- | Insert a value at the given key, throwing an exception if a value+--   already exists at this key.+insert' :: Transaction 'ReadWrite -> Database k v -> k -> v -> IO ()+insert' a b c d = do+  success <- insertInternal noOverwriteFlags a b c d+  when (not success) $ fail "LMDB insert': a value already exists at this key"++-- | Insert a value at the given key, returning 'True' if the operation succeeds+--   and 'False' if a value already exists at this key.+insertSuccess' :: Transaction 'ReadWrite -> Database k v -> k -> v -> IO Bool+insertSuccess' = insertInternal noOverwriteFlags++insert :: Cursor 'ReadWrite k v -> k -> v -> IO ()+insert cur k v = do+  success <- insertInternalCursorNeutral noOverwriteFlags (Right cur) k v+  when (not success) $ fail "LMDB insert: a value already exists at this key"++repsert :: Cursor 'ReadWrite k v -> k -> v -> IO ()+repsert cur k v = do+  success <- insertInternalCursorNeutral noWriteFlags (Right cur) k v+  when (not success) $ impossibleFailure "repsert"++insertSuccess :: Cursor 'ReadWrite k v -> k -> v -> IO Bool+insertSuccess cur k v = insertInternalCursorNeutral noOverwriteFlags (Right cur) k v++
+ src/Lmdb/Multimap.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE BangPatterns #-}++module Lmdb.Multimap+  (+    lookupValues+  , insert+  , dupsert+  ) where++import Prelude hiding (last,lookup)+import Foreign.Ptr (Ptr)+import Lmdb.Internal+import Lmdb.Types+import Foreign.Storable+import Database.LMDB.Raw+import Data.Word+import Control.Monad.Trans.Class+import Pipes (yield, Producer')+import Pipes.Core (respond,Server',(\>\),(/>/),(>+>),(>~>),request,pull,push)+import Foreign.Marshal.Alloc (allocaBytes,alloca)+import Foreign.C.Types (CSize(..))+import Control.Monad++lookupFirstValue :: MultiCursor e k v -> k -> IO (Maybe v)+lookupFirstValue mc k = getValueWithKey MDB_SET_KEY (downgradeCursor mc) k++-- | Lookup all values at the given key. These values are provided+--   as a 'Producer' since there can be many pages of values. Since+--   the resulting 'Producer' captures the 'Cursor' given as the+--   first argument, it should not escape the call to 'withCursor' in+--   which the 'Cursor' was bound. Additionally, the 'Producer' should+--   be consumed before any other functions that use the 'Cursor' are+--   called. It is fine if the 'Producer' is not consumed entirely, as+--   long as the caller is not dependending on the cursor to end in a+--   particular place.+--+--   If values are encoded and decoded by a 'Codec' that uses a fixed+--   length, this function will take advantage of @MDB_GET_MULTIPLE@+--   and @MDB_NEXT_MULTIPLE@.+--+lookupValues :: MultiCursor e k v -> k -> Producer' v IO ()+lookupValues cur k = do+  m <- lift $ lookupFirstValue cur k+  case m of+    Nothing -> return ()+    Just v -> do+      yield v+      forwardValues cur++-- | Stream all values associated with the key, starting with the value+--   after the cursor\'s current position.+forwardValues :: MultiCursor e k v -> Producer' v IO ()+forwardValues cur = if isFixed+  then error "implement dupfixed value iteration"+  else forwardValuesStandard cur+  where+  isFixed = case multiCursorDatabaseSettings cur of+    MultiDatabaseSettings _ _ _ _ encVal _ -> isEncodingDupFixed encVal++forwardValuesStandard :: MultiCursor e k v -> Producer' v IO ()+forwardValuesStandard (MultiCursor cur dbs) = go where+  go = do+    m <- lift $ withKVPtrsNoInit $ \keyPtr valPtr -> do+      success <- mdb_cursor_get_X MDB_NEXT_DUP cur keyPtr valPtr+      decodeOne (getDecoding $ multiDatabaseSettingsDecodeValue dbs) success valPtr+    case m of+      Nothing -> return ()+      Just v -> yield v >> go++-- | Insert a key-value pair. If the value already exists at the key, do not add+--   another copy of it. This treats the existing values corresponding+--   to each key as a set. This uses @MDB_NODUPDATA@.+insert :: MultiCursor 'ReadWrite k v -> k -> v -> IO ()+insert cur k v = do+  insertInternalCursorNeutral noDupDataFlags (Right $ downgradeCursor cur) k v+  return ()++-- | Insert a key-value pair. If the value already exists at the key, add another+--   copy of it. This treats the existing values corresponding+--   to each key as a bag.+dupsert :: MultiCursor 'ReadWrite k v -> k -> v -> IO ()+dupsert cur k v = do+  insertInternalCursorNeutral noWriteFlags (Right $ downgradeCursor cur) k v+  return ()+
+ src/Lmdb/Types.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}+module Lmdb.Types where++import Database.LMDB.Raw+import Foreign.C.Types (CSize(..),CInt)+import Foreign.Ptr (Ptr,FunPtr)+import Data.Word+import Data.Primitive.ByteArray (ByteArray)+import qualified Data.Vector.Unboxed as UVector+import qualified Data.Vector.Primitive as PVector++-- | We only use the promoted version of this data type.+data Mode = ReadOnly | ReadWrite++class ModeBool (x :: Mode) where+  modeIsReadOnly :: proxy x -> Bool++instance ModeBool 'ReadOnly where+  modeIsReadOnly _ = True++instance ModeBool 'ReadWrite where+  modeIsReadOnly _ = False++newtype Environment (x :: Mode) = Environment+  { getEnvironment :: MDB_env+  }++newtype Transaction (t :: Mode) = Transaction+  { getTransaction :: MDB_txn+  }++data Cursor (t :: Mode) k v = Cursor+  { cursorRef :: !CursorByFfi+  , cursorDatabaseSettings :: !(DatabaseSettings k v)+  }++data MultiCursor (t :: Mode) k v = MultiCursor+  { multiCursorRef :: !CursorByFfi+  , multiCursorDatabaseSettings :: !(MultiDatabaseSettings k v)+  }+++data KeyValue k v = KeyValue+  { keyValueKey :: !k+  , keyValueValue :: !v+  }++data CursorByFfi+  = CursorSafe !MDB_cursor+  | CursorUnsafe !MDB_cursor'++data DbiByFfi+  = DbiSafe !MDB_dbi+  | DbiUnsafe !MDB_dbi'++data Database k v = Database+  { databaseRef :: !DbiByFfi+  , databaseTheSettings :: !(DatabaseSettings k v)+  }++data MultiDatabase k v = MultiDatabase+  { multiDatabaseRef :: DbiByFfi+  , multiDatabaseTheSettings :: !(MultiDatabaseSettings k v)+  }++data DatabaseSettings k v = forall ks vs. DatabaseSettings+  { databaseSettingsSort :: !(Sort ks k) -- ^ Sorting+  , databaseSettingsEncodeKey :: !(Encoding ks k)+  , databaseSettingsDecodeKey :: !(Decoding k)+  , databaseSettingsEncodeValue :: !(Encoding vs v)+  , databaseSettingsDecodeValue :: !(Decoding v)+  }++data MultiDatabaseSettings k v = forall ks vs. MultiDatabaseSettings+  { multiDatabaseSettingsSortKey :: Sort ks k+  , multiDatabaseSettingsSortValue :: Sort vs v+  , multiDatabaseSettingsEncodeKey :: !(Encoding ks k)+  , multiDatabaseSettingsDecodeKey :: !(Decoding k)+  , multiDatabaseSettingsEncodeValue :: !(Encoding vs v)+  , multiDatabaseSettingsDecodeValue :: !(Decoding v)+  }++data Codec s a = Codec+  { codecEncode :: !(Encoding s a)+  , codecDecode :: !(Decoding a)+  -- , codecMultiEncode :: !(MultiEncoding s a)+  -- , codecMultiDecode :: !(MultiDecoding s a)+  }++newtype Decoding a = Decoding { getDecoding :: CSize -> Ptr Word8 -> IO a }+-- newtype Encoding a = Encoding { getEncoding :: a -> SizedPoke }++-- data SomeFixedSize (s :: Size) where+--   SomeFixedSizeFixed :: CSize -> SomeFixedSize 'Fixed+--   SomeFixedSizeMachineWord :: SomeFixedSize 'MachineWord+--+-- data MultiEncoding (s :: Size) a where+--   MultiEncodingNone :: MultiEncoding 'Variable a+--   MultiEncodingUnboxedVector :: SomeFixedSize s+--     -> (ByteArray -> Ptr Word8 -> IO ()) -- todo: remove this entirely+--     -> MultiEncoding s a+--   -- MultiEncodingIndexedTraversal :: CSize+--   --   -> (forall f b. ((Int -> a -> IO b) -> f a -> IO ()) -> f a -> Ptr Word8 -> IO ())+--   --   -> MultiEncoding 'Fixed a+--+-- data MultiDecoding (s :: Size) a where+--   MultiDecodingNone :: MultiDecoding 'Variable a+--   MultiDecodingUnboxedVector :: SomeFixedSize s+--     -> (Int -> Ptr Word8 -> IO ByteArray) -- todo: remove this entirely+--     -> (forall m b. Monad m => (a -> m b) -> ByteArray -> m ()) -- maybe get rid of this too...+--     -> MultiDecoding s a++data Encoding (s :: Size) a where+  EncodingVariable :: (a -> SizedPoke) -> Encoding 'Variable a+  EncodingFixed :: CSize -> (a -> FixedPoke) -> Encoding 'Fixed a+  EncodingMachineWord :: (a -> FixedPoke) -> Encoding 'MachineWord a++data SizedPoke = SizedPoke+  { sizedPokeSize :: {-# UNPACK #-} !CSize -- ^ size in bytes+  , sizedPokePoke :: !(Ptr Word8 -> IO ())+  }++newtype FixedPoke = FixedPoke { getFixedPoke :: Ptr Word8 -> IO () }++data Size+  = Variable+  | Fixed+  | MachineWord++data NativeSort (s :: Size) where+  NativeSortLexographic :: NativeSort 'Variable+  NativeSortLexographicBackward :: NativeSort 'Variable+  NativeSortInteger :: NativeSort 'MachineWord++data CustomSort a+  = CustomSortSafe (a -> a -> Ordering)+  | CustomSortUnsafe (FunPtr (Ptr MDB_val -> Ptr MDB_val -> IO CInt))++data Sort (s :: Size) a where+  SortNative :: NativeSort s -> Sort s a+  SortCustom :: CustomSort a -> Sort 'Variable a++data Movement k+  = MovementNext+  | MovementPrev+  | MovementFirst+  | MovementLast+  | MovementAt !k+  | MovementAtGte !k+  | MovementCurrent++-- data SingMode (x :: Mode) where+--   SingReadOnly :: SingMode 'ReadOnly+--   SingReadWrite :: SingMode 'ReadWrite++-- class ImplicitMode (x :: Mode) where+--   implicitMode :: SingMode x+--+-- instance ImplicitMode 'ReadOnly where+--   implicitMode = SingReadOnly+--+-- instance ImplicitMode 'ReadWrite where+--   implicitMode = SingReadWrite++-- equivalent to logical implication+-- type family Implies (a :: Mode) (b :: Mode) :: Bool where+--   Implies 'ReadOnly 'ReadOnly = 'True+--   Implies 'ReadOnly 'ReadWrite = 'False+--   Implies 'ReadWrite 'ReadOnly = 'True+--   Implies 'ReadWrite 'ReadWrite = 'True+--+-- type SubMode a b = Implies a b ~ 'True+
+ test/Spec.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}++module Main (main) where++import Lmdb.Types+import Lmdb.Connection+import Lmdb.Internal (runEncoding)+import Data.Monoid (All(..))+import Control.Monad+import qualified Lmdb.Connection as Lmdb+import qualified Lmdb.Codec as Codec+import qualified Lmdb.Map as Map+import qualified Lmdb.Multimap as Multimap+import qualified Data.List as List+import qualified Data.ByteString.Char8 as BC8+import qualified Data.Set as Set+import qualified Data.Map as CMap+import Text.Read (readMaybe)+import Data.ByteString (ByteString)+import Data.Foldable+import Data.Word+import System.Random+import Foreign.Marshal.Alloc+import System.Directory+import Test.HUnit                           (Assertion,(@?=),assertBool,assertFailure)+import Test.Framework                       (testGroup, Test, defaultMain)+import Test.QuickCheck (Gen, Arbitrary(..), choose, Property, arbitraryBoundedEnum)+import Test.QuickCheck.Monadic (monadicIO, assert, run, pre, PropertyM)++import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.Framework.Providers.HUnit       (testCase)+import Debug.Trace+import Pipes+import Control.Concurrent+import Control.Concurrent.MVar+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Pipes.Prelude as Pipes++main :: IO ()+main = do+  let dir = "data/test/"+  createDirectoryIfMissing True dir+  defaultMain tests+  -- For some reason, this does not end up deleting the+  -- directory. Hmm...+  -- removeDirectoryRecursive dir++tests :: [Test]+tests =+  [ testProperty "Put Get Law (single transaction)" putGetLaw+  , testProperty "Put Get Law (separate transactions)" putGetLawSeparate+  , testProperty "Text Codec" (propCodecIso Codec.text)+  , testProperty "ByteString Codec" (propCodecIso Codec.byteString)+  , testProperty "Put Get Law (Text)" textCodecTest+  , testProperty "Native Word Ordering" wordOrdering+  , testProperty "Custom Color Ordering" customColorOrdering+  , testProperty "Multimap Streaming Values at Key" multimapStreamingValues+  ]++testDbiSettings :: DatabaseSettings Word Word+testDbiSettings = makeSettings+  (SortNative NativeSortInteger) Codec.word Codec.word++textualDbiSettings :: DatabaseSettings Text Text+textualDbiSettings = makeSettings+  (SortNative NativeSortLexographic) Codec.text Codec.text++wordTextDbiSettings :: DatabaseSettings Word Text+wordTextDbiSettings = makeSettings+  (SortNative NativeSortInteger) Codec.word Codec.text++-- multiTestSettings :: MultiDatabaseSettings Word Word+-- multiTestSettings = makeMultiSettings+--   (SortNative NativeSortInteger)+--   (SortNative NativeSortInteger)+--   Codec.word+--   Codec.word++multiColorSettings :: MultiDatabaseSettings Word Color+multiColorSettings = makeMultiSettings+  (SortNative NativeSortInteger)+  (SortCustom $ CustomSortSafe compare)+  Codec.word+  (Codec.throughByteString colorToByteString colorFromByteString)++customSortColorSettings :: DatabaseSettings Color Word+customSortColorSettings = makeSettings+  (SortCustom $ CustomSortSafe compare)+  (Codec.throughByteString colorToByteString colorFromByteString)+  Codec.word++data Color = Red | Green | Blue | Purple | Orange | Yellow+  deriving (Show,Read,Eq,Ord,Enum,Bounded)++colorToByteString :: Color -> ByteString+colorToByteString = BC8.pack . show++colorFromByteString :: ByteString -> Maybe Color+colorFromByteString = readMaybe . BC8.unpack++putGetLaw :: Word -> Word -> Property+putGetLaw k v = monadicIO $ do+  (assert =<<) $ run $ do+    withOneDb testDbiSettings $ \env db -> do+      withTransaction env $ \txn -> do+        Map.insert' txn db k v+        m <- Map.lookup' (readonly txn) db k+        return (m == Just v)++putGetLawSeparate :: Word -> Word -> Property+putGetLawSeparate k v = monadicIO $ do+  (assert =<<) $ run $ do+    withOneDb testDbiSettings $ \env db -> do+      withTransaction env $ \txn -> do+        Map.insert' txn db k v+      m <- withTransaction env $ \txn -> do+        Map.lookup' (readonly txn) db k+      return (m == Just v)++wordOrdering :: [Word] -> Property+wordOrdering ks = monadicIO $ do+  (assert =<<) $ run $ do+    withOneDb wordTextDbiSettings $ \env db -> do+      withTransaction env $ \txn -> do+        forM_ ks $ \k -> Map.insertSuccess' txn db k Text.empty+        let ksNoDups = Set.toList $ Set.fromList ks+        withCursor txn db $ \cur -> do+          xs <- Pipes.toListM (Map.firstForward cur)+          return (map keyValueKey xs == ksNoDups)++customColorOrdering :: [Color] -> Property+customColorOrdering ks = monadicIO $ do+  (assert =<<) $ run $ do+    withOneDb customSortColorSettings $ \env db -> do+      withTransaction env $ \txn -> do+        forM_ ks $ \k -> Map.insertSuccess' txn db k 55+        let ksNoDups = Set.toList $ Set.fromList ks+        withCursor txn db $ \cur -> do+          xs <- Pipes.toListM (Map.firstForward cur)+          return (map keyValueKey xs == ksNoDups)++multimapStreamingValues :: [(Word,Color)] -> Property+multimapStreamingValues xs = monadicIO $ do+  (assert =<<) $ run $ do+    withOneMultiDb multiColorSettings $ \env db -> do+      withTransaction env $ \txn -> do+        let xs2 = map (\(a,b) -> (a,Set.singleton b)) xs+            expected = CMap.toList $ fmap Set.toList $ CMap.fromListWith mappend xs2+        withMultiCursor txn db $ \cur -> do+          forM_ xs $ \(k,v) -> Multimap.insert cur k v+          All correct <- fmap mconcat $ forM expected $ \(k,expVals) -> do+            vals <- Pipes.toListM $ Multimap.lookupValues cur k+            return $ All $ vals == expVals+          return correct++textCodecTest :: Text -> Text -> Property+textCodecTest k v = monadicIO $ do+  pre (not $ Text.null k)+  pre (Text.length k < 512)+  (assertWith =<<) $ run $ do+    withOneDb textualDbiSettings $ \env db -> do+      withTransaction env $ \txn -> do+        Map.insert' txn db k v+      withTransaction env $ \txn -> do+        m <- Map.lookup' (readonly txn) db k+        return $ case m of+          Just found -> if found == v+            then Nothing+            else Just $ concat+              [ "Looking up key ["+              , Text.unpack k+              , "]: expected ["+              , Text.unpack v+              , "] but got ["+              , Text.unpack found+              , "]"+              ]+          Nothing -> Just $ concat+            [ "Tried to look up key ["+            , Text.unpack k+            , "] after insertion but no value was found"+            ]++propCodecIso :: (Eq a,Show a) => Codec s a -> a -> Property+propCodecIso (Codec encoding (Decoding decode)) original = do+  let SizedPoke sz f = runEncoding encoding original+  monadicIO $ (assertWith =<<) $ run $ allocaBytes (fromIntegral sz) $ \ptr -> do+    f ptr+    copied <- decode sz ptr+    return $ if copied == original+      then Nothing+      else Just $ concat+        [ "Original value: ["+        , show original+        , "] Decoded value: ["+        , show copied+        , "]"+        ]++assertWith :: Monad m => Maybe String -> PropertyM m ()+assertWith Nothing = return ()+assertWith (Just e) = fail e++withOneDb ::+     DatabaseSettings k v+  -> (Environment 'ReadWrite -> Database k v -> IO a)+  -> IO a+withOneDb s1 f = do+  dirNum <- randomIO :: IO Word64+  let dir = "data/test/" ++ show dirNum+  createDirectory dir+  env <- initializeReadWriteEnvironment 1000000 5 25 dir+  db1 <- withTransaction env $ \txn -> do+    openDatabase txn (Just "db1") s1+  a <- f env db1+  closeDatabase env db1+  closeEnvironment env+  removeDirectoryRecursive dir+  return a++withOneMultiDb ::+     MultiDatabaseSettings k v+  -> (Environment 'ReadWrite -> MultiDatabase k v -> IO a)+  -> IO a+withOneMultiDb s1 f = do+  dirNum <- randomIO :: IO Word64+  let dir = "data/test/" ++ show dirNum+  createDirectory dir+  env <- initializeReadWriteEnvironment 1000000 5 25 dir+  db1 <- withTransaction env $ \txn -> do+    openMultiDatabase txn (Just "db1") s1+  a <- f env db1+  closeMultiDatabase env db1+  closeEnvironment env+  removeDirectoryRecursive dir+  return a++instance Arbitrary Color where+  arbitrary = arbitraryBoundedEnum++instance Arbitrary Text where+  arbitrary = fmap Text.pack arbitrary+  shrink = map Text.pack . shrink . Text.unpack++instance Arbitrary ByteString where+  arbitrary = fmap BC8.pack arbitrary+  shrink = map BC8.pack . shrink . BC8.unpack+