Test.hs

module Data.Git.Phoenix.Test where

import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as C8
import Data.Git.Phoenix.CmdArgs
import Data.Git.Phoenix.CmdRun
import Data.Git.Phoenix.Prelude
import Test.QuickCheck as QC
import UnliftIO.Directory
import UnliftIO.IO (hSeek, SeekMode (..))
import UnliftIO.Temporary

currentHead :: String
currentHead = "62324a152b2f9272c922571ab1e08a5212da2d65"

readBranchCommit :: FilePath -> IO String
readBranchCommit fp = C8.unpack . BS.takeWhile isHexDigit <$> BS.readFile fp

data Root
data Uber

withUber :: (Tagged Root FilePath -> Tagged Uber FilePath -> IO ()) -> IO ()
withUber doWithUberDir =
  withSystemTempDirectory "gitphoenix" $ \rdir ->
    let phOut = rdir </> "photorec-output" in do
      createDirectory phOut
      forM_ cases $ \(d, f) -> do
        let destDir = phOut </> d
        createDirectory destDir
        runConduitRes
          (  sourceDirectoryDeep False "test-git-objects"
          .| foldMC (f destDir) (0 :: Int)
          )
      let uberOut = rdir </> "uber"
      runCmd BuildUberRepo { inDir = Tagged phOut
                           , outDir = Tagged uberOut
                           }
      doWithUberDir (Tagged @Root rdir) (Tagged @Uber uberOut)
  where
    cases =
      [ ("trail-trash", trailTrash)
      , ("middle-trash", middleTrash)
      , ("symlinks", symlinks)
      , ("clean-copy", cleanCopy)
      ]
    markWritable fp =
      setPermissions fp . setOwnerWritable True =<< getPermissions fp
    trailTrash destDir nextFileName gitObjFp = liftIO $ do
      let destFp = destDir </> show nextFileName <> ".go1"
      copyFile gitObjFp destFp
      markWritable destFp
      withBinaryFile destFp AppendMode $ \h -> genBs >>= BS.hPut h
      pure $ nextFileName + 1
    middleTrash destDir nextFileName gitObjFp = liftIO $ do
      let destFp = destDir </> show nextFileName <> ".go1"
      copyFile gitObjFp destFp
      markWritable destFp
      withBinaryFile destFp WriteMode $ \h -> do
        hs <- fromIntegral <$> getFileSize gitObjFp
        i <- fromIntegral <$> generate (chooseInt (0, hs - 1))
        hSeek h AbsoluteSeek i
        genBs >>= BS.hPut h
      pure $ nextFileName + 1
    symlinks destDir nextFileName gitObjFp = liftIO $ do
      let destFp = destDir </> show nextFileName <> ".go1"
      (`createFileLink` destFp) =<< makeAbsolute gitObjFp
      pure $ nextFileName + 1
    cleanCopy destDir nextFileName gitObjFp = liftIO $ do
      let destFp = destDir </> show nextFileName <> ".go1"
      copyFile gitObjFp destFp
      pure $ nextFileName + 1

genBs :: MonadIO m => m ByteString
genBs = liftIO $ generate go
  where
    go = do
      s <- QC.getSize
      BS.pack <$> QC.vector (1 + s)