--  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 Prelude ()
import Darcs.Prelude hiding ( writeFile )

import Data.ByteString.Lazy ( writeFile )
import Data.Char ( isAlphaNum )
import Control.Monad ( when )
import System.Directory ( setCurrentDirectory )
import System.Process ( system )
import System.Exit ( ExitCode(..), exitWith )
import System.FilePath.Posix ( takeFileName, (</>) )

import Darcs.Util.Workaround ( getCurrentDirectory )
import Codec.Archive.Tar ( pack, write )
import Codec.Archive.Tar.Entry ( entryPath )
import Codec.Compression.GZip ( compress )

import Codec.Archive.Zip ( emptyArchive, fromArchive, addEntryToArchive, toEntry )
import Darcs.Util.External ( fetchFilePS, Cachable( Uncachable ) )
import Darcs.Util.Global ( darcsdir )
import Darcs.Repository.Hashed ( peekPristineHash )
import Darcs.Repository.HashedIO ( pathsAndContents )
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString as B
import Darcs.UI.Flags as F ( DarcsFlag, useCache )
import qualified Darcs.UI.Flags as F ( setScriptsExecutable )
import Darcs.UI.Options
    ( (^), oid, odesc, ocheck, onormalise
    , defaultFlags, 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 ( withTempDir )
import Darcs.Patch.Match ( haveNonrangeMatch )
import Darcs.Repository.Match ( getNonrangeMatch )
import Darcs.Repository ( withRepository, withRepositoryLocation, RepoJob(..),
                          setScriptsExecutable, repoPatchType, repoCache,
                          createPartialsPristineDirectoryTree )
import Darcs.Repository.Prefs ( getPrefval )

import Darcs.Util.DateTime ( getCurrentTime, toSeconds )
import Darcs.Util.Path ( AbsolutePath, toFilePath )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Printer ( text, vcat )


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

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

dist :: DarcsCommand [DarcsFlag]
dist :: DarcsCommand [DarcsFlag]
dist = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "dist"
    , commandHelp :: String
commandHelp = String
distHelp
    , commandDescription :: String
commandDescription = String
distDescription
    , commandExtraArgs :: Int
commandExtraArgs = 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
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = []
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
distBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
distOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
distOpts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
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 :: DarcsOption
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
distOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> a)
distBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> Bool
   -> Maybe String
   -> [MatchFlag]
   -> SetScriptsExecutable
   -> Bool
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> UseCache
   -> HooksConfig
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     (Maybe String
      -> Bool
      -> Maybe String
      -> [MatchFlag]
      -> SetScriptsExecutable
      -> Bool
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a) (UseCache -> HooksConfig -> a)
forall (d :: * -> *) f a. OptSpec d f a a
oid

distCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
distCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
distCmd _ opts :: [DarcsFlag]
opts _ | 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 _ opts :: [DarcsFlag]
opts _ = UseCache -> RepoJob () -> IO ()
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO ())
 -> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR 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 MatchOption
O.matchUpToOne [DarcsFlag]
opts
  String
formerdir <- IO String
getCurrentDirectory
  let distname :: String
distname = String -> Maybe String -> String
getDistName String
formerdir (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)
  Maybe String
predist <- String -> IO (Maybe String)
getPrefval "predist"
  let resultfile :: String
resultfile = String
formerdir String -> String -> String
</> String
distname String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".tar.gz"
  String -> (AbsolutePath -> IO ()) -> IO ()
