{-|
License : GPL-2

Packs are an optimization that enable faster repository cloning over HTTP.
A pack is actually a @tar.gz@ file that contains many files that would otherwise
have to be transfered one by one (which is much slower over HTTP).

Two packs are created at the same time by 'createPacks':

  1. The basic pack, contains the latest recorded version of the working tree.
  2. The patches pack, contains the set of patches of the repository.

The paths of these files are @_darcs\/packs\/basic.tar.gz@ and
@_darcs\/packs\/patches.tar.gz@. There is also @_darcs\/packs\/pristine@ which
indicates the pristine hash at the moment of the creation of the packs. This
last file is useful to determine whether the basic pack is in sync with the
current pristine of the repository.
-}

module Darcs.Repository.Packs
    ( fetchAndUnpackBasic
    , fetchAndUnpackPatches
    , packsDir
    , createPacks
    ) where

import qualified Codec.Archive.Tar as Tar
import Codec.Archive.Tar.Entry ( fileEntry, toTarPath )
import Codec.Compression.GZip as GZ ( compress, decompress )
import Control.Concurrent.Async ( withAsync )
import Control.Exception ( Exception, IOException, throwIO, catch, finally )
import Control.Monad ( void, when, unless )
import System.IO.Error ( isAlreadyExistsError )
import System.IO.Unsafe ( unsafeInterleaveIO )

import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.List ( isPrefixOf, sort )

import System.Directory ( createDirectoryIfMissing
                        , renameFile
                        , removeFile
                        , doesFileExist
                        , getModificationTime
                        , listDirectory
                        )
import System.FilePath ( (</>)
                       , (<.>)
                       , takeFileName
                       , splitPath
                       , joinPath
                       , takeDirectory
                       )
import System.Posix.Files ( createLink )

import Darcs.Prelude

import Darcs.Util.ByteString ( gzReadFilePS )
import Darcs.Util.Lock ( withTemp )
import Darcs.Util.External ( Cachable(..), fetchFileLazyPS )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Progress ( debugMessage, progressList )

import Darcs.Patch ( IsRepoType, RepoPatch )
import Darcs.Patch.PatchInfoAnd ( extractHash )
import Darcs.Patch.Progress ( progressFL )
import Darcs.Patch.Witnesses.Ordered ( mapFL )
import Darcs.Patch.Set ( patchSet2FL )

import Darcs.Repository.Traverse ( listInventories )
import Darcs.Repository.InternalTypes ( Repository )
import Darcs.Repository.Hashed ( readRepo )
import Darcs.Repository.Inventory ( getValidHash )
import Darcs.Repository.Format
    ( identifyRepoFormat, formatHas, RepoProperty ( HashedInventory ) )
import Darcs.Repository.Cache ( fetchFileUsingCache
                              , HashedDir(..)
                              , Cache
                              , closestWritableDirectory
                              , hashedDir
                              , bucketFolder
                              )
import Darcs.Repository.Old ( oldRepoFailMsg )
import Darcs.Repository.Pristine ( readHashedPristineRoot )

packsDir, basicPack, patchesPack :: String
packsDir :: String
packsDir     = String
"packs"
basicPack :: String
basicPack    = String
"basic.tar.gz"
patchesPack :: String
patchesPack  = String
"patches.tar.gz"

fetchAndUnpack :: FilePath
               -> HashedDir
               -> Cache
               -> FilePath
               -> IO ()
fetchAndUnpack :: String -> HashedDir -> Cache -> String -> IO ()
fetchAndUnpack String
filename HashedDir
dir Cache
cache String
remote = do
  forall e. Exception e => Cache -> HashedDir -> Entries e -> IO ()
unpackTar Cache
cache HashedDir
dir forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZ.decompress forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    String -> Cachable -> IO ByteString
fetchFileLazyPS (String
remote String -> String -> String
</> String
darcsdir String -> String -> String
</> String
packsDir String -> String -> String
</> String
filename) Cachable
Uncachable

fetchAndUnpackPatches :: [String] -> Cache -> FilePath -> IO ()
fetchAndUnpackPatches :: [String] -> Cache -> String -> IO ()
fetchAndUnpackPatches [String]
paths Cache
cache String
remote =
  -- Patches pack can miss some new patches of the repository.
  -- So we download pack asynchonously and alway do a complete pass
  -- of individual patch files.
  forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (String -> HashedDir -> Cache -> String -> IO ()
fetchAndUnpack String
patchesPack HashedDir
HashedInventoriesDir Cache
cache String
remote) forall a b. (a -> b) -> a -> b
$ \Async ()
_ -> do
  Cache -> HashedDir -> [String] -> IO ()
fetchFilesUsingCache Cache
cache HashedDir
HashedPatchesDir [String]
paths

