mirror of https://github.com/voidlizard/hbs2
git hbs2 init
This commit is contained in:
Dmitry Zuikov
parent
e7f4adb9a1
commit
6069abb33e
|
|
@ -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")
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue