1{-# LANGUAGE BangPatterns #-}
2
3{- git commit history interface
4 -
5 - Copyright 2019 Joey Hess <id@joeyh.name>
6 -
7 - Licensed under the GNU AGPL version 3 or higher.
8 -}
9
10module Git.History where
11
12import Common
13import Git
14import Git.Command
15import Git.Sha
16
17import qualified Data.Set as S
18import qualified Data.ByteString.Lazy as L
19import qualified Data.ByteString.Char8 as B8
20import qualified Data.ByteString.Lazy.Char8 as L8
21
22data History t = History t (S.Set (History t))
23	deriving (Show, Eq, Ord)
24
25mapHistory :: (Ord a, Ord b) => (a -> b) -> History a -> History b
26mapHistory f (History t s) = History (f t) (S.map (mapHistory f) s)
27
28historyDepth :: History t -> Integer
29historyDepth (History _ s)
30	| S.null s = 1
31	| otherwise = 1 + maximum (map historyDepth (S.toList s))
32
33truncateHistoryToDepth :: Ord t => Integer -> History t -> History t
34truncateHistoryToDepth n (History t ps) = History t (go 1 ps)
35  where
36	go depth s
37		| depth >= n = S.empty
38		| otherwise =
39			let depth' = succ depth
40			in flip S.map s $ \(History t' s') ->
41				History t' (go depth' s')
42
43
44data HistoryCommit = HistoryCommit
45	{ historyCommit :: Sha
46	, historyCommitTree :: Sha
47	, historyCommitParents :: [Sha]
48	} deriving (Show, Eq, Ord)
49
50{- Gets a History starting with the provided commit, and down to the
51 - requested depth. -}
52getHistoryToDepth :: Integer -> Ref -> Repo -> IO (Maybe (History HistoryCommit))
53getHistoryToDepth n commit r = withCreateProcess p go
54  where
55	p = (gitCreateProcess params r)
56		{ std_out = CreatePipe }
57	go _ (Just inh) _ pid = do
58		!h <- fmap (truncateHistoryToDepth n)
59			. build Nothing
60			. map parsehistorycommit
61			. map L.toStrict
62			. L8.lines
63			<$> L.hGetContents inh
64		hClose inh
65		void $ waitForProcess pid
66		return h
67	go _ _ _ _ = error "internal"
68
69	build h [] = fmap (mapHistory fst) h
70	build _ (Nothing:_) = Nothing
71	build Nothing (Just v:rest) =
72		build (Just (History v S.empty)) rest
73	build (Just h) (Just v:rest) =
74		let h' = traverseadd v h
75		in build (Just h') $
76			-- detect when all parents down to desired depth
77			-- have been found, and avoid processing any more,
78			-- this makes it much faster when there is a lot of
79			-- history.
80			if parentsfound h' then [] else rest
81
82	traverseadd v@(hc, _ps) (History v'@(hc', ps') s)
83		| historyCommit hc `elem` ps' =
84			let ps'' = filter (/= historyCommit hc) ps'
85			in History (hc', ps'') (S.insert (History v S.empty) s)
86		| otherwise = History v' (S.map (traverseadd v) s)
87
88	parentsfound = parentsfound' 1
89	parentsfound' depth (History (_hc, ps) s)
90		| not (null ps) = False
91		| null ps && depth == n = True
92		| depth >= n = True
93		| otherwise = all (parentsfound' (succ depth)) (S.toList s)
94
95	params =
96		[ Param "log"
97		, Param (fromRef commit)
98		, Param "--full-history"
99		, Param "--no-abbrev"
100		, Param "--format=%T %H %P"
101		]
102
103	parsehistorycommit l = case map extractSha (B8.split ' ' l) of
104		(Just t:Just c:ps) -> Just $
105			( HistoryCommit
106				{ historyCommit = c
107				, historyCommitTree = t
108				, historyCommitParents = catMaybes ps
109				}
110			, catMaybes ps
111			)
112		_ -> Nothing
113