--  Copyright (C) 2003 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

-- |
-- Module      : Darcs.UI.Commands.Dist
-- Copyright   : 2003 David Roundy
-- License     : GPL
-- Maintainer  : darcs-devel@darcs.net
-- Stability   : experimental
-- Portability : portable

module Darcs.UI.Commands.Dist
    (
      dist
    , doFastZip -- libdarcs export
    , doFastZip'
    ) where

import Darcs.Prelude

import Control.Monad ( forM, unless, when )
import System.Process ( system )
import System.Exit ( ExitCode(..), exitWith )
import System.FilePath.Posix ( takeFileName, (</>) )

import Darcs.Util.Workaround ( getCurrentDirectory )
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import Codec.Compression.GZip ( compress )

import qualified Codec.Archive.Zip as Zip
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import Darcs.UI.Flags as F ( DarcsFlag, useCache )
import Darcs.UI.Options ( oid, parseFlags, (?), (^) )
import qualified Darcs.UI.Options.All as O

import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository
    , putVerbose, putInfo
    )
import Darcs.UI.Completion ( noArgs )
import Darcs.Util.Lock ( withDelayedDir )
import Darcs.Patch.Match ( patchSetMatch )
import Darcs.Repository.Match ( getPristineUpToMatch )
import Darcs.Repository ( RepoJob(..), withRepository, withRepositoryLocation )
import Darcs.Repository.Prefs ( getPrefval )
import Darcs.Repository.Pristine ( readPristine )

import Darcs.Util.DateTime ( getCurrentTime, toSeconds )
import Darcs.Util.Path ( AbsolutePath, realPath, toFilePath )
import Darcs.Util.Printer ( Doc, text, vcat )
import qualified Darcs.Util.Tree as T
import Darcs.Util.Tree.Plain ( readPlainTree, writePlainTree )


distDescription :: String
distDescription :: String
distDescription = String
"Create a distribution archive."

distHelp :: Doc
distHelp :: Doc
distHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
  [ String
"`darcs dist` creates a compressed archive in the repository's root"
  , String
"directory, containing the recorded state of the working tree"
  , String
"(unrecorded changes and the `_darcs` directory are excluded)."
  , String
"The command accepts matchers to create an archive of some past"
  , String
"repository state, for instance `--tag`."
  , String
""
  , String
"By default, the archive (and the top-level directory within the"
  , String
"archive) has the same name as the repository, but this can be"
  , String
"overridden with the `--dist-name` option."
  , String
""
  , String
"If a predist command is set (see `darcs setpref`), that command will"
  , String
"be run on the recorded state prior to archiving.  For example,"
  , String
"autotools projects would set it to `autoconf && automake`."
  , String
""
  , String
"If `--zip` is used, matchers and the predist command are ignored."
  ]

dist :: DarcsCommand
dist :: DarcsCommand
dist = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"dist"
    , commandHelp :: Doc
commandHelp = Doc
distHelp
    , commandDescription :: String
commandDescription = String
distDescription
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
distCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
distOpts
    }
  where
    distBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
distBasicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
  (Maybe String)
