--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/haskell/qdbm/QDBM/Depot.hs	Sun Apr 27 12:33:49 2008 +0100
@@ -0,0 +1,131 @@
+{-# INCLUDE <depot.h> #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE OverloadedStrings #-}
+module QDBM.Depot (
+  AccessMode (Read, Write),
+  Depot,
+  openDepot,
+  closeDepot,
+  put,
+  get,
+  remove
+)where
+import Foreign.C 
+import Foreign.C.String
+import Foreign
+import Foreign.Marshal.Alloc
+import Data.ByteString
+import Data.ByteString.Unsafe
+import qualified Data.ByteString.Internal as Internal
+import Data.Bits
+import Control.Monad
+ 
+type Depot = Ptr CDepot
+
+data AccessMode = Read | Write
+
+-- Open the Depot with the given name, creating it if it does not exist, 
+-- using the given access mode.
+openDepot :: ByteString -> AccessMode -> IO Depot
+openDepot name mode = useAsCString name openDepotWithCString
+  where modemask = case mode of 
+                        Read -> dp_OREADER 
+                        Write -> dp_OWRITER .|. dp_OCREATE   
+        openDepotWithCString str = do depot <- dpopen str modemask 100
+                                      if (depot == nullPtr)
+                                        then dpError
+                                        else return depot
+
+-- Close the Depot. Any subsequent uses of it will be invalid and have
+-- undefined behaviour.
+closeDepot :: Depot -> IO ()
+closeDepot = check . dpclose
+
+
+get :: Depot -> ByteString -> IO (Maybe ByteString)
+get depot str = unsafeUseAsCStringLen str getCSL
+  where getCSL :: CStringLen -> IO (Maybe ByteString)
+        getCSL (cstr, len) =  
+          do (result, resultlen) <- withInParam $ dpget depot cstr len 0 (-1)                
+             if (result == nullPtr) then return Nothing
+                                    else liftM Just $ cStringLenToByteString (result, resultlen) 
+
+put :: Depot -> ByteString -> ByteString -> IO () 
+put depot key value =  unsafeUseAsCStringLen key $ \k -> (unsafeUseAsCStringLen value $ put' k)
+  where put' :: CStringLen -> CStringLen -> IO ()
+        put' (ks, kl) (vs, vl) = check $ dpput depot ks kl vs vl 0 
+
+remove :: Depot -> ByteString -> IO ()
+remove depot string = check $ unsafeUseAsCStringLen string (uncurry $ dpout depot)
+
+-- Note that this function is *not* reentrant. Calling it inside itself
+-- will break everything. :(
+forEachKey :: Depot -> (ByteString -> IO Bool) -> IO ()
+forEachKey depot f = do check $ dpiterinit depot
+                        doNext
+  where doNext = do (result, len) <- withInParam (dpiternext depot)
+                    if (result == nullPtr) 
+                      then return ()
+                      else do continue <- (cStringLenToByteString (result, len)) >>= f
+                              if (continue) 
+                                then doNext
+                                else return ()
+                                               
+
+dpError :: IO a
+dpError = dpecodeptr >>= peek >>= dperrmsg >>= peekCString >>= fail
+                          
+
+-- IO and FFI utilities
+withInParam :: (Storable a) => (Ptr a -> IO b) -> IO (b, a)
+withInParam f = alloca $ \ptr -> do x <- f ptr
+                                    y <- peek ptr
+                                    return (x, y)
+
+cStringToForeignPtr :: CString -> IO (ForeignPtr Word8)
+cStringToForeignPtr str = newForeignPtr finalizerFree (castPtr str)
+
+cStringLenToByteString :: CStringLen -> IO ByteString
+cStringLenToByteString (str, len) = do ptr <- cStringToForeignPtr str
+                                       return $ Internal.fromForeignPtr ptr 0 len
+
+check :: IO CInt -> IO ()
+check action = do x <- action
+                  if (x == 0) 
+                    then dpError
+                    else return ()
+
+-- FFI bits
+dp_OREADER = 1 :: CInt
+dp_OWRITER = 1 `shiftL` 1 :: CInt
+dp_OCREATE = 1 `shiftL` 2 :: CInt
+
+-- DEPOT *dpopen(const char *name, int omode, int bnum);
+data CDepot
+
+foreign import ccall "dpopen" dpopen :: CString -> CInt -> CInt -> IO (Ptr CDepot)
+
+-- int dpclose(DEPOT *depot);
+foreign import ccall "dpclose" dpclose :: Ptr CDepot -> IO CInt
+
+-- int dpput(DEPOT *depot, const char *kbuf, int ksiz, const char *vbuf, int vsiz, int dmode);
+foreign import ccall "dpput" dpput :: Ptr CDepot -> CString -> Int -> CString -> Int -> Int -> IO CInt
+
+-- int dpout(DEPOT *depot, const char *kbuf, int ksiz);
+foreign import ccall "dpout" dpout :: Ptr CDepot -> CString -> Int -> IO CInt
+
+-- char *dpget(DEPOT *depot, const char *kbuf, int ksiz, int start, int max, int *sp);
+foreign import ccall "dpget" dpget :: Ptr CDepot -> CString -> Int -> Int -> Int -> Ptr Int -> IO CString
+
+-- int dpiterinit(DEPOT *depot);
+foreign import ccall "dpiterinit" dpiterinit :: Ptr CDepot -> IO CInt
+
+-- char *dpiternext(DEPOT *depot, int *sp); 
+foreign import ccall "dpiternext" dpiternext :: Ptr CDepot -> Ptr Int -> IO CString
+
+-- extern int dpecode;
+foreign import ccall "dpecodeptr" dpecodeptr :: IO (Ptr CInt)
+
+-- const char *dperrmsg(int ecode); 
+foreign import ccall "dperrmsg" dperrmsg :: CInt -> IO CString