mirror of https://github.com/voidlizard/hbs2
wip, ncq storage
This commit is contained in:
voidlizard
Dmitry Zuykov
parent
13cb6a730c
commit
569b55d401
2
Makefile
2
Makefile
|
|
@ -26,7 +26,7 @@ BINS := \
|
||||||
fixme-new \
|
fixme-new \
|
||||||
hbs2-git3 \
|
hbs2-git3 \
|
||||||
git-remote-hbs23 \
|
git-remote-hbs23 \
|
||||||
|
hbs2-ncq \
|
||||||
|
|
||||||
RT_DIR := tests/RT
|
RT_DIR := tests/RT
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -14,4 +14,6 @@ debug-info: True
|
||||||
-- executable-static: True
|
-- executable-static: True
|
||||||
-- profiling: True
|
-- profiling: True
|
||||||
--library-profiling: False
|
--library-profiling: False
|
||||||
|
debug-info: True
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -84,12 +84,12 @@ peerEntries = do
|
||||||
|
|
||||||
[isOpaqueOf @LBS.ByteString -> Just lbs] -> do
|
[isOpaqueOf @LBS.ByteString -> Just lbs] -> do
|
||||||
sto <- getStorage
|
sto <- getStorage
|
||||||
(putBlock sto lbs <&> fmap (mkStr . show . pretty . HashRef) )
|
(putBlock sto lbs <&> fmap (mkSym . show . pretty . HashRef) )
|
||||||
>>= orThrowUser "storage error"
|
>>= orThrowUser "storage error"
|
||||||
|
|
||||||
[isOpaqueOf @BS.ByteString -> Just bs] -> do
|
[isOpaqueOf @BS.ByteString -> Just bs] -> do
|
||||||
sto <- getStorage
|
sto <- getStorage
|
||||||
(putBlock sto (LBS.fromStrict bs) <&> fmap (mkStr . show . pretty . HashRef) )
|
(putBlock sto (LBS.fromStrict bs) <&> fmap (mkSym . show . pretty . HashRef) )
|
||||||
>>= orThrowUser "storage error"
|
>>= orThrowUser "storage error"
|
||||||
|
|
||||||
-- FIXME: deprecate-this
|
-- FIXME: deprecate-this
|
||||||
|
|
@ -103,7 +103,14 @@ peerEntries = do
|
||||||
sto <- getStorage
|
sto <- getStorage
|
||||||
lift $ putTextLit sto s
|
lift $ putTextLit sto s
|
||||||
|
|
||||||
_ -> throwIO $ BadFormException @c nil
|
[] -> do
|
||||||
|
bs <- liftIO BS.getContents
|
||||||
|
sto <- getStorage
|
||||||
|
putBlock sto (LBS.fromStrict bs) >>= \case
|
||||||
|
Nothing -> pure nil
|
||||||
|
Just h -> pure $ mkSym (show $ pretty $ HashRef h)
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @c (mkList e)
|
||||||
|
|
||||||
brief "checks if peer available"
|
brief "checks if peer available"
|
||||||
$ noArgs
|
$ noArgs
|
||||||
|
|
|
||||||
|
|
@ -56,6 +56,7 @@ common shared-properties
|
||||||
|
|
||||||
build-depends:
|
build-depends:
|
||||||
hbs2-core
|
hbs2-core
|
||||||
|
, hbs2-log-structured
|
||||||
, hbs2-peer
|
, hbs2-peer
|
||||||
, hbs2-storage-simple
|
, hbs2-storage-simple
|
||||||
, hbs2-keyman-direct-lib
|
, hbs2-keyman-direct-lib
|
||||||
|
|
|
||||||
|
|
@ -1,256 +1,7 @@
|
||||||
module HBS2.Data.Log.Structured where
|
module HBS2.Data.Log.Structured
|
||||||
|
( module Exported
|
||||||
import HBS2.Prelude.Plated
|
)
|
||||||
import HBS2.OrDie
|
|
||||||
|
|
||||||
import Network.ByteOrder qualified as N
|
|
||||||
import Data.ByteString.Builder qualified as B
|
|
||||||
import Data.ByteString.Lazy (ByteString)
|
|
||||||
import Data.ByteString.Lazy qualified as LBS
|
|
||||||
import Data.ByteString qualified as BS
|
|
||||||
import Data.Maybe
|
|
||||||
import Network.ByteOrder hiding (ByteString)
|
|
||||||
import Control.Monad.State
|
|
||||||
|
|
||||||
import Codec.Compression.Zstd qualified as Zstd
|
|
||||||
import Codec.Compression.Zstd.Streaming qualified as Zstd
|
|
||||||
import Codec.Compression.Zstd.Streaming (Result(..))
|
|
||||||
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad.Trans.Maybe
|
|
||||||
import Lens.Micro.Platform
|
|
||||||
|
|
||||||
-- import UnliftIO
|
|
||||||
|
|
||||||
class ReadLogOpts a where
|
|
||||||
|
|
||||||
data ReadLogError = SomeReadLogError
|
|
||||||
deriving stock (Typeable, Show)
|
|
||||||
|
|
||||||
instance Exception ReadLogError
|
|
||||||
|
|
||||||
instance ReadLogOpts ()
|
|
||||||
|
|
||||||
type NumBytes = Int
|
|
||||||
|
|
||||||
class Monad m => BytesReader m where
|
|
||||||
noBytesLeft :: m Bool
|
|
||||||
readBytes :: NumBytes -> m ByteString
|
|
||||||
|
|
||||||
readBytesMaybe :: NumBytes -> m (Maybe ByteString)
|
|
||||||
readBytesMaybe n = do
|
|
||||||
bs <- readBytes n
|
|
||||||
if LBS.length bs == fromIntegral n then pure (Just bs) else pure Nothing
|
|
||||||
|
|
||||||
newtype ConsumeLBS m a = ConsumeLBS { fromConsumeLBS :: StateT ByteString m a }
|
|
||||||
deriving newtype ( Applicative
|
|
||||||
, Functor
|
|
||||||
, Monad
|
|
||||||
, MonadState ByteString
|
|
||||||
, MonadIO
|
|
||||||
, MonadTrans
|
|
||||||
)
|
|
||||||
|
|
||||||
readChunkThrow :: MonadIO m => Int -> ConsumeLBS m ByteString
|
|
||||||
readChunkThrow n = do
|
|
||||||
lbs <- get
|
|
||||||
let (this, that) = LBS.splitAt (fromIntegral n) lbs
|
|
||||||
if LBS.length this /= fromIntegral n then
|
|
||||||
liftIO $ throwIO SomeReadLogError
|
|
||||||
else do
|
|
||||||
put $! that
|
|
||||||
pure this
|
|
||||||
|
|
||||||
readChunkSimple :: Monad m => Int -> ConsumeLBS m ByteString
|
|
||||||
readChunkSimple n = do
|
|
||||||
lbs <- get
|
|
||||||
let (this, that) = LBS.splitAt (fromIntegral n) lbs
|
|
||||||
put $! that
|
|
||||||
pure this
|
|
||||||
|
|
||||||
reminds :: Monad m => ConsumeLBS m Int
|
|
||||||
reminds = gets (fromIntegral . LBS.length)
|
|
||||||
|
|
||||||
consumed :: Monad m => ConsumeLBS m Bool
|
|
||||||
consumed = gets LBS.null
|
|
||||||
|
|
||||||
runConsumeLBS :: Monad m => ByteString -> ConsumeLBS m a -> m a
|
|
||||||
runConsumeLBS s m = evalStateT (fromConsumeLBS m) s
|
|
||||||
|
|
||||||
newtype ConsumeBS m a = ConsumeBS { fromConsumeBS :: StateT BS.ByteString m a }
|
|
||||||
deriving newtype ( Applicative
|
|
||||||
, Functor
|
|
||||||
, Monad
|
|
||||||
, MonadState BS.ByteString
|
|
||||||
, MonadIO
|
|
||||||
, MonadTrans
|
|
||||||
)
|
|
||||||
|
|
||||||
|
|
||||||
instance Monad m => BytesReader (ConsumeLBS m) where
|
|
||||||
readBytes = readChunkSimple
|
|
||||||
noBytesLeft = consumed
|
|
||||||
|
|
||||||
instance Monad m => BytesReader (ConsumeBS m) where
|
|
||||||
noBytesLeft = gets BS.null
|
|
||||||
readBytes n = do
|
|
||||||
s <- get
|
|
||||||
let (a,b) = BS.splitAt n s
|
|
||||||
put $! b
|
|
||||||
pure (LBS.fromStrict a)
|
|
||||||
|
|
||||||
{- HLINT ignore "Eta reduce"-}
|
|
||||||
toSectionList :: BS.ByteString -> [BS.ByteString]
|
|
||||||
toSectionList source = go source
|
|
||||||
where
|
where
|
||||||
go bs | BS.length bs < 4 = []
|
|
||||||
| otherwise = go1 (BS.splitAt 4 bs & over _1 (fromIntegral . N.word32))
|
|
||||||
|
|
||||||
go1 (len,rest) | BS.length rest < len = []
|
import HBS2.Data.Log.Structured.SD as Exported
|
||||||
|
|
||||||
go1 (len,rest) = do
|
|
||||||
let (sect, rest1) = BS.splitAt len rest
|
|
||||||
sect : go rest1
|
|
||||||
|
|
||||||
validateSorted :: BS.ByteString -> Bool
|
|
||||||
validateSorted bs = do
|
|
||||||
let sections = toSectionList bs
|
|
||||||
let r = flip fix (Nothing, sections, 0) $ \next -> \case
|
|
||||||
(_, [], e) -> e
|
|
||||||
(Nothing, x:xs, e) -> next (Just x, xs, e)
|
|
||||||
(Just v, x:_, e) | v > x -> (e+1)
|
|
||||||
(Just _, x:xs, e) -> next (Just x, xs, e)
|
|
||||||
r == 0
|
|
||||||
|
|
||||||
|
|
||||||
scanBS :: Monad m => BS.ByteString -> ( BS.ByteString -> m () ) -> m ()
|
|
||||||
scanBS bs action = do
|
|
||||||
let hsz = 4
|
|
||||||
flip fix bs $ \next bss -> do
|
|
||||||
if BS.length bss < hsz then pure ()
|
|
||||||
else do
|
|
||||||
let (ssize, rest) = BS.splitAt hsz bss
|
|
||||||
let size = N.word32 ssize & fromIntegral
|
|
||||||
let (sdata, rest2) = BS.splitAt size rest
|
|
||||||
if BS.length sdata < size then
|
|
||||||
pure ()
|
|
||||||
else do
|
|
||||||
action sdata
|
|
||||||
next rest2
|
|
||||||
|
|
||||||
runConsumeBS :: Monad m => BS.ByteString -> ConsumeBS m a -> m a
|
|
||||||
runConsumeBS s m = evalStateT (fromConsumeBS m) s
|
|
||||||
|
|
||||||
|
|
||||||
readSections :: forall m . (MonadIO m, BytesReader m)
|
|
||||||
=> ( Int -> ByteString -> m () )
|
|
||||||
-> m ()
|
|
||||||
|
|
||||||
readSections action = fix \next -> do
|
|
||||||
done <- noBytesLeft
|
|
||||||
if done then
|
|
||||||
pure ()
|
|
||||||
else do
|
|
||||||
ssize <- readBytesMaybe 4
|
|
||||||
>>= orThrow SomeReadLogError
|
|
||||||
<&> fromIntegral . N.word32 . LBS.toStrict
|
|
||||||
|
|
||||||
sdata <- readBytesMaybe ssize
|
|
||||||
>>= orThrow SomeReadLogError
|
|
||||||
|
|
||||||
action ssize sdata
|
|
||||||
next
|
|
||||||
|
|
||||||
writeSection :: forall m . Monad m
|
|
||||||
=> ByteString
|
|
||||||
-> ( ByteString -> m () )
|
|
||||||
-> m ()
|
|
||||||
|
|
||||||
writeSection bs output = do
|
|
||||||
let bssize = bytestring32 (fromIntegral $ LBS.length bs)
|
|
||||||
let section = B.byteString bssize <> B.lazyByteString bs
|
|
||||||
output (B.toLazyByteString section)
|
|
||||||
|
|
||||||
|
|
||||||
writeSections :: forall m . Monad m
|
|
||||||
=> m (Maybe ByteString)
|
|
||||||
-> ( ByteString -> m () )
|
|
||||||
-> m ()
|
|
||||||
|
|
||||||
writeSections source sink = fix \next -> do
|
|
||||||
source >>= maybe none (\bs -> writeSection bs sink >> next)
|
|
||||||
|
|
||||||
|
|
||||||
data CompressedStreamError =
|
|
||||||
CompressedStreamWriteError
|
|
||||||
deriving stock (Typeable,Show)
|
|
||||||
|
|
||||||
instance Exception CompressedStreamError
|
|
||||||
|
|
||||||
writeCompressedChunkZstd :: forall m . MonadIO m
|
|
||||||
=> ( ByteString -> m () )
|
|
||||||
-> Result
|
|
||||||
-> Maybe ByteString
|
|
||||||
-> m Result
|
|
||||||
|
|
||||||
writeCompressedChunkZstd sink stream mlbs = do
|
|
||||||
flip fix ( LBS.toChunks lbs, stream) $ \next -> \case
|
|
||||||
|
|
||||||
([], r@(Done s)) -> sink (LBS.fromStrict s) >> pure r
|
|
||||||
|
|
||||||
(_, Done{}) -> liftIO (throwIO CompressedStreamWriteError)
|
|
||||||
|
|
||||||
(_, Error{})-> liftIO (throwIO CompressedStreamWriteError)
|
|
||||||
|
|
||||||
(w, Produce s continue) -> do
|
|
||||||
sink (LBS.fromStrict s)
|
|
||||||
c <- liftIO continue
|
|
||||||
next (w, c)
|
|
||||||
|
|
||||||
(_, Consume consume) | isNothing mlbs -> do
|
|
||||||
r <- liftIO (consume mempty)
|
|
||||||
next ([], r)
|
|
||||||
|
|
||||||
([], r@(Consume{})) -> pure r
|
|
||||||
|
|
||||||
(x:xs, r@(Consume consume)) -> do
|
|
||||||
what <- liftIO (consume x)
|
|
||||||
next (xs, what)
|
|
||||||
|
|
||||||
where
|
|
||||||
lbs = fromMaybe mempty mlbs
|
|
||||||
|
|
||||||
|
|
||||||
writeCompressedStreamZstd :: forall m . MonadIO m
|
|
||||||
=> Result
|
|
||||||
-> m (Maybe ByteString)
|
|
||||||
-> ( ByteString -> m () )
|
|
||||||
-> m ()
|
|
||||||
writeCompressedStreamZstd stream source sink = do
|
|
||||||
flip fix stream $ \next sn -> do
|
|
||||||
source >>= \case
|
|
||||||
Nothing -> writeCompressedChunkZstd sink sn Nothing >> none
|
|
||||||
Just lbs -> writeCompressedChunkZstd sink sn (Just lbs) >>= next
|
|
||||||
|
|
||||||
|
|
||||||
binarySearchBS :: Monad m
|
|
||||||
=> Int -- ^ record size
|
|
||||||
-> ( BS.ByteString -> BS.ByteString ) -- ^ key extractor
|
|
||||||
-> BS.ByteString -- ^ key
|
|
||||||
-> BS.ByteString -- ^ source
|
|
||||||
-> m (Maybe Int)
|
|
||||||
|
|
||||||
binarySearchBS rs getKey s source = do
|
|
||||||
let maxn = BS.length source `div` rs
|
|
||||||
loop 0 maxn
|
|
||||||
where
|
|
||||||
loop l u | u <= l = pure Nothing
|
|
||||||
| otherwise = do
|
|
||||||
let e = getKey (BS.drop ( k * rs ) source)
|
|
||||||
case compare e s of
|
|
||||||
EQ -> pure $ Just (k * rs)
|
|
||||||
LT -> loop (k+1) u
|
|
||||||
GT -> loop l k
|
|
||||||
|
|
||||||
where k = (l + u) `div` 2
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,30 @@
|
||||||
|
Copyright (c) 2023,
|
||||||
|
|
||||||
|
All rights reserved.
|
||||||
|
|
||||||
|
Redistribution and use in source and binary forms, with or without
|
||||||
|
modification, are permitted provided that the following conditions are met:
|
||||||
|
|
||||||
|
* Redistributions of source code must retain the above copyright
|
||||||
|
notice, this list of conditions and the following disclaimer.
|
||||||
|
|
||||||
|
* Redistributions in binary form must reproduce the above
|
||||||
|
copyright notice, this list of conditions and the following
|
||||||
|
disclaimer in the documentation and/or other materials provided
|
||||||
|
with the distribution.
|
||||||
|
|
||||||
|
* Neither the name of nor the names of other
|
||||||
|
contributors may be used to endorse or promote products derived
|
||||||
|
from this software without specific prior written permission.
|
||||||
|
|
||||||
|
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||||
|
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||||
|
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||||
|
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||||
|
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||||
|
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||||
|
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||||
|
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||||
|
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||||
|
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||||
|
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||||
|
|
@ -0,0 +1,103 @@
|
||||||
|
cabal-version: 3.0
|
||||||
|
name: hbs2-log-structured
|
||||||
|
version: 0.25.0.1
|
||||||
|
-- synopsis:
|
||||||
|
-- description:
|
||||||
|
license: BSD-3-Clause
|
||||||
|
license-file: LICENSE
|
||||||
|
-- author:
|
||||||
|
-- maintainer:
|
||||||
|
-- copyright:
|
||||||
|
category: Database
|
||||||
|
build-type: Simple
|
||||||
|
-- extra-doc-files: CHANGELOG.md
|
||||||
|
-- extra-source-files:
|
||||||
|
|
||||||
|
common shared-properties
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-- -fno-warn-unused-matches
|
||||||
|
-- -fno-warn-unused-do-bind
|
||||||
|
-- -Werror=missing-methods
|
||||||
|
-- -Werror=incomplete-patterns
|
||||||
|
-- -fno-warn-unused-binds
|
||||||
|
-- -threaded
|
||||||
|
-- -rtsopts
|
||||||
|
-- "-with-rtsopts=-N4 -A64m -AL256m -I0"
|
||||||
|
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
default-extensions:
|
||||||
|
ApplicativeDo
|
||||||
|
, BangPatterns
|
||||||
|
, BlockArguments
|
||||||
|
, ConstraintKinds
|
||||||
|
, DataKinds
|
||||||
|
, DeriveDataTypeable
|
||||||
|
, DeriveGeneric
|
||||||
|
, DerivingStrategies
|
||||||
|
, DerivingVia
|
||||||
|
, ExtendedDefaultRules
|
||||||
|
, FlexibleContexts
|
||||||
|
, FlexibleInstances
|
||||||
|
, GADTs
|
||||||
|
, GeneralizedNewtypeDeriving
|
||||||
|
, ImportQualifiedPost
|
||||||
|
, LambdaCase
|
||||||
|
, MultiParamTypeClasses
|
||||||
|
, OverloadedStrings
|
||||||
|
, QuasiQuotes
|
||||||
|
, ScopedTypeVariables
|
||||||
|
, StandaloneDeriving
|
||||||
|
, TupleSections
|
||||||
|
, TypeApplications
|
||||||
|
, TypeOperators
|
||||||
|
, TypeFamilies
|
||||||
|
|
||||||
|
|
||||||
|
library
|
||||||
|
import: shared-properties
|
||||||
|
exposed-modules:
|
||||||
|
HBS2.Data.Log.Structured.SD
|
||||||
|
HBS2.Data.Log.Structured.NCQ
|
||||||
|
|
||||||
|
-- other-modules:
|
||||||
|
-- other-extensions:
|
||||||
|
build-depends: base, hbs2-core, suckless-conf
|
||||||
|
, async
|
||||||
|
, atomic-write
|
||||||
|
, binary
|
||||||
|
, bytestring
|
||||||
|
, bytestring-mmap
|
||||||
|
, cache
|
||||||
|
, containers
|
||||||
|
, directory
|
||||||
|
, filepath
|
||||||
|
, filepattern
|
||||||
|
, memory
|
||||||
|
, microlens-platform
|
||||||
|
, mmap
|
||||||
|
, mtl
|
||||||
|
, network-byte-order
|
||||||
|
, prettyprinter
|
||||||
|
, random
|
||||||
|
, safe
|
||||||
|
, serialise
|
||||||
|
, stm
|
||||||
|
, stm-chans
|
||||||
|
, streaming
|
||||||
|
, temporary
|
||||||
|
, time
|
||||||
|
, transformers
|
||||||
|
, uniplate
|
||||||
|
, unix
|
||||||
|
, unliftio
|
||||||
|
, unordered-containers
|
||||||
|
, vector
|
||||||
|
, zstd
|
||||||
|
|
||||||
|
|
||||||
|
hs-source-dirs: lib
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,351 @@
|
||||||
|
{-# Language MultiWayIf #-}
|
||||||
|
{-# Language AllowAmbiguousTypes #-}
|
||||||
|
{-# Language UndecidableInstances #-}
|
||||||
|
{-# Language RecordWildCards #-}
|
||||||
|
module HBS2.Data.Log.Structured.NCQ where
|
||||||
|
|
||||||
|
-- ^ N-way pseudo-cuckoo disk hash tables
|
||||||
|
|
||||||
|
import HBS2.Prelude.Plated
|
||||||
|
import HBS2.OrDie
|
||||||
|
import HBS2.Hash
|
||||||
|
import HBS2.Data.Types.Refs
|
||||||
|
import HBS2.Merkle
|
||||||
|
|
||||||
|
import Data.Config.Suckless.Syntax
|
||||||
|
import Data.Config.Suckless.Script
|
||||||
|
import Data.Config.Suckless.System
|
||||||
|
|
||||||
|
import Data.Bits
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.ByteString qualified as BS
|
||||||
|
import Data.ByteString.Char8 qualified as BS8
|
||||||
|
import Data.ByteString.Builder
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Word
|
||||||
|
import Data.List qualified as List
|
||||||
|
import Data.Vector qualified as V
|
||||||
|
import Data.Vector ((!))
|
||||||
|
import Control.Monad.Trans.Cont
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
|
import Network.ByteOrder qualified as N
|
||||||
|
import Data.Coerce
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
import Data.IntMap qualified as IntMap
|
||||||
|
import Data.IntMap (IntMap)
|
||||||
|
import Data.Fixed
|
||||||
|
import System.Environment
|
||||||
|
import System.Posix.Fcntl
|
||||||
|
import System.Posix.IO
|
||||||
|
import System.Posix.Files (setFileSize)
|
||||||
|
import System.FilePath.Posix
|
||||||
|
import System.IO.MMap
|
||||||
|
import System.IO.Temp
|
||||||
|
import System.IO qualified as IO
|
||||||
|
import Safe
|
||||||
|
import Lens.Micro.Platform
|
||||||
|
import Control.Concurrent.STM qualified as STM
|
||||||
|
import UnliftIO
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
nextPowerOf2 :: Word64 -> Word64
|
||||||
|
nextPowerOf2 0 = 1 -- 0 округляем к 1 (минимальная степень двойки)
|
||||||
|
nextPowerOf2 n =
|
||||||
|
let n' = n - 1
|
||||||
|
in foldl (\x shift -> x .|. (x `shiftR` shift)) n' [1,2,4,8,16,32,64] + 1
|
||||||
|
|
||||||
|
data NWayHashException =
|
||||||
|
NWayHashInvalidMetaData String
|
||||||
|
deriving stock (Show, Typeable)
|
||||||
|
|
||||||
|
instance Exception NWayHashException
|
||||||
|
|
||||||
|
|
||||||
|
type NWayPageOff = Word64
|
||||||
|
type NWayPageBuckets = Word64
|
||||||
|
|
||||||
|
data NWayHash =
|
||||||
|
NWayHash
|
||||||
|
{ nwayKeySize :: Int
|
||||||
|
, nwayKeyPartSize :: Int
|
||||||
|
, nwayValueSize :: Int
|
||||||
|
, nwayBucketSize :: Int
|
||||||
|
, nwayPages :: [(NWayPageOff, NWayPageBuckets)]
|
||||||
|
}
|
||||||
|
deriving stock (Show)
|
||||||
|
|
||||||
|
nwayItemSize :: NWayHash -> Int
|
||||||
|
nwayItemSize NWayHash{..} = nwayKeySize + nwayValueSize
|
||||||
|
|
||||||
|
instance IsContext c => MkSyntax c NWayHash where
|
||||||
|
mkSyntax NWayHash{..} =
|
||||||
|
mkList [ mkForm "keysize" [mkInt nwayKeySize]
|
||||||
|
, mkForm "keypartsize" [mkInt nwayKeyPartSize]
|
||||||
|
, mkForm "valuesize" [mkInt nwayValueSize]
|
||||||
|
, mkForm "bucksize" [mkInt nwayBucketSize]
|
||||||
|
, mkForm "buckets" [mkInt x | x <- fmap snd nwayPages]
|
||||||
|
, mkForm "cqfile" [mkInt 1]
|
||||||
|
]
|
||||||
|
|
||||||
|
instance Pretty NWayHash where
|
||||||
|
pretty = pretty . mkSyntax @C
|
||||||
|
|
||||||
|
nwayHashMMapReadOnly :: MonadUnliftIO m => FilePath -> m (Maybe (ByteString, NWayHash))
|
||||||
|
nwayHashMMapReadOnly fn = runMaybeT do
|
||||||
|
|
||||||
|
bs0 <- liftIO $ mmapFileByteString fn Nothing
|
||||||
|
|
||||||
|
let size = BS.length bs0
|
||||||
|
let (_,metasize) = BS.splitAt (size - 4) bs0 & over _2 (fromIntegral . N.word32)
|
||||||
|
let (_,meta) = BS.splitAt (size - metasize - 4) bs0 & over _2 (BS8.unpack . BS.take metasize)
|
||||||
|
|
||||||
|
let bs1 = BS.take (BS.length bs0 - 4 - metasize) bs0
|
||||||
|
|
||||||
|
metaSyn <- parseTop meta & toMPlus
|
||||||
|
|
||||||
|
nwayKeySize <- headMay [ x | MatchOption "keysize" (LitIntVal x) <- metaSyn ]
|
||||||
|
& orThrow (NWayHashInvalidMetaData "keysize")
|
||||||
|
<&> fromIntegral
|
||||||
|
|
||||||
|
nwayValueSize <- headMay [ x | MatchOption "valuesize" (LitIntVal x) <- metaSyn ]
|
||||||
|
& orThrow (NWayHashInvalidMetaData "valuesize")
|
||||||
|
<&> fromIntegral
|
||||||
|
|
||||||
|
nwayBucketSize <- headMay [ x | MatchOption "bucksize" (LitIntVal x) <- metaSyn ]
|
||||||
|
& orThrow (NWayHashInvalidMetaData "bucksize")
|
||||||
|
<&> fromIntegral
|
||||||
|
|
||||||
|
nwayKeyPartSize <- headMay [ x | MatchOption "keypartsize" (LitIntVal x) <- metaSyn ]
|
||||||
|
& orThrow (NWayHashInvalidMetaData "keypartsize")
|
||||||
|
<&> fromIntegral
|
||||||
|
|
||||||
|
let buckets' = [ bsz | ListVal (SymbolVal "buckets" : bsz) <- metaSyn ]
|
||||||
|
& mconcat
|
||||||
|
|
||||||
|
let buckets = [ fromIntegral n :: NWayPageBuckets | LitIntVal n <- buckets' ]
|
||||||
|
|
||||||
|
let isize = fromIntegral nwayKeySize + fromIntegral nwayValueSize
|
||||||
|
|
||||||
|
let nwayPages= List.scanl' (\sz x -> sz + x*isize* fromIntegral nwayBucketSize) 0 buckets
|
||||||
|
& flip zip buckets
|
||||||
|
|
||||||
|
when (List.null nwayPages) do
|
||||||
|
throwIO $ NWayHashInvalidMetaData "buckets"
|
||||||
|
|
||||||
|
pure (bs1,NWayHash{..})
|
||||||
|
|
||||||
|
bucketSizes :: Int -> [Int]
|
||||||
|
bucketSizes maxSize = takeWhile (<= maxSize) fibs
|
||||||
|
where
|
||||||
|
fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
|
||||||
|
|
||||||
|
nwayHashLookup :: MonadUnliftIO m
|
||||||
|
=> NWayHash
|
||||||
|
-> ByteString
|
||||||
|
-> ByteString
|
||||||
|
-> m (Maybe ByteString)
|
||||||
|
|
||||||
|
nwayHashLookup nw@NWayHash{..} mmaped keyBs = do
|
||||||
|
let keySize = fromIntegral nwayKeySize
|
||||||
|
let valSize = fromIntegral nwayValueSize
|
||||||
|
let itemSize = fromIntegral $ nwayItemSize nw
|
||||||
|
let buckL = fromIntegral nwayBucketSize :: Word64
|
||||||
|
let buckSize = fromIntegral $ fromIntegral buckL * nwayItemSize nw
|
||||||
|
let emptyKey = BS.replicate keySize 0
|
||||||
|
|
||||||
|
let hxs = chunks nwayKeyPartSize (keyBs :: ByteString)
|
||||||
|
|
||||||
|
flip runContT pure $ callCC \exit -> do
|
||||||
|
|
||||||
|
for_ (zip nwayPages hxs) $ \((pageOff,nbuck), hx) -> do
|
||||||
|
let ki = N.word64 hx
|
||||||
|
let buck = ki `mod` nbuck
|
||||||
|
-- let buck = ki .&. (nbuck - 1)
|
||||||
|
let baseOff = pageOff + buck * buckSize
|
||||||
|
let buckEnd = baseOff + itemSize * buckL
|
||||||
|
-- liftIO $ print $ niceHash <+> pretty ki <+> pretty buck <+> pretty baseOff <+> pretty nbuck <+> pretty pageOff
|
||||||
|
|
||||||
|
flip fix (baseOff :: NWayPageOff) $ \nextEntry -> \case
|
||||||
|
eOff | eOff >= buckEnd -> none
|
||||||
|
| otherwise -> do
|
||||||
|
let es = BS.drop (fromIntegral eOff) mmaped
|
||||||
|
let ks = BS.take keySize es
|
||||||
|
|
||||||
|
if | ks == keyBs -> do
|
||||||
|
exit $ Just (BS.take valSize (BS.drop keySize es))
|
||||||
|
|
||||||
|
| ks == emptyKey -> do
|
||||||
|
exit Nothing
|
||||||
|
|
||||||
|
| otherwise -> do
|
||||||
|
nextEntry (eOff + itemSize)
|
||||||
|
|
||||||
|
pure Nothing
|
||||||
|
|
||||||
|
data NWayHashAlloc =
|
||||||
|
NWayHashAlloc
|
||||||
|
{ nwayAllocRatio :: Fixed E3
|
||||||
|
, nwayAllocKeySize :: Int
|
||||||
|
, nwayAllocKeyPartSize :: Int
|
||||||
|
, nwayAllocValueSize :: Int
|
||||||
|
, nwayAllocBucketSize :: Int
|
||||||
|
, nwayAllocMinBuckets :: Int
|
||||||
|
, nwayAllocBucketNum :: NWayHashAlloc -> Int -> Int
|
||||||
|
, nwayAllocResize :: NWayHashAlloc -> Int -> Int -> Int -> Maybe Int
|
||||||
|
}
|
||||||
|
|
||||||
|
nwayAllocDef :: Fixed E3 -> Int -> Int -> Int -> NWayHashAlloc
|
||||||
|
nwayAllocDef r ks kps vs =
|
||||||
|
NWayHashAlloc r ks kps vs 4 512 nwayAllocPow2 nwayAllocResizeDefault
|
||||||
|
|
||||||
|
nwayAllocPow2 :: NWayHashAlloc -> Int -> Int
|
||||||
|
nwayAllocPow2 NWayHashAlloc{..} num = fromIntegral $
|
||||||
|
nextPowerOf2 (ceiling (nwayAllocRatio * (realToFrac num / realToFrac nwayAllocBucketSize)))
|
||||||
|
|
||||||
|
nwayAllocResizeDefault :: NWayHashAlloc -> Int -> Int -> Int -> Maybe Int
|
||||||
|
nwayAllocResizeDefault NWayHashAlloc{..} i c num = Nothing
|
||||||
|
|
||||||
|
nwayWriteBatch :: MonadUnliftIO m
|
||||||
|
=> NWayHashAlloc
|
||||||
|
-> FilePath -- ^ dir
|
||||||
|
-> FilePath -- ^ template
|
||||||
|
-> [(ByteString, ByteString)]
|
||||||
|
-> m FilePath
|
||||||
|
|
||||||
|
nwayWriteBatch nwa@NWayHashAlloc{..} path tpl items = do
|
||||||
|
|
||||||
|
let ks = nwayAllocKeySize
|
||||||
|
|
||||||
|
let vs = nwayAllocValueSize
|
||||||
|
let kpiece = nwayAllocKeyPartSize
|
||||||
|
|
||||||
|
let itemsInBuck = nwayAllocBucketSize
|
||||||
|
let itemSize = fromIntegral $ ks + vs
|
||||||
|
let buckSize = fromIntegral $ itemSize * itemsInBuck
|
||||||
|
|
||||||
|
let kparts = ks `div` fromIntegral kpiece
|
||||||
|
|
||||||
|
fn0 <- liftIO (emptyTempFile path tpl)
|
||||||
|
fn <- liftIO (emptyTempFile path (takeBaseName fn0 <>".part"))
|
||||||
|
|
||||||
|
h0 <- openFile fn ReadWriteMode
|
||||||
|
fd <- liftIO $ handleToFd h0
|
||||||
|
h <- liftIO $ fdToHandle fd
|
||||||
|
|
||||||
|
flip runContT pure do
|
||||||
|
|
||||||
|
buckets <- newTQueueIO
|
||||||
|
leftovers <- newTQueueIO
|
||||||
|
|
||||||
|
void $ ContT $ bracket none $ const do
|
||||||
|
hClose h
|
||||||
|
|
||||||
|
wq <- newTQueueIO
|
||||||
|
|
||||||
|
writer <- ContT $ withAsync do
|
||||||
|
fix \next -> do
|
||||||
|
ops <- atomically do
|
||||||
|
void (peekTQueue wq)
|
||||||
|
STM.flushTQueue wq
|
||||||
|
|
||||||
|
for_ ops $ \case
|
||||||
|
Just (_,op) -> op
|
||||||
|
Nothing -> none
|
||||||
|
|
||||||
|
unless (any isNothing ops) next
|
||||||
|
|
||||||
|
flip fix (Nothing,0,0,items) \nextPage (numBuck,pageOff,i,es) -> do
|
||||||
|
|
||||||
|
let buckNum = case numBuck of
|
||||||
|
Just x -> x
|
||||||
|
Nothing -> max nwayAllocMinBuckets (nwayAllocBucketNum nwa (List.length es))
|
||||||
|
|
||||||
|
atomically $ writeTQueue buckets buckNum
|
||||||
|
|
||||||
|
tvx <- replicateM (fromIntegral buckNum) ( newTVarIO 0 )
|
||||||
|
let alloc = V.fromList tvx
|
||||||
|
|
||||||
|
let pageSize = buckNum * buckSize
|
||||||
|
|
||||||
|
liftIO do
|
||||||
|
fileAllocate fd pageOff (fromIntegral pageSize)
|
||||||
|
|
||||||
|
for_ es $ \(k,v) -> do
|
||||||
|
let ki = BS.take kpiece (BS.drop (i*kpiece) k ) & N.word64
|
||||||
|
let bn = ki `mod` fromIntegral buckNum
|
||||||
|
let buckOff = fromIntegral pageOff + bn * fromIntegral buckSize
|
||||||
|
|
||||||
|
eIdx <- atomically do
|
||||||
|
e <- readTVar (alloc ! fromIntegral bn)
|
||||||
|
if e >= itemsInBuck then do
|
||||||
|
writeTQueue leftovers (k,v)
|
||||||
|
pure Nothing
|
||||||
|
else do
|
||||||
|
writeTVar (alloc ! fromIntegral bn) (e+1)
|
||||||
|
pure $ Just e
|
||||||
|
|
||||||
|
for_ eIdx \e -> liftIO do
|
||||||
|
let woff = fromIntegral buckOff + fromIntegral (e * itemSize)
|
||||||
|
let op = liftIO do
|
||||||
|
hSeek h AbsoluteSeek woff
|
||||||
|
BS.hPut h (k <> BS.take (fromIntegral vs) v)
|
||||||
|
|
||||||
|
atomically (writeTQueue wq (Just (woff, op)))
|
||||||
|
|
||||||
|
lo <- atomically $ STM.flushTQueue leftovers
|
||||||
|
|
||||||
|
if | List.null lo -> none
|
||||||
|
|
||||||
|
| i + 1 < fromIntegral kparts -> do
|
||||||
|
let resize = nwayAllocResize nwa i buckNum (List.length lo)
|
||||||
|
nextPage (resize, pageOff + fromIntegral pageSize, succ i, lo)
|
||||||
|
|
||||||
|
| otherwise -> do
|
||||||
|
-- TODO: check-how-it-works
|
||||||
|
liftIO (setFileSize fn pageOff)
|
||||||
|
nextPage (Just (buckNum*2), pageOff, i, lo)
|
||||||
|
|
||||||
|
atomically $ writeTQueue wq Nothing
|
||||||
|
wait writer
|
||||||
|
|
||||||
|
-- finalize write
|
||||||
|
bucklist <- atomically $ STM.flushTQueue buckets
|
||||||
|
|
||||||
|
let meta = [ mkForm @C "keysize" [mkInt ks]
|
||||||
|
, mkForm "keypartsize" [mkInt kpiece]
|
||||||
|
, mkForm "valuesize" [mkInt vs]
|
||||||
|
, mkForm "bucksize" [mkInt itemsInBuck]
|
||||||
|
, mkForm "buckets" (fmap mkInt bucklist)
|
||||||
|
, mkForm "cqfile" [mkInt 1]
|
||||||
|
]
|
||||||
|
|
||||||
|
let metabs = BS8.pack $ show $ vsep (fmap pretty meta)
|
||||||
|
let metaSize = fromIntegral $ BS.length metabs
|
||||||
|
|
||||||
|
liftIO do
|
||||||
|
hSeek h SeekFromEnd 0
|
||||||
|
BS.hPut h metabs
|
||||||
|
BS.hPut h (N.bytestring32 metaSize)
|
||||||
|
mv fn fn0
|
||||||
|
|
||||||
|
pure fn0
|
||||||
|
|
||||||
|
nwayHashScanAll :: MonadIO m
|
||||||
|
=> NWayHash
|
||||||
|
-> ByteString
|
||||||
|
-> ( NWayPageOff -> ByteString -> ByteString -> m () )
|
||||||
|
-> m ()
|
||||||
|
|
||||||
|
nwayHashScanAll n@NWayHash{..} mmaped action = do
|
||||||
|
let itemSize = fromIntegral $ nwayItemSize n
|
||||||
|
flip fix (0,mmaped) $ \next (o,bs) -> do
|
||||||
|
if BS.null bs then
|
||||||
|
none
|
||||||
|
else do
|
||||||
|
let ks = BS.take nwayKeySize bs
|
||||||
|
let vs = BS.take nwayValueSize (BS.drop 32 bs)
|
||||||
|
action o ks vs
|
||||||
|
next (o+itemSize, BS.drop (fromIntegral itemSize) bs)
|
||||||
|
|
||||||
|
|
@ -0,0 +1,253 @@
|
||||||
|
module HBS2.Data.Log.Structured.SD where
|
||||||
|
|
||||||
|
import HBS2.Prelude.Plated
|
||||||
|
import HBS2.OrDie
|
||||||
|
|
||||||
|
import Network.ByteOrder qualified as N
|
||||||
|
import Data.ByteString.Builder qualified as B
|
||||||
|
import Data.ByteString.Lazy (ByteString)
|
||||||
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
|
import Data.ByteString qualified as BS
|
||||||
|
import Data.Maybe
|
||||||
|
import Network.ByteOrder hiding (ByteString)
|
||||||
|
import Control.Monad.State
|
||||||
|
|
||||||
|
import Codec.Compression.Zstd.Streaming (Result(..))
|
||||||
|
|
||||||
|
import Control.Exception
|
||||||
|
import Lens.Micro.Platform
|
||||||
|
|
||||||
|
-- import UnliftIO
|
||||||
|
|
||||||
|
class ReadLogOpts a where
|
||||||
|
|
||||||
|
data ReadLogError = SomeReadLogError
|
||||||
|
deriving stock (Typeable, Show)
|
||||||
|
|
||||||
|
instance Exception ReadLogError
|
||||||
|
|
||||||
|
instance ReadLogOpts ()
|
||||||
|
|
||||||
|
type NumBytes = Int
|
||||||
|
|
||||||
|
class Monad m => BytesReader m where
|
||||||
|
noBytesLeft :: m Bool
|
||||||
|
readBytes :: NumBytes -> m ByteString
|
||||||
|
|
||||||
|
readBytesMaybe :: NumBytes -> m (Maybe ByteString)
|
||||||
|
readBytesMaybe n = do
|
||||||
|
bs <- readBytes n
|
||||||
|
if LBS.length bs == fromIntegral n then pure (Just bs) else pure Nothing
|
||||||
|
|
||||||
|
newtype ConsumeLBS m a = ConsumeLBS { fromConsumeLBS :: StateT ByteString m a }
|
||||||
|
deriving newtype ( Applicative
|
||||||
|
, Functor
|
||||||
|
, Monad
|
||||||
|
, MonadState ByteString
|
||||||
|
, MonadIO
|
||||||
|
, MonadTrans
|
||||||
|
)
|
||||||
|
|
||||||
|
readChunkThrow :: MonadIO m => Int -> ConsumeLBS m ByteString
|
||||||
|
readChunkThrow n = do
|
||||||
|
lbs <- get
|
||||||
|
let (this, that) = LBS.splitAt (fromIntegral n) lbs
|
||||||
|
if LBS.length this /= fromIntegral n then
|
||||||
|
liftIO $ throwIO SomeReadLogError
|
||||||
|
else do
|
||||||
|
put $! that
|
||||||
|
pure this
|
||||||
|
|
||||||
|
readChunkSimple :: Monad m => Int -> ConsumeLBS m ByteString
|
||||||
|
readChunkSimple n = do
|
||||||
|
lbs <- get
|
||||||
|
let (this, that) = LBS.splitAt (fromIntegral n) lbs
|
||||||
|
put $! that
|
||||||
|
pure this
|
||||||
|
|
||||||
|
reminds :: Monad m => ConsumeLBS m Int
|
||||||
|
reminds = gets (fromIntegral . LBS.length)
|
||||||
|
|
||||||
|
consumed :: Monad m => ConsumeLBS m Bool
|
||||||
|
consumed = gets LBS.null
|
||||||
|
|
||||||
|
runConsumeLBS :: Monad m => ByteString -> ConsumeLBS m a -> m a
|
||||||
|
runConsumeLBS s m = evalStateT (fromConsumeLBS m) s
|
||||||
|
|
||||||
|
newtype ConsumeBS m a = ConsumeBS { fromConsumeBS :: StateT BS.ByteString m a }
|
||||||
|
deriving newtype ( Applicative
|
||||||
|
, Functor
|
||||||
|
, Monad
|
||||||
|
, MonadState BS.ByteString
|
||||||
|
, MonadIO
|
||||||
|
, MonadTrans
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
instance Monad m => BytesReader (ConsumeLBS m) where
|
||||||
|
readBytes = readChunkSimple
|
||||||
|
noBytesLeft = consumed
|
||||||
|
|
||||||
|
instance Monad m => BytesReader (ConsumeBS m) where
|
||||||
|
noBytesLeft = gets BS.null
|
||||||
|
readBytes n = do
|
||||||
|
s <- get
|
||||||
|
let (a,b) = BS.splitAt n s
|
||||||
|
put $! b
|
||||||
|
pure (LBS.fromStrict a)
|
||||||
|
|
||||||
|
{- HLINT ignore "Eta reduce"-}
|
||||||
|
toSectionList :: BS.ByteString -> [BS.ByteString]
|
||||||
|
toSectionList source = go source
|
||||||
|
where
|
||||||
|
go bs | BS.length bs < 4 = []
|
||||||
|
| otherwise = go1 (BS.splitAt 4 bs & over _1 (fromIntegral . N.word32))
|
||||||
|
|
||||||
|
go1 (len,rest) | BS.length rest < len = []
|
||||||
|
|
||||||
|
go1 (len,rest) = do
|
||||||
|
let (sect, rest1) = BS.splitAt len rest
|
||||||
|
sect : go rest1
|
||||||
|
|
||||||
|
validateSorted :: BS.ByteString -> Bool
|
||||||
|
validateSorted bs = do
|
||||||
|
let sections = toSectionList bs
|
||||||
|
let r = flip fix (Nothing, sections, 0) $ \next -> \case
|
||||||
|
(_, [], e) -> e
|
||||||
|
(Nothing, x:xs, e) -> next (Just x, xs, e)
|
||||||
|
(Just v, x:_, e) | v > x -> (e+1)
|
||||||
|
(Just _, x:xs, e) -> next (Just x, xs, e)
|
||||||
|
r == 0
|
||||||
|
|
||||||
|
|
||||||
|
scanBS :: Monad m => BS.ByteString -> ( BS.ByteString -> m () ) -> m ()
|
||||||
|
scanBS bs action = do
|
||||||
|
let hsz = 4
|
||||||
|
flip fix bs $ \next bss -> do
|
||||||
|
if BS.length bss < hsz then pure ()
|
||||||
|
else do
|
||||||
|
let (ssize, rest) = BS.splitAt hsz bss
|
||||||
|
let size = N.word32 ssize & fromIntegral
|
||||||
|
let (sdata, rest2) = BS.splitAt size rest
|
||||||
|
if BS.length sdata < size then
|
||||||
|
pure ()
|
||||||
|
else do
|
||||||
|
action sdata
|
||||||
|
next rest2
|
||||||
|
|
||||||
|
runConsumeBS :: Monad m => BS.ByteString -> ConsumeBS m a -> m a
|
||||||
|
runConsumeBS s m = evalStateT (fromConsumeBS m) s
|
||||||
|
|
||||||
|
|
||||||
|
readSections :: forall m . (MonadIO m, BytesReader m)
|
||||||
|
=> ( Int -> ByteString -> m () )
|
||||||
|
-> m ()
|
||||||
|
|
||||||
|
readSections action = fix \next -> do
|
||||||
|
done <- noBytesLeft
|
||||||
|
if done then
|
||||||
|
pure ()
|
||||||
|
else do
|
||||||
|
ssize <- readBytesMaybe 4
|
||||||
|
>>= orThrow SomeReadLogError
|
||||||
|
<&> fromIntegral . N.word32 . LBS.toStrict
|
||||||
|
|
||||||
|
sdata <- readBytesMaybe ssize
|
||||||
|
>>= orThrow SomeReadLogError
|
||||||
|
|
||||||
|
action ssize sdata
|
||||||
|
next
|
||||||
|
|
||||||
|
writeSection :: forall m . Monad m
|
||||||
|
=> ByteString
|
||||||
|
-> ( ByteString -> m () )
|
||||||
|
-> m ()
|
||||||
|
|
||||||
|
writeSection bs output = do
|
||||||
|
let bssize = bytestring32 (fromIntegral $ LBS.length bs)
|
||||||
|
let section = B.byteString bssize <> B.lazyByteString bs
|
||||||
|
output (B.toLazyByteString section)
|
||||||
|
|
||||||
|
|
||||||
|
writeSections :: forall m . Monad m
|
||||||
|
=> m (Maybe ByteString)
|
||||||
|
-> ( ByteString -> m () )
|
||||||
|
-> m ()
|
||||||
|
|
||||||
|
writeSections source sink = fix \next -> do
|
||||||
|
source >>= maybe none (\bs -> writeSection bs sink >> next)
|
||||||
|
|
||||||
|
|
||||||
|
data CompressedStreamError =
|
||||||
|
CompressedStreamWriteError
|
||||||
|
deriving stock (Typeable,Show)
|
||||||
|
|
||||||
|
instance Exception CompressedStreamError
|
||||||
|
|
||||||
|
writeCompressedChunkZstd :: forall m . MonadIO m
|
||||||
|
=> ( ByteString -> m () )
|
||||||
|
-> Result
|
||||||
|
-> Maybe ByteString
|
||||||
|
-> m Result
|
||||||
|
|
||||||
|
writeCompressedChunkZstd sink stream mlbs = do
|
||||||
|
flip fix ( LBS.toChunks lbs, stream) $ \next -> \case
|
||||||
|
|
||||||
|
([], r@(Done s)) -> sink (LBS.fromStrict s) >> pure r
|
||||||
|
|
||||||
|
(_, Done{}) -> liftIO (throwIO CompressedStreamWriteError)
|
||||||
|
|
||||||
|
(_, Error{})-> liftIO (throwIO CompressedStreamWriteError)
|
||||||
|
|
||||||
|
(w, Produce s continue) -> do
|
||||||
|
sink (LBS.fromStrict s)
|
||||||
|
c <- liftIO continue
|
||||||
|
next (w, c)
|
||||||
|
|
||||||
|
(_, Consume consume) | isNothing mlbs -> do
|
||||||
|
r <- liftIO (consume mempty)
|
||||||
|
next ([], r)
|
||||||
|
|
||||||
|
([], r@(Consume{})) -> pure r
|
||||||
|
|
||||||
|
(x:xs, r@(Consume consume)) -> do
|
||||||
|
what <- liftIO (consume x)
|
||||||
|
next (xs, what)
|
||||||
|
|
||||||
|
where
|
||||||
|
lbs = fromMaybe mempty mlbs
|
||||||
|
|
||||||
|
|
||||||
|
writeCompressedStreamZstd :: forall m . MonadIO m
|
||||||
|
=> Result
|
||||||
|
-> m (Maybe ByteString)
|
||||||
|
-> ( ByteString -> m () )
|
||||||
|
-> m ()
|
||||||
|
writeCompressedStreamZstd stream source sink = do
|
||||||
|
flip fix stream $ \next sn -> do
|
||||||
|
source >>= \case
|
||||||
|
Nothing -> writeCompressedChunkZstd sink sn Nothing >> none
|
||||||
|
Just lbs -> writeCompressedChunkZstd sink sn (Just lbs) >>= next
|
||||||
|
|
||||||
|
|
||||||
|
binarySearchBS :: Monad m
|
||||||
|
=> Int -- ^ record size
|
||||||
|
-> ( BS.ByteString -> BS.ByteString ) -- ^ key extractor
|
||||||
|
-> BS.ByteString -- ^ key
|
||||||
|
-> BS.ByteString -- ^ source
|
||||||
|
-> m (Maybe Int)
|
||||||
|
|
||||||
|
binarySearchBS rs getKey s source = do
|
||||||
|
let maxn = BS.length source `div` rs
|
||||||
|
loop 0 maxn
|
||||||
|
where
|
||||||
|
loop l u | u <= l = pure Nothing
|
||||||
|
| otherwise = do
|
||||||
|
let e = getKey (BS.drop ( k * rs ) source)
|
||||||
|
case compare e s of
|
||||||
|
EQ -> pure $ Just (k * rs)
|
||||||
|
LT -> loop (k+1) u
|
||||||
|
GT -> loop l k
|
||||||
|
|
||||||
|
where k = (l + u) `div` 2
|
||||||
|
|
||||||
|
|
@ -495,6 +495,7 @@ downloadFromPeer bu cache env h peer = liftIO $ withPeerM env do
|
||||||
|
|
||||||
let w0 = 2.0 :: Timeout 'MilliSeconds
|
let w0 = 2.0 :: Timeout 'MilliSeconds
|
||||||
|
|
||||||
|
-- FIXME: possible-busyloop
|
||||||
let watchdog = flip fix 0 \next x -> do
|
let watchdog = flip fix 0 \next x -> do
|
||||||
r <- race (pause @'MilliSeconds wx) do
|
r <- race (pause @'MilliSeconds wx) do
|
||||||
atomically do
|
atomically do
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,48 @@
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import HBS2.Prelude.Plated
|
||||||
|
import HBS2.Storage.NCQ
|
||||||
|
|
||||||
|
import Data.Config.Suckless.Script
|
||||||
|
|
||||||
|
import System.Environment
|
||||||
|
import UnliftIO
|
||||||
|
|
||||||
|
|
||||||
|
runTop :: forall c m . ( IsContext c
|
||||||
|
, NCQPerks m
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, Exception (BadFormException c)
|
||||||
|
) => [Syntax c] -> m ()
|
||||||
|
runTop forms = do
|
||||||
|
|
||||||
|
|
||||||
|
let dict = makeDict @c do
|
||||||
|
|
||||||
|
internalEntries
|
||||||
|
|
||||||
|
entry $ bindMatch "--help" $ nil_ \case
|
||||||
|
HelpEntryBound what -> helpEntry what
|
||||||
|
[StringLike s] -> helpList False (Just s)
|
||||||
|
_ -> helpList False Nothing
|
||||||
|
|
||||||
|
entry $ bindMatch "ncq:init" $ nil_ $ \case
|
||||||
|
[ StringLike path ] -> do
|
||||||
|
ncqStorageInit path
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @c (mkList e)
|
||||||
|
|
||||||
|
tvd <- newTVarIO dict
|
||||||
|
runEval tvd forms >>= eatNil display
|
||||||
|
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
argz <- getArgs
|
||||||
|
|
||||||
|
forms <- parseTop (unlines $ unwords <$> splitForms argz)
|
||||||
|
& either (error.show) pure
|
||||||
|
|
||||||
|
runTop forms
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,154 @@
|
||||||
|
cabal-version: 3.0
|
||||||
|
name: hbs2-storage-ncq
|
||||||
|
version: 0.25.0.1
|
||||||
|
-- synopsis:
|
||||||
|
-- description:
|
||||||
|
license: BSD-3-Clause
|
||||||
|
license-file: LICENSE
|
||||||
|
-- author:
|
||||||
|
-- maintainer:
|
||||||
|
-- copyright:
|
||||||
|
category: Database
|
||||||
|
build-type: Simple
|
||||||
|
-- extra-doc-files: CHANGELOG.md
|
||||||
|
-- extra-source-files:
|
||||||
|
|
||||||
|
common shared-properties
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-- -fno-warn-unused-matches
|
||||||
|
-- -fno-warn-unused-do-bind
|
||||||
|
-- -Werror=missing-methods
|
||||||
|
-- -Werror=incomplete-patterns
|
||||||
|
-- -fno-warn-unused-binds
|
||||||
|
-- -threaded
|
||||||
|
-- -rtsopts
|
||||||
|
-- "-with-rtsopts=-N4 -A64m -AL256m -I0"
|
||||||
|
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
default-extensions:
|
||||||
|
ApplicativeDo
|
||||||
|
, BangPatterns
|
||||||
|
, BlockArguments
|
||||||
|
, ConstraintKinds
|
||||||
|
, DataKinds
|
||||||
|
, DeriveDataTypeable
|
||||||
|
, DeriveGeneric
|
||||||
|
, DerivingStrategies
|
||||||
|
, DerivingVia
|
||||||
|
, ExtendedDefaultRules
|
||||||
|
, FlexibleContexts
|
||||||
|
, FlexibleInstances
|
||||||
|
, GADTs
|
||||||
|
, GeneralizedNewtypeDeriving
|
||||||
|
, ImportQualifiedPost
|
||||||
|
, LambdaCase
|
||||||
|
, MultiParamTypeClasses
|
||||||
|
, OverloadedStrings
|
||||||
|
, QuasiQuotes
|
||||||
|
, ScopedTypeVariables
|
||||||
|
, StandaloneDeriving
|
||||||
|
, TupleSections
|
||||||
|
, TypeApplications
|
||||||
|
, TypeOperators
|
||||||
|
, TypeFamilies
|
||||||
|
|
||||||
|
|
||||||
|
library
|
||||||
|
import: shared-properties
|
||||||
|
exposed-modules: HBS2.Storage.NCQ
|
||||||
|
-- other-modules:
|
||||||
|
-- other-extensions:
|
||||||
|
build-depends: base, hbs2-core, hbs2-log-structured, suckless-conf
|
||||||
|
, async
|
||||||
|
, binary
|
||||||
|
, bytestring
|
||||||
|
, bytestring-mmap
|
||||||
|
, containers
|
||||||
|
, directory
|
||||||
|
, filepath
|
||||||
|
, filepattern
|
||||||
|
, memory
|
||||||
|
, microlens-platform
|
||||||
|
, mmap
|
||||||
|
, mtl
|
||||||
|
, network-byte-order
|
||||||
|
, prettyprinter
|
||||||
|
, psqueues
|
||||||
|
, random
|
||||||
|
, safe
|
||||||
|
, serialise
|
||||||
|
, stm
|
||||||
|
, stm-chans
|
||||||
|
, streaming
|
||||||
|
, temporary
|
||||||
|
, time
|
||||||
|
, text
|
||||||
|
, transformers
|
||||||
|
, uniplate
|
||||||
|
, unix
|
||||||
|
, unliftio
|
||||||
|
, unordered-containers
|
||||||
|
, vector
|
||||||
|
|
||||||
|
|
||||||
|
hs-source-dirs: lib
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
|
||||||
|
executable hbs2-ncq
|
||||||
|
import: shared-properties
|
||||||
|
|
||||||
|
ghc-options:
|
||||||
|
-Wall
|
||||||
|
-- -fno-warn-unused-matches
|
||||||
|
-- -fno-warn-unused-do-bind
|
||||||
|
-- -Werror=missing-methods
|
||||||
|
-- -Werror=incomplete-patterns
|
||||||
|
-- -fno-warn-unused-binds
|
||||||
|
-threaded
|
||||||
|
-rtsopts
|
||||||
|
"-with-rtsopts=-N8 -A64m -AL256m -I0"
|
||||||
|
|
||||||
|
main-is: Main.hs
|
||||||
|
-- other-modules:
|
||||||
|
-- other-extensions:
|
||||||
|
build-depends: base, hbs2-core, hbs2-storage-ncq, suckless-conf
|
||||||
|
, aeson
|
||||||
|
, async
|
||||||
|
, base58-bytestring
|
||||||
|
, binary
|
||||||
|
, bytestring
|
||||||
|
, cborg
|
||||||
|
, clock
|
||||||
|
, containers
|
||||||
|
, directory
|
||||||
|
, filepath
|
||||||
|
, hashable
|
||||||
|
, memory
|
||||||
|
, microlens-platform
|
||||||
|
, mtl
|
||||||
|
, optparse-applicative
|
||||||
|
, prettyprinter
|
||||||
|
, random
|
||||||
|
, safe
|
||||||
|
, serialise
|
||||||
|
, streaming
|
||||||
|
, split
|
||||||
|
, text
|
||||||
|
, temporary
|
||||||
|
, transformers
|
||||||
|
, uniplate
|
||||||
|
, timeit
|
||||||
|
, stm
|
||||||
|
, unliftio
|
||||||
|
, network-byte-order
|
||||||
|
, unordered-containers
|
||||||
|
|
||||||
|
hs-source-dirs: app
|
||||||
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -0,0 +1,757 @@
|
||||||
|
{-# Language RecordWildCards #-}
|
||||||
|
module HBS2.Storage.NCQ where
|
||||||
|
|
||||||
|
import HBS2.Prelude.Plated
|
||||||
|
import HBS2.Hash
|
||||||
|
import HBS2.Data.Types.Refs
|
||||||
|
import HBS2.Base58
|
||||||
|
import HBS2.Storage
|
||||||
|
import HBS2.Misc.PrettyStuff
|
||||||
|
import HBS2.System.Logger.Simple.ANSI
|
||||||
|
|
||||||
|
import HBS2.Data.Log.Structured.NCQ
|
||||||
|
import HBS2.Data.Log.Structured.SD
|
||||||
|
|
||||||
|
import Data.Config.Suckless.System
|
||||||
|
import Data.Config.Suckless.Script hiding (void)
|
||||||
|
|
||||||
|
import Control.Applicative
|
||||||
|
import Data.ByteString.Builder
|
||||||
|
import Network.ByteOrder qualified as N
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Control.Monad.Trans.Cont
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
|
import Control.Concurrent.STM qualified as STM
|
||||||
|
import Control.Concurrent.STM.TSem
|
||||||
|
import Data.HashPSQ qualified as HPSQ
|
||||||
|
import Data.HashPSQ (HashPSQ)
|
||||||
|
import Data.IntMap qualified as IntMap
|
||||||
|
import Data.IntMap (IntMap)
|
||||||
|
import Data.Sequence as Seq
|
||||||
|
import Data.List qualified as List
|
||||||
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.ByteString qualified as BS
|
||||||
|
import Data.ByteString.Char8 qualified as BS8
|
||||||
|
import Data.Char (isDigit)
|
||||||
|
import Data.Coerce
|
||||||
|
import Data.Word
|
||||||
|
import Data.Either
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Text qualified as Text
|
||||||
|
import Data.Text.IO qualified as Text
|
||||||
|
import Lens.Micro.Platform
|
||||||
|
import Data.HashSet (HashSet)
|
||||||
|
import Data.HashSet qualified as HS
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
import System.FilePath.Posix
|
||||||
|
import System.Posix.Fcntl
|
||||||
|
import System.Posix.Files qualified as Posix
|
||||||
|
import System.Posix.IO as PosixBase
|
||||||
|
import System.Posix.Types as Posix
|
||||||
|
import System.Posix.IO.ByteString as Posix
|
||||||
|
import System.Posix.Unistd
|
||||||
|
import System.IO.MMap as MMap
|
||||||
|
import System.IO.Temp (emptyTempFile)
|
||||||
|
-- import Foreign.Ptr
|
||||||
|
-- import Foreign di
|
||||||
|
import qualified Data.ByteString.Internal as BSI
|
||||||
|
import Streaming.Prelude qualified as S
|
||||||
|
|
||||||
|
import UnliftIO
|
||||||
|
import UnliftIO.Concurrent(getNumCapabilities)
|
||||||
|
import UnliftIO.IO.File
|
||||||
|
|
||||||
|
{- HLINT ignore "Functor law" -}
|
||||||
|
|
||||||
|
type NCQPerks m = MonadIO m
|
||||||
|
|
||||||
|
data NCQStorageException =
|
||||||
|
NCQStorageAlreadyExist String
|
||||||
|
deriving stock (Show,Typeable)
|
||||||
|
|
||||||
|
instance Exception NCQStorageException
|
||||||
|
|
||||||
|
|
||||||
|
newtype FileKey = FileKey ByteString
|
||||||
|
deriving newtype (Eq,Ord,Hashable,Show)
|
||||||
|
|
||||||
|
instance IsString FileKey where
|
||||||
|
fromString = FileKey . BS8.pack . dropExtension . takeFileName
|
||||||
|
|
||||||
|
instance Pretty FileKey where
|
||||||
|
pretty (FileKey s) = parens ("file-key" <+> pretty (BS8.unpack s))
|
||||||
|
|
||||||
|
data NCQStorage =
|
||||||
|
NCQStorage
|
||||||
|
{ ncqRoot :: FilePath
|
||||||
|
, ncqGen :: Int
|
||||||
|
, ncqSyncSize :: Int
|
||||||
|
, ncqMinLog :: Int
|
||||||
|
, ncqMaxLog :: Int
|
||||||
|
, ncqMaxCachedIdx :: Int
|
||||||
|
, ncqMaxCachedData :: Int
|
||||||
|
, ncqRefsMem :: TVar (HashMap HashRef HashRef)
|
||||||
|
, ncqRefsDirty :: TVar Bool
|
||||||
|
, ncqWriteQueue :: TVar (HashPSQ HashRef TimeSpec LBS.ByteString)
|
||||||
|
, ncqWaitIndex :: TVar (HashPSQ HashRef TimeSpec (Word64,Word64))
|
||||||
|
, ncqTrackedFiles :: TVar (HashSet FileKey)
|
||||||
|
, ncqCachedIndexes :: TVar (HashPSQ FileKey TimeSpec (ByteString,NWayHash))
|
||||||
|
, ncqCachedData :: TVar (HashPSQ FileKey TimeSpec ByteString)
|
||||||
|
, ncqNotWritten :: TVar Word64
|
||||||
|
, ncqLastWritten :: TVar TimeSpec
|
||||||
|
, ncqCurrentHandleW :: TVar Fd
|
||||||
|
, ncqCurrentHandleR :: TVar Fd
|
||||||
|
, ncqCurrentUsage :: TVar (IntMap Int)
|
||||||
|
, ncqCurrentReadReq :: TVar (Seq (Fd, Word64, Word64, TMVar ByteString))
|
||||||
|
, ncqFlushNow :: TQueue ()
|
||||||
|
, ncqOpenDone :: TMVar Bool
|
||||||
|
, ncqStopped :: TVar Bool
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
data Location =
|
||||||
|
InWriteQueue LBS.ByteString
|
||||||
|
| InCurrent (Word64, Word64)
|
||||||
|
| InFossil FileKey (Word64, Word64)
|
||||||
|
deriving stock (Eq,Show)
|
||||||
|
|
||||||
|
instance Pretty Location where
|
||||||
|
pretty = \case
|
||||||
|
InWriteQueue{} -> "write-queue"
|
||||||
|
InCurrent (o,l) -> pretty $ mkForm @C "current" [mkInt o, mkInt l]
|
||||||
|
InFossil f (o,l) -> pretty $ mkForm @C "fossil " [mkSym (show (pretty f)), mkList [mkInt o, mkInt l]]
|
||||||
|
|
||||||
|
type IsHCQKey h = ( Eq (Key h)
|
||||||
|
, Hashable (Key h)
|
||||||
|
, IsKey h
|
||||||
|
, Key h ~ Hash h
|
||||||
|
, ToByteString (AsBase58 (Hash h))
|
||||||
|
, FromByteString (AsBase58 (Hash h))
|
||||||
|
)
|
||||||
|
|
||||||
|
ncqGetCurrentName_ :: FilePath -> Int -> FilePath
|
||||||
|
ncqGetCurrentName_ root gen = root </> show (pretty gen) </> "current.data"
|
||||||
|
|
||||||
|
ncqGetFileName :: NCQStorage -> FilePath -> FilePath
|
||||||
|
ncqGetFileName NCQStorage{..} f = ncqRoot </> show (pretty ncqGen) </> takeFileName f
|
||||||
|
|
||||||
|
ncqGetCurrentName :: NCQStorage -> FilePath
|
||||||
|
ncqGetCurrentName NCQStorage{..} = ncqGetCurrentName_ ncqRoot ncqGen
|
||||||
|
|
||||||
|
ncqGetCurrentDir :: NCQStorage -> FilePath
|
||||||
|
ncqGetCurrentDir ncq = takeDirectory (ncqGetCurrentName ncq)
|
||||||
|
|
||||||
|
ncqGetCurrentSizeName_ :: FilePath -> Int -> FilePath
|
||||||
|
ncqGetCurrentSizeName_ root gen = dropExtension (ncqGetCurrentName_ root gen) <> ".size"
|
||||||
|
|
||||||
|
ncqGetCurrentSizeName :: NCQStorage -> FilePath
|
||||||
|
ncqGetCurrentSizeName NCQStorage{..} = dropExtension (ncqGetCurrentName_ ncqRoot ncqGen) <> ".size"
|
||||||
|
|
||||||
|
ncqGetNewFossilName :: MonadIO m => NCQStorage -> m FilePath
|
||||||
|
ncqGetNewFossilName n@NCQStorage{} = do
|
||||||
|
let fn = ncqGetFileName n "fossil-.data"
|
||||||
|
let (p,tpl) = splitFileName fn
|
||||||
|
liftIO $ emptyTempFile p tpl
|
||||||
|
|
||||||
|
ncqGetIndexFileName :: NCQStorage -> FileKey -> FilePath
|
||||||
|
ncqGetIndexFileName ncq fk = do
|
||||||
|
ncqGetFileName ncq (addExtension (dropExtension (BS8.unpack (coerce fk))) ".cq")
|
||||||
|
|
||||||
|
ncqGetDataFileName :: NCQStorage -> FileKey -> FilePath
|
||||||
|
ncqGetDataFileName ncq fk = do
|
||||||
|
ncqGetFileName ncq (addExtension (dropExtension (BS8.unpack (coerce fk))) ".data")
|
||||||
|
|
||||||
|
ncqGetErrorLogName :: NCQStorage -> FilePath
|
||||||
|
ncqGetErrorLogName ncq = do
|
||||||
|
ncqGetFileName ncq "errors.log"
|
||||||
|
|
||||||
|
-- ncqCheckCurrentSize :: MonadIO m => NCQStorage -> m (Either Integer Integer)
|
||||||
|
-- ncqCheckCurrentSize ncq = liftIO $ readCurrent `catch` (\(_ :: IOError) -> pure $ Left 0)
|
||||||
|
-- where
|
||||||
|
-- readCurrent = do
|
||||||
|
-- let name = ncqGetCurrentName ncq
|
||||||
|
-- a <- liftIO (BS.readFile (ncqGetCurrentSizeName ncq)) <&> N.word64
|
||||||
|
-- b <- fileSize name
|
||||||
|
-- pure $ if a == fromIntegral b then Right (fromIntegral a) else Left (fromIntegral a)
|
||||||
|
|
||||||
|
|
||||||
|
ncqAddCachedSTM :: TimeSpec -- ^ now
|
||||||
|
-> Int -- ^ limit
|
||||||
|
-> TVar (HashPSQ FileKey TimeSpec a) -- ^ entry
|
||||||
|
-> FileKey -- ^ key
|
||||||
|
-> a -- ^ value
|
||||||
|
-> STM ()
|
||||||
|
ncqAddCachedSTM now limit tv k v = do
|
||||||
|
|
||||||
|
cache <- readTVar tv
|
||||||
|
|
||||||
|
unless (HPSQ.member k cache) do
|
||||||
|
|
||||||
|
let dst = if HPSQ.size cache + 1 > limit then
|
||||||
|
maybe cache (view _4) (HPSQ.minView cache)
|
||||||
|
else
|
||||||
|
cache
|
||||||
|
|
||||||
|
writeTVar tv (HPSQ.insert k now v dst)
|
||||||
|
|
||||||
|
|
||||||
|
ncqAddTrackedFilesSTM :: NCQStorage -> [FileKey] -> STM ()
|
||||||
|
ncqAddTrackedFilesSTM NCQStorage{..} keys = do
|
||||||
|
modifyTVar ncqTrackedFiles (HS.union (HS.fromList keys))
|
||||||
|
|
||||||
|
ncqReadTrackedFiles :: MonadIO m => NCQStorage -> m ()
|
||||||
|
ncqReadTrackedFiles ncq@NCQStorage{} = do
|
||||||
|
|
||||||
|
files <- dirFiles (ncqGetCurrentDir ncq)
|
||||||
|
>>= mapM (pure . takeBaseName)
|
||||||
|
<&> List.filter (List.isPrefixOf "fossil-")
|
||||||
|
<&> fmap fromString
|
||||||
|
|
||||||
|
atomically $ ncqAddTrackedFilesSTM ncq files
|
||||||
|
|
||||||
|
ncqWriteError :: MonadIO m => NCQStorage -> Text -> m ()
|
||||||
|
ncqWriteError ncq txt = liftIO do
|
||||||
|
p <- getPOSIXTime <&> round @_ @Integer
|
||||||
|
let msg = Text.pack $ show $ "error" <+> fill 12 (pretty p) <+> pretty txt <> line
|
||||||
|
Text.appendFile (ncqGetErrorLogName ncq) msg
|
||||||
|
|
||||||
|
ncqIndexFile :: MonadUnliftIO m => NCQStorage -> FilePath -> m FilePath
|
||||||
|
ncqIndexFile n@NCQStorage{} fp' = do
|
||||||
|
|
||||||
|
let fp = ncqGetFileName n fp'
|
||||||
|
& takeBaseName
|
||||||
|
& (`addExtension` ".cq")
|
||||||
|
& ncqGetFileName n
|
||||||
|
|
||||||
|
items <- S.toList_ do
|
||||||
|
ncqStorageScanDataFile n fp' $ \o w k v -> do
|
||||||
|
let rs = w - 32 & fromIntegral @_ @Word32 & N.bytestring32
|
||||||
|
let os = fromIntegral @_ @Word64 o & N.bytestring64
|
||||||
|
let record = os <> rs
|
||||||
|
-- debug $ "write record" <+> pretty (BS.length record)
|
||||||
|
S.yield (coerce k, record)
|
||||||
|
|
||||||
|
let (dir,name) = splitFileName fp
|
||||||
|
|
||||||
|
result <- nwayWriteBatch (nwayAllocDef 1.10 32 8 12) dir name items
|
||||||
|
|
||||||
|
mv result fp
|
||||||
|
|
||||||
|
pure fp
|
||||||
|
|
||||||
|
ncqStorageStop :: MonadUnliftIO m => NCQStorage -> m ()
|
||||||
|
ncqStorageStop ncq@NCQStorage{..} = do
|
||||||
|
atomically $ writeTVar ncqStopped True
|
||||||
|
ncqStorageSync ncq
|
||||||
|
atomically $ fix \next -> do
|
||||||
|
done <- readTVar ncqWriteQueue <&> HPSQ.null
|
||||||
|
unless done STM.retry
|
||||||
|
|
||||||
|
ncqStorageRun :: MonadUnliftIO m => NCQStorage -> m ()
|
||||||
|
ncqStorageRun ncq@NCQStorage{..} = flip runContT pure do
|
||||||
|
|
||||||
|
let dumpTimeout = round 10e6
|
||||||
|
let dumpData = 1024 ^ 2
|
||||||
|
let syncData = fromIntegral ncqSyncSize
|
||||||
|
|
||||||
|
ContT $ bracket none $ const $ liftIO do
|
||||||
|
-- writeJournal syncData
|
||||||
|
readTVarIO ncqCurrentHandleW >>= closeFd
|
||||||
|
|
||||||
|
debug "RUNNING STORAGE!"
|
||||||
|
|
||||||
|
-- cap <- (10*) <$> getNumCapabilities
|
||||||
|
cap <- getNumCapabilities
|
||||||
|
|
||||||
|
reader <- ContT $ withAsync $ forever do
|
||||||
|
|
||||||
|
reqs <- atomically do
|
||||||
|
xs <- stateTVar ncqCurrentReadReq (Seq.splitAt cap)
|
||||||
|
when (List.null xs) STM.retry
|
||||||
|
pure xs
|
||||||
|
|
||||||
|
for_ reqs $ \(fd,off,l,answ) -> liftIO do
|
||||||
|
atomically $ modifyTVar ncqCurrentUsage (IntMap.adjust pred (fromIntegral fd))
|
||||||
|
fdSeek fd AbsoluteSeek (fromIntegral $ 4 + 32 + off)
|
||||||
|
bs <- Posix.fdRead fd (fromIntegral l)
|
||||||
|
atomically $ putTMVar answ bs
|
||||||
|
|
||||||
|
link reader
|
||||||
|
|
||||||
|
indexQ <- newTQueueIO
|
||||||
|
|
||||||
|
indexer <- ContT $ withAsync $ forever do
|
||||||
|
(fd, fn) <- atomically (readTQueue indexQ)
|
||||||
|
key <- ncqIndexFile ncq fn <&> fromString @FileKey
|
||||||
|
|
||||||
|
atomically do
|
||||||
|
ncqAddTrackedFilesSTM ncq [key]
|
||||||
|
modifyTVar ncqCurrentUsage (IntMap.adjust pred (fromIntegral fd))
|
||||||
|
|
||||||
|
ncqLoadSomeIndexes ncq [key]
|
||||||
|
|
||||||
|
link indexer
|
||||||
|
|
||||||
|
fix \loop -> do
|
||||||
|
|
||||||
|
flush <- liftIO $ race (pause @'Seconds ( realToFrac dumpTimeout / 4e6 )) $ atomically do
|
||||||
|
peekTQueue ncqFlushNow >> STM.flushTQueue ncqFlushNow
|
||||||
|
pure True
|
||||||
|
|
||||||
|
let flushNow = fromRight False flush
|
||||||
|
|
||||||
|
now <- getTimeCoarse
|
||||||
|
lastW <- readTVarIO ncqLastWritten
|
||||||
|
bytes <- readTVarIO ncqNotWritten
|
||||||
|
|
||||||
|
let dumpByTime = toMicroSeconds (TimeoutTS (now - lastW)) > dumpTimeout && bytes > 0
|
||||||
|
|
||||||
|
when (dumpByTime || bytes >= dumpData || flushNow) do
|
||||||
|
-- debug "NCQStorage: dump data!"
|
||||||
|
liftIO $ writeJournal indexQ syncData
|
||||||
|
|
||||||
|
done <- atomically do
|
||||||
|
mt <- readTVar ncqWriteQueue <&> HPSQ.null
|
||||||
|
stop <- readTVar ncqStopped
|
||||||
|
pure (mt && stop)
|
||||||
|
|
||||||
|
unless done loop
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
writeJournal indexQ syncData = liftIO do
|
||||||
|
|
||||||
|
trace $ "writeJournal" <+> pretty syncData
|
||||||
|
|
||||||
|
fh <- readTVarIO ncqCurrentHandleW
|
||||||
|
|
||||||
|
fdSeek fh SeekFromEnd 0
|
||||||
|
|
||||||
|
init <- readTVarIO ncqWriteQueue
|
||||||
|
|
||||||
|
wResult <- flip fix (0,init) \next (written,q) -> case HPSQ.minView q of
|
||||||
|
Nothing -> pure mempty
|
||||||
|
Just (h,_,bs,rest) -> do
|
||||||
|
|
||||||
|
off <- fdSeek fh SeekFromEnd 0
|
||||||
|
let b = byteString (coerce @_ @ByteString h) <> lazyByteString bs
|
||||||
|
let wbs = toLazyByteString b
|
||||||
|
let len = LBS.length wbs
|
||||||
|
let ws = N.bytestring32 (fromIntegral len)
|
||||||
|
let w = 4 + len
|
||||||
|
|
||||||
|
liftIO (Posix.fdWrite fh (ws <> LBS.toStrict wbs))
|
||||||
|
|
||||||
|
let kks = LBS.take 32 (toLazyByteString b) & coerce @_ @HashRef . LBS.toStrict
|
||||||
|
-- debug $ "WRITE SHIT!" <+> pretty len <+> pretty kks <+> pretty (LBS.length bs)
|
||||||
|
|
||||||
|
written' <- if written < syncData then do
|
||||||
|
pure (written + w)
|
||||||
|
else do
|
||||||
|
fileSynchronise fh
|
||||||
|
pure 0
|
||||||
|
|
||||||
|
((h, (fromIntegral off, fromIntegral len)) : ) <$> next (written', rest)
|
||||||
|
|
||||||
|
fileSynchronise fh
|
||||||
|
size <- fdSeek fh SeekFromEnd 0
|
||||||
|
|
||||||
|
now1 <- getTimeCoarse
|
||||||
|
atomically do
|
||||||
|
q0 <- readTVar ncqWriteQueue
|
||||||
|
w0 <- readTVar ncqWaitIndex
|
||||||
|
b0 <- readTVar ncqNotWritten
|
||||||
|
|
||||||
|
wbytes <- newTVar 0
|
||||||
|
|
||||||
|
(rq,rw) <- flip fix (q0,w0,wResult) \next (q,w,r) -> do
|
||||||
|
case r of
|
||||||
|
[] -> pure (q,w)
|
||||||
|
((h,(o,l)):xs) -> do
|
||||||
|
modifyTVar wbytes (+l)
|
||||||
|
next (HPSQ.delete h q, HPSQ.insert h now1 (o,l) w,xs)
|
||||||
|
|
||||||
|
writeTVar ncqWriteQueue rq
|
||||||
|
writeTVar ncqWaitIndex rw
|
||||||
|
bw <- readTVar wbytes
|
||||||
|
writeTVar ncqNotWritten (max 0 (b0 - bw))
|
||||||
|
|
||||||
|
writeBinaryFileDurable (ncqGetCurrentSizeName ncq) (N.bytestring64 (fromIntegral size))
|
||||||
|
|
||||||
|
when (fromIntegral size >= ncqMinLog) do
|
||||||
|
|
||||||
|
(n,u) <- atomically do
|
||||||
|
r <- readTVar ncqCurrentHandleR <&> fromIntegral
|
||||||
|
u <- readTVar ncqCurrentUsage <&> fromMaybe 0 . IntMap.lookup r
|
||||||
|
pure (fromIntegral @_ @Word32 r, u)
|
||||||
|
|
||||||
|
let current = ncqGetCurrentName ncq
|
||||||
|
|
||||||
|
fossilized <- ncqGetNewFossilName ncq
|
||||||
|
|
||||||
|
warn $ "NEED TRUNCATE" <+> pretty current <+> viaShow size <+> pretty n <+> pretty u
|
||||||
|
|
||||||
|
mv current fossilized
|
||||||
|
|
||||||
|
atomically do
|
||||||
|
r <- readTVar ncqCurrentHandleR
|
||||||
|
-- NOTE: extra-use
|
||||||
|
-- добавляем лишний 1 для индексации.
|
||||||
|
-- исходный файл закрываем, только когда проиндексировано.
|
||||||
|
-- то есть должны отнять 1 после индексации.
|
||||||
|
modifyTVar ncqCurrentUsage (IntMap.insertWith (+) (fromIntegral r) 1)
|
||||||
|
writeTQueue indexQ (r, fossilized)
|
||||||
|
|
||||||
|
let flags = defaultFileFlags { exclusive = True }
|
||||||
|
|
||||||
|
touch current
|
||||||
|
writeBinaryFileDurable (ncqGetCurrentSizeName ncq) (N.bytestring64 0)
|
||||||
|
|
||||||
|
liftIO (PosixBase.openFd current Posix.ReadWrite flags)
|
||||||
|
>>= atomically . writeTVar ncqCurrentHandleW
|
||||||
|
|
||||||
|
liftIO (PosixBase.openFd current Posix.ReadWrite flags)
|
||||||
|
>>= atomically . writeTVar ncqCurrentHandleR
|
||||||
|
|
||||||
|
debug $ "TRUNCATED, moved to" <+> pretty fossilized
|
||||||
|
|
||||||
|
toClose <- atomically do
|
||||||
|
w <- readTVar ncqCurrentUsage <&> IntMap.toList
|
||||||
|
let (alive,dead) = List.partition( (>0) . snd) w
|
||||||
|
writeTVar ncqCurrentUsage (IntMap.fromList alive)
|
||||||
|
pure dead
|
||||||
|
|
||||||
|
for_ toClose $ \(f,_) -> do
|
||||||
|
when (f > 0) do
|
||||||
|
debug $ "CLOSE FD" <+> pretty f
|
||||||
|
Posix.closeFd (fromIntegral f)
|
||||||
|
|
||||||
|
ncqStoragePut :: MonadUnliftIO m => NCQStorage -> LBS.ByteString -> m (Maybe HashRef)
|
||||||
|
ncqStoragePut ncq@NCQStorage{..} lbs = flip runContT pure $ callCC \exit -> do
|
||||||
|
|
||||||
|
stoped <- readTVarIO ncqStopped
|
||||||
|
|
||||||
|
when stoped $ exit Nothing
|
||||||
|
|
||||||
|
let h = hashObject @HbSync lbs & coerce
|
||||||
|
|
||||||
|
ncqLocate ncq h >>= \case
|
||||||
|
Just{} -> exit (Just h)
|
||||||
|
_ -> none
|
||||||
|
|
||||||
|
now <- getTimeCoarse
|
||||||
|
atomically do
|
||||||
|
ql <- readTVar ncqWriteQueue <&> HPSQ.size
|
||||||
|
-- FIXME: hardcode
|
||||||
|
when (ql > 8192) STM.retry
|
||||||
|
modifyTVar ncqWriteQueue (HPSQ.insert h now lbs)
|
||||||
|
modifyTVar ncqNotWritten (+ (fromIntegral $ 36 + LBS.length lbs))
|
||||||
|
pure (Just h)
|
||||||
|
|
||||||
|
ncqLocatedSize :: Location -> Integer
|
||||||
|
ncqLocatedSize = \case
|
||||||
|
InWriteQueue lbs -> fromIntegral $ LBS.length lbs
|
||||||
|
InCurrent (_,s) -> fromIntegral s
|
||||||
|
InFossil _ (_,s) -> fromIntegral s
|
||||||
|
|
||||||
|
ncqLocate :: MonadIO m => NCQStorage -> HashRef -> m (Maybe Location)
|
||||||
|
ncqLocate ncq@NCQStorage{..} h = flip runContT pure $ callCC \exit -> do
|
||||||
|
|
||||||
|
l1 <- atomically do
|
||||||
|
inQ <- readTVar ncqWriteQueue <&> (fmap snd . HPSQ.lookup h) <&> fmap InWriteQueue
|
||||||
|
inC <- readTVar ncqWaitIndex <&> (fmap snd . HPSQ.lookup h) <&> fmap InCurrent
|
||||||
|
pure (inQ <|> inC)
|
||||||
|
|
||||||
|
for_ l1 $ exit . Just
|
||||||
|
|
||||||
|
now <- getTimeCoarse
|
||||||
|
|
||||||
|
(cachedIdx, rest) <- atomically do
|
||||||
|
cached <- readTVar ncqCachedIndexes
|
||||||
|
other' <- readTVar ncqTrackedFiles <&> HS.toList
|
||||||
|
let other = [ x | x <- other', not (HPSQ.member x cached) ]
|
||||||
|
pure (cached, other)
|
||||||
|
|
||||||
|
|
||||||
|
for_ (HPSQ.toList cachedIdx) $ \(fk,_,nway) -> do
|
||||||
|
lookupEntry h nway <&> fmap (InFossil fk) >>= \case
|
||||||
|
Nothing -> pure Nothing -- none
|
||||||
|
other -> do
|
||||||
|
atomically $ modifyTVar ncqCachedIndexes (HPSQ.insert fk now nway)
|
||||||
|
exit other
|
||||||
|
|
||||||
|
-- TODO: use-filter-for-faster-scan
|
||||||
|
-- 1. Какой фильтр?
|
||||||
|
-- 2. Как и когда его перестраивать?
|
||||||
|
-- 2.1 На открытии? Будет расти время открытия (но можно параллельно)
|
||||||
|
--
|
||||||
|
|
||||||
|
for_ rest $ \r -> runMaybeT do
|
||||||
|
let fn = ncqGetIndexFileName ncq r
|
||||||
|
|
||||||
|
nway' <- liftIO (nwayHashMMapReadOnly fn)
|
||||||
|
|
||||||
|
when (isNothing nway') do
|
||||||
|
err ("NCQStorage: can't mmap file" <+> pretty fn)
|
||||||
|
|
||||||
|
nway <- toMPlus nway'
|
||||||
|
|
||||||
|
e <- lookupEntry h nway <&> fmap (InFossil r) >>= toMPlus
|
||||||
|
|
||||||
|
liftIO (mmapFileByteString (ncqGetDataFileName ncq r) Nothing) >>= \mmaped ->
|
||||||
|
atomically do
|
||||||
|
ncqAddCachedSTM now ncqMaxCachedIdx ncqCachedIndexes r nway
|
||||||
|
ncqAddCachedSTM now ncqMaxCachedData ncqCachedData r mmaped
|
||||||
|
|
||||||
|
lift (exit (Just e))
|
||||||
|
|
||||||
|
pure Nothing
|
||||||
|
|
||||||
|
where
|
||||||
|
|
||||||
|
lookupEntry (hx :: HashRef) (mmaped, nway) = runMaybeT do
|
||||||
|
|
||||||
|
entryBs <- liftIO (nwayHashLookup nway mmaped (coerce hx))
|
||||||
|
>>= toMPlus
|
||||||
|
|
||||||
|
pure $ ( fromIntegral $ N.word64 (BS.take 8 entryBs),
|
||||||
|
fromIntegral $ N.word32 (BS.take 4 (BS.drop 8 entryBs)))
|
||||||
|
|
||||||
|
ncqStorageHasBlock :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe Integer)
|
||||||
|
ncqStorageHasBlock ncq h = ncqLocate ncq h <&> fmap ncqLocatedSize
|
||||||
|
|
||||||
|
ncqStorageScanDataFile :: MonadIO m
|
||||||
|
=> NCQStorage
|
||||||
|
-> FilePath
|
||||||
|
-> ( Integer -> Integer -> HashRef -> ByteString -> m () )
|
||||||
|
-> m ()
|
||||||
|
ncqStorageScanDataFile ncq fp' action = do
|
||||||
|
let fp = ncqGetFileName ncq fp'
|
||||||
|
mmaped <- liftIO (mmapFileByteString fp Nothing)
|
||||||
|
|
||||||
|
flip runContT pure $ callCC \exit -> do
|
||||||
|
flip fix (0,mmaped) $ \next (o,bs) -> do
|
||||||
|
|
||||||
|
when (BS.length bs < 4) $ exit ()
|
||||||
|
|
||||||
|
let w = BS.take 4 bs & N.word32 & fromIntegral
|
||||||
|
|
||||||
|
when (BS.length bs < 4 + w) $ exit ()
|
||||||
|
|
||||||
|
let kv = BS.drop 4 bs
|
||||||
|
|
||||||
|
let k = BS.take 32 kv & coerce @_ @HashRef
|
||||||
|
let v = BS.take (w-32) $ BS.drop 32 kv
|
||||||
|
|
||||||
|
lift (action o (fromIntegral w) k v)
|
||||||
|
|
||||||
|
next (4 + o + fromIntegral w, BS.drop (w+4) bs)
|
||||||
|
|
||||||
|
ncqStorageGet :: MonadUnliftIO m => NCQStorage -> HashRef -> m (Maybe LBS.ByteString)
|
||||||
|
ncqStorageGet ncq@NCQStorage{..} h = do
|
||||||
|
|
||||||
|
ncqLocate ncq h >>= \case
|
||||||
|
Nothing -> pure Nothing
|
||||||
|
Just (InWriteQueue lbs) -> pure $ Just lbs
|
||||||
|
|
||||||
|
Just (InCurrent (o,l)) -> do
|
||||||
|
-- FIXME: timeout!
|
||||||
|
answ <- atomically do
|
||||||
|
a <- newEmptyTMVar
|
||||||
|
fd <- readTVar ncqCurrentHandleR
|
||||||
|
modifyTVar ncqCurrentUsage (IntMap.insertWith (+) (fromIntegral fd) 1)
|
||||||
|
modifyTVar ncqCurrentReadReq ( |> (fd, o, l, a) )
|
||||||
|
pure a
|
||||||
|
atomically $ takeTMVar answ <&> Just . LBS.fromStrict
|
||||||
|
|
||||||
|
Just (InFossil key (o,l)) -> do
|
||||||
|
|
||||||
|
mmaped <- readTVarIO ncqCachedData <&> HPSQ.lookup key >>= \case
|
||||||
|
Just (_,mmaped) -> do
|
||||||
|
now <- getTimeCoarse
|
||||||
|
atomically $ modifyTVar ncqCachedData (HPSQ.insert key now mmaped)
|
||||||
|
pure mmaped
|
||||||
|
|
||||||
|
Nothing -> do
|
||||||
|
now <- getTimeCoarse
|
||||||
|
let fn = ncqGetDataFileName ncq key
|
||||||
|
-- TODO: possible-exception!
|
||||||
|
newMmaped <- liftIO (mmapFileByteString fn Nothing)
|
||||||
|
atomically $ ncqAddCachedSTM now ncqMaxCachedData ncqCachedData key newMmaped
|
||||||
|
pure newMmaped
|
||||||
|
|
||||||
|
pure $ Just $ LBS.fromStrict $ BS.take (fromIntegral l) (BS.drop (fromIntegral o+4+32) mmaped)
|
||||||
|
|
||||||
|
ncqStorageDel :: MonadUnliftIO m => NCQStorage -> HashRef -> m NCQStorage
|
||||||
|
ncqStorageDel sto h = do
|
||||||
|
error "not implemented yet"
|
||||||
|
|
||||||
|
ncqStorageSync :: MonadUnliftIO m => NCQStorage -> m ()
|
||||||
|
ncqStorageSync NCQStorage{..} = do
|
||||||
|
atomically $ writeTQueue ncqFlushNow ()
|
||||||
|
|
||||||
|
|
||||||
|
ncqLoadSomeIndexes :: MonadIO m => NCQStorage -> [FileKey] -> m ()
|
||||||
|
ncqLoadSomeIndexes ncq@NCQStorage{..} keys = do
|
||||||
|
now <- getTimeCoarse
|
||||||
|
for_ keys $ \key -> do
|
||||||
|
let fn = ncqGetIndexFileName ncq key
|
||||||
|
liftIO (nwayHashMMapReadOnly fn) >>= \case
|
||||||
|
Nothing -> err $ "NCQStorage: can't mmap index file" <+> pretty fn
|
||||||
|
Just nway -> atomically do
|
||||||
|
ncqAddCachedSTM now ncqMaxCachedIdx ncqCachedIndexes key nway
|
||||||
|
|
||||||
|
ncqLoadIndexes :: MonadIO m => NCQStorage -> m ()
|
||||||
|
ncqLoadIndexes ncq@NCQStorage{..} = do
|
||||||
|
debug "WIP: ncqStorageLoadIndexes"
|
||||||
|
w <- readTVarIO ncqTrackedFiles <&> List.take (ncqMaxCachedIdx `div` 2) . HS.toList
|
||||||
|
ncqLoadSomeIndexes ncq w
|
||||||
|
|
||||||
|
ncqFixIndexes :: MonadUnliftIO m => NCQStorage -> m ()
|
||||||
|
ncqFixIndexes ncq@NCQStorage{..} = do
|
||||||
|
debug "ncqFixIndexes"
|
||||||
|
|
||||||
|
keys <- readTVarIO ncqTrackedFiles
|
||||||
|
|
||||||
|
for_ keys $ \k -> do
|
||||||
|
let idxName = ncqGetIndexFileName ncq k
|
||||||
|
here <- doesFileExist idxName
|
||||||
|
|
||||||
|
unless here do
|
||||||
|
warn $ "missed-index" <+> pretty k
|
||||||
|
let dataName = ncqGetDataFileName ncq k
|
||||||
|
newKey <- ncqIndexFile ncq dataName <&> fromString @FileKey
|
||||||
|
atomically $ ncqAddTrackedFilesSTM ncq [newKey]
|
||||||
|
|
||||||
|
ncqStorageOpen :: MonadUnliftIO m => FilePath -> m NCQStorage
|
||||||
|
ncqStorageOpen fp = do
|
||||||
|
ncq@NCQStorage{..} <- ncqStorageInit_ False fp
|
||||||
|
ncqReadTrackedFiles ncq
|
||||||
|
ncqFixIndexes ncq
|
||||||
|
ncqLoadIndexes ncq
|
||||||
|
readCurrent ncq
|
||||||
|
atomically $ putTMVar ncqOpenDone True
|
||||||
|
pure ncq
|
||||||
|
|
||||||
|
where
|
||||||
|
readCurrent ncq@NCQStorage{..} = do
|
||||||
|
let fn = ncqGetCurrentName ncq
|
||||||
|
-- liftIO $ print $ pretty "FILE" <+> pretty fn
|
||||||
|
bs0 <- liftIO $ mmapFileByteString fn Nothing
|
||||||
|
|
||||||
|
now <- getTimeCoarse
|
||||||
|
|
||||||
|
flip runContT pure $ callCC \exit ->do
|
||||||
|
flip fix (0,bs0) $ \next (o,bs) -> do
|
||||||
|
when (BS.length bs < 4) $ exit ()
|
||||||
|
let w = BS.take 4 bs & N.word32 & fromIntegral
|
||||||
|
let p = BS.take w (BS.drop 4 bs)
|
||||||
|
|
||||||
|
when (BS.length p < w ) do
|
||||||
|
err $ "broken file" <+> pretty fn
|
||||||
|
exit ()
|
||||||
|
|
||||||
|
let k = BS.take 32 p & coerce
|
||||||
|
let vs = w - 32
|
||||||
|
|
||||||
|
-- trace $ "GOT RECORD"
|
||||||
|
-- <+> pretty w
|
||||||
|
-- <+> pretty k
|
||||||
|
-- <+> pretty o
|
||||||
|
-- <+> pretty vs
|
||||||
|
|
||||||
|
atomically $ modifyTVar ncqWaitIndex (HPSQ.insert k now (fromIntegral o, fromIntegral vs))
|
||||||
|
|
||||||
|
next (o+w+4, BS.drop (w+4) bs)
|
||||||
|
|
||||||
|
ncqStorageInit :: MonadUnliftIO m => FilePath -> m NCQStorage
|
||||||
|
ncqStorageInit = ncqStorageInit_ True
|
||||||
|
|
||||||
|
|
||||||
|
ncqStorageInit_ :: MonadUnliftIO m => Bool -> FilePath -> m NCQStorage
|
||||||
|
ncqStorageInit_ check path = do
|
||||||
|
|
||||||
|
let ncqGen = 0
|
||||||
|
|
||||||
|
here <- doesPathExist path
|
||||||
|
|
||||||
|
when (here && check) $ throwIO (NCQStorageAlreadyExist path)
|
||||||
|
|
||||||
|
mkdir (path </> show ncqGen)
|
||||||
|
|
||||||
|
unless here do
|
||||||
|
now <- liftIO $ getPOSIXTime <&> round @_ @Int
|
||||||
|
|
||||||
|
let meta = [ mkForm @C "created" [ mkInt now ] ]
|
||||||
|
let metas = show $ vsep (fmap pretty meta)
|
||||||
|
|
||||||
|
liftIO $ appendFile (path </> "metadata") metas
|
||||||
|
|
||||||
|
let ncqRoot = path
|
||||||
|
|
||||||
|
ncqRefsMem <- newTVarIO mempty
|
||||||
|
ncqRefsDirty <- newTVarIO False
|
||||||
|
|
||||||
|
let ncqSyncSize = 32 * (1024 ^ 2)
|
||||||
|
let ncqMinLog = 2 * (1024 ^ 3)
|
||||||
|
let ncqMaxLog = 10 * (1024 ^ 3)
|
||||||
|
|
||||||
|
let ncqMaxCachedIdx = 64
|
||||||
|
let ncqMaxCachedData = ncqMaxCachedIdx `div` 2
|
||||||
|
|
||||||
|
ncqWriteQueue <- newTVarIO HPSQ.empty
|
||||||
|
|
||||||
|
ncqNotWritten <- newTVarIO 0
|
||||||
|
ncqLastWritten <- getTimeCoarse >>= newTVarIO
|
||||||
|
ncqWaitIndex <- newTVarIO HPSQ.empty
|
||||||
|
|
||||||
|
ncqFlushNow <- newTQueueIO
|
||||||
|
ncqOpenDone <- newEmptyTMVarIO
|
||||||
|
ncqCurrentReadReq <- newTVarIO mempty
|
||||||
|
ncqCurrentUsage <- newTVarIO mempty
|
||||||
|
ncqStopped <- newTVarIO False
|
||||||
|
ncqCachedIndexes <- newTVarIO HPSQ.empty
|
||||||
|
ncqCachedData <- newTVarIO HPSQ.empty
|
||||||
|
ncqTrackedFiles <- newTVarIO mempty
|
||||||
|
|
||||||
|
let currentName = ncqGetCurrentName_ path ncqGen
|
||||||
|
|
||||||
|
let currentSize = ncqGetCurrentSizeName_ path ncqGen
|
||||||
|
|
||||||
|
hereCurrent <- doesPathExist currentName
|
||||||
|
|
||||||
|
when hereCurrent $ liftIO do
|
||||||
|
let ncqCurrentHandleW = undefined
|
||||||
|
let ncqCurrentHandleR = undefined
|
||||||
|
let ncq0 = NCQStorage{..}
|
||||||
|
lastSz <- try @_ @IOException (BS.readFile currentSize)
|
||||||
|
<&> either (const 0) N.word64
|
||||||
|
|
||||||
|
currSz <- try @_ @IOException (fileSize currentName)
|
||||||
|
<&> fromRight 0
|
||||||
|
<&> fromIntegral
|
||||||
|
|
||||||
|
when (lastSz /= currSz ) do
|
||||||
|
fossilized <- ncqGetNewFossilName ncq0
|
||||||
|
let fn = takeFileName fossilized
|
||||||
|
let msg = fromString $ show $ "wrong-size" <+> pretty lastSz <+> pretty fn
|
||||||
|
err $ pretty msg
|
||||||
|
ncqWriteError ncq0 msg
|
||||||
|
mv currentName fossilized
|
||||||
|
|
||||||
|
touch currentName
|
||||||
|
|
||||||
|
let flags = defaultFileFlags { exclusive = True }
|
||||||
|
|
||||||
|
ncqCurrentHandleW <- liftIO (PosixBase.openFd currentName Posix.ReadWrite flags)
|
||||||
|
>>= newTVarIO
|
||||||
|
|
||||||
|
ncqCurrentHandleR <- liftIO (PosixBase.openFd currentName Posix.ReadOnly flags)
|
||||||
|
>>= newTVarIO
|
||||||
|
|
||||||
|
debug $ "currentFileName" <+> pretty (ncqGetCurrentName_ path ncqGen)
|
||||||
|
|
||||||
|
pure $ NCQStorage{..}
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -32,6 +32,7 @@ common common-deps
|
||||||
, microlens-platform
|
, microlens-platform
|
||||||
, mtl
|
, mtl
|
||||||
, mwc-random
|
, mwc-random
|
||||||
|
, psqueues
|
||||||
, prettyprinter
|
, prettyprinter
|
||||||
, QuickCheck
|
, QuickCheck
|
||||||
, random
|
, random
|
||||||
|
|
@ -1177,3 +1178,25 @@ executable test-scripts
|
||||||
, time
|
, time
|
||||||
, zstd
|
, zstd
|
||||||
|
|
||||||
|
|
||||||
|
executable test-cq-storage
|
||||||
|
import: shared-properties
|
||||||
|
import: common-deps
|
||||||
|
default-language: Haskell2010
|
||||||
|
ghc-options:
|
||||||
|
hs-source-dirs: test
|
||||||
|
main-is: TestCQ.hs
|
||||||
|
build-depends:
|
||||||
|
base, hbs2-core, hbs2-log-structured, hbs2-storage-ncq
|
||||||
|
, network
|
||||||
|
, string-conversions
|
||||||
|
, db-pipe
|
||||||
|
, suckless-conf
|
||||||
|
, network-byte-order
|
||||||
|
, text
|
||||||
|
, time
|
||||||
|
, mmap
|
||||||
|
, zstd
|
||||||
|
, unix
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,520 @@
|
||||||
|
{-# Language AllowAmbiguousTypes #-}
|
||||||
|
{-# Language UndecidableInstances #-}
|
||||||
|
{-# Language MultiWayIf #-}
|
||||||
|
{-# Language RecordWildCards #-}
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import HBS2.Prelude.Plated
|
||||||
|
import HBS2.OrDie
|
||||||
|
import HBS2.Hash
|
||||||
|
import HBS2.Data.Types.Refs
|
||||||
|
import HBS2.Clock
|
||||||
|
import HBS2.Merkle
|
||||||
|
|
||||||
|
import HBS2.Storage
|
||||||
|
import HBS2.Storage.Simple
|
||||||
|
import HBS2.Storage.Operations.ByteString
|
||||||
|
|
||||||
|
import HBS2.System.Logger.Simple.ANSI
|
||||||
|
|
||||||
|
import HBS2.Storage.NCQ
|
||||||
|
import HBS2.Data.Log.Structured.NCQ
|
||||||
|
|
||||||
|
|
||||||
|
import Data.Config.Suckless.Syntax
|
||||||
|
import Data.Config.Suckless.Script
|
||||||
|
import Data.Config.Suckless.System
|
||||||
|
|
||||||
|
import DBPipe.SQLite hiding (field)
|
||||||
|
|
||||||
|
import Data.Bits
|
||||||
|
import Data.ByteString (ByteString)
|
||||||
|
import Data.ByteString qualified as BS
|
||||||
|
import Data.ByteString.Lazy qualified as LBS
|
||||||
|
import Data.ByteString.Char8 qualified as BS8
|
||||||
|
import Data.ByteString.Builder
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.Word
|
||||||
|
import Data.List qualified as List
|
||||||
|
import Data.Vector qualified as V
|
||||||
|
import Data.Vector ((!))
|
||||||
|
import Control.Monad.Trans.Cont
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
|
import Network.ByteOrder qualified as N
|
||||||
|
import Data.Coerce
|
||||||
|
import Data.HashPSQ qualified as HPSQ
|
||||||
|
import Data.HashSet qualified as HS
|
||||||
|
import Data.HashMap.Strict (HashMap)
|
||||||
|
import Data.HashMap.Strict qualified as HM
|
||||||
|
import Data.IntMap qualified as IntMap
|
||||||
|
import Data.IntMap (IntMap)
|
||||||
|
import Data.Fixed
|
||||||
|
import System.Environment
|
||||||
|
import System.Directory
|
||||||
|
import System.Posix.Fcntl
|
||||||
|
import System.Posix.IO
|
||||||
|
import System.IO.MMap
|
||||||
|
import System.IO qualified as IO
|
||||||
|
import System.Random
|
||||||
|
import Safe
|
||||||
|
import Lens.Micro.Platform
|
||||||
|
import Control.Concurrent.STM qualified as STM
|
||||||
|
import UnliftIO
|
||||||
|
import Text.InterpolatedString.Perl6 (qc)
|
||||||
|
|
||||||
|
import Streaming.Prelude qualified as S
|
||||||
|
import System.TimeIt
|
||||||
|
|
||||||
|
|
||||||
|
setupLogger :: MonadIO m => m ()
|
||||||
|
setupLogger = do
|
||||||
|
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
||||||
|
setLogging @ERROR $ toStderr . logPrefix "[error] "
|
||||||
|
setLogging @WARN $ toStderr . logPrefix "[warn] "
|
||||||
|
setLogging @NOTICE $ toStdout . logPrefix ""
|
||||||
|
|
||||||
|
flushLoggers :: MonadIO m => m ()
|
||||||
|
flushLoggers = do
|
||||||
|
silence
|
||||||
|
|
||||||
|
silence :: MonadIO m => m ()
|
||||||
|
silence = do
|
||||||
|
setLoggingOff @DEBUG
|
||||||
|
setLoggingOff @ERROR
|
||||||
|
setLoggingOff @WARN
|
||||||
|
setLoggingOff @NOTICE
|
||||||
|
setLoggingOff @TRACE
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
|
||||||
|
let dict = makeDict @C do
|
||||||
|
|
||||||
|
entry $ bindMatch "--help" $ nil_ \case
|
||||||
|
HelpEntryBound what -> helpEntry what
|
||||||
|
[StringLike s] -> helpList False (Just s)
|
||||||
|
_ -> helpList False Nothing
|
||||||
|
|
||||||
|
internalEntries
|
||||||
|
|
||||||
|
entry $ bindMatch "test:sqlite" $ nil_ $ \case
|
||||||
|
[StringLike fn] -> liftIO do
|
||||||
|
hashes <- readFile fn <&> mapMaybe (fromStringMay @HashRef) . lines
|
||||||
|
|
||||||
|
let dbname = "jopakita.db"
|
||||||
|
rm dbname
|
||||||
|
newDb <- newDBPipeEnv dbPipeOptsDef dbname
|
||||||
|
|
||||||
|
withDB newDb do
|
||||||
|
ddl [qc|CREATE TABLE kv (k BLOB PRIMARY KEY, v int)|]
|
||||||
|
|
||||||
|
timeItNamed "sqlite -- test insert" do
|
||||||
|
withDB newDb $ transactional do
|
||||||
|
for_ hashes $ \h -> do
|
||||||
|
let k = coerce @_ @ByteString h
|
||||||
|
insert [qc|insert into kv (k,v) values(?,?)|] (k,0)
|
||||||
|
|
||||||
|
replicateM_ 5 do
|
||||||
|
withDB newDb do
|
||||||
|
timeItNamed "sqlite -- select test" do
|
||||||
|
-- fn <- newTVarIO 0
|
||||||
|
-- fns <- newTVarIO 0
|
||||||
|
q <- newTQueueIO
|
||||||
|
for_ hashes $ \h -> do
|
||||||
|
let k = coerce @_ @ByteString h
|
||||||
|
|
||||||
|
founds <- select [qc|select k,v from kv where k = ?|] (Only k)
|
||||||
|
|
||||||
|
for_ founds $ \(s :: ByteString,n :: Int) -> do
|
||||||
|
atomically $ writeTQueue q (s,n)
|
||||||
|
|
||||||
|
found <- atomically (STM.flushTQueue q) <&> List.length
|
||||||
|
liftIO $ IO.hPrint stderr $ "FOUND" <+> pretty found
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:hashmap" $ nil_ $ \case
|
||||||
|
[StringLike fn] -> liftIO do
|
||||||
|
hashes <- readFile fn <&> mapMaybe (fromStringMay @HashRef) . lines
|
||||||
|
let hma = HM.fromList [(h,()) | h <- hashes ]
|
||||||
|
|
||||||
|
replicateM_ 5 do
|
||||||
|
timeItNamed (show $ "HashMap lookup test" <+> pretty (List.length hashes)) do
|
||||||
|
q <- newTQueueIO
|
||||||
|
for_ hashes $ \h -> do
|
||||||
|
when (HM.member h hma) do
|
||||||
|
atomically $ writeTQueue q h
|
||||||
|
|
||||||
|
n <- atomically ( STM.flushTQueue q) <&> List.length
|
||||||
|
liftIO $ print $ "FOUND" <+> pretty n
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
|
||||||
|
entry $ bindMatch "test:nway:scan" $ nil_ $ \case
|
||||||
|
[ StringLike fn ]-> liftIO do
|
||||||
|
(mmaped,meta@NWayHash{..}) <- nwayHashMMapReadOnly fn >>= orThrow (NWayHashInvalidMetaData fn)
|
||||||
|
let emptyKey = BS.replicate nwayKeySize 0
|
||||||
|
nwayHashScanAll meta mmaped $ \o k v -> do
|
||||||
|
unless (k == emptyKey) do
|
||||||
|
liftIO $ print $ "scan:found" <+> fill 44 (pretty (coerce @_ @HashRef k)) <+> pretty o
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
|
||||||
|
entry $ bindMatch "test:nway:lookup" $ nil_ $ \case
|
||||||
|
|
||||||
|
[ StringLike fn ] -> liftIO do
|
||||||
|
|
||||||
|
hashes <- getContents <&> mapMaybe (fromStringMay @HashRef) . lines
|
||||||
|
|
||||||
|
(mmaped, nw) <- nwayHashMMapReadOnly fn >>= orThrow (NWayHashInvalidMetaData fn)
|
||||||
|
|
||||||
|
replicateM_ 5 do
|
||||||
|
timeItNamed (show $ "lookup:nway" <+> pretty (List.length hashes)) do
|
||||||
|
rQ <- newTQueueIO
|
||||||
|
|
||||||
|
for_ hashes $ \h -> do
|
||||||
|
r <- nwayHashLookup nw mmaped (coerce @_ @ByteString h)
|
||||||
|
when (isJust r) do
|
||||||
|
atomically $ writeTQueue rQ (h,r)
|
||||||
|
|
||||||
|
found <- atomically $ STM.flushTQueue rQ
|
||||||
|
liftIO $ print $ "FOUND" <+> pretty (List.length found)
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:nway:stats" $ \case
|
||||||
|
[StringLike fn] -> liftIO do
|
||||||
|
|
||||||
|
mt_ <- newTVarIO 0
|
||||||
|
total_ <- newTVarIO 0
|
||||||
|
|
||||||
|
(mmaped,meta@NWayHash{..}) <- nwayHashMMapReadOnly fn >>= orThrow (NWayHashInvalidMetaData fn)
|
||||||
|
|
||||||
|
let emptyKey = BS.replicate nwayKeySize 0
|
||||||
|
nwayHashScanAll meta mmaped $ \o k v -> do
|
||||||
|
atomically do
|
||||||
|
modifyTVar total_ succ
|
||||||
|
when (k == emptyKey) do
|
||||||
|
modifyTVar mt_ succ
|
||||||
|
|
||||||
|
mt <- readTVarIO mt_
|
||||||
|
total <- readTVarIO total_
|
||||||
|
let used = total - mt
|
||||||
|
|
||||||
|
let ratio = realToFrac @_ @(Fixed E3) (realToFrac used / realToFrac total)
|
||||||
|
|
||||||
|
let stats = mkForm @C "stats" [ mkForm "empty" [mkInt mt]
|
||||||
|
, mkForm "used" [mkInt used]
|
||||||
|
, mkForm "total" [mkInt total]
|
||||||
|
, mkForm "ratio" [mkDouble ratio]
|
||||||
|
]
|
||||||
|
|
||||||
|
pure $ mkList [mkForm "metadata" [mkSyntax meta], stats]
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:nway:metadata" $ \case
|
||||||
|
[StringLike fn] -> liftIO do
|
||||||
|
(_, nw) <- nwayHashMMapReadOnly fn >>= orThrowUser "can't mmape file"
|
||||||
|
pure $ mkSyntax nw
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:nway:write" $ nil_ $ \case
|
||||||
|
[StringLike fn] -> liftIO do
|
||||||
|
hashes <- getContents <&> mapMaybe (fromStringMay @HashRef) . lines
|
||||||
|
let items = [ (coerce @_ @ByteString x, N.bytestring64 0) | x <- hashes ]
|
||||||
|
nwayWriteBatch (nwayAllocDef 1.10 32 8 8) "." fn items
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:index" $ \case
|
||||||
|
[ StringLike p, StringLike fsrc ]-> lift $ flip runContT pure do
|
||||||
|
|
||||||
|
ncq <- lift $ ncqStorageOpen p
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
fres <- lift $ ncqIndexFile ncq fsrc
|
||||||
|
|
||||||
|
pure $ mkSym fres
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:raw:get" $ \case
|
||||||
|
|
||||||
|
[StringLike fn, HashLike h] -> liftIO $ flip runContT pure do
|
||||||
|
|
||||||
|
ncq <- lift $ ncqStorageOpen fn
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
lift do
|
||||||
|
ncqStorageGet ncq h >>= \case
|
||||||
|
Nothing -> pure nil
|
||||||
|
Just bs -> do
|
||||||
|
-- debug $ "GET" <+> pretty (LBS.length bs) <+> pretty (hashObject @HbSync bs)
|
||||||
|
mkOpaque bs
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:has" $ \case
|
||||||
|
|
||||||
|
[StringLike fn, HashLike h] -> liftIO $ flip runContT pure do
|
||||||
|
|
||||||
|
ncq <- lift $ ncqStorageOpen fn
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
lift do
|
||||||
|
ncqStorageHasBlock ncq h >>= \case
|
||||||
|
Nothing -> pure nil
|
||||||
|
Just x -> pure $ mkInt x
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:raw:up" $ nil_ $ \case
|
||||||
|
|
||||||
|
[StringLike fn] -> liftIO $ flip runContT pure do
|
||||||
|
|
||||||
|
ncq@NCQStorage{..} <- lift $ ncqStorageOpen fn
|
||||||
|
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
trf <- readTVarIO ncqTrackedFiles <&> HS.toList
|
||||||
|
|
||||||
|
for_ trf $ \tf -> do
|
||||||
|
notice $ "tracked" <+> pretty tf
|
||||||
|
|
||||||
|
tri <- readTVarIO ncqCachedIndexes <&> HPSQ.toList
|
||||||
|
|
||||||
|
for_ tri $ \(k,_,_) -> do
|
||||||
|
notice $ "cached-index" <+> pretty k
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:raw" $ \case
|
||||||
|
[StringLike fn] -> liftIO $ flip runContT pure do
|
||||||
|
|
||||||
|
debug "SHIT"
|
||||||
|
|
||||||
|
ncq <- lift $ ncqStorageOpen fn
|
||||||
|
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
h <- lift $ ncqStoragePut ncq "JOPAKITA!"
|
||||||
|
h2 <- lift $ ncqStoragePut ncq "PECHENTRESKI!"
|
||||||
|
|
||||||
|
liftIO $ ncqStorageStop ncq
|
||||||
|
|
||||||
|
pure $ mkList [mkSym (show $ pretty h), mkSym (show $ pretty h2)]
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:raw:list" $ nil_ \case
|
||||||
|
[StringLike p, StringLike f] -> liftIO $ flip runContT pure do
|
||||||
|
|
||||||
|
ncq <- lift $ ncqStorageOpen p
|
||||||
|
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
lift $ ncqStorageScanDataFile ncq f $ \o _ k v -> do
|
||||||
|
liftIO $ print $ pretty k -- <+> pretty o <+> pretty (BS.length v)
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:raw:find-some" $ nil_ \case
|
||||||
|
[StringLike fn] -> liftIO $ flip runContT pure do
|
||||||
|
hashes <- liftIO $ getContents <&> mapMaybe (fromStringMay @HashRef) . lines
|
||||||
|
|
||||||
|
ncq <- lift $ ncqStorageOpen fn
|
||||||
|
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
liftIO $ for_ hashes $ \h -> runMaybeT do
|
||||||
|
what <- liftIO (ncqStorageHasBlock ncq h) >>= toMPlus
|
||||||
|
-- let h1 = hashObject @HbSync what
|
||||||
|
-- liftIO $ print $ "block" <+> pretty h <+> pretty h1 <+> pretty (LBS.length what)
|
||||||
|
liftIO $ print $ "block" <+> pretty h <+> pretty what -- (LBS.length what)
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:raw:dump-some" $ nil_ \case
|
||||||
|
[StringLike fn] -> liftIO $ flip runContT pure do
|
||||||
|
hashes <- liftIO $ getContents <&> mapMaybe (fromStringMay @HashRef) . lines
|
||||||
|
|
||||||
|
xdg <- liftIO $ getXdgDirectory XdgData "hbs2" <&> fromString @StoragePrefix
|
||||||
|
|
||||||
|
s <- simpleStorageInit @HbSync (Just xdg)
|
||||||
|
|
||||||
|
w <- ContT $ withAsync $ simpleStorageWorker s
|
||||||
|
link w
|
||||||
|
|
||||||
|
let sto = AnyStorage s
|
||||||
|
|
||||||
|
rm fn
|
||||||
|
dump <- openFile fn WriteMode
|
||||||
|
|
||||||
|
for_ hashes $ \h -> runMaybeT do
|
||||||
|
blk <- getBlock sto (coerce h) >>= toMPlus
|
||||||
|
debug $ "read" <+> pretty (LBS.length blk)
|
||||||
|
none
|
||||||
|
-- liftIO $ LBS.hPut dump blk
|
||||||
|
|
||||||
|
hClose dump
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:raw:locate" $ nil_ \case
|
||||||
|
[StringLike fn] -> liftIO $ flip runContT pure do
|
||||||
|
hashes <- liftIO $ getContents <&> mapMaybe (fromStringMay @HashRef) . lines
|
||||||
|
|
||||||
|
ncq <- lift $ ncqStorageOpen fn
|
||||||
|
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
timeItNamed (show $ "lookup" <+> pretty (List.length hashes)) do
|
||||||
|
for_ hashes $ \h -> liftIO do
|
||||||
|
ncqLocate ncq h >>= \case
|
||||||
|
Nothing -> print $ pretty "not-found" <+> pretty h
|
||||||
|
Just l -> print $ pretty "found" <+> pretty h <+> pretty l
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:raw:put" $ \case
|
||||||
|
[StringLike fn] -> liftIO $ flip runContT pure do
|
||||||
|
|
||||||
|
what <- liftIO BS.getContents
|
||||||
|
|
||||||
|
ncq <- lift $ ncqStorageOpen fn
|
||||||
|
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
href <- liftIO $ ncqStoragePut ncq (LBS.fromStrict what)
|
||||||
|
|
||||||
|
liftIO $ ncqStorageStop ncq
|
||||||
|
|
||||||
|
pure $ maybe nil (mkSym . show . pretty) href
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:raw:merkle:write" $ nil_ \case
|
||||||
|
[StringLike fn, StringLike what] -> liftIO $ flip runContT pure do
|
||||||
|
|
||||||
|
ncq <- lift $ ncqStorageOpen fn
|
||||||
|
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
ContT $ bracket none $ const do
|
||||||
|
none
|
||||||
|
|
||||||
|
lbs <- liftIO $ LBS.readFile what
|
||||||
|
|
||||||
|
ta <- getTimeCoarse
|
||||||
|
|
||||||
|
(t1,hashes) <- timeItT $ liftIO do
|
||||||
|
chu <- S.toList_ (readChunkedBS lbs (256*1024))
|
||||||
|
forConcurrently chu $ \chunk -> do
|
||||||
|
ncqStoragePut ncq chunk >>= orThrowUser "can't save"
|
||||||
|
|
||||||
|
tb <- getTimeCoarse
|
||||||
|
|
||||||
|
notice $ "stored in" <+> pretty t1
|
||||||
|
<+> pretty (realToFrac @_ @(Fixed E6) (realToFrac (toMicroSeconds (TimeoutTS (tb - ta))) / 1e6))
|
||||||
|
|
||||||
|
-- FIXME: handle-hardcode
|
||||||
|
let pt = toPTree (MaxSize 1024) (MaxNum 256) hashes -- FIXME: settings
|
||||||
|
|
||||||
|
m <- makeMerkle 0 pt $ \(_,_,bss) -> liftIO do
|
||||||
|
void $ ncqStoragePut ncq bss >>= orThrowUser "can't save"
|
||||||
|
|
||||||
|
liftIO $ print $ pretty m
|
||||||
|
|
||||||
|
liftIO $ ncqStorageStop ncq
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:ncq:raw:write-some" $ nil_ \case
|
||||||
|
[StringLike fn] -> liftIO $ flip runContT pure do
|
||||||
|
|
||||||
|
hashes <- liftIO $ getContents <&> mapMaybe (fromStringMay @HashRef) . lines
|
||||||
|
|
||||||
|
xdg <- liftIO $ getXdgDirectory XdgData "hbs2" <&> fromString @StoragePrefix
|
||||||
|
|
||||||
|
s <- simpleStorageInit @HbSync (Just xdg)
|
||||||
|
|
||||||
|
w <- ContT $ withAsync $ simpleStorageWorker s
|
||||||
|
link w
|
||||||
|
|
||||||
|
let sto = AnyStorage s
|
||||||
|
|
||||||
|
ncq <- lift $ ncqStorageOpen fn
|
||||||
|
|
||||||
|
writer <- ContT $ withAsync $ ncqStorageRun ncq
|
||||||
|
link writer
|
||||||
|
|
||||||
|
ContT $ bracket none $ const do
|
||||||
|
none
|
||||||
|
|
||||||
|
for_ hashes $ \h -> runMaybeT do
|
||||||
|
blk <- getBlock sto (coerce h) >>= toMPlus
|
||||||
|
liftIO do
|
||||||
|
let l = LBS.length blk
|
||||||
|
-- print $ pretty h <+> pretty l
|
||||||
|
ncqStoragePut ncq blk
|
||||||
|
|
||||||
|
liftIO $ ncqStorageStop ncq
|
||||||
|
|
||||||
|
e -> throwIO $ BadFormException @C (mkList e)
|
||||||
|
|
||||||
|
entry $ bindMatch "test:retry" $ nil_ $ const $ flip runContT pure do
|
||||||
|
|
||||||
|
q <- newTQueueIO
|
||||||
|
w <- newTVarIO 0
|
||||||
|
|
||||||
|
p1 <- ContT $ withAsync $ forever do
|
||||||
|
pause @'Seconds 0.001
|
||||||
|
x <- randomIO @Word64
|
||||||
|
atomically do
|
||||||
|
writeTQueue q x
|
||||||
|
modifyTVar w succ
|
||||||
|
|
||||||
|
p2 <- ContT $ withAsync $ do
|
||||||
|
atomically $ fix \next -> do
|
||||||
|
e <- readTQueue q
|
||||||
|
if (e == 0xDEADF00D) then none else next
|
||||||
|
|
||||||
|
p3 <- ContT $ withAsync $ do
|
||||||
|
pause @'Seconds 10
|
||||||
|
|
||||||
|
waitAnyCatchCancel [p1,p2,p3]
|
||||||
|
|
||||||
|
s <- atomically $ STM.flushTQueue q
|
||||||
|
n <- readTVarIO w
|
||||||
|
|
||||||
|
liftIO $ print $ "so?" <+> pretty n <+> pretty (length s)
|
||||||
|
|
||||||
|
setupLogger
|
||||||
|
|
||||||
|
argz <- liftIO getArgs
|
||||||
|
|
||||||
|
forms <- parseTop (unlines $ unwords <$> splitForms argz)
|
||||||
|
& either (error.show) pure
|
||||||
|
|
||||||
|
tvd <- newTVarIO dict
|
||||||
|
|
||||||
|
(runEval tvd forms >>= eatNil display)
|
||||||
|
`finally` flushLoggers
|
||||||
|
|
||||||
Loading…
Reference in New Issue