ENH Add a Haskell interface

.gitignore

@@ -0,0 +1 @@
+/.stack-work/

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

diskhash.cabal

@@ -0,0 +1,28 @@
+name:               diskhash
+version:            0.0.1.0
+synopsis:           Disk-based hash table
+description:        Disk-based hash table
+category:           Data
+author:             Luis Pedro Coelho
+maintainer:         Luis Pedro Coelho
+license:            MIT
+license-file:       COPYING
+cabal-version:      >= 1.10
+build-type:         Simple
+bug-reports:        https://github.com/luispedro/diskhash/issues
+extra-source-files: README.md ChangeLog
+
+library
+  default-language: Haskell2010
+  exposed-modules: Data.DiskHash
+  hs-source-dirs: haskell/
+  C-sources: haskell/Data/diskhash2.c src/diskhash.c
+  Include-dirs: src/
+  ghc-options: -Wall
+  build-depends:
+    base > 4 && < 5,
+    bytestring
+
+source-repository head
+  type: git
+  location: https://github.com/luispedro/safeio

haskell/Data/DiskHash.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
+module Data.DiskHash
+    ( DiskHashRO
+    , DiskHashRW
+    , htOpenRO
+    , htOpenRW
+    , htLookupRO
+    , htLookupRW
+    , htInsert
+    , htModify
+    , htReserve
+    ) where
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
+import Control.Exception (throwIO)
+import System.IO.Unsafe (unsafeDupablePerformIO)
+import Foreign.Ptr (Ptr, FunPtr, castPtr, nullPtr)
+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)
+import Foreign.Storable (Storable(..))
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.C.Types (CInt(..))
+import Foreign.C.String (CString)
+
+-- | Disk based hash table
+--
+-- The Haskell interface has two types, distinguishing between read-only and
+-- read-write hash tables.
+
+type HashTable_t = ForeignPtr ()
+data DiskHashRO a = DiskHashRO HashTable_t
+data DiskHashRW a = DiskHashRW HashTable_t
+
+foreign import ccall "dht_open2" c_dht_open2:: CString -> CInt -> CInt -> CInt -> IO (Ptr ())
+foreign import ccall "dht_lookup" c_dht_lookup :: Ptr () -> CString -> IO (Ptr ())
+foreign import ccall "dht_reserve" c_dht_reserve :: Ptr () -> CInt -> IO ()
+foreign import ccall "dht_insert" c_dht_insert :: Ptr () -> CString -> Ptr () -> IO CInt
+foreign import ccall "&dht_free" c_dht_free_p :: FunPtr (Ptr () -> IO ())
+
+-- | open a hash table in read-write mode
+htOpenRW :: forall a. (Storable a) => FilePath -> Int -> IO (DiskHashRW a)
+htOpenRW fpath maxk = DiskHashRW <$> open' (undefined :: a) fpath maxk 66
+
+-- | open a hash table in read-only mode
+htOpenRO :: forall a. (Storable a) => FilePath -> Int -> IO (DiskHashRO a)
+htOpenRO fpath maxk = DiskHashRO <$> open' (undefined :: a) fpath maxk 0
+
+open' :: forall a. (Storable a) => a -> FilePath -> Int -> CInt -> IO HashTable_t
+open' unused fpath maxk flags = B.useAsCString (B8.pack fpath) $ \fpath' -> do
+    ht <- c_dht_open2 fpath' (fromIntegral maxk) (fromIntegral $ sizeOf unused) flags
+    newForeignPtr c_dht_free_p ht
+
+-- | insert an element into the hash table
+--
+-- Returns whether an insertion took place (if an object with that key already
+-- exists, no insertion is made).
+htInsert :: (Storable a) => B.ByteString
+                            -- ^ key
+                            -> a
+                            -- ^ value
+                            -> DiskHashRW a
+                            -- ^ hash table
+                            -> IO Bool
+                            -- ^ True if inserted, False if not
+htInsert key val (DiskHashRW ht) =
+        withForeignPtr ht $ \ht' ->
+            B.useAsCString key $ \key' ->
+                alloca $ \val' -> do
+                    poke val' val
+                    r <- c_dht_insert ht' key' (castPtr val')
+                    case r of
+                        1 -> return True
+                        0 -> return False
+                        -1 -> throwIO $ userError "insertion failed (probably out of memory)"
+                        _ -> throwIO $ userError "Unexpected return from dht_insert"
+-- | Lookup by key
+htLookupRW :: (Storable a) => B.ByteString -> DiskHashRW a -> IO (Maybe a)
+htLookupRW key (DiskHashRW ht) =
+    withForeignPtr ht $ \ht' ->
+        B.useAsCString key $ \key' -> do
+            r <- c_dht_lookup ht' key'
+            if r == nullPtr
+                then return Nothing
+                else Just <$> peek (castPtr r)
+
+-- | Lookup by key
+htLookupRO :: (Storable a) => B.ByteString -> DiskHashRO a -> Maybe a
+htLookupRO key (DiskHashRO ht) = unsafeDupablePerformIO (htLookupRW key (DiskHashRW ht))
+
+-- | Modify a value
+htModify :: (Storable a) => B.ByteString -> (a -> a) -> DiskHashRW a -> IO Bool
+htModify key f (DiskHashRW ht) =
+    withForeignPtr ht $ \ht' ->
+        B.useAsCString key $ \key' -> do
+            r <- castPtr <$> c_dht_lookup ht' key'
+            if r == nullPtr
+                then return False
+                else do
+                    val <- peek r
+                    poke r (f val)
+                    return True
+
+-- | Reserve space in the hash table
+--
+-- If the operation fails, an exception is raised
+htReserve :: (Storable a) => Int -> DiskHashRW a -> IO Int
+htReserve cap (DiskHashRW ht) =
+    withForeignPtr ht $ \ht' -> do
+        cap' <- fromEnum <$> c_dht_reserve ht' (fromIntegral cap)
+        if cap' == 0
+            then throwIO $ userError "Could not change capacity"
+            else return cap'
+

haskell/Data/diskhash2.c

@@ -0,0 +1,7 @@
+#include "diskhash.h"
+HashTable* dht_open2(const char* f, unsigned int key_maxlen, unsigned int object_datalen, int flags) {
+    HashTableOpts opts;
+    opts.key_maxlen = key_maxlen;
+    opts.object_datalen = object_datalen;
+    return dht_open(f, opts, flags);
+}

src/diskhash.h

@@ -1,7 +1,10 @@
+#include <stddef.h>
+
 #ifdef __cplusplus
 extern "C" {
 #endif
 
+
 typedef struct HashTableOpts {
     size_t key_maxlen;
     size_t object_datalen;
@@ -81,6 +84,9 @@ int dht_insert(HashTable*, const char* key, const void* data);
  * This function returns the actual capacity allocated (which may be more than
  * requested, but never less). Calling dht_reserve asking for _less_ capacity
  * than is currently used is a no-op.
+ *
+ * If capacity cannot be allocated, this function returns 0 (but no changes to
+ * the hash table are made).
  */
 size_t dht_reserve(HashTable*, size_t capacity);
 

stack.yaml

@@ -0,0 +1,9 @@
+resolver: lts-8.15
+
+packages:
+- .
+extra-deps: []
+
+flags: {}
+
+extra-package-dbs: []