LMDB.hs (13685B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE EmptyDataDecls #-} 4 5 -- | 6 -- Module: Database.LMDB 7 -- Copyright: (c) 2026 Jared Tobin 8 -- License: MIT 9 -- Maintainer: Jared Tobin <jared@ppad.tech> 10 -- 11 -- Minimal bindings to 12 -- [LMDB](https://www.symas.com/lmdb), an embedded ACID key-value 13 -- store. The upstream LMDB C source is vendored under @cbits\/@ at 14 -- release @LMDB_0.9.33@; no external @liblmdb@ is needed. 15 -- 16 -- LMDB has a single-writer, many-reader transaction model and uses 17 -- memory mapping for zero-copy reads. This module presents that as a 18 -- bracketed @IO@-only interface. 19 -- 20 -- Read-only and read-write transactions are distinguished at the type 21 -- level via a phantom parameter on 'Txn', so using a write primitive 22 -- (e.g. 'put') on a read transaction is a compile-time error. 23 -- 24 -- Most operations throw 'LMDBException' on error. 'get' and 'del' are 25 -- the exceptions: they map a missing key onto 'Nothing' and 'False' 26 -- respectively, since absence is normal control flow. 27 28 module Database.LMDB ( 29 -- * Environments 30 Env 31 , EnvFlags(..) 32 , defaultEnvFlags 33 , open 34 , close 35 , withEnv 36 37 -- * Transactions 38 , Txn 39 , RO 40 , RW 41 , withReadTxn 42 , withWriteTxn 43 44 -- * Databases 45 , Dbi 46 , openDbi 47 48 -- * Key-value operations 49 , get 50 , put 51 , del 52 53 -- * Cursors 54 , Cursor 55 , withCursor 56 , cursorFirst 57 , cursorLast 58 , cursorNext 59 , cursorPrev 60 , cursorSeek 61 62 -- * Errors 63 , LMDBException(..) 64 ) where 65 66 import Control.Exception 67 ( Exception, bracket, bracketOnError, mask, onException, throwIO) 68 import qualified Data.ByteString as BS 69 import qualified Data.ByteString.Unsafe as BU 70 import Foreign.C.String (peekCString, withCString) 71 import Foreign.C.Types (CInt, CSize, CUInt) 72 import Foreign.Marshal.Alloc (alloca, allocaBytes) 73 import Foreign.Ptr (Ptr, nullPtr, plusPtr) 74 import Foreign.Storable (peek, peekByteOff, pokeByteOff) 75 import Database.LMDB.Internal 76 77 -- handles -------------------------------------------------------------------- 78 79 -- | An LMDB environment. Roughly, an open database file (or, with 80 -- 'envNoSubdir' off, a directory containing one). 81 newtype Env = Env (Ptr MDB_env) 82 83 -- | Phantom tag for read-only transactions. 84 data RO 85 86 -- | Phantom tag for read-write transactions. 87 data RW 88 89 -- | A transaction. The phantom @s@ distinguishes 'RO' from 'RW' so 90 -- that write operations refuse to type-check against read-only 91 -- transactions. 92 newtype Txn s = Txn (Ptr MDB_txn) 93 94 -- | A database identifier within an 'Env'. 95 newtype Dbi = Dbi MDB_dbi 96 97 -- | A cursor for range-scanning a 'Dbi'. 98 newtype Cursor s = Cursor (Ptr MDB_cursor) 99 100 -- environment flags ---------------------------------------------------------- 101 102 -- | Configuration for 'open'. 103 data EnvFlags = EnvFlags 104 { envMapSize :: !Int 105 -- ^ map size in bytes; LMDB will refuse writes beyond this. The 106 -- default of 10 MiB is intentionally small — set it to something 107 -- appropriate for your workload before opening. 108 , envMaxDbs :: !Int 109 -- ^ maximum number of named sub-databases. Default 1. 110 , envNoSubdir :: !Bool 111 -- ^ if 'True', treat the path as a regular file rather than a 112 -- directory containing @data.mdb@ and @lock.mdb@. 113 , envReadOnly :: !Bool 114 -- ^ open the environment read-only. 115 , envNoSync :: !Bool 116 -- ^ skip @fsync@ at commit time. Faster, but a crash may lose 117 -- the last transaction. The database remains internally 118 -- consistent. 119 } deriving Show 120 121 -- | Default 'EnvFlags': 10 MiB map, one database, directory layout, 122 -- read-write, syncing at commit. 123 -- 124 -- >>> envMapSize defaultEnvFlags 125 -- 10485760 126 defaultEnvFlags :: EnvFlags 127 defaultEnvFlags = EnvFlags 128 { envMapSize = 10 * 1024 * 1024 129 , envMaxDbs = 1 130 , envNoSubdir = False 131 , envReadOnly = False 132 , envNoSync = False 133 } 134 135 envFlagBits :: EnvFlags -> CUInt 136 envFlagBits EnvFlags { envNoSubdir = nsd, envReadOnly = ro, envNoSync = ns } = 137 (if nsd then _MDB_NOSUBDIR else 0) 138 + (if ro then _MDB_RDONLY else 0) 139 + (if ns then _MDB_NOSYNC else 0) 140 141 -- error handling ------------------------------------------------------------- 142 143 -- | A typed wrapper around LMDB error codes. 'LMDBOther' carries the 144 -- raw error code plus the message from @mdb_strerror@. 145 data LMDBException 146 = LMDBKeyExist 147 | LMDBNotFound -- ^ Only seen via "Database.LMDB.Internal"; 148 -- the safe layer maps this to 'Nothing' 149 -- or 'False' instead of throwing. 150 | LMDBMapFull 151 | LMDBCorrupted 152 | LMDBPanic 153 | LMDBVersionMismatch 154 | LMDBOther !Int !String 155 deriving Show 156 157 instance Exception LMDBException 158 159 throwLmdb :: CInt -> IO a 160 throwLmdb code 161 | code == _MDB_KEYEXIST = throwIO LMDBKeyExist 162 | code == _MDB_NOTFOUND = throwIO LMDBNotFound 163 | code == _MDB_MAP_FULL = throwIO LMDBMapFull 164 | code == _MDB_CORRUPTED = throwIO LMDBCorrupted 165 | code == _MDB_PANIC = throwIO LMDBPanic 166 | code == _MDB_VERSION_MISMATCH = throwIO LMDBVersionMismatch 167 | otherwise = do 168 msg <- mdb_strerror code >>= peekCString 169 throwIO (LMDBOther (fromIntegral code) msg) 170 171 check :: CInt -> IO () 172 check 0 = pure () 173 check c = throwLmdb c 174 {-# INLINE check #-} 175 176 -- environment lifecycle ------------------------------------------------------ 177 178 -- | Open an LMDB environment at the given path. The path must already 179 -- exist (as a directory unless 'envNoSubdir' is set, in which case 180 -- the file's parent directory must exist). 181 -- 182 -- Throws 'LMDBException' on failure. 183 -- 184 -- >>> env <- open "/tmp/mydb" defaultEnvFlags { envNoSubdir = True } 185 open :: FilePath -> EnvFlags -> IO Env 186 open path flags = mask $ \restore -> do 187 envp <- alloca $ \pp -> do 188 check =<< mdb_env_create pp 189 peek pp 190 let env = Env envp 191 flip onException (close env) . restore $ do 192 check =<< mdb_env_set_mapsize envp 193 (fromIntegral (envMapSize flags)) 194 check =<< mdb_env_set_maxdbs envp 195 (fromIntegral (envMaxDbs flags)) 196 withCString path $ \cpath -> 197 check =<< mdb_env_open envp cpath (envFlagBits flags) 0o644 198 pure env 199 200 -- | Close an environment. Must not be called while transactions are 201 -- live. 202 close :: Env -> IO () 203 close (Env envp) = mdb_env_close envp 204 205 -- | Bracketed environment lifecycle: 'open' the environment, run the 206 -- action, 'close' on exit (including async exceptions). 207 -- 208 -- >>> withEnv "/tmp/mydb" defaultEnvFlags $ \env -> ... 209 withEnv :: FilePath -> EnvFlags -> (Env -> IO a) -> IO a 210 withEnv path flags = bracket (open path flags) close 211 212 -- transactions --------------------------------------------------------------- 213 214 beginTxn :: Env -> CUInt -> IO (Ptr MDB_txn) 215 beginTxn (Env envp) flags = alloca $ \pp -> do 216 check =<< mdb_txn_begin envp nullPtr flags pp 217 peek pp 218 219 -- | Run an action in a read-only transaction. The transaction is 220 -- aborted on exit; read transactions have no work to commit. 221 -- 222 -- >>> withReadTxn env $ \txn -> ... 223 withReadTxn :: Env -> (Txn RO -> IO a) -> IO a 224 withReadTxn env act = bracketOnError 225 (beginTxn env _MDB_RDONLY) 226 mdb_txn_abort 227 (\txnp -> do 228 r <- act (Txn txnp) 229 mdb_txn_abort txnp 230 pure r) 231 232 -- | Run an action in a read-write transaction. Commits if the action 233 -- returns normally; aborts on exception. 234 -- 235 -- >>> withWriteTxn env $ \txn -> ... 236 withWriteTxn :: Env -> (Txn RW -> IO a) -> IO a 237 withWriteTxn env act = bracketOnError 238 (beginTxn env 0) 239 mdb_txn_abort 240 (\txnp -> do 241 r <- act (Txn txnp) 242 check =<< mdb_txn_commit txnp 243 pure r) 244 245 -- databases ------------------------------------------------------------------ 246 247 -- | Open a database within a transaction. Pass 'Nothing' for the 248 -- unnamed default database. If the @create@ flag is 'True', the 249 -- database is created if it does not already exist — and the 250 -- transaction must be a read-write transaction. 251 -- 252 -- >>> dbi <- openDbi txn Nothing True 253 openDbi 254 :: Txn s 255 -> Maybe BS.ByteString -- ^ database name; 'Nothing' for the default 256 -> Bool -- ^ create if not present 257 -> IO Dbi 258 openDbi (Txn txnp) mname create = alloca $ \pp -> do 259 let flags = if create then _MDB_CREATE else 0 260 go cstr = do 261 check =<< mdb_dbi_open txnp cstr flags pp 262 Dbi <$> peek pp 263 case mname of 264 Nothing -> go nullPtr 265 Just nm -> BU.unsafeUseAsCString nm go 266 267 -- bytestring <-> MDB_val helpers -------------------------------------------- 268 269 -- An MDB_val is two words: a CSize length at offset 0, a payload Ptr 270 -- at offset 8 (on 64-bit). We poke fields directly rather than going 271 -- through the Storable instance so hot paths don't depend on it being 272 -- inlined. 273 274 withBSAsVal :: BS.ByteString -> (Ptr MDB_val -> IO a) -> IO a 275 withBSAsVal bs k = 276 BU.unsafeUseAsCStringLen bs $ \(p, n) -> 277 allocaBytes 16 $ \vp -> do 278 pokeByteOff vp 0 (fromIntegral n :: CSize) 279 pokeByteOff vp 8 p 280 k vp 281 {-# INLINE withBSAsVal #-} 282 283 peekVal :: Ptr MDB_val -> IO BS.ByteString 284 peekVal vp = do 285 sz <- peekByteOff vp 0 :: IO CSize 286 pd <- peekByteOff vp 8 287 BS.packCStringLen (pd, fromIntegral sz) 288 {-# INLINE peekVal #-} 289 290 -- key-value ops -------------------------------------------------------------- 291 292 -- | Look up a key. Returns 'Nothing' if not found. Other LMDB errors 293 -- throw 'LMDBException'. 294 -- 295 -- The returned 'BS.ByteString' is a copy of the data; LMDB's 296 -- memory-mapped buffer is not aliased into Haskell. 297 -- 298 -- >>> get txn dbi "hello" 299 -- Just "world" 300 get 301 :: Txn s 302 -> Dbi 303 -> BS.ByteString -- ^ key 304 -> IO (Maybe BS.ByteString) -- ^ value, if present 305 get (Txn txnp) (Dbi dbi) k = 306 BU.unsafeUseAsCStringLen k $ \(kdata, klen) -> 307 allocaBytes 32 $ \kp -> do 308 let !vp = kp `plusPtr` 16 309 pokeByteOff kp 0 (fromIntegral klen :: CSize) 310 pokeByteOff kp 8 kdata 311 code <- mdb_get txnp dbi kp vp 312 if code == _MDB_NOTFOUND 313 then pure Nothing 314 else do 315 check code 316 Just <$> peekVal vp 317 {-# INLINE get #-} 318 319 -- | Insert or replace a key. Throws 'LMDBException' on failure. 320 -- 321 -- >>> put txn dbi "hello" "world" 322 put 323 :: Txn RW 324 -> Dbi 325 -> BS.ByteString -- ^ key 326 -> BS.ByteString -- ^ value 327 -> IO () 328 put (Txn txnp) (Dbi dbi) k v = 329 BU.unsafeUseAsCStringLen k $ \(kdata, klen) -> 330 BU.unsafeUseAsCStringLen v $ \(vdata, vlen) -> 331 allocaBytes 32 $ \kp -> do 332 let !vp = kp `plusPtr` 16 333 pokeByteOff kp 0 (fromIntegral klen :: CSize) 334 pokeByteOff kp 8 kdata 335 pokeByteOff vp 0 (fromIntegral vlen :: CSize) 336 pokeByteOff vp 8 vdata 337 check =<< mdb_put txnp dbi kp vp 0 338 {-# INLINE put #-} 339 340 -- | Delete a key. Returns 'True' if the key existed and was removed, 341 -- 'False' if it was already absent. 342 -- 343 -- >>> del txn dbi "hello" 344 -- True 345 del 346 :: Txn RW 347 -> Dbi 348 -> BS.ByteString -- ^ key 349 -> IO Bool -- ^ 'True' if the key was present and removed 350 del (Txn txnp) (Dbi dbi) k = 351 withBSAsVal k $ \kp -> do 352 code <- mdb_del txnp dbi kp nullPtr 353 if code == _MDB_NOTFOUND then pure False 354 else do 355 check code 356 pure True 357 {-# INLINE del #-} 358 359 -- cursors -------------------------------------------------------------------- 360 361 -- | Bracketed cursor lifecycle: open a cursor over the given 'Dbi', 362 -- run the action, close the cursor on exit (including async 363 -- exceptions). 364 -- 365 -- >>> withCursor txn dbi $ \cur -> ... 366 withCursor :: Txn s -> Dbi -> (Cursor s -> IO a) -> IO a 367 withCursor (Txn txnp) (Dbi dbi) act = bracket open' mdb_cursor_close use' 368 where 369 open' = alloca $ \pp -> do 370 check =<< mdb_cursor_open txnp dbi pp 371 peek pp 372 use' p = act (Cursor p) 373 374 -- Scan-position helper (no input key): one 32-byte buffer for both 375 -- output MDB_vals. 376 cursorMove 377 :: Cursor s 378 -> CInt -- MDB_cursor_op 379 -> IO (Maybe (BS.ByteString, BS.ByteString)) 380 cursorMove (Cursor cp) op = 381 allocaBytes 32 $ \kp -> do 382 let !vp = kp `plusPtr` 16 383 code <- mdb_cursor_get cp kp vp op 384 if code == _MDB_NOTFOUND 385 then pure Nothing 386 else do 387 check code 388 k <- peekVal kp 389 v <- peekVal vp 390 pure (Just (k, v)) 391 {-# INLINE cursorMove #-} 392 393 -- | Position at the first key/value pair, or 'Nothing' on an empty 394 -- database. 395 -- 396 -- >>> cursorFirst cur 397 -- Just ("a","alpha") 398 cursorFirst :: Cursor s -> IO (Maybe (BS.ByteString, BS.ByteString)) 399 cursorFirst c = cursorMove c _MDB_FIRST 400 {-# INLINE cursorFirst #-} 401 402 -- | Position at the last key/value pair, or 'Nothing' on an empty 403 -- database. 404 cursorLast :: Cursor s -> IO (Maybe (BS.ByteString, BS.ByteString)) 405 cursorLast c = cursorMove c _MDB_LAST 406 {-# INLINE cursorLast #-} 407 408 -- | Advance to the next key/value pair, or 'Nothing' if already at 409 -- the end. 410 cursorNext :: Cursor s -> IO (Maybe (BS.ByteString, BS.ByteString)) 411 cursorNext c = cursorMove c _MDB_NEXT 412 {-# INLINE cursorNext #-} 413 414 -- | Step back to the previous key/value pair, or 'Nothing' if already 415 -- at the start. 416 cursorPrev :: Cursor s -> IO (Maybe (BS.ByteString, BS.ByteString)) 417 cursorPrev c = cursorMove c _MDB_PREV 418 {-# INLINE cursorPrev #-} 419 420 -- | Position at the first key /greater than or equal to/ the given 421 -- key, or 'Nothing' if no such key exists. 422 -- 423 -- >>> cursorSeek cur "m" 424 -- Just ("n","november") 425 cursorSeek 426 :: Cursor s 427 -> BS.ByteString 428 -> IO (Maybe (BS.ByteString, BS.ByteString)) 429 cursorSeek (Cursor cp) k = 430 BU.unsafeUseAsCStringLen k $ \(kdata, klen) -> 431 allocaBytes 32 $ \kp -> do 432 let !vp = kp `plusPtr` 16 433 pokeByteOff kp 0 (fromIntegral klen :: CSize) 434 pokeByteOff kp 8 kdata 435 code <- mdb_cursor_get cp kp vp _MDB_SET_RANGE 436 if code == _MDB_NOTFOUND 437 then pure Nothing 438 else do 439 check code 440 ok <- peekVal kp 441 ov <- peekVal vp 442 pure (Just (ok, ov))