forall a. String -> (AbsolutePath -> IO a) -> IO a
withTempDir "darcsdist" ((AbsolutePath -> IO ()) -> IO ())
-> (AbsolutePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \tempdir :: AbsolutePath
tempdir -> do
    String -> IO ()
setCurrentDirectory String
formerdir
    String -> (AbsolutePath -> IO ()) -> IO ()
forall a. String -> (AbsolutePath -> IO a) -> IO a
withTempDir (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
tempdir String -> String -> String
</> String -> String
takeFileName String
distname) ((AbsolutePath -> IO ()) -> IO ())
-> (AbsolutePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ddir :: AbsolutePath
ddir -> do
      if PatchType rt p -> [MatchFlag] -> Bool
forall (rt :: RepoType) (p :: * -> * -> *).
(IsRepoType rt, Matchable p) =>
PatchType rt p -> [MatchFlag] -> Bool
haveNonrangeMatch (Repository rt p wR wU wR -> PatchType rt p
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> PatchType rt p
repoPatchType Repository rt p wR wU wR
repository) [MatchFlag]
matchFlags
        then AbsolutePath -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory AbsolutePath
ddir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wR -> [MatchFlag] -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPatch p,
 ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> [MatchFlag] -> IO ()
getNonrangeMatch Repository rt p wR wU wR
repository [MatchFlag]
matchFlags
        else Repository rt p wR wU wR -> [String] -> String -> IO ()
forall fp (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
FilePathLike fp =>
Repository rt p wR wU wT -> [fp] -> String -> IO ()
createPartialsPristineDirectoryTree Repository rt p wR wU wR
repository [""] (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
ddir)
      ExitCode
ec <- case Maybe String
predist of Nothing -> ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
                            Just pd :: String
pd -> String -> IO ExitCode
system String
pd
      if ExitCode
ec ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
        then do
          AbsolutePath -> IO () -> IO ()
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory AbsolutePath
ddir (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
              (PrimDarcsOption SetScriptsExecutable
F.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 ()
setScriptsExecutable
          [DarcsFlag] -> AbsolutePath -> AbsolutePath -> String -> IO ()
doDist [DarcsFlag]
opts AbsolutePath
tempdir AbsolutePath
ddir String
resultfile
        else do
          String -> IO ()
putStrLn "Dist aborted due to predist failure"
          ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith ExitCode
ec


-- | This function performs the actual distribution action itself.
-- NB - it does /not/ perform the pre-dist, that should already
-- have completed successfully before this is invoked.
doDist :: [DarcsFlag] -> AbsolutePath -> AbsolutePath -> FilePath -> IO ()
doDist :: [DarcsFlag] -> AbsolutePath -> AbsolutePath -> String -> IO ()
doDist opts :: [DarcsFlag]
opts tempdir :: AbsolutePath
tempdir ddir :: AbsolutePath
ddir resultfile :: String
resultfile = do
    String -> IO ()
setCurrentDirectory (AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
tempdir)
    let safeddir :: String
safeddir = String -> String
safename (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
takeFileName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ AbsolutePath -> String
forall a. FilePathLike a => a -> String
toFilePath AbsolutePath
ddir
    [Entry]
entries <- String -> [String] -> IO [Entry]
pack "." [String
safeddir]
    [DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Entry -> Doc) -> [Entry] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> (Entry -> String) -> Entry -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> String
entryPath) [Entry]
entries
    String -> ByteString -> IO ()
writeFile String
resultfile (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
compress (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [Entry] -> ByteString
write [Entry]
entries
    [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ "Created dist as " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
resultfile
  where
    safename :: String -> String
safename n :: String
n@(c :: Char
c:_) | Char -> Bool
isAlphaNum Char
c  = String
n
    safename n :: String
n = "./" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n


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

doFastZip :: [DarcsFlag] -> IO ()
doFastZip :: [DarcsFlag] -> IO ()
doFastZip opts :: [DarcsFlag]
opts = do
  String
currentdir <- IO String
getCurrentDirectory
  let distname :: String
distname = String -> Maybe String -> String
getDistName String
currentdir (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
resultfile = String
currentdir String -> String -> String
</> String
distname String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".zip"
  [DarcsFlag] -> String -> (ByteString -> IO ()) -> IO ()
forall a. [DarcsFlag] -> String -> (ByteString -> IO a) -> IO a
doFastZip' [DarcsFlag]
opts String
currentdir (String -> ByteString -> IO ()
writeFile String
resultfile)
  [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ "Created " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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' :: [DarcsFlag] -> String -> (ByteString -> IO a) -> IO a
doFastZip' opts :: [DarcsFlag]
opts path :: String
path act :: ByteString -> IO a
act = UseCache -> String -> RepoJob a -> IO a
forall a. UseCache -> String -> RepoJob a -> IO a
withRepositoryLocation (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 a -> IO a) -> RepoJob a -> IO a
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO a)
 -> RepoJob a)
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO a)
-> RepoJob a
forall a b. (a -> b) -> a -> b
$ \repo :: Repository rt p wR wU wR
repo -> do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrimDarcsOption SetScriptsExecutable
F.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 "WARNING: Zip archives cannot store executable flag."  
  let distname :: String
distname = String -> Maybe String -> String
getDistName String
path (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)
  ByteString
i <- String -> Cachable -> IO ByteString
fetchFilePS (String
path String -> String -> String
</> String
darcsdir String -> String -> String
</> "hashed_inventory") Cachable
Uncachable
  [(String, ByteString)]
pristine <- String -> Cache -> String -> IO [(String, ByteString)]
pathsAndContents (String
distname String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/") (Repository rt p wR wU wR -> Cache
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wR
repo) (ByteString -> String
peekPristineHash ByteString
i)
  Integer
epochtime <- UTCTime -> Integer
toSeconds (UTCTime -> Integer) -> IO UTCTime -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO UTCTime
getCurrentTime
  let entries :: [Entry]
entries = [ String -> Integer -> ByteString -> Entry
toEntry String
filepath Integer
epochtime (ByteString -> ByteString
toLazy ByteString
contents) | (filepath :: String
filepath,contents :: ByteString
contents) <- [(String, ByteString)]
pristine ]
  let archive :: Archive
archive = (Entry -> Archive -> Archive) -> Archive -> [Entry] -> Archive
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Entry -> Archive -> Archive
addEntryToArchive Archive
emptyArchive [Entry]
entries
  ByteString -> IO a
act (Archive -> ByteString
fromArchive Archive
archive)


toLazy :: B.ByteString -> BL.ByteString
toLazy :: ByteString -> ByteString
toLazy bs :: ByteString
bs = [ByteString] -> ByteString
BL.fromChunks [ByteString
bs]