wip

.fixme-new/log

@@ -1,5 +0,0 @@
-modified 1716433451 "2piRBmaQkb3c2nAcH6Mrf8EAddNJF34c6Tm8PWnbVBqN" "workflow" "done"
-deleted "9m2B74CHFTGBTWXo1uNoi9StuQ3AxnMpULwbLcToMkmZ"
-deleted "EUP5zeroTKWuP96dQQrZVZqUhBXdh8icD3P9EebYo9HR"
-modified 1716435973 "H2AZFfGZsSaVWyBme21PJQkprAn5yaizf8LNGQekFhPe" "workflow" "test"
-deleted "ETndVbmSb2T6rPPF8k7BSYnYzAWbaUtifvQEUQVFeLzQ"

fixme-new/fixme.cabal

@@ -80,6 +80,7 @@ common shared-properties
       , mtl
       , safe
       , serialise
+      , scientific
       , streaming
       , stm
       , text

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}"|]
+    lift $ insertFixmeDelStaged ha
-
-    debug $ red "deleted" <+> pretty ha
-
-    for_ acts $ \(UpdateAction what) -> do
-      liftIO $ what (Literal noContext syn)
 
 
 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}"|]
+    lift $ insertFixmeModStaged ha (fromString a) (fromString b)
-
-    debug $ red $ pretty syn
-
-    for_ acts $ \(UpdateAction what) -> do
-      liftIO $ what (Literal noContext syn)
-
-
 
 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
 

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)
+mklist :: IsContext c => [Syntax c] -> Syntax c
-      mksym  = Symbol (noContext :: Context c)
+mklist ss = List noContext ss
-      mkstr = Literal (noContext :: Context c) . LitStr
+
+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)|]
 
 
+

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