wip, removing obsolete stuff, mkdir for state

hbs2-git3/app/Main.hs

@@ -30,14 +30,12 @@ import HBS2.CLI.Run.RefLog (getCredentialsForReflog,mkRefLogUpdateFrom)
 import HBS2.System.Dir
 
 import HBS2.Git3.Types
-import HBS2.Git3.State.Direct
 import HBS2.Git3.Config.Local
 import HBS2.Git3.Git
 import HBS2.Git3.Export
 
 import Data.Config.Suckless.Script
 import Data.Config.Suckless.Script.File
-import DBPipe.SQLite
 
 import Codec.Compression.Zstd.Streaming qualified as ZstdS
 import Codec.Compression.Zstd.Streaming (Result(..))
@@ -142,6 +140,10 @@ recover m = fix \again -> do
 
         ref <- getGitRemoteKey >>= orThrowUser "remote ref not set"
 
+        state <- getStatePath (AsBase58 ref)
+
+        mkdir state
+
         let sto = AnyStorage (StorageClient storageAPI)
 
         connected <- Git3Connected soname sto peerAPI refLogAPI
@@ -582,46 +584,6 @@ theDict = do
 
           _ -> throwIO (BadFormException @C nil)
 
-
-        entry $ bindMatch "test:git:log:index:entry" $ nil_ $ \case
-          [LitIntVal i, StringLike fn] -> lift do
-
-            bs <- liftIO $ mmapFileByteString fn Nothing
-            let index = fromIntegral i
-            let offset = index * 24
-
-            let record = BS.take 24 (BS.drop offset bs)
-            let n = BS.take 4 record & N.word32
-            let key = BS.take 20 $ BS.drop 4 record
-            liftIO $ print $ pretty n <+> pretty (GitHash key)
-
-          _ -> throwIO (BadFormException @C nil)
-
-        entry $ bindMatch "test:git:log:index:flat" $ nil_ $ \syn -> lift do
-          let (_, argz) = splitOpts [] syn
-          let fnames = [ x | StringLike x <- argz]
-
-          s <- randomIO @Word16
-          liftIO $ withBinaryFile (show ("index" <> pretty s <> ".idx")) AppendMode $ \fh -> do
-
-            all <- S.toList_ do
-
-              for_ fnames $ \f -> do
-                theLog <- liftIO $ LBS.readFile f
-
-                void $ runConsumeLBS (ZstdL.decompress theLog) $  readLogFileLBS () $ \h s lbs -> do
-                  lift $ S.yield (coerce @_ @BS.ByteString h)
-                  debug $ "object" <+> pretty h
-
-            let sorted = Set.toList $ Set.fromList all
-
-            for_ sorted $ \ghs -> do
-              let ks = BS.length ghs
-              let entrySize = N.bytestring32 (fromIntegral ks)
-              BS.hPutStr fh entrySize
-              BS.hPutStr fh ghs
-
-
         entry $ bindMatch "test:segment:dump" $ nil_ $ \syn -> lift do
           sto <- getStorage
           let (_, argz) = splitOpts [] syn
@@ -838,68 +800,6 @@ theDict = do
 
           _ -> throwIO (BadFormException @C nil)
 
-        entry $ bindMatch "test:git:reflog:index:sqlite" $ nil_ $ \syn -> lift $ connectedDo do
-
-          reflog <- getGitRemoteKey >>= orThrowUser "reflog not set"
-
-          api <- getClientAPI @RefLogAPI @UNIX
-
-          sto <- getStorage
-
-          flip runContT pure do
-
-            what' <- lift $ callRpcWaitMay @RpcRefLogGet (TimeoutSec 2) api reflog
-                      >>= orThrowUser "rpc timeout"
-
-            what <- ContT $ maybe1 what' none
-
-            idxPath <- getStatePath (AsBase58 reflog) <&> (</> "index")
-            mkdir idxPath
-
-            debug $ "STATE" <+> pretty idxPath
-
-            sink <- S.toList_ do
-              walkMerkle (coerce what) (getBlock sto) $ \case
-                Left{} -> throwIO MissedBlockError
-                Right (hs :: [HashRef]) -> do
-                  for_ hs $ \h -> void $ runMaybeT do
-
-                    tx <- getBlock sto (coerce h)
-                             >>= toMPlus
-
-                    RefLogUpdate{..} <- deserialiseOrFail @(RefLogUpdate L4Proto) tx
-                                          & toMPlus
-
-                    AnnotatedHashRef _ href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict _refLogUpdData)
-                                                 & toMPlus
-
-                    -- FIXME: error logging
-                    lbs <- liftIO (runExceptT (getTreeContents sto href))
-                             >>= orThrow MissedBlockError
-
-                    pieces <- S.toList_ do
-                      void $ runConsumeLBS (ZstdL.decompress lbs) $ readLogFileLBS () $ \o s _ -> do
-                        lift $ S.yield o
-
-                    lift $ S.yield (h, pieces)
-
-            file <- liftIO $ Temp.emptyTempFile "" "index.db"
-
-            db <- newDBPipeEnv dbPipeOptsDef file
-
-            liftIO $ withDB db do
-
-              ddl [qc|create table object (sha1 text not null primary key, tx text not null)|]
-
-              for_ sink $ \(h, pieces) -> do
-                transactional do
-                  for_ pieces $ \p -> do
-                    void $ insert [qc|insert into
-                                        object (sha1,tx)
-                                      values(?,?)
-                                      on conflict (sha1)
-                                      do update set tx = excluded.tx|] (p,h)
-
         entry $ bindMatch "reflog:index:compact" $ nil_ $ \_ -> lift do
           size <- getIndexBlockSize
           compactIndex size

