voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
Dmitry Zuikov 2024-06-03 14:00:39 +03:00
parent 5eed1746e2
commit 570f93543d
4 changed files with 49 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
.fixme-new/log
View File

Binary file not shown.

66
fixme-new/lib/Fixme/Run.hs
View File

@ -520,50 +520,49 @@ run what = do
warn $ red "GENERATE FORMS? FROM STAGE"
what <- selectStage @C
what <- selectStage
for_ what $ \w -> do
warn $ pretty w
warn $ red "ADD RECORDS FROM STAGE TO BINARY LOG"
sto <- compactStorageOpen @HbSync mempty fn
-- 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)
-- 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 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
-- 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
-- -- FIXME: fuck-the-fucking-scientific
-- -- сраный Scientiс не реализует Generic
-- -- и не открывает конструкторы, нельзя
-- -- сделать инстанс Serialise.
-- -- надо выпилить его к херам. а пока вот так
-- h <- makeMerkle 0 pt $ \(_,_,bss) -> do
-- void $ putBlock sto bss
updateRef sto logRootKey h
-- updateRef sto logRootKey h
compactStorageClose sto
-- compactStorageClose sto
liftIO $ print $ vcat (fmap pretty new)
-- 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
-- liftIO $ withFixmeEnv env (runForms theLog)
-- cleanStage
ListVal [SymbolVal "no-debug"] -> do
setLoggingOff @DEBUG
@ -581,19 +580,20 @@ run what = do
cleanStage
ListVal [SymbolVal "builtin:show-stage"] -> do
stage <- selectStage @C
stage <- selectStage
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
-- FIXME: re-implement
-- 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
-- walkMerkle rv (getBlock sto) $ \case
-- Left{} -> error "malformed log"
-- Right (xs :: [Text]) -> do
-- liftIO $ mapM_ (print . pretty) xs
compactStorageClose sto

15
fixme-new/lib/Fixme/State.hs
View File

@ -570,22 +570,21 @@ insertFixmeDelStaged hash = withState do
|] (hash,ts)
type StageModRow = (Text,Integer,Text,Text)
type StageModRow = (HashRef,Word64,Text,Text)
selectStageModified :: (IsContext c,FixmePerks m,MonadReader FixmeEnv m) => m [Syntax c]
selectStageModified :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
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]
pure $ Modified t h (FixmeAttrName k) (FixmeAttrVal v)
selectStageDeleted :: (IsContext c,FixmePerks m,MonadReader FixmeEnv m) => m [Syntax c]
selectStageDeleted :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
selectStageDeleted = withState do
what <- select_ @_ @(Text,Word64) [qc|select hash,ts from fixmestagedel|]
what <- select_ @_ @(HashRef,Word64) [qc|select hash,ts from fixmestagedel|]
for what $ \(h,t) -> do
pure $ mklist [mksym "deleted", mkstr h]
pure $ Deleted t h
selectStage :: (IsContext c,FixmePerks m,MonadReader FixmeEnv m) => m [Syntax c]
selectStage :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction]
selectStage = do
a <- selectStageModified
b <- selectStageDeleted

10
fixme-new/lib/Fixme/Types.hs
View File

@ -66,6 +66,12 @@ class IsContext c => MkStr c a where
instance IsContext c => MkStr c FixmeAttrVal where
mkstr (s :: FixmeAttrVal) = Literal (noContext @c) (LitStr (coerce s))
instance IsContext c => MkStr c FixmeAttrName where
mkstr (s :: FixmeAttrName) = Literal (noContext @c) (LitStr (coerce s))
instance IsContext c => MkStr c HashRef where
mkstr s = Literal (noContext @c) (LitStr (fromString $ show $ pretty s))
instance IsContext c => MkStr c Text where
mkstr = Literal noContext . LitStr
@ -182,8 +188,10 @@ data CompactAction =
instance Pretty CompactAction where
pretty = \case
Deleted s r -> pretty $ mklist @C [ mksym "deleted" ]
Deleted s r -> pretty $ mklist @C [ mksym "deleted", mkint s, mkstr r ]
Modified s r k v -> pretty $ mklist @C [ mksym "modified", mkint s, mkstr r, mkstr k, mkstr v ]
instance Serialise CompactAction
data FixmeTemplate =
Simple SimpleTemplate