diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Expression.hs | 12 | ||||
| -rw-r--r-- | src/Repo.hs | 112 |
2 files changed, 84 insertions, 40 deletions
diff --git a/src/Expression.hs b/src/Expression.hs index bf35f2a..43f859e 100644 --- a/src/Expression.hs +++ b/src/Expression.hs @@ -132,10 +132,14 @@ evaluateDeclaredRevision repo = \case ts -> return $ StaticRef $ tagObject $ foldl1' sel ts WatchedRef (TextRef ref) -> do - watched <- watchBranch repo ref - output <- getOutput - outputEvent output $ TestMessage $ "watch-branch-started " <> ref - return $ WatchedRef $ BranchRef watched + watchBranch repo ref >>= \case + Right watched -> do + output <- getOutput + outputEvent output $ TestMessage $ "watch-branch-started " <> ref + return $ WatchedRef $ BranchRef watched + Left commit -> do + return $ StaticRef commit + WatchedRef (TagRef wtPattern wtUpdate) -> do wtChan <- watchTags repo value <- filter (Glob.match wtPattern . T.unpack . tagTag) <$> listTags repo >>= \case diff --git a/src/Repo.hs b/src/Repo.hs index 7fe699c..9fab2f7 100644 --- a/src/Repo.hs +++ b/src/Repo.hs @@ -68,8 +68,7 @@ data Repo { gitDir :: FilePath , gitWritable :: Bool , gitLock :: MVar () - , gitInotify :: MVar (Maybe ( INotify, TChan (Tag Commit) )) - , gitWatchedBranches :: MVar (Map Text [ TVar (Maybe Commit) ]) + , gitInotify :: MVar (Maybe GitInotify) } instance Show Repo where @@ -178,7 +177,6 @@ openRepo gitWritable path = do Just gitDir -> do gitLock <- newMVar () gitInotify <- newMVar Nothing - gitWatchedBranches <- newMVar M.empty return $ Just GitRepo {..} Nothing -> do return Nothing @@ -329,6 +327,12 @@ findUpstreamRef repo@GitRepo {..} ref = liftIO $ do _ -> return Nothing _ -> return Nothing +getGitRefPath :: MonadIO m => Repo -> Text -> m (Maybe FilePath) +getGitRefPath GitRepo {..} ref = liftIO $ do + readProcessWithExitCode "git" [ "--git-dir=" <> gitDir, "rev-parse", "--symbolic-full-name", T.unpack ref ] "" >>= \case + ( ExitSuccess, out, _ ) | [ path ] <- lines out -> return (Just path) + ( _, _, _ ) -> return Nothing + getCommitDetails :: (MonadIO m, MonadFail m) => Commit -> m CommitDetails getCommitDetails Commit {..} = do @@ -502,41 +506,77 @@ pushToBranch Branch {..} Commit {..} = do | otherwise -> error "createProcess must return stdout handle" -repoInotify :: Repo -> IO ( INotify, TChan (Tag Commit) ) -repoInotify repo@GitRepo {..} = modifyMVar gitInotify $ \case - cur@(Just info) -> - return ( cur, info ) +data GitInotify = GitInotify + { giInotify :: INotify + , giTags :: MVar (Maybe ( WatchDescriptor, TChan (Tag Commit) )) + , giDirs :: MVar (Map FilePath ( WatchDescriptor, Map Text (TVar (Maybe Commit)) )) + } + +repoInotify :: Repo -> IO GitInotify +repoInotify GitRepo {..} = modifyMVar gitInotify $ \case + cur@(Just gi) -> + return ( cur, gi ) Nothing -> do - inotify <- initINotify - tagsChan <- newBroadcastTChanIO - let info = ( inotify, tagsChan ) + giInotify <- initINotify + giTags <- newMVar Nothing + giDirs <- newMVar M.empty + let gi = GitInotify {..} + return ( Just gi, gi ) + +watchBranch :: (MonadIO m, MonadFail m) => Repo -> Text -> m (Either Commit (STM (Maybe Commit))) +watchBranch repo@GitRepo {..} ref = liftIO $ do + mbCommit <- tryReadCommit repo ref + gi@GitInotify {..} <- repoInotify repo + getGitRefPath repo ref >>= \case + Just path -> Right <$> do + let ( dir, sbranch ) = splitFileName path + branch = T.pack sbranch + modifyMVar giDirs $ \dirMap -> + case M.lookup dir dirMap of + Just ( wd, branchMap ) -> + case M.lookup branch branchMap of + Just tvar -> do + return ( dirMap, readTVar tvar ) + Nothing -> do + tvar <- newTVarIO mbCommit + return ( M.insert dir ( wd, M.insert branch tvar branchMap ) dirMap, readTVar tvar ) + + Nothing -> do + wd <- addBranchWatch gi dir + tvar <- newTVarIO mbCommit + return ( M.insert dir ( wd, M.singleton branch tvar ) dirMap, readTVar tvar ) + + Nothing | Just commit <- mbCommit -> do + return $ Left commit - _ <- addWatch inotify [ MoveIn ] (BC.pack headsDir) $ \event -> do - let branch = decodeUtf8 $ filePath event - tvars <- fromMaybe [] . M.lookup branch <$> readMVar gitWatchedBranches - when (not $ null tvars) $ do - commit <- readBranch repo branch - atomically $ do - mapM_ (`writeTVar` commit) tvars - - _ <- addWatch inotify [ MoveIn ] (BC.pack tagsDir) $ \event -> do - tryReadTag repo (decodeUtf8 $ filePath event) >>= \case - Just tag -> atomically $ writeTChan tagsChan tag - Nothing -> return () - - return ( Just info, info ) + _ -> do + fail $ "ref ‘" <> T.unpack ref <> "’ not found in ‘" <> gitDir <> "’" where - headsDir = gitDir </> "refs/heads" - tagsDir = gitDir </> "refs/tags" - -watchBranch :: MonadIO m => Repo -> Text -> m (STM (Maybe Commit)) -watchBranch repo@GitRepo {..} branch = liftIO $ do - var <- newTVarIO =<< readBranch repo branch - void $ repoInotify repo - modifyMVar_ gitWatchedBranches $ return . M.insertWith (++) branch [ var ] - return $ readTVar var + addBranchWatch GitInotify {..} dir = do + addWatch giInotify [ MoveIn ] (BC.pack $ gitDir </> dir) $ \event -> do + let branch = decodeUtf8 $ filePath event + withMVar giDirs $ \dirMap -> do + Just ( _, branchMap ) <- return $ M.lookup dir dirMap + case M.lookup branch branchMap of + Just tvar -> do + commit <- readCommitFromFile repo (dir </> T.unpack branch) + atomically $ writeTVar tvar commit + Nothing -> do + return () watchTags :: MonadIO m => Repo -> m (TChan (Tag Commit)) -watchTags repo = liftIO $ do - tagsChan <- snd <$> repoInotify repo - atomically $ dupTChan tagsChan +watchTags repo@GitRepo {..} = liftIO $ do + GitInotify {..} <- repoInotify repo + chan <- modifyMVar giTags $ \case + cur@(Just ( _, chan )) -> do + return ( cur, chan ) + Nothing -> do + chan <- newBroadcastTChanIO + wd <- addWatch giInotify [ MoveIn ] (BC.pack tagsDir) $ \event -> do + tryReadTag repo (decodeUtf8 $ filePath event) >>= \case + Just tag -> atomically $ writeTChan chan tag + Nothing -> return () + return ( Just ( wd, chan ), chan ) + atomically $ dupTChan chan + where + tagsDir = gitDir </> "refs/tags" |