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