92f775eba0
Not yet 100% done, so far I've grepped for waitForProcess and converted everything that uses that to start the process with withCreateProcess. Except for some things like P2P.IO and Assistant.TransferrerPool, and Utility.CoProcess, that manage a pool of processes. See #2 in https://git-annex.branchable.com/todo/more_extensive_retries_to_mask_transient_failures/#comment-209f8a8c38e63fb3a704e1282cb269c7 for how those will need to be dealt with. checkSuccessProcess, ignoreFailureProcess, and forceSuccessProcess calls waitForProcess, so callers of them will also need to be dealt with, and have not been yet.
112 lines
3 KiB
Haskell
112 lines
3 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
|
|
{- git commit history interface
|
|
-
|
|
- Copyright 2019 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Git.History where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Command
|
|
import Git.Sha
|
|
|
|
import qualified Data.Set as S
|
|
import qualified Data.ByteString.Lazy as L
|
|
import qualified Data.ByteString.Char8 as B8
|
|
import qualified Data.ByteString.Lazy.Char8 as L8
|
|
|
|
data History t = History t (S.Set (History t))
|
|
deriving (Show, Eq, Ord)
|
|
|
|
mapHistory :: (Ord a, Ord b) => (a -> b) -> History a -> History b
|
|
mapHistory f (History t s) = History (f t) (S.map (mapHistory f) s)
|
|
|
|
historyDepth :: History t -> Integer
|
|
historyDepth (History _ s)
|
|
| S.null s = 1
|
|
| otherwise = 1 + maximum (map historyDepth (S.toList s))
|
|
|
|
truncateHistoryToDepth :: Ord t => Integer -> History t -> History t
|
|
truncateHistoryToDepth n (History t ps) = History t (go 1 ps)
|
|
where
|
|
go depth s
|
|
| depth >= n = S.empty
|
|
| otherwise =
|
|
let depth' = succ depth
|
|
in flip S.map s $ \(History t' s') ->
|
|
History t' (go depth' s')
|
|
|
|
|
|
data HistoryCommit = HistoryCommit
|
|
{ historyCommit :: Sha
|
|
, historyCommitTree :: Sha
|
|
, historyCommitParents :: [Sha]
|
|
} deriving (Show, Eq, Ord)
|
|
|
|
{- Gets a History starting with the provided commit, and down to the
|
|
- requested depth. -}
|
|
getHistoryToDepth :: Integer -> Ref -> Repo -> IO (Maybe (History HistoryCommit))
|
|
getHistoryToDepth n commit r = withCreateProcess p go
|
|
where
|
|
p = (gitCreateProcess params r)
|
|
{ std_out = CreatePipe }
|
|
go _ (Just inh) _ pid = do
|
|
!h <- fmap (truncateHistoryToDepth n)
|
|
. build Nothing
|
|
. map parsehistorycommit
|
|
. map L.toStrict
|
|
. L8.lines
|
|
<$> L.hGetContents inh
|
|
hClose inh
|
|
void $ waitForProcess pid
|
|
return h
|
|
go _ _ _ _ = error "internal"
|
|
|
|
build h [] = fmap (mapHistory fst) h
|
|
build _ (Nothing:_) = Nothing
|
|
build Nothing (Just v:rest) =
|
|
build (Just (History v S.empty)) rest
|
|
build (Just h) (Just v:rest) =
|
|
let h' = traverseadd v h
|
|
in build (Just h') $
|
|
-- detect when all parents down to desired depth
|
|
-- have been found, and avoid processing any more,
|
|
-- this makes it much faster when there is a lot of
|
|
-- history.
|
|
if parentsfound h' then [] else rest
|
|
|
|
traverseadd v@(hc, _ps) (History v'@(hc', ps') s)
|
|
| historyCommit hc `elem` ps' =
|
|
let ps'' = filter (/= historyCommit hc) ps'
|
|
in History (hc', ps'') (S.insert (History v S.empty) s)
|
|
| otherwise = History v' (S.map (traverseadd v) s)
|
|
|
|
parentsfound = parentsfound' 1
|
|
parentsfound' depth (History (_hc, ps) s)
|
|
| not (null ps) = False
|
|
| null ps && depth == n = True
|
|
| depth >= n = True
|
|
| otherwise = all (parentsfound' (succ depth)) (S.toList s)
|
|
|
|
params =
|
|
[ Param "log"
|
|
, Param (fromRef commit)
|
|
, Param "--full-history"
|
|
, Param "--no-abbrev"
|
|
, Param "--format=%T %H %P"
|
|
]
|
|
|
|
parsehistorycommit l = case map extractSha (B8.split ' ' l) of
|
|
(Just t:Just c:ps) -> Just $
|
|
( HistoryCommit
|
|
{ historyCommit = c
|
|
, historyCommitTree = t
|
|
, historyCommitParents = catMaybes ps
|
|
}
|
|
, catMaybes ps
|
|
)
|
|
_ -> Nothing
|