mirror of https://github.com/voidlizard/hbs2
merged 3qQz3NXAeX [] git-hbs2-show
This commit is contained in:
Dmitry Zuikov
parent
8b0e63dab9
commit
a6b7b91988
|
|
@ -1,2 +1,3 @@
|
|||
(fixme-set "assigned" "voidlizard" "vksb7zZbUm")
|
||||
(fixme-set "workflow" "wip" "vksb7zZbUm")
|
||||
(fixme-set "workflow" "test" "3qQz3NXAeX")
|
||||
|
||||
(fixme-set "assigned" "3qQz3NXAeX" "voidlizard")
|
||||
|
|
@ -1,7 +1,6 @@
|
|||
module Main where
|
||||
|
||||
import HBS2.Prelude
|
||||
import HBS2.System.Logger.Simple hiding (info)
|
||||
|
||||
import HBS2Git.App
|
||||
import HBS2Git.Export
|
||||
|
|
@ -23,7 +22,7 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
parser :: Parser (IO ())
|
||||
parser = hsubparser ( command "export" (info pExport (progDesc "export repo"))
|
||||
<> command "list-refs" (info pListRefs (progDesc "list refs"))
|
||||
<> command "show" (info pShow (progDesc "show current state"))
|
||||
<> command "show" (info pShow (progDesc "show various types of objects"))
|
||||
)
|
||||
|
||||
pExport = do
|
||||
|
|
@ -34,7 +33,11 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
pListRefs = do
|
||||
pure $ runApp NoLog runListRefs
|
||||
|
||||
pShow = do
|
||||
ref <- strArgument (metavar "HASH-REF")
|
||||
pure $ runApp NoLog (runShow ref)
|
||||
showReader s = if s == "config"
|
||||
then Just ShowConfig
|
||||
else ShowRef <$> fromStringMay s
|
||||
|
||||
pShow = do
|
||||
object <- optional $
|
||||
argument (maybeReader showReader) (metavar "object" <> help "<HASH-REF> | config")
|
||||
pure $ runApp NoLog (runShow object)
|
||||
|
|
|
|||
|
|
@ -3,29 +3,46 @@ module RunShow where
|
|||
import HBS2.Prelude
|
||||
import HBS2.Base58
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
import HBS2.Git.Types
|
||||
import HBS2Git.App
|
||||
import HBS2Git.State
|
||||
import HBS2Git.Config
|
||||
import HBS2Git.ListRefs
|
||||
|
||||
import Data.Foldable
|
||||
|
||||
runShow :: MonadIO m => RepoRef -> App m ()
|
||||
runShow h = do
|
||||
shutUp
|
||||
setLogging @INFO infoPrefix
|
||||
data ShowObject = ShowRef RepoRef | ShowConfig
|
||||
|
||||
showRef :: MonadIO m => RepoRef -> App m ()
|
||||
showRef h = do
|
||||
db <- makeDbPath h >>= dbEnv
|
||||
|
||||
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)
|
||||
|
||||
info $ "current state for" <+> pretty (AsBase58 h)
|
||||
info $ "head:" <+> pretty hd
|
||||
info $ "last operations:" <> line
|
||||
showRefs :: MonadIO m => App m ()
|
||||
showRefs = do
|
||||
liftIO $ print $ pretty "References:"
|
||||
runListRefs
|
||||
|
||||
for_ imported $ \(t,h1,h2) -> do
|
||||
info $ pretty t <+> pretty h1 <+> pretty h2
|
||||
showConfig :: MonadIO m => App m ()
|
||||
showConfig = liftIO do
|
||||
ConfigPathInfo{..} <- getConfigPathInfo
|
||||
cfg <- readFile configFilePath
|
||||
print $ "Config file location:" <> line <> pretty configFilePath <> line
|
||||
print $ "Config contents:" <> line <> pretty cfg
|
||||
|
||||
showSummary :: MonadIO m => App m ()
|
||||
showSummary = do
|
||||
showRefs
|
||||
liftIO $ print $ pretty ""
|
||||
showConfig
|
||||
|
||||
runShow :: MonadIO m => Maybe ShowObject -> App m ()
|
||||
runShow (Just (ShowRef h)) = showRef h
|
||||
runShow (Just ShowConfig) = showConfig
|
||||
runShow Nothing = showSummary
|
||||
|
|
|
|||
|
|
@ -20,8 +20,10 @@ import System.Directory
|
|||
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
|
||||
|
|
@ -31,48 +33,51 @@ findGitDir dir = liftIO do
|
|||
then return Nothing
|
||||
else findGitDir parentDir
|
||||
|
||||
-- Finds .git dir inside current directory moving upwards
|
||||
findWorkingGitDir :: MonadIO m => m FilePath
|
||||
findWorkingGitDir = do
|
||||
this <- liftIO getCurrentDirectory
|
||||
findGitDir this `orDie` ".git directory not found"
|
||||
|
||||
configPath :: MonadIO m => FilePath -> m FilePath
|
||||
configPath pwd = liftIO do
|
||||
xdg <- liftIO $ getXdgDirectory XdgConfig appName
|
||||
home <- liftIO getHomeDirectory
|
||||
gitDir <- findGitDir pwd `orDie` ".git directory not found"
|
||||
pure $ xdg </> makeRelative home pwd
|
||||
|
||||
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 => m ConfigPathInfo
|
||||
getConfigPathInfo = do
|
||||
trace "getConfigPathInfo"
|
||||
gitDir <- findWorkingGitDir
|
||||
let pwd = takeDirectory gitDir
|
||||
confP <- configPath pwd
|
||||
let confFile = confP </> "config"
|
||||
trace $ "git dir" <+> pretty gitDir
|
||||
trace $ "confPath:" <+> pretty confP
|
||||
pure ConfigPathInfo {
|
||||
configRepoParentDir = pwd,
|
||||
configDir = confP,
|
||||
configFilePath = confFile
|
||||
}
|
||||
|
||||
-- returns current directory, where found .git directory
|
||||
configInit :: MonadIO m => m (FilePath, [Syntax C])
|
||||
configInit = liftIO do
|
||||
trace "configInit"
|
||||
|
||||
trace "locating .git directory"
|
||||
|
||||
this <- getCurrentDirectory
|
||||
|
||||
gitDir <- findGitDir this `orDie` ".git directory not found"
|
||||
|
||||
let pwd = takeDirectory gitDir
|
||||
|
||||
confP <- configPath pwd
|
||||
|
||||
trace $ "git dir" <+> pretty gitDir
|
||||
trace $ "confPath:" <+> pretty confP
|
||||
|
||||
here <- doesDirectoryExist confP
|
||||
|
||||
ConfigPathInfo{..} <- getConfigPathInfo
|
||||
here <- doesDirectoryExist configDir
|
||||
unless here do
|
||||
debug $ "create directory" <+> pretty confP
|
||||
createDirectoryIfMissing True confP
|
||||
|
||||
let confFile = confP </> "config"
|
||||
|
||||
confHere <- doesFileExist confFile
|
||||
|
||||
debug $ "create directory" <+> pretty configDir
|
||||
createDirectoryIfMissing True configDir
|
||||
confHere <- doesFileExist configFilePath
|
||||
unless confHere do
|
||||
appendFile confFile ""
|
||||
|
||||
cfg <- readFile confFile <&> parseTop <&> either mempty id
|
||||
|
||||
pure (pwd, cfg)
|
||||
|
||||
|
||||
|
||||
appendFile configFilePath ""
|
||||
cfg <- readFile configFilePath <&> parseTop <&> either mempty id
|
||||
pure (configRepoParentDir, cfg)
|
||||
|
|
|
|||
|
|
@ -1,19 +1,39 @@
|
|||
module HBS2Git.ListRefs where
|
||||
|
||||
import HBS2Git.Types
|
||||
import HBS2.Prelude
|
||||
import HBS2Git.App
|
||||
import HBS2.Data.Types.Refs (HashRef)
|
||||
|
||||
import HBS2.Git.Local.CLI
|
||||
|
||||
import Data.Functor
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as Text
|
||||
import Prettyprinter
|
||||
import Data.Traversable
|
||||
|
||||
newtype AsRemoteEntry = AsRemoteEntry (Text,Text)
|
||||
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 (x,y)) = fill 16 (pretty x) <+> pretty y
|
||||
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 которая выведет
|
||||
|
|
@ -23,8 +43,41 @@ instance Pretty AsRemoteEntry where
|
|||
runListRefs :: MonadIO m => App m ()
|
||||
runListRefs = do
|
||||
refs <- gitGetRemotes <&> filter isHbs2
|
||||
liftIO $ print $ vcat (fmap (pretty.AsRemoteEntry) refs)
|
||||
|
||||
remoteEntries <-
|
||||
forM
|
||||
refs
|
||||
( \(name, url) -> do
|
||||
refVal <- getRefVal url
|
||||
pure $
|
||||
AsRemoteEntry
|
||||
{ remoteName = name,
|
||||
remoteURL = url,
|
||||
remoteRefValue = refVal
|
||||
}
|
||||
)
|
||||
let header =
|
||||
fill remoteNameColWidth "Name"
|
||||
<+> fill remoteURLColWidth "URL"
|
||||
<+> fill remoteRefValueColWidth "Reference value"
|
||||
liftIO $ print header
|
||||
liftIO $ print $ vcat $ pretty <$> remoteEntries
|
||||
where
|
||||
isHbs2 (_,b) = Text.isPrefixOf "hbs2://" b
|
||||
isHbs2 (_, b) = Text.isPrefixOf hbs2Prefix b
|
||||
|
||||
getRefVal :: (MonadIO m, HasCatAPI 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 <- readRefHttp ref
|
||||
case mRefVal of
|
||||
Nothing -> do
|
||||
liftIO $ print $ pretty "readRefHttp error" <+> pretty ref
|
||||
pure Nothing
|
||||
Just v -> pure $ Just v
|
||||
|
|
|
|||
Loading…
Reference in New Issue