{-|
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 pristine 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 ( forM_, when )
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.Cache
    ( Cache
    , bucketFolder
    , closestWritableDirectory
    , fetchFileUsingCache
    )
import Darcs.Util.File ( Cachable(..), fetchFileLazyPS, withTemp )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Progress ( debugMessage, progressList )
import Darcs.Util.ValidHash ( InventoryHash, PatchHash, encodeValidHash )

import Darcs.Patch ( 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, AccessType(RW), withRepoDir )
import Darcs.Repository.Hashed ( readPatches )
import Darcs.Repository.Paths
    ( hashedInventoryPath
    , inventoriesDirPath
    , patchesDirPath
    , pristineDirPath
    )
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
               -> Cache
               -> FilePath
               -> IO ()
fetchAndUnpack :: String -> Cache -> String -> IO ()
fetchAndUnpack String
filename Cache
cache String
remote = do
  Cache -> Entries FormatError -> IO ()
forall e. Exception e => Cache -> Entries e -> IO ()
unpackTar Cache
cache (Entries FormatError -> IO ())
-> (ByteString -> Entries FormatError) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries FormatError
Tar.read (ByteString -> Entries FormatError)
-> (ByteString -> ByteString) -> ByteString -> Entries FormatError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZ.decompress (ByteString -> IO ()) -> IO ByteString -> IO ()
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 :: [InventoryHash] -> [PatchHash] -> Cache -> FilePath -> IO ()
fetchAndUnpackPatches :: [InventoryHash] -> [PatchHash] -> Cache -> String -> IO ()
fetchAndUnpackPatches [InventoryHash]
ihs [PatchHash]
phs Cache
cache String
remote =
  -- Patches pack can miss some new patches of the repository.
  -- So we download pack asynchonously and always do a complete pass
  -- of individual patch and inventory files.
  IO () -> (Async () -> IO ()) -> IO ()
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync (String -> Cache -> String -> IO ()
fetchAndUnpack String
patchesPack Cache
cache String
remote) ((Async () -> IO ()) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async ()
_ -> do
    [InventoryHash]
-> (InventoryHash -> IO (String, ByteString)) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [InventoryHash]
ihs (Cache -> InventoryHash -> IO (String, ByteString)
forall h. ValidHash h => Cache -> h -> IO (String, ByteString)
fetchFileUsingCache Cache
cache)
    [PatchHash] -> (PatchHash -> IO (String, ByteString)) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [PatchHash]
phs (Cache -> PatchHash -> IO (String, ByteString)
forall h. ValidHash h => Cache -> h -> IO (String, ByteString)
fetchFileUsingCache Cache
cache)

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

unpackTar :: Exception e => Cache -> Tar.Entries e -> IO ()
unpackTar :: forall e. Exception e => Cache -> Entries e -> IO ()
unpackTar Cache
_ GenEntries TarPath LinkTarget e
Tar.Done = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
unpackTar Cache
_ (Tar.Fail e
e) = e -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO e
e
unpackTar Cache
c (Tar.Next GenEntry TarPath LinkTarget
e GenEntries TarPath LinkTarget e
es) = case GenEntry TarPath LinkTarget -> GenEntryContent LinkTarget
forall tarPath linkTarget.
GenEntry tarPath linkTarget -> GenEntryContent linkTarget
Tar.entryContent GenEntry TarPath LinkTarget
e of
  Tar.NormalFile ByteString
bs FileSize
_ -> do
    let p :: String
p = GenEntry TarPath LinkTarget -> String
forall linkTarget. GenEntry TarPath linkTarget -> String
Tar.entryPath GenEntry TarPath LinkTarget
e
    if String
"meta-" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String -> String
takeFileName String
p
      then Cache -> GenEntries TarPath LinkTarget e -> IO ()
forall e. Exception e => Cache -> Entries e -> IO ()
unpackTar Cache
c GenEntries TarPath LinkTarget e
es -- just ignore them
      else do
        ex <- String -> IO Bool
doesFileExist String
p
        if ex
          then debugMessage $ "TAR thread: exists " ++ p ++ "\nStopping TAR thread."
          else do
            if p == hashedInventoryPath
              then writeFile' Nothing p bs
              else writeFile' (closestWritableDirectory c) p $ GZ.compress bs
            debugMessage $ "TAR thread: GET " ++ p
            unpackTar c es
  GenEntryContent LinkTarget
_ -> String -> IO ()
forall a. String -> IO a
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 = (String -> IO ()) -> IO ()
forall a. (String -> IO a) -> IO a
withTemp ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
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]
_               -> String -> String
forall a. String -> [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected file path"
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory String
path
    String -> String -> IO ()
createLink String
fileFullPath String
path IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOException
ex :: IOException) -> do
      if IOException -> Bool
isAlreadyExistsError IOException
ex then
        () -> IO ()
forall a. a -> IO a
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' Maybe String
forall a. Maybe a
Nothing String
path ByteString
content)

