{-# LINE 1 "src/Data/BerkeleyDB/Internal.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}
{-# LINE 2 "src/Data/BerkeleyDB/Internal.hsc" #-}

{-# LINE 3 "src/Data/BerkeleyDB/Internal.hsc" #-}
module Data.BerkeleyDB.Internal where

import Foreign.C.Error
import Foreign.C
import Foreign
import System.IO.Unsafe
import Data.Char

import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Internal as B

data DB
data DBT
data DBC
data ENV

type DBTYPE = Word32
{-# LINE 22 "src/Data/BerkeleyDB/Internal.hsc" #-}

data Flag
    = AutoCommit
    | Create
    | Excl
    | Multiversion
    | NoMMap
    | ReadOnly
    | ReadUncommitted
    | Thread
    | Truncate
    deriving (Read, Show, Enum, Eq, Ord)

data DbType
    = BTree
    | Hash
    | Recno
    | Queue
    | UnknownType

fromDbType BTree = 1
{-# LINE 43 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromDbType Hash = 2
{-# LINE 44 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromDbType Recno = 3
{-# LINE 45 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromDbType Queue = 4
{-# LINE 46 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromDbType UnknownType = 5
{-# LINE 47 "src/Data/BerkeleyDB/Internal.hsc" #-}

fromFlag AutoCommit = 256
{-# LINE 49 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromFlag Create = 1
{-# LINE 50 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromFlag Excl = 64
{-# LINE 51 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromFlag Multiversion = 4
{-# LINE 52 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromFlag _ = 0

fromFlags = foldr (.|.) 0 . map fromFlag

data SyncOption = Sync | NoSync

fromSyncOption Sync = 0
fromSyncOption NoSync = 21
{-# LINE 60 "src/Data/BerkeleyDB/Internal.hsc" #-}

data PutFlag
    = Append
    | NoDupData
    | NoOverwrite
    deriving (Read, Show, Enum, Eq, Ord)

fromPutFlag Append = 2
{-# LINE 68 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromPutFlag NoDupData = 19
{-# LINE 69 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromPutFlag NoOverwrite = 20
{-# LINE 70 "src/Data/BerkeleyDB/Internal.hsc" #-}

fromPutFlags = foldr (.|.) 0 . map fromPutFlag

data DbFlag
    = Consume
    | ConsumeWait
    | Multiple
    | Duplicates
    | SortDuplicates
    | Next

fromDbFlag Consume = 4
{-# LINE 82 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromDbFlag ConsumeWait = 5
{-# LINE 83 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromDbFlag Multiple = 2048
{-# LINE 84 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromDbFlag Duplicates = 16
{-# LINE 85 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromDbFlag SortDuplicates = 4
{-# LINE 86 "src/Data/BerkeleyDB/Internal.hsc" #-}
fromDbFlag Next = 16
{-# LINE 87 "src/Data/BerkeleyDB/Internal.hsc" #-}

fromDbFlags = foldr (.|.) 0 . map fromDbFlag

type Object = B.ByteString



--int db_env_create(DB_ENV **dbenvp, u_int32_t flags);
foreign import ccall unsafe db_env_create
  :: Ptr (Ptr ENV) -> CUInt -> IO CInt

createEnv :: IO (Ptr ENV)
createEnv = alloca $ \tmp ->
            do throwErrnoIf (/=0) "db_env_create" $ db_env_create tmp 0
               peek tmp

--int DB_ENV->open(DB_ENV *dbenv, char *db_home, u_int32_t flags, int mode);
foreign import ccall unsafe hs_env_open
  :: Ptr ENV -> CString -> CUInt -> CInt -> IO CInt




--int db_create(DB **dbp, DB_ENV *dbenv, u_int32_t flags);
foreign import ccall unsafe "db_create" c_create ::
  Ptr (Ptr DB) -> Ptr ENV -> Word32 -> IO CInt

create :: IO (Ptr DB)
create = alloca $ \tmp ->
         do --env <- createEnv
--            let flags = #{const DB_INIT_CDB} .|. #{const DB_INIT_MPOOL} .|. #{const DB_CREATE} .|. #{const DB_PRIVATE} .|. #{const DB_THREAD}
--            throwErrnoIf (/=0) "env_open" $ hs_env_open env nullPtr flags 0
            throwErrnoIf (/=0) "create" $ c_create tmp nullPtr 0
            peek tmp


-- int DB->open(DB *db, DB_TXN *txnid, const char *file,
--    const char *database, DBTYPE type, u_int32_t flags, int mode);
foreign import ccall unsafe "hs_open" c_open ::
  Ptr DB -> Ptr () -> CString -> CString -> DBTYPE -> Word32 -> CInt -> IO CInt

open :: Maybe FilePath -> Maybe String -> DbType -> [Flag] -> IO (Ptr DB)
open mbFile mbDatabase dbType flags
    = do ptr <- create
         setFlags ptr [Duplicates]
         maybeWith withCString mbFile $ \cfile ->
           maybeWith withCString mbDatabase $ \cdatabase ->
             throwErrnoIf (/=0) "open" $
               c_open ptr nullPtr cfile cdatabase (fromDbType dbType) (fromFlags flags) 0
         return ptr




-- int DB->close(DB *db, u_int32_t flags);
foreign import ccall unsafe "hs_close" c_close :: Ptr DB -> Word32 -> IO CInt

close :: Ptr DB -> SyncOption -> IO ()
close db sync
    = do throwErrnoIf (/=0) "close" $ c_close db (fromSyncOption sync)
         return ()

foreign import ccall unsafe "&hs_gc_close" closePtr :: FunPtr (Ptr DB -> IO ())


foreign import ccall unsafe "hs_clear_dbt" clear_dbt :: Ptr DBT -> IO ()

withDBT :: Object -> (Ptr DBT -> IO a) -> IO a
withDBT object fn
    = allocaBytes (28) $ \dbt ->
{-# LINE 157 "src/Data/BerkeleyDB/Internal.hsc" #-}
      do clear_dbt dbt
         B.unsafeUseAsCStringLen object $ \(ptr,len) ->
           do (\hsc_ptr -> pokeByteOff hsc_ptr 0) dbt ptr
{-# LINE 160 "src/Data/BerkeleyDB/Internal.hsc" #-}
              (\hsc_ptr -> pokeByteOff hsc_ptr 4) dbt (fromIntegral len :: CInt)
{-# LINE 161 "src/Data/BerkeleyDB/Internal.hsc" #-}
              fn dbt


-- int DB->put(DB *db, DB_TXN *txnid, DBT *key, DBT *data, u_int32_t flags);
foreign import ccall unsafe "hs_put" c_put ::
  Ptr DB -> Ptr () -> Ptr DBT -> Ptr DBT -> Word32 -> IO CInt

put :: Ptr DB -> Object -> Object -> [PutFlag] -> IO ()
put db key value flags
    = withDBT key $ \dbtKey ->
      withDBT value $ \dbtValue ->
      do throwErrnoIf (/=0) "put" $
           c_put db nullPtr dbtKey dbtValue (fromPutFlags flags)
         return ()


-- int DB->get(DB *db, DB_TXN *txnid, DBT *key, DBT *data, u_int32_t flags);
foreign import ccall unsafe "hs_get" c_get ::
  Ptr DB -> Ptr () -> Ptr DBT -> Ptr DBT -> Word32 -> IO CInt

get :: Ptr DB -> Object -> [DbFlag] -> IO (Maybe Object)
get db object flags
    = withDBT object $ \keyDbt ->
      withDBT nullObject $ \dataDbt ->
      do (\hsc_ptr -> pokeByteOff hsc_ptr 24) keyDbt (16 :: Word32)
{-# LINE 186 "src/Data/BerkeleyDB/Internal.hsc" #-}
         ret <- c_get db nullPtr keyDbt dataDbt (fromDbFlags flags)
         case ret of
             -30988 -> return Nothing
{-# LINE 189 "src/Data/BerkeleyDB/Internal.hsc" #-}
             0 -> do ptr <- (\hsc_ptr -> peekByteOff hsc_ptr 0) dataDbt
{-# LINE 190 "src/Data/BerkeleyDB/Internal.hsc" #-}
                     size <- (\hsc_ptr -> peekByteOff hsc_ptr 4) dataDbt :: IO CInt
{-# LINE 191 "src/Data/BerkeleyDB/Internal.hsc" #-}
                     bs <- B.unsafePackCStringFinalizer ptr (fromIntegral size) (free ptr)
                     return $ Just bs
             _ -> throwErrno "get"
{-
foreign import ccall unsafe hs_multiple_init
  :: Ptr (Ptr a) -> Ptr DBT -> IO ()

foreign import ccall unsafe hs_multiple_next
  :: Ptr (Ptr a) -> Ptr DBT -> Ptr (Ptr b) -> Ptr #{type size_t} -> IO ()
-}
getMany :: Ptr DB -> Object -> [DbFlag] -> IO [Object]
getMany db object flags
    = withDBT object $ \keyDbt ->
      withDBT nullObject $ \dataDbt ->
      dbtGetMany dataDbt (c_get db nullPtr keyDbt dataDbt (fromDbFlags (Multiple:flags)))

dbtGetMany dataDbt fn
    = let loop size =
           do ptr <- mallocBytes size
              (\hsc_ptr -> pokeByteOff hsc_ptr 0) dataDbt ptr
{-# LINE 211 "src/Data/BerkeleyDB/Internal.hsc" #-}
              (\hsc_ptr -> pokeByteOff hsc_ptr 24) dataDbt (1024 :: Word32)
{-# LINE 212 "src/Data/BerkeleyDB/Internal.hsc" #-}
              (\hsc_ptr -> pokeByteOff hsc_ptr 8) dataDbt (fromIntegral size :: Word32)
{-# LINE 213 "src/Data/BerkeleyDB/Internal.hsc" #-}
              ret <- fn
              case ret of
                -30988 -> free ptr >> return []
{-# LINE 216 "src/Data/BerkeleyDB/Internal.hsc" #-}
                -30999 -> free ptr >> loop (size*2)
{-# LINE 217 "src/Data/BerkeleyDB/Internal.hsc" #-}
                0 -> do ulen <- fmap fromIntegral ((\hsc_ptr -> peekByteOff hsc_ptr 8) dataDbt :: IO Word32)
{-# LINE 218 "src/Data/BerkeleyDB/Internal.hsc" #-}
                        fptr <- newForeignPtr finalizerFree ptr
                        let intPtr = castPtr ptr
                        let walker n ls = do offset <- peekByteOff intPtr (ulen - (4) * (n+1)) :: IO Word32
{-# LINE 221 "src/Data/BerkeleyDB/Internal.hsc" #-}
                                             len <- peekByteOff intPtr (ulen - (4) * (n+2)) :: IO Word32
{-# LINE 222 "src/Data/BerkeleyDB/Internal.hsc" #-}
--                                             putStrLn $ "walker: " ++ show (ulen, offset, len, ptr)
                                             if offset == -1 || (offset == 0 && len == 0)
                                                then return ls
                                                else let bs = B.fromForeignPtr fptr (fromIntegral offset) (fromIntegral len)
                                                     in walker (n+2) (bs:ls)
                        walker 0 []
                _ -> throwErrno "getMany"
      in loop (1024*sizeOf (undefined :: Int))


--int hs_set_flags(DB *db, u_int32_t flags);
foreign import ccall unsafe hs_set_flags :: Ptr DB -> Word32 -> IO CInt

setFlags :: Ptr DB -> [DbFlag] -> IO ()
setFlags ptr flags
    = do throwErrnoIf (/=0) "setFlags" $ hs_set_flags ptr (fromDbFlags flags)
         return ()

--int hs_get_flags(DB *db, u_int32_t *flags);

foreign import ccall unsafe "hs_cursor"
  hs_cursor :: Ptr DB -> Ptr () -> Ptr (Ptr DBC) -> Word32 -> IO CInt

foreign import ccall unsafe "hs_cursor_get"
  hs_cursor_get :: Ptr DBC -> Ptr DBT -> Ptr DBT -> Word32 -> IO CInt

foreign import ccall unsafe "hs_cursor_close"
  hs_cursor_close :: Ptr DBC -> IO CInt

closeCursor :: Ptr DBC -> IO ()
closeCursor ptr = do throwErrnoIf (/=0) "hs_cursor_close" $ hs_cursor_close ptr
                     return ()

newCursor :: Ptr DB -> IO (Ptr DBC)
newCursor db
    = alloca $ \dbcPtr -> do throwErrnoIf (/=0) "hs_cursor" $ hs_cursor db nullPtr dbcPtr 0
                             peek dbcPtr

getAtCursor :: Ptr DBC -> [DbFlag] -> IO (Maybe (Object,[Object]))
getAtCursor dbc flags
    = withDBT nullObject $ \keyDbt ->
      withDBT nullObject $ \dataDbt ->
      do clear_dbt keyDbt
         (\hsc_ptr -> pokeByteOff hsc_ptr 24) keyDbt (16 :: Word32)
{-# LINE 266 "src/Data/BerkeleyDB/Internal.hsc" #-}
         objs <- dbtGetMany dataDbt $ hs_cursor_get dbc keyDbt dataDbt (fromDbFlags $ Multiple:flags)
         if null objs then return Nothing else do
         ptr <- (\hsc_ptr -> peekByteOff hsc_ptr 0) keyDbt
{-# LINE 269 "src/Data/BerkeleyDB/Internal.hsc" #-}
         size <- (\hsc_ptr -> peekByteOff hsc_ptr 4) keyDbt :: IO CInt
{-# LINE 270 "src/Data/BerkeleyDB/Internal.hsc" #-}
         keyObject <- B.unsafePackCStringFinalizer ptr (fromIntegral size) (free ptr)
         let pp = B.take 40 . Char8.filter isPrint
--         putStrLn $ "Key: " ++ show (pp keyObject) ++ ": " ++ show (map pp objs)
--         putStrLn $ "Key ptr: " ++ show ptr
--         putStrLn $ "  Objs: " ++ show (map (B.take 30 . Char8.filter isAlphaNum) objs)
         return (Just (keyObject,objs))

{-
getAllObjects :: Ptr DB -> IO [(Object,[Object])]
getAllObjects ptr
    = do dbc <- alloca $ \dbcPtr -> do throwErrnoIf (/=0) "hs_cursor" $ hs_cursor ptr nullPtr dbcPtr 0
                                       peek dbcPtr
         let flags = #{const DB_MULTIPLE} .|. #{const DB_NEXT}
         let loop = --unsafeInterleaveIO $
                    withDBT nullObject $ \keyDbt ->
                    withDBT nullObject $ \dataDbt ->
                    do clear_dbt keyDbt
                       #{poke DBT, flags} keyDbt (#{const DB_DBT_MALLOC} :: Word32)
                       objs <- dbtGetMany dataDbt $ hs_cursor_get dbc keyDbt dataDbt flags
                       if null objs then return [] else do
                       ptr <- #{peek DBT, data} keyDbt
                       size <- #{peek DBT, size} keyDbt :: IO CInt
                       keyObject <- B.unsafePackCStringFinalizer ptr (fromIntegral size) (free ptr)
                       let pp = B.take 40 . Char8.filter isPrint
--                       putStrLn $ "Key: " ++ show (pp keyObject) ++ ": " ++ show (map pp objs)
--                       putStrLn $ "Key ptr: " ++ show ptr
--                       putStrLn $ "  Objs: " ++ show (map (B.take 30 . Char8.filter isAlphaNum) objs)
                       rest <- loop
                       return ((keyObject,objs):rest)
         loop
-}

nullObject = B.fromForeignPtr B.nullForeignPtr 0 0