module System.TrailDB
(
newTrailDBCons
, closeTrailDBCons
, withTrailDBCons
, addTrail
, appendTdbToTdbCons
, finalizeTrailDBCons
, ToTdbRow(..)
, ToTdbRowField(..)
, TdbConsRow(..)
, TdbShowable(..)
, pattern TShow
, openTrailDB
, closeTrailDB
, getTdbVersion
, dontneedTrailDB
, willneedTrailDB
, withTrailDB
, FromTrail(..)
, getTrail
, getTrailBytestring
, makeCursor
, stepCursor
, stepCursorList
, setCursor
, forEachTrailID
, forEachTrailIDUUID
, traverseEachTrailID
, traverseEachTrailIDUUID
, foldTrailDB
, foldTrailDBUUID
, getNumTrails
, getNumEvents
, getNumFields
, getMinTimestamp
, getMaxTimestamp
, getUUID
, getTrailID
, getFieldName
, getFieldID
, getItemByField
, getValue
, getItem
, utcTimeToUnixTime
, posixSecondsToUnixTime
, dayToUnixTime
, withRawTdb
, getRawTdb
, touchTdb
, withRawTdbCons
, getRawTdbCons
, touchTdbCons
, TdbRaw
, TdbConsRaw
, field
, value
, (^.)
, UUID
, TrailID
, FieldID
, Crumb
, Feature()
, TdbField
, TdbVal
, TdbVersion
, FieldName
, FieldNameLike(..)
, featureWord
, featureTdbVal
, Cursor()
, TdbCons()
, Tdb()
, UnixTime
, getUnixTime
, TrailDBException(..)
, findTrailDBs
, filterTrailDBDirectories )
where
import Control.Applicative
import Control.Concurrent
import Control.Lens hiding ( coerce )
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Primitive
import Control.Monad.Trans.State.Strict
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Lazy as BL
import Data.Coerce
import Data.Foldable ( for_, foldlM, Foldable )
import Data.Data
import Data.IORef
import qualified Data.Map.Strict as M
import Data.Monoid
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import Data.Time
import Data.Time.Clock.POSIX
import qualified Data.Vector as VS
import qualified Data.Vector.Generic as VG
import qualified Data.Vector.Generic.Mutable as VGM
import qualified Data.Vector.Unboxed as V
import qualified Data.Vector.Unboxed.Mutable as VM
import Data.Traversable ( for )
import Data.Word
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import GHC.Generics
import System.Directory hiding ( isSymbolicLink )
import System.IO.Error
import System.Posix.Files.ByteString
import System.TrailDB.Error
import System.TrailDB.Internal
type TdbField = Word32
type FieldID = TdbField
type TdbVal = Word64
type TdbItem = Word64
foreign import ccall unsafe tdb_error_str
:: CInt -> IO (Ptr CChar)
foreign import ccall unsafe tdb_cons_init
:: IO (Ptr TdbConsRaw)
foreign import ccall unsafe tdb_cons_open
:: Ptr TdbConsRaw
-> Ptr CChar
-> Ptr (Ptr CChar)
-> Word64
-> IO CInt
foreign import ccall unsafe tdb_cons_close
:: Ptr TdbConsRaw -> IO ()
foreign import ccall unsafe tdb_cons_add
:: Ptr TdbConsRaw
-> Ptr Word8
-> Word64
-> Ptr (Ptr CChar)
-> Ptr Word64
-> IO CInt
foreign import ccall safe tdb_cons_finalize
:: Ptr TdbConsRaw
-> Word64
-> IO CInt
foreign import ccall safe tdb_cons_append
:: Ptr TdbConsRaw
-> Ptr TdbRaw
-> IO CInt
foreign import ccall unsafe tdb_dontneed
:: Ptr TdbRaw
-> IO ()
foreign import ccall unsafe tdb_willneed
:: Ptr TdbRaw
-> IO ()
foreign import ccall unsafe tdb_init
:: IO (Ptr TdbRaw)
foreign import ccall safe tdb_open
:: Ptr TdbRaw
-> Ptr CChar
-> IO CInt
foreign import ccall safe tdb_close
:: Ptr TdbRaw
-> IO ()
foreign import ccall unsafe tdb_get_trail_id
:: Ptr TdbRaw
-> Ptr Word8
-> Ptr Word64
-> IO CInt
foreign import ccall unsafe tdb_get_uuid
:: Ptr TdbRaw
-> Word64
-> IO (Ptr Word8)
foreign import ccall unsafe tdb_num_trails
:: Ptr TdbRaw -> IO Word64
foreign import ccall unsafe tdb_num_events
:: Ptr TdbRaw -> IO Word64
foreign import ccall unsafe tdb_num_fields
:: Ptr TdbRaw -> IO Word64
foreign import ccall unsafe tdb_min_timestamp
:: Ptr TdbRaw -> IO Word64
foreign import ccall unsafe tdb_max_timestamp
:: Ptr TdbRaw -> IO Word64
foreign import ccall unsafe tdb_version
:: Ptr TdbRaw -> IO Word64
foreign import ccall unsafe tdb_get_field
:: Ptr TdbRaw
-> Ptr CChar
-> Ptr TdbField
-> IO CInt
foreign import ccall unsafe tdb_get_field_name
:: Ptr TdbRaw
-> TdbField
-> IO (Ptr CChar)
foreign import ccall unsafe tdb_get_item_value
:: Ptr TdbRaw
-> TdbItem
-> Ptr Word64
-> IO (Ptr CChar)
foreign import ccall unsafe tdb_get_item
:: Ptr TdbRaw
-> TdbField
-> Ptr CChar
-> Word64
-> IO TdbItem
foreign import ccall unsafe tdb_get_trail
:: Ptr TdbCursorRaw
-> Word64
-> IO CInt
foreign import ccall unsafe tdb_cursor_new
:: Ptr TdbRaw
-> IO (Ptr TdbCursorRaw)
foreign import ccall unsafe tdb_cursor_free
:: Ptr TdbCursorRaw
-> IO ()
foreign import ccall unsafe shim_tdb_cursor_next
:: Ptr TdbCursorRaw
-> IO (Ptr TdbEventRaw)
foreign import ccall unsafe shim_tdb_item_to_field
:: Word64
-> Word32
foreign import ccall unsafe shim_tdb_item_to_val
:: Word64
-> Word64
foreign import ccall unsafe shim_tdb_field_val_to_item
:: Word32
-> Word64
-> Word64
data TdbCursorRaw
data TdbEventRaw
type UUID = B.ByteString
type FieldName = B.ByteString
type UnixTime = Word64
type TrailID = Word64
type TdbVersion = Word64
type Crumb = (UnixTime, V.Vector Feature)
newtype Feature = Feature TdbItem
deriving ( Eq, Ord, Show, Read, Typeable, Data, Generic, Storable )
featureWord :: Iso' Feature Word64
featureWord = iso (\(Feature w) -> w) (\w -> Feature w)
featureTdbVal :: Iso' Feature TdbVal
featureTdbVal = featureWord
newtype instance V.Vector Feature = V_Feature (V.Vector Word64)
newtype instance VM.MVector s Feature = VM_Feature (VM.MVector s Word64)
instance VGM.MVector VM.MVector Feature where
basicLength (VM_Feature w64) = VGM.basicLength w64
basicUnsafeSlice a b (VM_Feature w64) = coerce $
VGM.basicUnsafeSlice a b w64
basicOverlaps (VM_Feature w1) (VM_Feature w2) = VGM.basicOverlaps w1 w2
basicUnsafeNew sz = do
result <- VGM.basicUnsafeNew sz
return $ VM_Feature result
basicUnsafeRead (VM_Feature w64) i = do
result <- VGM.basicUnsafeRead w64 i
return $ coerce result
basicUnsafeWrite (VM_Feature w64) i v =
VGM.basicUnsafeWrite w64 i (coerce v)
instance VG.Vector V.Vector Feature where
basicLength (V_Feature w64) = VG.basicLength w64
basicUnsafeFreeze (VM_Feature w64) = do
result <- VG.basicUnsafeFreeze w64
return $ coerce (result :: V.Vector Word64)
basicUnsafeThaw (V_Feature w64) = do
result <- VG.basicUnsafeThaw w64
return $ coerce result
basicUnsafeIndexM (V_Feature w64) idx = do
result <- VG.basicUnsafeIndexM w64 idx
return $ coerce result
basicUnsafeSlice i1 i2 (V_Feature w64) =
coerce $ VG.basicUnsafeSlice i1 i2 w64
instance V.Unbox Feature
getUnixTime :: MonadIO m => m UnixTime
getUnixTime = liftIO $ do
now <- getPOSIXTime
let t = floor now
return t
utcTimeToUnixTime :: UTCTime -> UnixTime
utcTimeToUnixTime utc = floor $ utcTimeToPOSIXSeconds utc
posixSecondsToUnixTime :: POSIXTime -> UnixTime
posixSecondsToUnixTime = floor
dayToUnixTime :: Day -> UnixTime
dayToUnixTime day = utcTimeToUnixTime (UTCTime day 0)
field :: Lens' Feature FieldID
field = lens get_it set_it
where
get_it (Feature f) = shim_tdb_item_to_field f
set_it original new = Feature $ shim_tdb_field_val_to_item new (original^.value)
value :: Lens' Feature TdbVal
value = lens get_it set_it
where
get_it (Feature f) = shim_tdb_item_to_val f
set_it original new = Feature $ shim_tdb_field_val_to_item (original^.field) new
class FieldNameLike a where
encodeToFieldName :: a -> B.ByteString
instance FieldNameLike String where
encodeToFieldName = T.encodeUtf8 . T.pack
instance FieldNameLike B.ByteString where
encodeToFieldName = id
instance FieldNameLike BL.ByteString where
encodeToFieldName = BL.toStrict
instance FieldNameLike T.Text where
encodeToFieldName = T.encodeUtf8
instance FieldNameLike TL.Text where
encodeToFieldName = T.encodeUtf8 . TL.toStrict
newtype TdbCons = TdbCons (MVar (Maybe (Ptr TdbConsRaw)))
deriving ( Typeable, Generic )
tdbThrowIfError :: MonadIO m => m CInt -> m ()
tdbThrowIfError action = do
result <- action
if result == 0
then return ()
else liftIO $ do err_string <- peekCString =<< tdb_error_str result
throwM $ TrailDBError result err_string
newTrailDBCons :: (FieldNameLike a, MonadIO m)
=> FilePath
-> [a]
-> m TdbCons
newTrailDBCons filepath fields' = liftIO $ mask_ $
withCString filepath $ \root ->
withBytestrings fields $ \fields_ptr -> do
tdb_cons <- tdb_cons_init
when (tdb_cons == nullPtr) $
throwM CannotAllocateTrailDBCons
flip onException (tdb_cons_close tdb_cons) $ do
tdbThrowIfError $ tdb_cons_open
tdb_cons
root
fields_ptr
(fromIntegral $ length fields)
mvar <- newMVar (Just tdb_cons)
void $ mkWeakMVar mvar $ modifyMVar_ mvar $ \case
Nothing -> return Nothing
Just ptr -> do
void $ tdb_cons_finalize ptr 0
tdb_cons_close ptr
return Nothing
return $ TdbCons mvar
where
fields = fmap encodeToFieldName fields'
withTrailDBCons :: (FieldNameLike a, MonadIO m, MonadMask m)
=> FilePath
-> [a]
-> (TdbCons -> m b)
-> m b
withTrailDBCons filepath fields action = mask $ \restore -> do
cons <- newTrailDBCons filepath fields
finally (restore $ action cons) (closeTrailDBCons cons)
withBytestrings :: forall a. [B.ByteString] -> (Ptr (Ptr CChar) -> IO a) -> IO a
withBytestrings [] action = action nullPtr
withBytestrings listing action =
allocaArray (length listing) $ \bs_ptr -> loop_it bs_ptr listing 0
where
loop_it :: Ptr (Ptr CChar) -> [B.ByteString] -> Int -> IO a
loop_it bs_ptr (bs:rest) idx = do
B.useAsCString bs $ \string_ptr -> do
pokeElemOff bs_ptr idx string_ptr
loop_it bs_ptr rest (idx+1)
loop_it bs_ptr [] _ = action bs_ptr
class ToTdbRow r where
toTdbRow :: r -> [B.ByteString]
class ToTdbRowField f where
toTdbField :: f -> B.ByteString
instance (ToTdbRowField f1, ToTdbRowField f2) => ToTdbRow (f1, f2) where
toTdbRow (f1, f2) = toTdbRow [toTdbField f1, toTdbField f2]
instance (ToTdbRowField f1, ToTdbRowField f2, ToTdbRowField f3) => ToTdbRow (f1, f2, f3) where
toTdbRow (f1, f2, f3) = toTdbRow [toTdbField f1, toTdbField f2, toTdbField f3]
instance (ToTdbRowField f1, ToTdbRowField f2, ToTdbRowField f3, ToTdbRowField f4) => ToTdbRow (f1, f2, f3, f4) where
toTdbRow (f1, f2, f3, f4) = toTdbRow [toTdbField f1, toTdbField f2, toTdbField f3, toTdbField f4]
instance (ToTdbRowField f1, ToTdbRowField f2, ToTdbRowField f3, ToTdbRowField f4, ToTdbRowField f5) => ToTdbRow (f1, f2, f3, f4, f5) where
toTdbRow (f1, f2, f3, f4, f5) = toTdbRow [toTdbField f1, toTdbField f2, toTdbField f3, toTdbField f4, toTdbField f5]
instance ToTdbRowField B.ByteString where
toTdbField = id
instance ToTdbRowField BL.ByteString where
toTdbField = BL.toStrict
instance ToTdbRowField String where
toTdbField = T.encodeUtf8 . T.pack
instance ToTdbRowField T.Text where
toTdbField = T.encodeUtf8
instance ToTdbRowField TL.Text where
toTdbField = T.encodeUtf8 . TL.toStrict
instance ToTdbRowField f => ToTdbRow [f] where
toTdbRow = fmap toTdbField
data TdbConsRow a b = (:.) a b
infixr 7 :.
instance (ToTdbRowField a, ToTdbRow b)
=> ToTdbRow (TdbConsRow a b) where
toTdbRow (a :. b) = toTdbField a:toTdbRow b
newtype TdbShowable a = TdbShowable a
deriving ( Functor, Foldable, Traversable, Typeable, Generic, Eq, Ord, Show, Read )
pattern TShow a = TdbShowable a
instance Show a => ToTdbRowField (TdbShowable a) where
toTdbField (TdbShowable thing) = toTdbField $ show thing
addTrail :: (MonadIO m, ToTdbRow r)
=> TdbCons
-> UUID
-> UnixTime
-> r
-> m ()
addTrail _ cookie _ _ | B.length cookie /= 16 =
error "addTrail: cookie must be 16 bytes in length."
addTrail (TdbCons mvar) cookie epoch (toTdbRow -> values) = liftIO $ withMVar mvar $ \case
Nothing -> error "addTrail: tdb_cons is closed."
Just ptr ->
B.unsafeUseAsCString cookie $ \cookie_ptr ->
withBytestrings values $ \values_ptr -> do
withArray (fmap (fromIntegral . B.length) values) $ \values_length_ptr ->
tdbThrowIfError $ tdb_cons_add
ptr
(castPtr cookie_ptr)
epoch
values_ptr
values_length_ptr
finalizeTrailDBCons :: MonadIO m => TdbCons -> m ()
finalizeTrailDBCons (TdbCons mvar) = liftIO $ withMVar mvar $ \case
Nothing -> error "finalizeTrailDBCons: tdb_cons is closed."
Just ptr -> do
result <- tdb_cons_finalize ptr 0
unless (result == 0) $ throwM FinalizationFailure
closeTrailDBCons :: MonadIO m => TdbCons -> m ()
closeTrailDBCons (TdbCons mvar) = liftIO $ mask_ $ modifyMVar_ mvar $ \case
Nothing -> return Nothing
Just ptr -> do
result <- tdb_cons_finalize ptr 0
unless (result == 0) $ throwM FinalizationFailure
tdb_cons_close ptr >> return Nothing
appendTdbToTdbCons :: MonadIO m
=> Tdb
-> TdbCons
-> m ()
appendTdbToTdbCons (Tdb mvar_tdb) (TdbCons mvar_tdb_cons) = liftIO $
withMVar mvar_tdb_cons $ \case
Nothing -> error "appendTdbToTdbCons: tdb_cons is closed."
Just tdb_cons_ptr -> withCVar mvar_tdb $ \case
Nothing -> error "appendTdbToTdbCons: tdb is closed."
Just (tdbPtr -> tdb_ptr) -> do
result <- tdb_cons_append tdb_cons_ptr tdb_ptr
unless (result == 0) $
error "appendTdbToTdbCons: tdb_cons_append() failed."
openTrailDB :: MonadIO m
=> FilePath
-> m Tdb
openTrailDB root = liftIO $ mask_ $
withCString root $ \root_str -> do
tdb <- tdb_init
flip onException (when (tdb /= nullPtr) $ tdb_close tdb) $ do
when (tdb == nullPtr) $ throwM CannotAllocateTrailDB
tdbThrowIfError $ tdb_open tdb root_str
buf <- mallocForeignPtrArray 1
mvar <- newCVar (Just TdbState {
tdbPtr = tdb
, decodeBuffer = buf
, decodeBufferSize = 1
})
void $ mkWeakCVar mvar $ modifyCVar_ mvar $ \case
Nothing -> return Nothing
Just (tdbPtr -> ptr) -> tdb_close ptr >> return Nothing
return $ Tdb mvar
dontneedTrailDB :: MonadIO m
=> Tdb
-> m ()
dontneedTrailDB tdb = withTdb tdb "dontneedTrailDB" tdb_dontneed
willneedTrailDB :: MonadIO m
=> Tdb
-> m ()
willneedTrailDB tdb = withTdb tdb "willneedTrailDB" tdb_willneed
closeTrailDB :: MonadIO m
=> Tdb
-> m ()
closeTrailDB (Tdb mvar) = liftIO $ mask_ $ modifyCVar_ mvar $ \case
Nothing -> return Nothing
Just (tdbPtr -> ptr) -> tdb_close ptr >> return Nothing
data Cursor = Cursor !(Ptr TdbCursorRaw) !(IORef ()) !(MVar (Maybe TdbState))
deriving ( Eq, Typeable, Generic )
makeCursor :: MonadIO m
=> Tdb
-> m Cursor
makeCursor (Tdb mvar) = liftIO $ withCVar mvar $ \case
Nothing -> error "makeCursor: tdb is closed."
Just (tdbPtr -> tdb_ptr) -> mask_ $ do
cursor <- tdb_cursor_new tdb_ptr
cursor_fin <- newIORef ()
void $ mkWeakIORef cursor_fin $ tdb_cursor_free cursor
return $ Cursor cursor cursor_fin mvar
class FromTrail a where
fromBytestringList :: [(UnixTime, [(B.ByteString, B.ByteString)])] -> a
instance FromTrail [(UnixTime, [(B.ByteString, B.ByteString)])] where
fromBytestringList = id
instance FromTrail [M.Map B.ByteString B.ByteString] where
fromBytestringList = fmap (M.fromList . snd)
instance FromTrail [[B.ByteString]] where
fromBytestringList = fmap (fmap snd . snd)
instance FromTrail (VS.Vector (M.Map B.ByteString B.ByteString)) where
fromBytestringList = VS.fromList . fmap (M.fromList . snd)
instance FromTrail (S.Set B.ByteString) where
fromBytestringList = S.fromList . concat . fmap (fmap snd . snd)
forEachTrailID :: (Applicative m, MonadIO m) => Tdb -> (TrailID -> m ()) -> m ()
forEachTrailID tdb action = do
num_trails <- getNumTrails tdb
for_ [0..num_trails1] $ \tid -> action tid
forEachTrailIDUUID :: (Applicative m, MonadIO m) => Tdb -> (TrailID -> UUID -> m ()) -> m ()
forEachTrailIDUUID tdb action = do
num_trails <- getNumTrails tdb
for_ [0..num_trails1] $ \tid -> do
uuid <- getUUID tdb tid
action tid uuid
traverseEachTrailID :: (Applicative m, MonadIO m) => (TrailID -> m ()) -> Tdb -> m ()
traverseEachTrailID action tdb = forEachTrailID tdb action
traverseEachTrailIDUUID :: (Applicative m, MonadIO m) => (TrailID -> UUID -> m ()) -> Tdb -> m ()
traverseEachTrailIDUUID action tdb = forEachTrailIDUUID tdb action
foldTrailDB :: MonadIO m => (a -> TrailID -> m a) -> a -> Tdb -> m a
foldTrailDB action initial tdb = do
num_trails <- getNumTrails tdb
foldlM action initial [0..num_trails1]
foldTrailDBUUID :: MonadIO m => (a -> TrailID -> UUID -> m a) -> a -> Tdb -> m a
foldTrailDBUUID action initial tdb = do
num_trails <- getNumTrails tdb
foldlM (\accum tid -> do
uuid <- getUUID tdb tid
action accum tid uuid)
initial [0..num_trails1]
getTrail :: (FromTrail a, MonadIO m)
=> Tdb
-> TrailID
-> m a
getTrail tdb tid = liftIO $ do
cursor <- makeCursor tdb
setCursor cursor tid
fromBytestringList <$> exhaustCursor cursor
where
exhaustCursor :: Cursor -> IO [(UnixTime, [(B.ByteString, B.ByteString)])]
exhaustCursor cursor = do
stepCursor cursor >>= \case
Nothing -> return []
Just (unixtime, V.toList -> features) -> do
let field_ids = features <&> (^.field)
fieldnames <- for field_ids $ getFieldName tdb
valuenames <- for features $ getValue tdb
fmap ((unixtime, zip fieldnames valuenames):) $ exhaustCursor cursor
getTrailBytestring :: MonadIO m => Tdb -> TrailID -> m [(UnixTime, [(B.ByteString, B.ByteString)])]
getTrailBytestring = getTrail
stepCursor :: MonadIO m
=> Cursor
-> m (Maybe Crumb)
stepCursor (Cursor cursor mvar finalizer) = liftIO $ do
event_ptr <- shim_tdb_cursor_next cursor
if event_ptr /= nullPtr
then do let word64_ptr = castPtr event_ptr :: Ptr Word64
timestamp <- peekElemOff word64_ptr 0
num_items <- peekElemOff word64_ptr 1
let items = plusPtr word64_ptr (2*sizeOf (undefined :: Word64))
vec <- V.generateM (fromIntegral num_items) $ peekElemOff items
touch mvar
touch finalizer
return $ Just (timestamp, vec)
else return Nothing
stepCursorList :: MonadIO m
=> Cursor
-> m [Crumb]
stepCursorList cursor = liftIO $ step_loop
where
step_loop = stepCursor cursor >>= \case
Just item -> (item:) <$> step_loop
_ -> return []
setCursor :: MonadIO m
=> Cursor
-> TrailID
-> m ()
setCursor (Cursor cursor mvar finalizer) trail_id = liftIO $ do
tdbThrowIfError $ tdb_get_trail cursor trail_id
touch mvar
touch finalizer
withTdb :: MonadIO m => Tdb -> String -> (Ptr TdbRaw -> IO a) -> m a
withTdb (Tdb mvar) errstring action = liftIO $ withCVar mvar $ \case
Nothing -> error $ errstring <> ": tdb is closed."
Just (tdbPtr -> ptr) -> action ptr
getUUID :: MonadIO m => Tdb -> TrailID -> m UUID
getUUID tdb cid = withTdb tdb "getUUID" $ \ptr -> do
cptr <- tdb_get_uuid ptr cid
when (cptr == nullPtr) $
throwM NoSuchTrailID
B.packCStringLen (castPtr cptr, 16)
getTrailID :: MonadIO m => Tdb -> UUID -> m TrailID
getTrailID _ cookie | B.length cookie /= 16 = error "getTrailID: cookie must be 16 bytes in length."
getTrailID tdb cookie = withTdb tdb "getTrailID" $ \ptr ->
B.unsafeUseAsCString cookie $ \cookie_str ->
alloca $ \result_ptr -> do
result <- tdb_get_trail_id ptr (castPtr cookie_str) result_ptr
if result == 0
then peek result_ptr
else throwM NoSuchUUID
getNumTrails :: MonadIO m => Tdb -> m Word64
getNumTrails tdb = withTdb tdb "getNumTrails" tdb_num_trails
getNumEvents :: MonadIO m => Tdb -> m Word64
getNumEvents tdb = withTdb tdb "getNumEvents" tdb_num_events
getNumFields :: MonadIO m => Tdb -> m Word64
getNumFields tdb = withTdb tdb "getNumFields" tdb_num_fields
getMinTimestamp :: MonadIO m => Tdb -> m UnixTime
getMinTimestamp tdb = withTdb tdb "getMinTimestamp" tdb_min_timestamp
getMaxTimestamp :: MonadIO m => Tdb -> m UnixTime
getMaxTimestamp tdb = withTdb tdb "getMaxTimestamp" tdb_max_timestamp
getFieldName :: MonadIO m => Tdb -> FieldID -> m FieldName
getFieldName tdb fid = withTdb tdb "getFieldName" $ \ptr -> do
result <- tdb_get_field_name ptr fid
when (result == nullPtr) $ throwM NoSuchFieldID
B.packCString result
getFieldID :: (FieldNameLike a, MonadIO m) => Tdb -> a -> m FieldID
getFieldID tdb (encodeToFieldName -> field_name) = withTdb tdb "getFieldID" $ \ptr ->
B.useAsCString field_name $ \field_name_cstr -> do
alloca $ \field_ptr -> do
tdbThrowIfError $ tdb_get_field ptr field_name_cstr field_ptr
result <- peek field_ptr
return $ fromIntegral $ result1
getValue :: MonadIO m => Tdb -> Feature -> m B.ByteString
getValue tdb (Feature ft) = withTdb tdb "getValue" $ \ptr -> do
alloca $ \len_ptr -> do
cstr <- tdb_get_item_value ptr ft len_ptr
when (cstr == nullPtr) $ throwM NoSuchValue
len <- peek len_ptr
B.packCStringLen (cstr, fromIntegral len)
getItem :: MonadIO m => Tdb -> FieldID -> B.ByteString -> m Feature
getItem tdb fid bs = withTdb tdb "getItem" $ \ptr -> do
B.unsafeUseAsCStringLen bs $ \(cstr, len) -> do
ft <- tdb_get_item ptr (fid+1) cstr (fromIntegral len)
if ft == 0
then throwM NoSuchFeature
else return $ Feature ft
getItemByField :: (FieldNameLike a, MonadIO m) => Tdb -> a -> B.ByteString -> m Feature
getItemByField tdb (encodeToFieldName -> fid) bs = liftIO $ do
fid <- getFieldID tdb fid
getItem tdb fid bs
getRawTdb :: MonadIO m => Tdb -> m (Ptr TdbRaw)
getRawTdb (Tdb cvar) = liftIO $ withCVar cvar $ \case
Nothing -> error "getRawTdb: tdb is closed."
Just tdbstate -> return (tdbPtr tdbstate)
getRawTdbCons :: MonadIO m => TdbCons -> m (Ptr TdbConsRaw)
getRawTdbCons (TdbCons cvar) = liftIO $ withCVar cvar $ \case
Nothing -> error "getRawTdbCons: tdb_cons is closed."
Just raw_ptr -> return raw_ptr
touchTdbCons :: MonadIO m => TdbCons -> m ()
touchTdbCons (TdbCons cvar) = liftIO $ withCVar cvar $ \case
Nothing -> return ()
Just raw_ptr -> touch raw_ptr
withRawTdbCons :: MonadIO m => TdbCons -> (Ptr TdbConsRaw -> IO a) -> m a
withRawTdbCons tdb_cons action = do
ptr <- getRawTdbCons tdb_cons
liftIO $ finally (action ptr) (touch ptr)
touchTdb :: MonadIO m => Tdb -> m ()
touchTdb (Tdb cvar) = liftIO $ void $ withCVar cvar $ \case
Nothing -> return ()
Just tdbstate -> touch (tdbPtr tdbstate)
withRawTdb :: MonadIO m => Tdb -> (Ptr TdbRaw -> IO a) -> m a
withRawTdb tdb action = do
ptr <- getRawTdb tdb
liftIO $ finally (action ptr) (touchTdb tdb)
withTrailDB :: (MonadIO m, MonadMask m) => FilePath -> (Tdb -> m a) -> m a
withTrailDB fpath action = mask $ \restore -> do
tdb <- openTrailDB fpath
finally (restore $ action tdb) (closeTrailDB tdb)
findTrailDBs :: forall m. (MonadIO m, MonadMask m)
=> FilePath
-> Bool
-> m [FilePath]
findTrailDBs filepath follow_symbolic_links = do
contents <- liftIO $ getDirectoryContents filepath
dirs <- execStateT (filterChildDirectories filepath contents) [filepath]
filterTrailDBDirectories dirs
where
filterChildDirectories :: FilePath -> [FilePath] -> StateT [FilePath] m ()
filterChildDirectories prefix (".":rest) = filterChildDirectories prefix rest
filterChildDirectories prefix ("..":rest) = filterChildDirectories prefix rest
filterChildDirectories prefix (dir_raw:rest) = do
let dir = prefix <> "/" <> dir_raw
is_dir <- liftIO $ doesDirectoryExist dir
is_symbolic_link_maybe <- liftIO $ tryIOError $ getFileStatus (T.encodeUtf8 $ T.pack dir)
case is_symbolic_link_maybe of
Left exc | isDoesNotExistError exc -> filterChildDirectories prefix rest
Left exc -> throwM exc
Right is_symbolic_link ->
if is_dir
then (if (isSymbolicLink is_symbolic_link && follow_symbolic_links) ||
(not $ isSymbolicLink is_symbolic_link)
then modify (dir:) >> recurse dir >> filterChildDirectories prefix rest
else filterChildDirectories prefix rest)
else filterChildDirectories prefix rest
filterChildDirectories _ [] = return ()
recurse dir = do
contents <- liftIO $ getDirectoryContents dir
filterChildDirectories dir contents
filterTrailDBDirectories :: (MonadIO m, MonadMask m) => [FilePath] -> m [FilePath]
filterTrailDBDirectories = filterM $ \dir -> do
result <- try $ openTrailDB dir
case result of
Left CannotAllocateTrailDB -> return False
Left exc -> throwM exc
Right ok -> closeTrailDB ok >> return True
getTdbVersion :: MonadIO m => Tdb -> m TdbVersion
getTdbVersion tdb = withTdb tdb "getTdbVersion" tdb_version