removing old hbs2-git

Makefile

@@ -12,12 +12,9 @@ BINS := \
   hbs2-peer          \
   hbs2-keyman        \
 	hbs2-fixer         \
-	hbs2-git-reposync  \
 	hbs2-git-subscribe \
   git-remote-hbs2    \
   git-hbs2           \
-  git-remote-hbs21   \
-  git-hbs21          \
 
 ifeq ($(origin .RECIPEPREFIX), undefined)
   $(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later)

flake.nix

@@ -33,11 +33,9 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-core"
      "hbs2-storage-simple"
      "hbs2-git"
-     "hbs2-git-reposync"
      "hbs2-qblf"
      "hbs2-keyman"
      "hbs2-share"
-     "hbs21-git"
      "hbs2-fixer"
     ];
   in
@@ -62,8 +60,6 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-keyman" = "./hbs2-keyman";
      "hbs2-share"  = "./hbs2-share";
      "hbs2-git"    = "./hbs2-git";
-     "hbs21-git"   = "./hbs21-git";
-     "hbs2-git-reposync"   = "./hbs2-git-reposync";
      "hbs2-fixer"  = "./hbs2-fixer";
    };
 

hbs2-core/lib/HBS2/Net/Auth/Schema.hs

@@ -1,6 +1,9 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# Language UndecidableInstances #-}
-module HBS2.Net.Auth.Schema where
+module HBS2.Net.Auth.Schema
+  ( module HBS2.Net.Auth.Schema
+  , module HBS2.Net.Proto.Types
+  ) where
 
 import HBS2.Prelude
 import HBS2.OrDie

hbs2-core/lib/HBS2/System/Dir.hs

@@ -7,9 +7,11 @@ module HBS2.System.Dir
 
 import System.FilePath
 import System.FilePattern
-import System.Directory as D
+import System.Directory qualified as D
-import UnliftIO hiding (try)
+import Data.ByteString.Lazy qualified as LBS
-
+import UnliftIO
+import Control.Exception qualified as E
+import Control.Monad
 
 data MkDirOpt = MkDirOptNone
 
@@ -27,7 +29,32 @@ instance ToFilePath FilePath where
 
 mkdir :: (MonadIO m, ToFilePath a) => a -> m ()
 mkdir a = do
-  liftIO $ createDirectoryIfMissing True (toFilePath a)
+  void $ liftIO $ E.try @SomeException (D.createDirectoryIfMissing True (toFilePath a))
+
+data TouchOpt = TouchEasy | TouchHard
+                 deriving stock (Eq,Ord,Show)
+
+class ToFilePath a => HasTouchOpts a where
+  touchOpts :: a -> [TouchOpt]
+
+instance HasTouchOpts FilePath where
+  touchOpts = const [TouchEasy]
+
+touch :: (MonadIO m, HasTouchOpts a) => a -> m ()
+touch what = do
+  here <- doesPathExist fn
+  dir  <- doesDirectoryExist fn
+
+  when (not here || hard) do
+    mkdir (takeDirectory fn)
+    liftIO $ print (takeDirectory fn)
+    unless dir do
+      liftIO $ print fn
+      liftIO $ LBS.appendFile fn mempty
+
+  where
+    hard = TouchHard `elem` touchOpts  what
+    fn = toFilePath what
 
 pwd :: MonadIO m => m FilePath
 pwd = liftIO D.getCurrentDirectory

hbs2-fixer/app/Main.hs

@@ -1,6 +1,94 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Main where
 
+import HBS2.Prelude.Plated
+import HBS2.Net.Auth.Schema
+import HBS2.Polling
+import HBS2.System.Dir
+import HBS2.System.Logger.Simple.ANSI hiding (info)
+
+import Data.Config.Suckless
+
+import Control.Monad.Reader
+import Lens.Micro.Platform
+import System.Directory
+import System.FilePath
+import UnliftIO
+import Options.Applicative
+import Data.Maybe
+import Data.Either
+
+{- HLINT ignore "Functor law" -}
+
+data FixerEnv = FixerEnv
+  { _config :: TVar [Syntax C]
+  }
+
+makeLenses ''FixerEnv
+
+
+data Watch s =
+  WatchRefLog (PubKey 'Sign s)
+  deriving stock (Generic)
+
+newtype FixerM m a = FixerM { runFixerM :: ReaderT FixerEnv m a }
+  deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader FixerEnv, MonadUnliftIO)
+
+withConfig :: MonadUnliftIO m => Maybe FilePath -> FixerM m () -> FixerM m ()
+withConfig cfgPath m = do
+  defConfDir <- liftIO $ getXdgDirectory XdgConfig "hbs2-fixer"
+
+  let configPath = fromMaybe (defConfDir </> "config") cfgPath
+
+  unless (isJust cfgPath) do
+    debug $ pretty configPath
+    touch configPath
+
+  syn <- liftIO (readFile configPath) <&> parseTop <&> fromRight mempty
+  tsyn <- newTVarIO syn
+
+  local (set config tsyn) (void m)
+
+withApp :: Maybe FilePath -> FixerM IO () -> IO ()
+withApp cfgPath action = do
+  setLogging @DEBUG debugPrefix
+  setLogging @INFO  defLog
+  setLogging @ERROR errorPrefix
+  setLogging @WARN  warnPrefix
+  setLogging @NOTICE noticePrefix
+  env <- FixerEnv <$> newTVarIO mempty
+  runReaderT (runFixerM $ withConfig cfgPath action) env
+    `finally` do
+       setLoggingOff @DEBUG
+       setLoggingOff @INFO
+       setLoggingOff @ERROR
+       setLoggingOff @WARN
+       setLoggingOff @NOTICE
+       pure ()
+
+  where
+    debugPrefix  = toStdout . logPrefix "[debug] "
+    errorPrefix  = toStdout . logPrefix "[error] "
+    warnPrefix   = toStdout . logPrefix "[warn] "
+    noticePrefix = toStdout . logPrefix "[notice] "
+
+mainLoop :: FixerM IO ()
+mainLoop = forever $ do
+  debug "hbs2-fixer. do stuff since 2024"
+  pause @'Seconds 5
+
+
 main :: IO ()
 main = do
-  print "hbs2-fixer"
+  runMe =<< customExecParser (prefs showHelpOnError)
+              ( info (helper <*> opts)
+                ( fullDesc
+                <> header "hbs2-fixer"
+                <> progDesc "Intermediary between hbs2-peer and external applications. Listen events / do stuff"
+                ))
+
+  where
+    opts = optional $ strOption (short 'c' <> long "config" <> metavar "FILE" <> help "Specify configuration file")
+
+    runMe opt = withApp opt mainLoop
 

hbs2-git-reposync/LICENSE

@@ -1,30 +0,0 @@
-Copyright (c) 2023, Dmitry Zuikov
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-
-    * Redistributions in binary form must reproduce the above
-      copyright notice, this list of conditions and the following
-      disclaimer in the documentation and/or other materials provided
-      with the distribution.
-
-    * Neither the name of Dmitry Zuikov nor the names of other
-      contributors may be used to endorse or promote products derived
-      from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

hbs2-git-reposync/ReposyncMain.hs

