wip

fixme-new/lib/Fixme/Run.hs

@@ -516,53 +516,44 @@ run what = do
 
           env <- ask
 
-          warn  $ red "play-log-file WIP" <+> pretty  fn
+          debug $ red "play-log-file WIP" <+> pretty  fn
-
-          warn  $ red "GENERATE FORMS? FROM STAGE"
 
           what <- selectStage
 
+          sto <- compactStorageOpen @HbSync mempty fn
+
           for_ what $ \w -> do
-            warn $ pretty w
+            let k = mkKey w
+            v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction .  LBS.fromStrict)
+            case v0 of
+              Nothing -> do
+                put sto k (LBS.toStrict $ serialise w)
 
-          warn  $ red "ADD RECORDS FROM STAGE TO BINARY LOG"
+              Just (Left{}) -> do
+                put sto k (LBS.toStrict $ serialise w)
 
-          -- sto <- compactStorageOpen @HbSync mempty fn
+              Just (Right prev) | getSequence w > getSequence prev -> do
+                put sto k (LBS.toStrict $ serialise w)
 
-          -- wtf <- S.toList_ $ runMaybeT do
+              _ -> pure ()
-          --         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
+          compactStorageCommit sto
-          -- -- FIXME: mtree-params-hardcode
 
-          -- let new = theLog & fmap ( fromString @Text . show . pretty )
+          ks <- keys sto
-          -- let pt = toPTree (MaxSize 1024) (MaxNum 256) new
 
-          -- -- FIXME: fuck-the-fucking-scientific
+          entries <- mapM (get sto) ks
-          -- --  сраный Scientiс не реализует Generic
+                      <&> catMaybes
-          -- --  и не открывает конструкторы, нельзя
+                      <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
-          -- --  сделать инстанс Serialise.
+                      <&> rights
-          -- --  надо выпилить его к херам. а пока вот так
-          -- h <- makeMerkle 0 pt $ \(_,_,bss) -> do
-          --        void $ putBlock sto bss
 
-          -- updateRef sto logRootKey h
 
-          -- compactStorageClose sto
+          compactStorageClose sto
 
-          -- liftIO $ print $ vcat (fmap pretty new)
+          let top = show $ vcat (fmap pretty entries)
+          let theLog = parseTop top & fromRight mempty
 
-          warn  $ red "DELETE STAGE"
+          liftIO $ withFixmeEnv env (runForms theLog)
-          warn  $ red "SCAN BINARY LOG?"
+          cleanStage
-          warn  $ red "RUN NEW FORMS"
-
-          -- liftIO $ withFixmeEnv env (runForms theLog)
-          -- cleanStage
 
         ListVal [SymbolVal "no-debug"] -> do
           setLoggingOff @DEBUG
@@ -586,14 +577,14 @@ run what = do
         ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do
           sto <- compactStorageOpen @HbSync readonly fn
 
-          -- FIXME: re-implement
+          ks <- keys sto
-          -- void $ runMaybeT do
-          --   rv <- MaybeT $ getRef sto logRootKey
 
-          --   walkMerkle rv (getBlock sto) $ \case
+          entries <- mapM (get sto) ks
-          --     Left{} -> error "malformed log"
+                      <&> catMaybes
-          --     Right (xs :: [Text]) -> do
+                      <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict)
-          --       liftIO $ mapM_ (print  . pretty) xs
+                      <&> rights
+
+          liftIO $ print $ vcat (fmap pretty entries)
 
           compactStorageClose sto
 

fixme-new/lib/Fixme/Types.hs

@@ -14,7 +14,8 @@ import Data.Config.Suckless
 import Prettyprinter.Render.Terminal
 import Control.Applicative
 import Data.Aeson
-import Data.ByteString.Lazy (ByteString)
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LBS
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as HM
 import Data.HashSet (HashSet)
@@ -177,15 +178,25 @@ data UpdateAction = forall c . IsContext c => UpdateAction { runUpdateAction ::
 data ReadLogAction = forall c . IsContext c => ReadLogAction { runReadLog :: Syntax c -> IO () }
 
 -- FIXME: fucking-context-hardcode-wtf-1
-data CatAction = CatAction { catAction :: [(Id, Syntax C)] -> ByteString -> IO () }
+data CatAction = CatAction { catAction :: [(Id, Syntax C)] -> LBS.ByteString -> IO () }
 
 data SimpleTemplate = forall c . (IsContext c, Data (Context c), Data c) => SimpleTemplate [Syntax c]
 
+class HasSequence w where
+  getSequence :: w -> Word64
+
 data CompactAction =
     Deleted  Word64 HashRef
   | Modified Word64 HashRef FixmeAttrName FixmeAttrVal
   deriving stock (Eq,Ord,Show,Generic)
 
+class MkKey a where
+  mkKey :: a -> ByteString
+
+instance MkKey CompactAction where
+  mkKey (Deleted _ h) = "D" <> LBS.toStrict (serialise h)
+  mkKey (Modified _ h _ _) = "M" <> LBS.toStrict (serialise h)
+
 instance Pretty CompactAction where
   pretty = \case
     Deleted s r      -> pretty $ mklist @C [ mksym "deleted", mkint s, mkstr r  ]
@@ -193,6 +204,19 @@ instance Pretty CompactAction where
 
 instance Serialise CompactAction
 
+pattern CompactActionSeq :: Word64 -> CompactAction
+pattern CompactActionSeq s <- (seqOf -> Just s)
+
+{-# COMPLETE CompactActionSeq #-}
+
+seqOf :: CompactAction -> Maybe Word64
+seqOf = \case
+  Deleted   w  _ -> Just w
+  Modified  w _ _ _ -> Just w
+
+instance HasSequence CompactAction where
+  getSequence x = fromMaybe 0 (seqOf x)
+
 data FixmeTemplate =
   Simple SimpleTemplate