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 =
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
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 ()
else
Maybe String -> String -> ByteString -> IO ()
writeFile' forall a. Maybe a
Nothing String
path ByteString
content)
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
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
"."
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)
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
[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
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
[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