@@ -1,463 +0,0 @@
-{-# Language TemplateHaskell #-}
-module Main where
-
-import HBS2.Prelude.Plated
-import HBS2.Net.Auth.Credentials
-import HBS2.OrDie
-import HBS2.Data.Types.Refs
-import HBS2.Actors.Peer
-import HBS2.Net.Proto.Notify
-import HBS2.Peer.Proto
-import HBS2.Peer.RPC.Client.Unix hiding (Cookie)
-import HBS2.Peer.RPC.API.RefLog
-import HBS2.Peer.Notify
-
-import HBS2.System.Logger.Simple hiding (info)
-
-import Data.Config.Suckless
-
-import Data.Char qualified as Char
-import Control.Monad.Catch (MonadThrow(..))
-import Control.Monad.Except (runExceptT,throwError)
-import Control.Monad.Cont
-import Control.Monad.Reader
-import Data.ByteString.Builder hiding (writeFile)
-import Data.ByteString.Char8 qualified as BS8
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.Either
-import Data.List qualified as List
-import Data.Maybe
-import Data.Text qualified as Text
-import Lens.Micro.Platform
-import Network.Wai.Middleware.Static (staticPolicy, addBase)
-import Network.Wai.Middleware.RequestLogger (logStdoutDev)
-import Options.Applicative
-import qualified Data.Text.Encoding as TE
-import System.Directory
-import System.FilePath
-import System.Process.Typed
-import Text.InterpolatedString.Perl6 (qc)
-import Control.Concurrent.STM (flushTQueue)
-import UnliftIO
-import Web.Scotty hiding (header,next)
-
-import Network.HTTP.Types
-import Network.Wai
-
-import System.Exit qualified as Exit
-import System.IO.Unsafe (unsafePerformIO)
-
-import Streaming.Prelude qualified as S
-
--- TODO: support-encrypted-repoes
-
-die :: (MonadIO m, Show msg) => msg -> m a
-die msg = liftIO $ Exit.die [qc|{msg}|]
-
-data RepoInitException = RepoInitException FilePath deriving (Show, Typeable)
-instance Exception RepoInitException
-
-debugPrefix :: SetLoggerEntry
-debugPrefix  = toStdout . logPrefix "[debug] "
-
-errorPrefix :: SetLoggerEntry
-errorPrefix  = toStdout . logPrefix "[error] "
-
-warnPrefix :: SetLoggerEntry
-warnPrefix  = toStdout . logPrefix "[warn] "
-
-noticePrefix :: SetLoggerEntry
-noticePrefix  = toStdout . logPrefix "[notice] "
-
-data ReposyncRootKey
-data ReposyncHttpPort
-
-instance Monad m => HasCfgKey ReposyncRootKey (Maybe String) m where
-  key = "root"
-
-instance Monad m => HasCfgKey ReposyncHttpPort (Maybe Int) m where
-  key = "http-port"
-
-data RepoEntry =
-  RepoEntry
-  { repoPath :: FilePath
-  , repoRef  :: RefLogKey HBS2Basic
-  , repoKeys :: [FilePath]
-  , repoHash :: TVar (Maybe HashRef)
-  }
-  deriving stock (Eq)
-
-
-data ReposyncState =
-
-  ReposyncState
-  { _rpcSoname         :: FilePath
-  , _rpcRefLog         :: ServiceCaller RefLogAPI UNIX
-  , _rpcNotifySink     :: NotifySink (RefLogEvents L4Proto) UNIX
-  , _reposyncBaseDir   :: FilePath
-  , _reposyncPort      :: Int
-  , _reposyncEntries   :: TVar [RepoEntry]
-  }
-
-makeLenses 'ReposyncState
-
-newtype ReposyncM m a =
-  App { unReposyncM :: ReaderT ReposyncState m a }
-  deriving newtype ( Applicative
-                   , Functor
-                   , Monad
-                   , MonadIO
-                   , MonadThrow
-                   , MonadReader ReposyncState
-                   , MonadUnliftIO
-                   , MonadTrans
-                   )
-
-
-myName :: FilePath
-myName = "hbs2-git-reposync"
-
-reposyncDefaultDir :: FilePath
-reposyncDefaultDir = unsafePerformIO do
-  getXdgDirectory XdgData (myName </> "repo")
-{-# NOINLINE reposyncDefaultDir #-}
-
-newState :: MonadUnliftIO m
-         => FilePath
-         -> ServiceCaller RefLogAPI UNIX
-         -> NotifySink (RefLogEvents L4Proto) UNIX
-         -> m ReposyncState
-
-newState so refLog sink =
-  ReposyncState so refLog sink reposyncDefaultDir 4017 <$> newTVarIO mempty
-
-{- HLINT ignore "Functor law" -}
-withConfig :: forall a m . (MonadUnliftIO m) => Maybe FilePath -> ReposyncM m a -> ReposyncM m ()
-withConfig cfg m = do
-
-  let defDir  = reposyncDefaultDir
-
-  defConfDir <- liftIO $ getXdgDirectory XdgConfig myName
-
-  realCfg <- case cfg of
-             Just f -> pure f
-             Nothing -> do
-                liftIO do
-                  let conf = defConfDir </> "config"
-                  void $ try @_ @IOException $ createDirectoryIfMissing True defConfDir
-                  debug $ "config-dir" <+> pretty defConfDir
-                  void $ try @_ @IOException $ appendFile conf ""
-                  pure conf
-
-  syn <- liftIO (readFile realCfg) <&> parseTop
-                                   <&> fromRight mempty
-
-  debug $ "config" <+> pretty realCfg <> line <> pretty syn
-
-  ev <- asks (view reposyncEntries)
-
-  let root = runReader (cfgValue @ReposyncRootKey) syn
-              & fromMaybe defDir
-
-  let port = runReader (cfgValue @ReposyncHttpPort) syn
-              & fromMaybe 4017
-
-  es <- entries root syn
-  atomically $ modifyTVar ev (\x -> List.nub ( x <> es))
-
-  local ( set reposyncBaseDir root .
-          set reposyncPort port
-        ) (void m)
-
-  where
-    entries root syn = do
-
-      let findKeys w = [ Text.unpack p
-                       | ListVal (Key "decrypt" [LitStrVal p]) <- w
-                       ]
-
-      let reflogs = catMaybes [ (,) <$> fromStringMay @(RefLogKey HBS2Basic) (Text.unpack o)
-                                    <*> pure (findKeys args)
-                              | ListVal (Key "reflog" (LitStrVal o : args)) <- syn
-                              ]
-
-      forM reflogs $ \(repo, keys) -> do
-        let path = show $ pretty repo
-        mt <- newTVarIO Nothing
-        pure $ RepoEntry (root </> path) repo keys mt
-
-
-
-
-runSync :: (MonadUnliftIO m, MonadThrow m) => ReposyncM m ()
-runSync = do
-  es <- asks (view reposyncEntries) >>= readTVarIO
-  so <- asks (view rpcSoname)
-
-  refLogRPC <- asks (view rpcRefLog)
-  sink      <- asks (view rpcNotifySink)
-
-  root <- asks (view reposyncBaseDir)
-  port <- asks (fromIntegral . view reposyncPort)
-
-  http <- async $ liftIO $ scotty port $ do
-              middleware $ staticPolicy (addBase root)
-              middleware logStdoutDev
-              get "/" $ do
-                text "This is hbs2-git-reposync"
-
-  r <- forM es $ \entry -> async $ void $ flip runContT pure do
-          let ref = repoRef entry
-          let rk = fromRefLogKey ref
-          tv <- newTVarIO Nothing
-
-          upd <- newTQueueIO
-
-          debug $ "STARTED WITH" <+> pretty (repoPath entry)
-
-          let notif =
-                liftIO $ async do
-                          debug $ "Subscribed" <+> pretty ref
-                          runNotifySink sink (RefLogNotifyKey ref) $ \(RefLogUpdateNotifyData _ h) -> do
-                            debug $ "Got notification" <+> pretty ref <+> pretty h
-                            atomically $ writeTQueue upd ()
-
-          void $ ContT $ bracket notif cancel
-
-          lift $ initRepo entry
-
-          lift $ syncRepo entry
-
-
-          fix \next -> do
-
-            void $ liftIO $ race (pause @'Seconds 60) (atomically (peekTQueue upd))
-            pause @'Seconds 5
-            liftIO $ atomically $ flushTQueue upd
-
-            rr' <- liftIO $ race (pause @'Seconds 1) do
-                      callService @RpcRefLogGet refLogRPC rk
-                          <&> fromRight Nothing
-
-            rr <- either (const $ pause @'Seconds 1 >> warn "rpc call timeout" >>  next) pure rr'
-
-            debug $ "REFLOG VALUE:" <+> pretty rr
-
-            r0 <- readTVarIO tv
-
-            unless ( rr == r0 ) do
-              debug $ "Syncronize repo!" <+> pretty (repoPath entry)
-              fix \again -> do
-                lift (syncRepo entry) >>= \case
-                  Left{} -> do
-                    debug $ "Failed to update:" <+> pretty (repoPath entry)
-                    pause @'Seconds 5
-                    again
-
-                  Right{} -> do
-                    atomically $ writeTVar tv rr
-
-            next
-
-  void $ waitAnyCatchCancel (http : r)
-
-data SyncError = SyncError
-
-syncRepo :: (MonadUnliftIO m, MonadThrow m) => RepoEntry -> m (Either SyncError ())
-syncRepo (RepoEntry{..}) = runExceptT do
-
-  -- let cfg = shell [qc|git fetch origin && git remote update origin|] & setWorkingDir repoPath
-  let cfg = shell [qc|git remote update origin && git remote prune origin|] & setWorkingDir repoPath
-  code <- runProcess cfg
-
-  case code of
-    ExitFailure{} -> do
-      err $ "Unable to sync repo" <+> pretty repoPath
-      throwError SyncError
-
-    _             -> debug $ "synced" <+> pretty repoPath
-
-
-  let readLocalBranches = shell [qc|git for-each-ref refs/heads|]
-                            & setWorkingDir repoPath
-
-  let readBranches = shell [qc|git ls-remote origin|]
-                       & setWorkingDir repoPath
-
-  (_, o, _) <- readProcess readBranches
-
-  let txt = TE.decodeUtf8 (LBS.toStrict o)
-
-  let ls = Text.lines txt & fmap Text.words
-
-  let refs = [ (b,a) | [a,b] <- ls ]
-
-  -- TODO: remove-only-vanished-refs
-  unless (null refs) do
-
-    (_, o, _) <- readProcess readLocalBranches
-    let out = TE.decodeUtf8 (LBS.toStrict o)
-                 & Text.lines
-                 & fmap Text.words
-
-    let refs = [ r | [_,_,r] <- out ]
-    forM_ refs $ \r -> do
-      -- debug $ "REMOVING REF" <+> pretty r
-      let cmd = shell [qc|git update-ref -d {r}|] & setWorkingDir repoPath
-      void $ runProcess cmd
-
-  forM_ refs $ \(ref, val) -> do
-    -- debug $ "SET REFERENCE" <+> pretty ref <+> pretty val
-    let updateBranch = shell [qc|git update-ref {ref} {val}|]
-                        & setWorkingDir repoPath
-                        & setStdout closed
-                        & setStderr closed
-
-    void $ readProcess updateBranch
-
-    void $ runProcess (shell "git update-server-info" & setWorkingDir repoPath)
-
-  -- let gc = shell [qc|git gc|] & setWorkingDir repoPath
-  -- void $ runProcess gc
-
-regenConfig :: MonadUnliftIO m => RepoEntry -> ReposyncM m ()
-regenConfig RepoEntry{..} = do
-
-  let hbs2conf = repoPath </> ".hbs2/config"
-  rpc <- asks (view rpcSoname)
-
-  let config = ";; generated by hbs2-reposync" <> line
-               <> "rpc" <+> "unix" <+> viaShow rpc <> line
-               <> line
-               <> vcat (fmap (("decrypt"<+>) . dquotes.pretty) repoKeys)
-
-  liftIO $ writeFile hbs2conf (show config)
-
-initRepo :: (MonadUnliftIO m, MonadThrow m) => RepoEntry -> ReposyncM m ()
-initRepo e@(RepoEntry{..}) = do
-  debug $ "initRepo" <+> pretty repoPath
-
-  let gitDir = repoPath
-  gitHere <- liftIO $ doesDirectoryExist gitDir
-
-  liftIO $ createDirectoryIfMissing True gitDir
-  debug $ "create dir" <+> pretty gitDir
-
-  let hbs2 = gitDir </> ".hbs2"
-  liftIO $ createDirectoryIfMissing True hbs2
-
-  regenConfig e
-
-  unless gitHere do
-
-    let cfg = shell [qc|git init --bare && git remote add origin hbs2://{pretty repoRef}|]
-                 & setWorkingDir repoPath
-
-    code <- runProcess cfg
-
-    case code of
-      ExitFailure{} -> do
-        err $ "Unable to init git repository:" <+> pretty gitDir
-        throwM $ RepoInitException gitDir
-
-      _ -> pure ()
-
-
-detectRPC :: (MonadUnliftIO m) => m (Maybe FilePath)
-detectRPC = do
-
-  (_, o, _) <- readProcess (shell [qc|hbs2-peer poke|])
-  let answ = parseTop (LBS.unpack o) & fromRight mempty
-
-  pure (headMay [ Text.unpack r | ListVal (Key "rpc:" [LitStrVal r]) <- answ  ])
-
-withApp :: forall a m . MonadUnliftIO m
-        => Maybe FilePath
-        -> ReposyncM m a
-        -> m ()
-
-withApp cfg m = do
-
-  setLogging @DEBUG  debugPrefix
-  setLogging @INFO   defLog
-  setLogging @ERROR  errorPrefix
-  setLogging @WARN   warnPrefix
-  setLogging @NOTICE noticePrefix
-
-  -- lrpc =
-
-  forever $ handleAny cleanup $ do
-
-    soname <- detectRPC `orDie` "RPC not found"
-
-    let o = [MUWatchdog 20, MUDontRetry]
-
-    client <- race ( pause @'Seconds 1) (newMessagingUnixOpts o False 1.0 soname)
-                `orDie` "hbs2-peer rpc timeout!"
-
-    clientN <- newMessagingUnixOpts o False 1.0 soname
-
-    rpc <- makeServiceCaller (fromString soname)
-
-    messaging <- async $ runMessagingUnix client
-
-    mnotify   <- async $ runMessagingUnix clientN
-
-    sink <- newNotifySink
-
-    wNotify <- liftIO $ async $ flip runReaderT clientN $ do
-                debug "notify restarted!"
-                runNotifyWorkerClient sink
-
-    nProto <- liftIO $ async $ flip runReaderT clientN $ do
-        runProto @UNIX
-          [ makeResponse (makeNotifyClient @(RefLogEvents L4Proto) sink)
-          ]
-
-    let endpoints = [ Endpoint @UNIX  rpc
-                    ]
-
-    c1 <- async $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
-
-    state <- newState soname rpc sink
-
-    r <- async $ void $ runReaderT (unReposyncM $ withConfig cfg m) state
-
-    void $ waitAnyCatchCancel [c1, messaging, mnotify, nProto, wNotify, r]
-
-    notice "exiting"
-
-  setLoggingOff @DEBUG
-  setLoggingOff @INFO
-  setLoggingOff @ERROR
-  setLoggingOff @WARN
-  setLoggingOff @NOTICE
-
-
-  where
-    cleanup e = do
-      err (viaShow e)
-      warn "Something bad happened. Retrying..."
-      pause @'Seconds 2.5
-
-main :: IO ()
-main = runMe .  customExecParser (prefs showHelpOnError) $
-  info (helper <*> ((,) <$> opts <*> parser))
-  (  fullDesc
-  <> header "hbs2-reposync"
-  <> progDesc "syncronizes hbs2-git repositories"
-  )
-  where
-    -- parser ::  Parser (IO ())
-    parser = hsubparser (  command "run" (info pRun (progDesc "run syncronization"))
-                        )
-
-    runMe x = do
-      (o, run) <- x
-      withApp o run
-
-    opts = optional $ strOption (short 'c' <> long "config")
-
-    pRun = do
-      pure runSync
-

hbs2-git-reposync/examples/config

@@ -1,19 +0,0 @@
-
-rpc unix "/tmp/hbs2-rpc.socket"
-
-; http-port 4017
-
-; root "/home/dmz/.local/share/hbs2-reposync/repo"
-
-;; single reflog
-
-[ reflog "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP"
-;; options may go here if any
-]
-
-[ reflog  "JCVvyFfj1C21QfFkcjrFN6CoarykfAf6jLFpCNNKjP7E"
-  (decrypt "/home/dmz/w/hbs2/owner.key")
-]
-
-
-

hbs2-git-reposync/hbs2-git-reposync.cabal

@@ -1,135 +0,0 @@
-cabal-version:      3.0
-name:               hbs2-git-reposync
-version:            0.24.1.0
--- synopsis:
--- description:
-license:            BSD-3-Clause
-license-file:       LICENSE
-author:             Dmitry Zuikov
-maintainer:         dzuikov@gmail.com
--- copyright:
-category:           Development
-build-type:         Simple
-extra-doc-files:    CHANGELOG.md
--- extra-source-files:
-
-common shared-properties
-  ghc-options:
-        -Wall
-        -Wno-type-defaults
-        -fprint-potential-instances
-        -- -fno-warn-unused-matches
-        -- -fno-warn-unused-do-bind
-        -- -Werror=missing-methods
-        -- -Werror=incomplete-patterns
-        -- -fno-warn-unused-binds
-
-
-  default-language:    Haskell2010
-
-  default-extensions:
-                       ApplicativeDo
-                     , BangPatterns
-                     , BlockArguments
-                     , ConstraintKinds
-                     , DataKinds
-                     , DeriveDataTypeable
-                     , DeriveGeneric
-                     , DerivingStrategies
-                     , DerivingVia
-                     , ExtendedDefaultRules
-                     , FlexibleContexts
-                     , FlexibleInstances
-                     , GADTs
-                     , GeneralizedNewtypeDeriving
-                     , ImportQualifiedPost
-                     , LambdaCase
-                     , MultiParamTypeClasses
-                     , OverloadedStrings
-                     , QuasiQuotes
-                     , RecordWildCards
-                     , ScopedTypeVariables
-                     , StandaloneDeriving
-                     , TupleSections
-                     , TypeApplications
-                     , TypeOperators
-                     , TypeFamilies
-                     , TemplateHaskell
-
-
-  build-depends: hbs2-core, hbs2-peer
-               , attoparsec
-               , aeson
-               , async
-               , base16-bytestring
-               , bytestring
-               , cache
-               , containers
-               , streaming
-               , streaming-bytestring
-               , streaming-commons
-               , streaming-utils
-               , cryptonite
-               , directory
-               , exceptions
-               , filelock
-               , filepath
-               , filepattern
-               , generic-lens
-               , hashable
-               , http-conduit
-               , interpolatedstring-perl6
-               , memory
-               , microlens-platform
-               , mtl
-               , prettyprinter
-               , prettyprinter-ansi-terminal
-               , random
-               , resourcet
-               , safe
-               , saltine
-               , serialise
-               , split
-               , sqlite-simple
-               , stm
-               , suckless-conf
-               , temporary
-               , text
-               , time
-               , timeit
-               , transformers
-               , typed-process
-               , uniplate
-               , unliftio
-               , unliftio-core
-               , unordered-containers
-               , wai-app-file-cgi
-               , wai-extra
-
-executable hbs2-git-reposync
-    import:           shared-properties
-    main-is:          ReposyncMain.hs
-
-    ghc-options:
-        -threaded
-        -rtsopts
-        "-with-rtsopts=-N4 -A64m -AL256m -I0"
-
-    other-modules:
-
-    -- other-extensions:
-    build-depends:
-        base, hbs2-core, hbs2-peer
-      , optparse-applicative
-      , unliftio
-      , terminal-progress-bar
-      , http-types
-      , scotty
-      , wai
-      , wai-middleware-static
-      , wai-extra
-
-    hs-source-dirs:   .
-    default-language: Haskell2010
-
-

hbs2-git/CHANGELOG.md

@@ -1,5 +0,0 @@
-# Revision history for hbs2-git
-
-## 0.1.0.0 -- YYYY-mm-dd
-
-* First version. Released on an unsuspecting world.

hbs2-git/LICENSE

@@ -1,30 +0,0 @@
-Copyright (c) 2023, Dmitry Zuikov
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-
-    * Redistributions in binary form must reproduce the above
-      copyright notice, this list of conditions and the following
-      disclaimer in the documentation and/or other materials provided
-      with the distribution.
-
-    * Neither the name of Dmitry Zuikov nor the names of other
-      contributors may be used to endorse or promote products derived
-      from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

hbs2-git/examples/config/encrypted-ref

@@ -1,18 +0,0 @@
-rpc unix "/tmp/hbs2-rpc.socket"
-
-keyring "/home/dmz/dmz-data/hbs2/HBcSZnjpEcA88S19S5QwC5N4yyKZY4SvAuBWqHQhK6wV.key"
-
-keyring "/home/dmz/w/hbs2/test1.key"
-keyring "/home/dmz/w/hbs2/test2.key"
-keyring "/home/dmz/w/hbs2/test3.key"
-keyring "/home/dmz/w/hbs2/test4.key"
-keyring "/home/dmz/w/hbs2/test5.key"
-
-[ encrypted "EDRuSaFmWbCnyUNtFbgCtqfiCrYPJvnY9pZB81AbSTbr"
-  (ttl 86400)
-  (owner "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G")
-  (member "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G")
-  (member "GcTjPEDSTCKNKnwPZWBjudeTqSie2fvYfsoSAzUKTRZ5")
-]
-
-

hbs2-git/examples/config/encrypted-ref-2

@@ -1,30 +0,0 @@
-rpc unix "/tmp/hbs2-rpc.socket"
-
-branch "master"
-branch "hbs2-git"
-
-keyring "/home/dmz/dmz-data/hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP.key"
-keyring "/home/dmz/dmz-data/hbs2/HBcSZnjpEcA88S19S5QwC5N4yyKZY4SvAuBWqHQhK6wV.key"
-
-keyring "/home/dmz/w/hbs2/k5.key"
-
-;;keyring "/home/dmz/w/hbs2/test1.key"
-;;keyring "/home/dmz/w/hbs2/test2.key"
-;;keyring "/home/dmz/w/hbs2/test6.key"
-;; keyring "/home/dmz/w/hbs2/test3.key"
-
-decrypt "/home/dmz/w/hbs2/au11.key"
-decrypt "/home/dmz/w/hbs2/owner.key"
-decrypt "/home/dmz/w/hbs2/k5.key"
-
-[ encrypted "HFKuPTyaQLLmfgfVveu5GA4spt4c6oQBMUo1aeQ4abXG"
-  (ttl 86400)
-  (owner "21MU19xcRbhhPakPJCG6Jyrf7Xv6JMCyMDEfCk16hR5G")
-  (member "H9miZgHYg84wZM8Hu93t7iLHcKnZytAEgcB26LGbLTz4")
-  (member "2jsaezeu8iCRYBqMVBauCxnkHXvP3CkEFLeVxE8bRfvH")
-  (member "FNGD1oNh9AVXw1v7ZFpC5V2P2GGYRoUwnP6qwTw9JGpn")
-  (member "J2FWG3uib7TpZsu1k8sz8cekC3VH1ggNBhZKJxtUce4Q")
-  (member "E9WGzRzmD5G5SHbz9u7n3WKCz1eaVNPvT5f1NEKUQ6FU")
-  (keyring "/home/dmz/w/hbs2/owner.key")
-]
-

hbs2-git/git-hbs2/GitRemoteMain.hs

@@ -1,267 +0,0 @@
-module Main where
-
-import HBS2.Prelude.Plated
-import HBS2.Data.Types.Refs
-import HBS2.Base58
-import HBS2.OrDie
-import HBS2.Git.Types
-
-import HBS2.System.Logger.Simple
-
-import HBS2Git.App
-import HBS2Git.State
-import HBS2Git.Import
-import HBS2Git.Evolve
-import HBS2.Git.Local.CLI
-
-import HBS2Git.Export (runExport)
-
-import HBS2Git.Config as Config
-import GitRemoteTypes
-import GitRemotePush
-
-
-import Control.Concurrent.STM
-import Control.Monad.Reader
-import Data.Attoparsec.Text hiding (try)
-import Data.Attoparsec.Text qualified as Atto
-import Data.ByteString.Char8 qualified as BS
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.Foldable
-import Data.Functor
-import Data.Function ((&))
-import Data.HashMap.Strict qualified as HashMap
-import Data.Maybe
-import Data.Text qualified as Text
-import Data.List qualified as List
-import System.Environment
-import System.Posix.Signals
-import Text.InterpolatedString.Perl6 (qc)
-import UnliftIO.IO as UIO
-import Control.Monad.Catch
-import Control.Monad.Trans.Resource
-import Lens.Micro.Platform
-
-
-send :: MonadIO m => BS.ByteString -> m ()
-send = liftIO . BS.hPutStr stdout
-
-sendLn :: MonadIO m => BS.ByteString -> m ()
-sendLn s = do
-  trace $ "sendLn" <+> pretty (show s)
-  liftIO $ BS.hPutStrLn stdout s
-
-sendEol :: MonadIO m => m ()
-sendEol = liftIO $ BS.hPutStrLn stdout "" >> hFlush stdout
-
-receive :: MonadIO m => m BS.ByteString
-receive = liftIO $ BS.hGetLine stdin
-
-done :: MonadIO m => m Bool
-done = UIO.hIsEOF stdin
-
-parseRepoURL :: String -> Maybe HashRef
-parseRepoURL url' = either (const Nothing) Just (parseOnly p url)
-  where
-    url = Text.pack url'
-    p = do
-      _ <- string "hbs2://"
-      topic'  <- Atto.manyTill' anyChar endOfInput
-      let topic = BS.unpack <$> fromBase58 (BS.pack topic')
-      maybe (fail "invalid url") (pure . fromString) topic
-
-
-capabilities :: BS.ByteString
-capabilities = BS.unlines ["push","fetch"]
-
-
-getGlobalOptionFromURL :: HasGlobalOptions m => [String] -> m ()
-getGlobalOptionFromURL args = do
-
-  case args of
-    [_, ss] -> do
-      let (_, suff) = Text.breakOn "?" (Text.pack ss)
-                      & over _2 (Text.dropWhile (== '?'))
-                      & over _2 (Text.splitOn "&")
-                      & over _2 (fmap (over _2 (Text.dropWhile (=='=')) . Text.break (== '=')))
-                      & over _2 (filter (\(k,_) -> k /= ""))
-
-      forM_ suff $ \(k,v) -> do
-        addGlobalOption (Text.unpack k) (Text.unpack v)
-
-    _ -> pure ()
-
-loop :: forall m . ( MonadIO m
-                   , MonadCatch m
-                   , MonadUnliftIO m
-                   , MonadMask m
-                   , HasProgress m
-                   , HasConf m
-                   , HasStorage m
-                   , HasRPC m
-                   , HasRefCredentials m
-                   , HasEncryptionKeys m
-                   , HasGlobalOptions m
-                   ) => [String] -> m ()
-loop args = do
-
-  trace $ "args:" <+> pretty args
-
-  ref <- case args of
-            [_, ss] -> do
-              let (s, _) = Text.breakOn "?" (Text.pack ss)
-
-              let r = Text.stripPrefix "hbs2://" s <&> fromString @RepoRef . Text.unpack
-
-              pure r `orDie` [qc|bad reference {args}||]
-
-            _  -> do
-                die [qc|bad reference: {args}|]
-
-  trace $ "ref:" <+> pretty ref
-
-  dbPath <- makeDbPath ref
-
-  trace $ "dbPath:" <+> pretty dbPath
-
-  db <- dbEnv dbPath
-
-  -- TODO: hbs2-peer-fetch-reference-and-wait
-
-  checkRef <- readRef ref <&> isJust
-
-  let getHeads upd = do
-        when upd do importRefLogNew False ref
-        refsNew <- withDB db stateGetActualRefs
-        let possibleHead = listToMaybe $ List.take 1 $ List.sortOn guessHead (fmap fst refsNew)
-
-        let hd = refsNew & LBS.pack . show
-                                    . pretty
-                                    . AsGitRefsFile
-                                    . RepoHead possibleHead
-                                    . HashMap.fromList
-        pure hd
-
-
-  hd <- getHeads True
-
-  refs <- withDB db stateGetActualRefs
-
-  let heads = [ h | h@GitHash{} <- universeBi refs ]
-
-  missed <- try (mapM (gitReadObject Nothing) heads) <&> either (\(_::SomeException) -> True) (const False)
-
-  let force = missed || List.null heads
-
-  when force do
-  -- sync state first
-    traceTime "TIMING: importRefLogNew" $ importRefLogNew True ref
-
-  batch <- liftIO $ newTVarIO False
-
-  fix \next -> do
-
-    eof <- done
-
-    when eof do
-      exitFailure
-
-    s <- receive
-
-    let str = BS.unwords (BS.words s)
-    let cmd = BS.words str
-
-    isBatch <- liftIO $ readTVarIO batch
-
-    case cmd of
-      [] -> do
-        liftIO $ atomically $ writeTVar batch False
-        sendEol
-        when isBatch next
-        -- unless isBatch do
-
-      ["capabilities"] -> do
-          trace $ "send capabilities" <+> pretty (BS.unpack capabilities)
-          send capabilities >> sendEol
-          next
-
-      ["list"] -> do
-        for_ (LBS.lines hd) (sendLn . LBS.toStrict)
-        sendEol
-        next
-
-      ["list","for-push"] -> do
-        for_ (LBS.lines hd) (sendLn . LBS.toStrict)
-        sendEol
-        next
-
-      ["fetch", sha1, x] -> do
-        trace $ "fetch" <+> pretty (BS.unpack sha1) <+> pretty (BS.unpack x)
-        liftIO $ atomically $ writeTVar batch True
-        -- sendEol
-        next
-
-      ["push", rr] -> do
-        let bra = BS.split ':' rr
-        let pu = fmap (fromString' . BS.unpack) bra
-        liftIO $ atomically $ writeTVar batch True
-        -- debug $ "FUCKING PUSH" <> viaShow rr <+> pretty pu
-        -- shutUp
-        pushed <- push ref pu
-        case pushed of
-          Nothing  -> hPrint stderr "oopsie!" >> sendEol >> shutUp
-          Just re -> sendLn [qc|ok {pretty re}|]
-        next
-
-      other -> die $ show other
-
-
-    shutUp
-
-  where
-    fromString' "" = Nothing
-    fromString' x  = Just $ fromString x
-
-main :: IO ()
-main = do
-
-  hSetBuffering stdin  NoBuffering
-  hSetBuffering stdout LineBuffering
-
-  doTrace <- lookupEnv "HBS2TRACE" <&> isJust
-
-  when doTrace do
-    setLogging @DEBUG  debugPrefix
-    setLogging @TRACE  tracePrefix
-
-  setLogging @NOTICE noticePrefix
-  setLogging @ERROR  errorPrefix
-  setLogging @WARN   warnPrefix
-  setLogging @INFO   infoPrefix
-
-  args <- getArgs
-
-  void $ installHandler sigPIPE Ignore Nothing
-
-  evolve
-
-  (_, syn) <- Config.configInit
-
-  runWithRPC $ \rpc -> do
-    env <- RemoteEnv <$> liftIO (newTVarIO mempty)
-                     <*> liftIO (newTVarIO mempty)
-                     <*> liftIO (newTVarIO mempty)
-                     <*> pure rpc
-
-    runRemoteM env do
-      runWithConfig syn $ do
-        getGlobalOptionFromURL args
-        loadCredentials mempty
-        loadKeys
-        loop args
-
-  shutUp
-
-  hPutStrLn stdout ""
-  hPutStrLn stderr ""
-

hbs2-git/git-hbs2/GitRemotePush.hs

@@ -1,106 +0,0 @@
-{-# Language AllowAmbiguousTypes #-}
-module GitRemotePush where
-
-import HBS2.Prelude.Plated
-import HBS2.Data.Types.Refs
-import HBS2.OrDie
-import HBS2.System.Logger.Simple
-import HBS2.Net.Auth.Credentials hiding (getCredentials)
-
-import HBS2.Git.Local
-import HBS2.Git.Local.CLI
-
-import HBS2Git.Config as Config
-import HBS2Git.Types
-import HBS2Git.State
-import HBS2Git.App
-import HBS2Git.Export (exportRefOnly,exportRefDeleted)
-import HBS2Git.Import (importRefLogNew)
-
-import GitRemoteTypes
-
-import Control.Monad.Reader
-import Data.Functor
-import Data.Set (Set)
-import Text.InterpolatedString.Perl6 (qc)
-import Control.Monad.Catch
-import Control.Monad.Trans.Resource
-
-newtype RunWithConfig m a =
-  WithConfig { fromWithConf :: ReaderT [Syntax C] m a }
-  deriving newtype ( Applicative
-                   , Functor
-                   , Monad
-                   , MonadIO
-                   , MonadReader [Syntax C]
-                   , MonadTrans
-                   , MonadThrow
-                   , MonadCatch
-                   , MonadMask
-                   , MonadUnliftIO
-                   )
-
-
-runWithConfig :: MonadIO m => [Syntax C] -> RunWithConfig m a -> m a
-runWithConfig conf m = runReaderT (fromWithConf m) conf
-
-
-instance (Monad m, HasGlobalOptions m) => HasGlobalOptions (RunWithConfig m) where
-  addGlobalOption k v = lift $ addGlobalOption k v
-  getGlobalOption k = lift $ getGlobalOption k
-
-instance (Monad m, HasStorage m) => HasStorage (RunWithConfig m) where
-  getStorage = lift getStorage
-
-instance (Monad m, HasRPC m) => HasRPC (RunWithConfig m) where
-  getRPC = lift getRPC
-
-instance MonadIO m => HasConf (RunWithConfig (GitRemoteApp m)) where
-  getConf = ask
-
-instance MonadIO m => HasRefCredentials (RunWithConfig (GitRemoteApp m)) where
-  getCredentials = lift . getCredentials
-  setCredentials r c = lift $ setCredentials r c
-
-
-instance MonadIO m => HasEncryptionKeys (RunWithConfig (GitRemoteApp m)) where
-  addEncryptionKey = lift . addEncryptionKey
-  findEncryptionKey = lift . findEncryptionKey
-  enumEncryptionKeys = lift enumEncryptionKeys
-
-push :: forall  m . ( MonadIO m
-                    , MonadCatch m
-                    , HasConf m
-                    , HasRefCredentials m
-                    , HasEncryptionKeys m
-                    , HasGlobalOptions m
-                    , HasStorage m
-                    , HasRPC m
-                    , MonadUnliftIO m
-                    , MonadMask m
-                    )
-
-     => RepoRef -> [Maybe GitRef] -> m (Maybe GitRef)
-
-
-push remote what@[Just bFrom , Just br] = do
-
-  _ <- cfgValue @ConfBranch  @(Set GitRef) <&> transformBi normalizeRef
-  trace $ "PUSH PARAMS" <+> pretty what
-  gh <- gitGetHash (normalizeRef bFrom) `orDie` [qc|can't read hash for ref {pretty br}|]
-  _ <- traceTime "TIME: exportRefOnly" $ exportRefOnly () remote (Just bFrom) br gh
-  importRefLogNew False remote
-  pure (Just br)
-
-push remote [Nothing, Just br]  = do
-
-  _ <- cfgValue @ConfBranch  @(Set GitRef) <&> transformBi normalizeRef
-  trace $ "deleting remote reference" <+> pretty br
-  exportRefDeleted () remote br
-  importRefLogNew False remote
-  pure (Just br)
-
-push r w = do
-  warn $ "ignoring weird push" <+> pretty w <+> pretty r
-  pure Nothing
-

hbs2-git/git-hbs2/GitRemoteTypes.hs

@@ -1,83 +0,0 @@
-{-# Language TemplateHaskell #-}
-{-# Language UndecidableInstances #-}
-module GitRemoteTypes where
-
-import HBS2.Prelude
-import HBS2.OrDie
-import HBS2.Net.Proto
-import HBS2.Net.Auth.Credentials
-import HBS2.Peer.RPC.Client.StorageClient
-
-import HBS2Git.Types
-import Control.Monad.Reader
-import Lens.Micro.Platform
-import Data.HashMap.Strict qualified as HashMap
-import Data.HashMap.Strict (HashMap)
-import Control.Concurrent.STM
-import Control.Monad.Catch
-import Control.Monad.Trans.Resource
-
-data RemoteEnv =
-  RemoteEnv
-  { _reCreds :: TVar (HashMap RepoRef (PeerCredentials Schema))
-  , _reKeys  :: TVar (HashMap (PubKey 'Encrypt Schema) (PrivKey 'Encrypt Schema))
-  , _reOpts  :: TVar (HashMap String String)
-  , _reRpc   :: RPCEndpoints
-  }
-
-makeLenses 'RemoteEnv
-
-newtype GitRemoteApp m a =
-  GitRemoteApp { fromRemoteApp :: ReaderT RemoteEnv m a }
-  deriving newtype ( Applicative
-                   , Functor
-                   , Monad
-                   , MonadIO
-                   , MonadReader RemoteEnv
-                   , MonadThrow
-                   , MonadCatch
-                   , MonadUnliftIO
-                   , MonadMask
-                   , MonadTrans
-                   )
-
-instance Monad m => HasStorage (GitRemoteApp m) where
-  getStorage =  asks (rpcStorage . view reRpc) <&> AnyStorage . StorageClient
-
-instance Monad m => HasRPC (GitRemoteApp m) where
-  getRPC =  asks (view reRpc)
-
-runRemoteM :: MonadIO m => RemoteEnv -> GitRemoteApp m a -> m a
-runRemoteM env m = runReaderT (fromRemoteApp m) env
-
-
-instance MonadIO m => HasGlobalOptions (GitRemoteApp m) where
-  addGlobalOption k v =
-    asks (view reOpts ) >>= \t -> liftIO $ atomically $
-      modifyTVar' t (HashMap.insert k v)
-
-  getGlobalOption k = do
-    hm <- asks (view reOpts) >>= liftIO . readTVarIO
-    pure (HashMap.lookup k hm)
-
-instance MonadIO m => HasRefCredentials (GitRemoteApp m) where
-
-  setCredentials ref cred = do
-    asks (view reCreds) >>= \t -> liftIO $ atomically $
-      modifyTVar' t (HashMap.insert ref cred)
-
-  getCredentials ref = do
-    hm <- asks (view reCreds) >>= liftIO . readTVarIO
-    pure (HashMap.lookup ref hm) `orDie` "keyring not set (3)"
-
-instance MonadIO m => HasEncryptionKeys (GitRemoteApp m) where
-  addEncryptionKey ke = do
-    asks (view reKeys) >>= \t -> liftIO $ atomically do
-      modifyTVar' t (HashMap.insert (view krPk ke) (view krSk ke))
-
-  findEncryptionKey puk = (asks (view reKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.lookup puk
-
-  enumEncryptionKeys = do
-    them <- (asks (view reKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.toList
-    pure $ [KeyringEntry k s Nothing | (k,s) <- them ]
-

hbs2-git/git-hbs2/Main.hs

@@ -1,122 +1,219 @@
+{-# Language UndecidableInstances #-}
 module Main where
 
-import HBS2.Prelude
+import HBS2.Git.Client.Prelude hiding (info)
-import HBS2.OrDie
+import HBS2.Git.Client.App
+import HBS2.Git.Client.Export
+import HBS2.Git.Client.Import
+import HBS2.Git.Client.State
 
-import HBS2Git.App
+import HBS2.Git.Data.RefLog
-import HBS2Git.Export
+import HBS2.Git.Local.CLI qualified as Git
-import HBS2Git.Tools
+import HBS2.Git.Data.Tx qualified as TX
-import HBS2Git.KeysCommand
+import HBS2.Git.Data.Tx (RepoHead(..))
-import HBS2.Version
+import HBS2.Git.Data.LWWBlock
+import HBS2.Git.Data.GK
 
-import RunShow
+import HBS2.Storage.Operations.ByteString
 
 import Options.Applicative as O
-import Control.Monad
-import Data.Aeson qualified as Aeson
 import Data.ByteString.Lazy qualified as LBS
 
-import Paths_hbs2_git qualified as Pkg
+import System.Exit
+
+globalOptions :: Parser [GitOption]
+globalOptions = do
+
+  t <- flag [] [GitTrace]
+           (  long "trace" <> short 't' <> help "allow trace"
+           )
+
+  d <- flag [] [GitDebug]
+           (  long "debug" <> short 'd' <> help "allow debug"
+           )
+
+  pure (t <> d)
+
+commands :: GitPerks m => Parser (GitCLI m ())
+commands =
+  hsubparser (  command "export"  (info pExport  (progDesc "export repo to hbs2-git"))
+             <> command "import" (info pImport  (progDesc "import repo from reflog"))
+             <> command "key"    (info pKey     (progDesc "key management"))
+             <> command "tools"  (info pTools   (progDesc "misc tools"))
+             )
+
+
+pRefLogId :: ReadM RefLogId
+pRefLogId = maybeReader (fromStringMay @RefLogId)
+
+
+pLwwKey :: ReadM (LWWRefKey HBS2Basic)
+pLwwKey = maybeReader fromStringMay
+
+pHashRef :: ReadM HashRef
+pHashRef = maybeReader (fromStringMay @HashRef)
+
+pInit :: GitPerks m => Parser (GitCLI m ())
+pInit = do
+  pure runDefault
+
+
+pExport :: GitPerks m => Parser (GitCLI m ())
+pExport = do
+
+  puk <- argument pLwwKey (metavar "REFLOG-KEY")
+
+  et <- flag ExportInc ExportNew
+           (  long "new" <> help "new is usable to export to a new empty reflog"
+           )
+
+  enc <- flag' ExportPublic (long "public" <> help "create unencrypted reflog")
+          <|>
+          ( ExportPrivate <$>
+                strOption (long "encrypted" <> help "create encrypted reflog"
+                                            <> metavar "GROUP-KEY-FILE")
+          )
+
+  pure do
+    git <- Git.findGitDir >>= orThrowUser "not a git dir"
+    notice (green "git dir" <+> pretty git <+> pretty (AsBase58 puk))
+
+    env <- ask
+
+    withGitEnv ( env & set gitApplyHeads False & set gitExportType et & set gitExportEnc enc) do
+      unless (et == ExportNew) do
+        importRepoWait puk
+
+      export puk mempty
+
+pImport :: GitPerks m => Parser (GitCLI m ())
+pImport = do
+  puk <- argument pLwwKey (metavar "LWWREF")
+
+  pure do
+    git <- Git.findGitDir >>= orThrowUser "not a git dir"
+    importRepoWait puk
+
+pTools :: GitPerks m => Parser (GitCLI m ())
+pTools = hsubparser (  command "dump-pack" (info pDumpPack (progDesc "dump hbs2 git pack"))
+                    <> command "show-ref" (info pShowRef (progDesc "show current references"))
+                    <> command "show-remotes" (info pShowLww (progDesc "show current remotes (hbs2 references)"))
+                    )
+
+
+data DumpOpt = DumpInfoOnly | DumpObjects | DumpPack
+
+pDumpPack :: GitPerks m => Parser (GitCLI m ())
+pDumpPack = do
+  what <- dumpInfoOnly <|> dumpObjects <|> dumpPack
+  pure do
+    co <- liftIO LBS.getContents
+
+    (idSize,idVer,sidx,pack) <- TX.unpackPackMay co
+                                  & orThrowUser "can't unpack the bundle"
+
+    case what of
+      DumpInfoOnly -> do
+        liftIO $ print $ pretty "version:"    <+> pretty idVer  <> line
+                             <> "index size:" <+> pretty idSize <> line
+                             <> "objects:"    <+> pretty (length sidx)
+      DumpObjects -> do
+        liftIO $ print $ vcat (fmap pretty sidx)
+
+      DumpPack -> do
+        liftIO $ LBS.putStr pack
+
+  where
+    dumpInfoOnly = flag DumpInfoOnly DumpInfoOnly
+                      ( long "info-only" )
+
+    dumpObjects = flag DumpObjects DumpObjects
+                      ( long "objects" )
+
+    dumpPack = flag DumpPack DumpPack
+                      ( long "pack" )
+
+
+pShowLww :: GitPerks m => Parser (GitCLI m ())
+pShowLww = pure do
+  items <- withState selectAllLww
+  liftIO $ print $ vcat (fmap fmt items)
+  where
+    fmt (l,n,k) = fill 4 (pretty n) <+> fill 32 (pretty l) <+> fill 32 (pretty (AsBase58 k))
+
+pShowRef :: GitPerks m => Parser (GitCLI m ())
+pShowRef = do
+  pure do
+    sto <- asks _storage
+    void $ runMaybeT do
+
+      tx  <- withState do
+               selectMaxAppliedTx >>= lift  . toMPlus <&> fst
+
+      rh <- TX.readRepoHeadFromTx sto tx >>= toMPlus
+
+      liftIO $ print $ vcat (fmap formatRef (_repoHeadRefs rh))
+
+
+pKey :: GitPerks m => Parser (GitCLI m ())
+pKey = hsubparser (  command "show"   (info pKeyShow  (progDesc "show current key"))
+                  <> command "update" (info pKeyUpdate (progDesc "update current key"))
+                  )
+        <|> pKeyShow
+
+pKeyShow :: GitPerks m => Parser (GitCLI m ())
+pKeyShow = do
+  full <- flag False True (long "full" <> help "show full key info")
+  pure do
+    sto <- asks _storage
+    void $ runMaybeT do
+
+      tx  <- withState do
+               selectMaxAppliedTx >>= lift  . toMPlus <&> fst
+
+      rh <- TX.readRepoHeadFromTx sto tx
+               >>= toMPlus
+
+      gkh <- toMPlus (_repoHeadGK0 rh)
+
+      if not full then do
+        liftIO $ print $ pretty gkh
+      else do
+        gk <- runExceptT (readGK0 sto gkh) >>= toMPlus
+        liftIO $ print $ ";; group key" <+> pretty gkh <> line <> line <> pretty gk
+
+pKeyUpdate :: GitPerks m => Parser (GitCLI m ())
+pKeyUpdate = do
+  rlog <- argument pRefLogId (metavar "REFLOG-KEY")
+  fn <- strArgument (metavar "GROUP-KEY-FILE")
+  pure do
+    gk <- loadGK0FromFile  fn
+            `orDie` "can not load group key or invalid format"
+
+    sto <- asks _storage
+
+    gh <- writeAsMerkle sto (serialise gk) <&> HashRef
+
+    added <- withState $ runMaybeT do
+                (tx,_) <- lift selectMaxAppliedTx >>= toMPlus
+                lift do
+                  insertNewGK0 rlog tx gh
+                  commitAll
+                  pure gh
+
+    case added of
+      Nothing -> liftIO $ putStrLn "not added" >> exitFailure
+      Just x  -> liftIO $ print $ pretty x
 
 main :: IO ()
-main = join . customExecParser (prefs showHelpOnError) $
+main = do
-  info (helper <*> parser)
+  (o, action) <- customExecParser (prefs showHelpOnError) $
-  (  fullDesc
+                      O.info (liftA2 (,) globalOptions commands <**> helper)
-  <> header "git-hbs2"
+                        ( fullDesc
-  <> progDesc "helper tool for hbs2-git"
+                           <> header "hbs2-git"
-  )
+                           <> progDesc "hbs2-git"
-  where
-    parser ::  Parser (IO ())
-    parser = hsubparser (  command "init"      (info pInit (progDesc "init new hbs2 repo"))
-                        <> command "list-refs" (info pListRefs (progDesc "list refs"))
-                        <> command "show"      (info pShow (progDesc "show various types of objects"))
-                        <> command "tools"     (info pTools (progDesc "misc tools"))
-                        <> command "key"       (info pKeys (progDesc "manage keys"))
-                        <> command "version"   (info pVersion (progDesc "show program version"))
                         )
 
-    pVersion = pure do
+  runGitCLI o action
-        LBS.putStr $ Aeson.encode $(inlineBuildVersion Pkg.version)
-
-    pExport = do
-      keyfile   <- strArgument (metavar "KEIRING-FILE")
-      pure $ runApp WithLog do
-          runExport' keyfile
-
-    pListRefs = do
-      pure $ runApp NoLog runListRefs
-
-    showReader s = if s == "config"
-      then Just ShowConfig
-      else ShowRef <$> fromStringMay s
-
-    pShow = do
-      object <- optional $
-        argument (maybeReader showReader) (metavar "object" <> help "<HASH-REF> | config")
-
-      pure $ runApp NoLog (runShow object)
-
-    pTools = hsubparser (    command "scan" (info pToolsScan (progDesc "scan reference"))
-                          <> command "export"    (info pExport (progDesc "export repo"))
-                          <> command "refs" (info pToolsGetRefs (progDesc "list references"))
-
-                        )
-
-    pToolsScan = do
-      ref  <- strArgument (metavar "HASH-REF")
-      pure $ runApp WithLog (runToolsScan ref)
-
-    pToolsGetRefs = do
-      ref  <- strArgument (metavar "HASH-REF")
-      pure $ runApp WithLog (runToolsGetRefs ref)
 
 
-    pKeys = hsubparser (  command "list"   (info pKeysList    (progDesc "list keys for refs"))
-                       <> command "refs"   (info pKeyRefsList (progDesc "list encrypted refs"))
-                       <> command "update" (info pKeyUpdate   (progDesc "update key for the ref"))
-                       )
-
-
-    pKeyUpdate = do
-      ref <- strArgument (metavar "REF-KEY")
-      pure $ do
-        rk <- pure (fromStringMay ref) `orDie` "invalid REF-KEY"
-        runApp WithLog (runKeysUpdate rk)
-
-    pKeyRefsList = do
-      pure $ do
-        runApp WithLog runKeyRefsList
-
-    pKeysList = do
-      ref <- strArgument (metavar "REF-KEY")
-      pure $ do
-        rk <- pure (fromStringMay ref) `orDie` "invalid REF-KEY"
-        runApp WithLog (runKeysList rk)
-
-    pInit = do
-      opts <- pOpts
-      pure do
-        runInit (runInitRepo opts)
-
-      where
-        pOpts = pInteractive
-
-        pInteractive = NewRepoOpts <$> optional pKeyring
-                                   <*> pEncryption
-
-
-        pEncryption = pEncryptionHere <|> pure Nothing
-
-        pEncryptionHere = do
-          puk <- option pEncPk ( short 'p' <> long "encryption-pk" <> help "public key for encryption")
-          fn  <- strOption ( short 'e' <> long "keyring-enc" <> help "keyring for encryption" )
-          pure $ Just (puk, fn)
-
-
-        pEncPk :: ReadM (PubKey 'Encrypt (Encryption L4Proto))
-        pEncPk  = eitherReader $
-            maybe (Left "invalid encryption public key") pure . fromStringMay
-
-        pKeyring = do
-          strOption (short 'k' <> long "keyring" <> help "reference keyring file")
-

hbs2-git/git-hbs2/RunShow.hs

@@ -1,53 +0,0 @@
-module RunShow where
-
-import HBS2.Prelude
-import HBS2.Base58
-
-import HBS2Git.App
-import HBS2Git.State
-import HBS2Git.Config
-import HBS2Git.Tools
-import HBS2Git.PrettyStuff
-
-import Control.Monad.Catch (MonadMask)
-import Data.Foldable
-import Prettyprinter.Render.Terminal
-
-data ShowObject = ShowRef RepoRef | ShowConfig
-
-showRef :: (MonadIO m, MonadMask m) => RepoRef -> App m ()
-showRef h = do
-  db <- makeDbPath h >>= dbEnv
-  -- FIXME: re-implement-showRef
-  pure ()
-  -- withDB db do
-  --   hd <- stateGetHead
-  --   imported <- stateGetLastImported 10
-  --   liftIO $ do
-  --     print $ "current state for" <+> pretty (AsBase58 h)
-  --     print $ "head:" <+> pretty hd
-  --     print $ pretty "last operations:"
-  --     for_ imported (\(t,h1,h2) -> print $ pretty t <+> pretty h1 <+> pretty h2)
-
-showRefs :: (MonadIO m, MonadMask m) => App m ()
-showRefs = do
-  liftIO $ putDoc $ line <> green "References:" <> section
-  runListRefs
-
-showConfig :: (MonadIO m, MonadMask m) => App m ()
-showConfig = liftIO do
-  ConfigPathInfo{..} <- getConfigPathInfo
-  cfg <- readFile configFilePath
-  putDoc $ green "Config file location:" <> section <> pretty configFilePath <> section
-  putDoc $ green "Config contents:" <> line <> pretty cfg
-
-showSummary :: (MonadIO m, MonadMask m) => App m ()
-showSummary = do
-  showRefs
-  liftIO $ putDoc section
-  showConfig
-
-runShow :: (MonadIO m, MonadMask m) => Maybe ShowObject -> App m ()
-runShow (Just (ShowRef h)) = showRef h
-runShow (Just ShowConfig) = showConfig
-runShow Nothing = showSummary

hbs2-git/hbs2-git.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               hbs2-git
-version:            0.1.0.0
+version:            0.24.1.0
 -- synopsis:
 -- description:
 license:            BSD-3-Clause
@@ -8,24 +8,21 @@ license-file:       LICENSE
 author:             Dmitry Zuikov
 maintainer:         dzuikov@gmail.com
 -- copyright:
-category:           Development
+category:           System
 build-type:         Simple
-extra-doc-files:    CHANGELOG.md
+-- extra-doc-files:    CHANGELOG.md
 -- extra-source-files:
 
 common shared-properties
   ghc-options:
         -Wall
-        -Wno-type-defaults
+        -fno-warn-type-defaults
-        -fprint-potential-instances
+        -threaded
-        -- -fno-warn-unused-matches
+        -rtsopts
-        -- -fno-warn-unused-do-bind
+        -O2
-        -- -Werror=missing-methods
+        "-with-rtsopts=-N4 -A64m -AL256m -I0"
-        -- -Werror=incomplete-patterns
-        -- -fno-warn-unused-binds
 
-
+  default-language: GHC2021
-  default-language:    Haskell2010
 
   default-extensions:
                        ApplicativeDo
@@ -52,147 +49,122 @@ common shared-properties
                      , StandaloneDeriving
                      , TupleSections
                      , TypeApplications
-                     , TypeOperators
                      , TypeFamilies
-                     , TemplateHaskell
 
 
-  build-depends: hbs2-core, hbs2-peer
+  build-depends:
-               , attoparsec
+        hbs2-core
-               , aeson
+      , hbs2-peer
-               , async
+      , hbs2-storage-simple
-               , base16-bytestring
+      , hbs2-keyman
-               , bytestring
+      , db-pipe
-               , cache
+      , suckless-conf
-               , containers
-               , streaming
-               , streaming-bytestring
-               , streaming-commons
-               , streaming-utils
-               , cryptonite
-               , directory
-               , exceptions
-               , filelock
-               , filepath
-               , filepattern
-               , generic-lens
-               , hashable
-               , http-conduit
-               , interpolatedstring-perl6
-               , memory
-               , microlens-platform
-               , mtl
-               , prettyprinter
-               , prettyprinter-ansi-terminal
-               , random
-               , resourcet
-               , safe
-               , saltine
-               , serialise
-               , split
-               , sqlite-simple
-               , stm
-               , suckless-conf
-               , temporary
-               , text
-               , time
-               , timeit
-               , transformers
-               , typed-process
-               , uniplate
-               , unliftio
-               , unliftio-core
-               , unordered-containers
-               , wai-app-file-cgi
-               , wai-extra
 
-library
+      , attoparsec
+      , atomic-write
+      , bytestring
+      , binary
+      , containers
+      , directory
+      , exceptions
+      , filepath
+      , filepattern
+      , interpolatedstring-perl6
+      , memory
+      , microlens-platform
+      , mtl
+      , safe
+      , serialise
+      , streaming
+      , stm
+      , text
+      , time
+      , timeit
+      , transformers
+      , typed-process
+      , unordered-containers
+      , unliftio
+      , unliftio-core
+      , zlib
+      , prettyprinter
+      , prettyprinter-ansi-terminal
+      , random
+      , vector
+      , unix
+
+
+library hbs2-git-client-lib
     import:           shared-properties
 
     exposed-modules:
-      HBS2.Git.Types
-      HBS2Git.Prelude
-      HBS2Git.Alerts
-      HBS2Git.Annotations
-      HBS2Git.App
-      HBS2Git.KeysMetaData
-      HBS2Git.Config
-      HBS2Git.Evolve
-      HBS2Git.Export
-      HBS2Git.Encryption
-      HBS2Git.Encryption.KeyInfo
-      HBS2Git.GitRepoLog
-      HBS2Git.Import
-      HBS2Git.KeysCommand
-      HBS2Git.Tools
       HBS2.Git.Local
       HBS2.Git.Local.CLI
-      HBS2Git.PrettyStuff
-      HBS2Git.State
-      HBS2Git.Types
 
+      HBS2.Git.Data.Tx
+      HBS2.Git.Data.GK
+      HBS2.Git.Data.RefLog
+      HBS2.Git.Data.LWWBlock
+
+      HBS2.Git.Client.Prelude
+      HBS2.Git.Client.App.Types
+      HBS2.Git.Client.App.Types.GitEnv
+      HBS2.Git.Client.App
+      HBS2.Git.Client.Config
+      HBS2.Git.Client.State
+      HBS2.Git.Client.RefLog
+      HBS2.Git.Client.Export
+      HBS2.Git.Client.Import
+      HBS2.Git.Client.Progress
+
+    build-depends:    base
+                    , base16-bytestring
+                    , binary
+                    , unix
+
+    hs-source-dirs:   hbs2-git-client-lib
+
+
+executable hbs2-git-subscribe
+    import:           shared-properties
+    main-is:          Main.hs
     -- other-modules:
     -- other-extensions:
-    build-depends:    base
+    build-depends:
-                   , exceptions
+        base, hbs2-git-client-lib
-                   , terminal-progress-bar
+        , binary
-                   , http-types
+        , vector
-                   , uuid
+        , optparse-applicative
-                   , zlib
 
-    hs-source-dirs:   lib
+    hs-source-dirs:   git-hbs2-subscribe
-    default-language: Haskell2010
+    default-language: GHC2021
 
 executable git-hbs2
     import:           shared-properties
     main-is:          Main.hs
-
+    -- other-modules:
-    ghc-options:
-        -threaded
-        -rtsopts
-        "-with-rtsopts=-N4 -A64m -AL256m -I0"
-
-    other-modules:
-      RunShow
-      Paths_hbs2_git
-
     -- other-extensions:
     build-depends:
-        base, hbs2-git
+        base, hbs2-git-client-lib
-      , optparse-applicative
+        , binary
-      , http-types
+        , vector
-      , template-haskell
+        , optparse-applicative
 
     hs-source-dirs:   git-hbs2
-    default-language: Haskell2010
+    default-language: GHC2021
 
 
 executable git-remote-hbs2
     import:           shared-properties
-    main-is:          GitRemoteMain.hs
+    main-is:          Main.hs
-
+    -- other-modules:
-    ghc-options:
-        -threaded
-        -rtsopts
-        "-with-rtsopts=-N4 -A64m -AL256m -I0"
-
-    other-modules:
-      GitRemoteTypes
-      GitRemotePush
-
     -- other-extensions:
     build-depends:
-        base, hbs2-git
+        base, hbs2-git-client-lib
-      , async
+        , binary
-      , attoparsec
+        , vector
-      , optparse-applicative
+        , optparse-applicative
-      , unix
-      , unliftio
-      , terminal-progress-bar
-      , http-types
-
-    hs-source-dirs:   git-hbs2
-    default-language: Haskell2010
 
+    hs-source-dirs:   git-remote-hbs2
+    default-language: GHC2021
 
 

hbs2-git/hie.yaml

@@ -1,2 +0,0 @@
-cradle:
-  cabal:

hbs2-git/lib/HBS2/Git/Local.hs

@@ -1,31 +0,0 @@
-module HBS2.Git.Local
-  ( module HBS2.Git.Types
-  , module HBS2.Git.Local
-  )where
-
-import HBS2.Git.Types
-
-import Data.Functor
-import Data.String
-import Control.Monad
-import Control.Monad.IO.Class
-import Data.Set (Set)
-import Data.Set qualified as Set
-import System.Directory
-import System.FilePath
-
-gitReadRefs :: MonadIO m => FilePath -> Set String -> m [(GitRef, GitHash)]
-gitReadRefs p m = do
-
-  xs <- forM (Set.toList m) $ \br -> do
-          let fn = p </> "refs/heads" </> br
-          here <- liftIO $ doesFileExist fn
-          if here then do
-            s <- liftIO $ readFile fn <&> (fromString br,) . fromString
-            pure [s]
-          else do
-            pure mempty
-
-  pure $ mconcat xs
-
-

hbs2-git/lib/HBS2/Git/Local/CLI.hs

@@ -1,515 +0,0 @@
-{-# Language AllowAmbiguousTypes #-}
-module HBS2.Git.Local.CLI
-  ( module HBS2.Git.Local.CLI
-  , getStdin
-  , getStdout
-  , stopProcess
-  ) where
-
-import HBS2.Prelude.Plated
-import HBS2.Git.Types
-
-import HBS2.System.Logger.Simple
-
-import Control.Concurrent.Async
-import Control.Concurrent.STM
-import Control.Monad.Writer
-import Data.HashSet (HashSet)
-import Data.HashSet qualified as HashSet
-import Data.HashMap.Strict (HashMap)
-import Data.HashMap.Strict qualified as HashMap
-import Data.ByteString.Char8 qualified as BS8
-import Data.ByteString.Lazy.Char8 (ByteString)
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.Functor
-import Data.Function
-import Data.Maybe
-import Data.Set qualified as Set
-import Data.Set (Set)
-import Data.List qualified as List
-import Data.Text.Encoding qualified as Text
-import Data.Text.Encoding (decodeLatin1)
-import Data.Text qualified as Text
-import System.Process.Typed
-import Text.InterpolatedString.Perl6 (qc)
-import Lens.Micro.Platform
-import Control.Monad.Trans.Maybe
-import System.IO
-
--- FIXME: specify-git-dir
-
-parseHash :: BS8.ByteString -> GitHash
-parseHash = fromString . BS8.unpack
-
-parseHashLazy :: LBS.ByteString -> GitHash
-parseHashLazy = fromString . BS8.unpack . LBS.toStrict
-
-gitGetDepsPure :: GitObject -> Set GitHash
-
-gitGetDepsPure (GitObject Tree bs) = Set.fromList $ execWriter (go bs)
-  where
-    go :: ByteString -> Writer [GitHash] ()
-    go s = case LBS.uncons s of
-      Nothing -> pure ()
-      Just ('\x00', rest) -> do
-        let (hash, rest') = LBS.splitAt 20 rest
-        tell [GitHash (LBS.toStrict hash)]
-        go rest'
-
-      Just (_, rest) -> go rest
-
-gitGetDepsPure (GitObject Commit bs) = Set.fromList (recurse ls)
-  where
-    ls = LBS.lines bs
-    recurse :: [LBS.ByteString] -> [GitHash]
-    recurse [] = []
-    recurse ("":_)  = []
-    recurse (x:xs) =
-      case LBS.words x of
-        ["tree", s]   -> fromString (LBS.unpack s) : recurse xs
-        ["parent", s] -> fromString (LBS.unpack s) : recurse xs
-        _             -> recurse xs
-
-
-gitGetDepsPure _ = mempty
-
-gitCommitGetParentsPure :: LBS.ByteString -> [GitHash]
-gitCommitGetParentsPure bs = foldMap seek pairs
-  where
-    pairs = take 2 . LBS.words <$> LBS.lines bs
-    seek = \case
-      ["parent", x] -> [fromString (LBS.unpack x)]
-      _             -> mempty
-
-data GitParsedRef = GitCommitRef GitHash
-                  | GitTreeRef GitHash
-                    deriving stock (Data,Eq,Ord)
-
-gitGetParsedCommit :: MonadIO m => GitObject -> m [GitParsedRef]
-gitGetParsedCommit (GitObject Commit bs)  = do
-  let ws = fmap LBS.words (LBS.lines bs)
-  oo <- forM ws $ \case
-          ["tree", s]   -> pure [GitTreeRef (fromString (LBS.unpack s))]
-          ["commit", s] -> pure [GitCommitRef (fromString (LBS.unpack s))]
-          _             -> pure mempty
-
-  pure $ mconcat oo
-
-gitGetParsedCommit _ = pure mempty
-
--- FIXME: use-fromStringMay
-gitGetObjectType :: MonadIO m => GitHash -> m (Maybe GitObjectType)
-gitGetObjectType hash = do
-  (_, out, _) <- readProcess (shell [qc|git cat-file -t {pretty hash}|])
-  case headMay (LBS.words out) of
-    Just "commit" -> pure (Just Commit)
-    Just "tree"   -> pure (Just Tree)
-    Just "blob"   -> pure (Just Blob)
-    _        -> pure Nothing
-
-
-
-gitGetCommitDeps :: MonadIO m => GitHash -> m [GitHash]
-gitGetCommitDeps hash  = do
-  (_, out, _) <- readProcess (shell [qc|git cat-file commit {pretty hash}|])
-  pure $ Set.toList (gitGetDepsPure (GitObject Commit out))
-
-gitGetTreeDeps :: MonadIO m => GitHash -> m [GitHash]
-gitGetTreeDeps hash = do
-  (_, out, _) <- readProcess (shell [qc|git ls-tree {pretty hash}|])
-  let ls =  fmap parseHash . getHash <$> BS8.lines (LBS.toStrict out)
-  pure (catMaybes ls)
-  where
-    getHash = flip atMay 2 . BS8.words
-
-
-gitGetDependencies :: MonadIO m => GitHash -> m [GitHash]
-gitGetDependencies hash = do
-  ot <- gitGetObjectType hash
-  case ot of
-    Just Commit -> gitGetCommitDeps hash
-    Just Tree   -> gitGetTreeDeps hash
-    _           -> pure mempty
-
-
--- | calculates all dependencies of given list
---   of git objects
-gitGetAllDependencies :: MonadIO m
-                       => Int  -- ^ number of threads
-                       -> [ GitHash ] -- ^ initial list of objects to calculate deps
-                       -> ( GitHash -> IO [GitHash] ) -- ^ lookup function
-                       -> ( GitHash -> IO () ) -- ^ progress update function
-                       -> m [(GitHash, GitHash)]
-
-gitGetAllDependencies n objects lookup progress = liftIO do
-  input <- newTQueueIO
-  output <- newTQueueIO
-
-  memo  <- newTVarIO ( mempty :: HashSet GitHash )
-  work  <- newTVarIO ( mempty :: HashMap Int Int )
-  num   <- newTVarIO 1
-
-  atomically $ mapM_ (writeTQueue input) objects
-
-  replicateConcurrently_ n $ do
-
-    i <- atomically $ stateTVar num ( \x -> (x, succ x) )
-
-    fix \next -> do
-      o <- atomically $ tryReadTQueue input
-      case o of
-        Nothing -> do
-          todo <- atomically $ do
-            modifyTVar work (HashMap.delete i)
-            readTVar work <&> HashMap.elems <&> sum
-
-          when (todo > 0) next
-
-        Just h -> do
-
-          progress h
-
-          done <- atomically $ do
-            here <- readTVar memo <&> HashSet.member h
-            modifyTVar memo (HashSet.insert h)
-            pure here
-
-          unless done do
-            cached <- lookup h
-
-            deps <- if null cached then do
-                      gitGetDependencies h
-                    else
-                      pure cached
-
-            forM_ deps $ \d -> do
-              atomically $ writeTQueue output (h,d)
-
-            atomically $ modifyTVar work (HashMap.insert i (length deps))
-
-          next
-
-  liftIO $ atomically $ flushTQueue output
-
-
-gitGetTransitiveClosure :: forall cache . (HasCache cache GitHash (Set GitHash) IO)
-                        => cache
-                        -> Set GitHash
-                        -> GitHash
-                        -> IO (Set GitHash)
-
-gitGetTransitiveClosure cache exclude hash = do
-    -- trace $ "gitGetTransitiveClosure" <+> pretty hash
-    r <- cacheLookup cache hash :: IO (Maybe (Set GitHash))
-    case r of
-      Just xs -> pure xs
-      Nothing -> do
-        deps <- gitGetDependencies hash
-        clos <- mapM (gitGetTransitiveClosure cache exclude) deps
-        let res = (Set.fromList (hash:deps) <> Set.unions clos) `Set.difference` exclude
-        cacheInsert cache hash res
-        pure res
-
-
--- gitGetAllDepsByCommit :: GitHash -> IO [GitHash]
--- gitGetAllDepsByCommit h = do
--- -- FIXME: error-handling
---   (_, out, _) <- liftIO $ readProcess (shell [qc|git rev-list {pretty h}|])
---   let ls =  LBS.lines out & fmap ( fromString . LBS.unpack )
-
---   forM ls $ \l -> do
---     o <- liftIO $ gitReadObject (Just Commit) l
---     let tree = gitGetDepsPure (GitObject Commit o)
---     (_, out, _) <- liftIO $ readProcess (shell [qc|git rev-list {pretty h}|])
-
---     print tree
-
---   -- mapM_ (print.pretty) ls
---   pure []
-  -- deps <- mapM gitGetDependencies ls <&> mconcat
-  -- pure $ List.nub $ ls <> deps
-
--- FIXME: inject-git-working-dir-via-typeclass
-
-gitConfigGet :: MonadIO m => Text -> m (Maybe Text)
-gitConfigGet k = do
-  let cmd = [qc|git config {k}|]
-  (code, out, _) <- liftIO $ readProcess (shell cmd)
-
-  case code of
-    ExitSuccess -> pure (Just $ Text.strip [qc|{LBS.unpack out}|])
-    _           -> pure Nothing
-
-
-gitConfigSet :: MonadIO m => Text -> Text -> m ()
-gitConfigSet k v = do
-  let cmd = [qc|git config --add {k} {v}|]
-  liftIO $ putStrLn cmd
-  runProcess_ (shell cmd)
-
-gitGetRemotes :: MonadIO m => m [(Text,Text)]
-gitGetRemotes = do
-  let cmd = [qc|git config --get-regexp '^remote\..*\.url$'|]
-  (code, out, _) <- liftIO $ readProcess (shell cmd)
-
-  let txt = Text.decodeUtf8 (LBS.toStrict out)
-
-  let ls = Text.lines txt -- & foldMap (drop 1 . Text.words)
-
-  remotes <- forM ls $ \l ->
-                case Text.words l of
-                  [r,val] | Text.isPrefixOf "remote." r -> pure $ (,val) <$> stripRemote r
-                  _       -> pure Nothing
-
-  pure $ catMaybes remotes
-
-  where
-    stripRemote x = headMay $ take 1 $ drop 1 $ Text.splitOn "." x
-
--- FIXME: respect-git-workdir
-gitHeadFullName :: MonadIO m => GitRef -> m GitRef
-gitHeadFullName (GitRef r) = do
-  let r' = Text.stripPrefix "refs/heads" r & fromMaybe r
-  pure $ GitRef $ "refs/heads/" <> r'
-
--- FIXME: error handling!
-gitReadObject :: MonadIO m => Maybe GitObjectType -> GitHash -> m LBS.ByteString
-gitReadObject mbType' hash = do
-
-  mbType'' <- case mbType' of
-    Nothing -> gitGetObjectType hash
-    Just tp -> pure (Just tp)
-
-  oType <- maybe (error [qc|unknown type of {pretty hash}|]) pure mbType''
-
-  -- liftIO $ hPutStrLn stderr [qc|git cat-file {pretty oType} {pretty hash}|]
-
-  (_, out, _) <- readProcess (shell [qc|git cat-file {pretty oType} {pretty hash}|])
-
-  pure out
-
-
-gitRemotes :: MonadIO m => m (Set GitRef)
-gitRemotes = do
-  let cmd = setStdin closed $ setStdout closed
-                            $ setStderr closed
-                            $ shell [qc|git remote|]
-
-  (_, out, _) <- readProcess cmd
-  let txt = decodeLatin1 (LBS.toStrict out)
-  pure $ Set.fromList (GitRef . Text.strip <$> Text.lines txt)
-
-
-gitNormalizeRemoteBranchName :: MonadIO  m => GitRef -> m GitRef
-gitNormalizeRemoteBranchName orig@(GitRef ref) = do
-  remotes <- gitRemotes
-  stripped <- forM (Set.toList remotes) $ \(GitRef remote) -> do
-     pure $ GitRef <$> (("refs/heads" <>) <$> Text.stripPrefix remote ref)
-
-
-  let GitRef r = headDef orig (catMaybes stripped)
-
-  if Text.isPrefixOf "refs/heads" r
-      then pure (GitRef r)
-      else pure (GitRef $ "refs/heads/" <> r)
-
-
-gitStoreObject :: MonadIO m => GitObject -> m (Maybe GitHash)
-gitStoreObject (GitObject t s) = do
-  let cmd = [qc|git hash-object -t {pretty t} -w --stdin|]
-  let procCfg = setStdin (byteStringInput s) $ setStderr closed
-                                             (shell cmd)
-  (code, out, _) <- readProcess procCfg
-  case code of
-    ExitSuccess -> pure $ Just (parseHashLazy out)
-    ExitFailure{} -> pure Nothing
-
-gitCheckObject :: MonadIO m => GitHash -> m Bool
-gitCheckObject gh = do
-  let cmd = [qc|git cat-file -e {pretty gh}|]
-  let procCfg = setStderr closed (shell cmd)
-  (code, _, _) <- readProcess procCfg
-  case code of
-    ExitSuccess -> pure True
-    ExitFailure{} -> pure False
-
-gitListAllObjects :: MonadIO m => m [(GitObjectType, GitHash)]
-gitListAllObjects = do
-  let cmd = [qc|git cat-file --batch-check --batch-all-objects|]
-  let procCfg = setStdin closed $ setStderr closed (shell cmd)
-  (_, out, _) <- readProcess procCfg
-
-  pure $ LBS.lines out & foldMap (fromLine . LBS.words)
-
-  where
-    fromLine = \case
-      [ha, tp, _] -> [(fromString (LBS.unpack tp), fromString (LBS.unpack ha))]
-      _          -> []
-
--- FIXME: better error handling
-gitGetHash :: MonadIO m => GitRef -> m (Maybe GitHash)
-gitGetHash ref = do
-
-  trace $ "gitGetHash" <+> [qc|git rev-parse {pretty ref}|]
-
-  (code, out, _) <- readProcess (shell [qc|git rev-parse {pretty ref}|])
-
-  if code == ExitSuccess then do
-    let hash = fromString . LBS.unpack <$> headMay (LBS.lines out)
-    pure hash
-  else
-    pure Nothing
-
-gitGetBranchHEAD :: MonadIO m => m (Maybe GitRef)
-gitGetBranchHEAD = do
-  (code, out, _) <- readProcess (shell [qc|git rev-parse --abbrev-ref HEAD|])
-
-  if code == ExitSuccess then do
-    let hash = fromString . LBS.unpack <$> headMay (LBS.lines out)
-    pure hash
-  else
-    pure Nothing
-
-
-gitListLocalBranches :: MonadIO m => m [(GitRef, GitHash)]
-gitListLocalBranches  = do
-  let cmd = [qc|git branch --format='%(objectname) %(refname)'|]
-  let procCfg = setStdin closed $ setStderr closed (shell cmd)
-  (_, out, _) <- readProcess procCfg
-
-  pure $ LBS.lines out & foldMap (fromLine . LBS.words)
-
-  where
-    fromLine = \case
-      [h, n] -> [(fromString (LBS.unpack n), fromString (LBS.unpack h))]
-      _      -> []
-
-
-gitListAllCommits :: MonadIO m => m [GitHash]
-gitListAllCommits = do
-  let cmd = [qc|git log --all --pretty=format:'%H'|]
-  let procCfg = setStdin closed $ setStderr closed (shell cmd)
-  (_, out, _) <- readProcess procCfg
-  pure $ fmap (fromString . LBS.unpack) (LBS.lines out)
-
-gitRunCommand :: MonadIO m => String -> m (Either ExitCode ByteString)
-gitRunCommand cmd = do
-  let procCfg = setStdin closed $ setStderr closed (shell cmd)
-  (code, out, _) <- readProcess procCfg
-  case code of
-    ExitSuccess -> pure (Right out)
-    e           -> pure (Left e)
-
--- | list all commits from the given one in order of date
-gitListAllCommitsExceptBy :: MonadIO m => Set GitHash -> Maybe GitHash -> GitHash -> m [GitHash]
-gitListAllCommitsExceptBy excl l h = do
-  let from = maybe mempty (\r -> [qc|{pretty r}..|] ) l
-  let cmd = [qc|git rev-list --reverse --date-order {from}{pretty h}|]
-  let procCfg = setStdin closed $ setStderr closed (shell cmd)
-  (_, out, _) <- readProcess procCfg
-  let res = fmap (fromString . LBS.unpack) (LBS.lines out)
-  pure $ List.reverse $ filter ( not . flip Set.member excl) res
-
--- | list all objects for the given commit range in order of date
-gitRevList :: MonadIO m => Maybe GitHash -> GitHash -> m [GitHash]
-gitRevList l h = do
-  let from = maybe mempty (\r -> [qc|{pretty r}..|] ) l
-  -- let cmd = [qc|git rev-list --objects --in-commit-order --reverse --date-order {from}{pretty h}|]
-  -- let cmd = [qc|git rev-list --objects --reverse --in-commit-order {from}{pretty h}|]
-  let cmd = [qc|git rev-list --reverse --in-commit-order --objects {from}{pretty h}|]
-  let procCfg = setStdin closed $ setStderr closed (shell cmd)
-  (_, out, _) <- readProcess procCfg
-  pure $ mapMaybe (fmap (fromString . LBS.unpack) . headMay . LBS.words) (LBS.lines out)
-
--- TODO: handle-invalid-input-somehow
-gitGetObjectTypeMany :: MonadIO m =>  [GitHash] -> m [(GitHash, GitObjectType)]
-gitGetObjectTypeMany hashes = do
-  let hss = LBS.unlines $ fmap (LBS.pack.show.pretty) hashes
-  let cmd = [qc|git cat-file --batch-check='%(objectname) %(objecttype)'|]
-  let procCfg = setStdin (byteStringInput hss) $ setStderr closed (shell cmd)
-  (_, out, _) <- readProcess procCfg
-  pure $ mapMaybe (parse . fmap LBS.unpack . LBS.words) (LBS.lines out)
-  where
-    parse [h,tp] = (,) <$> fromStringMay h <*> fromStringMay tp
-    parse _ = Nothing
-
-gitGetCommitImmediateDeps :: MonadIO m => GitHash -> m [GitHash]
-gitGetCommitImmediateDeps h = do
-  o <- gitReadObject (Just Commit) h
-  let lws = LBS.lines o & fmap LBS.words
-
-  t <- forM lws $ \case
-        ["tree", hs]  -> pure (Just ( fromString @GitHash (LBS.unpack hs) ))
-        _             -> pure Nothing
-
-  let tree = take 1 $ catMaybes t
-
-  deps <- gitRunCommand [qc|git rev-list --objects {pretty (headMay tree)}|]
-            >>= either (const $ pure mempty)
-                       (pure . mapMaybe withLine . LBS.lines)
-
-  pure $ List.nub $ tree <> deps
-  where
-    withLine :: LBS.ByteString -> Maybe GitHash
-    withLine l = do
-      let wordsInLine = LBS.words l
-      firstWord <- listToMaybe wordsInLine
-      pure $ fromString @GitHash $ LBS.unpack firstWord
-
-
-startGitHashObject :: MonadIO m => GitObjectType -> m (Process Handle () ())
-startGitHashObject objType = do
-  let cmd = "git"
-  let args = ["hash-object", "-w", "-t", show (pretty objType), "--stdin-paths"]
-  let config = setStdin createPipe $ setStdout closed $ setStderr inherit $ proc cmd args
-  startProcess config
-
-startGitCatFile :: MonadIO m => m (Process Handle Handle ())
-startGitCatFile = do
-  let cmd = "git"
-  let args = ["cat-file", "--batch"]
-  let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ proc cmd args
-  startProcess config
-
-gitReadFromCatFileBatch :: MonadIO m
-                        => Process Handle Handle a
-                        -> GitHash
-                        -> m (Maybe GitObject)
-
-gitReadFromCatFileBatch prc gh = do
-
-    let ssin = getStdin prc
-    let sout = getStdout prc
-
-    liftIO $ hPrint  ssin (pretty gh) >> hFlush ssin
-
-    runMaybeT do
-
-      here <- liftIO $ hWaitForInput sout 1000
-
-      guard here
-
-      header <- liftIO $ BS8.hGetLine sout
-
-      case BS8.unpack <$> BS8.words header of
-        [ha, t, s] -> do
-          (_, tp, size) <- MaybeT $ pure $ (,,) <$> fromStringMay @GitHash ha
-                                                <*> fromStringMay @GitObjectType t
-                                                <*> readMay s
-
-          content <- liftIO $ LBS.hGet sout size
-
-          guard (LBS.length content == fromIntegral size)
-
-          void $ liftIO $ LBS.hGet sout 1
-
-          let object = GitObject tp content
-
-          -- TODO: optionally-check-hash
-          -- guard (gh== gitHashObject object)
-
-          pure object
-
-        _                -> MaybeT $ pure Nothing
-
-

hbs2-git/lib/HBS2/Git/Types.hs

@@ -1,134 +0,0 @@
-{-# Language AllowAmbiguousTypes #-}
-module HBS2.Git.Types where
-
-import HBS2.Prelude
-import HBS2.System.Logger.Simple
-
-import Crypto.Hash hiding (SHA1)
-import Crypto.Hash qualified as Crypto
-import Data.Aeson
-import Data.ByteArray qualified as BA
-import Data.ByteString.Base16 qualified as B16
-import Data.ByteString (ByteString)
-import Data.ByteString.Char8 qualified as BS
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.Data
-import Data.Generics.Uniplate.Data()
-import Data.String (IsString(..))
-import Data.Text.Encoding (decodeLatin1)
-import Data.Text qualified as Text
-import Data.Text (Text)
-import GHC.Generics
-import Prettyprinter
-import Text.InterpolatedString.Perl6 (qc)
-import Data.Hashable
-import Codec.Serialise
-import Data.Maybe
-
-class Monad m => HasCache t k v m where
-  cacheLookup  :: t -> k -> m (Maybe v)
-  cacheInsert  :: t -> k -> v -> m ()
-
-data SHA1 = SHA1
-            deriving stock(Eq,Ord,Data,Generic)
-
-newtype GitHash = GitHash ByteString
-                  deriving stock (Eq,Ord,Data,Generic,Show)
-                  deriving newtype Hashable
-
-instance Serialise GitHash
-
-instance IsString GitHash where
-  fromString s = GitHash (B16.decodeLenient (BS.pack s))
-
-instance FromStringMaybe GitHash where
-  fromStringMay s = either (const Nothing) pure (GitHash <$> B16.decode bs)
-    where
-      bs = BS.pack s
-
-instance Pretty GitHash where
-  pretty (GitHash s) = pretty @String [qc|{B16.encode s}|]
-
-
-data GitObjectType = Commit | Tree | Blob
-                     deriving stock (Eq,Ord,Show,Generic)
-
-instance ToJSON GitObjectType
-instance FromJSON GitObjectType
-
-instance IsString GitObjectType where
-  fromString = \case
-    "commit" -> Commit
-    "tree"   -> Tree
-    "blob"   -> Blob
-    x        -> error [qc|invalid git object type {x}|]
-
-instance FromStringMaybe GitObjectType where
-  fromStringMay = \case
-    "commit" -> Just Commit
-    "tree"   -> Just Tree
-    "blob"   -> Just Blob
-    _        -> Nothing
-
-instance Pretty GitObjectType where
-  pretty = \case
-    Commit -> pretty @String "commit"
-    Tree   -> pretty @String "tree"
-    Blob   -> pretty @String "blob"
-
-
-data GitObject = GitObject GitObjectType LBS.ByteString
-
-newtype GitRef = GitRef { unGitRef :: Text }
-                 deriving stock (Eq,Ord,Data,Generic,Show)
-                 deriving newtype (IsString,FromJSON,ToJSON,Monoid,Semigroup,Hashable)
-
-instance Serialise GitRef
-
-mkGitRef :: ByteString -> GitRef
-mkGitRef x = GitRef (decodeLatin1 x)
-
-instance Pretty GitRef where
-  pretty (GitRef x) = pretty @String [qc|{x}|]
-
-
-instance FromJSONKey GitRef where
-  fromJSONKey = FromJSONKeyText GitRef
-
-class Monad m => HasDependecies m a where
-  getDependencies :: a -> m [GitHash]
-
-class GitHashed a where
-  gitHashObject :: a -> GitHash
-
-instance GitHashed LBS.ByteString where
-  gitHashObject s = GitHash $ BA.convert digest
-    where
-      digest = hashlazy s :: Digest Crypto.SHA1
-
-instance GitHashed GitObject where
-  gitHashObject (GitObject t c) = gitHashObject  (hd <> c)
-    where
-      hd = LBS.pack $ show (pretty t) <> " " <> show (LBS.length c) <> "\x0"
-
-normalizeRef :: GitRef -> GitRef
-normalizeRef (GitRef x) = GitRef "refs/heads/" <> GitRef (fromMaybe x (Text.stripPrefix "refs/heads/" (strip x)))
-  where
-    strip = Text.dropWhile (=='+')
-
-guessHead :: GitRef -> Integer
-guessHead = \case
-  "refs/heads/master" -> 0
-  "refs/heads/main"   -> 0
-  _                   -> 1
-
-shutUp :: MonadIO m => m ()
-shutUp = do
-  setLoggingOff @DEBUG
-  setLoggingOff @ERROR
-  setLoggingOff @NOTICE
-  setLoggingOff @TRACE
-  setLoggingOff @INFO
-  setLoggingOff @WARN
-
-

hbs2-git/lib/HBS2Git/Alerts.hs

@@ -1,9 +0,0 @@
-module HBS2Git.Alerts where
-
-import HBS2.Prelude
-
-import Text.InterpolatedString.Perl6 (qc)
-
-noKeyInfoMsg :: forall a . Pretty a => a -> String
-noKeyInfoMsg repo =
-  [qc|*** No KeyInfo found, maybe malformed 'encryption' section for {pretty repo} in config|]

hbs2-git/lib/HBS2Git/Annotations.hs

@@ -1,20 +0,0 @@
-module HBS2Git.Annotations where
-
-import HBS2Git.Prelude
-import HBS2Git.Encryption
-
-data Annotation =
-  GK1 HashRef (GroupKey 'Symm HBS2Basic)
-  deriving (Generic)
-
-data Annotations =
-    NoAnnotations
-  | SmallAnnotations [Annotation]
-  deriving (Generic)
-
-instance Serialise Annotation
-instance Serialise Annotations
-
-
-
-

hbs2-git/lib/HBS2Git/App.hs

@@ -1,602 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# Language AllowAmbiguousTypes #-}
-{-# Language UndecidableInstances #-}
-module HBS2Git.App
-  ( module HBS2Git.App
-  , module HBS2Git.Types
-  , HasStorage(..)
-  , HasConf(..)
-  )
-  where
-
-import HBS2.Prelude.Plated
-import HBS2.Data.Types.Refs
-import HBS2.Base58
-import HBS2.OrDie
-import HBS2.Hash
-import HBS2.Clock
-import HBS2.Storage
-import HBS2.Storage.Operations.ByteString as OP
-import HBS2.Net.Auth.GroupKeySymm qualified as Symm
-import HBS2.System.Logger.Simple
-import HBS2.Merkle
-import HBS2.Git.Types
-import HBS2.Peer.RPC.Client.StorageClient
-import HBS2.Net.Auth.Credentials hiding (getCredentials)
-import HBS2.Peer.Proto
-import HBS2.Defaults (defBlockSize)
-
-import HBS2.Peer.RPC.Client.Unix
-import HBS2.Peer.RPC.API.Peer
-import HBS2.Peer.RPC.API.RefLog
-
-import HBS2Git.Types
-import HBS2Git.Config as Config
-import HBS2Git.State
-import HBS2Git.KeysMetaData
-import HBS2Git.Encryption
-import HBS2Git.Evolve
-import HBS2Git.PrettyStuff
-import HBS2Git.Alerts
-
-import Data.Maybe
-import Control.Monad.Trans.Maybe
-import Data.Foldable
-import Data.Either
-import Control.Monad.Reader
-import Control.Monad.Trans.Resource
-import Control.Monad.Except (runExceptT)
-import Control.Monad.Catch
-import Crypto.Saltine.Core.Sign qualified as Sign
-import Data.ByteString.Lazy.Char8 (ByteString)
-import Data.ByteString.Char8 qualified as B8
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.Set (Set)
-import Data.Set qualified as Set
-import Lens.Micro.Platform
-import System.Directory
-import System.FilePattern.Directory
-import System.FilePath
-import System.Process.Typed
-import Text.InterpolatedString.Perl6 (qc)
-import Control.Concurrent.STM (flushTQueue)
-import Codec.Serialise
-import Data.HashMap.Strict qualified as HashMap
-import Data.HashSet qualified as HashSet
-import Data.List qualified as List
-import Data.Text qualified as Text
-import System.Environment
-
-import Prettyprinter.Render.Terminal
-
-import Streaming.Prelude qualified as S
-
-import UnliftIO as UIO
-
-data NoRPCException = NoRPCException
-  deriving stock (Show, Typeable)
-
-instance Exception NoRPCException
-
--- instance HasTimeLimits  UNIX (ServiceProto PeerAPI UNIX) m where
-
-instance MonadIO m => HasCfgKey ConfBranch (Set String) m where
-  key = "branch"
-
-instance MonadIO m => HasCfgKey ConfBranch (Set GitRef) m where
-  key = "branch"
-
-instance MonadIO m => HasCfgKey HeadBranch (Maybe GitRef) m where
-  key = "head-branch"
-
-instance MonadIO m => HasCfgKey KeyRingFile (Maybe FilePath) m where
-  key = "keyring"
-
-instance MonadIO m => HasCfgKey KeyRingFiles (Set FilePath) m where
-  key = "keyring"
-
-instance MonadIO m => HasCfgKey StoragePref (Maybe FilePath) m where
-  key = "storage"
-
-tracePrefix :: SetLoggerEntry
-tracePrefix  = toStderr . logPrefix "[trace] "
-
-debugPrefix :: SetLoggerEntry
-debugPrefix  = toStderr . logPrefix "[debug] "
-
-errorPrefix :: SetLoggerEntry
-errorPrefix  = toStderr . logPrefix "[error] "
-
-warnPrefix :: SetLoggerEntry
-warnPrefix   = toStderr . logPrefix "[warn] "
-
-noticePrefix :: SetLoggerEntry
-noticePrefix = toStderr
-
-infoPrefix :: SetLoggerEntry
-infoPrefix = toStderr
-
-data WithLog = NoLog | WithLog
-
-
-instance MonadIO m => HasGlobalOptions (App m) where
-  addGlobalOption k v =
-    asks (view appOpts ) >>= \t -> liftIO $ atomically $
-      modifyTVar' t (HashMap.insert k v)
-
-  getGlobalOption k = do
-    hm <- asks (view appOpts) >>= liftIO . readTVarIO
-    pure (HashMap.lookup k hm)
-
-instance MonadIO m => HasRefCredentials (App m) where
-  setCredentials ref cred = do
-    asks (view appRefCred) >>= \t -> liftIO $ atomically $
-      modifyTVar' t (HashMap.insert ref cred)
-
-  getCredentials ref = do
-    hm <- asks (view appRefCred) >>= liftIO . readTVarIO
-    pure (HashMap.lookup ref hm) `orDie` "keyring not set (1)"
-
-instance MonadIO m => HasEncryptionKeys (App m) where
-  addEncryptionKey ke = do
-    asks (view appKeys) >>= \t -> liftIO $ atomically do
-      modifyTVar' t (HashMap.insert (view krPk ke) (view krSk ke))
-
-  findEncryptionKey puk = (asks (view appKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.lookup puk
-
-  enumEncryptionKeys = do
-    them <- (asks (view appKeys) >>= \t -> liftIO $ readTVarIO t) <&> HashMap.toList
-    pure $ [KeyringEntry k s Nothing | (k,s) <- them ]
-
-instance (Monad m, HasStorage m) => (HasStorage (ResourceT m)) where
-  getStorage = lift getStorage
-
-instance MonadIO m => HasStorage (App m) where
-  getStorage =  asks (rpcStorage . view appRpc) <&> AnyStorage . StorageClient
-
-instance MonadIO m => HasRPC (App m) where
-  getRPC =  asks (view appRpc)
-
-withApp :: MonadIO m => AppEnv -> App m a -> m a
-withApp env m = runReaderT (fromApp m) env
-
-
-detectRPC :: (MonadIO m, MonadThrow m) => Bool -> m FilePath
-detectRPC noisy = do
-  (_, o, _) <- readProcess (shell [qc|hbs2-peer poke|])
-
-  let answ = parseTop (LBS.unpack o) & fromRight mempty
-
-  so <- case headMay [ Text.unpack r | ListVal (Key "rpc:" [LitStrVal r]) <- answ  ] of
-          Nothing -> throwM NoRPCException
-          Just w  -> pure w
-
-  when noisy do
-
-    -- FIXME: logger-to-support-colors
-    liftIO $ hPutDoc stderr $ yellow "rpc: found RPC" <+> pretty so
-                              <> line <>
-                              yellow "rpc: add option" <+> parens ("rpc unix" <+> dquotes (pretty so))
-                              <+> "to the config .hbs2/config"
-                              <> line <> line
-
-
-  pure so
-
-runWithRPC :: forall m . (MonadUnliftIO m, MonadThrow m) => (RPCEndpoints -> m ()) -> m ()
-runWithRPC action = do
-
-  (_, syn) <- configInit
-
-  let soname' = lastMay [ Text.unpack n
-                        | ListVal (Key "rpc" [SymbolVal "unix", LitStrVal n]) <- syn
-                        ]
-
-  soname <- race ( pause @'Seconds 1) (maybe (detectRPC True) pure soname') `orDie` "hbs2-peer rpc timeout!"
-
-  client <- race ( pause @'Seconds 1) (newMessagingUnix False 1.0 soname) `orDie` "hbs2-peer rpc timeout!"
-
-  rpc <- RPCEndpoints <$> makeServiceCaller (fromString soname)
-                      <*> makeServiceCaller (fromString soname)
-                      <*> makeServiceCaller (fromString soname)
-
-  messaging <- async $ runMessagingUnix client
-  link messaging
-
-  let endpoints = [ Endpoint @UNIX  (rpcPeer rpc)
-                  , Endpoint @UNIX  (rpcStorage rpc)
-                  , Endpoint @UNIX  (rpcRefLog rpc)
-                  ]
-
-  c1 <- async $ liftIO $ runReaderT (runServiceClientMulti endpoints) client
-  link c1
-
-  test <- race ( pause @'Seconds 1) (callService @RpcPoke (rpcPeer rpc) ()) `orDie` "hbs2-peer rpc timeout!"
-
-  void $ pure test `orDie` "hbs2-peer rpc error!"
-
-  debug $ "hbs2-peer RPC ok" <+> pretty soname
-
-  action rpc
-
-  cancel messaging
-
-  void $ waitAnyCatchCancel [messaging, c1]
-
-runInit :: (MonadUnliftIO m, MonadThrow m) => m () -> m ()
-runInit m = m
-
-runApp :: (MonadUnliftIO m, MonadThrow m) => WithLog -> App m () -> m ()
-runApp l m = do
-
-  flip UIO.catches dealWithException do
-
-    case l of
-      NoLog   -> pure ()
-      WithLog -> do
-        setLogging @ERROR  errorPrefix
-        setLogging @NOTICE noticePrefix
-        setLogging @INFO   infoPrefix
-
-    doTrace <- liftIO $ lookupEnv "HBS2TRACE" <&> isJust
-
-    if doTrace then do
-      setLogging @DEBUG  debugPrefix
-      setLogging @TRACE  tracePrefix
-    else do
-      setLoggingOff @DEBUG
-      setLoggingOff @TRACE
-
-    evolve
-
-    (pwd, syn) <- Config.configInit
-
-    xdgstate <- getAppStateDir
-
-    runWithRPC $ \rpc -> do
-      mtCred <- liftIO $ newTVarIO mempty
-      mtKeys <- liftIO $ newTVarIO mempty
-      mtOpt <- liftIO $ newTVarIO mempty
-      let env = AppEnv pwd (pwd </> ".git") syn xdgstate mtCred mtKeys mtOpt rpc
-      runReaderT (fromApp (loadKeys >> m)) (set appRpc rpc env)
-
-    debug $ vcat (fmap pretty syn)
-
-    setLoggingOff @DEBUG
-    setLoggingOff @ERROR
-    setLoggingOff @NOTICE
-    setLoggingOff @TRACE
-    setLoggingOff @INFO
-
-  where
-    dealWithException = [ noWorkDir ]
-
-    noWorkDir = Handler $
-      \NoWorkDirException -> liftIO do
-        hPutDoc stderr $ "hbs2-git:" <+> red "*** no git working directory found."
-                                     <+> yellow "Perhaps you'd call" <+> "'git init'" <+> "first"
-                                     <> line
-        exitFailure
-
-readBlock :: forall m . (MonadIO m, HasStorage m) => HashRef -> m (Maybe ByteString)
-readBlock h = do
-  sto <- getStorage
-  liftIO $ getBlock sto (fromHashRef h)
-
-readRef :: (HasStorage m, MonadIO m) => RepoRef -> m (Maybe HashRef)
-readRef ref = do
-  sto <- getStorage
-  liftIO (getRef sto ref) <&> fmap HashRef
-
-readHashesFromBlock :: (MonadIO m, HasStorage m) => HashRef -> m [HashRef]
-readHashesFromBlock (HashRef h) = do
-  treeQ <- liftIO newTQueueIO
-  walkMerkle h (readBlock . HashRef) $ \hr -> do
-    case hr of
-      Left{} -> pure ()
-      Right (hrr :: [HashRef]) -> liftIO $ atomically $ writeTQueue treeQ hrr
-  re <- liftIO $ atomically $ flushTQueue treeQ
-  pure $ mconcat re
-
-type ObjType = MTreeAnn [HashRef]
-
-readObject :: forall m . (MonadIO m, HasStorage m) => HashRef -> m (Maybe ByteString)
-readObject h = runMaybeT do
-
-  q <- liftIO newTQueueIO
-
-  -- trace $ "readObject" <+> pretty h
-
-  blk <- MaybeT $ readBlock h
-
-  ann <- MaybeT $ pure $ deserialiseOrFail @(MTreeAnn [HashRef]) blk & either (const Nothing) Just
-
-  walkMerkleTree (_mtaTree ann) (lift . readBlock . HashRef) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
-    case hr of
-      Left{} -> mzero
-      Right (hrr :: [HashRef]) -> do
-        for_ hrr $ \(HashRef hx) -> do
-            block <- MaybeT $ readBlock (HashRef hx)
-            liftIO $ atomically $ writeTQueue q block
-
-  mconcat <$> liftIO (atomically $ flushTQueue q)
-
-calcRank :: forall m . (MonadIO m, HasStorage m) => HashRef -> m Int
-calcRank h = fromMaybe 0 <$> runMaybeT do
-
-  blk <- MaybeT $ readBlock h
-
-  ann <- MaybeT $ pure $ deserialiseOrFail @(MTree [HashRef]) blk & either (const Nothing) Just
-
-  n <- S.toList_ $ do
-    walkMerkleTree ann (lift . readBlock . HashRef) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
-      case hr of
-        Left{} -> pure ()
-        Right (hrr :: [HashRef]) -> do
-          S.yield (List.length hrr)
-
-  pure $ sum n
-
-postRefUpdate :: ( MonadIO m
-                 , MonadMask m
-                 , HasStorage m
-                 , HasConf m
-                 , HasRefCredentials m
-                 , HasEncryptionKeys m
-                 , HasRPC m
-                 , IsRefPubKey Schema
-                 )
-              => RepoRef
-              -> Integer
-              -> HashRef
-              -> m ()
-
-postRefUpdate ref seqno hash = do
-
-  cred <- getCredentials ref
-  let pubk = view peerSignPk cred
-  let privk = view peerSignSk cred
-
-  ann <- genKeysAnnotations ref
-
-  --  вот прямо сюда ОЧЕНЬ удобно вставить метаданные для GK1
-  let tran = SequentialRef seqno (AnnotatedHashRef ann hash)
-  let bs = serialise tran & LBS.toStrict
-
-  msg <- makeRefLogUpdate @HBS2L4Proto pubk privk bs
-
-  rpc <- getRPC <&> rpcRefLog
-
-  callService @RpcRefLogPost rpc msg
-    >>= either (err . viaShow) (const $ pure ())
-
-
-storeObject :: ( MonadIO m
-               , MonadMask m
-               , HasStorage m
-               , HasConf m
-               , HasRefCredentials m
-               , HasEncryptionKeys m
-               )
-            => RepoRef
-            -> ByteString
-            -> ByteString
-            -> m (Maybe HashRef)
-storeObject repo meta bs = do
-  encrypted <- isRefEncrypted (fromRefLogKey repo)
-  info $ "encrypted" <+> pretty repo <> colon <+> if encrypted then "yes" else "no"
-  storeObjectRPC encrypted repo meta bs
-
-
-
-data WriteOp = WritePlain | WriteEncrypted B8.ByteString
-
-storeObjectRPC :: ( MonadIO m
-                  , MonadMask m
-                  , HasStorage m
-                  , HasConf m
-                  , HasRefCredentials m
-                  , HasEncryptionKeys m
-                  )
-               => Bool
-               -> RepoRef
-               -> ByteString
-               -> ByteString
-               -> m (Maybe HashRef)
-
-storeObjectRPC False repo meta bs = do
-  sto <- getStorage
-  db <- makeDbPath repo >>= dbEnv
-
-  runMaybeT do
-
-
-    h <- liftIO $ writeAsMerkle sto bs
-    let txt = LBS.unpack meta & Text.pack
-    blk <- MaybeT $ liftIO $ getBlock sto h
-
-    -- FIXME: fix-excess-data-roundtrip
-    mtree <- MaybeT $ deserialiseOrFail @(MTree [HashRef]) blk
-                    & either (const $ pure  Nothing) (pure . Just)
-
-    -- TODO: upadte-metadata-right-here
-    let ann = serialise (MTreeAnn (ShortMetadata txt) NullEncryption mtree)
-    MaybeT $ liftIO $ putBlock sto ann <&> fmap HashRef
-
-
-storeObjectRPC True repo meta bs = do
-
-  sto <- getStorage
-  db <- makeDbPath repo >>= dbEnv
-
-  runMaybeT do
-
-    let txt = LBS.unpack meta & Text.pack
-
-    ki <- lift $ getKeyInfo (fromRefLogKey repo) >>= maybe noKeyInfo pure
-    gkh0 <- withDB db $ stateGetLocalKey ki >>= maybe noKeyFound pure
-
-    gk0  <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gkh0)))
-               >>= either (const $ noKeyFound) (pure . deserialiseOrFail @(GroupKey 'Symm HBS2Basic))
-               >>= either (const $ noKeyFound) pure
-
-    let pk = keyInfoOwner ki
-
-    sk <- lift (findEncryptionKey pk) >>= maybe noKeyFound pure
-
-    gks <- maybe noKeyFound pure (Symm.lookupGroupKey sk pk gk0)
-
-    let nonce = hashObject @HbSync bs & serialise
-                                      & LBS.drop 2
-                                      & LBS.toStrict
-
-    let bsStream = readChunkedBS bs defBlockSize
-
-    let source = ToEncryptSymmBS gks
-                                 (Left gkh0 :: LoadedRef (GroupKey 'Symm HBS2Basic))
-                                 nonce
-                                 bsStream
-                                 (ShortMetadata txt)
-                                 Nothing
-
-    h <- runExceptT (writeAsMerkle sto source) >>= either (const cantWriteMerkle) pure
-
-    pure (HashRef h)
-
-  where
-
-    cantWriteMerkle :: forall a m . MonadIO m => m a
-    cantWriteMerkle = die "Can't write encrypted merkle tree"
-
-    noKeyFound :: forall a m . MonadIO m => m a
-    noKeyFound = do
-      liftIO $ hPutDoc stderr (red $ "No group key found for repo" <+> pretty repo <> line)
-      die "*** fatal"
-
-    noKeyInfo = do
-      liftIO $ hPutDoc stderr (red $ pretty (noKeyInfoMsg repo) <> line)
-      die "*** fatal"
-
-
-loadCredentials :: ( MonadIO m
-                   , HasConf m
-                   , HasRefCredentials m
-                   ) => [FilePath] -> m ()
-loadCredentials fp = do
-
-  debug $ "loadCredentials" <+> pretty fp
-
-  krOpt' <- cfgValue @KeyRingFiles @(Set FilePath) <&> Set.toList
-
-  let krOpt = List.nub $ fp <> krOpt'
-
-  void $ runMaybeT do
-
-    when (null krOpt) do
-      debug "keyring not set (2)"
-      mzero
-
-    for_ krOpt $ \fn -> do
-      (puk, cred) <- loadKeyring fn
-      trace $ "got creds for" <+> pretty (AsBase58 puk)
-      lift $ setCredentials (RefLogKey puk) cred
-      pure ()
-
-loadCredentials' ::
-    ( MonadIO m
-    , HasRefCredentials m
-    )
-    => FilePath -> m Sign.PublicKey
-loadCredentials' fn = do
-    (puk, cred) <- runMaybeT (loadKeyring fn) `orDie` [qc|Can't load credentials {fn}|]
-    trace $ "got creds for" <+> pretty (AsBase58 puk)
-    setCredentials (RefLogKey puk) cred
-    pure puk
-
-loadKeyring :: (MonadIO m, MonadPlus m) => FilePath -> m (Sign.PublicKey, PeerCredentials Schema)
-loadKeyring fn = do
-    krData <- liftIO $ B8.readFile fn
-
-    let cred' = parseCredentials @Schema (AsCredFile krData)
-
-    maybe1 cred' mzero $ \cred -> do
-      let puk = view peerSignPk cred
-      pure (puk, cred)
-
-
-makeFilter :: String -> (String, [String])
-makeFilter = norm . over _1 sub1 . over _2 List.singleton . go ""
-  where
-    go pref ( cn : cs ) | cn `elem` "?*" = (p0, p1 <> p2)
-      where
-        (p0, p1) = splitFileName pref
-        p2 = cn : cs
-
-    go pref ( '/' : cn : cs ) | cn `elem` "?*" = (pref <> ['/'], cn : cs)
-
-    go pref ( c : cs ) = go (pref <> [c]) cs
-
-    go pref [] = (pref, "")
-
-    sub1 "" = "."
-    sub1 x = x
-
-    norm (xs, [""]) = (p1, [p2])
-      where
-        (p1, p2) = splitFileName xs
-
-    norm x = x
-
-loadKeys :: ( MonadIO m
-            , HasConf m
-            , HasEncryptionKeys m
-            , HasGlobalOptions m
-            ) => m ()
-loadKeys = do
-  conf <- getConf
-
-  trace $ "loadKeys"
-
-  found1 <- findKeyFiles =<< liftIO (lookupEnv "HBS2KEYS")
-  found2 <- findKeyFiles =<< getGlobalOption "key"
-
-  found <- liftIO $ mapM canonicalizePath (found1 <> found2)
-
-  let enc = [ args | (ListVal (SymbolVal "encrypted" : (LitStrVal r) : args)) <- conf ]
-
-  let owners  = [ fromStringMay @(PubKey 'Encrypt Schema) (Text.unpack o)
-                | ListVal (Key "owner" [LitStrVal o]) :: Syntax C <- universeBi enc
-                ] & catMaybes & HashSet.fromList
-
-
-  let members = [ fromStringMay @(PubKey 'Encrypt Schema) (Text.unpack o)
-                | ListVal (Key "member" [LitStrVal o]) :: Syntax C <- universeBi enc
-                ] & catMaybes & HashSet.fromList
-
-  let decrypt =  [ Text.unpack o
-                 | ListVal (Key "decrypt" [LitStrVal o]) <- conf
-                 ]
-
-  let keyrings = [ Text.unpack o | (ListVal (Key "keyring" [LitStrVal o]) :: Syntax C)
-                 <- universeBi enc
-                 ] <> decrypt <> found
-                 & List.nub
-
-  forM_ keyrings $ \k -> void $ runMaybeT do
-    trace $ "loadKeys: keyring" <+> pretty k
-    (_, pc) <- loadKeyring k
-
-    forM_ (view peerKeyring pc) $ \ke -> do
-      let pk = view krPk  ke
-
-      trace $ "loadKeyring: key" <+> pretty (AsBase58 pk)
-      lift $ addEncryptionKey ke
-
-
-  where
-    findKeyFiles w = do
-        let flt = makeFilter <$> w
-        maybe1 flt (pure mempty) $
-          \(p, fmask) -> liftIO do
-            getDirectoryFiles p fmask <&> fmap (p</>)
-

hbs2-git/lib/HBS2Git/Config.hs

@@ -1,142 +0,0 @@
-module HBS2Git.Config
-  ( module HBS2Git.Config
-  , module Data.Config.Suckless
-  ) where
-
-import HBS2.Prelude.Plated
-import HBS2.Base58
-import HBS2.System.Logger.Simple
-import HBS2.OrDie
-
-import Data.Config.Suckless
-
-import HBS2Git.Types
-
-import Control.Applicative
-
-import Control.Exception
-import Control.Monad.Catch (MonadThrow, throwM)
-import System.FilePath
-import System.Directory
-import Data.Maybe
-import Data.Either
-import Data.List (isSuffixOf)
-import Control.Monad.Trans.Maybe
-
-import System.Environment
-
-import System.IO (stderr)
-
-data NoWorkDirException =
-  NoWorkDirException
-  deriving (Show, Typeable)
-
-instance Exception NoWorkDirException
-
-appName :: FilePath
-appName = "hbs2-git"
-
--- Finds .git dir inside given directory moving upwards
-findGitDir :: MonadIO m => FilePath -> m (Maybe FilePath)
-findGitDir dir = liftIO do
-  trace "locating .git directory"
-  let gitDir = dir </> ".git"
-  exists <- doesDirectoryExist gitDir
-  if exists
-    then return $ Just gitDir
-    else let parentDir = takeDirectory dir
-         in if parentDir == dir -- we've reached the root directory
-               then return Nothing
-               else findGitDir parentDir
-
-configPathOld :: MonadIO m => FilePath -> m FilePath
-configPathOld pwd = liftIO do
-  xdg <- liftIO $ getXdgDirectory XdgConfig appName
-  home <- liftIO getHomeDirectory
-  pure $ xdg </> makeRelative home pwd
-
-configPath :: (MonadIO m, MonadThrow m) => FilePath -> m FilePath
-configPath _ = do
-  pwd <- liftIO getCurrentDirectory
-  git <- findGitDir pwd
-  byEnv <- liftIO $ lookupEnv "GIT_DIR"
-
-  bare <- if isJust (git <|> byEnv) then do
-            pure Nothing
-          else runMaybeT do
-            -- check may be it's a bare git repo
-            gitConf <- toMPlus =<< liftIO ( try @IOException $
-                                             readFile "config"
-                                                <&> parseTop
-                                                <&> fromRight mempty )
-
-            let core = or [True | SymbolVal @C "core" <- universeBi gitConf]
-            let bare = or [True | ListVal [SymbolVal @C "bare", _, SymbolVal "true"] <- universeBi gitConf ]
-            let repo = or [True | SymbolVal @C "repositoryformatversion" <- universeBi gitConf ]
-
-            if core && bare && repo then do
-              pure pwd
-            else
-              MaybeT $ pure Nothing
-
-  let maybePath = dropSuffix <$> (git <|> byEnv <|> bare)
-
-  path <- maybe (throwM NoWorkDirException)
-                pure
-                maybePath
-
-  pure (path </> ".hbs2")
-
-  where
-    dropSuffix s | isSuffixOf ".git/" s = takeDirectory s
-                 | isSuffixOf ".git" s  = takeDirectory s
-                 | otherwise = s
-
-data ConfigPathInfo = ConfigPathInfo {
-  configRepoParentDir :: FilePath,
-  configDir :: FilePath,
-  configFilePath :: FilePath
-} deriving (Eq, Show)
-
--- returns git repository parent dir, config directory and config file path
-getConfigPathInfo :: (MonadIO m, MonadThrow m) => m ConfigPathInfo
-getConfigPathInfo = do
-  trace "getConfigPathInfo"
-  confP <- configPath ""
-  let pwd = takeDirectory confP
-  let confFile = confP </> "config"
-  trace $ "confPath:" <+> pretty confP
-  pure ConfigPathInfo {
-      configRepoParentDir = pwd,
-      configDir = confP,
-      configFilePath = confFile
-    }
-
--- returns current directory, where found .git directory
-configInit :: (MonadIO m, MonadThrow m) => m (FilePath, [Syntax C])
-configInit = liftIO do
-  trace "configInit"
-  ConfigPathInfo{..} <- getConfigPathInfo
-  here <- doesDirectoryExist configDir
-  unless here do
-    debug $ "create directory" <+> pretty configDir
-    createDirectoryIfMissing True configDir
-  confHere <- doesFileExist configFilePath
-  unless confHere do
-    appendFile configFilePath ""
-  cfg <- readFile configFilePath <&> parseTop <&> either mempty id
-  pure (configRepoParentDir, cfg)
-
-cookieFile :: (MonadIO m, MonadThrow m) => m FilePath
-cookieFile = configPath "" <&> (</> "cookie")
-
-getAppStateDir :: forall m . MonadIO m => m FilePath
-getAppStateDir = liftIO $ getXdgDirectory XdgData appName
-
-
-makeDbPath :: MonadIO m => RepoRef -> m FilePath
-makeDbPath h = do
-  state <- getAppStateDir
-  liftIO $ createDirectoryIfMissing True state
-  pure $ state </> show (pretty (AsBase58 h))
-

hbs2-git/lib/HBS2Git/Encryption.hs

@@ -1,55 +0,0 @@
-module HBS2Git.Encryption
-  ( module HBS2Git.Encryption
-  , module HBS2Git.Encryption.KeyInfo
-  , module HBS2.Net.Auth.GroupKeySymm
-  ) where
-
-import HBS2Git.Prelude
-
-import HBS2.Net.Auth.Credentials
-import HBS2.Net.Proto.Types hiding (Cookie)
-import HBS2.Net.Auth.GroupKeySymm hiding (Cookie)
-
-
-import HBS2Git.Encryption.KeyInfo
-
-import Data.Config.Suckless.Syntax
-import Data.Config.Suckless.KeyValue
-
-import Data.HashSet qualified as HashSet
-import Data.Maybe
-import Data.Text qualified as Text
-import Data.Time.Clock.POSIX
-
--- type ForEncryption ?
-
-isRefEncrypted :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m Bool
-isRefEncrypted ref = do
-  conf <- getConf
-
-  let ee = [ True
-           | (ListVal (SymbolVal "encrypted" : (LitStrVal r) : _))  <- conf
-           , fromStringMay (Text.unpack r) == Just ref
-           ]
-
-  -- liftIO $ hPutDoc stderr $ "isRefEncrypted" <+> pretty (AsBase58 ref) <+> pretty ee <+> pretty (not (null ee)) <> line
-
-  pure $ not $ null ee
-
-getKeyInfo :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m (Maybe KeyInfo)
-getKeyInfo ref = do
-  conf <- getConf
-
-  now <- liftIO getPOSIXTime
-  let every = [ keyInfoFrom now syn | syn <- conf
-              , isJust (keyInfoFrom now syn)
-              ] & catMaybes
-
-  pure (lastMay [ x | x <- every, keyInfoRef x == ref ])
-
-
-genGK0 :: (MonadIO m) => KeyInfo -> m (GroupKey 'Symm  HBS2Basic)
-genGK0 ki = generateGroupKey @HBS2Basic Nothing members
-  where
-    members = HashSet.toList ( keyInfoOwner ki `HashSet.insert` keyInfoMembers ki )
-

hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs

@@ -1,56 +0,0 @@
-{-# Language UndecidableInstances #-}
-module HBS2Git.Encryption.KeyInfo where
-
-import HBS2.Prelude.Plated
-import HBS2.Hash
-import HBS2.Net.Auth.Credentials
-
-import HBS2.Net.Proto.Types hiding (Cookie)
-
-import Data.Config.Suckless.Syntax
-import Data.Config.Suckless.KeyValue
-
-import Codec.Serialise
-import Data.HashSet
-import Data.HashSet qualified as HashSet
-import Data.Text qualified as Text
-import Data.Time.Clock.POSIX (POSIXTime)
-import Data.Maybe
-
-
-data KeyInfo =
-  KeyInfo
-  { keyInfoNonce   :: Integer
-  , keyInfoRef     :: PubKey 'Sign HBS2Basic
-  , keyInfoOwner   :: PubKey 'Encrypt HBS2Basic
-  , keyInfoMembers :: HashSet (PubKey 'Encrypt HBS2Basic)
-  }
-  deriving (Eq,Ord,Show,Generic)
-
-type ForKeys s = (Serialise (PubKey 'Sign s), Serialise (PubKey 'Encrypt s))
-
-instance ForKeys HBS2Basic => Serialise KeyInfo
-
-instance ForKeys HBS2Basic => Hashed HbSync KeyInfo where
-  hashObject ki = hashObject (serialise ki)
-
-
-keyInfoFrom :: POSIXTime -> Syntax C -> Maybe KeyInfo
-keyInfoFrom t (ListVal (SymbolVal "encrypted" : (LitStrVal r) : args)) =
-  KeyInfo <$> nonce
-          <*> ref
-          <*> owner
-          <*> members
-
-  where
-    nonce = Just $ maybe 0 (round t `div`) ttl
-    ref = fromStringMay  (Text.unpack r)
-    ttl = Just $ lastDef 86400 [ x | ListVal (Key "ttl" [LitIntVal x]) <- args ]
-    owner = fromStringMay =<< lastMay [ Text.unpack o | ListVal (Key "owner" [LitStrVal o]) <- args ]
-    members = Just $ HashSet.fromList
-                   $ catMaybes
-                   [ fromStringMay (Text.unpack o) | ListVal (Key "member" [LitStrVal o]) <- args ]
-
-    -- keypath = lastMay [ Text.unpack p | ListVal @C (Key "keyring" [LitStrVal p]) <- args ]
-
-keyInfoFrom _ _ = Nothing

hbs2-git/lib/HBS2Git/Evolve.hs

@@ -1,108 +0,0 @@
-module HBS2Git.Evolve (evolve,makePolled) where
-
-import HBS2.Prelude.Plated
-import HBS2.System.Logger.Simple
-import HBS2.Net.Proto.Service
-
-import HBS2.Peer.RPC.API.Peer
-
-import HBS2Git.Types
-import HBS2Git.Config
-import HBS2Git.PrettyStuff
-
-import Control.Monad.Trans.Maybe
-import Control.Monad.Catch (MonadThrow(..))
-import Data.List qualified as List
-import System.Directory
-import System.Random
-import System.FilePath
-import UnliftIO
-
--- NOTE: hbs2-git-evolve
---   выполняет идемпотентные миграции между старыми и
---   новыми версиями.
---   например, переносит конфиг
-
-evolve :: (MonadIO m, MonadThrow m) => m ()
-evolve = void $ runMaybeT do
-
-  here   <- liftIO getCurrentDirectory
-
-  debug $ "evolve: current directory:" <+> pretty here
-
-  cfg <- configPath ""
-
-  debug $ "*** GIT DIRECTORY" <+> pretty cfg
-
-  migrateConfig
-  generateCookie
-
-
-makePolled :: (MonadIO m, HasRPC m) => RepoRef -> m ()
-makePolled ref = do
-  rpc <- getRPC <&> rpcPeer
-  n <- liftIO $ randomRIO (4,7)
-  void $ callService @RpcPollAdd rpc (fromRefLogKey ref, "reflog", n)
-
-generateCookie :: (MonadIO m, MonadThrow m) => m ()
-generateCookie = void $ runMaybeT do
-  file <- cookieFile
-
-  guard =<< liftIO (not <$> doesFileExist file)
-
-  -- NOTE: cookie-note
-  --  поскольку куки должна быть уникальна в рамках БД,
-  --  а тут мы пока не знаем, с какой БД мы работаем,
-  --  то отложим генерацию куки до создания БД.
-  --  В скором времени БД будет одна, но пока это не так
-  liftIO $ writeFile file ""
-
-
-migrateConfig :: (MonadIO m, MonadThrow m) => m ()
-migrateConfig = void $ runMaybeT do
-  here   <- liftIO getCurrentDirectory
-
-  rootDir <- configPath "" <&> takeDirectory
-
-  oldPath <- configPathOld here
-  let oldConf = oldPath </> "config"
-
-  let newConfDir = rootDir </> ".hbs2"
-  let newConfFile = newConfDir </> "config"
-
-  guard =<< liftIO (not <$> doesFileExist newConfFile)
-
-  trace $ "EVOLVE: root directory" <+> pretty newConfDir
-
-  confFileHere <- liftIO $ doesFileExist newConfFile
-
-  guard (not confFileHere)
-
-  liftIO do
-    hPutDoc stderr $ red "evolve: creating new config" <+> pretty newConfFile <> line
-    createDirectoryIfMissing True newConfDir
-
-    appendFile newConfFile ""
-
-    oldHere <- doesFileExist oldConf
-
-    when oldHere do
-      hPutDoc stderr $ red "evolve: moving config to" <+> pretty newConfFile <> line
-      liftIO $ renameFile oldConf newConfFile
-
-      anything <- liftIO $ listDirectory oldPath
-
-      if List.null anything then do
-        hPutDoc stderr $ red "evolve: removing"
-                          <+> pretty oldPath <> line
-
-        removeDirectory oldPath
-      else do
-        hPutDoc stderr $ red "evolve: not empty" <+> pretty oldPath <> line
-
-        hPutDoc stderr $ yellow "evolve: remove"
-                            <+> pretty oldPath
-                            <+> yellow "on your own"
-                            <> line
-
-

hbs2-git/lib/HBS2Git/Export.hs

@@ -1,540 +0,0 @@
-{-# Language AllowAmbiguousTypes #-}
-{-# Language RankNTypes #-}
-{-# Language TemplateHaskell #-}
-module HBS2Git.Export
-  ( exportRefDeleted
-  , exportRefOnly
-  , runExport
-  , runExport'
-  , ExportRepoOps
-  ) where
-
-import HBS2.Prelude.Plated
-import HBS2.Data.Types.Refs
-import HBS2.OrDie
-import HBS2.System.Logger.Simple
-import HBS2.Base58
-import HBS2.Peer.Proto
-
-import HBS2.Git.Local
-import HBS2.Git.Local.CLI
-
-import HBS2Git.App
-import HBS2Git.State
-import HBS2Git.Config
-import HBS2Git.KeysMetaData
-import HBS2Git.GitRepoLog
-import HBS2Git.PrettyStuff
-
-import Control.Applicative
-import Control.Monad.Catch
-import Control.Monad.Reader
-import Control.Concurrent.STM
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.HashMap.Strict qualified as HashMap
-import Data.HashSet qualified as HashSet
-import Data.HashSet (HashSet)
-import Data.Maybe
-import Data.Set qualified as Set
-import Data.Map qualified as Map
-import Data.List qualified as List
-import Lens.Micro.Platform
-import Prettyprinter.Render.Terminal
-import System.Directory
-import System.FilePath
-import Text.InterpolatedString.Perl6 (qc)
-import UnliftIO.IO
-import System.IO hiding (hClose,hPrint,hPutStrLn,hFlush)
-import System.IO.Temp
-import Control.Monad.Trans.Resource
-import Data.List.Split (chunksOf)
-import Codec.Compression.GZip
-import Control.Monad.Trans.Maybe
-
-class ExportRepoOps a where
-
-instance ExportRepoOps ()
-
-data ExportEnv =
-  ExportEnv
-  { _exportDB          :: DBEnv
-  , _exportWritten     :: TVar (HashSet GitHash)
-  , _exportFileName    :: FilePath
-  , _exportDir         :: FilePath
-  , _exportRepo        :: RepoRef
-  , _exportReadObject  :: GitHash -> IO (Maybe GitObject)
-  }
-
-makeLenses 'ExportEnv
-
-
-exportRefDeleted :: forall  o m . ( MonadIO m
-                                  , MonadCatch m
-                                  , MonadMask m
-                                  , MonadUnliftIO m
-                                  , HasConf m
-                                  , HasRefCredentials m
-                                  , HasEncryptionKeys m
-                                  , HasProgress m
-                                  , HasStorage m
-                                  , HasRPC m
-                                  , ExportRepoOps o
-                                  )
-              => o
-              -> RepoRef
-              -> GitRef
-              -> m HashRef
-exportRefDeleted _ repo ref = do
-  trace $ "exportRefDeleted" <+> pretty repo <+> pretty ref
-
-  dbPath <- makeDbPath repo
-  db <- dbEnv dbPath
-
-  let opts = ()
-
-  -- это "ненормальный" лог, т.е удаление ссылки в текущем контексте
-  --  мы удаляем ссылку "там", то есть нам нужно "то" значение ссылки
-  --  удалить её локально мы можем и так, просто гитом.
-  --  NOTE: empty-log-post
-  --    мы тут  постим пустой лог (не содержащий коммитов)
-  --    нам нужно будет найти его позицию относитеьлно прочих логов.
-  --    его контекст = текущее значение ссылки, которое мы удаляем
-  --    но вот если мы удаляем уже удаленную ссылку, то для ссылки 00..0
-  --    будет ошибка где-то.
-
-  vals <- withDB db $ stateGetLastKnownCommits 10
-  let (ctxHead, ctxBs) = makeContextEntry vals
-
-  trace $ "DELETING REF CONTEXT" <+> pretty vals
-
-  let repoHead = RepoHead Nothing (HashMap.fromList [(ref,"0000000000000000000000000000000000000000")])
-  let repoHeadStr =  (LBS.pack . show . pretty . AsGitRefsFile) repoHead
-  let ha = gitHashObject (GitObject Blob repoHeadStr)
-  let headEntry = GitLogEntry GitLogEntryHead (Just ha) ( fromIntegral $ LBS.length repoHeadStr )
-
-  r <- fromMaybe 0 <$> runMaybeT do
-          h <- MaybeT $ readRef repo
-          calcRank h
-
-  let rankBs = serialise (GitLogContextRank r)
-  let rank = GitLogEntry GitLogContext Nothing (fromIntegral $ LBS.length rankBs)
-
-  let content  =  gitRepoLogMakeEntry opts ctxHead ctxBs
-                   <> gitRepoLogMakeEntry opts headEntry repoHeadStr
-                   <> gitRepoLogMakeEntry opts rank rankBs
-
-  -- FIXME: remove-code-dup
-  let meta = fromString $ show
-                          $    "hbs2-git" <> line
-                            <> "type:" <+> "hbs2-git-push-log"
-                            <> line
-
-  updateGK0  repo
-
-  logMerkle <- storeObject repo meta content `orDie` [qc|Can't store push log|]
-  postRefUpdate repo 0 logMerkle
-  pure logMerkle
-
-makeContextEntry :: [GitHash] -> (GitLogEntry, LBS.ByteString)
-makeContextEntry  hashes = (entryHead, payload)
-  where
-    ha = Nothing
-    payload = GitLogContextCommits (HashSet.fromList hashes) & serialise
-    entryHead = GitLogEntry GitLogContext ha undefined
-
-
-newtype ExportT m a = ExportT { fromExportT :: ReaderT ExportEnv m a }
-                      deriving newtype ( Functor
-                                       , Applicative
-                                       , Monad
-                                       , MonadIO
-                                       , MonadTrans
-                                       , MonadReader ExportEnv
-                                       , MonadMask
-                                       , MonadCatch
-                                       , MonadThrow
-                                       )
-
-instance (Monad m, HasStorage m) => HasStorage (ExportT m) where
-  getStorage = lift getStorage
-
-instance (Monad m, HasConf m) => HasConf (ExportT m) where
-  getConf = lift getConf
-
-instance (Monad m, HasRPC m) => HasRPC (ExportT m) where
-  getRPC = lift getRPC
-
-instance (Monad m, HasEncryptionKeys m) => HasEncryptionKeys (ExportT m) where
-  addEncryptionKey = lift . addEncryptionKey
-  findEncryptionKey k  = lift $ findEncryptionKey k
-  enumEncryptionKeys = lift enumEncryptionKeys
-
-withExportEnv :: MonadIO m => ExportEnv -> ExportT m a -> m a
-withExportEnv env f = runReaderT (fromExportT f) env
-
-writeLogSegments :: forall m . ( MonadIO m
-                               , HasStorage m
-                               , HasRPC m
-                               , MonadMask m
-                               , HasRefCredentials m
-                               , HasEncryptionKeys m
-                               , HasConf m
-                               )
-                 => ( Int -> m () )
-                 -> RepoRef
-                 -> GitHash
-                 -> [GitHash]
-                 -> Int
-                 -> [(GitLogEntry, LBS.ByteString)]
-                 -> ExportT m [HashRef]
-
-writeLogSegments onProgress repo val objs chunkSize trailing = do
-
-  db          <- asks $ view exportDB
-  written     <- asks $ view exportWritten
-  fname       <- asks $ view exportFileName
-  dir         <- asks $ view exportDir
-  remote      <- asks $ view exportRepo
-  readGit     <- asks $ view exportReadObject
-
-  let opts = CompressWholeLog
-
-  -- TODO: options-for-compression-level
-  --   помним, что всё иммутабельное. как один раз запостим,
-  --   такое и будет жить всегда
-  let compressOpts = defaultCompressParams { compressLevel = bestSpeed }
-
-  rank <- fromMaybe 0 <$> runMaybeT do
-            h <- MaybeT $ readRef remote
-            calcRank h <&> fromIntegral
-
-  -- FIXME: fix-code-dup
-  let meta = fromString $ show
-                        $     "hbs2-git"
-                           <> line
-                           <> "type:"    <+> "hbs2-git-push-log"
-                           <> line
-                           <> "flags:"   <+> "gz:sgmt"
-                           <> line
-
-  let segments = chunksOf chunkSize objs
-  let totalSegments = length segments
-
-  -- TODO: no-sense-in-temp-files
-  --   временные файлы больше не имеют смысла, т.к мы
-  --   1) нарезаем на небольшие сегменты
-  --   2) всё равно их читаем обратно в память, что бы сжать gzip
-  --   нужно удалить, будет работать чуть быстрее
-
-  r <- forM (zip segments [1..]) $ \(segment, segmentIndex) -> do
-    let fpath = dir </> fname <> "_" <> show segmentIndex
-    bracket (liftIO $ openBinaryFile fpath AppendMode)
-            (const $ pure ()) $ \fh -> do
-      for_ segment $ \d -> do
-        here <- liftIO $ readTVarIO written <&> HashSet.member d
-        inState <- withDB db (stateIsLogObjectExists d)
-
-        lift $ onProgress 1
-
-        unless (here || inState) do
-
-          GitObject tp o  <- liftIO $ readGit d `orDie` [qc|error reading object {pretty d}|]
-
-          let entry = GitLogEntry ( gitLogEntryTypeOf tp ) (Just d) ( fromIntegral $ LBS.length o )
-          gitRepoLogWriteEntry opts fh entry o
-          liftIO $ atomically $ modifyTVar written (HashSet.insert d)
-
-          -- gitRepoLogWriteEntry fh ctx ctxBs
-
-          trace $ "writing" <+> pretty tp <+> pretty d
-
-      when (segmentIndex == totalSegments) $ do
-        for_ trailing $ \(e, bs) -> do
-          gitRepoLogWriteEntry opts fh e bs
-
-      -- finalize log section
-      hClose fh
-
-      content   <- liftIO $ LBS.readFile fpath
-
-      let gzipped = compressWith compressOpts content
-
-      -- let nonce = hashObject @HbSync (serialise segments)
-      logMerkle <- lift $ storeObject repo meta gzipped `orDie` [qc|Can't store push log|]
-
-      trace $ "PUSH LOG HASH: " <+> pretty logMerkle
-      trace $ "POSTING REFERENCE UPDATE TRANSACTION" <+> pretty remote <+> pretty logMerkle
-
-      lift $ postRefUpdate remote rank logMerkle
-
-      pure logMerkle
-
-
-  if not (null r) then do
-    pure r
-  else do
-    let content = foldMap (uncurry (gitRepoLogMakeEntry opts)) trailing
-                   & compressWith compressOpts
-
-    logMerkle <- lift $ storeObject repo meta content `orDie` [qc|Can't store push log|]
-
-    lift $ postRefUpdate remote rank logMerkle
-
-    pure [logMerkle]
-
--- | Exports only one ref to the repo.
---   Corresponds to a single ```git push``` operation
-exportRefOnly :: forall  o m . ( MonadIO m
-                               , MonadCatch m
-                               , MonadMask m
-                               , MonadUnliftIO m
-                               , HasConf m
-                               , HasRefCredentials m
-                               , HasEncryptionKeys m
-                               , HasProgress m
-                               , HasStorage m
-                               , HasRPC m
-                               , ExportRepoOps o
-                               )
-              => o
-              -> RepoRef
-              -> Maybe GitRef
-              -> GitRef
-              -> GitHash
-              -> m (Maybe HashRef)
-
-exportRefOnly _ remote rfrom ref val = do
-
-  let repoHead = RepoHead Nothing (HashMap.fromList [(ref,val)])
-
-  let repoHeadStr =  (LBS.pack . show . pretty . AsGitRefsFile) repoHead
-
-  dbPath <- makeDbPath remote
-  db <- dbEnv dbPath
-
-  r <- fromMaybe 0 <$> runMaybeT do
-          h <- MaybeT $ readRef remote
-          calcRank h
-
-  updateGK0 remote
-
-  trace $ "exportRefOnly" <+> pretty remote <+> pretty ref <+> pretty val
-
-  -- 1. get max ref value for known REMOTE branch
-  -- 2. if unkwnown - get max branch ref value for known LOCAL branch (known from the state)
-  -- 3. if unkwnown - then Nothing
-  -- therefore, we export only the delta for the objects for push between known state and current
-  -- git repot state
-  -- if it's a new branch push without any objects commited -- then empty log
-  -- only with HEAD section should be created
-  lastKnownRev <- withDB db do
-                    rThat <- stateGetActualRefValue  ref
-                    rThis <- maybe1 rfrom (pure Nothing) stateGetActualRefValue
-                    pure $ rThat  <|> rThis
-
-  trace $ "LAST_KNOWN_REV" <+> braces (pretty rfrom) <+> braces (pretty ref) <+> braces (pretty lastKnownRev)
-
-  entries <- traceTime "gitRevList" $ gitRevList lastKnownRev val
-
-  let entryNum = length entries
-
-  -- NOTE: just-for-test-new-non-empty-push-to-another-branch-112
-
-  -- FIXME: may-blow-on-huge-repo-export
-  types <- traceTime "gitGetObjectTypeMany" $ gitGetObjectTypeMany entries <&> Map.fromList
-
-  let lookupType t = Map.lookup t types
-
-  let onEntryType e = (fx $ lookupType e, e)
-         where fx = \case
-                 Just Blob   -> 0
-                 Just Tree   -> 1
-                 Just Commit -> 2
-                 Nothing     -> 3
-
-  trace $ "ENTRIES:" <+> pretty (length entries)
-
-  trace "MAKING OBJECTS LOG"
-
-  let fname = [qc|{pretty val}.data|]
-
-  -- TODO: investigate-on-signal-behaviour
-  --   похоже, что в случае прилёта сигнала он тут не обрабатывается,
-  --   и временный каталог остаётся
-  runResourceT $ do
-
-    gitCatFile <- startGitCatFile
-
-    written <- liftIO $ newTVarIO (HashSet.empty :: HashSet GitHash)
-
-    let myTempDir = "hbs-git"
-    temp <- liftIO getCanonicalTemporaryDirectory
-
-    (_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
-
-    let (blobs, notBlobs) = List.partition (\e -> fst (onEntryType e) == 0) entries
-    let (trees, notTrees) = List.partition (\e -> fst (onEntryType e) == 1) notBlobs
-    -- FIXME: others-might-be-tags
-    let (commits, others) = List.partition (\e -> fst (onEntryType e) == 2) notTrees
-
-    -- FIXME: hbs2-git-size-hardcode-to-args
-    let batch = 20000
-    let objects = blobs <> trees <> others <> commits
-    mon <- newProgressMonitor "write objects"   (length objects)
-
-    let env = ExportEnv
-              { _exportDB = db
-              , _exportWritten = written
-              , _exportFileName = fname
-              , _exportDir = dir
-              , _exportRepo = remote
-              , _exportReadObject = gitReadFromCatFileBatch gitCatFile
-              }
-
-
-    let ha = gitHashObject (GitObject Blob repoHeadStr)
-    let headEntry = GitLogEntry GitLogEntryHead (Just ha) ( fromIntegral $ LBS.length repoHeadStr )
-
-    let upd = updateProgress mon
-
-    vals <- withDB db $ stateGetLastKnownCommits 10
-    let (ctx, ctxBs) = makeContextEntry (List.nub $ val:vals)
-
-    let rankBs = serialise (GitLogContextRank r)
-    let rank = GitLogEntry GitLogContext Nothing (fromIntegral $ LBS.length rankBs)
-
-    -- we need context entries to determine log HEAD operation sequence
-    -- so only the last section needs it alongwith headEntry
-    logz  <- lift $ withExportEnv env (writeLogSegments upd remote val objects batch [ (ctx, ctxBs)
-                                                                                     , (rank, rankBs)
-                                                                                     , (headEntry, repoHeadStr)
-                                                                                     ])
-
-    -- NOTE: отдаём только последнюю секцию лога,
-    --       что бы оставить совместимость
-    pure $ lastMay logz
-
----
-
-
-
-runExport :: forall m . ( MonadIO m
-                        , MonadUnliftIO m
-                        , MonadCatch m
-                        , HasProgress (App m)
-                        , MonadMask (App m)
-                        , HasStorage (App m)
-                        , HasRPC (App m)
-                        , HasEncryptionKeys (App m)
-                        )
-
-          => Maybe FilePath -> RepoRef -> App m ()
-runExport mfp repo = do
-    loadCredentials (maybeToList mfp)
-    loadKeys
-    let krf = fromMaybe "keyring-file" mfp & takeFileName
-    runExport'' krf repo
-
----
-
-runExport' :: forall m . ( MonadIO m
-                        , MonadUnliftIO m
-                        , MonadCatch m
-                        , HasProgress (App m)
-                        , MonadMask (App m)
-                        , HasStorage (App m)
-                        , HasRPC (App m)
-                        , HasEncryptionKeys (App m)
-                        )
-
-          => FilePath -> App m ()
-
-runExport' fp = do
-    repo <- loadCredentials' fp
-    loadKeys
-    runExport'' (takeFileName fp) (RefLogKey repo)
-
----
-
-runExport'' :: forall m . ( MonadIO m
-                        , MonadUnliftIO m
-                        , MonadCatch m
-                        , HasProgress (App m)
-                        , MonadMask (App m)
-                        , HasStorage (App m)
-                        , HasRPC (App m)
-                        )
-
-          => FilePath -> RepoRef -> App m ()
-runExport'' krf repo = do
-
-  liftIO $ putDoc $
-       line
-    <> green "Exporting to reflog" <+> pretty (AsBase58 repo)
-    <> section
-    <> "it may take some time on the first run"
-    <> section
-
-  git <- asks (view appGitDir)
-
-  trace $ "git directory is" <+> pretty git
-
-  -- FIXME: wtf-runExport
-  branchesGr <- cfgValue @ConfBranch <&> Set.map normalizeRef
-
-  headBranch <- gitGetBranchHEAD `orDie` "undefined HEAD for repo"
-
-  refs <- gitListLocalBranches
-             <&> filter (\x -> Set.null branchesGr ||  Set.member (fst x) branchesGr)
-
-  trace $ "REFS" <+> pretty refs
-
-  fullHead <- gitHeadFullName headBranch
-
-  -- debug $ "HEAD" <+> pretty fullHead
-
-  -- let repoHead = RepoHead (Just fullHead)
-  --                         (HashMap.fromList refs)
-
-  -- trace $ "NEW REPO HEAD" <+> pretty (AsGitRefsFile repoHead)
-
-  val <- gitGetHash fullHead `orDie` [qc|Can't resolve ref {pretty fullHead}|]
-
-   -- _ <- exportRefOnly () remote br gh
-  hhh <- exportRefOnly () repo Nothing fullHead val
-
-  -- NOTE: ???
-  -- traceTime "importRefLogNew (export)" $ importRefLogNew False repo
-
-  shutUp
-
-  cwd <- liftIO getCurrentDirectory
-  cfgPath <- configPath cwd
-
-  liftIO $ putStrLn ""
-  liftIO $ putDoc $
-    "exported" <+> pretty hhh
-    <> section
-    <> green "Repository config:" <+> pretty (cfgPath </> "config")
-    <> section
-    <>  "Put the keyring file" <+> yellow (pretty krf) <+> "into a safe place," <> line
-    <> "like encrypted directory or volume."
-    <> section
-    <> "You will need this keyring to push into the repository."
-    <> section
-    <> green "Add keyring into the repo's config:"
-    <> section
-    <> "keyring" <+> pretty [qc|"/my/safe/place/{krf}"|]
-    <> section
-    <> green "Add git remote:"
-    <> section
-    <> pretty [qc|git remote add remotename hbs2://{pretty repo}|]
-    <> section
-    <> green "Work with git as usual:"
-    <> section
-    <> "git pull remotename" <> line
-    <> "(or git fetch remotename && git reset --hard remotename/branch)" <> line
-    <> "git push remotename" <> line
-    <> line
-
-

hbs2-git/lib/HBS2Git/GitRepoLog.hs

@@ -1,211 +0,0 @@
-{-# Language TemplateHaskell #-}
-module HBS2Git.GitRepoLog where
-
-import HBS2.Prelude.Plated
-import HBS2.Git.Types
-import HBS2.Data.Types.Refs
-
-import HBS2.System.Logger.Simple
-
-import Data.Word
-import Data.Function
-import Lens.Micro.Platform
-import Codec.Serialise
-import Data.ByteString.Lazy qualified as LBS
-import Data.ByteString.Lazy (ByteString)
--- import System.IO
-import UnliftIO.IO
-import Control.Monad.IO.Unlift
-import Codec.Compression.GZip
-import System.Directory
-import Data.HashSet (HashSet)
-import Data.HashSet qualified as HashSet
-import Control.Concurrent.STM
-import Data.Maybe
-
-class HasGitLogOptions a where
-  compressEntries  :: a -> Bool
-  compressWholeLog :: a -> Bool
-
-
--- | default GitLogOptions
-instance HasGitLogOptions () where
-  compressEntries = const True
-  compressWholeLog = const False
-
-data CompressWholeLog = CompressWholeLog
-
-instance HasGitLogOptions CompressWholeLog where
-  compressEntries = const False
-  compressWholeLog = const True
-
-data GitLogEntryType = GitLogEntryCommit
-                     | GitLogEntryBlob
-                     | GitLogEntryTree
-                     | GitLogEntryHead
-                     | GitLogHead
-                     | GitLogDeps
-                     | GitLogHeadDel
-                     | GitLogContext
-                     deriving stock (Eq,Ord,Enum,Generic,Show)
-
-
-newtype GitLogTimeStamp = GitLogTimeStamp Int
-                          deriving stock (Eq,Ord,Show,Data,Generic)
-
-instance Serialise GitLogTimeStamp
-
-newtype GitLogHeadEntry =
-  GitLogHeadEntry
-  { _gitLogHeadAfter :: Maybe HashRef
-  }
-  deriving stock (Eq,Generic)
-
-instance Serialise GitLogHeadEntry
-
-makeLenses ''GitLogHeadEntry
-
-
-newtype GitLogDepsEntry =
-  GitLogDepsEntry
-  { _gitLogDeps :: [HashRef]
-  }
-  deriving stock (Eq,Generic)
-
-makeLenses ''GitLogDepsEntry
-
-instance Serialise GitLogDepsEntry
-
--- deletion is handled by special way.
--- we need a context WHEN the reference is deleted
--- because it may be deleted, created again, deleted again, etc.
--- Having current repository context via collecting all reference states
--- we may calculate an actual current state of the reference.
--- Or, we may use a special code to mark object as deleted
-data GitLogHeadDelEntry =
-  GitLogHeadDelEntry
-  { _gitHeadContext :: [(GitRef, GitHash)] -- this gives us context to order this delete operation
-  , _gitHeadDeleted :: GitRef              -- this is a reference to delete
-  }
-  deriving stock (Eq,Generic)
-
-makeLenses ''GitLogHeadDelEntry
-
-instance Serialise GitLogHeadDelEntry
-
-data GitLogContextEntry =
-    GitLogNoContext
-  | GitLogContextCommits (HashSet GitHash)
-  | GitLogContextRank Int
-  deriving stock (Eq,Data,Generic)
-
-commitsOfGitLogContextEntry :: GitLogContextEntry -> [GitHash]
-commitsOfGitLogContextEntry = \case
-  GitLogContextCommits co -> HashSet.toList co
-  _ -> mempty
-
-instance Serialise GitLogContextEntry
-
-data GitLogEntry =
-  GitLogEntry
-  { _gitLogEntryType :: GitLogEntryType
-  , _gitLogEntryHash :: Maybe GitHash
-  , _gitLogEntrySize :: Word32
-  }
-  deriving stock (Eq,Ord,Generic,Show)
-
-makeLenses 'GitLogEntry
-
-entryHeadSize :: Integral a => a
-entryHeadSize = 64
-
-instance Serialise GitLogEntryType
-instance Serialise GitLogEntry
-
-gitLogEntryTypeOf :: GitObjectType -> GitLogEntryType
-gitLogEntryTypeOf = \case
-  Commit -> GitLogEntryCommit
-  Tree   -> GitLogEntryTree
-  Blob   -> GitLogEntryBlob
-
--- | scans hbs2-git repo log
-gitRepoLogScan :: forall m . MonadUnliftIO m
-               => Bool         -- ^ do read log section content
-               -> FilePath     -- ^ log file path
-               -> (GitLogEntry -> Maybe ByteString -> m ()) -- ^ log section callback
-               -> m ()
-
-gitRepoLogScan r fn cb = do
-
-  trace $ "gitRepoLogScan" <+> pretty fn
-  withBinaryFile fn ReadMode $ \h -> do
-    sz <- liftIO $ getFileSize fn
-    go h sz
-
-  where
-    go _ 0 = pure ()
-    go h size = do
-      ss <- liftIO $ LBS.hGet h entryHeadSize
-      let es = deserialise @GitLogEntry ss
-      let esize = es ^. gitLogEntrySize
-      let consumed = entryHeadSize + fromIntegral esize
-      if r then do
-        o <- liftIO $ LBS.hGet h (fromIntegral esize) <&> decompress
-        cb es (Just o)
-      else do
-        liftIO $ hSeek h RelativeSeek (fromIntegral esize)
-        cb es Nothing
-      go h ( max 0 (size - consumed) )
-
-gitRepoLogWriteHead :: forall o m . (HasGitLogOptions o, MonadIO m)
-                    => o
-                    -> Handle
-                    -> GitLogHeadEntry
-                    -> m ()
-
-gitRepoLogWriteHead opt fh e = do
-  let s = serialise e
-  let entry = GitLogEntry GitLogHead Nothing (fromIntegral $ LBS.length s)
-  gitRepoLogWriteEntry opt fh entry s
-
-
-
-gitRepoLogMakeEntry :: forall o . (HasGitLogOptions o)
-                    => o
-                    -> GitLogEntry
-                    -> ByteString
-                    -> ByteString
-
-gitRepoLogMakeEntry opts entry' o = bs <> ss
-  where
-    ss = compressWith co o
-    entry = entry' & set gitLogEntrySize (fromIntegral $ LBS.length ss)
-    bs = LBS.take entryHeadSize $ serialise entry <> LBS.replicate entryHeadSize 0
-    co | compressEntries opts = defaultCompressParams { compressLevel = bestSpeed }
-       | otherwise            = defaultCompressParams { compressLevel = noCompression }
-
-gitRepoLogWriteEntry :: forall o m . (MonadIO m, HasGitLogOptions o)
-                     => o
-                     -> Handle
-                     -> GitLogEntry
-                     -> ByteString
-                     -> m ()
-
-gitRepoLogWriteEntry opts fh entry' o = do
-  let entryWithSize = gitRepoLogMakeEntry opts entry' o
-  liftIO $ LBS.hPutStr fh entryWithSize
-
-gitRepoMakeIndex :: FilePath -> IO (HashSet GitHash)
-gitRepoMakeIndex fp = do
-  here <- doesFileExist fp
-  if not here then do
-    pure mempty
-  else do
-    out <- newTQueueIO
-
-    gitRepoLogScan  False fp $ \e _ -> do
-      atomically $ writeTQueue out ( e ^. gitLogEntryHash )
-
-    atomically $ flushTQueue out <&> HashSet.fromList . catMaybes
-
-

hbs2-git/lib/HBS2Git/Import.hs

@@ -1,409 +0,0 @@
-{-# Language TemplateHaskell #-}
-module HBS2Git.Import where
-
-import HBS2.Prelude.Plated
-import HBS2.Data.Types.Refs
-import HBS2.OrDie
-import HBS2.System.Logger.Simple
-import HBS2.Merkle
-import HBS2.Hash
-import HBS2.Storage
-import HBS2.Storage.Operations.Class
-import HBS2.Storage.Operations.Missed
-import HBS2.Storage.Operations.ByteString(TreeKey(..))
-import HBS2.Net.Auth.GroupKeySymm
-import HBS2.Peer.Proto
-import Text.InterpolatedString.Perl6 (qc)
-import HBS2.Data.Detect hiding (Blob)
-
-import HBS2.Git.Local
-import HBS2Git.GitRepoLog
-import HBS2Git.App
-import HBS2Git.Config
-import HBS2Git.State
-import HBS2Git.Evolve
-import HBS2Git.KeysMetaData
-import HBS2.Git.Local.CLI
-
-import Data.Fixed
-import Control.Monad.Trans.Maybe
-import Control.Concurrent.STM
-import Control.Concurrent.STM.TQueue qualified as Q
-import Control.Monad.Reader
-import Data.Maybe
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Lens.Micro.Platform
-import Data.Set qualified as Set
-import Codec.Serialise
-import Control.Monad.Except (runExceptT)
-import Control.Monad.Catch
-import Control.Monad.Trans.Resource
-import System.Directory
-import System.IO.Temp
-import UnliftIO.IO
-import System.IO (openBinaryFile)
-import System.FilePath.Posix
-import Data.HashMap.Strict qualified as HashMap
-import Data.Text qualified as Text
-import Data.Either
-
-import Streaming.Prelude qualified as S
-import Streaming.ByteString qualified as SB
-import Streaming.Zip qualified as SZip
-
-import HBS2Git.PrettyStuff
-
-data RunImportOpts =
-  RunImportOpts
-  { _runImportDry    :: Maybe Bool
-  , _runImportRefVal :: Maybe HashRef
-  }
-
-makeLenses 'RunImportOpts
-
-isRunImportDry :: RunImportOpts -> Bool
-isRunImportDry o = view runImportDry o == Just True
-
-
-
-walkHashes :: (MonadIO m, HasStorage m) => TQueue HashRef -> Hash HbSync -> m ()
-walkHashes q h = walkMerkle h (readBlock . HashRef) $ \(hr :: Either (Hash HbSync) [HashRef]) -> do
-  case hr of
-    Left hx -> die $ show $ pretty "missed block:" <+> pretty hx
-    Right (hrr :: [HashRef]) -> do
-       forM_ hrr $ \hx -> do
-        liftIO $ atomically $ Q.writeTQueue q hx
-
-blockSource :: (MonadIO m, HasStorage m) => HashRef -> SB.ByteStream m Integer
-blockSource h = do
-  tsize <- liftIO $ newTVarIO 0
-  deepScan ScanDeep (const none) (fromHashRef h) (lift . readBlock . HashRef) $ \ha -> do
-    sec <- lift $ readBlock (HashRef ha) `orDie` [qc|missed block {pretty ha}|]
-    -- skip merkle tree head block, write only the data
-    liftIO $ atomically $ modifyTVar tsize (+ LBS.length sec)
-    when (h /= HashRef ha) do
-      SB.fromLazy sec
-
-  liftIO $ readTVarIO tsize <&> fromIntegral
-
-getLogFlags :: MonadIO m
-            => (HashRef -> m (Maybe LBS.ByteString))
-            -> HashRef
-            -> m (Maybe [Text])
-
-getLogFlags doRead h = do
-
-  runMaybeT do
-
-    treeBs   <- MaybeT $ doRead h
-
-    let something =  tryDetect (fromHashRef h) treeBs
-    let meta = mconcat $ rights [ parseTop (Text.unpack s) | ShortMetadata s <- universeBi something ]
-
-    -- TODO: check-if-it-is-hbs2-git-log
-    let tp = lastMay [ "hbs2-git-push-log"
-                     | (ListVal (Key "type:" [SymbolVal "hbs2-git-push-log"]) ) <- meta
-                     ]
-
-    guard ( tp == Just "hbs2-git-push-log" )
-
-    pure $ mconcat [ Text.splitOn ":" (Text.pack (show $ pretty s))
-                   | (ListVal (Key "flags:" [SymbolVal s]) ) <- meta
-                   ]
-
-class HasImportOpts a where
-  importForce :: a -> Bool
-  importDontWriteGit :: a -> Bool
-
-instance HasImportOpts Bool where
-  importForce f = f
-  importDontWriteGit = const False
-
-instance HasImportOpts (Bool, Bool) where
-  importForce = fst
-  importDontWriteGit = snd
-
-importRefLogNew :: ( MonadIO m
-                   , MonadUnliftIO m
-                   , MonadCatch m
-                   , MonadMask m
-                   , HasStorage m
-                   , HasRPC m
-                   , HasEncryptionKeys m
-                   , HasImportOpts opts
-                   )
-                => opts -> RepoRef -> m ()
-
-importRefLogNew opts ref = runResourceT do
-
-  let force = importForce opts
-
-  sto <- getStorage
-
-  let myTempDir = "hbs-git"
-  temp <- liftIO getTemporaryDirectory
-
-  (_,dir) <- allocate (createTempDirectory temp myTempDir) removeDirectoryRecursive
-
-  lift $ makePolled ref
-
-  db <- makeDbPath ref >>= dbEnv
-
-  void $ runMaybeT do
-    trace $ "importRefLogNew" <+> pretty ref
-    logRoot <- toMPlus =<< readRef ref
-    trace $ "ROOT" <+> pretty logRoot
-
-    trans <- withDB db $ stateGetAllTranImported <&> Set.fromList
-    done <- withDB db $ stateGetRefImported logRoot
-
-    when (not done || force) do
-
-      logQ <- liftIO newTQueueIO
-
-      lift $ walkHashes logQ (fromHashRef logRoot)
-
-      let notSkip n = force || not (Set.member n trans)
-
-      entries' <- liftIO $ atomically $ flushTQueue logQ <&> filter notSkip
-
-      pMiss <- newProgressMonitor [qc|scan for missed blocks|]  (length entries')
-
-      -- TODO: might-be-slow
-      entries <- S.toList_ $ forM_ entries' $ \e -> do
-                    updateProgress pMiss 1
-                    missed <- lift $ findMissedBlocks sto e
-                    if null missed then do
-                      S.yield e
-                    else do
-                      S.yield e
-                      forM_ missed $ \m -> do
-                        debug $ "missed blocks in tree" <+> pretty e  <+> pretty m
-
-      pCommit <- liftIO $ startGitHashObject Commit
-      pTree <- liftIO $ startGitHashObject Tree
-      pBlob <- liftIO $ startGitHashObject Blob
-
-      let hCommits = getStdin pCommit
-      let hTrees = getStdin pTree
-      let hBlobs = getStdin pBlob
-
-      let handles = [hCommits, hTrees, hBlobs]
-
-      sp0 <- withDB db savepointNew
-      withDB db $ savepointBegin sp0
-
-      decrypt <- lift $ lift enumEncryptionKeys
-
-      debug $ "Decrypt" <> vcat (fmap pretty decrypt)
-
-      pMeta  <- newProgressMonitor [qc|process metadata|]  (length entries)
-
-      forM_ entries $ \e -> runMaybeT do
-        let kDone = serialise ("processmetadata", e)
-
-        updateProgress pMeta 1
-
-        -- guard =<< withDB db (not <$> stateGetProcessed kDone)
-
-        rd <- toMPlus =<< parseTx  e
-        let (SequentialRef _ (AnnotatedHashRef ann' h)) = rd
-        forM_ ann' (withDB db . importKeysAnnotations ref e)
-
-        -- withDB db $ statePutProcessed kDone
-
-      -- TODO: exclude-metadata-transactions
-      forM_ entries $ \e -> do
-
-        missed <- lift $ readBlock e <&> isNothing
-
-        when missed do
-          warn $ "MISSED BLOCK" <+> pretty e
-
-        let fname = show (pretty e)
-        let fpath = dir </> fname
-
-        (keyFh, fh) <- allocate (openBinaryFile fpath AppendMode) hClose
-
-        void $ runMaybeT $ do
-
-          refData <- toMPlus =<< parseTx e
-          -- NOTE: good-place-to-process-hash-log-update-first
-          let (SequentialRef _ (AnnotatedHashRef ann' h)) = refData
-
-          -- forM_ ann' (withDB db . importKeysAnnotations ref e)
-
-          trace $ "PUSH LOG HASH" <+> pretty h
-
-          treeBs   <- MaybeT $ lift $ readBlock h
-
-          let something =  tryDetect (fromHashRef h) treeBs
-          let meta = mconcat $ rights [ parseTop (Text.unpack s) | ShortMetadata s <- universeBi something ]
-
-          -- TODO: check-if-it-is-hbs2-git-log
-
-          let flags = mconcat [ Text.splitOn ":" (Text.pack (show $ pretty s))
-                              | (ListVal (Key "flags:" [SymbolVal s]) ) <- meta
-                              ]
-
-          let gzipped = "gz" `elem` flags
-
-          debug $ "FOUND LOG METADATA " <+> pretty flags
-                                        <+> pretty "gzipped:" <+> pretty gzipped
-
-          here <- withDB db $ stateGetLogImported h
-
-          unless (here && not force) do
-
-            (src, enc) <- case something of
-
-              MerkleAnn ann@(MTreeAnn _ sc@(EncryptGroupNaClSymm g nonce) tree) -> do
-
-                gk10' <- runExceptT $ readFromMerkle sto (SimpleKey g)
-
-                -- FIXME: nicer-error-handling
-                gk10'' <- either (const $ err ("GK0 not found:" <+> pretty g)  >> mzero) pure gk10'
-
-                gk10 <- toMPlus (deserialiseOrFail gk10'')
-
-                gk11 <- withDB db $ stateListGK1 (HashRef g)
-
-                let gk1 = mconcat $ gk10 : gk11
-
-                -- elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS decrypt (fromHashRef h))
-                elbs <- runExceptT $ readFromMerkle sto (ToDecryptBS2 gk1 nonce decrypt ann)
-
-                case elbs of
-                  Left{} -> do
-                    let lock = toStringANSI $ red "x"
-                    hPutStrLn stderr [qc|import [{lock}] {pretty e}|]
-                    mzero
-
-                  Right lbs -> (,True) <$> pure do
-                    SB.fromLazy lbs
-                    pure (fromIntegral (LBS.length lbs))
-
-              -- FIXME: remove-debug
-              MerkleAnn{} -> pure (blockSource h, False)
-
-              _ -> pure (blockSource h, False)
-
-            sz <- if gzipped then do
-              SB.toHandle fh $ SZip.gunzip src
-            else
-              SB.toHandle fh src
-
-            release keyFh
-
-            let fpathReal = fpath
-
-            tnum <- liftIO $ newTVarIO 0
-            liftIO $ gitRepoLogScan True fpathReal $ \_ _ -> do
-              liftIO $ atomically $ modifyTVar tnum succ
-
-            num <- liftIO $ readTVarIO tnum
-            trace $ "LOG ENTRY COUNT" <+> pretty  num
-
-            let lock = toStringANSI $ if enc then yellow "@" else " "
-
-            let pref = take 16 (show (pretty e))
-            let name = [qc|import [{lock}] {pref}... {realToFrac sz / (1024*1024) :: Fixed E3}|]
-
-            oMon  <- newProgressMonitor name  num
-
-            lift $ lift $ gitRepoLogScan True fpathReal $ \entry s -> void $ runMaybeT do
-
-              updateProgress oMon 1
-
-              lbs <- toMPlus s
-
-              withDB db do
-
-                case view gitLogEntryType entry of
-                  GitLogEntryCommit -> do
-                    bss <- lift (pure s) `orDie` [qc|git object not read from log|]
-                    let co = view gitLogEntryHash entry
-                    hx <- pure (view gitLogEntryHash entry) `orDie` [qc|empty git hash|]
-
-                    trace $ "logobject" <+> pretty h <+> "commit" <+> pretty (view gitLogEntryHash entry)
-
-                    writeIfNew hCommits dir hx (GitObject Commit lbs)
-                    statePutLogObject (h, Commit, hx)
-
-                    let parents = gitCommitGetParentsPure bss
-
-                    forM_ parents $ \p -> do
-                      trace $ "fact" <+> "commit-parent" <+> pretty co <+> pretty p
-                      statePutLogCommitParent (hx,p)
-
-                  GitLogEntryBlob   -> do
-                    trace $ "logobject" <+> pretty h <+> "blob" <+> pretty (view gitLogEntryHash entry)
-                    hx <- pure (view gitLogEntryHash entry) `orDie` [qc|empty git hash|]
-                    writeIfNew hBlobs dir hx (GitObject Blob lbs)
-                    statePutLogObject (h, Blob, hx)
-
-                  GitLogEntryTree   -> do
-                    trace $ "logobject" <+> pretty h <+> "tree" <+> pretty (view gitLogEntryHash entry)
-                    hx <- pure (view gitLogEntryHash entry) `orDie` [qc|empty git hash|]
-                    writeIfNew hTrees dir hx (GitObject Tree lbs)
-                    statePutLogObject (h, Tree, hx)
-
-                  GitLogContext -> do
-                    trace $ "logobject" <+> pretty h <+> "context" <+> pretty (view gitLogEntryHash entry)
-
-                    void $ runMaybeT do
-                      ss <- MaybeT $ pure s
-                      logEntry <- MaybeT $ pure $ deserialiseOrFail @GitLogContextEntry ss & either (const Nothing) Just
-
-                      case logEntry of
-                        GitLogContextRank n -> do
-                          lift $ statePutLogContextRank h n
-
-                        GitLogContextCommits co -> do
-                          lift $ forM_ co  (statePutLogContextCommit h)
-
-                        _ -> pure ()
-
-                  GitLogEntryHead   -> do
-                    trace $ "HEAD ENTRY" <+> viaShow s
-                    let mbrh = fromStringMay @RepoHead (maybe mempty LBS.unpack s)
-                    rh <- pure mbrh `orDie` [qc|invalid log header in {pretty h} {s}|]
-
-                    forM_ (HashMap.toList $ view repoHeads rh) $ \(re,ha) -> do
-                      trace $ "logrefval" <+> pretty h <+> pretty re <+> pretty ha
-                      statePutLogRefVal (h,re,ha)
-
-                  _ -> pure ()
-
-                -- otherwise we wan't process those logs next time.
-                unless (importDontWriteGit opts) do
-                  statePutLogImported h
-                  statePutTranImported e
-
-      mapM_ hClose handles
-
-      withDB db $ do
-        stateUpdateCommitDepths
---         statePutRefImported logRoot
-        if (length entries == length entries') then do
-          statePutRefImported logRoot
-        else do
-          warn "Some entries not processed!"
-
-        savepointRelease sp0
-
-  where
-
-    parseTx e = runMaybeT do
-      bs <- MaybeT $ readBlock e
-      refupd <- toMPlus $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) bs
-      toMPlus $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd)
-
-    writeIfNew gitHandle dir h (GitObject tp s) = do
-      unless (importDontWriteGit opts) do
-        let nf = dir </> show (pretty h)
-        liftIO $ LBS.writeFile nf s
-        hPutStrLn gitHandle nf
-        hFlush gitHandle
-        trace $ "WRITTEN OBJECT" <+> pretty tp <+> pretty h <+> pretty nf
-

hbs2-git/lib/HBS2Git/KeysCommand.hs

@@ -1,79 +0,0 @@
-module HBS2Git.KeysCommand
-  ( module HBS2Git.KeysCommand
-  , module HBS2.Net.Proto.Types
-  , CryptoAction(..)
-  ) where
-
-
-import HBS2Git.Prelude
-import HBS2Git.App
-import HBS2Git.Encryption
-
-import HBS2.OrDie
-import HBS2.Net.Proto.Types
-
-import HBS2.System.Logger.Simple
-
-import Data.Time.Clock.POSIX
-import Data.Maybe
-
-
-runKeyRefsList :: (MonadIO m, HasConf m) => m ()
-runKeyRefsList = do
-  conf <- getConf
-
-  now <- liftIO getPOSIXTime
-
-  let every = [ keyInfoRef <$> keyInfoFrom now syn | syn <- conf
-              , isJust (keyInfoFrom now syn)
-              ] & catMaybes
-
-  liftIO $ print $ vcat (fmap (pretty . AsBase58) every)
-
-
-
-runKeysUpdate :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m ()
-runKeysUpdate ref = do
-  conf <- getConf
-
-  -- TODO: generate-GK0
-  --  generate basic key for OWNER only
-
-  now <- liftIO getPOSIXTime
-  let every = [ keyInfoFrom now syn | syn <- conf
-              , isJust (keyInfoFrom now syn)
-              ] & catMaybes
-
-  this <- pure (lastMay [ x | x <- every, keyInfoRef x == ref ])
-            `orDie` "Not found encrypted section for given ref"
-
-  gk0 <- generateGroupKey @HBS2Basic Nothing [keyInfoOwner this]
-
-  pure ()
-
-  -- now <- liftIO getPOSIXTime
-
-  -- let every = [ keyInfoFrom now syn | syn <- conf
-  --             , isJust (keyInfoFrom now syn)
-  --             ] & catMaybes
-
-  -- let keys = [ x | x <- every, keyInfoRef x == ref ]
-
-  -- info $ viaShow keys
-
-
-runKeysList :: (MonadIO m, HasConf m) => PubKey 'Sign HBS2Basic -> m ()
-runKeysList ref = do
-  conf <- getConf
-
-  now <- liftIO getPOSIXTime
-
-  let every = [ keyInfoFrom now syn | syn <- conf
-              , isJust (keyInfoFrom now syn)
-              ] & catMaybes
-
-  let keys = [ x | x <- every, keyInfoRef x == ref ]
-
-  info $ viaShow keys
-
-

hbs2-git/lib/HBS2Git/KeysMetaData.hs

@@ -1,258 +0,0 @@
-module HBS2Git.KeysMetaData where
-
-
-import HBS2Git.Prelude
-import HBS2Git.Types
-import HBS2Git.Alerts
-import HBS2Git.Annotations
-import HBS2Git.Encryption
-import HBS2Git.State
-import HBS2Git.PrettyStuff
-import HBS2Git.Config
-
-
-import HBS2.Data.Detect
-import HBS2.Merkle
-import HBS2.Peer.Proto
-import HBS2.OrDie
-import HBS2.Storage
-import HBS2.Storage.Operations.ByteString
-import HBS2.System.Logger.Simple
-
-import Control.Monad
-import Control.Monad.Catch (MonadMask)
-import Control.Monad.Except (runExceptT)
-import Control.Monad.Trans.Maybe
-import Data.ByteString.Lazy (ByteString)
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.Either
-import Data.HashMap.Strict qualified as HashMap
-import Data.HashSet qualified as HashSet
-import Data.List qualified as List
-import Data.Maybe
-import Lens.Micro.Platform
-import Streaming.Prelude qualified as S
-import System.IO
-import Text.InterpolatedString.Perl6 (qc)
-
-
-updateGK0 :: forall m . ( MonadIO m
-                        -- , HasRPC m
-                        , MonadMask m
-                        , HasStorage m
-                        , HasConf m
-                        , HasEncryptionKeys m
-                        )
-                 => RepoRef
-                 -> m ()
-updateGK0 repo = void $ runMaybeT do
-
-  guard =<< lift (isRefEncrypted (fromRefLogKey repo))
-
-  db <- makeDbPath repo >>= dbEnv
-  -- FIXME: check-if-for-die-good-here
-  ki <- lift $ getKeyInfo (fromRefLogKey repo)
-          `orDie` noKeyInfoMsg repo
-
-  -- 2. Если нет GK0 или он expired
-  mbGk0Hash <- withDB db $ stateGetLocalKey ki
-
-  -- 2.1 Генерируем новый GK0
-  gk0Hash <- lift $ maybe1 mbGk0Hash (makeNewGK0 ki) pure
-
-  when (isNothing mbGk0Hash) do
-    liftIO $ hPutDoc stderr $ "New GK0" <+> pretty gk0Hash <> line
-
-  withDB db $ statePutLocalKey ki gk0Hash repo
-
-  debug  $ "GK0" <+> pretty gk0Hash
-
-  where
-    makeNewGK0 ki = do
-      sto <- getStorage
-      gk <- genGK0 ki <&> serialise
-      liftIO $ writeAsMerkle sto (gk :: ByteString) <&> HashRef
-
-genKeysAnnotations :: forall m . ( MonadIO m
-                                 , MonadMask m
-                                 , HasStorage m
-                                 , HasConf m
-                                 , HasEncryptionKeys m
-                                 )
-                 => RepoRef
-                 -> m (Maybe HashRef)
-
-genKeysAnnotations repo = do
-  sto <- getStorage
-
-  runMaybeT do
-
-    guard =<< lift (isRefEncrypted (fromRefLogKey repo))
-
-    db <- makeDbPath repo >>= dbEnv
-    -- TODO: generate-and-update-keys-metadata
-    -- 1. get GK0
-
-    ki <- lift $ getKeyInfo (fromRefLogKey repo)
-            `orDie` noKeyInfoMsg repo
-
-    gk0Hash <- withDB db $ stateGetLocalKey ki
-                `orDie` noKeyInfoMsg repo
-
-    let processedKey = serialise ("GENKEYMETADATA", gk0Hash)
-
-    isNewKey  <- withDB db $ not <$> stateGetProcessed processedKey
-
-    sp0 <- withDB db savepointNew
-    withDB db $ savepointBegin sp0
-
-    -- FIXME: excess-data-roundtrip
-    gk0newBs <- (runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gk0Hash))))
-                  `orDie` [qc|*** Can't load GK0 {pretty gk0Hash}, maybe storage failure|]
-
-    -- теперь нам надо как-то узнать, что ключ новый и нам надо обработать
-    -- новых читателей.
-    -- Вариант #1: писать авторов в стейт. если они не обработаны еще,
-    -- то обрабатывать.
-
-    -- 2.2 Генерируем новый GK1 ∀ members
-    -- FIXME: might-be-slow
-
-    guard isNewKey
-
-    -- notice $ "NEW KEY APPEARED" <+> pretty gk0Hash
-
-    h <- toMPlus =<< getRef sto (refAlias repo)
-
-    gk0hs <- HashSet.fromList <$> S.toList_ (findAllGK0 sto h)
-
-    let keySource = do
-          forM_ gk0hs $ \gkh -> void $ runMaybeT do
-            gbs <- toMPlus =<< runExceptT (readFromMerkle sto (SimpleKey gkh))
-            gk0 <- toMPlus $ deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gbs
-            -- TODO: decrypt-secret-right-here
-            lift $ S.yield (gkh, gk0)
-
-    allKeys <- S.toList_ keySource <&> HashMap.fromList
-
-    -- ∀ gk0:
-    --    - вытащить секрет (найти, кем расшифровать) recipients
-    --    - взять вообще всех recipients и сформировать новый GK1
-    --      для каждого из recipients из allKeys
-
-    -- взять все доступные пары ключей?
-    keys <- lift enumEncryptionKeys <&> fmap (\x -> (view krPk x, view krSk x))
-
-    new' <- forM (HashMap.toList allKeys) $ \(hx, gk0) -> do
-      let gksec' = [ lookupGroupKey sk pk gk0 | (pk,sk) <- keys ] & catMaybes & headMay
-      case gksec' of
-        Nothing  -> pure (Left hx)
-        Just sec -> pure $ Right (hx, gk0, sec)
-
-    let missed = lefts new'
-
-    forM_ missed $ \miss -> do
-      warn $ "new group key: unavailable keys for gk" <+> pretty miss
-
-    let new = rights new'
-
-    gk0new <- pure (deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gk0newBs)
-                `orDie` [qc|*** Malformed/corrupted group key {pretty gk0Hash}|]
-
-    let rcpt0 = recipients gk0new
-
-    gnew <- forM new $ \(hx, gk0, sec) -> do
-
-      -- TODO: test-if-key-removing-works
-      let newRcpt = (recipients gk0new & HashMap.keysSet)
-                     `HashSet.difference`
-                    (recipients gk0 & HashMap.keysSet)
-
-      let r1 = HashMap.keys $ recipients gk0 <> recipients gk0new
-
-      let r11 = [ x | x <- r1, HashMap.member x rcpt0 ]
-
-      gk1 <- generateGroupKey @HBS2Basic (Just sec) r11
-
-      pure (hx, newRcpt, gk1)
-
-    let nr = HashSet.unions $ fmap (view _2) gnew
-
-    ann <- if HashSet.null nr then do
-             pure mempty
-           else do
-            forM gnew $ \(gk0h, _, gk1) -> do
-              pure (GK1 (HashRef gk0h) gk1)
-
-
-    annHash <- if List.null ann then do
-                 pure Nothing
-               else do
-                 Just . HashRef <$> writeAsMerkle sto (serialise (SmallAnnotations ann))
-
-    debug $ "ANNOTATIONS" <+> pretty annHash
-
-    withDB db do
-      statePutProcessed processedKey
-      savepointRelease sp0
-
-    toMPlus annHash
-
-  where
-
-    -- FIXME: deepScan-ScanShallow-broken
-    -- TODO: deal-with-missed-blocks
-    findAllGK0 sto h = do
-        -- TODO: performance-memoize-possible
-        --   можно мемоизировать для h
-        deepScan ScanDeep (const none) h (getBlock sto) $ \hx -> do
-          void $ runMaybeT do
-            blk  <- toMPlus =<< getBlock sto hx
-            refupd <- toMPlus $ deserialiseOrFail @(RefLogUpdate HBS2L4Proto) blk
-            payload <- toMPlus $ deserialiseOrFail (LBS.fromStrict $ view refLogUpdData refupd)
-
-            let (SequentialRef _ (AnnotatedHashRef _ ht)) = payload
-
-            treeBs <- toMPlus =<< getBlock sto (fromHashRef ht)
-
-            enc <- toMPlus (deserialiseOrFail @(MTreeAnn [HashRef]) treeBs)
-                       <&> _mtaCrypt
-
-            case enc of
-              EncryptGroupNaClSymm g _  -> do
-                -- liftIO $ hPutDoc stderr $ "GK0 FOR" <+> pretty
-                lift $ S.yield g
-
-              _ -> pure ()
-
-
-importKeysAnnotations :: forall m . ( MonadIO m
-                                    , MonadMask m
-                                    , HasStorage m
-                                    )
-                 => RepoRef
-                 -> HashRef
-                 -> HashRef
-                 -> DB m ()
-
-importKeysAnnotations repo e href = do
-  sto <- lift getStorage
-  void $ runMaybeT do
-    ebs <- runExceptT $ readFromMerkle sto (SimpleKey (fromHashRef href))
-
-    bs <- toMPlus ebs
-
-    anns <- toMPlus $ deserialiseOrFail @Annotations bs
-
-    let entries = case anns of
-                    SmallAnnotations e -> [ gk1 | gk1@(GK1{}) <- e ]
-                    _                  -> mempty
-
-
-    forM_ entries $ \(GK1 gk0h gk1) -> do
-
-      forM_ (HashMap.toList (recipients gk1)) $ \(pk,box) -> do
-        let gk1small = GroupKeySymm @HBS2Basic (HashMap.singleton pk box)
-        lift $ statePutGK1 gk0h pk gk1small
-
-

hbs2-git/lib/HBS2Git/Prelude.hs

@@ -1,15 +0,0 @@
-module HBS2Git.Prelude
-  ( module HBS2.Prelude.Plated
-  , module HBS2.Base58
-  , module HBS2.Data.Types.Refs
-  , module Credentials
-  , module Codec.Serialise
-  ) where
-
-import HBS2.Prelude.Plated
-import HBS2.Base58
-import HBS2.Data.Types.Refs
-import HBS2.Net.Auth.Credentials as Credentials
-
-import Codec.Serialise
-

hbs2-git/lib/HBS2Git/PrettyStuff.hs

@@ -1,30 +0,0 @@
-module HBS2Git.PrettyStuff
-  ( module HBS2Git.PrettyStuff
-  , hPutDoc
-  ) where
-
-import Data.Text qualified as Text
-import Prettyprinter
-import Prettyprinter.Render.Terminal
-
-green :: Doc AnsiStyle -> Doc AnsiStyle
-green = annotate (color Green)
-
-yellow :: Doc AnsiStyle -> Doc AnsiStyle
-yellow = annotate (color Yellow)
-
-red :: Doc AnsiStyle -> Doc AnsiStyle
-red = annotate (color Red)
-
-blue :: Doc AnsiStyle -> Doc AnsiStyle
-blue = annotate (color Blue)
-
-section :: Doc ann
-section = line <> line
-
-toStringANSI :: Doc AnsiStyle -> String
-toStringANSI doc = Text.unpack $ renderStrict $ layoutPretty defaultLayoutOptions doc
-
-
--- asHex ::
-

hbs2-git/lib/HBS2Git/State.hs

@@ -1,656 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# Language UndecidableInstances #-}
-module HBS2Git.State where
-
-import HBS2Git.Prelude hiding (getCredentials)
-import HBS2Git.Types
-import HBS2Git.Config (cookieFile)
-import HBS2Git.Encryption
-import HBS2.Git.Types
-
-import HBS2.Data.Types.Refs
-import HBS2.Hash
-
-import HBS2.System.Logger.Simple
-
-
-import Control.Monad.Trans.Resource
-import Data.Functor
-import Data.Function
-import Database.SQLite.Simple
-import Database.SQLite.Simple.FromField
-import Database.SQLite.Simple.ToField
-import Control.Monad.Reader
-import Text.InterpolatedString.Perl6 (qc)
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Data.Text.IO qualified as Text
-import Data.Text qualified as Text
-import System.Directory
-import System.FilePath
-import Data.Maybe
-import Data.UUID.V4 qualified as UUID
-import Control.Monad.Catch
-import Control.Concurrent.STM
-import Data.Graph (graphFromEdges, topSort)
-import Lens.Micro.Platform
-
--- FIXME: move-orphans-to-separate-module
-
-instance ToField Cookie where
-  toField (Cookie x) = toField x
-
-instance FromField Cookie where
-  fromField = fmap Cookie . fromField @Text.Text
-
-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 FromField GitObjectType where
-  fromField = fmap fromString . fromField @String
-
-instance ToField HashRef where
-  toField h = toField (show $ pretty h)
-
-instance ToField GitObjectType where
-  toField h = toField (show $ pretty h)
-
-instance FromField HashRef where
-  fromField = fmap fromString . fromField @String
-
-instance ToField (RefLogKey HBS2Basic) where
-  toField rk = toField (show (pretty rk))
-
-newtype Base58Field a = Base58Field { unBaseB8Field :: a }
-
-instance Pretty (AsBase58 a) => ToField (Base58Field a) where
-  toField (Base58Field a) = toField (show (pretty (AsBase58 a)))
-
-instance FromStringMaybe a => FromField (Base58Field a) where
-  fromField x =
-    fromField @String x
-      <&> fromStringMay @a
-      >>= maybe (fail "can't parse base58 value") (pure  . Base58Field)
-
-newtype DB m a =
-  DB { fromDB :: ReaderT DBEnv m a }
-  deriving newtype ( Applicative
-                   , Functor
-                   , Monad
-                   , MonadIO
-                   , MonadReader DBEnv
-                   , MonadTrans
-                   , MonadThrow
-                   , MonadCatch
-                   )
-
-instance (HasRefCredentials m) => HasRefCredentials (DB m) where
-  getCredentials = lift . getCredentials
-  setCredentials r s  = lift (setCredentials r s)
-
-stateConnection :: MonadIO m => DB m Connection
-stateConnection = do
-  env <- ask
-  initConnection env
-
-initConnection :: MonadIO m => DBEnv -> m Connection
-initConnection env = do
-  mco <- liftIO $ readTVarIO (view dbConn env)
-  case mco of
-    Just co -> pure co
-    Nothing -> do
-      co <- liftIO $ open (view dbFilePath env)
-      liftIO $ atomically $ writeTVar (view dbConn env) (Just co)
-      pure co
-
-dbEnv0 :: (MonadIO m, MonadMask m) => DB m () -> FilePath -> m DBEnv
-dbEnv0 dbInit fp = do
-  trace  "dbEnv called"
-  let dir = takeDirectory fp
-  liftIO $ createDirectoryIfMissing True dir
-  env0 <- DBEnv fp "" <$> liftIO (newTVarIO Nothing)
-  void $ withDB env0 dbInit
-  cookie <- withDB env0 $ readOrCreateCookie
-  DBEnv fp cookie <$> liftIO (newTVarIO Nothing)
-
-dbEnv :: (MonadIO m, MonadMask m) => FilePath -> m DBEnv
-dbEnv = dbEnv0 stateInit
-
-dbEnvReadOnly :: (MonadIO m, MonadMask m) => FilePath -> m DBEnv
-dbEnvReadOnly = dbEnv0 none
-
-withDB :: (MonadIO m, MonadMask m) => DBEnv -> DB m a -> m a
-withDB env action = do
-  trace $ "** DB run with COOKIE" <+> viaShow (view dbCookie env)
-  conn <- initConnection env
-  finally (runReaderT (fromDB action) env) $ do
-    -- NOTE: we could not close connection here.
-    pure ()
-
-shutdownDB :: MonadIO m => DBEnv -> m ()
-shutdownDB env = liftIO do
-  co <- atomically do
-    conn <- readTVar (view dbConn env)
-    writeTVar (view dbConn env) Nothing
-    pure conn
-  maybe1 co none close
-
-stateInit :: (MonadIO m, MonadThrow m) => DB m ()
-stateInit = do
-  conn <- stateConnection
-  liftIO $ execute_ conn [qc|
-  create table if not exists logrefval
-  ( loghash text not null
-  , refname text not null
-  , refval  text not null
-  , primary key (loghash, refname)
-  )
-  |]
-
-  liftIO $ execute_ conn [qc|
-  create table if not exists logobject
-  ( loghash text not null
-  , type text not null
-  , githash text not null
-  , primary key (loghash, githash)
-  )
-  |]
-
-  liftIO $ execute_ conn [qc|
-  create table if not exists logcommitparent
-  ( kommit text not null
-  , parent text not null
-  , primary key (kommit,parent)
-  )
-  |]
-
-  forM_ ["logimported", "tranimported", "refimported"] $ \t -> do
-    here <- colExists conn t "cookie"
-    unless here $ liftIO do
-      liftIO $ execute_ conn [qc|
-      DROP TABLE IF EXISTS {t};
-      |]
-
-  liftIO $ execute_ conn [qc|
-  create table if not exists logimported
-  ( hash text not null
-  , cookie text not null
-  , primary key (hash, cookie)
-  )
-  |]
-
-  liftIO $ execute_ conn [qc|
-  create table if not exists refimported
-  ( hash text not null
-  , cookie text not null
-  , timestamp DATETIME DEFAULT CURRENT_TIMESTAMP
-  , primary key (hash, cookie)
-  )
-  |]
-
-  liftIO $ execute_ conn [qc|
-  create table if not exists tranimported
-  ( hash text not null
-  , cookie text not null
-  , timestamp DATETIME DEFAULT CURRENT_TIMESTAMP
-  , primary key (hash, cookie)
-  )
-  |]
-
-  liftIO $ execute_ conn [qc|
-  DROP VIEW IF EXISTS v_refval_actual;
-  |]
-
-  liftIO $ execute_ conn [qc|
-  CREATE TABLE IF NOT EXISTS logcommitdepth
-  ( kommit text not null
-  , depth integer not null
-  , primary key (kommit)
-  );
-  |]
-
-  liftIO $ execute_ conn [qc|
-  CREATE TABLE IF NOT EXISTS logrank
-  ( hash text not null
-  , rank int not null
-  , primary key (hash)
-  );
-  |]
-
-  liftIO $ execute_ conn [qc|
-  CREATE TABLE IF NOT EXISTS cookie
-  ( cookie text not null
-  , primary key (cookie)
-  );
-  |]
-
-
-  liftIO $ execute_ conn [qc|
-  CREATE TABLE IF NOT EXISTS groupkeylocal
-  ( keyhash    text not null
-  , ref        text not null
-  , timestamp  DATETIME DEFAULT CURRENT_TIMESTAMP
-  , valuehash  text not null
-  , primary key (keyhash)
-  );
-  |]
-
-  liftIO $ execute_ conn [qc|
-  CREATE TABLE IF NOT EXISTS gk1
-  ( gk0        text not null
-  , pk         text not null
-  , gk1        text not null
-  , primary key (gk0, pk)
-  );
-  |]
-
-  liftIO $ execute_ conn [qc|
-  CREATE TABLE IF NOT EXISTS processed
-  ( hash    text not null
-  , cookie  text not null
-  , timestamp  DATETIME DEFAULT CURRENT_TIMESTAMP
-  , primary key (hash)
-  );
-  |]
-
-  liftIO $ execute_ conn [qc|
-  DROP VIEW IF EXISTS v_log_depth;
-  |]
-
-  liftIO $ execute_ conn [qc|
-  DROP VIEW IF EXISTS v_refval_actual;
-  |]
-
-  liftIO $ execute_ conn [qc|
-  CREATE VIEW v_refval_actual AS
-  WITH ranks AS (
-      SELECT  rv.refname,
-              MAX(COALESCE(d.depth, 0)) as max_depth,
-              MAX(COALESCE(r.rank, 0)) as max_rank
-      FROM logrefval rv
-      LEFT JOIN logcommitdepth d ON rv.refval = d.kommit
-      LEFT JOIN logrank r ON r.hash = rv.loghash
-      GROUP BY rv.refname
-  )
-  SELECT r.refname, rv.refval, r.max_rank as r, r.max_depth as d
-  FROM logrefval rv
-  JOIN ranks r ON r.refname = rv.refname
-  WHERE
-      (
-          (r.max_rank > 0 AND rv.loghash IN (SELECT hash FROM logrank WHERE rank = r.max_rank))
-       OR (r.max_rank = 0 AND rv.refval IN (SELECT kommit FROM logcommitdepth WHERE depth = r.max_depth))
-      )
-  AND rv.refval <> '0000000000000000000000000000000000000000'
-  ORDER BY r.refname;
-  |]
-
-  void $ readOrCreateCookie
-
-  where
-    colExists :: MonadIO m => Connection -> String -> String -> m Bool
-    colExists conn table col = do
-      let sql =[qc|PRAGMA table_info({table})|]
-      fields <- liftIO $ query_ conn sql
-      let fs = [x | ((_, x, _, _, _, _) :: (Int, String, String, Int, Maybe String, Int)) <- fields ]
-      pure ( col `elem` fs )
-
-readOrCreateCookie :: (MonadIO m, MonadThrow m) => DB m Cookie
-readOrCreateCookie = do
-  cfn <- cookieFile
-  cf <- liftIO $ readFile cfn <&> take 4096
-
-  if null cf then do
-    cookie <- stateGenCookie
-    liftIO $ Text.writeFile cfn (fromCookie cookie)
-    pure cookie
-  else do
-    let cookie@(Cookie co) = Cookie (fromString cf)
-    statePutCookie cookie
-    pure cookie
-
-newtype Savepoint =
-  Savepoint String
-  deriving newtype (IsString)
-  deriving stock (Eq,Ord)
-
-savepointNew :: forall m . MonadIO m => DB m Savepoint
-savepointNew  = do
-  uu <- liftIO UUID.nextRandom
-  let s = LBS.pack (show uu) & hashObject @HbSync & pretty & show
-  pure $ fromString ("sp" <> s)
-
-savepointBegin :: forall m . MonadIO m => Savepoint -> DB m ()
-savepointBegin (Savepoint sp) = do
-  conn <- stateConnection
-  liftIO $ execute_ conn [qc|SAVEPOINT {sp}|]
-
-savepointRelease:: forall m . MonadIO m => Savepoint -> DB m ()
-savepointRelease (Savepoint sp) = do
-  conn <- stateConnection
-  liftIO $ execute_ conn [qc|RELEASE SAVEPOINT {sp}|]
-
-savepointRollback :: forall m . MonadIO m => Savepoint -> DB m ()
-savepointRollback (Savepoint sp) = do
-  conn <- stateConnection
-  liftIO $ execute_ conn [qc|ROLLBACK TO SAVEPOINT {sp}|]
-
-transactional :: forall a m . (MonadCatch m, MonadIO m) => DB m a -> DB m a
-transactional action = do
-
-  sp <- savepointNew
-
-  savepointBegin sp
-  r <- try action
-
-  case r of
-    Left (e :: SomeException) -> do
-      savepointRollback sp
-      throwM e
-
-    Right x -> do
-      savepointRelease sp
-      pure x
-
--- TODO: backlog-head-history
---   можно сделать таблицу history, в которую
---   писать журнал всех изменений голов.
---   тогда можно будет откатиться на любое предыдущее
---   состояние репозитория
-
-
-statePutLogRefVal :: MonadIO m => (HashRef, GitRef, GitHash) -> DB m ()
-statePutLogRefVal row = do
-  conn <- stateConnection
-  liftIO $ execute conn [qc|
-  insert into logrefval (loghash,refname,refval) values(?,?,?)
-  on conflict (loghash,refname) do nothing
-  |] row
-
-
-statePutLogObject :: MonadIO m => (HashRef, GitObjectType, GitHash) -> DB m ()
-statePutLogObject row = do
-  conn <- stateConnection
-  liftIO $ execute conn [qc|
-  insert into logobject (loghash,type,githash) values(?,?,?)
-  on conflict (loghash,githash) do nothing
-  |] row
-
-stateIsLogObjectExists :: MonadIO m => GitHash -> DB m Bool
-stateIsLogObjectExists h = do
-  conn <- stateConnection
-  liftIO $ query conn [qc|
-  SELECT NULL FROM logobject WHERE githash = ? LIMIT 1
-  |] (Only h) <&> isJust . listToMaybe . fmap (fromOnly @(Maybe Int))
-
-
-stateGetGitLogObject :: MonadIO m => GitHash -> DB m (Maybe HashRef)
-stateGetGitLogObject h = do
-  conn <- stateConnection
-  liftIO $ query conn [qc|
-  SELECT loghash FROM logobject
-  WHERE githash = ? and type in ('commit', 'tree', 'blob')
-  LIMIT 1
-  |] (Only h) <&> listToMaybe . fmap fromOnly
-
-statePutLogContextCommit :: MonadIO m => HashRef -> GitHash -> DB m ()
-statePutLogContextCommit loghash ctx = do
-  conn <- stateConnection
-  liftIO $ execute conn [qc|
-  insert into logobject (loghash,type,githash) values(?,'context',?)
-  on conflict (loghash,githash) do nothing
-  |] (loghash,ctx)
-
-
-statePutLogContextRank :: MonadIO m => HashRef -> Int -> DB m ()
-statePutLogContextRank loghash rank = do
-  conn <- stateConnection
-  liftIO $ execute conn [qc|
-  insert into logrank (hash,rank) values(?,?)
-  on conflict (hash) do nothing
-  |] (loghash,rank)
-
-statePutLogCommitParent :: MonadIO m => (GitHash, GitHash) -> DB m ()
-statePutLogCommitParent row = do
-  conn <- stateConnection
-  liftIO $ execute conn [qc|
-  insert into logcommitparent (kommit,parent) values(?,?)
-  on conflict (kommit,parent) do nothing
-  |] row
-
-
-statePutLogImported :: MonadIO m => HashRef -> DB m ()
-statePutLogImported h = do
-  conn <- stateConnection
-  cookie <- asks (view dbCookie)
-  liftIO $ execute conn [qc|
-  insert into logimported (hash,cookie) values(?,?)
-  on conflict (hash,cookie) do nothing
-  |] (h,cookie)
-
-stateGetLogImported :: MonadIO m => HashRef -> DB m Bool
-stateGetLogImported h = do
-  conn <- stateConnection
-  cookie <- asks (view dbCookie)
-  r <- liftIO $ query @_ @(Only Int) conn [qc|
-    select 1 from logimported where hash = ? and cookie = ? limit 1
-  |] (h, cookie)
-  pure $ not $ null r
-
-statePutRefImported :: MonadIO m => HashRef -> DB m ()
-statePutRefImported h = do
-  conn <- stateConnection
-  cookie <- asks (view dbCookie)
-  liftIO $ execute conn [qc|
-  insert into refimported (hash,cookie) values(?,?)
-  on conflict (hash,cookie) do nothing
-  |] (h,cookie)
-
-stateGetRefImported :: MonadIO m => HashRef -> DB m Bool
-stateGetRefImported h = do
-  conn <- stateConnection
-  cookie <- asks (view dbCookie)
-  r <- liftIO $ query @_ @(Only Int) conn [qc|
-    select 1 from refimported where hash = ? and cookie = ? limit 1
-  |] (h, cookie)
-  pure $ not $ null r
-
-statePutTranImported :: MonadIO m => HashRef -> DB m ()
-statePutTranImported h = do
-  conn <- stateConnection
-  cookie <- asks (view dbCookie)
-  debug $ "statePutTranImported" <+> pretty h <+> viaShow cookie
-  liftIO $ execute conn [qc|
-  insert into tranimported (hash, cookie) values(?, ?)
-  on conflict (hash, cookie) do nothing
-  |] (h, cookie)
-
-stateGetTranImported :: MonadIO m => HashRef -> DB m Bool
-stateGetTranImported h = do
-  conn <- stateConnection
-  cookie <- asks (view dbCookie)
-  r <- liftIO $ query @_ @(Only Int) conn [qc|
-    select 1 from tranimported where hash = ? and cookie = ? limit 1
-  |] (h, cookie)
-  pure $ not $ null r
-
-stateGetAllTranImported :: MonadIO m => DB m [HashRef]
-stateGetAllTranImported = do
-  conn <- stateConnection
-  cookie <- asks (view dbCookie)
-  results <- liftIO $ query conn [qc|
-    select hash from tranimported where cookie = ?
-  |] (Only cookie)
-  pure $ map fromOnly results
-
-stateGetImportedCommits :: MonadIO m => DB m [GitHash]
-stateGetImportedCommits = do
-  conn <- stateConnection
-  liftIO $ query_ conn [qc|
-    select distinct(githash) from logobject where type = 'commit'
-  |] <&> fmap fromOnly
-
-stateGetActualRefs :: MonadIO m => DB m [(GitRef, GitHash)]
-stateGetActualRefs = do
-  conn <- stateConnection
-  liftIO $ query_ conn [qc|
-    select refname,refval from v_refval_actual
-  |]
-
-stateGetActualRefValue :: MonadIO m => GitRef -> DB m (Maybe GitHash)
-stateGetActualRefValue ref = do
-  conn <- stateConnection
-  liftIO $ query conn [qc|
-    select refval from v_refval_actual
-    where refname = ?
-  |] (Only ref) <&> fmap fromOnly . listToMaybe
-
-stateGetLastKnownCommits :: MonadIO m => Int -> DB m [GitHash]
-stateGetLastKnownCommits n  = do
-  conn <- stateConnection
-  liftIO $ query conn [qc|
-    select kommit from logcommitdepth order by depth asc limit ?;
-  |] (Only n) <&> fmap fromOnly
-
-stateUpdateCommitDepths :: MonadIO m => DB m ()
-stateUpdateCommitDepths = do
-  conn <- stateConnection
-  sp <- savepointNew
-
-  rows <- liftIO $ query_ @(GitHash, GitHash) conn [qc|SELECT kommit, parent FROM logcommitparent|]
-
-  -- TODO: check-it-works-on-huge-graphs
-  let commitEdges = rows
-  let (graph, nodeFromVertex, _) = graphFromEdges [(commit, commit, [parent]) | (commit, parent) <- commitEdges]
-  let sortedVertices = topSort graph
-  let sortedCommits = reverse [commit | vertex <- sortedVertices, let (commit, _, _) = nodeFromVertex vertex]
-  let ordered = zip sortedCommits [1..]
-
-  savepointBegin sp
-  liftIO $ execute_ conn [qc|DELETE FROM logcommitdepth|]
-  forM_ ordered $ \(co, n) -> do
-    liftIO $ execute conn
-      [qc| INSERT INTO logcommitdepth(kommit,depth)
-           VALUES(?,?)
-           ON CONFLICT(kommit)
-           DO UPDATE SET depth = ?
-      |] (co,n,n)
-    pure ()
-  savepointRelease sp
-
-
-statePutCookie :: MonadIO m => Cookie -> DB m ()
-statePutCookie cookie = do
-  conn <- stateConnection
-  let sql = [qc|INSERT INTO cookie (cookie) values(?) ON CONFLICT(cookie) DO NOTHING|]
-  liftIO $ execute conn sql (Only cookie)
-
-stateGenCookie :: (MonadIO m) => DB m Cookie
-stateGenCookie = do
-  conn <- stateConnection
-  fix \next -> do
-    cookie <- liftIO (UUID.nextRandom <&> (fromString @Cookie. show))
-
-    here <- liftIO $ query conn [qc|select 1 from cookie where cookie = ? limit 1|] (Only cookie)
-                        <&> listToMaybe @(Only Int)
-
-    if isJust here then do
-      next
-    else liftIO do
-      void $ execute conn [qc|insert into cookie (cookie) values(?)|] (Only cookie)
-      pure cookie
-
-
-stateListLocalKeys :: MonadIO m => DB m [HashRef]
-stateListLocalKeys = do
-  undefined
-
-stateGetLocalKey :: MonadIO m
-                 => KeyInfo
-                 -> DB m (Maybe HashRef)
-stateGetLocalKey ki = do
-  conn <- stateConnection
-  let h = hashObject @HbSync ki & HashRef
-  liftIO $ query conn [qc|select valuehash from groupkeylocal where keyhash = ? limit 1|] (Only h)
-            <&> fmap fromOnly . listToMaybe
-
-statePutLocalKey :: MonadIO m
-                 => KeyInfo
-                 -> HashRef
-                 -> RefLogKey HBS2Basic
-                 -> DB m ()
-
-statePutLocalKey ki gkh reflog = do
-  conn <- stateConnection
-  let sql = [qc|
-  INSERT INTO groupkeylocal (keyhash, ref, valuehash)
-  VALUES (?,?,?)
-  ON CONFLICT (keyhash) DO UPDATE SET
-    ref = excluded.ref, valuehash = excluded.valuehash
-  |]
-
-  liftIO $ execute conn sql (HashRef (hashObject @HbSync ki), reflog, gkh)
-  pure ()
-
-
-statePutProcessed :: (MonadIO m, Hashed HbSync b) => b -> DB m ()
-statePutProcessed h = do
-  conn <- stateConnection
-  cookie <- asks (view dbCookie)
-  liftIO $ execute conn [qc|
-    insert into processed (hash, cookie) values (?, ?)
-    on conflict (hash) do nothing
-  |] (HashRef (hashObject @HbSync h), cookie)
-
-stateGetProcessed :: (MonadIO m, Hashed HbSync b) => b -> DB m Bool
-stateGetProcessed h = do
-  conn <- stateConnection
-  cookie <- asks (view dbCookie)
-  r <- liftIO $ query @_ @(Only Int) conn [qc|
-    select 1 from processed where hash = ? and cookie = ? limit 1
-  |] (HashRef (hashObject @HbSync h), cookie)
-  pure $ not $ null r
-
-
-statePutGK1 :: MonadIO m => HashRef
-            -> PubKey 'Encrypt HBS2Basic
-            -> GroupKey 'Symm HBS2Basic
-            -> DB m ()
-
-statePutGK1 gk0 pk gk1 = do
-  conn <- stateConnection
-  liftIO $ execute conn [qc|
-    insert into gk1 (gk0, pk, gk1) values (?, ?, ?)
-    on conflict (gk0, pk) do nothing
-  |] (gk0, Base58Field pk, Base58Field gk1)
-
-stateGetGK1 :: MonadIO m
-            => HashRef
-            -> PubKey 'Encrypt HBS2Basic
-            -> DB m (Maybe (GroupKey 'Symm HBS2Basic))
-
-stateGetGK1 gk0 pk = do
-  conn <- stateConnection
-  r <- liftIO $ query conn [qc|
-    select gk1 from gk1 where gk0 = ? and pk = ? limit 1
-  |] (gk0, Base58Field pk)
-  pure $ listToMaybe $ fmap (unBaseB8Field . fromOnly) r
-
-stateListGK1 :: MonadIO m
-            => HashRef
-            -> DB m [GroupKey 'Symm HBS2Basic]
-
-stateListGK1 gk0 = do
-  conn <- stateConnection
-  r <- liftIO $ query conn [qc|
-    select gk1 from gk1 where gk0 = ?
-  |] (Only gk0)
-  pure $ fmap (unBaseB8Field . fromOnly) r
-

hbs2-git/lib/HBS2Git/Tools.hs

@@ -1,323 +0,0 @@
-module HBS2Git.Tools where
-
-import HBS2.Prelude.Plated
-import HBS2.Base58
-import HBS2.Net.Proto.Types
-import HBS2.Net.Auth.Credentials
-import HBS2.Data.Types.Refs (HashRef)
-import HBS2.OrDie
-
-import HBS2.System.Logger.Simple
-
-import HBS2Git.Types
-import HBS2Git.App
-
-import HBS2.Git.Local.CLI
-import HBS2.Git.Types
-import HBS2Git.Import (importRefLogNew)
-import HBS2Git.Config
-import HBS2Git.State
-import HBS2Git.PrettyStuff
-
-import Data.HashMap.Strict qualified as HashMap
-import Data.ByteString.Char8 qualified as BS8
-import Data.Text qualified as Text
-import Data.Traversable
-import Data.Maybe
-import Data.Either
-import Prettyprinter.Render.Terminal
-import Control.Monad.IO.Unlift
-import Control.Monad.Catch (MonadCatch,MonadThrow,MonadMask)
-import Data.Generics.Product (field)
-import Lens.Micro.Platform
-import System.FilePath
-import System.Directory
-import System.Process.Typed
-import Text.InterpolatedString.Perl6 (qc)
-import System.IO.Temp
-import System.IO (stdout,stderr)
-
-import UnliftIO
-
-data EncryptionOpts =
-  EncryptionOpts
-  { encryptKeyring :: FilePath
-  , encryptKey     :: PubKey 'Encrypt HBS2Basic
-  }
-  deriving stock Generic
-
-data NewRepoOpts =
-  NewRepoOpts
-  { newRepoKeyring      :: Maybe FilePath
-  , newRepoEncryption   :: Maybe (PubKey 'Encrypt HBS2Basic, FilePath)
-  }
-  deriving stock (Generic)
-
-data AsRemoteEntry = AsRemoteEntry
-  { remoteName :: Text,
-    remoteURL :: Text,
-    remoteRefValue :: Maybe HashRef
-  }
-
-remoteNameColWidth :: Int
-remoteNameColWidth = 16
-
-remoteURLColWidth :: Int
-remoteURLColWidth = 51
-
-remoteRefValueColWidth :: Int
-remoteRefValueColWidth = 44
-
-instance Pretty AsRemoteEntry where
-  pretty (AsRemoteEntry {..}) =
-    fill remoteNameColWidth (pretty remoteName)
-      <+> fill remoteURLColWidth (pretty remoteURL)
-      <+> fill remoteRefValueColWidth (maybe "-" pretty remoteRefValue)
-
-hbs2Prefix :: Text
-hbs2Prefix = "hbs2://"
-
--- TODO: backlog-list-refs-all-option
---  сделать опцию --all которая выведет
---  все известные ref-ы из стейта.
---  Сейчас выводятся только локальные
-
-runListRefs :: (MonadIO m, HasStorage (App m)) => App m ()
-runListRefs = do
-  refs <- gitGetRemotes <&> filter isHbs2
-  remoteEntries <-
-    forM
-      refs
-      ( \(name, url) -> do
-          refVal <- getRefVal url
-          pure $
-            AsRemoteEntry
-              { remoteName = name,
-                remoteURL = url,
-                remoteRefValue = refVal
-              }
-      )
-  let header =
-        fill remoteNameColWidth (green "Name")
-          <+> fill remoteURLColWidth (green "URL")
-          <+> fill remoteRefValueColWidth (green "Reference value")
-  liftIO $ putDoc $ header <> line
-  liftIO $ putDoc $ vcat $ pretty <$> remoteEntries
-  where
-    isHbs2 (_, b) = Text.isPrefixOf hbs2Prefix b
-
-runToolsScan :: (MonadUnliftIO m,MonadCatch m,MonadMask m,HasStorage (App m)) => RepoRef -> App m ()
-runToolsScan ref = do
-  trace $ "runToolsScan" <+> pretty ref
-  importRefLogNew True ref
-  shutUp
-  pure ()
-
-runToolsGetRefs :: (MonadUnliftIO m,MonadCatch m,MonadMask m) => RepoRef -> App m ()
-runToolsGetRefs ref = do
-  db <- makeDbPath ref >>= dbEnv
-  refs <- withDB db stateGetActualRefs
-  let rh = RepoHead Nothing (HashMap.fromList refs)
-  hPrint stdout $ pretty (AsGitRefsFile rh)
-  shutUp
-
-getRefVal :: (MonadIO m, HasStorage m) => Text -> m (Maybe HashRef)
-getRefVal url =
-  case Text.stripPrefix hbs2Prefix url of
-    Nothing -> do
-      liftIO $ print $ pretty "wrong URL format" <+> pretty url
-      pure Nothing
-    Just refStr -> case fromStringMay $ Text.unpack refStr of
-      Nothing -> do
-        liftIO $ print $ pretty "can't parse ref" <+> pretty refStr
-        pure Nothing
-      Just ref -> do
-        mRefVal <- readRef ref
-        case mRefVal of
-          Nothing -> do
-            liftIO $ print $ pretty "readRef error" <+> pretty ref
-            pure Nothing
-          Just v -> pure $ Just v
-
-
-
-runInitRepo :: (MonadUnliftIO m, MonadThrow m, MonadCatch m) => NewRepoOpts -> m ()
-runInitRepo = runInitInteractive
-
-runInitInteractive :: (MonadUnliftIO m, MonadThrow m, MonadCatch m) => NewRepoOpts -> m ()
-runInitInteractive opts = do
-
-  hSetBuffering stdin  NoBuffering
-  hSetBuffering stdout LineBuffering
-
-  conf <- configPath ""
-           `catch`
-            (\NoWorkDirException -> do
-                liftIO $ hPutDoc stderr $ red "init:"
-                                           <+> "No git working directory."
-                                           <+> yellow "Run" <+> "'git init'" <+> "first"
-                                           <> line
-                die "nope"
-            )
-
-  rpc <- (Just <$> detectRPC False)
-           `catch`
-            (\NoRPCException -> do
-                liftIO $ hPutDoc stderr $ yellow "init:"
-                                           <+> "No RPC found."
-                                           <+> "Perhaps, hbs2-peer is down"
-                                           <> line
-                                           <> "Okay, you may add it later"
-                                           <> line
-                pure Nothing
-            )
-
-  let confFile = conf </> "config"
-
-  liftIO $ createDirectoryIfMissing True conf
-
-  confHere <- liftIO $ doesFileExist confFile
-
-  when confHere do
-    liftIO $ hPutDoc stdout $ yellow "Config"
-                           <+> pretty confFile
-                           <+> yellow "is already here."
-                           <+> "Continue? [y/n]: "
-
-    liftIO $ hFlush stdout
-
-    y <- liftIO getChar
-
-    unless (y `elem` "'yY ") do
-      exitFailure
-
-  liftIO $ hPutStrLn stdout ""
-
-  syn <- if not confHere then do
-           pure (mempty :: [Syntax C])
-         else do
-           liftIO $ try @_ @IOException (readFile confFile)
-                                <&> fromRight mempty
-                                <&> parseTop
-                                <&> fromRight mempty
-
-  let rpcHere = or [ True | (SymbolVal "rpc" :: Syntax C) <- universeBi syn ]
-
-  maybe1 rpc none $ \r -> do
-    unless rpcHere $ liftIO do
-      appendFile confFile $ show
-                          $ "rpc" <+> "unix" <+> dquotes (pretty r)
-                            <> line
-                            <> line
-
-  puk <- case view (field @"newRepoKeyring") opts of
-    Just kr -> liftIO do
-      addKeyring confFile kr
-
-    Nothing -> do
-      tmp <- liftIO $ emptyTempFile "." "reflog.key"
-
-      code <- runProcess (shell [qc|hbs2 keyring-new > {tmp}|])
-
-      unless (code == ExitSuccess) do
-        liftIO $ hPutDoc stderr $ red "init:" <+> "can't generate new keyring file" <> line
-        die "nope"
-
-      addKeyring confFile tmp
-
-
-  encrypt <- if isJust (view (field @"newRepoEncryption") opts) then do
-               pure True
-             else do
-               liftIO $ hPutDoc stdout $ yellow "Make reflog" <+> pretty (AsBase58 puk)
-                                         <+> "encrypted?"
-                                         <+> "[y/n]: "
-
-               liftIO $ hFlush stdout
-
-               y2 <- liftIO getChar
-
-               liftIO $ hPutStrLn stdout ""
-
-               pure $ y2 `elem` "'yY "
-
-  when encrypt do
-    let enc = view (field @"newRepoEncryption") opts
-
-    case enc of
-      Just (epuk, fp') -> do
-        fp <- liftIO $ makeAbsolute fp'
-        addDecrypt confFile fp
-        addEncrypted confFile puk epuk
-
-      Nothing -> do
-        tmp <- liftIO $ emptyTempFile "." "cred.key"
-
-        code <- runProcess (shell [qc|hbs2 keyring-new -n1 > {tmp}|])
-
-        fp <- liftIO $ makeAbsolute tmp
-
-        ke <- readPubKeyFrom fp
-        addDecrypt confFile fp
-        addEncrypted confFile puk ke
-
-        pure ()
-
-    pure ()
-
-  liftIO $ hPutDoc stderr $ green "Succeed!" <> line <> line
-  liftIO $ hPutDoc stderr $ pretty confFile <> line <> line
-  liftIO $ readFile confFile >>= putStrLn
-
-  where
-
-    readPubKeyFrom fp = do
-      bs <- liftIO $ BS8.readFile fp
-      cred <- pure (parseCredentials @HBS2Basic (AsCredFile bs))
-               `orDie` [qc|invalid credentials file {fp}|]
-
-      pure (view krPk <$> headMay (view peerKeyring cred))
-               `orDie` [qc|invalid credentials file {fp}|]
-
-    addEncrypted fn puk enc = liftIO do
-
-      appendFile fn $ show $
-        line
-        <> brackets (  "encrypted" <+> dquotes (pretty (AsBase58 puk))
-                      <> line
-                      <> parens ("ttl" <+> pretty 864000)
-                      <> line
-                      <> parens ("owner" <+> dquotes (pretty (AsBase58 enc)))
-                      <> line
-                    )
-        <> line
-
-      pure ()
-
-    addDecrypt fn kf = liftIO do
-      appendFile fn $ show
-                    $ ";; this keyring is a SECRET for encryption/decryption"
-                       <> line
-                       <> ";; move it to a private/safe place"
-                       <> line
-                       <> "decrypt" <+> dquotes (pretty kf)
-                       <> line
-
-    addKeyring fn kr = liftIO do
-      fp <- makeAbsolute kr
-
-      bs <- BS8.readFile fp
-      cred <- pure (parseCredentials @HBS2Basic (AsCredFile bs))
-               `orDie` [qc|invalid credentials file {fp}|]
-
-      let puk = view peerSignPk cred
-
-      liftIO $ hPutDoc stdout $ yellow "Adding reflog" <+> pretty (AsBase58 puk) <> line
-      appendFile fn  $ show $ ";; SECRET keyring for reflog" <+> pretty (AsBase58 puk) <> line
-      appendFile fn  $ show $ ";; move it to a private/safe place" <> line
-      appendFile fn  $ show line
-      appendFile fn  $ show $ "keyring" <+> dquotes (pretty fp) <> line <> line
-
-      pure puk
-
-

hbs2-git/lib/HBS2Git/Types.hs

@@ -1,237 +0,0 @@
-{-# Language PatternSynonyms #-}
-{-# Language UndecidableInstances #-}
-{-# Language TemplateHaskell #-}
-{-# Language AllowAmbiguousTypes #-}
-module HBS2Git.Types
-  ( module HBS2Git.Types
-  , module Control.Monad.IO.Class
-  , HasStorage(..)
-  , HasConf(..)
-  , AnyStorage(..)
-  , RefLogKey(..)
-  )
-  where
-
-import HBS2.Prelude.Plated
-import HBS2.Hash
-import HBS2.Git.Types
-import HBS2.Storage
-import HBS2.Peer.RPC.Client.Unix hiding (Cookie)
-import HBS2.Net.Auth.Credentials
-import HBS2.Peer.Proto hiding (Cookie)
-
-import HBS2.Peer.RPC.API.Peer
-import HBS2.Peer.RPC.API.RefLog
-import HBS2.Peer.RPC.API.Storage
-
-import HBS2.System.Logger.Simple
-
-import Data.Config.Suckless
-
-import System.ProgressBar
-import System.Exit as Exit
-import Control.Applicative
-import Control.Monad.IO.Class
-import Control.Monad.Reader
-import Data.ByteString.Lazy.Char8 qualified as LBS
-import Database.SQLite.Simple (Connection)
-import Data.Char (isSpace)
-import Data.List qualified as List
-import Lens.Micro.Platform
-import Data.HashMap.Strict (HashMap)
-import Data.HashMap.Strict qualified as HashMap
-import Control.Concurrent.STM
-import System.IO qualified as IO
-import System.IO (Handle)
-import Data.Kind
-import Control.Monad.Catch
-import Control.Monad.IO.Unlift
-
-import System.TimeIt
-
--- FIXME: remove-udp-hardcode-asap
-type Schema = HBS2Basic
-type HBS2L4Proto = L4Proto
-
--- FIXME: introduce-API-type
-type API = String
-
-newtype Cookie =
-  Cookie { fromCookie :: Text }
-  deriving newtype (Eq,Ord,Show)
-
-instance IsString Cookie where
-  fromString s = Cookie cookie
-    where cookie = fromString $ take 8
-                              $ show
-                              $ pretty
-                              $ hashObject @HbSync (LBS.pack s)
-data DBEnv =
-  DBEnv { _dbFilePath :: FilePath
-        , _dbCookie   :: Cookie
-        , _dbConn     :: TVar (Maybe Connection)
-        }
-
-makeLenses 'DBEnv
-
-type RepoRef = RefLogKey Schema
-
-data ConfBranch
-data HeadBranch
-data KeyRingFile
-data KeyRingFiles
-data StoragePref
-
-data RPCEndpoints =
-  RPCEndpoints
-  { rpcPeer    :: ServiceCaller PeerAPI UNIX
-  , rpcStorage :: ServiceCaller StorageAPI UNIX
-  , rpcRefLog  :: ServiceCaller RefLogAPI UNIX
-  }
-
-data AppEnv =
-  AppEnv
-  { _appCurDir       :: FilePath
-  , _appGitDir       :: FilePath
-  , _appConf         :: [Syntax C]
-  , _appStateDir     :: FilePath
-  , _appRefCred      :: TVar (HashMap RepoRef (PeerCredentials Schema))
-  , _appKeys         :: TVar (HashMap (PubKey 'Encrypt Schema) (PrivKey 'Encrypt Schema))
-  , _appOpts         :: TVar (HashMap String String)
-  , _appRpc          :: RPCEndpoints
-  }
-
-makeLenses 'AppEnv
-
-newtype AsGitRefsFile a = AsGitRefsFile a
-
-class HasRPC m where
-  getRPC :: m RPCEndpoints
-
-data RepoHead =
-  RepoHead
-  { _repoHEAD  :: Maybe GitRef
-  , _repoHeads :: HashMap GitRef GitHash
-  }
-  deriving stock (Generic,Show)
-
-makeLenses 'RepoHead
-
-
-instance Monoid RepoHead where
-  mempty = RepoHead Nothing mempty
-
-instance Semigroup RepoHead where
-  (<>) a b = mempty & set repoHEAD  ( view repoHEAD b <|> view repoHEAD a )
-                    & set repoHeads ( view repoHeads a <> view repoHeads b )
-
-instance Pretty (AsGitRefsFile RepoHead) where
-  pretty (AsGitRefsFile h) = hhead <> vcat (fmap fmt els)
-    where
-      hhead = case view repoHEAD h of
-               Nothing -> mempty
-               Just r -> "@" <> pretty r <+> "HEAD"  <> line
-
-      els = HashMap.toList (view repoHeads h)
-      fmt (r,hx) = pretty hx <+> pretty (normalizeRef r)
-
-
-instance Serialise RepoHead
-
--- FIXME: test-for-from-string-maybe-repohead
---   Нужно написать или сгенерировать тест
-instance FromStringMaybe RepoHead where
-  fromStringMay "" = Nothing
-  fromStringMay s =
-    case traverse decodePair (take 2 . words <$> lines trimmed) of
-      Right xs -> Just $ mconcat xs
-      _        -> Nothing
-    where
-      trimmed = dropWhile isSpace s
-      hbranch x = fromString <$> List.stripPrefix "@" x
-      decodePair :: [String] -> Either [String] RepoHead
-      decodePair [x, "HEAD"] | "@" `List.isPrefixOf` x = Right $ RepoHead (hbranch x) mempty
-
-      -- special case: deleted branch. should be handled somehow
-      decodePair [_] = Right $ RepoHead Nothing mempty
-
-      decodePair [x,r] = case fromStringMay x of
-                            Just h  -> Right $ RepoHead Nothing (HashMap.singleton (fromString r) h)
-                            Nothing -> Left [r,x]
-      decodePair other  = Left other
-
-
-class HasProgress m where
-  type family ProgressMonitor m :: Type
-  newProgressMonitor :: String -> Int -> m (ProgressMonitor  m)
-  updateProgress :: ProgressMonitor m -> Int -> m ()
-
-
-instance {-# OVERLAPPABLE #-} MonadIO m => HasProgress m where
-  type instance ProgressMonitor m = ProgressBar ()
-  updateProgress bar n = liftIO (incProgress bar n)
-  newProgressMonitor s total = liftIO $ liftIO $ newProgressBar st 10 (Progress 0 total ())
-    where
-      st = defStyle { stylePrefix = msg (fromString s)
-                    , styleWidth   = ConstantWidth 60
-                    }
-
-class MonadIO m => HasRefCredentials m where
-  getCredentials :: RepoRef -> m (PeerCredentials Schema)
-  setCredentials :: RepoRef -> PeerCredentials Schema -> m ()
-
-class MonadIO m => HasGlobalOptions m where
-  addGlobalOption :: String -> String -> m ()
-  getGlobalOption :: String -> m (Maybe String)
-
-class MonadIO m => HasEncryptionKeys m where
-  addEncryptionKey  :: KeyringEntry Schema -> m ()
-  findEncryptionKey :: PubKey 'Encrypt Schema -> m (Maybe (PrivKey 'Encrypt Schema))
-  enumEncryptionKeys :: m [KeyringEntry Schema]
-
-newtype App m a =
-  App { fromApp :: ReaderT AppEnv m a }
-  deriving newtype ( Applicative
-                   , Functor
-                   , Monad
-                   , MonadIO
-                   , MonadReader AppEnv
-                   , MonadThrow
-                   , MonadCatch
-                   , MonadMask
-                   , MonadUnliftIO
-                   , MonadTrans
-                   )
-
-instance MonadIO m => HasConf (App m) where
-  getConf = asks (view appConf)
-
-
-hPrint :: (Show a, MonadIO m) => Handle -> a -> m ()
-hPrint h s = liftIO $ IO.hPrint h s
-
-hPutStrLn :: (Show a, MonadIO m) => Handle -> String -> m ()
-hPutStrLn h s = liftIO $ IO.hPutStrLn h s
-
-exitSuccess :: MonadIO m => m ()
-exitSuccess = do
-  shutUp
-  liftIO Exit.exitSuccess
-
-exitFailure :: MonadIO m => m ()
-exitFailure = do
-  shutUp
-  liftIO Exit.exitFailure
-
-die :: MonadIO m => String -> m a
-die s = do
-  shutUp
-  pause @'Seconds 0.1
-  liftIO $ Exit.die s
-
-traceTime :: MonadIO m => String -> m a -> m a
-traceTime s action = do
-  (t, x) <- timeItT action
-  trace $ "time" <+> pretty s <+> pretty t
-  pure x
-

hbs2-tests/hbs2-tests.cabal

@@ -947,47 +947,3 @@ executable test-playground
         , resourcet
         , text-icu >= 0.8.0.3
 
-
-executable  test-repo-export
-    import:           shared-properties
-    default-language: Haskell2010
-
-    -- other-extensions:
-
-    hs-source-dirs:   repo-export
-    main-is:          RepoExportMain.hs
-    build-depends:
-          base, hbs2-core, hbs2-peer, hbs2-git
-        , async
-        , bytestring
-        , cache
-        , containers
-        , directory
-        , exceptions
-        , hashable
-        , microlens-platform
-        , mtl
-        , prettyprinter
-        , random
-        , safe
-        , serialise
-        , stm
-        , streaming
-        , transformers
-        , uniplate
-        , vector
-        , simple-logger
-        , string-conversions
-        , filepath
-        , temporary
-        , unliftio
-        , unordered-containers
-        , timeit
-        , memory
-        , deepseq
-        , xxhash-ffi
-        , optparse-generic
-        , interpolatedstring-perl6
-
-
-

hbs21-git/git-hbs21/Main.hs

@@ -1,219 +0,0 @@
-{-# Language UndecidableInstances #-}
-module Main where
-
-import HBS2.Git.Client.Prelude hiding (info)
-import HBS2.Git.Client.App
-import HBS2.Git.Client.Export
-import HBS2.Git.Client.Import
-import HBS2.Git.Client.State
-
-import HBS2.Git.Data.RefLog
-import HBS2.Git.Local.CLI qualified as Git
-import HBS2.Git.Data.Tx qualified as TX
-import HBS2.Git.Data.Tx (RepoHead(..))
-import HBS2.Git.Data.LWWBlock
-import HBS2.Git.Data.GK
-
-import HBS2.Storage.Operations.ByteString
-
-import Options.Applicative as O
-import Data.ByteString.Lazy qualified as LBS
-
-import System.Exit
-
-globalOptions :: Parser [GitOption]
-globalOptions = do
-
-  t <- flag [] [GitTrace]
-           (  long "trace" <> short 't' <> help "allow trace"
-           )
-
-  d <- flag [] [GitDebug]
-           (  long "debug" <> short 'd' <> help "allow debug"
-           )
-
-  pure (t <> d)
-
-commands :: GitPerks m => Parser (GitCLI m ())
-commands =
-  hsubparser (  command "export"  (info pExport  (progDesc "export repo to hbs2-git"))
-             <> command "import" (info pImport  (progDesc "import repo from reflog"))
-             <> command "key"    (info pKey     (progDesc "key management"))
-             <> command "tools"  (info pTools   (progDesc "misc tools"))
-             )
-
-
-pRefLogId :: ReadM RefLogId
-pRefLogId = maybeReader (fromStringMay @RefLogId)
-
-
-pLwwKey :: ReadM (LWWRefKey HBS2Basic)
-pLwwKey = maybeReader fromStringMay
-
-pHashRef :: ReadM HashRef
-pHashRef = maybeReader (fromStringMay @HashRef)
-
-pInit :: GitPerks m => Parser (GitCLI m ())
-pInit = do
-  pure runDefault
-
-
-pExport :: GitPerks m => Parser (GitCLI m ())
-pExport = do
-
-  puk <- argument pLwwKey (metavar "REFLOG-KEY")
-
-  et <- flag ExportInc ExportNew
-           (  long "new" <> help "new is usable to export to a new empty reflog"
-           )
-
-  enc <- flag' ExportPublic (long "public" <> help "create unencrypted reflog")
-          <|>
-          ( ExportPrivate <$>
-                strOption (long "encrypted" <> help "create encrypted reflog"
-                                            <> metavar "GROUP-KEY-FILE")
-          )
-
-  pure do
-    git <- Git.findGitDir >>= orThrowUser "not a git dir"
-    notice (green "git dir" <+> pretty git <+> pretty (AsBase58 puk))
-
-    env <- ask
-
-    withGitEnv ( env & set gitApplyHeads False & set gitExportType et & set gitExportEnc enc) do
-      unless (et == ExportNew) do
-        importRepoWait puk
-
-      export puk mempty
-
-pImport :: GitPerks m => Parser (GitCLI m ())
-pImport = do
-  puk <- argument pLwwKey (metavar "LWWREF")
-
-  pure do
-    git <- Git.findGitDir >>= orThrowUser "not a git dir"
-    importRepoWait puk
-
-pTools :: GitPerks m => Parser (GitCLI m ())
-pTools = hsubparser (  command "dump-pack" (info pDumpPack (progDesc "dump hbs2 git pack"))
-                    <> command "show-ref" (info pShowRef (progDesc "show current references"))
-                    <> command "show-remotes" (info pShowLww (progDesc "show current remotes (hbs2 references)"))
-                    )
-
-
-data DumpOpt = DumpInfoOnly | DumpObjects | DumpPack
-
-pDumpPack :: GitPerks m => Parser (GitCLI m ())
-pDumpPack = do
-  what <- dumpInfoOnly <|> dumpObjects <|> dumpPack
-  pure do
-    co <- liftIO LBS.getContents
-
-    (idSize,idVer,sidx,pack) <- TX.unpackPackMay co
-                                  & orThrowUser "can't unpack the bundle"
-
-    case what of
-      DumpInfoOnly -> do
-        liftIO $ print $ pretty "version:"    <+> pretty idVer  <> line
-                             <> "index size:" <+> pretty idSize <> line
-                             <> "objects:"    <+> pretty (length sidx)
-      DumpObjects -> do
-        liftIO $ print $ vcat (fmap pretty sidx)
-
-      DumpPack -> do
-        liftIO $ LBS.putStr pack
-
-  where
-    dumpInfoOnly = flag DumpInfoOnly DumpInfoOnly
-                      ( long "info-only" )
-
-    dumpObjects = flag DumpObjects DumpObjects
-                      ( long "objects" )
-
-    dumpPack = flag DumpPack DumpPack
-                      ( long "pack" )
-
-
-pShowLww :: GitPerks m => Parser (GitCLI m ())
-pShowLww = pure do
-  items <- withState selectAllLww
-  liftIO $ print $ vcat (fmap fmt items)
-  where
-    fmt (l,n,k) = fill 4 (pretty n) <+> fill 32 (pretty l) <+> fill 32 (pretty (AsBase58 k))
-
-pShowRef :: GitPerks m => Parser (GitCLI m ())
-pShowRef = do
-  pure do
-    sto <- asks _storage
-    void $ runMaybeT do
-
-      tx  <- withState do
-               selectMaxAppliedTx >>= lift  . toMPlus <&> fst
-
-      rh <- TX.readRepoHeadFromTx sto tx >>= toMPlus
-
-      liftIO $ print $ vcat (fmap formatRef (_repoHeadRefs rh))
-
-
-pKey :: GitPerks m => Parser (GitCLI m ())
-pKey = hsubparser (  command "show"   (info pKeyShow  (progDesc "show current key"))
-                  <> command "update" (info pKeyUpdate (progDesc "update current key"))
-                  )
-        <|> pKeyShow
-
-pKeyShow :: GitPerks m => Parser (GitCLI m ())
-pKeyShow = do
-  full <- flag False True (long "full" <> help "show full key info")
-  pure do
-    sto <- asks _storage
-    void $ runMaybeT do
-
-      tx  <- withState do
-               selectMaxAppliedTx >>= lift  . toMPlus <&> fst
-
-      rh <- TX.readRepoHeadFromTx sto tx
-               >>= toMPlus
-
-      gkh <- toMPlus (_repoHeadGK0 rh)
-
-      if not full then do
-        liftIO $ print $ pretty gkh
-      else do
-        gk <- runExceptT (readGK0 sto gkh) >>= toMPlus
-        liftIO $ print $ ";; group key" <+> pretty gkh <> line <> line <> pretty gk
-
-pKeyUpdate :: GitPerks m => Parser (GitCLI m ())
-pKeyUpdate = do
-  rlog <- argument pRefLogId (metavar "REFLOG-KEY")
-  fn <- strArgument (metavar "GROUP-KEY-FILE")
-  pure do
-    gk <- loadGK0FromFile  fn
-            `orDie` "can not load group key or invalid format"
-
-    sto <- asks _storage
-
-    gh <- writeAsMerkle sto (serialise gk) <&> HashRef
-
-    added <- withState $ runMaybeT do
-                (tx,_) <- lift selectMaxAppliedTx >>= toMPlus
-                lift do
-                  insertNewGK0 rlog tx gh
-                  commitAll
-                  pure gh
-
-    case added of
-      Nothing -> liftIO $ putStrLn "not added" >> exitFailure
-      Just x  -> liftIO $ print $ pretty x
-
-main :: IO ()
-main = do
-  (o, action) <- customExecParser (prefs showHelpOnError) $
-                      O.info (liftA2 (,) globalOptions commands <**> helper)
-                        ( fullDesc
-                           <> header "hbs2-git"
-                           <> progDesc "hbs2-git"
-                        )
-
-  runGitCLI o action
-
-

hbs21-git/hbs21-git.cabal

@@ -1,170 +0,0 @@
-cabal-version:      3.0
-name:               hbs21-git
-version:            0.24.1.0
--- synopsis:
--- description:
-license:            BSD-3-Clause
-license-file:       LICENSE
-author:             Dmitry Zuikov
-maintainer:         dzuikov@gmail.com
--- copyright:
-category:           System
-build-type:         Simple
--- extra-doc-files:    CHANGELOG.md
--- extra-source-files:
-
-common shared-properties
-  ghc-options:
-        -Wall
-        -fno-warn-type-defaults
-        -threaded
-        -rtsopts
-        -O2
-        "-with-rtsopts=-N4 -A64m -AL256m -I0"
-
-  default-language: GHC2021
-
-  default-extensions:
-                       ApplicativeDo
-                     , BangPatterns
-                     , BlockArguments
-                     , ConstraintKinds
-                     , DataKinds
-                     , DeriveDataTypeable
-                     , DeriveGeneric
-                     , DerivingStrategies
-                     , DerivingVia
-                     , ExtendedDefaultRules
-                     , FlexibleContexts
-                     , FlexibleInstances
-                     , GADTs
-                     , GeneralizedNewtypeDeriving
-                     , ImportQualifiedPost
-                     , LambdaCase
-                     , MultiParamTypeClasses
-                     , OverloadedStrings
-                     , QuasiQuotes
-                     , RecordWildCards
-                     , ScopedTypeVariables
-                     , StandaloneDeriving
-                     , TupleSections
-                     , TypeApplications
-                     , TypeFamilies
-
-
-  build-depends:
-        hbs2-core
-      , hbs2-peer
-      , hbs2-storage-simple
-      , hbs2-keyman
-      , db-pipe
-      , suckless-conf
-
-      , attoparsec
-      , atomic-write
-      , bytestring
-      , binary
-      , containers
-      , directory
-      , exceptions
-      , filepath
-      , filepattern
-      , interpolatedstring-perl6
-      , memory
-      , microlens-platform
-      , mtl
-      , safe
-      , serialise
-      , streaming
-      , stm
-      , text
-      , time
-      , timeit
-      , transformers
-      , typed-process
-      , unordered-containers
-      , unliftio
-      , unliftio-core
-      , zlib
-      , prettyprinter
-      , prettyprinter-ansi-terminal
-      , random
-      , vector
-      , unix
-
-
-library hbs2-git-client-lib
-    import:           shared-properties
-
-    exposed-modules:
-      HBS2.Git.Local
-      HBS2.Git.Local.CLI
-
-      HBS2.Git.Data.Tx
-      HBS2.Git.Data.GK
-      HBS2.Git.Data.RefLog
-      HBS2.Git.Data.LWWBlock
-
-      HBS2.Git.Client.Prelude
-      HBS2.Git.Client.App.Types
-      HBS2.Git.Client.App.Types.GitEnv
-      HBS2.Git.Client.App
-      HBS2.Git.Client.Config
-      HBS2.Git.Client.State
-      HBS2.Git.Client.RefLog
-      HBS2.Git.Client.Export
-      HBS2.Git.Client.Import
-      HBS2.Git.Client.Progress
-
-    build-depends:    base
-                    , base16-bytestring
-                    , binary
-                    , unix
-
-    hs-source-dirs:   hbs2-git-client-lib
-
-
-executable hbs2-git-subscribe
-    import:           shared-properties
-    main-is:          Main.hs
-    -- other-modules:
-    -- other-extensions:
-    build-depends:
-        base, hbs2-git-client-lib
-        , binary
-        , vector
-        , optparse-applicative
-
-    hs-source-dirs:   git-hbs2-subscribe
-    default-language: GHC2021
-
-executable git-hbs21
-    import:           shared-properties
-    main-is:          Main.hs
-    -- other-modules:
-    -- other-extensions:
-    build-depends:
-        base, hbs2-git-client-lib
-        , binary
-        , vector
-        , optparse-applicative
-
-    hs-source-dirs:   git-hbs21
-    default-language: GHC2021
-
-
-executable git-remote-hbs21
-    import:           shared-properties
-    main-is:          Main.hs
-    -- other-modules:
-    -- other-extensions:
-    build-depends:
-        base, hbs2-git-client-lib
-        , binary
-        , vector
-        , optparse-applicative
-
-    hs-source-dirs:   git-remote-hbs21
-    default-language: GHC2021
-
-