diff --git a/Makefile b/Makefile index 3275bc56..22dbd6d0 100644 --- a/Makefile +++ b/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) diff --git a/flake.nix b/flake.nix index 03b6c0a3..8373d009 100644 --- a/flake.nix +++ b/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"; }; diff --git a/hbs2-core/lib/HBS2/Net/Auth/Schema.hs b/hbs2-core/lib/HBS2/Net/Auth/Schema.hs index 3f578356..5c4150e2 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Schema.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/System/Dir.hs b/hbs2-core/lib/HBS2/System/Dir.hs index 77356a27..18f49514 100644 --- a/hbs2-core/lib/HBS2/System/Dir.hs +++ b/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 UnliftIO hiding (try) - +import System.Directory qualified as D +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 diff --git a/hbs2-fixer/app/Main.hs b/hbs2-fixer/app/Main.hs index 0ade0a67..a912737d 100644 --- a/hbs2-fixer/app/Main.hs +++ b/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 diff --git a/hbs2-git-reposync/LICENSE b/hbs2-git-reposync/LICENSE deleted file mode 100644 index 3086ee5d..00000000 --- a/hbs2-git-reposync/LICENSE +++ /dev/null @@ -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. diff --git a/hbs2-git-reposync/ReposyncMain.hs b/hbs2-git-reposync/ReposyncMain.hs deleted file mode 100644 index 381cfec0..00000000 --- a/hbs2-git-reposync/ReposyncMain.hs +++ /dev/null @@ -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 - diff --git a/hbs2-git-reposync/examples/config b/hbs2-git-reposync/examples/config deleted file mode 100644 index eed546cb..00000000 --- a/hbs2-git-reposync/examples/config +++ /dev/null @@ -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") -] - - - diff --git a/hbs2-git-reposync/hbs2-git-reposync.cabal b/hbs2-git-reposync/hbs2-git-reposync.cabal deleted file mode 100644 index 9b32e9fc..00000000 --- a/hbs2-git-reposync/hbs2-git-reposync.cabal +++ /dev/null @@ -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 - - diff --git a/hbs2-git/CHANGELOG.md b/hbs2-git/CHANGELOG.md deleted file mode 100644 index 30f0d555..00000000 --- a/hbs2-git/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for hbs2-git - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/hbs2-git/LICENSE b/hbs2-git/LICENSE index 3086ee5d..e69de29b 100644 --- a/hbs2-git/LICENSE +++ b/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. diff --git a/hbs2-git/examples/config/encrypted-ref b/hbs2-git/examples/config/encrypted-ref deleted file mode 100644 index 815ee636..00000000 --- a/hbs2-git/examples/config/encrypted-ref +++ /dev/null @@ -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") -] - - diff --git a/hbs2-git/examples/config/encrypted-ref-2 b/hbs2-git/examples/config/encrypted-ref-2 deleted file mode 100644 index 8d1ea976..00000000 --- a/hbs2-git/examples/config/encrypted-ref-2 +++ /dev/null @@ -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") -] - diff --git a/hbs21-git/git-hbs2-subscribe/Main.hs b/hbs2-git/git-hbs2-subscribe/Main.hs similarity index 100% rename from hbs21-git/git-hbs2-subscribe/Main.hs rename to hbs2-git/git-hbs2-subscribe/Main.hs diff --git a/hbs2-git/git-hbs2/GitRemoteMain.hs b/hbs2-git/git-hbs2/GitRemoteMain.hs deleted file mode 100644 index c7b589ba..00000000 --- a/hbs2-git/git-hbs2/GitRemoteMain.hs +++ /dev/null @@ -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 "" - diff --git a/hbs2-git/git-hbs2/GitRemotePush.hs b/hbs2-git/git-hbs2/GitRemotePush.hs deleted file mode 100644 index 4f60a8ec..00000000 --- a/hbs2-git/git-hbs2/GitRemotePush.hs +++ /dev/null @@ -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 - diff --git a/hbs2-git/git-hbs2/GitRemoteTypes.hs b/hbs2-git/git-hbs2/GitRemoteTypes.hs deleted file mode 100644 index b33b70ef..00000000 --- a/hbs2-git/git-hbs2/GitRemoteTypes.hs +++ /dev/null @@ -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 ] - diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index f5b1fc42..d21f58d5 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -1,122 +1,219 @@ +{-# Language UndecidableInstances #-} module Main where -import HBS2.Prelude -import HBS2.OrDie +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 HBS2Git.App -import HBS2Git.Export -import HBS2Git.Tools -import HBS2Git.KeysCommand -import HBS2.Version +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 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) $ - info (helper <*> parser) - ( fullDesc - <> header "git-hbs2" - <> progDesc "helper tool for 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")) +main = do + (o, action) <- customExecParser (prefs showHelpOnError) $ + O.info (liftA2 (,) globalOptions commands <**> helper) + ( fullDesc + <> header "hbs2-git" + <> progDesc "hbs2-git" ) - pVersion = pure do - 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 " | 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) + runGitCLI o action - 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") - diff --git a/hbs2-git/git-hbs2/RunShow.hs b/hbs2-git/git-hbs2/RunShow.hs deleted file mode 100644 index d69fbb14..00000000 --- a/hbs2-git/git-hbs2/RunShow.hs +++ /dev/null @@ -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 diff --git a/hbs21-git/git-remote-hbs21/Main.hs b/hbs2-git/git-remote-hbs2/Main.hs similarity index 100% rename from hbs21-git/git-remote-hbs21/Main.hs rename to hbs2-git/git-remote-hbs2/Main.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Config.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Config.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Config.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Config.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Local.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Local.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs diff --git a/hbs21-git/hbs2-git-client-lib/HBS2/Git/Local/CLI.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local/CLI.hs similarity index 100% rename from hbs21-git/hbs2-git-client-lib/HBS2/Git/Local/CLI.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Local/CLI.hs diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 9ef97a3d..f5cc753f 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/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 - -fprint-potential-instances - -- -fno-warn-unused-matches - -- -fno-warn-unused-do-bind - -- -Werror=missing-methods - -- -Werror=incomplete-patterns - -- -fno-warn-unused-binds + -fno-warn-type-defaults + -threaded + -rtsopts + -O2 + "-with-rtsopts=-N4 -A64m -AL256m -I0" - - default-language: Haskell2010 + default-language: GHC2021 default-extensions: ApplicativeDo @@ -52,147 +49,122 @@ common shared-properties , 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 + build-depends: + hbs2-core + , hbs2-peer + , hbs2-storage-simple + , hbs2-keyman + , db-pipe + , suckless-conf -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 - , exceptions - , terminal-progress-bar - , http-types - , uuid - , zlib + build-depends: + base, hbs2-git-client-lib + , binary + , vector + , optparse-applicative - hs-source-dirs: lib - default-language: Haskell2010 + hs-source-dirs: git-hbs2-subscribe + default-language: GHC2021 executable git-hbs2 import: shared-properties main-is: Main.hs - - ghc-options: - -threaded - -rtsopts - "-with-rtsopts=-N4 -A64m -AL256m -I0" - - other-modules: - RunShow - Paths_hbs2_git - + -- other-modules: -- other-extensions: build-depends: - base, hbs2-git - , optparse-applicative - , http-types - , template-haskell + base, hbs2-git-client-lib + , binary + , vector + , optparse-applicative hs-source-dirs: git-hbs2 - default-language: Haskell2010 + default-language: GHC2021 executable git-remote-hbs2 import: shared-properties - main-is: GitRemoteMain.hs - - ghc-options: - -threaded - -rtsopts - "-with-rtsopts=-N4 -A64m -AL256m -I0" - - other-modules: - GitRemoteTypes - GitRemotePush - + main-is: Main.hs + -- other-modules: -- other-extensions: build-depends: - base, hbs2-git - , async - , attoparsec - , optparse-applicative - , unix - , unliftio - , terminal-progress-bar - , http-types - - hs-source-dirs: git-hbs2 - default-language: Haskell2010 + base, hbs2-git-client-lib + , binary + , vector + , optparse-applicative + hs-source-dirs: git-remote-hbs2 + default-language: GHC2021 diff --git a/hbs2-git/hie.yaml b/hbs2-git/hie.yaml deleted file mode 100644 index 04cd2439..00000000 --- a/hbs2-git/hie.yaml +++ /dev/null @@ -1,2 +0,0 @@ -cradle: - cabal: diff --git a/hbs2-git/lib/HBS2/Git/Local.hs b/hbs2-git/lib/HBS2/Git/Local.hs deleted file mode 100644 index a8e3a9b6..00000000 --- a/hbs2-git/lib/HBS2/Git/Local.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-git/lib/HBS2/Git/Local/CLI.hs b/hbs2-git/lib/HBS2/Git/Local/CLI.hs deleted file mode 100644 index b8bd5910..00000000 --- a/hbs2-git/lib/HBS2/Git/Local/CLI.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-git/lib/HBS2/Git/Types.hs b/hbs2-git/lib/HBS2/Git/Types.hs deleted file mode 100644 index 8cd329a1..00000000 --- a/hbs2-git/lib/HBS2/Git/Types.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-git/lib/HBS2Git/Alerts.hs b/hbs2-git/lib/HBS2Git/Alerts.hs deleted file mode 100644 index 9c8e3449..00000000 --- a/hbs2-git/lib/HBS2Git/Alerts.hs +++ /dev/null @@ -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|] diff --git a/hbs2-git/lib/HBS2Git/Annotations.hs b/hbs2-git/lib/HBS2Git/Annotations.hs deleted file mode 100644 index ab87cf14..00000000 --- a/hbs2-git/lib/HBS2Git/Annotations.hs +++ /dev/null @@ -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 - - - - diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs deleted file mode 100644 index 4c343ba0..00000000 --- a/hbs2-git/lib/HBS2Git/App.hs +++ /dev/null @@ -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) - diff --git a/hbs2-git/lib/HBS2Git/Config.hs b/hbs2-git/lib/HBS2Git/Config.hs deleted file mode 100644 index 3cdbd230..00000000 --- a/hbs2-git/lib/HBS2Git/Config.hs +++ /dev/null @@ -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)) - diff --git a/hbs2-git/lib/HBS2Git/Encryption.hs b/hbs2-git/lib/HBS2Git/Encryption.hs deleted file mode 100644 index a4ef507d..00000000 --- a/hbs2-git/lib/HBS2Git/Encryption.hs +++ /dev/null @@ -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 ) - diff --git a/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs b/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs deleted file mode 100644 index abbf8112..00000000 --- a/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs +++ /dev/null @@ -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 diff --git a/hbs2-git/lib/HBS2Git/Evolve.hs b/hbs2-git/lib/HBS2Git/Evolve.hs deleted file mode 100644 index 30e780ad..00000000 --- a/hbs2-git/lib/HBS2Git/Evolve.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-git/lib/HBS2Git/Export.hs b/hbs2-git/lib/HBS2Git/Export.hs deleted file mode 100644 index 3e402c90..00000000 --- a/hbs2-git/lib/HBS2Git/Export.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-git/lib/HBS2Git/GitRepoLog.hs b/hbs2-git/lib/HBS2Git/GitRepoLog.hs deleted file mode 100644 index 1ead5034..00000000 --- a/hbs2-git/lib/HBS2Git/GitRepoLog.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-git/lib/HBS2Git/Import.hs b/hbs2-git/lib/HBS2Git/Import.hs deleted file mode 100644 index 1be13ab1..00000000 --- a/hbs2-git/lib/HBS2Git/Import.hs +++ /dev/null @@ -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 - diff --git a/hbs2-git/lib/HBS2Git/KeysCommand.hs b/hbs2-git/lib/HBS2Git/KeysCommand.hs deleted file mode 100644 index 6bb21088..00000000 --- a/hbs2-git/lib/HBS2Git/KeysCommand.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-git/lib/HBS2Git/KeysMetaData.hs b/hbs2-git/lib/HBS2Git/KeysMetaData.hs deleted file mode 100644 index eb6c60a2..00000000 --- a/hbs2-git/lib/HBS2Git/KeysMetaData.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-git/lib/HBS2Git/Prelude.hs b/hbs2-git/lib/HBS2Git/Prelude.hs deleted file mode 100644 index 1c421ba5..00000000 --- a/hbs2-git/lib/HBS2Git/Prelude.hs +++ /dev/null @@ -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 - diff --git a/hbs2-git/lib/HBS2Git/PrettyStuff.hs b/hbs2-git/lib/HBS2Git/PrettyStuff.hs deleted file mode 100644 index f3f4570b..00000000 --- a/hbs2-git/lib/HBS2Git/PrettyStuff.hs +++ /dev/null @@ -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 :: - diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs deleted file mode 100644 index 0ef1b55d..00000000 --- a/hbs2-git/lib/HBS2Git/State.hs +++ /dev/null @@ -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 - diff --git a/hbs2-git/lib/HBS2Git/Tools.hs b/hbs2-git/lib/HBS2Git/Tools.hs deleted file mode 100644 index 52f0433d..00000000 --- a/hbs2-git/lib/HBS2Git/Tools.hs +++ /dev/null @@ -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 - - diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs deleted file mode 100644 index b3f55d97..00000000 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ /dev/null @@ -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 - diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index 784edb2d..424e10a5 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/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 - - - diff --git a/hbs21-git/LICENSE b/hbs21-git/LICENSE deleted file mode 100644 index e69de29b..00000000 diff --git a/hbs21-git/git-hbs21/Main.hs b/hbs21-git/git-hbs21/Main.hs deleted file mode 100644 index d21f58d5..00000000 --- a/hbs21-git/git-hbs21/Main.hs +++ /dev/null @@ -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 - - diff --git a/hbs21-git/hbs21-git.cabal b/hbs21-git/hbs21-git.cabal deleted file mode 100644 index 6db693e6..00000000 --- a/hbs21-git/hbs21-git.cabal +++ /dev/null @@ -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 - -