more tests

1 files changed, 233 insertions, 0 deletions

diff --git a/git-deli b/git-deli
new file mode 100755
index 0000000..8f0165d
--- /dev/null
+++ b/git-deli
@@ -0,0 +1,233 @@
+#!/usr/bin/env cabal
+{- cabal:
+build-depends: base, process, filepath
+-}
+import Control.Monad
+import Data.List
+import Data.Maybe
+import System.Environment
+import System.Exit
+import System.FilePath
+import System.IO
+import System.Process
+import Text.Read
+
+import Debug.Trace
+
+{-
+ - program & directory work
+ -}
+gitProg :: IO String
+gitProg = fromMaybe "git" <$> lookupEnv "DELI_GIT"
+
+setGitRef :: String -> String -> IO ()
+setGitRef refname tgt = do
+  git <- gitProg
+  st <- rawSystem git ["update-ref", refname, tgt]
+  unless (st == ExitSuccess) . fail
+    $ "git-update-ref failed for " ++ show (refname, tgt)
+
+split :: (Char -> Bool) -> String -> [String]
+split p [] = []
+split p xs = uncurry (:) $ fmap (split p . drop 1) $ break p xs
+
+uniq (x:xs@(y:_))
+  | x == y = uniq xs
+  | otherwise = x : uniq xs
+uniq [x] = [x]
+uniq [] = []
+
+data SourceItem
+  = SourceFile FilePath
+  | SourceRange FilePath Int Int
+  deriving (Show)
+
+itemPath (SourceFile p) = p
+itemPath (SourceRange p _ _) = p
+
+sourceItems = start . map words
+  where
+    start (("diff":"--git":(a':'/':path):_):ls) = go (SourceFile path) ls
+    start (_:ls) = start ls
+    start [] = []
+    go f (("diff":"--git":(a':'/':path):_):ls)
+      | SourceFile _ <- f = f : go (SourceFile path) ls
+      | otherwise = go (SourceFile path) ls
+    go f (("@@":('-':inrange):('+':_):"@@":[]):ls)
+      | [Just a, Just b] <- map readMaybe $ split (== ',') inrange
+      , a /= 0
+      , b /= 0
+      , r <- SourceRange (itemPath f) a b = r : go r ls
+    go f (_:ls) = go f ls
+    go (SourceFile fp) [] = [SourceFile fp]
+    go _ [] = []
+
+blameItem :: FilePath -> SourceItem -> IO [String]
+blameItem base (SourceFile path) = do
+  git <- gitProg
+  (out, st) <-
+    withCreateProcess
+      (proc git ["log", "-1", "--full-history", "--format=%H", base, "--", path])
+        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
+      (,) <$> hGetContents' oh <*> waitForProcess p
+  unless (st == ExitSuccess) . fail $ "git-log failed on " ++ show (base, path)
+  pure $ lines out
+blameItem base (SourceRange path r0 r1) = do
+  git <- gitProg
+  (out, st) <-
+    withCreateProcess
+      (proc
+         git
+         ["annotate", "-l", "-L", show r0 ++ "," ++ show r1, base, "--", path])
+        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
+      (,) <$> hGetContents' oh <*> waitForProcess p
+  unless (st == ExitSuccess) . fail
+    $ "git-annotate failed on " ++ show (r0, r1, base, path)
+  pure . concatMap (take 1 . words) $ lines out
+
+indepCommits :: [String] -> IO [String]
+indepCommits = go []
+  where
+    batch = 32
+    go acc [] = pure acc
+    go acc xs = do
+      git <- gitProg
+      (out, st) <-
+        withCreateProcess
+          (proc git
+             $ concat [["merge-base", "--independent"], acc, take batch xs])
+            {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
+          (,) <$> hGetContents' oh <*> waitForProcess p
+      unless (st == ExitSuccess) . fail
+        $ "git-merge-base failed on " ++ show (acc, take batch xs)
+      go (lines out) (drop batch xs)
+
+diffToSources :: String -> String -> IO [String]
+diffToSources base commit = do
+  git <- gitProg
+  (out, st) <-
+    withCreateProcess
+      (proc git ["diff", "-p", "--no-renames", base, commit])
+        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
+      (,) <$> hGetContents' oh <*> waitForProcess p
+  unless (st == ExitSuccess) . fail
+    $ "git-diff failed on " ++ show (base, commit)
+  bis <-
+    fmap (uniq . sort . uniq . concat) . traverse (blameItem base) . sourceItems
+      $ lines out
+  indepCommits bis
+
+makeEmptyTree :: IO String
+makeEmptyTree = do
+  git <- gitProg
+  (out, st) <-
+    withCreateProcess
+      (proc git ["hash-object", "-w", "-t", "tree", "--stdin"])
+        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
+      (,) <$> hGetContents' oh <*> waitForProcess p
+  unless (st == ExitSuccess) . fail $ "git-hash-object tree failed"
+  case lines out of
+    [x] -> pure x
+    _ -> fail "hash-object tree output?"
+
+makeEmptyCommit :: IO String
+makeEmptyCommit = do
+  et <- makeEmptyTree
+  git <- gitProg
+  let writeCommit h = do
+        hPutStrLn h $ "tree " ++ et
+        hPutStrLn h $ "author git-deli <git-deli@localhost> 1777294464 +0000"
+        hPutStrLn h $ "committer git-deli <git-deli@localhost> 1777294464 +0000"
+        hPutStrLn h $ ""
+        hPutStrLn h $ "git-deli head commit"
+        hClose h
+  (out, st) <-
+    withCreateProcess
+      (proc git ["hash-object", "-w", "-t", "commit", "--stdin"])
+        {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p ->
+      (,) <$> (writeCommit ih >> hGetContents' oh) <*> waitForProcess p
+  unless (st == ExitSuccess) . fail $ "git-hash-object commit failed"
+  ec <-
+    case lines out of
+      [x] -> pure x
+      _ -> fail "hash-object commit output?"
+  pure ec
+
+mergedCommitsTree [] = makeEmptyTree
+mergedCommitsTree (c:cs) = go c c cs
+  where
+    go _ t [] = pure t
+    go b t (c1:cs) = do
+      git <- gitProg
+      (out, st) <-
+        withCreateProcess
+          (proc git ["merge-base", b, c1])
+            {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
+          (,) <$> hGetContents' oh <*> waitForProcess p
+      unless (st == ExitSuccess) . fail
+        $ "git-merge-base failed with" ++ show (b, c1)
+      b' <-
+        case lines out of
+          [x] -> pure x
+          _ -> fail "merge base output?"
+      (out, st) <-
+        withCreateProcess
+          (proc git ["merge-tree", "--write-tree", "--merge-base=" ++ b', t, c1])
+            {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
+          (,) <$> hGetContents' oh <*> waitForProcess p
+      unless (st == ExitSuccess) . fail
+        $ "git-merge-btree failed with" ++ show (t, c1, b')
+      t' <-
+        case lines out of
+          [x] -> pure x
+          _ -> fail "merge-tree output??"
+      go b' t' cs
+
+delinearize :: String -> String -> IO String
+delinearize head commit = do
+  parents <- diffToSources head commit
+  t <- mergedCommitsTree parents
+  git <- gitProg
+  -- create a new tree which is essentially commit-head+mergedtree
+  (out, st) <-
+    withCreateProcess
+      (proc
+         git
+         ["merge-tree", "--write-tree", "--merge-base=" ++ head, t, commit])
+        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
+      (,) <$> hGetContents' oh <*> waitForProcess p
+  unless (st == ExitSuccess) . fail $ "final git-merge-tree failed"
+  t' <-
+    case lines out of
+      [x] -> pure x
+      _ -> fail "final merge-tree returned what?"
+  -- now let's get all the data from the original commit and change parents
+  (commitMsg', st) <-
+    withCreateProcess
+      (proc git ["cat-file", "commit", commit])
+        {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
+      (,) <$> hGetContents' oh <*> waitForProcess p
+  unless (st == ExitSuccess) . fail $ "git-cat-file failed"
+  let (msgHead, msgBody) = break null $ lines commitMsg'
+      commitMsg =
+        unlines
+          $ ["tree " ++ t']
+              ++ map ("parent " ++) parents
+              ++ filter ((/= ["parent"]) . take 1 . words) msgHead
+              ++ msgBody
+  -- label the stuff with a proper commit
+  (out, st) <-
+    withCreateProcess
+      (proc git ["hash-object", "-w", "-t", "commit", "--stdin"])
+        {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p ->
+      (,) <$> (hPutStr ih commitMsg >> hGetContents' oh) <*> waitForProcess p
+  unless (st == ExitSuccess) . fail $ "git-hash-object final commit failed"
+  commit' <-
+    case lines out of
+      [x] -> pure x
+      _ -> fail "final has-object returned what?"
+  -- move the ref!
+  pure commit'
+
+main = do
+  diffToSources "HEAD^" "HEAD"