fix git hbs2 init

This commit is contained in:
Dmitry Zuikov 2023-10-17 11:40:03 +03:00
parent 6069abb33e
commit 2962cc78ea
2 changed files with 21 additions and 4 deletions

View File

@ -194,7 +194,7 @@ runWithRPC action = do
| ListVal (Key "rpc" [SymbolVal "unix", LitStrVal n]) <- syn | ListVal (Key "rpc" [SymbolVal "unix", LitStrVal n]) <- syn
] ]
soname <- race ( pause @'Seconds 1) (maybe (detectRPC False) pure soname') `orDie` "hbs2-peer rpc timeout!" 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!" client <- race ( pause @'Seconds 1) (newMessagingUnix False 1.0 soname) `orDie` "hbs2-peer rpc timeout!"

View File

@ -21,10 +21,10 @@ import HBS2Git.PrettyStuff
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Char8 qualified as BS8
import Control.Monad.Trans.Maybe
import Data.Text qualified as Text import Data.Text qualified as Text
import Data.Traversable import Data.Traversable
import Data.Maybe import Data.Maybe
import Data.Either
import Prettyprinter.Render.Terminal import Prettyprinter.Render.Terminal
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
import Control.Monad.Catch (MonadCatch,MonadThrow,MonadMask) import Control.Monad.Catch (MonadCatch,MonadThrow,MonadMask)
@ -34,7 +34,6 @@ import System.FilePath
import System.Directory import System.Directory
import System.Process.Typed import System.Process.Typed
import Text.InterpolatedString.Perl6 (qc) import Text.InterpolatedString.Perl6 (qc)
import System.FilePattern.Directory
import System.IO.Temp import System.IO.Temp
import System.IO (stdout,stderr) import System.IO (stdout,stderr)
@ -194,6 +193,23 @@ runInitInteractive opts = do
liftIO $ hPutStrLn stdout "" 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 puk <- case view (field @"newRepoKeyring") opts of
Just kr -> liftIO do Just kr -> liftIO do
addKeyring confFile kr addKeyring confFile kr
@ -249,7 +265,8 @@ runInitInteractive opts = do
pure () pure ()
liftIO $ hPutDoc stderr $ green "succeed!" <> line <> line liftIO $ hPutDoc stderr $ green "Succeed!" <> line <> line
liftIO $ hPutDoc stderr $ pretty confFile <> line <> line
liftIO $ readFile confFile >>= putStrLn liftIO $ readFile confFile >>= putStrLn
where where