diff --git a/.fixme-new/log b/.fixme-new/log deleted file mode 100644 index bd5ebccd..00000000 --- a/.fixme-new/log +++ /dev/null @@ -1,5 +0,0 @@ -modified 1716433451 "2piRBmaQkb3c2nAcH6Mrf8EAddNJF34c6Tm8PWnbVBqN" "workflow" "done" -deleted "9m2B74CHFTGBTWXo1uNoi9StuQ3AxnMpULwbLcToMkmZ" -deleted "EUP5zeroTKWuP96dQQrZVZqUhBXdh8icD3P9EebYo9HR" -modified 1716435973 "H2AZFfGZsSaVWyBme21PJQkprAn5yaizf8LNGQekFhPe" "workflow" "test" -deleted "ETndVbmSb2T6rPPF8k7BSYnYzAWbaUtifvQEUQVFeLzQ" diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal index 5e11968b..53d1a3a9 100644 --- a/fixme-new/fixme.cabal +++ b/fixme-new/fixme.cabal @@ -80,6 +80,7 @@ common shared-properties , mtl , safe , serialise + , scientific , streaming , stm , text diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs index 2df8b547..3a6ed335 100644 --- a/fixme-new/lib/Fixme/Run.hs +++ b/fixme-new/lib/Fixme/Run.hs @@ -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 diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs index cc31fa2d..ca4f0c8c 100644 --- a/fixme-new/lib/Fixme/State.hs +++ b/fixme-new/lib/Fixme/State.hs @@ -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)|] + diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs b/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs index 0406238d..a6a1ed83 100644 --- a/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs +++ b/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs @@ -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