2019-05-30 02:19:07 +03:00
|
|
|
-- TODO: Make sure transaction closed in all error cases
|
2019-05-30 23:19:26 +03:00
|
|
|
-- TODO: Don't allow writing non-contiguous events
|
|
|
|
module Vere.Log (
|
|
|
|
init,
|
|
|
|
shutdown,
|
|
|
|
-- we don't export write; you use the queue
|
|
|
|
readEvents,
|
|
|
|
latestEventNumber,
|
|
|
|
readLogIdentity,
|
|
|
|
writeLogIdentity
|
|
|
|
) where
|
|
|
|
|
|
|
|
import ClassyPrelude hiding (init)
|
2019-05-31 05:53:00 +03:00
|
|
|
import Control.Lens hiding ((<|))
|
|
|
|
|
2019-05-30 02:19:07 +03:00
|
|
|
import Data.Noun
|
|
|
|
import Data.Noun.Atom
|
|
|
|
import Data.Noun.Jam
|
|
|
|
import Data.Noun.Pill
|
2019-05-29 03:16:30 +03:00
|
|
|
import Data.Void
|
2019-05-30 02:19:07 +03:00
|
|
|
import Database.LMDB.Raw
|
|
|
|
import Foreign.Ptr
|
|
|
|
import Foreign.Marshal.Alloc
|
2019-05-30 23:19:26 +03:00
|
|
|
import Vere.Pier.Types
|
2019-05-30 02:19:07 +03:00
|
|
|
|
2019-05-31 05:53:00 +03:00
|
|
|
import Control.Lens ((^.))
|
2019-05-30 02:19:07 +03:00
|
|
|
import Foreign.Storable (peek, poke, sizeOf)
|
|
|
|
|
|
|
|
import qualified Data.ByteString.Unsafe as BU
|
2019-05-31 05:53:00 +03:00
|
|
|
import qualified Data.ByteString as B
|
|
|
|
import qualified Data.Vector as V
|
|
|
|
import qualified Data.Vector.Mutable as MV
|
2019-05-29 03:32:39 +03:00
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
2019-05-29 03:16:30 +03:00
|
|
|
|
2019-05-30 23:19:26 +03:00
|
|
|
-- TODO: Handle throws on the async
|
|
|
|
init :: FilePath -> TQueue (Writ [Effect]) -> (Writ [Effect] -> STM ())
|
|
|
|
-> IO LogState
|
|
|
|
init dir inp cb = do
|
2019-05-29 03:16:30 +03:00
|
|
|
env <- mdb_env_create
|
|
|
|
mdb_env_set_maxdbs env 3
|
|
|
|
mdb_env_set_mapsize env (40 * 1024 * 1024 * 1024)
|
|
|
|
mdb_env_open env dir []
|
2019-05-30 23:19:26 +03:00
|
|
|
writer <- persistThread env inp cb
|
|
|
|
pure (LogState env inp cb writer)
|
|
|
|
|
|
|
|
-- TODO: properly handle shutdowns during write
|
|
|
|
shutdown :: LogState -> IO ()
|
|
|
|
shutdown s = do
|
|
|
|
void $ waitCancel (writer s)
|
|
|
|
mdb_env_close (env s)
|
2019-05-29 03:16:30 +03:00
|
|
|
|
2019-05-30 23:19:26 +03:00
|
|
|
waitCancel :: Async a -> IO (Either SomeException a)
|
|
|
|
waitCancel async = cancel async >> waitCatch async
|
2019-05-29 03:16:30 +03:00
|
|
|
|
2019-05-29 03:32:39 +03:00
|
|
|
--------------------------------------------------------------------------------
|
2019-05-29 03:16:30 +03:00
|
|
|
|
2019-05-29 21:33:09 +03:00
|
|
|
{-
|
|
|
|
Read one or more items from a TQueue, only blocking on the first item.
|
|
|
|
-}
|
|
|
|
readQueue :: TQueue a -> STM (NonNull [a])
|
2019-05-29 03:32:39 +03:00
|
|
|
readQueue q =
|
|
|
|
readTQueue q >>= go . singleton
|
2019-05-29 03:16:30 +03:00
|
|
|
where
|
2019-05-29 21:33:09 +03:00
|
|
|
go acc =
|
|
|
|
tryReadTQueue q >>= \case
|
|
|
|
Nothing -> pure (reverse acc)
|
|
|
|
Just item -> go (item <| acc)
|
2019-05-29 03:32:39 +03:00
|
|
|
|
|
|
|
byteStringAsMdbVal :: ByteString -> (MDB_val -> IO a) -> IO a
|
|
|
|
byteStringAsMdbVal bs k =
|
2019-05-30 02:19:07 +03:00
|
|
|
BU.unsafeUseAsCStringLen bs \(ptr,sz) ->
|
2019-05-29 03:32:39 +03:00
|
|
|
k (MDB_val (fromIntegral sz) (castPtr ptr))
|
|
|
|
|
2019-05-30 02:19:07 +03:00
|
|
|
mdbValToAtom :: MDB_val -> IO Atom
|
|
|
|
mdbValToAtom (MDB_val sz ptr) = do
|
2019-05-31 05:53:00 +03:00
|
|
|
bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz)
|
|
|
|
pure (bs ^. from (pill . pillBS))
|
|
|
|
|
|
|
|
maybeErr :: Maybe a -> String -> IO a
|
|
|
|
maybeErr (Just x) _ = pure x
|
|
|
|
maybeErr Nothing msg = error msg
|
2019-05-30 02:19:07 +03:00
|
|
|
|
|
|
|
mdbValToNoun :: MDB_val -> IO Noun
|
|
|
|
mdbValToNoun (MDB_val sz ptr) = do
|
|
|
|
bs <- BU.unsafePackCStringLen (castPtr ptr, fromIntegral sz)
|
2019-05-31 05:53:00 +03:00
|
|
|
let res = (bs ^? from pillBS . from pill . _Cue)
|
|
|
|
maybeErr res "mdb bad cue"
|
2019-05-30 02:19:07 +03:00
|
|
|
|
2019-05-30 23:19:26 +03:00
|
|
|
putRaw :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> MDB_val -> MDB_val -> IO ()
|
2019-05-29 21:33:09 +03:00
|
|
|
putRaw flags txn db key val =
|
2019-05-30 23:19:26 +03:00
|
|
|
mdb_put flags txn db key val >>= \case
|
2019-05-30 02:19:07 +03:00
|
|
|
True -> pure ()
|
|
|
|
False -> error "mdb bad put"
|
2019-05-30 23:19:26 +03:00
|
|
|
|
|
|
|
putNoun :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> ByteString -> Noun -> IO ()
|
|
|
|
putNoun flags txn db key val =
|
|
|
|
byteStringAsMdbVal key $ \mKey ->
|
2019-05-31 05:53:00 +03:00
|
|
|
byteStringAsMdbVal (val ^. re _CueBytes) $ \mVal ->
|
2019-05-30 23:19:26 +03:00
|
|
|
putRaw flags txn db mKey mVal
|
|
|
|
|
|
|
|
putJam :: MDB_WriteFlags -> MDB_txn -> MDB_dbi -> Word64 -> Jam -> IO ()
|
2019-05-31 05:53:00 +03:00
|
|
|
putJam flags txn db id (Jam atom) = do
|
2019-05-31 00:24:14 +03:00
|
|
|
withWord64AsMDBval id $ \idVal -> do
|
2019-05-31 05:53:00 +03:00
|
|
|
let !bs = atom ^. pill . pillBS
|
2019-05-31 00:24:14 +03:00
|
|
|
byteStringAsMdbVal bs $ \mVal -> do
|
|
|
|
putRaw flags txn db idVal mVal
|
2019-05-30 02:19:07 +03:00
|
|
|
|
|
|
|
get :: MDB_txn -> MDB_dbi -> ByteString -> IO Noun
|
|
|
|
get txn db key =
|
|
|
|
byteStringAsMdbVal key \mKey ->
|
|
|
|
mdb_get txn db mKey >>= maybe (error "mdb bad get") mdbValToNoun
|
|
|
|
|
|
|
|
mdbValToWord64 :: MDB_val -> IO Word64
|
|
|
|
mdbValToWord64 (MDB_val sz ptr) = do
|
|
|
|
assertErr (sz == 8) "wrong size in mdbValToWord64"
|
|
|
|
peek (castPtr ptr)
|
|
|
|
|
2019-05-30 23:19:26 +03:00
|
|
|
withWord64AsMDBval :: Word64 -> (MDB_val -> IO a) -> IO a
|
|
|
|
withWord64AsMDBval w cb = do
|
|
|
|
withWordPtr w $ \p ->
|
|
|
|
cb (MDB_val (fromIntegral (sizeOf w)) (castPtr p))
|
|
|
|
|
2019-05-30 02:19:07 +03:00
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
|
|
|
|
withWordPtr :: Word64 -> (Ptr Word64 -> IO a) -> IO a
|
|
|
|
withWordPtr w cb = do
|
|
|
|
allocaBytes (sizeOf w) (\p -> poke p w >> cb p)
|
|
|
|
|
2019-05-30 23:19:26 +03:00
|
|
|
-- TODO: We need to be able to send back an exception to the main thread on an
|
|
|
|
-- exception on the persistence thread.
|
|
|
|
persistThread :: MDB_env
|
|
|
|
-> TQueue (Writ [Effect])
|
|
|
|
-> (Writ [Effect] -> STM ())
|
|
|
|
-> IO (Async ())
|
2019-05-31 00:24:14 +03:00
|
|
|
persistThread env inputQueue onPersist = asyncBound $
|
|
|
|
forever do
|
2019-05-30 23:19:26 +03:00
|
|
|
writs <- atomically $ readQueue inputQueue
|
|
|
|
writeEvents writs
|
|
|
|
atomically $ traverse_ onPersist writs
|
|
|
|
where
|
|
|
|
writeEvents writs = do
|
|
|
|
txn <- mdb_txn_begin env Nothing False
|
|
|
|
db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY]
|
|
|
|
|
|
|
|
let flags = compileWriteFlags [MDB_NOOVERWRITE]
|
|
|
|
|
2019-05-31 00:24:14 +03:00
|
|
|
for_ writs $ \w -> do
|
2019-05-30 23:19:26 +03:00
|
|
|
putJam flags txn db (eventId w) (event w)
|
2019-05-30 02:43:51 +03:00
|
|
|
|
2019-05-30 23:19:26 +03:00
|
|
|
mdb_txn_commit txn
|
2019-05-30 02:43:51 +03:00
|
|
|
|
2019-05-30 23:19:26 +03:00
|
|
|
deriving instance Show MDB_val
|
2019-05-30 02:43:51 +03:00
|
|
|
|
2019-05-30 02:19:07 +03:00
|
|
|
-- TODO: This will read len items and will error if there are less than that
|
|
|
|
-- available. This differs from the current pier.c's expectations.
|
2019-05-30 23:19:26 +03:00
|
|
|
readEvents :: LogState -> Word64 -> Word64 -> IO (V.Vector (Word64,Atom))
|
|
|
|
readEvents (LogState env _ _ _) first len =
|
2019-05-30 02:19:07 +03:00
|
|
|
withWordPtr first $ \pIdx ->
|
2019-05-30 23:19:26 +03:00
|
|
|
withKVPtrs (MDB_val 8 (castPtr pIdx)) (MDB_val 0 nullPtr) $ \pKey pVal ->
|
2019-05-30 02:19:07 +03:00
|
|
|
do
|
|
|
|
txn <- mdb_txn_begin env Nothing True
|
|
|
|
db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY]
|
|
|
|
cur <- mdb_cursor_open txn db
|
|
|
|
|
|
|
|
found <- mdb_cursor_get MDB_SET_KEY cur pKey pVal
|
|
|
|
assertErr found "mdb could not read initial event of sequence"
|
|
|
|
|
|
|
|
vec <- V.generateM (int len) \i -> do
|
|
|
|
key <- peek pKey >>= mdbValToWord64
|
|
|
|
val <- peek pVal >>= mdbValToAtom
|
|
|
|
|
|
|
|
let idx = first + (fromIntegral i)
|
|
|
|
|
2019-05-30 23:19:26 +03:00
|
|
|
assertErr (key == idx) ("missing event in database " <> (show idx))
|
|
|
|
|
|
|
|
when (i + 1 /= (int len)) do
|
|
|
|
found <- mdb_cursor_get MDB_NEXT cur pKey pVal
|
|
|
|
assertErr found "lmdb: next event not found"
|
2019-05-30 02:19:07 +03:00
|
|
|
|
|
|
|
pure (idx, val)
|
|
|
|
|
|
|
|
mdb_cursor_close cur
|
|
|
|
mdb_txn_abort txn
|
|
|
|
|
|
|
|
pure vec
|
|
|
|
|
|
|
|
int :: Word64 -> Int
|
|
|
|
int = fromIntegral
|
|
|
|
|
|
|
|
assertErr :: Bool -> String -> IO ()
|
|
|
|
assertErr True _ = pure ()
|
|
|
|
assertErr False m = error m
|
|
|
|
|
2019-05-30 23:19:26 +03:00
|
|
|
latestEventNumber :: LogState -> IO Word64
|
|
|
|
latestEventNumber (LogState env _ _ _) =
|
2019-05-30 02:19:07 +03:00
|
|
|
do
|
2019-05-30 23:19:26 +03:00
|
|
|
txn <- mdb_txn_begin env Nothing True
|
2019-05-30 02:19:07 +03:00
|
|
|
db <- mdb_dbi_open txn (Just "EVENTS") [MDB_CREATE, MDB_INTEGERKEY]
|
|
|
|
cur <- mdb_cursor_open txn db
|
|
|
|
res <- fetch txn db cur
|
|
|
|
mdb_cursor_close cur
|
|
|
|
mdb_txn_abort txn
|
|
|
|
pure res
|
|
|
|
where
|
|
|
|
key = MDB_val 0 nullPtr
|
|
|
|
val = MDB_val 0 nullPtr
|
|
|
|
fetch txn db cur =
|
|
|
|
withKVPtrs key val $ \pKey pVal ->
|
|
|
|
mdb_cursor_get MDB_LAST cur pKey pVal >>= \case
|
|
|
|
False -> pure 0
|
|
|
|
True -> peek pKey >>= mdbValToWord64
|
|
|
|
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
|
2019-05-30 23:19:26 +03:00
|
|
|
readLogIdentity :: LogState -> IO LogIdentity
|
|
|
|
readLogIdentity (LogState env _ _ _) = do
|
2019-05-30 02:19:07 +03:00
|
|
|
txn <- mdb_txn_begin env Nothing True
|
|
|
|
db <- mdb_dbi_open txn (Just "META") []
|
|
|
|
who <- get txn db "who"
|
|
|
|
is_fake <- get txn db "is-fake"
|
|
|
|
life <- get txn db "life"
|
|
|
|
mdb_txn_abort txn
|
|
|
|
pure (LogIdentity who is_fake life)
|
2019-05-30 23:19:26 +03:00
|
|
|
|
|
|
|
writeLogIdentity :: LogState -> LogIdentity -> IO ()
|
|
|
|
writeLogIdentity (LogState env _ _ _) LogIdentity{..} = do
|
|
|
|
txn <- mdb_txn_begin env Nothing False
|
2019-05-31 02:04:06 +03:00
|
|
|
db <- mdb_dbi_open txn (Just "META") [MDB_CREATE]
|
2019-05-30 23:19:26 +03:00
|
|
|
let flags = compileWriteFlags []
|
|
|
|
putNoun flags txn db "who" who
|
|
|
|
putNoun flags txn db "is-fake" is_fake
|
|
|
|
putNoun flags txn db "life" life
|
|
|
|
mdb_txn_commit txn
|
|
|
|
pure ()
|