fetchAndUnpackBasic :: Cache -> FilePath -> IO ()
fetchAndUnpackBasic :: Cache -> String -> IO ()
fetchAndUnpackBasic = String -> HashedDir -> Cache -> String -> IO ()
fetchAndUnpack String
basicPack HashedDir
HashedPristineDir

unpackTar :: Exception e => Cache -> HashedDir -> Tar.Entries e -> IO ()
unpackTar :: forall e. Exception e => Cache -> HashedDir -> Entries e -> IO ()
unpackTar Cache
_ HashedDir
_   Entries e
Tar.Done = forall (m :: * -> *) a. Monad m => a -> m a
return ()
unpackTar Cache
_ HashedDir
_   (Tar.Fail e
e) = forall e a. Exception e => e -> IO a
throwIO e
e
unpackTar Cache
c HashedDir
dir (Tar.Next Entry
e Entries e
es) = case Entry -> EntryContent
Tar.entryContent Entry
e of
  Tar.NormalFile ByteString
bs FileSize
_ -> do
    let p :: String
p = Entry -> String
Tar.entryPath Entry
e
    if String
"meta-" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String -> String
takeFileName String
p
      then forall e. Exception e => Cache -> HashedDir -> Entries e -> IO ()
unpackTar Cache
c HashedDir
dir Entries e
es -- just ignore them
      else do
        Bool
ex <- String -> IO Bool
doesFileExist String
p
        if Bool
ex
          then String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"TAR thread: exists " forall a. [a] -> [a] -> [a]
++ String
p forall a. [a] -> [a] -> [a]
++ String
"\nStopping TAR thread."
          else do
            if String
p forall a. Eq a => a -> a -> Bool
== String
darcsdir String -> String -> String
</> String
"hashed_inventory"
              then Maybe String -> String -> ByteString -> IO ()
writeFile' forall a. Maybe a
Nothing String
p ByteString
bs
              else Maybe String -> String -> ByteString -> IO ()
writeFile' (Cache -> Maybe String
closestWritableDirectory Cache
c) String
p forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
GZ.compress ByteString
bs
            String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"TAR thread: GET " forall a. [a] -> [a] -> [a]
++ String
p
            forall e. Exception e => Cache -> HashedDir -> Entries e -> IO ()
unpackTar Cache
c HashedDir
dir Entries e
es
  EntryContent
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected non-file tar entry"
 where
  writeFile' :: Maybe String -> String -> ByteString -> IO ()
writeFile' Maybe String
Nothing String
path ByteString
content = forall a. (String -> IO a) -> IO a
withTemp forall a b. (a -> b) -> a -> b
$ \String
tmp -> do
    String -> ByteString -> IO ()
BLC.writeFile String
tmp ByteString
content
    String -> String -> IO ()
renameFile String
tmp String
path
  writeFile' (Just String
ca) String
path ByteString
content = do
    let fileFullPath :: String
fileFullPath = case String -> [String]
splitPath String
path of
          String
_:String
hDir:String
hFile:[String]
_  -> [String] -> String
joinPath [String
ca, String
hDir, String -> String
bucketFolder String
hFile, String
hFile]
          [String]
_               -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected file path"
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
path
    String -> String -> IO ()
createLink String
fileFullPath String
path forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
ex :: IOException) -> do
      if IOException -> Bool
isAlreadyExistsError IOException
ex then
        forall (m :: * -> *) a. Monad m => a -> m a
return () -- so much the better
      else
        -- ignore cache if we cannot link
        Maybe String -> String -> ByteString -> IO ()
writeFile' forall a. Maybe a
Nothing String
path ByteString
content)

-- | Similar to @'mapM_' ('void' 'fetchFileUsingCache')@, exepts
-- it stops execution if file it's going to fetch already exists.
fetchFilesUsingCache :: Cache -> HashedDir -> [FilePath] -> IO ()
fetchFilesUsingCache :: Cache -> HashedDir -> [String] -> IO ()
fetchFilesUsingCache Cache
cache HashedDir
dir = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
go where
  go :: String -> IO ()
go String
path = do
    Bool
ex <- String -> IO Bool
doesFileExist forall a b. (a -> b) -> a -> b
$ String
darcsdir String -> String -> String
</> HashedDir -> String
hashedDir HashedDir
dir String -> String -> String
</> String
path
    if Bool
ex
     then String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"FILE thread: exists " forall a. [a] -> [a] -> [a]
++ String
path
     else forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Cache -> HashedDir -> String -> IO (String, ByteString)
fetchFileUsingCache Cache
cache HashedDir
dir String
path

-- | Create packs from the current recorded version of the repository.
createPacks :: (IsRepoType rt, RepoPatch p)
            => Repository rt p wR wU wT -> IO ()
