Fix errors not releasing memory.

- Refactor some files for clarity
- Bump LTS Haskell

Author: jprupp

Diff for: CHANGELOG.md

@@ -1,3 +1,7 @@
+## 2.1.5
+
+ * Fix errors not releasing memory.
+
 ## 2.1.4
 
  * Add ResourceT support for snapshots and iterators.

Diff for: hie.yaml

@@ -0,0 +1,2 @@
+cradle:
+  stack:

Diff for: package.yaml

@@ -1,5 +1,5 @@
 name: rocksdb-haskell-jprupp
-version: 2.1.4
+version: 2.1.5
 synopsis: Haskell bindings for RocksDB
 description: See README at <https://github.com/jprupp/rocksdb-haskell#readme>
 maintainer: Jean-Pierre Rupp <[email protected]>

Diff for: rocksdb-haskell-jprupp.cabal

@@ -1,13 +1,13 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.35.2.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 48b49def634c00156ec5f8bc2f4a8c92caf0aca334fca3cef6507f51febe9867
+-- hash: 7e9a6be0b5ec766b502a4a03665778ca9fd0e9b17df4f5da3f902cb7631111be
 
 name:           rocksdb-haskell-jprupp
-version:        2.1.4
+version:        2.1.5
 synopsis:       Haskell bindings for RocksDB
 description:    See README at <https://github.com/jprupp/rocksdb-haskell#readme>
 category:       Database, FFI

Diff for: src/Database/RocksDB/Base.hs

@@ -146,9 +146,9 @@ withDBCF path config cf_cfgs f =
               write_opts = liftIO $ do
         when (createIfMissing config) $
             createDirectoryIfMissing True path
-        null <$> listDirectory path >>= \case
-            True -> create_new cf_names cf_opts opts_ptr read_opts write_opts
-            False -> withCString path $ \path_ptr ->
+        listDirectory path >>= \case
+            [] -> create_new cf_names cf_opts opts_ptr read_opts write_opts
+            _ -> withCString path $ \path_ptr ->
                 withCString "default" $ \cf_deflt_name -> do
                     pokeArray cf_names_array (cf_deflt_name : cf_names)
                     pokeArray cf_opts_array (opts_ptr : cf_opts)
@@ -280,13 +280,13 @@ getCommon DB{rocksDB = db_ptr, readOpts = read_opts} mcf key = liftIO $
                 Nothing -> c_rocksdb_get
                            db_ptr read_opts
                            key_ptr (intToCSize klen) vlen_ptr
-        vlen <- peek vlen_ptr
         if val_ptr == nullPtr
             then return Nothing
             else do
-                res' <- Just <$> BS.packCStringLen (val_ptr, cSizeToInt vlen)
+                vlen <- peek vlen_ptr
+                res <- Just <$> BS.packCStringLen (val_ptr, cSizeToInt vlen)
                 freeCString val_ptr
-                return res'
+                return res
 
 delete :: MonadIO m => DB -> ByteString -> m ()
 delete db = deleteCommon db Nothing
@@ -312,7 +312,7 @@ write DB{rocksDB = db_ptr, writeOpts = write_opts} batch = liftIO $
         throwIfErr "write" $ c_rocksdb_write db_ptr write_opts batch_ptr
         -- ensure @ByteString@s (and respective shared @CStringLen@s) aren't
         -- GC'ed until here
-        mapM_ (liftIO . touch) batch
+        mapM_ touch batch
   where
     batchAdd batch_ptr (Put key val) =
         BU.unsafeUseAsCStringLen key $ \(key_ptr, klen) ->

Diff for: src/Database/RocksDB/C.hs

@@ -109,7 +109,7 @@ type RocksDB            = Ptr LRocksDB
 type ColumnFamily       = Ptr LColumnFamily
 type Options            = Ptr LOptions
 type WriteBatch         = Ptr LWriteBatch
-type SliceTransform      = Ptr LSliceTransform
+type SliceTransform     = Ptr LSliceTransform
 type ReadOpts           = Ptr LReadOpts
 type WriteOpts          = Ptr LWriteOpts
 type Snapshot           = Ptr LSnapshot

Diff for: src/Database/RocksDB/Internal.hs

@@ -59,45 +59,30 @@ instance Default Config where
                  }
 
 withOptions :: MonadUnliftIO m => Config -> (Options -> m a) -> m a
