diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Command.hs | 2 | ||||
| -rw-r--r-- | src/Config.hs | 3 | ||||
| -rw-r--r-- | src/Main.hs | 37 | ||||
| -rw-r--r-- | src/Repo.hs | 14 |
4 files changed, 34 insertions, 22 deletions
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 }}) "<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 <> "’" - ) "<repo>:<path>") + (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 <path> 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 <> "’" + ) "<repo>:<path>") + 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" |