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