-withOptions Config {..} f =
-    with_opts $ \opts -> do
-        liftIO $ do
-            slice <- bloom
-            block_opts opts slice
-            pfx_extract opts
-            max_files opts
-            c_rocksdb_options_set_create_if_missing
-                opts (boolToCBool createIfMissing)
-            c_rocksdb_options_set_error_if_exists
-                opts (boolToCBool errorIfExists)
-            c_rocksdb_options_set_paranoid_checks
-                opts (boolToCBool paranoidChecks)
-        f opts
+withOptions Config {..} f = with_opts $ \opts -> do
+    liftIO $ do
+        when bloomFilter $ do
+            fp <- c_rocksdb_filterpolicy_create_bloom_full 10
+            bo <- c_rocksdb_block_based_options_create
+            c_rocksdb_block_based_options_set_filter_policy bo fp
+            c_rocksdb_options_set_block_based_table_factory opts bo
+        forM_ prefixLength $ \l -> do
+            t <- c_rocksdb_slicetransform_create_fixed_prefix (intToCSize l)
+            c_rocksdb_options_set_prefix_extractor opts t
+        forM_ maxFiles $
+            c_rocksdb_options_set_max_open_files opts . intToCInt
+        c_rocksdb_options_set_create_if_missing
+            opts (boolToCBool createIfMissing)
+        c_rocksdb_options_set_error_if_exists
+            opts (boolToCBool errorIfExists)
+        c_rocksdb_options_set_paranoid_checks
+            opts (boolToCBool paranoidChecks)
+    f opts
   where
     with_opts =
         bracket
         (liftIO c_rocksdb_options_create)
         (liftIO . c_rocksdb_options_destroy)
-    block_opts _ Nothing = return ()
-    block_opts opts (Just slice) = liftIO $ do
-        block <- c_rocksdb_block_based_options_create
-        c_rocksdb_block_based_options_set_filter_policy block slice
-        c_rocksdb_options_set_block_based_table_factory opts block
-    bloom =
-        if bloomFilter
-        then Just <$> c_rocksdb_filterpolicy_create_bloom_full 10
-        else return Nothing
-    pfx_extract opts =
-        case prefixLength of
-            Nothing -> return ()
-            Just len -> liftIO $ do
-                p <- c_rocksdb_slicetransform_create_fixed_prefix
-                     (intToCSize len)
-                c_rocksdb_options_set_prefix_extractor opts p
-    max_files opts =
-        case maxFiles of
-            Nothing -> return ()
-            Just i -> c_rocksdb_options_set_max_open_files opts (intToCInt i)
 
 
 withOptionsCF :: MonadUnliftIO m => [Config] -> ([Options] -> m a) -> m a
@@ -131,9 +116,10 @@ throwIfErr :: MonadUnliftIO m => String -> (ErrPtr -> m a) -> m a
 throwIfErr s f = alloca $ \err_ptr -> do
     liftIO $ poke err_ptr nullPtr
     res  <- f err_ptr
-    erra <- liftIO $ peek err_ptr
-    when (erra /= nullPtr) $ do
-        err <- liftIO $ peekCString erra
+    err_cstr <- liftIO $ peek err_ptr
+    when (err_cstr /= nullPtr) $ do
+        err <- liftIO $ peekCString err_cstr
+        liftIO $ free err_cstr
         throwIO $ userError $ s ++ ": " ++ err
     return res
 

Diff for: stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-16.5
+resolver: lts-21.11
 nix:
   packages:
     - rocksdb

Diff for: stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 531707
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/5.yaml
-    sha256: 9751e25e0af5713a53ddcfcc79564b082c71b1b357fadef0d85672a5b5ba3703
-  original: lts-16.5
+    sha256: 64d66303f927e87ffe6b8ccf736229bf608731e80d7afdf62bdd63c59f857740
+    size: 640037
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/11.yaml
+  original: lts-21.11

Diff for: test/tests.hs

@@ -37,7 +37,7 @@ main =  do
             it "should store and retrieve items from different column families" $
                 withSystemTempDirectory "rocksdbcf1" $ \path ->
                 withTestDBCF path ["two"] $ \db -> do
-                    let [two] = columnFamilies db
+                    let two = head $ columnFamilies db
                     put db "one" "one"
                     get db "one" `shouldReturn` Just "one"
                     getCF db two "one" `shouldReturn` Nothing
@@ -57,5 +57,5 @@ main =  do
                         kvs = zip keys vals
                     as1 <- mapM (\(k, v) -> async $ put db k v) kvs
                     mapM_ wait as1
-                    as2 <- mapM (\k -> async $ get db k) keys
+                    as2 <- mapM (async . get db) keys
                     mapM wait as2 `shouldReturn` map Just vals