diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index 737586cc..a70a4bf3 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -5,7 +5,7 @@ import HBS2.OrDie import HBS2Git.App import HBS2Git.Export -import HBS2Git.ListRefs +import HBS2Git.Tools import HBS2Git.KeysCommand import HBS2.Net.Proto.Definition() @@ -23,7 +23,7 @@ main = join . customExecParser (prefs showHelpOnError) $ ) where parser :: Parser (IO ()) - parser = hsubparser ( command "export" (info pExport (progDesc "export repo")) + 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")) @@ -49,6 +49,7 @@ main = join . customExecParser (prefs showHelpOnError) $ 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")) ) @@ -84,4 +85,30 @@ main = join . customExecParser (prefs showHelpOnError) $ 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 index 2c68bc05..d69fbb14 100644 --- a/hbs2-git/git-hbs2/RunShow.hs +++ b/hbs2-git/git-hbs2/RunShow.hs @@ -6,7 +6,7 @@ import HBS2.Base58 import HBS2Git.App import HBS2Git.State import HBS2Git.Config -import HBS2Git.ListRefs +import HBS2Git.Tools import HBS2Git.PrettyStuff import Control.Monad.Catch (MonadMask) diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index ad9e4407..cfaca4ff 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -72,6 +72,7 @@ common shared-properties , filelock , filepath , filepattern + , generic-lens , hashable , http-conduit , interpolatedstring-perl6 @@ -117,7 +118,7 @@ library HBS2Git.GitRepoLog HBS2Git.Import HBS2Git.KeysCommand - HBS2Git.ListRefs + HBS2Git.Tools HBS2.Git.Local HBS2.Git.Local.CLI HBS2Git.PrettyStuff diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index 374f274d..621752c6 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -73,7 +73,12 @@ import Prettyprinter.Render.Terminal import Streaming.Prelude qualified as S -import UnliftIO +import UnliftIO as UIO + +data NoRPCException = NoRPCException + deriving stock (Show, Typeable) + +instance Exception NoRPCException -- instance HasTimeLimits UNIX (ServiceProto PeerAPI UNIX) m where @@ -158,7 +163,29 @@ withApp :: MonadIO m => AppEnv -> App m a -> m a withApp env m = runReaderT (fromApp m) env -runWithRPC :: forall m . MonadUnliftIO m => (RPCEndpoints -> m ()) -> m () +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 @@ -167,7 +194,7 @@ runWithRPC action = do | ListVal (Key "rpc" [SymbolVal "unix", LitStrVal n]) <- syn ] - soname <- race ( pause @'Seconds 1) (maybe detectRPC pure soname') `orDie` "hbs2-peer rpc timeout!" + soname <- race ( pause @'Seconds 1) (maybe (detectRPC False) pure soname') `orDie` "hbs2-peer rpc timeout!" client <- race ( pause @'Seconds 1) (newMessagingUnix False 1.0 soname) `orDie` "hbs2-peer rpc timeout!" @@ -198,63 +225,60 @@ runWithRPC action = do void $ waitAnyCatchCancel [messaging, c1] - where +runInit :: (MonadUnliftIO m, MonadThrow m) => m () -> m () +runInit m = m - detectRPC = do - (_, o, _) <- readProcess (shell [qc|hbs2-peer poke|]) - - let answ = parseTop (LBS.unpack o) & fromRight mempty - - so <- pure (headMay [ Text.unpack r | ListVal (Key "rpc:" [LitStrVal r]) <- answ ]) - `orDie` "hbs2-peer rpc not detected" - - -- 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 - -runApp :: MonadUnliftIO m => WithLog -> App m () -> m () +runApp :: (MonadUnliftIO m, MonadThrow m) => WithLog -> App m () -> m () runApp l m = do - case l of - NoLog -> pure () - WithLog -> do - setLogging @ERROR errorPrefix - setLogging @NOTICE noticePrefix - setLogging @INFO infoPrefix + flip UIO.catches dealWithException do - doTrace <- liftIO $ lookupEnv "HBS2TRACE" <&> isJust + 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) - if doTrace then do - setLogging @DEBUG debugPrefix - setLogging @TRACE tracePrefix - else do setLoggingOff @DEBUG + setLoggingOff @ERROR + setLoggingOff @NOTICE setLoggingOff @TRACE + setLoggingOff @INFO - evolve + where + dealWithException = [ noWorkDir ] - (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 + 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 diff --git a/hbs2-git/lib/HBS2Git/Config.hs b/hbs2-git/lib/HBS2Git/Config.hs index 7813b2f5..3cdbd230 100644 --- a/hbs2-git/lib/HBS2Git/Config.hs +++ b/hbs2-git/lib/HBS2Git/Config.hs @@ -14,17 +14,25 @@ import HBS2Git.Types import Control.Applicative -import Data.Functor +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" @@ -47,30 +55,35 @@ configPathOld pwd = liftIO do home <- liftIO getHomeDirectory pure $ xdg makeRelative home pwd -configPath :: MonadIO m => FilePath -> m FilePath -configPath _ = liftIO do +configPath :: (MonadIO m, MonadThrow m) => FilePath -> m FilePath +configPath _ = do pwd <- liftIO getCurrentDirectory git <- findGitDir pwd - byEnv <- lookupEnv "GIT_DIR" + byEnv <- liftIO $ lookupEnv "GIT_DIR" bare <- if isJust (git <|> byEnv) then do pure Nothing - else do + else runMaybeT do -- check may be it's a bare git repo - gitConf <- readFile "config" - <&> parseTop - <&> fromRight mempty + 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 $ Just pwd + pure pwd else - pure Nothing + MaybeT $ pure Nothing - path <- pure (dropSuffix <$> (git <|> byEnv <|> bare)) `orDie` "*** hbs2-git: .git directory not found" + let maybePath = dropSuffix <$> (git <|> byEnv <|> bare) + + path <- maybe (throwM NoWorkDirException) + pure + maybePath pure (path ".hbs2") @@ -86,7 +99,7 @@ data ConfigPathInfo = ConfigPathInfo { } deriving (Eq, Show) -- returns git repository parent dir, config directory and config file path -getConfigPathInfo :: MonadIO m => m ConfigPathInfo +getConfigPathInfo :: (MonadIO m, MonadThrow m) => m ConfigPathInfo getConfigPathInfo = do trace "getConfigPathInfo" confP <- configPath "" @@ -100,7 +113,7 @@ getConfigPathInfo = do } -- returns current directory, where found .git directory -configInit :: MonadIO m => m (FilePath, [Syntax C]) +configInit :: (MonadIO m, MonadThrow m) => m (FilePath, [Syntax C]) configInit = liftIO do trace "configInit" ConfigPathInfo{..} <- getConfigPathInfo @@ -114,7 +127,7 @@ configInit = liftIO do cfg <- readFile configFilePath <&> parseTop <&> either mempty id pure (configRepoParentDir, cfg) -cookieFile :: MonadIO m => m FilePath +cookieFile :: (MonadIO m, MonadThrow m) => m FilePath cookieFile = configPath "" <&> ( "cookie") getAppStateDir :: forall m . MonadIO m => m FilePath diff --git a/hbs2-git/lib/HBS2Git/Evolve.hs b/hbs2-git/lib/HBS2Git/Evolve.hs index 43da9a8c..30e780ad 100644 --- a/hbs2-git/lib/HBS2Git/Evolve.hs +++ b/hbs2-git/lib/HBS2Git/Evolve.hs @@ -11,6 +11,7 @@ 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 @@ -22,7 +23,7 @@ import UnliftIO -- новыми версиями. -- например, переносит конфиг -evolve :: MonadIO m => m () +evolve :: (MonadIO m, MonadThrow m) => m () evolve = void $ runMaybeT do here <- liftIO getCurrentDirectory @@ -43,7 +44,7 @@ makePolled ref = do n <- liftIO $ randomRIO (4,7) void $ callService @RpcPollAdd rpc (fromRefLogKey ref, "reflog", n) -generateCookie :: MonadIO m => m () +generateCookie :: (MonadIO m, MonadThrow m) => m () generateCookie = void $ runMaybeT do file <- cookieFile @@ -57,7 +58,7 @@ generateCookie = void $ runMaybeT do liftIO $ writeFile file "" -migrateConfig :: MonadIO m => m () +migrateConfig :: (MonadIO m, MonadThrow m) => m () migrateConfig = void $ runMaybeT do here <- liftIO getCurrentDirectory diff --git a/hbs2-git/lib/HBS2Git/ListRefs.hs b/hbs2-git/lib/HBS2Git/ListRefs.hs deleted file mode 100644 index fb5559f7..00000000 --- a/hbs2-git/lib/HBS2Git/ListRefs.hs +++ /dev/null @@ -1,112 +0,0 @@ -module HBS2Git.ListRefs where - -import HBS2.Prelude - -import HBS2Git.Types -import HBS2.Prelude -import HBS2Git.App -import HBS2.Data.Types.Refs (HashRef) - -import HBS2.System.Logger.Simple -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.Functor -import Data.Text qualified as Text -import Data.Traversable -import Prettyprinter.Render.Terminal -import Control.Monad.IO.Unlift -import Control.Monad.Catch -import System.IO (stdout) - -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 - diff --git a/hbs2-git/lib/HBS2Git/State.hs b/hbs2-git/lib/HBS2Git/State.hs index 8dcd0a78..68b524e2 100644 --- a/hbs2-git/lib/HBS2Git/State.hs +++ b/hbs2-git/lib/HBS2Git/State.hs @@ -145,7 +145,7 @@ shutdownDB env = liftIO do pure conn maybe1 co none close -stateInit :: MonadIO m => DB m () +stateInit :: (MonadIO m, MonadThrow m) => DB m () stateInit = do conn <- stateConnection liftIO $ execute_ conn [qc| @@ -304,7 +304,7 @@ stateInit = do let fs = [x | ((_, x, _, _, _, _) :: (Int, String, String, Int, Maybe String, Int)) <- fields ] pure ( col `elem` fs ) -readOrCreateCookie :: MonadIO m => DB m Cookie +readOrCreateCookie :: (MonadIO m, MonadThrow m) => DB m Cookie readOrCreateCookie = do cfn <- cookieFile cf <- liftIO $ readFile cfn <&> take 4096 diff --git a/hbs2-git/lib/HBS2Git/Tools.hs b/hbs2-git/lib/HBS2Git/Tools.hs new file mode 100644 index 00000000..d2392c7c --- /dev/null +++ b/hbs2-git/lib/HBS2Git/Tools.hs @@ -0,0 +1,306 @@ +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 Control.Monad.Trans.Maybe +import Data.Text qualified as Text +import Data.Traversable +import Data.Maybe +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.FilePattern.Directory +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 "" + + 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 $ 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 + +