1--  Copyright (C) 2003 David Roundy
2--
3--  This program is free software; you can redistribute it and/or modify
4--  it under the terms of the GNU General Public License as published by
5--  the Free Software Foundation; either version 2, or (at your option)
6--  any later version.
7--
8--  This program is distributed in the hope that it will be useful,
9--  but WITHOUT ANY WARRANTY; without even the implied warranty of
10--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11--  GNU General Public License for more details.
12--
13--  You should have received a copy of the GNU General Public License
14--  along with this program; see the file COPYING.  If not, write to
15--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
16--  Boston, MA 02110-1301, USA.
17
18-- |
19-- Module      : Darcs.UI.Commands.Dist
20-- Copyright   : 2003 David Roundy
21-- License     : GPL
22-- Maintainer  : darcs-devel@darcs.net
23-- Stability   : experimental
24-- Portability : portable
25
26module Darcs.UI.Commands.Dist
27    (
28      dist
29    , doFastZip -- libdarcs export
30    , doFastZip'
31    ) where
32
33import Darcs.Prelude hiding ( writeFile )
34
35import Data.ByteString.Lazy ( writeFile )
36import Control.Monad ( when )
37import System.Directory ( createDirectory, setCurrentDirectory )
38import System.Process ( system )
39import System.Exit ( ExitCode(..), exitWith )
40import System.FilePath.Posix ( takeFileName, (</>) )
41
42import Darcs.Util.Workaround ( getCurrentDirectory )
43import Codec.Archive.Tar ( pack, write )
44import Codec.Archive.Tar.Entry ( entryPath )
45import Codec.Compression.GZip ( compress )
46
47import Codec.Archive.Zip ( emptyArchive, fromArchive, addEntryToArchive, toEntry )
48import Darcs.Util.External ( fetchFilePS, Cachable( Uncachable ) )
49import Darcs.Repository.Inventory ( peekPristineHash )
50import Darcs.Repository.HashedIO ( pathsAndContents )
51import Darcs.Repository.Paths ( hashedInventoryPath )
52import qualified Data.ByteString.Lazy as BL
53import qualified Data.ByteString as B
54import Darcs.UI.Flags as F ( DarcsFlag, useCache )
55import qualified Darcs.UI.Flags as F ( setScriptsExecutable )
56import Darcs.UI.Options
57    ( (^), oid, odesc, ocheck
58    , defaultFlags, parseFlags, (?)
59    )
60import qualified Darcs.UI.Options.All as O
61
62import Darcs.UI.Commands
63    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository
64    , putVerbose, putInfo
65    )
66import Darcs.UI.Completion ( noArgs )
67import Darcs.Util.Lock ( withTempDir )
68import Darcs.Patch.Match ( patchSetMatch )
69import Darcs.Repository.Match ( getRecordedUpToMatch )
70import Darcs.Repository ( withRepository, withRepositoryLocation, RepoJob(..),
71                          setScriptsExecutable, repoCache,
72                          createPartialsPristineDirectoryTree )
73import Darcs.Repository.Prefs ( getPrefval )
74
75import Darcs.Util.DateTime ( getCurrentTime, toSeconds )
76import Darcs.Util.Path ( AbsolutePath, toFilePath, anchoredRoot )
77import Darcs.Util.File ( withCurrentDirectory )
78import Darcs.Util.Printer ( Doc, text, vcat )
79
80
81distDescription :: String
82distDescription = "Create a distribution archive."
83
84distHelp :: Doc
85distHelp = text $ unlines
86  [ "`darcs dist` creates a compressed archive in the repository's root"
87  , "directory, containing the recorded state of the working tree"
88  , "(unrecorded changes and the `_darcs` directory are excluded)."
89  , "The command accepts matchers to create an archive of some past"
90  , "repository state, for instance `--tag`."
91  , ""
92  , "By default, the archive (and the top-level directory within the"
93  , "archive) has the same name as the repository, but this can be"
94  , "overridden with the `--dist-name` option."
95  , ""
96  , "If a predist command is set (see `darcs setpref`), that command will"
97  , "be run on the recorded state prior to archiving.  For example,"
98  , "autotools projects would set it to `autoconf && automake`."
99  , ""
100  , "If `--zip` is used, matchers and the predist command are ignored."
101  ]
102
103dist :: DarcsCommand
104dist = DarcsCommand
105    { commandProgramName = "darcs"
106    , commandName = "dist"
107    , commandHelp = distHelp
108    , commandDescription = distDescription
109    , commandExtraArgs = 0
110    , commandExtraArgHelp = []
111    , commandCommand = distCmd
112    , commandPrereq = amInHashedRepository
113    , commandCompleteArgs = noArgs
114    , commandArgdefaults = nodefaults
115    , commandAdvancedOptions = []
116    , commandBasicOptions = odesc distBasicOpts
117    , commandDefaults = defaultFlags distOpts
118    , commandCheckOptions = ocheck distOpts
119    }
120  where
121    distBasicOpts
122      = O.distname
123      ^ O.distzip
124      ^ O.repoDir
125      ^ O.matchUpToOne
126      ^ O.setScriptsExecutable
127      ^ O.storeInMemory
128    distOpts = distBasicOpts `withStdOpts` oid
129
130distCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
131distCmd _ opts _ | O.distzip ? opts = doFastZip opts
132distCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $ \repository -> do
133  let matchFlags = parseFlags O.matchUpToOne opts
134  formerdir <- getCurrentDirectory
135  let distname = getDistName formerdir (O.distname ? opts)
136  predist <- getPrefval "predist"
137  let resultfile = formerdir </> distname ++ ".tar.gz"
138  withTempDir "darcsdist" $ \tempdir -> do
139      setCurrentDirectory formerdir
140      let ddir = toFilePath tempdir </> distname
141      createDirectory ddir
142      case patchSetMatch matchFlags of
143        Just psm -> withCurrentDirectory ddir $ getRecordedUpToMatch repository psm
144        Nothing -> createPartialsPristineDirectoryTree repository [anchoredRoot] (toFilePath ddir)
145      ec <- case predist of Nothing -> return ExitSuccess
146                            Just pd -> system pd
147      if ec == ExitSuccess
148        then do
149          withCurrentDirectory ddir $
150            when
151              (F.setScriptsExecutable ? opts == O.YesSetScriptsExecutable)
152              setScriptsExecutable
153          doDist opts tempdir distname resultfile
154        else do
155          putStrLn "Dist aborted due to predist failure"
156          exitWith ec
157
158
159-- | This function performs the actual distribution action itself.
160-- NB - it does /not/ perform the pre-dist, that should already
161-- have completed successfully before this is invoked.
162doDist :: [DarcsFlag] -> AbsolutePath -> String -> FilePath -> IO ()
163doDist opts tempdir name resultfile = do
164    setCurrentDirectory (toFilePath tempdir)
165    entries <- pack "." [name]
166    putVerbose opts $ vcat $ map (text . entryPath) entries
167    writeFile resultfile $ compress $ write entries
168    putInfo opts $ text $ "Created dist as " ++ resultfile
169
170
171getDistName :: FilePath -> Maybe String -> FilePath
172getDistName _ (Just dn) = takeFileName dn
173getDistName currentDirectory _ = takeFileName currentDirectory
174
175doFastZip :: [DarcsFlag] -> IO ()
176doFastZip opts = do
177  currentdir <- getCurrentDirectory
178  let distname = getDistName currentdir (O.distname ? opts)
179  let resultfile = currentdir </> distname ++ ".zip"
180  doFastZip' opts currentdir (writeFile resultfile)
181  putInfo opts $ text $ "Created " ++ resultfile
182
183doFastZip' :: [DarcsFlag]              -- ^ Flags/options
184           -> FilePath                 -- ^ The path to the repository
185           -> (BL.ByteString -> IO a)  -- ^ An action to perform on the archive contents
186           -> IO a
187doFastZip' opts path act = withRepositoryLocation (useCache ? opts) path $ RepoJob $ \repo -> do
188  when (F.setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $
189    putStrLn "WARNING: Zip archives cannot store executable flag."
190  let distname = getDistName path (O.distname ? opts)
191  i <- fetchFilePS (path </> hashedInventoryPath) Uncachable
192  pristine <- pathsAndContents (distname ++ "/") (repoCache repo) (peekPristineHash i)
193  epochtime <- toSeconds `fmap` getCurrentTime
194  let entries = [ toEntry filepath epochtime (toLazy contents) | (filepath,contents) <- pristine ]
195  let archive = foldr addEntryToArchive emptyArchive entries
196  act (fromArchive archive)
197
198
199toLazy :: B.ByteString -> BL.ByteString
200toLazy bs = BL.fromChunks [bs]
201