wip, somehow works with sqlite

hbs2-sync/src/HBS2/Sync/Prelude.hs

@@ -49,6 +49,8 @@ import Data.Config.Suckless as Exported
 import Data.Config.Suckless.Script as Exported
 import Data.Config.Suckless.Script.File
 
+import DBPipe.SQLite
+
 import Codec.Serialise as Exported
 import Control.Applicative
 import Control.Concurrent.STM (flushTQueue)
@@ -57,8 +59,10 @@ import Control.Monad.Trans.Cont as Exported
 import Control.Monad.Trans.Maybe
 import Control.Monad.Except
 import Data.Ord
+import Data.ByteString qualified as BS
 import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString (ByteString)
 import Data.Coerce
 import Data.Either
 import Data.HashMap.Strict qualified as HM
@@ -77,6 +81,7 @@ import Streaming.Prelude qualified as S
 import System.Directory (getModificationTime,setModificationTime,doesFileExist,listDirectory)
 import System.Directory (XdgDirectory(..),getXdgDirectory)
 import System.Exit qualified as Exit
+import Text.InterpolatedString.Perl6 (qc)
 
 import UnliftIO.IO.File qualified as UIO
 
@@ -742,8 +747,8 @@ postEntryTx nonce' mgk refchan path entry = do
     -- FIXME: remove-nonce
     --   пока что будем постить транзакцию всегда.
     --   в дальнейшем стоит избавиться от нонса
-    let nonce = fromMaybe mempty nonce'
+    nonce <- liftIO $ getPOSIXTime <&> round <&> BS.take 6 . coerce  . hashObject @HbSync . serialise
-    let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx <> nonce)
+    let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx <> LBS.fromStrict nonce)
 
     notice $ red "post tree tx" <+> pretty p <+> pretty href
 
@@ -936,6 +941,19 @@ getStateFromDir seed path incl excl = do
            S.yield (p,e)
 
 
+
+  -- dbPath <- getStatePath
+  -- env <- liftIO newAppEnv
+  -- let db = appDb env
+  -- flip runContT pure $ do
+  --   void $ ContT $ bracket (async (runPipe db)) cancel
+
+  --   here <- doesPathExist dbPath
+
+  --   unless here do
+  --     withDB db $ populateState
+
+
 getStateFromRefChan :: forall m . ( MonadUnliftIO  m
                                   , HasClientAPI RefChanAPI UNIX m
                                   , HasClientAPI StorageAPI UNIX m
@@ -947,18 +965,32 @@ getStateFromRefChan :: forall m . ( MonadUnliftIO  m
                     -> m [(FilePath, Entry)]
 getStateFromRefChan rchan = do
 
-  debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan)
+  dir <- getRunDir
-
-  cache <- getCache
 
   sto <- getStorage
 
-  outq <- newTQueueIO
-  tss <- newTVarIO mempty
-
   rch <- Client.getRefChanHead @UNIX rchan
                >>= orThrow RefChanHeadNotFoundException
 
+  let statePath = dir </> ".hbs2-sync" </> "state"
+
+  db <- newDBPipeEnv dbPipeOptsDef (statePath </> "state.db")
+
+  flip runContT pure do
+
+    void $ ContT $ bracket (async (runPipe db)) cancel
+
+    withDB db $ do
+      ddl [qc|create table if not exists entry (txhash text not null primary key, s blob not null)|]
+      ddl [qc|create table if not exists seen (txhash text not null primary key)|]
+      commitAll
+
+    debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan)
+
+    outq <- newTQueueIO
+    seen <- newTQueueIO
+    tss <- newTVarIO mempty
+
     let members = view refChanHeadReaders rch & HS.toList
 
     krl <- liftIO $ runKeymanClient $ loadKeyRingEntries members
@@ -975,9 +1007,17 @@ getStateFromRefChan rchan = do
                   for_ s $ lift . S.yield
           pure $ headMay r
 
+    -- let check hx = pure True
+
+    let check hx = do
+         withDB db do
+          r <- select @(Only Int) [qc|select 1 from seen where txhash = ? limit 1|] (Only (show $ pretty $ hx))
+          pure $ L.null r
 
     -- FIXME: may-be-slow
-  walkRefChanTx @UNIX (\t -> pure True) rchan $ \txh u -> do
+    lift $ walkRefChanTx @UNIX check rchan $ \txh u -> do
+
+      atomically $ writeTQueue seen txh
 
       case  u of
 
@@ -991,14 +1031,19 @@ getStateFromRefChan rchan = do
           AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
                                       & toMPlus . either (const Nothing) Just
 
+
           runExceptT (extractMetaData @'HBS2Basic findKey sto href)
            >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, ((href, meta), txh)) )
 
+
+
     trees <- atomically (flushTQueue outq)
 
     tsmap <- readTVarIO tss
 
-  ess0 <- S.toList_ do
+    lift $ withDB db $ transactional do
+
+      -- ess0 <- S.toList_ do
       for_ trees $ \(txh, ((tree, meta),txxx)) -> do
         let what = parseTop meta & fromRight mempty
         let loc  = headDef "" [ l | ListVal [StringLike "location:", StringLike l] <- what ]
@@ -1012,16 +1057,33 @@ getStateFromRefChan rchan = do
           trace $ red "META" <+> pretty what
 
           if tomb then do
-          lift $ S.yield $
+            let r = Map.singleton fullPath (makeTomb ts fullPath (Just tree))
-            Map.singleton fullPath (makeTomb ts fullPath (Just tree))
+            withDB db do
+              insert [qc| insert into entry (txhash,s) values(?,?)
+                          on conflict (txhash) do update set s = excluded.s
+                        |] (show $ pretty $ txxx, serialise r)
+
           else do
             let r = entriesFromFile (Just tree) ts fullPath
-          lift $ S.yield r
+
+            withDB db do
+              insert [qc| insert into entry (txhash,s) values(?,?)
+                          on conflict (txhash) do update set s = excluded.s
+                        |] (show $ pretty $ txxx, serialise r)
+
+              -- lift $ S.yield r
+
+      seenTx <- atomically $ flushTQueue seen
+      for_ seenTx $ \txh -> do
+        insert [qc|insert into seen (txhash) values(?)|] (Only (show $ pretty $ txh))
+
+    ess0 <- withDB db do
+           select_ [qc|select s from entry|]
+             <&> fmap (deserialiseOrFail @(Map FilePath Entry) . LBS.fromStrict . fromOnly)
+             <&> rights
 
     let r = Map.unionsWith merge ess0
 
-  liftIO $ LBS.writeFile ".GOVNOSTATE" (serialise r)
-
     pure (Map.toList r)
 
   -- pure $ Map.toList $ Map.unionsWith merge ess0
@@ -1094,7 +1156,6 @@ instance HasRunDir m => HasRunDir (ContT r m) where
   getRunDirEnv d = lift (getRunDirEnv d)
   alterRunDirEnv d a = lift (alterRunDirEnv d a)
 
-
 instance HasTombs m => HasTombs (ContT r m) where
   getTombs = lift getTombs
   closeTombs = lift closeTombs