PrimDarcsOption (Maybe String)
O.distname
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
  (Maybe String)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> [MatchFlag] -> SetScriptsExecutable -> Bool -> a)
     (Bool
      -> Maybe String
      -> [MatchFlag]
      -> SetScriptsExecutable
      -> Bool
      -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> [MatchFlag] -> SetScriptsExecutable -> Bool -> a)
     (Maybe String
      -> Bool
      -> Maybe String
      -> [MatchFlag]
      -> SetScriptsExecutable
      -> Bool
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> [MatchFlag] -> SetScriptsExecutable -> Bool -> a)
  (Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
PrimDarcsOption Bool
O.distzip
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> [MatchFlag] -> SetScriptsExecutable -> Bool -> a)
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     ([MatchFlag] -> SetScriptsExecutable -> Bool -> a)
     (Maybe String -> [MatchFlag] -> SetScriptsExecutable -> Bool -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     ([MatchFlag] -> SetScriptsExecutable -> Bool -> a)
     (Maybe String
      -> Bool
      -> Maybe String
      -> [MatchFlag]
      -> SetScriptsExecutable
      -> Bool
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  ([MatchFlag] -> SetScriptsExecutable -> Bool -> a)
  (Maybe String -> [MatchFlag] -> SetScriptsExecutable -> Bool -> a)
PrimDarcsOption (Maybe String)
O.repoDir
      OptSpec
  DarcsOptDescr
  DarcsFlag
  ([MatchFlag] -> SetScriptsExecutable -> Bool -> a)
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (SetScriptsExecutable -> Bool -> a)
     ([MatchFlag] -> SetScriptsExecutable -> Bool -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (SetScriptsExecutable -> Bool -> a)
     (Maybe String
      -> Bool
      -> Maybe String
      -> [MatchFlag]
      -> SetScriptsExecutable
      -> Bool
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (SetScriptsExecutable -> Bool -> a)
  ([MatchFlag] -> SetScriptsExecutable -> Bool -> a)
MatchOption
O.matchUpToOne
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (SetScriptsExecutable -> Bool -> a)
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Bool -> a)
     (SetScriptsExecutable -> Bool -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Bool -> a)
     (Maybe String
      -> Bool
      -> Maybe String
      -> [MatchFlag]
      -> SetScriptsExecutable
      -> Bool
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> a)
  (SetScriptsExecutable -> Bool -> a)
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> a)
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Bool -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe String
      -> Bool
      -> Maybe String
      -> [MatchFlag]
      -> SetScriptsExecutable
      -> Bool
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (Bool -> a)
PrimDarcsOption Bool
O.storeInMemory
    distOpts :: CommandOptions
distOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
distBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
forall (d :: * -> *) f a. OptSpec d f a a
oid

distCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
distCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
distCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ | PrimOptSpec DarcsOptDescr DarcsFlag a Bool
PrimDarcsOption Bool
O.distzip PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts = [DarcsFlag] -> IO ()
doFastZip [DarcsFlag]
opts
distCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ = UseCache -> RepoJob 'RO () -> IO ()
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RO () -> IO ()) -> RepoJob 'RO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RO () -> RepoJob 'RO ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RO () -> RepoJob 'RO ())
-> TreePatchJob 'RO () -> RepoJob 'RO ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RO p wU wR
repository -> do
  let matchFlags :: [MatchFlag]
matchFlags = MatchOption -> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
MatchOption
O.matchUpToOne [DarcsFlag]
opts
  formerdir <- IO String
getCurrentDirectory
  let distname = String -> Maybe String -> String
getDistName String
formerdir (PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
PrimDarcsOption (Maybe String)
O.distname PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
  predist <- getPrefval "predist"
  let resultfile = String
formerdir String -> String -> String
</> String
distname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".tar.gz"
  raw_tree <-
    case patchSetMatch matchFlags of
      Just PatchSetMatch
psm -> Repository 'RO p wU wR -> PatchSetMatch -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSetMatch -> IO (Tree IO)
getPristineUpToMatch Repository 'RO p wU wR
repository PatchSetMatch
psm
      Maybe PatchSetMatch
Nothing -> Repository 'RO p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository 'RO p wU wR
repository
  tree <- case predist of
    Maybe String
Nothing -> Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
T.expand Tree IO
raw_tree
    Just String
pd -> do
      String -> (AbsolutePath -> IO (Tree IO)) -> IO (Tree IO)
forall a. String -> (AbsolutePath -> IO a) -> IO a
withDelayedDir String
"dist" ((AbsolutePath -> IO (Tree IO)) -> IO (Tree IO))
-> (AbsolutePath -> IO (Tree IO)) -> IO (Tree IO)
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
d -> do
        Tree IO -> String -> IO ()
writePlainTree Tree IO
raw_tree String
"."
        ec <- String -> IO ExitCode
system String
pd
        unless (ec == ExitSuccess) $ do
          putStrLn "Dist aborted due to predist failure"
          exitWith ec
        T.expand =<< readPlainTree (toFilePath d)
  entries <- createEntries distname tree
  putVerbose opts $ vcat $ map (text . Tar.entryPath) entries
  BL.writeFile resultfile $ compress $ Tar.write entries
  putInfo opts $ text $ "Created dist as " ++ resultfile
  where
    createEntries :: String -> Tree m -> m [GenEntry TarPath linkTarget]
createEntries String
top Tree m
tree = do
      topentry <- TarPath -> GenEntry TarPath linkTarget
forall tarPath linkTarget. tarPath -> GenEntry tarPath linkTarget
Tar.directoryEntry (TarPath -> GenEntry TarPath linkTarget)
-> m TarPath -> m (GenEntry TarPath linkTarget)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m TarPath)
-> (TarPath -> m TarPath) -> Either String TarPath -> m TarPath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m TarPath
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail TarPath -> m TarPath
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> String -> Either String TarPath
Tar.toTarPath Bool
True String
top)
      rest <- forM (T.list tree) go
      return $ topentry : rest
      where
        go :: (AnchoredPath, TreeItem m) -> m (GenEntry TarPath linkTarget)
go (AnchoredPath
_, T.Stub m (Tree m)
_ Maybe Hash
_) = String -> m (GenEntry TarPath linkTarget)
forall a. HasCallStack => String -> a
error String
"impossible"
        go (AnchoredPath
path, T.SubTree Tree m
_) = do
          tarpath <- (String -> m TarPath)
-> (TarPath -> m TarPath) -> Either String TarPath -> m TarPath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m TarPath
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail TarPath -> m TarPath
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String TarPath -> m TarPath)
-> Either String TarPath -> m TarPath
forall a b. (a -> b) -> a -> b
$ Bool -> String -> Either String TarPath
Tar.toTarPath Bool
True (String
top String -> String -> String
</> AnchoredPath -> String
realPath AnchoredPath
path)
          return $ Tar.directoryEntry tarpath
        go (AnchoredPath
path, T.File Blob m
b) = do
          content <- Blob m -> m ByteString
