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,82 +965,126 @@ 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 members = view refChanHeadReaders rch & HS.toList
+  let statePath = dir </> ".hbs2-sync" </> "state"
 
-  krl <- liftIO $ runKeymanClient $ loadKeyRingEntries members
+  db <- newDBPipeEnv dbPipeOptsDef (statePath </> "state.db")
-              <&> L.sortOn (Down . fst)
-              <&> fmap snd
 
-  let krs = HM.fromList [ (pk,e) | e@(KeyringEntry pk _ _) <- krl ]
+  flip runContT pure do
 
-  let findKey gk = do
+    void $ ContT $ bracket (async (runPipe db)) cancel
-        r <- S.toList_ do
+
-              forM_ (HM.toList $ recipients gk) $ \(pk,box) -> runMaybeT do
+    withDB db $ do
-                (KeyringEntry ppk ssk _) <- toMPlus $ HM.lookup pk krs
+      ddl [qc|create table if not exists entry (txhash text not null primary key, s blob not null)|]
-                let s = Symm.lookupGroupKey @'HBS2Basic ssk ppk gk
+      ddl [qc|create table if not exists seen (txhash text not null primary key)|]
-                for_ s $ lift . S.yield
+      commitAll
-        pure $ headMay r
+
+    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
+                <&> L.sortOn (Down . fst)
+                <&> fmap snd
+
+    let krs = HM.fromList [ (pk,e) | e@(KeyringEntry pk _ _) <- krl ]
+
+    let findKey gk = do
+          r <- S.toList_ do
+                forM_ (HM.toList $ recipients gk) $ \(pk,box) -> runMaybeT do
+                  (KeyringEntry ppk ssk _) <- toMPlus $ HM.lookup pk krs
+                  let s = Symm.lookupGroupKey @'HBS2Basic ssk ppk gk
+                  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
+    lift $ walkRefChanTx @UNIX check rchan $ \txh u -> do
+
+      atomically $ writeTQueue seen txh
+
+      case  u of
+
+        A (AcceptTran ts _ what) -> do
+          -- debug $ red "ACCEPT" <+> pretty ts <+> pretty what
+          for_ ts $ \w -> do
+            atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 w))
+
+        P orig (ProposeTran _ box) -> void $ runMaybeT do
+          (_, bs) <- unboxSignedBox0 box & toMPlus
+          AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
+                                      & toMPlus . either (const Nothing) Just
 
 
-  -- FIXME: may-be-slow
+          runExceptT (extractMetaData @'HBS2Basic findKey sto href)
-  walkRefChanTx @UNIX (\t -> pure True) rchan $ \txh u -> do
+           >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, ((href, meta), txh)) )
 
-    case  u of
 
-      A (AcceptTran ts _ what) -> do
-        -- debug $ red "ACCEPT" <+> pretty ts <+> pretty what
-        for_ ts $ \w -> do
-          atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 w))
 
-      P orig (ProposeTran _ box) -> void $ runMaybeT do
+    trees <- atomically (flushTQueue outq)
-        (_, bs) <- unboxSignedBox0 box & toMPlus
-        AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
-                                    & toMPlus . either (const Nothing) Just
 
-        runExceptT (extractMetaData @'HBS2Basic findKey sto href)
+    tsmap <- readTVarIO tss
-         >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, ((href, meta), txh)) )
 
-  trees <- atomically (flushTQueue outq)
+    lift $ withDB db $ transactional do
 
-  tsmap <- readTVarIO tss
+      -- 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 ]
 
-  ess0 <- S.toList_ do
+        void $ runMaybeT do
-    for_ trees $ \(txh, ((tree, meta),txxx)) -> do
+          fn   <- toMPlus $ headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ]
-      let what = parseTop meta & fromRight mempty
+          ts   <- toMPlus $ HM.lookup txh tsmap
-      let loc  = headDef "" [ l | ListVal [StringLike "location:", StringLike l] <- what ]
+          let tomb = or [ True | TombLikeOpt <- what  ]
+          let fullPath = loc </> fn
 
-      void $ runMaybeT do
+          trace $ red "META" <+> pretty what
-        fn   <- toMPlus $ headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ]
-        ts   <- toMPlus $ HM.lookup txh tsmap
-        let tomb = or [ True | TombLikeOpt <- what  ]
-        let fullPath = loc </> fn
 
-        trace $ red "META" <+> pretty what
+          if tomb then do
+            let r = 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)
 
-        if tomb then do
+          else do
-          lift $ S.yield $
+            let r = entriesFromFile (Just tree) ts fullPath
-            Map.singleton fullPath (makeTomb ts fullPath (Just tree))
-        else do
-          let r = entriesFromFile (Just tree) ts fullPath
-          lift $ S.yield r
 
-  let r = Map.unionsWith merge ess0
+            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)
 
-  liftIO $ LBS.writeFile ".GOVNOSTATE" (serialise r)
+              -- lift $ S.yield r
 
-  pure (Map.toList 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
+
+    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