From 31c243d5679825362ca0f60042ad5f4f8a2ba6dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Sat, 12 Sep 2026 11:05:16 +0200 Subject: Add "writable" flag to repo required for pushing --- src/Command.hs | 2 +- src/Config.hs | 3 ++- src/Main.hs | 37 ++++++++++++++++++++++--------------- src/Repo.hs | 14 +++++++++----- 4 files changed, 34 insertions(+), 22 deletions(-) (limited to 'src') diff --git a/src/Command.hs b/src/Command.hs index 452be9d..9dd6f35 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -37,7 +37,7 @@ import Repo data CommonOptions = CommonOptions { optJobs :: Int - , optRepo :: [ ( RepoName, FilePath ) ] + , optRepo :: [ ( RepoName, ( Bool, FilePath ) ) ] , optDestination :: [ ( DestinationName, Text ) ] } diff --git a/src/Config.hs b/src/Config.hs index 651b05c..885e9a8 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -188,10 +188,11 @@ parsePush = withSeq "Push list" $ mapM $ parseRepo :: Text -> Node Pos -> Parser DeclaredRepo parseRepo name node = choice - [ flip (withNull "Repo") node $ return $ DeclaredRepo (RepoName name) Nothing + [ flip (withNull "Repo") node $ return $ DeclaredRepo (RepoName name) Nothing False , flip (withMap "Repo") node $ \r -> DeclaredRepo <$> pure (RepoName name) <*> (fmap T.unpack <$> r .:? "path") + <*> (fromMaybe False <$> r .:? "writable") ] parseDestination :: Text -> Node Pos -> Parser DeclaredDestination diff --git a/src/Main.hs b/src/Main.hs index 647231d..e1fbee9 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -62,16 +62,11 @@ options = (ReqArg (\num opts -> return opts { optCommon = (optCommon opts) { optJobs = read num }}) "") ("number of jobs to run simultaneously (default " <> show (optJobs defaultCommonOptions) <> ")") , Option [] [ "repo" ] - (ReqArg (\value opts -> - case span (/= ':') value of - ( repo, ':' : path ) -> return opts - { optCommon = (optCommon opts) - { optRepo = ( RepoName $ T.pack repo, path ) : optRepo (optCommon opts) - } - } - _ -> throwError $ "--repo: invalid value ‘" <> value <> "’" - ) ":") + (repoOption "repo" False) ("override or declare repo path") + , Option [] [ "writable-repo" ] + (repoOption "writable-repo" True) + ("override or declare repo path and open it as writable") , Option [] [ "destination" ] (ReqArg (\value opts -> case span (/= ':') value of @@ -97,6 +92,18 @@ options = "use test-style output to or standard output" ] + where + repoOption optname writable = + (ReqArg (\value opts -> + case span (/= ':') value of + ( repo, ':' : path ) -> return opts + { optCommon = (optCommon opts) + { optRepo = ( RepoName $ T.pack repo, ( writable, path ) ) : optRepo (optCommon opts) + } + } + _ -> throwError $ "--" <> optname <> ": invalid value ‘" <> value <> "’" + ) ":") + data SomeCommandType = forall c. Command c => SC (Proxy c) commands :: NE.NonEmpty SomeCommandType @@ -212,12 +219,12 @@ runSomeCommand rootPath gopts (SC tproxy) args = do Right config -> return ( path, JobRootConfig config ) Left err -> reportFailure $ "Failed to parse job file ‘" <> path <> "’:" <> err False -> doesDirectoryExist path >>= \case - True -> openRepo path >>= \case + True -> openRepo False path >>= \case Just repo -> return ( path, JobRootRepo repo ) Nothing -> reportFailure $ "Failed to open repository ‘" <> path <> "’" False -> reportFailure $ "File or directory ‘" <> path <> "’ not found" Nothing -> do - openRepo "." >>= \case + openRepo False "." >>= \case Just repo -> return ( ".", JobRootRepo repo ) Nothing -> findConfig >>= \case Just path -> BL.readFile path >>= return . parseConfig >>= \case @@ -253,11 +260,11 @@ runSomeCommand rootPath gopts (SC tproxy) args = do ciContainingRepo <- case ciJobRoot of JobRootRepo repo -> return (Just repo) - JobRootConfig _ -> openRepo $ takeDirectory ciRootPath + JobRootConfig _ -> openRepo False $ takeDirectory ciRootPath - let openDeclaredRepo dir ( name, dpath ) = do + let openDeclaredRepo dir ( name, ( writable, dpath ) ) = do let path = dir dpath - openRepo path >>= \case + openRepo writable path >>= \case Just repo -> return ( name, repo ) Nothing -> do absPath <- makeAbsolute path @@ -272,7 +279,7 @@ runSomeCommand rootPath gopts (SC tproxy) args = do Just repo -> return ( repoName decl, repo ) Nothing | Just path <- repoPath decl - -> openDeclaredRepo (takeDirectory ciRootPath) ( repoName decl, path ) + -> openDeclaredRepo (takeDirectory ciRootPath) ( repoName decl, ( repoWritable decl, path ) ) | otherwise -> do diff --git a/src/Repo.hs b/src/Repo.hs index c6fc275..683a815 100644 --- a/src/Repo.hs +++ b/src/Repo.hs @@ -63,6 +63,7 @@ import System.Process data Repo = GitRepo { gitDir :: FilePath + , gitWritable :: Bool , gitLock :: MVar () , gitInotify :: MVar (Maybe ( INotify, TChan (Tag Commit) )) , gitWatchedBranches :: MVar (Map Text [ TVar (Maybe Commit) ]) @@ -77,6 +78,7 @@ getRepoWorkDir GitRepo {..} = takeDirectory gitDir data DeclaredRepo = DeclaredRepo { repoName :: RepoName , repoPath :: Maybe FilePath + , repoWritable :: Bool } newtype RepoName = RepoName Text @@ -164,8 +166,8 @@ runGitCommand GitRepo {..} args = liftIO $ do readProcess "git" (("--git-dir=" <> gitDir) : args) "" -openRepo :: FilePath -> IO (Maybe Repo) -openRepo path = do +openRepo :: Bool -> FilePath -> IO (Maybe Repo) +openRepo gitWritable path = do findGitDir >>= \case Just gitDir -> do gitLock <- newMVar () @@ -437,7 +439,9 @@ readCommittedFile Tree {..} path = do pushToBranch :: (MonadIO m, MonadFail m) => Branch -> Commit -> m () pushToBranch Branch {..} Commit {..} = do - liftIO $ + when (not $ gitWritable branchRepo) $ do + fail $ "repo ‘" <> gitDir branchRepo <> "’ is not writable" + join $ liftIO $ withMVar (gitLock branchRepo) $ \_ -> withMVar (gitLock commitRepo) $ \_ -> do let cmd = (proc "git" [ "--git-dir=" <> gitDir commitRepo, "push", "--quiet", "--porcelain", gitDir branchRepo, showCommitId commitId_ <> ":refs/heads/" <> T.unpack branchName ]) @@ -448,8 +452,8 @@ pushToBranch Branch {..} Commit {..} = do createProcess cmd >>= \( _, mbstdout, _, ph ) -> if | Just _ <- mbstdout -> do waitForProcess ph >>= \case - ExitSuccess -> return () - code -> fail $ "git push exited with error: " <> show code + ExitSuccess -> return $ return () + code -> return $ fail $ "git push exited with error: " <> show code | otherwise -> error "createProcess must return stdout handle" -- cgit v1.2.3