{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

-- | Utilities to implement cabal @v2-sdist@.
module Distribution.Client.SrcDist
  ( allPackageSourceFiles
  , packageDirToSdist
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify)
import Control.Monad.Trans (liftIO)
import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell)

import Distribution.Client.Errors
import Distribution.Client.Utils (tryReadAddSourcePackageDesc)
import Distribution.Package (Package (packageId))
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Distribution.Simple.PreProcess (knownSuffixHandlers)
import Distribution.Simple.SrcDist (listPackageSourcesWithDie)
import Distribution.Simple.Utils (dieWithException)
import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
import Distribution.Utils.Path
  ( getSymbolicPath
  , makeSymbolicPath
  )

import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Compression.GZip as GZip
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Set as Set
import System.Directory (canonicalizePath)
import System.FilePath

-- | List all source files of a given add-source dependency. Exits with error if
-- something is wrong (e.g. there is no .cabal file in the given directory).
--
-- Used in sandbox and projectbuilding.
-- TODO: when sandboxes are removed, move to ProjectBuilding.
allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]
allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]
allPackageSourceFiles Verbosity
verbosity FilePath
packageDir = do
  let err :: FilePath
err = FilePath
"Error reading source files of package."
  gpd <- Verbosity -> FilePath -> FilePath -> IO GenericPackageDescription
tryReadAddSourcePackageDesc Verbosity
verbosity FilePath
packageDir FilePath
err
  let pd = GenericPackageDescription -> PackageDescription
flattenPackageDescription GenericPackageDescription
gpd
  srcs <-
    listPackageSourcesWithDie
      verbosity
      (\Verbosity
_ CabalException
_ -> [res] -> IO [res]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
      (Just $ makeSymbolicPath packageDir)
      pd
      knownSuffixHandlers
  return $ map getSymbolicPath srcs

-- | Create a tarball for a package in a directory
packageDirToSdist
  :: Verbosity
  -> GenericPackageDescription
  -- ^ read in GPD
  -> FilePath
  -- ^ directory containing that GPD
  -> IO BSL.ByteString
  -- ^ resulting sdist tarball
packageDirToSdist :: Verbosity -> GenericPackageDescription -> FilePath -> IO ByteString
packageDirToSdist Verbosity
verbosity GenericPackageDescription
gpd FilePath
dir = do
  -- let thisDie :: Verbosity -> String -> IO a
  --    thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s
  absDir <- FilePath -> IO FilePath
canonicalizePath FilePath
dir
  files' <- listPackageSourcesWithDie verbosity dieWithException (Just $ makeSymbolicPath absDir) (flattenPackageDescription gpd) knownSuffixHandlers
  let files :: [FilePath]
      files = [FilePath] -> [FilePath]
forall a. Eq a => [a] -> [a]
nub ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ (SymbolicPath Pkg 'File -> FilePath)
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
normalise (FilePath -> FilePath)
-> (SymbolicPath Pkg 'File -> FilePath)
-> SymbolicPath Pkg 'File
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath) [SymbolicPath Pkg 'File]
files'

  let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()
      entriesM = do
        let prefix :: FilePath
prefix = PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (GenericPackageDescription -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericPackageDescription
gpd)
        (Set FilePath -> Set FilePath)
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
Set.insert FilePath
prefix)
        case Bool -> FilePath -> Either FilePath TarPath
Tar.toTarPath Bool
True FilePath
prefix of
          Left FilePath
err -> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a. IO a -> StateT (Set FilePath) (WriterT [Entry] IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
ErrorPackingSdist FilePath
err
          Right TarPath
path -> [Entry] -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [TarPath -> Entry
forall tarPath content linkTarget.
tarPath -> GenEntry content tarPath linkTarget
Tar.directoryEntry TarPath
path]

        [FilePath]
-> (FilePath -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FilePath]
files ((FilePath -> StateT (Set FilePath) (WriterT [Entry] IO) ())
 -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> (FilePath -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
          let fileDir :: FilePath
fileDir = FilePath -> FilePath
takeDirectory (FilePath
prefix FilePath -> FilePath -> FilePath
</> FilePath
file)
          needsEntry <- (Set FilePath -> Bool)
-> StateT (Set FilePath) (WriterT [Entry] IO) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember FilePath
fileDir)

          when needsEntry $ do
            modify (Set.insert fileDir)
            case Tar.toTarPath True fileDir of
              Left FilePath
err -> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a. IO a -> StateT (Set FilePath) (WriterT [Entry] IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
ErrorPackingSdist FilePath
err
              Right TarPath
path -> [Entry] -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [TarPath -> Entry
forall tarPath content linkTarget.
tarPath -> GenEntry content tarPath linkTarget
Tar.directoryEntry TarPath
path]

          contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file
          case Tar.toTarPath False (prefix </> file) of
            Left FilePath
err -> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a. IO a -> StateT (Set FilePath) (WriterT [Entry] IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ())
-> IO () -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
ErrorPackingSdist FilePath
err
            Right TarPath
path -> [Entry] -> StateT (Set FilePath) (WriterT [Entry] IO) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [(TarPath -> ByteString -> Entry
forall tarPath linkTarget.
tarPath -> ByteString -> GenEntry ByteString tarPath linkTarget
Tar.fileEntry TarPath
path ByteString
contents){Tar.entryPermissions = Tar.ordinaryFilePermissions}]

  entries <- execWriterT (evalStateT entriesM mempty)
  let
    -- Pretend our GZip file is made on Unix.
    normalize ByteString
bs = [ByteString] -> ByteString
BSL.concat [ByteString
pfx, ByteString
"\x03", ByteString
rest']
      where
        (ByteString
pfx, ByteString
rest) = EpochTime -> ByteString -> (ByteString, ByteString)
BSL.splitAt EpochTime
9 ByteString
bs
        rest' :: ByteString
rest' = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BSL.tail ByteString
rest
    -- The Unix epoch, which is the default value, is
    -- unsuitable because it causes unpacking problems on
    -- Windows; we need a post-1980 date. One gigasecond
    -- after the epoch is during 2001-09-09, so that does
    -- nicely. See #5596.
    setModTime :: Tar.Entry -> Tar.Entry
    setModTime Entry
entry = Entry
entry{Tar.entryTime = 1000000000}
  return . normalize . GZip.compress . Tar.write $ fmap setModTime entries