-- | Create packs from the current recorded version of the repository.
createPacks :: RepoPatch p => Repository 'RW p wU wR -> IO ()
createPacks :: forall (p :: * -> * -> *) wU wR.
RepoPatch p =>
Repository 'RW p wU wR -> IO ()
createPacks Repository 'RW p wU wR
repo =
 Repository 'RW p wU wR -> IO () -> IO ()
forall (rt :: AccessType) (p :: * -> * -> *) wU wR a.
Repository rt p wU wR -> IO a -> IO a
withRepoDir Repository 'RW p wU wR
repo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally ((String -> IO ()) -> [String] -> IO ()
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"
  ]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  -- pristine hash
  hash <- Repository 'RW p wU wR -> IO PristineHash
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO PristineHash
readHashedPristineRoot Repository 'RW p wU wR
repo
  createDirectoryIfMissing False (darcsdir </> packsDir)
  writeFile ( darcsdir </> packsDir </> "pristine" ) $ encodeValidHash hash
  -- pack patchesTar
  ps <- mapFL hashedPatchFileName . progressFL "Packing patches" . patchSet2FL <$>
    readPatches repo
  is <- map (inventoriesDirPath </>) <$> listInventories
  writeFile (darcsdir </> "meta-filelist-inventories") . unlines $
    map takeFileName 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.
  BLC.writeFile (patchesTar <.> "part") . GZ.compress . Tar.write =<<
    mapM fileEntry' ((darcsdir </> "meta-filelist-inventories") : ps ++ reverse is)
  renameFile (patchesTar <.> "part") patchesTar
  -- pack basicTar
  pr <- sortByMTime =<< dirContents pristineDirPath
  writeFile (darcsdir </> "meta-filelist-pristine") . unlines $
    map takeFileName pr
  BLC.writeFile (basicTar <.> "part") . GZ.compress . Tar.write =<< mapM fileEntry' (
    [ darcsdir </> "meta-filelist-pristine"
    -- unclean: we should not access the non-tentative version here;
    -- will work because we do not modify the tentative state
    , hashedInventoryPath
    ] ++ progressList "Packing pristine" (reverse pr))
  renameFile (basicTar <.> "part") 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 (GenEntry TarPath linkTarget)
fileEntry' String
x = IO (GenEntry TarPath linkTarget)
-> IO (GenEntry TarPath linkTarget)
forall a. IO a -> IO a
unsafeInterleaveIO (IO (GenEntry TarPath linkTarget)
 -> IO (GenEntry TarPath linkTarget))
-> IO (GenEntry TarPath linkTarget)
-> IO (GenEntry TarPath linkTarget)
forall a b. (a -> b) -> a -> b
$ do
    content <- [ByteString] -> ByteString
BLC.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
gzReadFilePS String
x
    tp <- either fail return $ toTarPath False x
    return $ fileEntry tp content
  dirContents :: String -> IO [String]
dirContents String
dir = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> String -> String
</>) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
dir
  hashedPatchFileName :: PatchInfoAndG p wA wB -> String
hashedPatchFileName PatchInfoAndG p wA wB
x = case PatchInfoAndG p wA wB -> Either (p wA wB) PatchHash
forall (p :: * -> * -> *) wA wB.
PatchInfoAndG p wA wB -> Either (p wA wB) PatchHash
extractHash PatchInfoAndG p wA wB
x of
    Left p wA wB
_ -> String -> String
forall a. String -> [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unexpected unhashed patch"
    Right PatchHash
h -> String
patchesDirPath String -> String -> String
</> PatchHash -> String
forall h. ValidHash h => h -> String
encodeValidHash PatchHash
h
  sortByMTime :: [String] -> IO [String]
sortByMTime [String]
xs = ((UTCTime, String) -> String) -> [(UTCTime, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (UTCTime, String) -> String
forall a b. (a, b) -> b
snd ([(UTCTime, String)] -> [String])
-> ([(UTCTime, String)] -> [(UTCTime, String)])
-> [(UTCTime, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(UTCTime, String)] -> [(UTCTime, String)]
forall a. Ord a => [a] -> [a]
sort ([(UTCTime, String)] -> [String])
-> IO [(UTCTime, String)] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO (UTCTime, String))
-> [String] -> IO [(UTCTime, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\String
x -> (\UTCTime
t -> (UTCTime
t, String
x)) (UTCTime -> (UTCTime, String))
-> IO UTCTime -> IO (UTCTime, String)
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
    ex <- String -> IO Bool
doesFileExist String
x
    when ex $ removeFile x