hbs2-git3/hbs2-git3.cabal

@@ -125,7 +125,6 @@ library
       HBS2.Git3.Prelude
       HBS2.Git3.Export
       HBS2.Git3.State.Types
-      HBS2.Git3.State.Direct
       HBS2.Git3.State.Index
       HBS2.Git3.Config.Local
       HBS2.Git3.Git

hbs2-git3/lib/HBS2/Git3/Prelude.hs

@@ -2,6 +2,7 @@
 {-# Language RecordWildCards #-}
 {-# Language UndecidableInstances #-}
 {-# Language AllowAmbiguousTypes #-}
+{-# Language PatternSynonyms #-}
 module HBS2.Git3.Prelude
   ( module HBS2.Git3.Prelude
   , module Exported
@@ -9,6 +10,7 @@ module HBS2.Git3.Prelude
   , module HBS2.Peer.RPC.Client.Unix
   , module Codec.Serialise
   , runExceptT
+  , pattern SignPubKeyLike
   ) where
 
 import HBS2.Prelude.Plated as Exported
@@ -17,6 +19,7 @@ import HBS2.Data.Types.Refs as Exported
 import HBS2.Base58 as Exported
 import HBS2.Merkle as Exported
 import HBS2.Misc.PrettyStuff as Exported
+import HBS2.Net.Auth.Credentials
 import HBS2.Peer.Proto.RefLog as Exported
 import HBS2.Peer.RPC.API.RefLog as Exported
 import HBS2.Peer.RPC.API.Peer as Exported
@@ -27,6 +30,7 @@ import HBS2.Storage.Operations.Class as Exported
 import HBS2.System.Logger.Simple.ANSI as Exported
 
 import HBS2.Git3.Types as Exported
+import HBS2.Git3.State.Types as Exported
 
 -- TODO: about-to-remove
 import DBPipe.SQLite

hbs2-git3/lib/HBS2/Git3/State/Direct.hs

@@ -1,141 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module HBS2.Git3.State.Direct
-  ( module HBS2.Git3.State.Direct
-  , module HBS2.Git3.State.Types
-  ) where
-
-import HBS2.Prelude.Plated
-import HBS2.OrDie
-import HBS2.Data.Types.Refs
-import HBS2.System.Dir
-
-import HBS2.Git3.Config.Local
-import HBS2.Git.Local
-import HBS2.Git.Local.CLI (findGitDir)
-
-import HBS2.Git3.State.Types
-
-import DBPipe.SQLite as SQL
-
-import System.Directory
-import Control.Monad.Trans.Maybe
-import Data.Maybe
-import Data.Word
-import Data.List qualified as List
-
-import Text.InterpolatedString.Perl6 (qc)
-
-
-getStatePathDB :: (MonadIO m, DBRef db) => db -> m FilePath
-getStatePathDB p = do
-  getStatePath p <&> (</> "state" </> "state.db")
-
-withState :: (MonadIO m, HasStateDB m) => DBPipeM m a -> m a
-withState action = getStateDB >>= flip withDB action
-
-evolveState :: (MonadIO m, HasStateDB m) => m ()
-evolveState = do
-  withState do
-
-    ddl [qc|
-create table if not exists
-cblock
-  ( id      integer primary key autoincrement
-  , cblock  text not null
-  , unique  (cblock)
-  )
-|]
-
-    ddl [qc|
-create table if not exists
-kommit
-  ( kommit  text primary key
-  , cblock  integer not null
-  )
-|]
-
-    ddl [qc|
-create table if not exists
-imported ( cblock integer primary key )
-|]
-
-instance ToField GitHash where
-  toField h = toField (show $ pretty h)
-
-instance ToField GitRef where
-  toField h = toField (show $ pretty h)
-
-instance FromField GitRef where
-  fromField = fmap fromString . fromField @String
-
-instance FromField GitHash where
-  fromField = fmap fromString . fromField @String
-
-instance ToField HashRef where
-  toField x = toField $ show $ pretty x
-
-instance FromField HashRef where
-  fromField = fmap (fromString @HashRef) . fromField @String
-
-data DatabaseError =
-  SomeDatabaseError
-  deriving stock (Typeable,Show)
-
-instance Exception DatabaseError
-
-insertImported :: MonadUnliftIO m => HashRef -> DBPipeM m ()
-insertImported cblock = void $ runMaybeT do
-  (n,_) <- lift (selectCBlockByHash cblock) >>= toMPlus
-  lift do
-    insert [qc| insert into imported (cblock) values(?)
-                on conflict (cblock) do nothing
-              |] (Only n)
-
-selectImported :: MonadUnliftIO m => HashRef -> DBPipeM m Bool
-selectImported cblock = do
-  select @(Only Bool)
-      [qc| select true from imported i join cblock c on c.id = i.cblock
-           where c.cblock = ?
-           limit 1
-         |] (Only cblock)
-  <&> not . List.null
-
-insertCBlock :: MonadUnliftIO m => GitHash -> HashRef -> DBPipeM m ()
-insertCBlock co cblk = do
-  transactional do
-    n <- select @(Only Word32) [qc|
-      insert into cblock (cblock) values(?)
-      on conflict (cblock) do update set cblock = excluded.cblock
-      returning id |]
-            (Only cblk)
-            <&> listToMaybe . fmap fromOnly
-            >>= orThrow SomeDatabaseError
-
-    insert [qc| insert into kommit (kommit,cblock) values(?,?)
-                on conflict (kommit) do update set cblock = excluded.cblock
-           |] (co,n)
-
-selectCBlockByHash :: MonadIO m => HashRef -> DBPipeM m (Maybe (Word32, HashRef))
-selectCBlockByHash cblock = do
-  select [qc| select c.id, c.cblock
-              from cblock c
-              where c.cblock = ? limit 1|] (Only cblock)
-   <&> listToMaybe
-
-selectCBlock :: MonadIO m => GitHash -> DBPipeM m (Maybe (Word32, HashRef))
-selectCBlock gh = do
-  select [qc| select c.id, c.cblock
-              from kommit k join cblock c on k.cblock = c.id
-              where kommit = ? limit 1|] (Only gh)
-   <&> listToMaybe
-
--- selectCBlockId :: MonadIO m => HashRef -> DBPipeM m (Maybe Word32)
--- selectCBlockId hh = do
---   select [qc|select id from cblock where cblock = ? limit 1|] (Only hh)
---    <&> fmap fromOnly . listToMaybe
-
--- selectCommitsByCBlock :: MonadIO m => HashRef -> DBPipeM m [GitHash]
--- selectCommitsByCBlock cb = do
---   select [qc|select kommit from cblock where cblock = ? limit 1|] (Only cb)
---    <&> fmap fromOnly
-

hbs2-git3/lib/HBS2/Git3/State/Index.hs

@@ -70,7 +70,7 @@ indexPath :: forall m . ( Git3Perks m
                         ) => m FilePath
 indexPath = do
   reflog <- getGitRemoteKey >>= orThrow Git3ReflogNotSet
-  getStatePath (AsBase58 reflog) <&> (</> "index")
+  getStatePath (AsBase58 reflog)
 
 data IndexEntry =
   IndexEntry
@@ -125,7 +125,7 @@ mergeSortedFilesN getKey inputFiles outFile = do
 compactIndex :: forall m . (Git3Perks m, MonadReader Git3Env m) => Natural -> m ()
 compactIndex maxSize = do
   reflog <- getGitRemoteKey >>= orThrowUser "reflog not set"
-  idxPath <- getStatePath (AsBase58 reflog) <&> (</> "index")
+  idxPath <- getStatePath (AsBase58 reflog)
   mkdir idxPath
   files <- listObjectIndexFiles <&> L.sortOn snd
 
@@ -384,13 +384,16 @@ updateReflogIndex = do
                                    | ListVal [LitIntVal t, GitHashLike h, StringLike x]
                                    <- parseTop (LBS8.unpack llbs) & fromRight mempty
                                    ]
-                        liftIO $ mapM_ (print . pretty) refs
 
-                      lift $ S.yield o
+                        lift $ S.yield (Left refs)
 
-                  lift $ S.yield (h, pieces)
+                      lift $ S.yield (Right o)
 
-      liftIO $ forConcurrently_ sink $ \(tx, pieces) -> do
+                  lift do
+                    S.yield (Right (h, rights pieces))
+                    S.yield (Left  (h, lefts pieces))
+
+      liftIO $ forConcurrently_ (rights sink) $ \(tx, pieces) -> do
         idxName <- emptyTempFile idxPath "objects-.idx"
         let ss = L.sort pieces
         UIO.withBinaryFileAtomic idxName WriteMode $ \wh -> do
@@ -402,3 +405,14 @@ updateReflogIndex = do
 
       getIndexBlockSize >>= lift . compactIndex
 
+      liftIO do
+        name <- emptyTempFile idxPath ".ref"
+        UIO.withBinaryFileAtomic name WriteMode $ \wh -> do
+          for_ (lefts sink) $ \(tx, refs) -> do
+            for_ (mconcat refs) $ \(ts,gh,nm) -> do
+              LBS8.hPutStrLn wh $ LBS8.pack $ show $
+                  "R" <+> pretty tx
+                      <+> pretty ts
+                      <+> pretty gh
+                      <+> pretty nm
+