mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
b802debd97
commit
a1ed4e3633
|
|
@ -1,5 +0,0 @@
|
|||
modified 1716433451 "2piRBmaQkb3c2nAcH6Mrf8EAddNJF34c6Tm8PWnbVBqN" "workflow" "done"
|
||||
deleted "9m2B74CHFTGBTWXo1uNoi9StuQ3AxnMpULwbLcToMkmZ"
|
||||
deleted "EUP5zeroTKWuP96dQQrZVZqUhBXdh8icD3P9EebYo9HR"
|
||||
modified 1716435973 "H2AZFfGZsSaVWyBme21PJQkprAn5yaizf8LNGQekFhPe" "workflow" "test"
|
||||
deleted "ETndVbmSb2T6rPPF8k7BSYnYzAWbaUtifvQEUQVFeLzQ"
|
||||
|
|
@ -80,6 +80,7 @@ common shared-properties
|
|||
, mtl
|
||||
, safe
|
||||
, serialise
|
||||
, scientific
|
||||
, streaming
|
||||
, stm
|
||||
, text
|
||||
|
|
|
|||
|
|
@ -13,11 +13,15 @@ import Fixme.Scan as Scan
|
|||
|
||||
import HBS2.Git.Local.CLI
|
||||
|
||||
import HBS2.Merkle
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Storage.Compact
|
||||
import HBS2.System.Dir
|
||||
import DBPipe.SQLite hiding (field)
|
||||
import Data.Config.Suckless
|
||||
|
||||
import Data.Aeson.Encode.Pretty as Aeson
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.Either
|
||||
|
|
@ -25,6 +29,8 @@ import Data.Maybe
|
|||
import Data.HashSet qualified as HS
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.Set qualified as Set
|
||||
import Data.List qualified as List
|
||||
import Data.Text qualified as Text
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Data.Coerce
|
||||
|
|
@ -36,6 +42,9 @@ import Control.Monad.Trans.Maybe
|
|||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
-- FIXME: move-to-suckless-conf
|
||||
deriving stock instance Ord (Syntax C)
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
|
||||
pattern Init :: forall {c}. Syntax c
|
||||
|
|
@ -61,6 +70,8 @@ pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c
|
|||
pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ]
|
||||
|
||||
|
||||
logRootKey :: SomeRefKey ByteString
|
||||
logRootKey = SomeRefKey "ROOT"
|
||||
|
||||
scanGitArgs :: [Syntax c] -> [ScanGitArgs]
|
||||
scanGitArgs syn = [ w | ScanGitArgs w <- syn ]
|
||||
|
|
@ -255,35 +266,17 @@ cat_ metaOnly hash = do
|
|||
delete :: FixmePerks m => Text -> FixmeM m ()
|
||||
delete txt = do
|
||||
acts <- asks fixmeEnvUpdateActions >>= readTVarIO
|
||||
|
||||
void $ runMaybeT do
|
||||
|
||||
ha <- toMPlus =<< lift (selectFixmeHash txt)
|
||||
let syn = mkLit @Text [qc|deleted "{pretty ha}"|]
|
||||
|
||||
debug $ red "deleted" <+> pretty ha
|
||||
|
||||
for_ acts $ \(UpdateAction what) -> do
|
||||
liftIO $ what (Literal noContext syn)
|
||||
lift $ insertFixmeDelStaged ha
|
||||
|
||||
|
||||
modify_ :: FixmePerks m => Text -> String -> String -> FixmeM m ()
|
||||
modify_ txt a b = do
|
||||
acts <- asks fixmeEnvUpdateActions >>= readTVarIO
|
||||
|
||||
ts <- getEpoch
|
||||
|
||||
void $ runMaybeT do
|
||||
|
||||
ha <- toMPlus =<< lift (selectFixmeHash txt)
|
||||
let syn = mkLit @Text [qc|modified {ts} "{pretty ha}" "{a}" "{b}"|]
|
||||
|
||||
debug $ red $ pretty syn
|
||||
|
||||
for_ acts $ \(UpdateAction what) -> do
|
||||
liftIO $ what (Literal noContext syn)
|
||||
|
||||
|
||||
lift $ insertFixmeModStaged ha (fromString a) (fromString b)
|
||||
|
||||
printEnv :: FixmePerks m => FixmeM m ()
|
||||
printEnv = do
|
||||
|
|
@ -522,17 +515,57 @@ run what = do
|
|||
appendFile fn "\n"
|
||||
|
||||
ListVal [SymbolVal "play-log-file", StringLike fn] -> do
|
||||
debug $ yellow "play-log-file" <+> pretty fn
|
||||
-- FIXME: just-for-in-case-sanitize-input
|
||||
-- $workflow: done
|
||||
what <- try @_ @IOException (liftIO $ readFile fn)
|
||||
<&> fromRight mempty
|
||||
<&> parseTop
|
||||
<&> fromRight mempty
|
||||
<&> sanitizeLog
|
||||
|
||||
env <- ask
|
||||
liftIO $ withFixmeEnv env (runForms what)
|
||||
|
||||
warn $ red "play-log-file WIP" <+> pretty fn
|
||||
|
||||
warn $ red "GENERATE FORMS? FROM STAGE"
|
||||
|
||||
what <- selectStage @C
|
||||
|
||||
for_ what $ \w -> do
|
||||
warn $ pretty w
|
||||
|
||||
warn $ red "ADD RECORDS FROM STAGE TO BINARY LOG"
|
||||
|
||||
sto <- compactStorageOpen @HbSync mempty fn
|
||||
|
||||
wtf <- S.toList_ $ runMaybeT do
|
||||
rv <- MaybeT $ getRef sto logRootKey
|
||||
walkMerkle rv (getBlock sto) $ \case
|
||||
Left{} -> pure ()
|
||||
Right (xs :: [Text]) -> do
|
||||
let what = fmap parseTop xs & rights & mconcat
|
||||
lift $ mapM_ S.yield (sanitizeLog what)
|
||||
|
||||
let theLog = Set.fromList (wtf <> what) & Set.toList
|
||||
-- FIXME: mtree-params-hardcode
|
||||
|
||||
let new = theLog & fmap ( fromString @Text . show . pretty )
|
||||
let pt = toPTree (MaxSize 1024) (MaxNum 256) new
|
||||
|
||||
-- FIXME: fuck-the-fucking-scientific
|
||||
-- сраный Scientiс не реализует Generic
|
||||
-- и не открывает конструкторы, нельзя
|
||||
-- сделать инстанс Serialise.
|
||||
-- надо выпилить его к херам. а пока вот так
|
||||
h <- makeMerkle 0 pt $ \(_,_,bss) -> do
|
||||
void $ putBlock sto bss
|
||||
|
||||
updateRef sto logRootKey h
|
||||
|
||||
compactStorageClose sto
|
||||
|
||||
liftIO $ print $ vcat (fmap pretty new)
|
||||
|
||||
warn $ red "DELETE STAGE"
|
||||
warn $ red "SCAN BINARY LOG?"
|
||||
warn $ red "RUN NEW FORMS"
|
||||
|
||||
liftIO $ withFixmeEnv env (runForms theLog)
|
||||
|
||||
cleanStage
|
||||
|
||||
ListVal [SymbolVal "no-debug"] -> do
|
||||
setLoggingOff @DEBUG
|
||||
|
|
@ -546,6 +579,26 @@ run what = do
|
|||
ListVal [SymbolVal "builtin:cleanup-state"] -> do
|
||||
cleanupDatabase
|
||||
|
||||
ListVal [SymbolVal "builtin:clean-stage"] -> do
|
||||
cleanStage
|
||||
|
||||
ListVal [SymbolVal "builtin:show-stage"] -> do
|
||||
stage <- selectStage @C
|
||||
liftIO $ print $ vcat (fmap pretty stage)
|
||||
|
||||
ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do
|
||||
sto <- compactStorageOpen @HbSync readonly fn
|
||||
|
||||
void $ runMaybeT do
|
||||
rv <- MaybeT $ getRef sto logRootKey
|
||||
|
||||
walkMerkle rv (getBlock sto) $ \case
|
||||
Left{} -> error "malformed log"
|
||||
Right (xs :: [Text]) -> do
|
||||
liftIO $ mapM_ (print . pretty) xs
|
||||
|
||||
compactStorageClose sto
|
||||
|
||||
ListVal [SymbolVal "builtin:update-indexes"] -> do
|
||||
updateIndexes
|
||||
|
||||
|
|
|
|||
|
|
@ -15,11 +15,17 @@ module Fixme.State
|
|||
, newCommit
|
||||
, cleanupDatabase
|
||||
, updateIndexes
|
||||
, insertFixmeDelStaged
|
||||
, insertFixmeModStaged
|
||||
, selectStageModified
|
||||
, selectStageDeleted
|
||||
, selectStage
|
||||
, cleanStage
|
||||
, HasPredicate(..)
|
||||
) where
|
||||
|
||||
import Fixme.Prelude
|
||||
import Fixme.Types
|
||||
import Fixme.Types hiding (mkstr, mksym)
|
||||
import Fixme.Config
|
||||
|
||||
import HBS2.System.Dir
|
||||
|
|
@ -29,7 +35,7 @@ import DBPipe.SQLite hiding (field)
|
|||
|
||||
import Data.Aeson as Aeson
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Text.InterpolatedString.Perl6 (q,qc)
|
||||
import Data.Text qualified as Text
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
|
|
@ -40,6 +46,7 @@ import Data.Generics.Product.Fields (field)
|
|||
import Control.Monad.Trans.Maybe
|
||||
import Data.Coerce
|
||||
import Data.Fixed
|
||||
import Data.Word (Word64)
|
||||
import System.TimeIt
|
||||
|
||||
|
||||
|
|
@ -239,6 +246,21 @@ createTables = do
|
|||
create index if not exists idx_fixmekey ON fixmejson(fixmekey)
|
||||
|]
|
||||
|
||||
ddl [qc| create table if not exists fixmestagedel
|
||||
( hash text not null primary key
|
||||
, ts integer not null
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc| create table if not exists fixmestagemod
|
||||
( hash text not null
|
||||
, ts integer not null
|
||||
, attr text not null
|
||||
, value text
|
||||
, primary key (hash,attr)
|
||||
)
|
||||
|]
|
||||
|
||||
-- .fixme-new/state.db
|
||||
-- and not exists (select null from fixmedeleted d where a.fixme = id limit 1)
|
||||
|
||||
|
|
@ -345,9 +367,17 @@ instance IsContext c => HasPredicate [Syntax c] where
|
|||
ListVal [x] -> x
|
||||
x -> x
|
||||
|
||||
mklist = List (noContext :: Context c)
|
||||
mksym = Symbol (noContext :: Context c)
|
||||
mkstr = Literal (noContext :: Context c) . LitStr
|
||||
mklist :: IsContext c => [Syntax c] -> Syntax c
|
||||
mklist ss = List noContext ss
|
||||
|
||||
mksym :: IsContext c => Id -> Syntax c
|
||||
mksym = Symbol noContext
|
||||
|
||||
mkint :: (IsContext c, Integral a) => a -> Syntax c
|
||||
mkint = Literal noContext . LitInt . fromIntegral
|
||||
|
||||
mkstr :: IsContext c => Text -> Syntax c
|
||||
mkstr = Literal noContext . LitStr
|
||||
|
||||
{- HLINT ignore "Functor law" -}
|
||||
{- HLINT ignore "Eta reduce" -}
|
||||
|
|
@ -466,18 +496,28 @@ updateFixmeJson = do
|
|||
|]
|
||||
|
||||
|
||||
-- TODO: predicate-for-stage-toggle
|
||||
selectFixmeThin :: (FixmePerks m, HasPredicate a) => a -> FixmeM m [FixmeThin]
|
||||
selectFixmeThin a = withState do
|
||||
|
||||
let predic = genPredQ "j" (predicate a)
|
||||
|
||||
let emptyObect = [q|'{}'|] :: String
|
||||
|
||||
let sql = [qc|
|
||||
|
||||
select j.json as blob
|
||||
with s1 as (
|
||||
select m.hash as hash
|
||||
, cast(json_group_object(m.attr,m.value) as blob) as json
|
||||
from fixmestagemod m
|
||||
)
|
||||
|
||||
select cast(json_patch(j.json, coalesce(s.json,{emptyObect})) as blob) as blob
|
||||
|
||||
from
|
||||
fixmejson j join fixmeactual f on f.fixme = j.fixme
|
||||
join fixme f0 on f0.id = f.fixme
|
||||
left join s1 s on s.hash = f0.id
|
||||
|
||||
where
|
||||
|
||||
|
|
@ -511,6 +551,63 @@ cleanupDatabase = do
|
|||
update_ [qc|delete from fixmerel|]
|
||||
update_ [qc|delete from fixmeactual|]
|
||||
update_ [qc|delete from fixmejson|]
|
||||
update_ [qc|delete from fixmestagedel|]
|
||||
update_ [qc|delete from fixmestagemod|]
|
||||
|
||||
|
||||
insertFixmeModStaged :: (FixmePerks m,MonadReader FixmeEnv m)
|
||||
=> Text
|
||||
-> FixmeAttrName
|
||||
-> FixmeAttrVal
|
||||
-> m ()
|
||||
insertFixmeModStaged hash k v = withState do
|
||||
ts <- getEpoch
|
||||
insert [qc| insert into fixmestagemod (hash,ts,attr,value) values(?,?,?,?)
|
||||
on conflict (hash,attr)
|
||||
do update set hash = excluded.hash
|
||||
, ts = excluded.ts
|
||||
, attr = excluded.attr
|
||||
, value = excluded.value
|
||||
|] (hash,ts,k,v)
|
||||
|
||||
|
||||
insertFixmeDelStaged :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
|
||||
insertFixmeDelStaged hash = withState do
|
||||
ts <- getEpoch
|
||||
insert [qc| insert into fixmestagedel (hash,ts) values(?,?)
|
||||
on conflict (hash)
|
||||
do update set hash = excluded.hash
|
||||
, ts = excluded.ts
|
||||
|] (hash,ts)
|
||||
|
||||
|
||||
type StageModRow = (Text,Integer,Text,Text)
|
||||
|
||||
selectStageModified :: (IsContext c,FixmePerks m,MonadReader FixmeEnv m) => m [Syntax c]
|
||||
selectStageModified = withState do
|
||||
what <- select_ @_ @StageModRow [qc|select hash,ts,attr,value from fixmestagemod|]
|
||||
for what $ \(h,t,k,v) -> do
|
||||
pure $ mklist [mksym "modified", mkint t, mkstr h, mkstr k, mkstr v]
|
||||
|
||||
|
||||
selectStageDeleted :: (IsContext c,FixmePerks m,MonadReader FixmeEnv m) => m [Syntax c]
|
||||
selectStageDeleted = withState do
|
||||
what <- select_ @_ @(Text,Word64) [qc|select hash,ts from fixmestagedel|]
|
||||
for what $ \(h,t) -> do
|
||||
pure $ mklist [mksym "deleted", mkstr h]
|
||||
|
||||
selectStage :: (IsContext c,FixmePerks m,MonadReader FixmeEnv m) => m [Syntax c]
|
||||
selectStage = do
|
||||
a <- selectStageModified
|
||||
b <- selectStageDeleted
|
||||
pure (a<>b)
|
||||
|
||||
cleanStage :: (FixmePerks m,MonadReader FixmeEnv m) => m ()
|
||||
cleanStage = withState do
|
||||
transactional do
|
||||
update_ [qc|delete from fixmestagedel|]
|
||||
update_ [qc|delete from fixmestagemod|]
|
||||
pure ()
|
||||
|
||||
deleteFixme :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m ()
|
||||
deleteFixme hash = withState do
|
||||
|
|
@ -558,3 +655,4 @@ updateIndexes = withState $ transactional do
|
|||
update_ [qc|delete from fixmejson where fixme in (select distinct id from fixmedeleted)|]
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,8 @@
|
|||
module HBS2.Storage.Compact
|
||||
( Storage(..)
|
||||
, CompactStorage
|
||||
, CompactStorageOpenOpt(..)
|
||||
, readonly
|
||||
, compactStorageOpen
|
||||
, compactStorageClose
|
||||
, compactStorageCommit
|
||||
|
|
@ -154,6 +156,7 @@ data CompactStorage k =
|
|||
CompactStorage
|
||||
{ csBuckets :: Int
|
||||
, csFile :: FilePath
|
||||
, csOpts :: CompactStorageOpenOpt
|
||||
, csHandle :: MVar Handle
|
||||
, csHeaderOff :: TVar EntryOffset
|
||||
, csSeq :: TVar Integer
|
||||
|
|
@ -164,7 +167,20 @@ data CompactStorage k =
|
|||
|
||||
type ForCompactStorage m = MonadIO m
|
||||
|
||||
data CompactStorageOpenOpt
|
||||
data CompactStorageOpenOpt =
|
||||
CompactStorageOpenOpt
|
||||
{ csReadOnly :: Bool
|
||||
}
|
||||
|
||||
|
||||
instance Monoid CompactStorageOpenOpt where
|
||||
mempty = CompactStorageOpenOpt False
|
||||
|
||||
instance Semigroup CompactStorageOpenOpt where
|
||||
(<>) _ b = CompactStorageOpenOpt (csReadOnly b)
|
||||
|
||||
readonly :: CompactStorageOpenOpt
|
||||
readonly = CompactStorageOpenOpt True
|
||||
|
||||
data CompactStorageOpenError =
|
||||
InvalidHeader
|
||||
|
|
@ -182,11 +198,11 @@ getBucket sto bs = do
|
|||
|
||||
|
||||
compactStorageOpen :: forall k m . (ForCompactStorage m)
|
||||
=> [CompactStorageOpenOpt]
|
||||
=> CompactStorageOpenOpt
|
||||
-> FilePath
|
||||
-> m (CompactStorage k)
|
||||
|
||||
compactStorageOpen _ fp = do
|
||||
compactStorageOpen opt fp = do
|
||||
|
||||
let buck = 8
|
||||
|
||||
|
|
@ -206,11 +222,11 @@ compactStorageOpen _ fp = do
|
|||
>>= newTVarIO
|
||||
|
||||
if sz == 0 then
|
||||
pure $ CompactStorage buck fp mha hoff0 ss keys0 uncommitted mmapped
|
||||
pure $ CompactStorage buck fp opt mha hoff0 ss keys0 uncommitted mmapped
|
||||
else do
|
||||
(p,header) <- readHeader mha Nothing >>= maybe (throwIO InvalidHeader) pure
|
||||
hoff <- newTVarIO p
|
||||
let sto = CompactStorage buck fp mha hoff ss keys0 uncommitted mmapped
|
||||
let sto = CompactStorage buck fp opt mha hoff ss keys0 uncommitted mmapped
|
||||
readIndex sto (hdrIndexOffset header) (hdrIndexEntries header)
|
||||
|
||||
flip fix (hdrPrev header) $ \next -> \case
|
||||
|
|
@ -475,7 +491,10 @@ unmapFile sto = do
|
|||
|
||||
compactStorageClose :: ForCompactStorage m => CompactStorage k -> m ()
|
||||
compactStorageClose sto = do
|
||||
compactStorageCommit sto
|
||||
|
||||
unless (csOpts sto & csReadOnly) do
|
||||
compactStorageCommit sto
|
||||
|
||||
-- FIXME: hangs-forever-on-io-exception
|
||||
liftIO $ do
|
||||
unmapFile sto
|
||||
|
|
|
|||
Loading…
Reference in New Issue