git-phoenix-0.0.1: test/Data/Git/Phoenix/Test/UberExtract.hs

module Data.Git.Phoenix.Test.UberExtract where

import Data.Git.Phoenix.CmdArgs
import Data.Git.Phoenix.CmdRun
import Data.Git.Phoenix.Prelude
import Data.Git.Phoenix.Test
import UnliftIO.Process

unit_uber_extract :: IO ()
unit_uber_extract = withUber go
  where
    go :: Tagged Root FilePath -> Tagged Uber FilePath -> IO ()
    go (Tagged rdir) (Tagged uberOut) = do
      let gitOut = rdir </> "git-phoenix"
      runCmd ExtractCommitTreeAsGitRepo { rootCommit = Tagged $ take 15 currentHead
                                        , uberRepoDir = Tagged uberOut
                                        , gitRepoOut = Tagged gitOut
                                        }
      callCommand $ "git -C " <> gitOut <> " fsck --full"
      gotHead <- readBranchCommit (gitOut </> ".git/refs/heads/master")
      when (gotHead /= currentHead) $ do
        fail $ "HEAD commit mismatch\nGot:      [" <> gotHead
                               <> "]\nExpected: [" <> currentHead <> "]"