createPacks :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO ()
createPacks Repository rt p wR wU wT
repo = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. IO a -> IO b -> IO a
finally (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
removeFileIfExists
  [ String
darcsdir String -> String -> String
</> String
"meta-filelist-inventories"
  , String
darcsdir String -> String -> String
</> String
"meta-filelist-pristine"
  , String
basicTar String -> String -> String
<.> String
"part"
  , String
patchesTar String -> String -> String
<.> String
"part"
  ]) forall a b. (a -> b) -> a -> b
$ do
  RepoFormat
rf <- String -> IO RepoFormat
identifyRepoFormat String
"."
  -- function is exposed in API so could be called on non-hashed repo
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
oldRepoFailMsg
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
False (String
darcsdir String -> String -> String
</> String
packsDir)
  -- pristine hash
  Just PristineHash
hash <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Maybe PristineHash)
readHashedPristineRoot Repository rt p wR wU wT
repo
  String -> String -> IO ()
writeFile ( String
darcsdir String -> String -> String
</> String
packsDir String -> String -> String
</> String
"pristine" ) forall a b. (a -> b) -> a -> b
$ forall a. ValidHash a => a -> String
getValidHash PristineHash
hash
  -- pack patchesTar
  [String]
ps <- forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall {rt :: RepoType} {p :: * -> * -> *} {wA} {wB}.
PatchInfoAndG rt p wA wB -> String
hashedPatchFileName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Packing patches" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
repo
  [String]
is <- forall a b. (a -> b) -> [a] -> [b]
map ((String
darcsdir String -> String -> String
</> String
"inventories") String -> String -> String
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
listInventories
  String -> String -> IO ()
writeFile (String
darcsdir String -> String -> String
</> String
"meta-filelist-inventories") forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map String -> String
takeFileName [String]
is
  -- Note: tinkering with zlib's compression parameters does not make
  -- any noticeable difference in generated archive size;
  -- switching to bzip2 would provide ~25% gain OTOH.
  String -> ByteString -> IO ()
BLC.writeFile (String
patchesTar String -> String -> String
<.> String
"part") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZ.compress forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entry] -> ByteString
Tar.write forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Entry
fileEntry' ((String
darcsdir String -> String -> String
</> String
"meta-filelist-inventories") forall a. a -> [a] -> [a]
: [String]
ps forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
reverse [String]
is)
  String -> String -> IO ()
renameFile (String
patchesTar String -> String -> String
<.> String
"part") String
patchesTar
  -- pack basicTar
  [String]
pr <- [String] -> IO [String]
sortByMTime forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO [String]
dirContents (String
darcsdir String -> String -> String
</> String
"pristine.hashed")
  String -> String -> IO ()
writeFile (String
darcsdir String -> String -> String
</> String
"meta-filelist-pristine") forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map String -> String
takeFileName [String]
pr
  String -> ByteString -> IO ()
BLC.writeFile (String
basicTar String -> String -> String
<.> String
"part") forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZ.compress forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entry] -> ByteString
Tar.write forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Entry
fileEntry' (
    [ String
darcsdir String -> String -> String
</> String
"meta-filelist-pristine"
    , String
darcsdir String -> String -> String
</> String
"hashed_inventory"
    ] forall a. [a] -> [a] -> [a]
++ forall a. String -> [a] -> [a]
progressList String
"Packing pristine" (forall a. [a] -> [a]
reverse [String]
pr))
  String -> String -> IO ()
renameFile (String
basicTar String -> String -> String
<.> String
"part") String
basicTar
 where
  basicTar :: String
basicTar = String
darcsdir String -> String -> String
</> String
packsDir String -> String -> String
</> String
basicPack
  patchesTar :: String
patchesTar = String
darcsdir String -> String -> String
</> String
packsDir String -> String -> String
</> String
patchesPack
  fileEntry' :: String -> IO Entry
fileEntry' String
x = forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
    ByteString
content <- [ByteString] -> ByteString
BLC.fromChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
gzReadFilePS String
x
    TarPath
tp <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> String -> Either String TarPath
toTarPath Bool
False String
x
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TarPath -> ByteString -> Entry
fileEntry TarPath
tp ByteString
content
  dirContents :: String -> IO [String]
dirContents String
dir = forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> String -> String
</>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
dir
  hashedPatchFileName :: PatchInfoAndG rt p wA wB -> String
hashedPatchFileName PatchInfoAndG rt p wA wB
x = case forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> Either (p wA wB) String
extractHash PatchInfoAndG rt p wA wB
x of
    Left p wA wB
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected unhashed patch"
    Right String
h -> String
darcsdir String -> String -> String
</> String
"patches" String -> String -> String
</> String
h
  sortByMTime :: [String] -> IO [String]
sortByMTime [String]
xs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
x -> (\UTCTime
t -> (UTCTime
t, String
x)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    String -> IO UTCTime
getModificationTime String
x) [String]
xs
  removeFileIfExists :: String -> IO ()
removeFileIfExists String
x = do
    Bool
ex <- String -> IO Bool
doesFileExist String
x
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ex forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
x