forall (m :: * -> *). Blob m -> m ByteString
T.readBlob Blob m
b
          tarpath <- either fail return $ Tar.toTarPath False (top </> realPath path)
          let entry = TarPath -> ByteString -> GenEntry TarPath linkTarget
forall tarPath linkTarget.
tarPath -> ByteString -> GenEntry tarPath linkTarget
Tar.fileEntry TarPath
tarpath ByteString
content
          return $
            if O.yes (O.setScriptsExecutable ? opts) &&
               executablePrefix `BL.isPrefixOf` content
              then entry {Tar.entryPermissions = Tar.executableFilePermissions}
              else entry
    executablePrefix :: ByteString
executablePrefix = String -> ByteString
BLC.pack String
"#!"

getDistName :: FilePath -> Maybe String -> FilePath
getDistName :: String -> Maybe String -> String
getDistName String
_ (Just String
dn) = String -> String
takeFileName String
dn
getDistName String
currentDirectory Maybe String
_ = String -> String
takeFileName String
currentDirectory

doFastZip :: [DarcsFlag] -> IO ()
doFastZip :: [DarcsFlag] -> IO ()
doFastZip [DarcsFlag]
opts = do
  currentdir <- IO String
getCurrentDirectory
  let distname = String -> Maybe String -> String
getDistName String
currentdir (PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
PrimDarcsOption (Maybe String)
O.distname PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
  let resultfile = String
currentdir String -> String -> String
</> String
distname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".zip"
  doFastZip' opts currentdir (BL.writeFile resultfile)
  putInfo opts $ text $ "Created " ++ resultfile

doFastZip' :: [DarcsFlag]              -- ^ Flags/options
           -> FilePath                 -- ^ The path to the repository
           -> (BL.ByteString -> IO a)  -- ^ An action to perform on the archive contents
           -> IO a
doFastZip' :: forall a. [DarcsFlag] -> String -> (ByteString -> IO a) -> IO a
doFastZip' [DarcsFlag]
opts String
path ByteString -> IO a
act = UseCache -> String -> RepoJob 'RO a -> IO a
forall a. UseCache -> String -> RepoJob 'RO a -> IO a
withRepositoryLocation (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) String
path (RepoJob 'RO a -> IO a) -> RepoJob 'RO a -> IO a
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RO a -> RepoJob 'RO a
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RO a -> RepoJob 'RO a)
-> TreePatchJob 'RO a -> RepoJob 'RO a
forall a b. (a -> b) -> a -> b
$ \Repository 'RO p wU wR
repo -> do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable PrimDarcsOption SetScriptsExecutable
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts SetScriptsExecutable -> SetScriptsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
O.YesSetScriptsExecutable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn String
"WARNING: Zip archives cannot store executable flag."  
  let distname :: String
distname = String -> Maybe String -> String
getDistName String
path (PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
PrimDarcsOption (Maybe String)
O.distname PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
  pristine <-
    Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
T.expand (Tree IO -> IO (Tree IO)) -> IO (Tree IO) -> IO (Tree IO)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    case [MatchFlag] -> Maybe PatchSetMatch
patchSetMatch (PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
MatchOption
O.matchUpToOne MatchOption -> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) of
      Just PatchSetMatch
psm -> Repository 'RO p wU wR -> PatchSetMatch -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSetMatch -> IO (Tree IO)
getPristineUpToMatch Repository 'RO p wU wR
repo PatchSetMatch
psm
      Maybe PatchSetMatch
Nothing -> Repository 'RO p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository 'RO p wU wR
repo
  pathsAndContents <-
    forM (T.list pristine) $ \(AnchoredPath
p,TreeItem IO
i) -> do
      case TreeItem IO
i of
        T.Stub IO (Tree IO)
_ Maybe Hash
_ -> String -> IO (String, ByteString)
forall a. HasCallStack => String -> a
error String
"tree is not expanded"
        T.SubTree Tree IO
_ -> (String, ByteString) -> IO (String, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
distname String -> String -> String
</> AnchoredPath -> String
realPath AnchoredPath
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/", ByteString
BL.empty)
        T.File Blob IO
b -> do
          content <- Blob IO -> IO ByteString
forall (m :: * -> *). Blob m -> m ByteString
T.readBlob Blob IO
b
          return (distname </> realPath p, content)
  epochtime <- toSeconds `fmap` getCurrentTime
  let entries = [ String -> Integer -> ByteString -> Entry
Zip.toEntry String
filepath Integer
epochtime ByteString
contents | (String
filepath,ByteString
contents) <- [(String, ByteString)]
pathsAndContents ]
  let archive = (Entry -> Archive -> Archive) -> Archive -> [Entry] -> Archive
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Entry -> Archive -> Archive
Zip.addEntryToArchive Archive
Zip.emptyArchive [Entry]
entries
  act (Zip.fromArchive archive)