cabal-install 0.6.2 → 0.6.4
raw patch · 16 files changed
+1116/−460 lines, 16 filesdep ~unix
Dependency ranges changed: unix
Files
- Distribution/Client/Check.hs +9/−9
- Distribution/Client/Config.hs +13/−2
- Distribution/Client/Dependency/TopDown.hs +38/−13
- Distribution/Client/IndexUtils.hs +25/−22
- Distribution/Client/Install.hs +5/−4
- Distribution/Client/InstallSymlink.hs +14/−15
- Distribution/Client/Setup.hs +3/−1
- Distribution/Client/Tar.hs +498/−357
- Distribution/Client/Unpack.hs +3/−3
- Distribution/Client/Update.hs +21/−12
- Distribution/Client/Upload.hs +6/−4
- Distribution/Compat/Version.hs +385/−0
- Main.hs +24/−1
- README +27/−7
- bootstrap.sh +40/−6
- cabal-install.cabal +5/−4
Distribution/Client/Check.hs view
@@ -25,7 +25,7 @@ import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils- ( defaultPackageDesc, toUTF8 )+ ( defaultPackageDesc, toUTF8, wrapText ) check :: Verbosity -> IO Bool check verbosity = do@@ -54,23 +54,19 @@ unless (null buildImpossible) $ do putStrLn "The package will not build sanely due to these errors:"- mapM_ (putStrLn . toUTF8. explanation) buildImpossible- putStrLn ""+ printCheckMessages buildImpossible unless (null buildWarning) $ do putStrLn "The following warnings are likely affect your build negatively:"- mapM_ (putStrLn . toUTF8 . explanation) buildWarning- putStrLn ""+ printCheckMessages buildWarning unless (null distSuspicious) $ do putStrLn "These warnings may cause trouble when distributing the package:"- mapM_ (putStrLn . toUTF8 . explanation) distSuspicious- putStrLn ""+ printCheckMessages distSuspicious unless (null distInexusable) $ do putStrLn "The following errors will cause portability problems on other environments:"- mapM_ (putStrLn . toUTF8 . explanation) distInexusable- putStrLn ""+ printCheckMessages distInexusable let isDistError (PackageDistSuspicious {}) = False isDistError _ = True@@ -83,3 +79,7 @@ putStrLn "No errors or warnings could be found in the package." return (null packageChecks)++ where+ printCheckMessages = mapM_ (putStrLn . format . explanation)+ format = toUTF8 . wrapText . ("* "++)
Distribution/Client/Config.hs view
@@ -74,7 +74,7 @@ import Data.Monoid ( Monoid(..) ) import Control.Monad- ( when, foldM )+ ( when, foldM, liftM ) import qualified Data.Map as Map import qualified Distribution.Compat.ReadP as Parse ( option )@@ -88,6 +88,8 @@ ( URI(..), URIAuth(..) ) import System.FilePath ( (</>), takeDirectory )+import System.Environment+ ( getEnvironment ) import System.IO.Error ( isDoesNotExistError ) @@ -228,11 +230,20 @@ loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do- configFile <- maybe defaultConfigFile return (flagToMaybe configFileFlag)+ let sources = [+ ("commandline option", return . flagToMaybe $ configFileFlag),+ ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment),+ ("default config file", Just `liftM` defaultConfigFile) ] + getSource [] = error "no config file path candidate found."+ getSource ((msg,action): xs) = + action >>= maybe (getSource xs) (return . (,) msg)++ (source, configFile) <- getSource sources minp <- readConfigFile mempty configFile case minp of Nothing -> do+ notice verbosity $ "Config file path source is " ++ source ++ "." notice verbosity $ "Config file " ++ configFile ++ " not found." notice verbosity $ "Writing default configuration to " ++ configFile commentConf <- commentSavedConfig
Distribution/Client/Dependency/TopDown.hs view
@@ -42,6 +42,8 @@ ( finalizePackageDescription, flattenPackageDescription ) import Distribution.Version ( VersionRange(AnyVersion), withinRange )+import Distribution.Compat.Version+ ( asVersionIntervals, UpperBound(..), simplifyVersionRange ) import Distribution.Compiler ( CompilerId ) import Distribution.System@@ -442,13 +444,15 @@ finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) = InstallPlan.Configured (ConfiguredPackage pkg flags deps') where- deps' = map (packageId . pickRemaining) deps- pickRemaining dep =+ deps' = map (packageId . pickRemaining mipkg) deps++ pickRemaining mipkg dep@(Dependency _name versionRange) = case PackageIndex.lookupDependency remainingChoices dep of [] -> impossible [pkg'] -> pkg' remaining -> assert (checkIsPaired remaining) $ maximumBy bestByPref remaining+ where -- We order candidate packages to pick for a dependency by these -- three factors. The last factor is just highest version wins. bestByPref =@@ -459,11 +463,22 @@ isCurrent = case mipkg :: Maybe InstalledPackage of Nothing -> \_ -> False Just ipkg -> \p -> packageId p `elem` depends ipkg- -- Is this package a preferred version acording to the hackage or- -- user's suggested version constraints- isPreferred p = packageVersion p `withinRange` preferredVersions+ -- If there is no upper bound on the version range then we apply a+ -- preferred version acording to the hackage or user's suggested+ -- version constraints. TODO: distinguish hacks from prefs+ bounded = boundedAbove versionRange+ isPreferred p+ | bounded = True -- any constant will do+ | otherwise = packageVersion p `withinRange` preferredVersions where (PackagePreferences preferredVersions _) = pref (packageName p) + boundedAbove :: VersionRange -> Bool+ boundedAbove vr = case asVersionIntervals vr of+ [] -> True -- this is the inconsistent version range.+ intervals -> case last intervals of+ (_, UpperBound _ _) -> True+ (_, NoUpperBound ) -> False+ -- We really only expect to find more than one choice remaining when -- we're finalising a dependency on a paired package. checkIsPaired [p1, p2] =@@ -627,10 +642,10 @@ display pkgid ++ " was excluded because it could not be configured" showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) = display pkgid ++ " was excluded because " ++- display pkgid' ++ " requires " ++ display (untagDependency dep)+ display pkgid' ++ " requires " ++ displayDep (untagDependency dep) showExclusionReason pkgid (ExcludedByTopLevelDependency dep) = display pkgid ++ " was excluded because of the top level dependency " ++- display dep+ displayDep dep -- ------------------------------------------------------------@@ -685,16 +700,16 @@ showFailure :: Failure -> String showFailure (ConfigureFailed pkg missingDeps) = "cannot configure " ++ displayPkg pkg ++ ". It requires "- ++ listOf (display . fst) missingDeps+ ++ listOf (displayDep . fst) missingDeps ++ '\n' : unlines (map (uncurry whyNot) missingDeps) where whyNot (Dependency name ver) [] = "There is no available version of " ++ display name- ++ " that satisfies " ++ display ver+ ++ " that satisfies " ++ displayVer ver whyNot dep conflicts =- "For the dependency on " ++ display dep+ "For the dependency on " ++ displayDep dep ++ " there are these packages: " ++ listOf display pkgs ++ ". However none of them are available.\n" ++ unlines [ showExclusionReason (packageId pkg') reason@@ -704,19 +719,19 @@ showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) = "dependencies conflict: "- ++ displayPkg pkg ++ " requires " ++ display dep ++ " however\n"+ ++ displayPkg pkg ++ " requires " ++ displayDep dep ++ " however\n" ++ unlines [ showExclusionReason (packageId pkg') reason | (pkg', reasons) <- conflicts, reason <- reasons ] showFailure (TopLevelVersionConstraintConflict name ver conflicts) = "constraints conflict: "- ++ "top level constraint " ++ display (Dependency name ver) ++ " however\n"+ ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n" ++ unlines [ showExclusionReason (packageId pkg') reason | (pkg', reasons) <- conflicts, reason <- reasons ] showFailure (TopLevelVersionConstraintUnsatisfiable name ver) = "There is no available version of " ++ display name- ++ " that satisfies " ++ display ver+ ++ " that satisfies " ++ displayVer ver showFailure (TopLevelInstallConstraintConflict name conflicts) = "constraints conflict: "@@ -726,6 +741,16 @@ showFailure (TopLevelInstallConstraintUnsatisfiable name) = "There is no installed version of " ++ display name++displayVer :: VersionRange -> String+displayVer = display . simplifyVersionRange++displayDep :: Dependency -> String+displayDep = display . simplifyDependency++simplifyDependency :: Dependency -> Dependency+simplifyDependency (Dependency name range) =+ Dependency name (simplifyVersionRange range) -- ------------------------------------------------------------ -- * Utils
Distribution/Client/IndexUtils.hs view
@@ -124,11 +124,12 @@ `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs)) extractPrefs :: Tar.Entry -> Maybe [Dependency]- extractPrefs entry- | takeFileName (Tar.fileName entry) == "preferred-versions"- = Just . parsePreferredVersions- . BS.Char8.unpack . Tar.fileContent $ entry- | otherwise = Nothing+ extractPrefs entry = case Tar.entryContent entry of+ Tar.NormalFile content _+ | takeFileName (Tar.entryPath entry) == "preferred-versions"+ -> Just . parsePreferredVersions+ . BS.Char8.unpack $ content+ _ -> Nothing handleNotFound action = catch action $ \e -> if isDoesNotExistError e then do@@ -189,24 +190,25 @@ parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) [] extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription)-extractPkg entry- | takeExtension fileName == ".cabal"- = case splitDirectories (normalise fileName) of- [pkgname,vers,_] -> case simpleParse vers of- Just ver -> Just (pkgid, descr)- where- pkgid = PackageIdentifier (PackageName pkgname) ver- parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack- . Tar.fileContent $ entry- descr = case parsed of- ParseOk _ d -> d- _ -> error $ "Couldn't read cabal file "- ++ show fileName+extractPkg entry = case Tar.entryContent entry of+ Tar.NormalFile content _+ | takeExtension fileName == ".cabal"+ -> case splitDirectories (normalise fileName) of+ [pkgname,vers,_] -> case simpleParse vers of+ Just ver -> Just (pkgid, descr)+ where+ pkgid = PackageIdentifier (PackageName pkgname) ver+ parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack+ $ content+ descr = case parsed of+ ParseOk _ d -> d+ _ -> error $ "Couldn't read cabal file "+ ++ show fileName+ _ -> Nothing _ -> Nothing- _ -> Nothing- | otherwise = Nothing+ _ -> Nothing where- fileName = Tar.fileName entry+ fileName = Tar.entryPath entry foldlTarball :: (a -> Tar.Entry -> a) -> a -> ByteString -> Either String a@@ -232,7 +234,8 @@ (_, Left name)) <- zip deps names ] ambigious -> die $ unlines [ if null matches- then "There is no package named " ++ display name+ then "There is no package named " ++ display name ++ ". "+ ++ "Perhaps you need to run 'cabal update' first?" else "The package name " ++ display name ++ "is ambigious. " ++ "It could be: " ++ intercalate ", " (map display matches) | (name, matches) <- ambigious ]
Distribution/Client/Install.hs view
@@ -548,14 +548,15 @@ withTempDirectory tmp (display pkgid) $ \tmpDirPath -> do info verbosity $ "Extracting " ++ pkgPath ++ " to " ++ tmpDirPath ++ "..."- extractTarGzFile tmpDirPath pkgPath- let unpackedPath = tmpDirPath </> display pkgid- descFilePath = unpackedPath+ let relUnpackedPath = display pkgid+ absUnpackedPath = tmpDirPath </> relUnpackedPath+ descFilePath = absUnpackedPath </> display (packageName pkgid) <.> "cabal"+ extractTarGzFile tmpDirPath relUnpackedPath pkgPath exists <- doesFileExist descFilePath when (not exists) $ die $ "Package .cabal file not found: " ++ show descFilePath- installPkg (Just unpackedPath)+ installPkg (Just absUnpackedPath) installUnpackedPackage :: Verbosity -> SetupScriptOptions
Distribution/Client/InstallSymlink.hs view
@@ -63,12 +63,12 @@ ( Platform(Platform) ) import System.Posix.Files- ( getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink- , createSymbolicLink, removeLink )+ ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink+ , removeLink ) import System.Directory ( canonicalizePath ) import System.FilePath- ( (</>), takeDirectory, splitPath, joinPath, isAbsolute )+ ( (</>), splitPath, joinPath, isAbsolute ) import System.IO.Error ( catch, isDoesNotExistError, ioError ) import Control.Exception@@ -178,7 +178,8 @@ -- did not own. Other errors like permission errors -- just propagate as exceptions. symlinkBinary publicBindir privateBindir publicName privateName = do- ok <- targetOkToOverwrite (publicBindir </> publicName) privateBindir+ ok <- targetOkToOverwrite (publicBindir </> publicName)+ (privateBindir </> privateName) case ok of NotOurFile -> return False NotExists -> mkLink >> return True@@ -191,24 +192,22 @@ -- | Check a filepath of a symlink that we would like to create to see if it -- is ok. For it to be ok to overwrite it must either not already exist yet or--- be a symlink to our private bin dir (in which case we can assume ownership).+-- be a symlink to our target (in which case we can assume ownership). -- targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private -- binary that we would like to create- -> FilePath -- ^ The canonical path of the private bin- -- directory. Use 'canonicalizePath'.+ -> FilePath -- ^ The canonical path of the private binary.+ -- Use 'canonicalizePath' to make this. -> IO SymlinkStatus-targetOkToOverwrite symlink privateBinDir = handleNotExist $ do+targetOkToOverwrite symlink target = handleNotExist $ do status <- getSymbolicLinkStatus symlink if not (isSymbolicLink status) then return NotOurFile- else return- . (\ok -> if ok then OkToOverwrite else NotOurFile)- . (== privateBinDir)- . takeDirectory- =<< canonicalizePath- . (symlink </>)- =<< readSymbolicLink symlink+ else do target' <- canonicalizePath symlink+ -- This relies on canonicalizePath handling symlinks+ if target == target'+ then return OkToOverwrite+ else return NotOurFile where handleNotExist action = catch action $ \ioexception ->
Distribution/Client/Setup.hs view
@@ -687,7 +687,9 @@ parsePkgArgs ds (arg:args) = case readPToMaybe parseDependencyOrPackageId arg of Just dep -> parsePkgArgs (dep:ds) args- Nothing -> Left ("Failed to parse package dependency: " ++ show arg)+ Nothing -> Left $+ show arg ++ " is not valid syntax for a package name or"+ ++ " package dependency." readPToMaybe :: Parse.ReadP a a -> String -> Maybe a readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
Distribution/Client/Tar.hs view
@@ -1,67 +1,68 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Tar -- Copyright : (c) 2007 Bjorn Bringert, -- 2008 Andrea Vezzosi,--- 2008 Duncan Coutts--- License : BSD-like+-- 2008-2009 Duncan Coutts+-- License : BSD3 -- -- Maintainer : duncan@haskell.org--- Stability : provisional -- Portability : portable ----- TAR archive reading and writing+-- Reading, writing and manipulating \"@.tar@\" archive files. -- ----------------------------------------------------------------------------- module Distribution.Client.Tar (- -- * High level all in one operations on files+ -- * High level \"all in one\" operations createTarGzFile, extractTarGzFile, - -- * Reading and writing the tar format+ -- * Converting between internal and external representation read, write, - -- * Packing and unpacking files to\/from a tar archive+ -- * Packing and unpacking files to\/from internal representation pack, unpack, - -- * Tar archive 'Entry'- Entry(..), fileName,- ExtendedHeader(..),- FileType(..),- UserId,- GroupId,+ -- * Tar entry and associated types+ Entry(..),+ entryPath,+ EntryContent(..),+ Ownership(..),+ FileSize,+ Permissions, EpochTime, DevMajor, DevMinor,- FileSize,+ TypeCode,+ Format(..), - -- ** Constructing entries- emptyEntry,- simpleFileEntry,- simpleDirectoryEntry,+ -- * Constructing simple entry values+ simpleEntry,+ fileEntry,+ directoryEntry, - -- ** 'TarPath's+ -- * TarPath type TarPath, toTarPath, fromTarPath, - -- * Sequence of 'Entry' records with failures+ -- ** Sequences of tar entries Entries(..), foldEntries, unfoldEntries, mapEntries, - -- * Sanity checking tar contents- checkEntryNames ) where import Data.Char (ord) import Data.Int (Int64)+import Data.Bits (Bits, shiftL) import Data.List (foldl')-import Control.Monad (MonadPlus(mplus)) import Numeric (readOct, showOct)+import Control.Monad (MonadPlus(mplus)) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8@@ -70,15 +71,14 @@ import System.FilePath ( (</>) )-import qualified System.FilePath as FilePath.Native- ( (</>), joinPath, splitDirectories, takeDirectory- , isAbsolute, isValid, makeRelative )-import qualified System.FilePath.Posix as FilePath.Posix- ( joinPath, pathSeparator, splitPath, splitDirectories )+import qualified System.FilePath as FilePath.Native+import qualified System.FilePath.Windows as FilePath.Windows+import qualified System.FilePath.Posix as FilePath.Posix import System.Directory- ( getDirectoryContents, doesDirectoryExist- , getModificationTime, createDirectoryIfMissing, copyFile- , Permissions(..), getPermissions )+ ( getDirectoryContents, doesDirectoryExist, getModificationTime+ , getPermissions, createDirectoryIfMissing, copyFile )+import qualified System.Directory as Permissions+ ( Permissions(executable) ) import System.Posix.Types ( FileMode ) import System.Time@@ -87,11 +87,9 @@ ( IOMode(ReadMode), openBinaryFile, hFileSize ) import System.IO.Unsafe (unsafeInterleaveIO) -import Distribution.Client.Utils- ( writeFileAtomic )- import Prelude hiding (read) + -- -- * High level operations --@@ -101,179 +99,159 @@ -> FilePath -- ^ Directory to archive, relative to base dir -> IO () createTarGzFile tar base dir =- writeFileAtomic tar . GZip.compress . write =<< pack base dir+ BS.writeFile tar . GZip.compress . write =<< pack base [dir] extractTarGzFile :: FilePath -- ^ Destination directory+ -> FilePath -- ^ Expected subdir (to check for tarbombs) -> FilePath -- ^ Tarball- -> IO ()-extractTarGzFile dir tar =- unpack dir . checkEntryNames . read . GZip.decompress =<< BS.readFile tar+ -> IO ()+extractTarGzFile dir expected tar =+ unpack dir . checkTarbomb expected . read . GZip.decompress =<< BS.readFile tar -- -- * Entry type -- -type UserId = Int-type GroupId = Int-type EpochTime = Int -- ^ The number of seconds since the UNIX epoch+type FileSize = Int64+-- | The number of seconds since the UNIX epoch+type EpochTime = Int64 type DevMajor = Int type DevMinor = Int-type FileSize = Int64+type TypeCode = Char+type Permissions = FileMode --- | TAR archive entry+-- | Tar archive entry.+-- data Entry = Entry { - -- | Path of the file or directory. The path separator should be @/@ for- -- portable TAR archives.- filePath :: TarPath,-- -- | UNIX file mode.- fileMode :: FileMode,-- -- | Numeric owner user id. Should be set to @0@ if unknown.- ownerId :: UserId,-- -- | Numeric owner group id. Should be set to @0@ if unknown.- groupId :: GroupId,-- -- | File size in bytes. Should be 0 for entries other than normal files.- fileSize :: FileSize,+ -- | The path of the file or directory within the archive. This is in a+ -- tar-specific form. Use 'entryPath' to get a native 'FilePath'.+ entryTarPath :: !TarPath, - -- | Last modification time.- modTime :: EpochTime,+ -- | The real content of the entry. For 'NormalFile' this includes the+ -- file data. An entry usually contains a 'NormalFile' or a 'Directory'.+ entryContent :: !EntryContent, - -- | Type of this entry.- fileType :: FileType,+ -- | File permissions (Unix style file mode).+ entryPermissions :: !Permissions, - -- | If the entry is a hard link or a symbolic link, this is the path of- -- the link target. For all other entry types this should be @\"\"@.- linkTarget :: FilePath,+ -- | The user and group to which this file belongs.+ entryOwnership :: !Ownership, - -- | The remaining meta-data is in the V7, ustar/posix or gnu formats- -- For V7 there is no extended info at all and for posix/ustar the- -- information is the same though the kind affects the way the information- -- is encoded.- headerExt :: ExtendedHeader,+ -- | The time the file was last modified.+ entryTime :: !EpochTime, - -- | Entry contents. For entries other than normal- -- files, this should be an empty string.- fileContent :: ByteString+ -- | The tar format the archive is using.+ entryFormat :: !Format } -fileName :: Entry -> FilePath-fileName = fromTarPath . filePath+-- | Native 'FilePath' of the file or directory within the archive.+--+entryPath :: Entry -> FilePath+entryPath = fromTarPath . entryTarPath -data ExtendedHeader- = V7- | USTAR {+-- | The content of a tar archive entry, which depends on the type of entry.+--+-- Portable archives should contain only 'NormalFile' and 'Directory'.+--+data EntryContent = NormalFile ByteString !FileSize+ | Directory+ | SymbolicLink !LinkTarget+ | HardLink !LinkTarget+ | CharacterDevice !DevMajor !DevMinor+ | BlockDevice !DevMajor !DevMinor+ | NamedPipe+ | OtherEntryType !TypeCode ByteString !FileSize++data Ownership = Ownership { -- | The owner user name. Should be set to @\"\"@ if unknown. ownerName :: String, -- | The owner group name. Should be set to @\"\"@ if unknown. groupName :: String, - -- | For character and block device entries, this is the- -- major number of the device. For all other entry types, it- -- should be set to @0@.- deviceMajor :: DevMajor,+ -- | Numeric owner user id. Should be set to @0@ if unknown.+ ownerId :: !Int, - -- | For character and block device entries, this is the- -- minor number of the device. For all other entry types, it- -- should be set to @0@.- deviceMinor :: DevMinor- }- | GNU {- -- | The owner user name. Should be set to @\"\"@ if unknown.- ownerName :: String,+ -- | Numeric owner group id. Should be set to @0@ if unknown.+ groupId :: !Int+ } - -- | The owner group name. Should be set to @\"\"@ if unknown.- groupName :: String,+-- | There have been a number of extensions to the tar file format over the+-- years. They all share the basic entry fields and put more meta-data in+-- different extended headers.+--+data Format = - -- | For character and block device entries, this is the- -- major number of the device. For all other entry types, it- -- should be set to @0@.- deviceMajor :: DevMajor,+ -- | This is the classic Unix V7 tar format. It does not support owner and+ -- group names, just numeric Ids. It also does not support device numbers.+ V7Format - -- | For character and block device entries, this is the- -- minor number of the device. For all other entry types, it- -- should be set to @0@.- deviceMinor :: DevMinor- }+ -- | The \"USTAR\" format is an extension of the classic V7 format. It was+ -- later standardised by POSIX. It has some restructions but is the most+ -- portable format.+ --+ | UstarFormat --- | TAR archive entry types.-data FileType = NormalFile- | HardLink- | SymbolicLink- | CharacterDevice- | BlockDevice- | Directory- | FIFO- | ExtendedHeader- | GlobalHeader- | Custom Char -- 'A' .. 'Z'- | Reserved Char -- other / reserved / unknown- deriving (Eq, Show)+ -- | The GNU tar implementation also extends the classic V7 format, though+ -- in a slightly different way from the USTAR format. In general for new+ -- archives the standard USTAR/POSIX should be used.+ --+ | GnuFormat+ deriving Eq -toFileTypeCode :: FileType -> Char-toFileTypeCode NormalFile = '0'-toFileTypeCode HardLink = '1'-toFileTypeCode SymbolicLink = '2'-toFileTypeCode CharacterDevice = '3'-toFileTypeCode BlockDevice = '4'-toFileTypeCode Directory = '5'-toFileTypeCode FIFO = '6'-toFileTypeCode ExtendedHeader = 'x'-toFileTypeCode GlobalHeader = 'g'-toFileTypeCode (Custom c) = c-toFileTypeCode (Reserved c) = c+-- | @rw-r--r--@ for normal files+ordinaryFilePermissions :: Permissions+ordinaryFilePermissions = 0o0644 -fromFileTypeCode :: Char -> FileType-fromFileTypeCode '0' = NormalFile-fromFileTypeCode '\0' = NormalFile-fromFileTypeCode '1' = HardLink-fromFileTypeCode '2' = SymbolicLink-fromFileTypeCode '3' = CharacterDevice-fromFileTypeCode '4' = BlockDevice-fromFileTypeCode '5' = Directory-fromFileTypeCode '6' = FIFO-fromFileTypeCode '7' = NormalFile-fromFileTypeCode 'x' = ExtendedHeader-fromFileTypeCode 'g' = GlobalHeader-fromFileTypeCode c | c >= 'A' && c <= 'Z'- = Custom c-fromFileTypeCode c = Reserved c+-- | @rwxr-xr-x@ for executable files+executableFilePermissions :: Permissions+executableFilePermissions = 0o0755 -emptyEntry :: FileType -> TarPath -> Entry-emptyEntry ftype tarpath = Entry {- filePath = tarpath,- fileMode = case ftype of- Directory -> 0o0755 -- rwxr-xr-x for directories- _ -> 0o0644, -- rw-r--r-- for normal files- ownerId = 0,- groupId = 0,- fileSize = 0,- modTime = 0,- fileType = ftype,- linkTarget = "",- headerExt = USTAR {- ownerName = "",- groupName = "",- deviceMajor = 0,- deviceMinor = 0- },- fileContent = BS.empty- }+-- | @rwxr-xr-x@ for directories+directoryPermissions :: Permissions+directoryPermissions = 0o0755 -simpleFileEntry :: TarPath -> ByteString -> Entry-simpleFileEntry name content = (emptyEntry NormalFile name) {- fileSize = BS.length content,- fileContent = content+-- | An 'Entry' with all default values except for the file name and type. It+-- uses the portable USTAR/POSIX format (see 'UstarHeader').+--+-- You can use this as a basis and override specific fields, eg:+--+-- > (emptyEntry name HardLink) { linkTarget = target }+--+simpleEntry :: TarPath -> EntryContent -> Entry+simpleEntry tarpath content = Entry {+ entryTarPath = tarpath,+ entryContent = content,+ entryPermissions = case content of+ Directory -> directoryPermissions+ _ -> ordinaryFilePermissions,+ entryOwnership = Ownership "" "" 0 0,+ entryTime = 0,+ entryFormat = UstarFormat } -simpleDirectoryEntry :: TarPath -> Entry-simpleDirectoryEntry name = emptyEntry Directory name+-- | A tar 'Entry' for a file.+--+-- Entry fields such as file permissions and ownership have default values.+--+-- You can use this as a basis and override specific fields. For example if you+-- need an executable file you could use:+--+-- > (fileEntry name content) { fileMode = executableFileMode }+--+fileEntry :: TarPath -> ByteString -> Entry+fileEntry name fileContent =+ simpleEntry name (NormalFile fileContent (BS.length fileContent)) +-- | A tar 'Entry' for a directory. --+-- Entry fields such as file permissions and ownership have default values.+--+directoryEntry :: TarPath -> Entry+directoryEntry name = simpleEntry name Directory++-- -- * Tar paths -- @@ -288,7 +266,7 @@ -- no simple calculation to work out if a file name is too long. Instead we -- have to try to find a valid split that makes the name fit in the two areas. ----- The rationale presumably was to make it a bit more compatible with tar+-- The rationale presumably was to make it a bit more compatible with old tar -- programs that only understand the classic format. A classic tar would be -- able to extract the file name and possibly some dir prefix, but not the -- full dir prefix. So the files would end up in the wrong place, but that's@@ -303,6 +281,7 @@ -- data TarPath = TarPath FilePath -- path name, 100 characters max. FilePath -- path prefix, 155 characters max.+ deriving (Eq, Ord) -- | Convert a 'TarPath' to a native 'FilePath'. --@@ -311,31 +290,37 @@ -- -- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is -- not valid on Windows.+-- -- * The tar path may be an absolute path or may contain @\"..\"@ components. -- For security reasons this should not usually be allowed, but it is your--- responsibility to check for these conditions.+-- responsibility to check for these conditions (eg using 'checkSecurity'). -- fromTarPath :: TarPath -> FilePath-fromTarPath (TarPath name prefix) =+fromTarPath (TarPath name prefix) = adjustDirectory $ FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix ++ FilePath.Posix.splitDirectories name+ where+ adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name+ = FilePath.Native.addTrailingPathSeparator+ | otherwise = id --- | Convert a native 'FilePath' to a 'TarPath'. The 'FileType' is needed--- because for directories a 'TarPath' uses a trailing @\/@.+-- | Convert a native 'FilePath' to a 'TarPath'. -- -- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a -- description of the problem with splitting long 'FilePath's. ---toTarPath :: FileType -> FilePath -> Either String TarPath-toTarPath ftype = splitLongPath- . addTrailingSep ftype+toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for+ -- directories a 'TarPath' must always use a trailing @\/@.+ -> FilePath -> Either String TarPath+toTarPath isDir = splitLongPath+ . addTrailingSep . FilePath.Posix.joinPath . FilePath.Native.splitDirectories where- addTrailingSep Directory path = path ++ [FilePath.Posix.pathSeparator]- addTrailingSep _ path = path+ addTrailingSep | isDir = FilePath.Posix.addTrailingPathSeparator+ | otherwise = id --- | Takes a sanitized path, split on directory separators and tries to pack it+-- | Take a sanitized path, split on directory separators and try to pack it -- into the 155 + 100 tar file name format. -- -- The stragey is this: take the name-directory components in reverse order@@ -371,7 +356,23 @@ where n' = n + length c packName' _ _ ok cs = (FilePath.Posix.joinPath ok, cs) +-- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and+-- 'HardLink' entry types. --+newtype LinkTarget = LinkTarget FilePath+ deriving (Eq, Ord)++-- | Convert a tar 'LinkTarget' to a native 'FilePath'.+--+fromLinkTarget :: LinkTarget -> FilePath+fromLinkTarget (LinkTarget path) = adjustDirectory $+ FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path+ where+ adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path+ = FilePath.Native.addTrailingPathSeparator+ | otherwise = id++-- -- * Entries type -- @@ -403,26 +404,68 @@ -- * Checking -- -checkEntryNames :: Entries -> Entries-checkEntryNames =- mapEntries (\entry -> maybe (Right entry) Left (checkEntryName entry))+-- | This function checks a sequence of tar entries for file name security+-- problems. It checks that:+--+-- * file paths are not absolute+--+-- * file paths do not contain any path components that are \"@..@\"+--+-- * file names are valid+--+-- These checks are from the perspective of the current OS. That means we check+-- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive+-- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the+-- link target. A failure in any entry terminates the sequence of entries with+-- an error.+--+checkSecurity :: Entries -> Entries+checkSecurity = checkEntries checkEntrySecurity -checkEntryName :: Entry -> Maybe String-checkEntryName entry = case fileType entry of- HardLink -> check (fileName entry) `mplus` check (linkTarget entry)- SymbolicLink -> check (fileName entry) `mplus` check (linkTarget entry)- _ -> check (fileName entry)+checkTarbomb :: FilePath -> Entries -> Entries+checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir) +checkEntrySecurity :: Entry -> Maybe String+checkEntrySecurity entry = case entryContent entry of+ HardLink link -> check (entryPath entry)+ `mplus` check (fromLinkTarget link)+ SymbolicLink link -> check (entryPath entry)+ `mplus` check (fromLinkTarget link)+ _ -> check (entryPath entry)+ where check name- | FilePath.Native.isAbsolute name+ | not (FilePath.Native.isRelative name) = Just $ "Absolute file name in tar archive: " ++ show name+ | not (FilePath.Native.isValid name) = Just $ "Invalid file name in tar archive: " ++ show name+ | any (=="..") (FilePath.Native.splitDirectories name) = Just $ "Invalid file name in tar archive: " ++ show name+ | otherwise = Nothing +checkEntryTarbomb :: FilePath -> Entry -> Maybe String+checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing+ where+ -- Ignore some special entries we will not unpack anyway+ nonFilesystemEntry =+ case entryContent entry of+ OtherEntryType 'g' _ _ -> True --PAX global header+ OtherEntryType 'x' _ _ -> True --PAX individual header+ _ -> False++checkEntryTarbomb expectedTopDir entry =+ case FilePath.Native.splitDirectories (entryPath entry) of+ (topDir:_) | topDir == expectedTopDir -> Nothing+ _ -> Just $ "File in tar archive is not in the expected directory "+ ++ show expectedTopDir++checkEntries :: (Entry -> Maybe String) -> Entries -> Entries+checkEntries checkEntry =+ mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry))+ -- -- * Reading --@@ -432,64 +475,81 @@ getEntry :: ByteString -> Either String (Maybe (Entry, ByteString)) getEntry bs- | BS.length header < 512 = Left "Truncated TAR archive"- | endBlock = Right Nothing --FIXME: force last two blocks to close fds!- | not (correctChecksum header chksum) = Left "TAR checksum error"- | magic /= "ustar\NUL00"- && magic /= "ustar \NUL" = Left $ "TAR entry not ustar format: " ++ show magic- | otherwise = Right (Just (entry, bs'''))- where- (header,bs') = BS.splitAt 512 bs+ | BS.length header < 512 = Left "truncated tar archive" - endBlock = getByte 0 header == '\0'+ -- Tar files end with at least two blocks of all '0'. Checking this serves+ -- two purposes. It checks the format but also forces the tail of the data+ -- which is necessary to close the file if it came from a lazily read file.+ | BS.head bs == 0 = case BS.splitAt 1024 bs of+ (end, trailing)+ | BS.length end /= 1024 -> Left "short tar trailer"+ | not (BS.all (== 0) end) -> Left "bad tar trailer"+ | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk"+ | otherwise -> Right Nothing + | otherwise = partial $ do++ case (chksum_, format_) of+ (Ok chksum, _ ) | correctChecksum header chksum -> return ()+ (Ok _, Ok _) -> fail "tar checksum error"+ _ -> fail "data is not in tar format"++ -- These fields are partial, have to check them+ format <- format_; mode <- mode_;+ uid <- uid_; gid <- gid_;+ size <- size_; mtime <- mtime_;+ devmajor <- devmajor_; devminor <- devminor_;++ let content = BS.take size (BS.drop 512 bs)+ padding = (512 - size) `mod` 512+ bs' = BS.drop (512 + size + padding) bs++ entry = Entry {+ entryTarPath = TarPath name prefix,+ entryContent = case typecode of+ '\0' -> NormalFile content size+ '0' -> NormalFile content size+ '1' -> HardLink (LinkTarget linkname)+ '2' -> SymbolicLink (LinkTarget linkname)+ '3' -> CharacterDevice devmajor devminor+ '4' -> BlockDevice devmajor devminor+ '5' -> Directory+ '6' -> NamedPipe+ '7' -> NormalFile content size+ _ -> OtherEntryType typecode content size,+ entryPermissions = mode,+ entryOwnership = Ownership uname gname uid gid,+ entryTime = mtime,+ entryFormat = format+ }++ return (Just (entry, bs'))++ where+ header = BS.take 512 bs+ name = getString 0 100 header- mode = getOct 100 8 header- uid = getOct 108 8 header- gid = getOct 116 8 header- size = getOct 124 12 header- mtime = getOct 136 12 header- chksum = getOct 148 8 header+ mode_ = getOct 100 8 header+ uid_ = getOct 108 8 header+ gid_ = getOct 116 8 header+ size_ = getOct 124 12 header+ mtime_ = getOct 136 12 header+ chksum_ = getOct 148 8 header typecode = getByte 156 header linkname = getString 157 100 header magic = getChars 257 8 header uname = getString 265 32 header gname = getString 297 32 header- devmajor = getOct 329 8 header- devminor = getOct 337 8 header+ devmajor_ = getOct 329 8 header+ devminor_ = getOct 337 8 header prefix = getString 345 155 header--- trailing = getBytes 500 12 header --TODO: check all \0's-- padding = (512 - size) `mod` 512- (cnt,bs'') = BS.splitAt size bs'- bs''' = BS.drop padding bs''+-- trailing = getBytes 500 12 header - entry = Entry {- filePath = TarPath name prefix,- fileMode = mode,- ownerId = uid,- groupId = gid,- fileSize = size,- modTime = mtime,- fileType = fromFileTypeCode typecode,- linkTarget = linkname,- headerExt = case magic of- "\0\0\0\0\0\0\0\0" -> V7- "ustar\NUL00" -> USTAR {- ownerName = uname,- groupName = gname,- deviceMajor = devmajor,- deviceMinor = devminor- }- "ustar \NUL" -> GNU {- ownerName = uname,- groupName = gname,- deviceMajor = devmajor,- deviceMinor = devminor- }- _ -> V7, --FIXME: fail instead- fileContent = cnt- }+ format_ = case magic of+ "\0\0\0\0\0\0\0\0" -> return V7Format+ "ustar\NUL00" -> return UstarFormat+ "ustar \NUL" -> return GnuFormat+ _ -> fail "tar entry not in a recognised format" correctChecksum :: ByteString -> Int -> Bool correctChecksum header checksum = checksum == checksum'@@ -504,17 +564,32 @@ -- * TAR format primitive input -getOct :: Integral a => Int64 -> Int64 -> ByteString -> a-getOct off len = parseOct- . BS.Char8.unpack- . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')- . getBytes off len+getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a+getOct off len header+ | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes))+ | null octstr = return 0+ | otherwise = case readOct octstr of+ [(x,[])] -> return x+ _ -> fail "tar header is malformed (bad numeric encoding)" where- parseOct "" = 0- parseOct s = case readOct s of- [(x,[])] -> x- _ -> error $ "Number format error: " ++ show s+ bytes = getBytes off len header+ octstr = BS.Char8.unpack+ . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')+ . BS.Char8.dropWhile (== ' ')+ $ bytes + -- Some tar programs switch into a binary format when they try to represent+ -- field values that will not fit in the required width when using the text+ -- octal format. In particular, the UID/GID fields can only hold up to 2^21+ -- while in the binary format can hold up to 2^32. The binary format uses+ -- '\128' as the header which leaves 7 bytes. Only the last 4 are used.+ parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] =+ return $! shiftL (fromIntegral byte3) 24+ + shiftL (fromIntegral byte2) 16+ + shiftL (fromIntegral byte1) 8+ + shiftL (fromIntegral byte0) 0+ parseBinInt _ = fail "tar header uses non-standard number encoding"+ getBytes :: Int64 -> Int64 -> ByteString -> ByteString getBytes off len = BS.take len . BS.drop off @@ -527,23 +602,41 @@ getString :: Int64 -> Int64 -> ByteString -> String getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len +data Partial a = Error String | Ok a++partial :: Partial a -> Either String a+partial (Error msg) = Left msg+partial (Ok x) = Right x++instance Monad Partial where+ return = Ok+ Error m >>= _ = Error m+ Ok x >>= k = k x+ fail = Error+ -- -- * Writing -- --- | Creates an uncompressed archive+-- | Create the external representation of a tar archive by serialising a list+-- of tar entries.+--+-- * The conversion is done lazily.+-- write :: [Entry] -> ByteString write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] putEntry :: Entry -> ByteString-putEntry entry = BS.concat [ header, content, padding ]+putEntry entry = case entryContent entry of+ NormalFile content size -> BS.concat [ header, content, padding size ]+ OtherEntryType _ content size -> BS.concat [ header, content, padding size ]+ _ -> header where- header = putHeader entry- content = fileContent entry- padding = BS.replicate paddingSize 0- paddingSize = fromIntegral $ negate (fileSize entry) `mod` 512+ header = putHeader entry+ padding size = BS.replicate paddingSize 0+ where paddingSize = fromIntegral (negate size `mod` 512) -putHeader :: Entry -> BS.ByteString+putHeader :: Entry -> ByteString putHeader entry = BS.Char8.pack $ take 148 block ++ putOct 7 checksum@@ -553,45 +646,63 @@ checksum = foldl' (\x y -> x + ord y) 0 block putHeaderNoChkSum :: Entry -> String-putHeaderNoChkSum entry = concat+putHeaderNoChkSum Entry {+ entryTarPath = TarPath name prefix,+ entryContent = content,+ entryPermissions = permissions,+ entryOwnership = ownership,+ entryTime = modTime,+ entryFormat = format+ } =++ concat [ putString 100 $ name- , putOct 8 $ fileMode entry- , putOct 8 $ ownerId entry- , putOct 8 $ groupId entry- , putOct 12 $ fileSize entry- , putOct 12 $ modTime entry+ , putOct 8 $ permissions+ , putOct 8 $ ownerId ownership+ , putOct 8 $ groupId ownership+ , putOct 12 $ contentSize+ , putOct 12 $ modTime , fill 8 $ ' ' -- dummy checksum- , putChar8 $ toFileTypeCode (fileType entry)- , putString 100 $ linkTarget entry+ , putChar8 $ typeCode+ , putString 100 $ linkTarget ] ++- case headerExt entry of- V7 ->+ case format of+ V7Format -> fill 255 '\NUL'- ext@USTAR {}-> concat+ UstarFormat -> concat [ putString 8 $ "ustar\NUL00"- , putString 32 $ ownerName ext- , putString 32 $ groupName ext- , putOct 8 $ deviceMajor ext- , putOct 8 $ deviceMinor ext+ , putString 32 $ ownerName ownership+ , putString 32 $ groupName ownership+ , putOct 8 $ deviceMajor+ , putOct 8 $ deviceMinor , putString 155 $ prefix , fill 12 $ '\NUL' ]- ext@GNU {} -> concat+ GnuFormat -> concat [ putString 8 $ "ustar \NUL"- , putString 32 $ ownerName ext- , putString 32 $ groupName ext- , putGnuDev 8 $ deviceMajor ext- , putGnuDev 8 $ deviceMinor ext+ , putString 32 $ ownerName ownership+ , putString 32 $ groupName ownership+ , putGnuDev 8 $ deviceMajor+ , putGnuDev 8 $ deviceMinor , putString 155 $ prefix , fill 12 $ '\NUL' ] where- TarPath name prefix = filePath entry- putGnuDev w n = case fileType entry of- CharacterDevice -> putOct w n- BlockDevice -> putOct w n- _ -> replicate w '\NUL'+ (typeCode, contentSize, linkTarget,+ deviceMajor, deviceMinor) = case content of+ NormalFile _ size -> ('0' , size, [], 0, 0)+ Directory -> ('5' , 0, [], 0, 0)+ SymbolicLink (LinkTarget link) -> ('2' , 0, link, 0, 0)+ HardLink (LinkTarget link) -> ('1' , 0, link, 0, 0)+ CharacterDevice major minor -> ('3' , 0, [], major, minor)+ BlockDevice major minor -> ('4' , 0, [], major, minor)+ NamedPipe -> ('6' , 0, [], 0, 0)+ OtherEntryType code _ size -> (code, size, [], 0, 0) + putGnuDev w n = case content of+ CharacterDevice _ _ -> putOct w n+ BlockDevice _ _ -> putOct w n+ _ -> replicate w '\NUL' -- * TAR format primitive output @@ -600,6 +711,7 @@ putString :: FieldWidth -> String -> String putString n s = take n s ++ fill (n - length s) '\NUL' +--TODO: check integer widths, eg for large file sizes putOct :: Integral a => FieldWidth -> a -> String putOct n x = let octStr = take (n-1) $ showOct x ""@@ -618,112 +730,141 @@ -- unpack :: FilePath -> Entries -> IO ()-unpack baseDir entries = extractLinks =<< extractFiles [] entries+unpack baseDir entries = unpackEntries [] (checkSecurity entries)+ >>= emulateLinks+ where- extractFiles _ (Fail err) = Prelude.fail err- extractFiles links Done = return links- extractFiles links (Next entry entries') = case fileType entry of- NormalFile -> extractFile entry >> extractFiles links entries'- HardLink -> extractFiles (saveLink entry links) entries'- SymbolicLink -> extractFiles (saveLink entry links) entries'- Directory -> extractDir entry >> extractFiles links entries'- _ -> extractFiles links entries' -- FIXME: warning?+ -- We're relying here on 'checkSecurity' to make sure we're not scribbling+ -- files all over the place. - extractFile entry = do- createDirectoryIfMissing False fileDir- BS.writeFile fullPath (fileContent entry)+ unpackEntries _ (Fail err) = fail err+ unpackEntries links Done = return links+ unpackEntries links (Next entry es) = case entryContent entry of+ NormalFile file _ -> extractFile path file+ >> unpackEntries links es+ Directory -> extractDir path+ >> unpackEntries links es+ HardLink link -> (unpackEntries $! saveLink path link links) es+ SymbolicLink link -> (unpackEntries $! saveLink path link links) es+ _ -> unpackEntries links es --ignore other file types where- fileDir = baseDir </> FilePath.Native.takeDirectory (fileName entry)- fullPath = baseDir </> fileName entry-- extractDir entry =- createDirectoryIfMissing False (baseDir </> fileName entry)+ path = entryPath entry - saveLink entry links = seq (length name)- $ seq (length name)- $ link:links+ extractFile path content = do+ -- Note that tar archives do not make sure each directory is created+ -- before files they contain, indeed we may have to create several+ -- levels of directory.+ createDirectoryIfMissing True absDir+ BS.writeFile absPath content where- name = fileName entry- target = linkTarget entry- link = (name, target)+ absDir = baseDir </> FilePath.Native.takeDirectory path+ absPath = baseDir </> path - extractLinks = mapM_ $ \(name, target) ->- let path = baseDir </> name- in copyFile (FilePath.Native.takeDirectory path </> target) path+ extractDir path = createDirectoryIfMissing True (baseDir </> path) + saveLink path link links = seq (length path)+ $ seq (length link')+ $ (path, link'):links+ where link' = fromLinkTarget link++ emulateLinks = mapM_ $ \(relPath, relLinkTarget) ->+ let absPath = baseDir </> relPath+ absTarget = FilePath.Native.takeDirectory absPath </> relLinkTarget+ in copyFile absTarget absPath+ -- -- * Packing -- --- | Creates a tar archive from a directory of files, the paths in the archive--- will be relative to the given base directory.----pack :: FilePath -- ^ Base directory- -> FilePath -- ^ Directory or file to package, relative to the base dir+pack :: FilePath -- ^ Base directory+ -> [FilePath] -- ^ Files and directories to pack, relative to the base dir -> IO [Entry]-pack baseDir sourceDir =- mapM (unsafeInterleaveIO . uncurry (createFileEntry baseDir))- =<< recurseDirectories [baseDir </> sourceDir]+pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir -recurseDirectories :: [FilePath] -> IO [(FileType, FilePath)]-recurseDirectories [] = return []-recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do- (files, dirs') <- collect [] [] =<< getDirectoryContents dir+preparePaths :: FilePath -> [FilePath] -> IO [FilePath]+preparePaths baseDir paths =+ fmap concat $ interleave+ [ do isDir <- doesDirectoryExist (baseDir </> path)+ if isDir+ then do entries <- getDirectoryContentsRecursive (baseDir </> path)+ return (FilePath.Native.addTrailingPathSeparator path+ : map (path </>) entries)+ else return [path]+ | path <- paths ] - files' <- recurseDirectories (dirs' ++ dirs)- return ((Directory, dir) : map ((,) NormalFile) files ++ files')+packPaths :: FilePath -> [FilePath] -> IO [Entry]+packPaths baseDir paths =+ interleave+ [ do tarpath <- either fail return (toTarPath isDir relpath)+ if isDir then packDirectoryEntry filepath tarpath+ else packFileEntry filepath tarpath+ | relpath <- paths+ , let isDir = FilePath.Native.hasTrailingPathSeparator filepath+ filepath = baseDir </> relpath ] +interleave :: [IO a] -> IO [a]+interleave = unsafeInterleaveIO . go where+ go [] = return []+ go (x:xs) = do+ x' <- x+ xs' <- interleave xs+ return (x':xs')++packFileEntry :: FilePath -- ^ Full path to find the file on the local disk+ -> TarPath -- ^ Path to use for the tar Entry in the archive+ -> IO Entry+packFileEntry filepath tarpath = do+ mtime <- getModTime filepath+ perms <- getPermissions filepath+ file <- openBinaryFile filepath ReadMode+ size <- hFileSize file+ content <- BS.hGetContents file+ return (simpleEntry tarpath (NormalFile content (fromIntegral size))) {+ entryPermissions = if Permissions.executable perms+ then executableFilePermissions+ else ordinaryFilePermissions,+ entryTime = mtime+ }++packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk+ -> TarPath -- ^ Path to use for the tar Entry in the archive+ -> IO Entry+packDirectoryEntry filepath tarpath = do+ mtime <- getModTime filepath+ return (directoryEntry tarpath) {+ entryTime = mtime+ }++getDirectoryContentsRecursive :: FilePath -> IO [FilePath]+getDirectoryContentsRecursive dir0 =+ fmap tail (recurseDirectories dir0 [""])++recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]+recurseDirectories _ [] = return []+recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do+ (files, dirs') <- collect [] [] =<< getDirectoryContents (base </> dir)++ files' <- recurseDirectories base (dirs' ++ dirs)+ return (dir : files ++ files')++ where collect files dirs' [] = return (reverse files, reverse dirs') collect files dirs' (entry:entries) | ignore entry = collect files dirs' entries collect files dirs' (entry:entries) = do- let dirEntry = dir </> entry- isDirectory <- doesDirectoryExist dirEntry+ let dirEntry = dir </> entry+ dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry+ isDirectory <- doesDirectoryExist (base </> dirEntry) if isDirectory- then collect files (dirEntry:dirs') entries+ then collect files (dirEntry':dirs') entries else collect (dirEntry:files) dirs' entries ignore ['.'] = True ignore ['.', '.'] = True ignore _ = False -createFileEntry :: FilePath -- ^ path to find the file- -> FileType- -> FilePath -- ^ path to use for the tar Entry- -> IO Entry-createFileEntry baseDir ftype absPath = do- let relPath = FilePath.Native.makeRelative baseDir absPath- tarpath <- either Prelude.fail return (toTarPath ftype relPath)- mtime <- getModTime absPath-- case ftype of- NormalFile -> do- file <- openBinaryFile absPath ReadMode- mode <- getFileMode absPath- size <- hFileSize file- content <- BS.hGetContents file- return (emptyEntry NormalFile tarpath) {- fileMode = mode,- modTime = mtime,- fileSize = fromIntegral size,- fileContent = content- }- _ ->- return (emptyEntry Directory tarpath) {- modTime = mtime- }---- | We can't be precise because of portability, so we default to rw-r--r-- for--- normal filesand rwxr-xr-x for executables.-getFileMode :: FilePath -> IO FileMode-getFileMode path = do- perms <- getPermissions path- if executable perms- then return 0o0755- else return 0o0644- getModTime :: FilePath -> IO EpochTime-getModTime path =- do (TOD s _) <- getModificationTime path- return (fromIntegral s)+getModTime path = do+ (TOD s _) <- getModificationTime path+ return $! fromIntegral s
Distribution/Client/Unpack.hs view
@@ -31,7 +31,7 @@ AvailablePackage(AvailablePackage), AvailablePackageDb(AvailablePackageDb)) import Distribution.Client.Fetch(fetchPackage)-import Distribution.Client.Tar(extractTarGzFile)+import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils (getAvailablePackages, disambiguateDependencies) @@ -68,10 +68,10 @@ Right (AvailablePackage pkgid _ (RepoTarballPackage repo)) -> do pkgPath <- fetchPackage verbosity repo pkgid let pkgdir = display pkgid- notice verbosity $ "Unpacking " ++ display pkgid ++ "..."+ notice verbosity $ "Unpacking " ++ pkgdir ++ "..." info verbosity $ "Extracting " ++ pkgPath ++ " to " ++ prefix </> pkgdir ++ "..."- extractTarGzFile prefix pkgPath+ Tar.extractTarGzFile prefix pkgdir pkgPath Right (AvailablePackage _ _ LocalUnpackedPackage) -> error "Distribution.Client.Unpack.unpack: the impossible happened."
Distribution/Client/Update.hs view
@@ -27,16 +27,20 @@ ( version ) import Distribution.Package- ( PackageName(..), packageId, packageVersion )+ ( PackageName(..), packageVersion )+import Distribution.Version+ ( VersionRange(AnyVersion), withinRange ) import Distribution.Simple.Utils- ( warn, notice, comparing )+ ( warn, notice ) import Distribution.Verbosity ( Verbosity ) import qualified Data.ByteString.Lazy as BS import qualified Codec.Compression.GZip as GZip (decompress)+import qualified Data.Map as Map import System.FilePath (dropExtension)-import Data.List (maximumBy)+import Data.Maybe (fromMaybe)+import Control.Monad (when) -- | 'update' downloads the package list from all known servers update :: Verbosity -> [Repo] -> IO ()@@ -59,15 +63,20 @@ checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () checkForSelfUpgrade verbosity repos = do- AvailablePackageDb available _ <- getAvailablePackages verbosity repos+ AvailablePackageDb available prefs <- getAvailablePackages verbosity repos let self = PackageName "cabal-install"- pkgs = PackageIndex.lookupPackageName available self- latestVersion = packageVersion (maximumBy (comparing packageId) pkgs)- currentVersion = Paths_cabal_install.version+ preferredVersionRange = fromMaybe AnyVersion (Map.lookup self prefs)+ currentVersion = Paths_cabal_install.version+ laterPreferredVersions =+ [ packageVersion pkg+ | pkg <- PackageIndex.lookupPackageName available self+ , let version = packageVersion pkg+ , version > currentVersion+ , version `withinRange` preferredVersionRange ] - if not (null pkgs) && latestVersion > currentVersion- then notice verbosity $- "Note: there is a new version of cabal-install available.\n"- ++ "To upgrade, run: cabal install cabal-install"- else return ()+ when (not (null laterPreferredVersions)) $+ notice verbosity $+ "Note: there is a new version of cabal-install available.\n"+ ++ "To upgrade, run: cabal install cabal-install"+
Distribution/Client/Upload.hs view
@@ -120,13 +120,15 @@ request req debug verbosity $ show resp case rspCode resp of- (2,0,0) -> do notice verbosity "OK"- (x,y,z) -> do notice verbosity $ "ERROR: " ++ path ++ ": " + (2,0,0) -> do notice verbosity "Ok"+ (x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": " ++ map intToDigit [x,y,z] ++ " " ++ rspReason resp case findHeader HdrContentType resp of- Just "text/plain" -> notice verbosity $ rspBody resp- _ -> debug verbosity $ rspBody resp+ Just contenttype+ | takeWhile (/= ';') contenttype == "text/plain"+ -> notice verbosity $ rspBody resp+ _ -> debug verbosity $ rspBody resp mkRequest :: URI -> FilePath -> IO (Request String) mkRequest uri path =
+ Distribution/Compat/Version.hs view
@@ -0,0 +1,385 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.Compat.Version+-- Copyright : Isaac Jones, Simon Marlow 2003-2004+-- Duncan Coutts 2008+--+-- Maintainer : cabal-devel@haskell.org+-- Portability : portable+--++{- Copyright (c) 2003-2004, Isaac Jones+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.Compat.Version (++ simplifyVersionRange,++ -- * Version intervals view+ asVersionIntervals,+ VersionInterval,+ LowerBound(..),+ UpperBound(..),+ Bound(..),++ -- ** 'VersionIntervals' abstract type+ -- | The 'VersionIntervals' type and the accompanying functions are exposed+ -- primarily for completeness and testing purposes. In practice + -- 'asVersionIntervals' is the main function to use to+ -- view a 'VersionRange' as a bunch of 'VersionInterval's.+ --+ VersionIntervals,+ toVersionIntervals,+ fromVersionIntervals,+ withinIntervals,+ versionIntervals,+ mkVersionIntervals,+ unionVersionIntervals,+ intersectVersionIntervals,++ ) where++import Distribution.Version++import Control.Exception (assert)++-- | The empty version range, that is a version range containing no versions.+--+-- This can be constructed using any unsatisfiable version range expression,+-- for example @> 1 && < 1@.+--+-- > withinRange v anyVersion = False+--+noVersion :: VersionRange+noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v)+ where v = Version [1] []++-- | Fold over the syntactic structure of a 'VersionRange'.+--+-- This provides a syntacic view of the expression defining the version range.+-- For a semantic view use 'asVersionIntervals'.+--+foldVersionRange :: a -> (Version -> a) -> (Version -> a) -> (Version -> a)+ -> (Version -> Version -> a)+ -> (a -> a -> a) -> (a -> a -> a)+ -> VersionRange -> a+foldVersionRange anyv this later earlier _wildcard union intersect = fold+ where+ fold AnyVersion = anyv+ fold (ThisVersion v) = this v+ fold (LaterVersion v) = later v+ fold (EarlierVersion v) = earlier v+ fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2)+ fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2)++-- | View a 'VersionRange' as a union of intervals.+--+-- This provides a canonical view of the semantics of a 'VersionRange' as+-- opposed to the syntax of the expression used to define it. For the syntactic+-- view use 'foldVersionRange'.+--+-- Each interval is non-empty. The sequence is in increasing order and no+-- intervals overlap or touch. Therefore only the first and last can be+-- unbounded. The sequence can be empty if the range is empty+-- (e.g. a range expression like @< 1 && > 2@).+--+-- Other checks are trivial to implement using this view. For example:+--+-- > isNoVersion vr | [] <- asVersionIntervals vr = True+-- > | otherwise = False+--+-- > isSpecificVersion vr+-- > | [(LowerBound v InclusiveBound+-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr+-- > , v == v' = Just v+-- > | otherwise = Nothing+--+asVersionIntervals :: VersionRange -> [VersionInterval]+asVersionIntervals = versionIntervals . toVersionIntervals++-- | Simplify a 'VersionRange' expression into a canonical form.+--+-- It just uses @fromVersionIntervals . toVersionIntervals@+--+-- It satisfies the following properties:+--+-- > withinRange v (simplifyVersionRange r) = withinRange v r+--+-- > withinRange v r = withinRange v r'+-- > ==> simplifyVersionRange r = simplifyVersionRange r'+--+simplifyVersionRange :: VersionRange -> VersionRange+simplifyVersionRange = fromVersionIntervals . toVersionIntervals++------------------+-- Intervals view+--++-- | A complementary representation of a 'VersionRange'. Instead of a boolean+-- version predicate it uses an increasing sequence of non-overlapping,+-- non-empty intervals.+--+-- The key point is that this representation gives a canonical representation+-- for the semantics of 'VersionRange's. This makes it easier to check things+-- like whether a version range is empty, covers all versions, or requires a+-- certain minimum or maximum version. It also makes it easy to check equality+-- or containment. It also makes it easier to identify \'simple\' version+-- predicates for translation into foreign packaging systems that do not+-- support complex version range expressions.+--+newtype VersionIntervals = VersionIntervals [VersionInterval]+ deriving (Eq, Show)++-- | Inspect the list of version intervals.+--+versionIntervals :: VersionIntervals -> [VersionInterval]+versionIntervals (VersionIntervals is) = is++type VersionInterval = (LowerBound, UpperBound)+data LowerBound = LowerBound Version !Bound deriving (Eq, Show)+data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show)+data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show)++minLowerBound :: LowerBound+minLowerBound = LowerBound (Version [0] []) InclusiveBound++isVersion0 :: Version -> Bool+isVersion0 (Version [0] _) = True+isVersion0 _ = False++instance Ord LowerBound where+ LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of+ LT -> True+ EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound)+ GT -> False++instance Ord UpperBound where+ _ <= NoUpperBound = True+ NoUpperBound <= UpperBound _ _ = False+ UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of+ LT -> True+ EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound)+ GT -> False++invariant :: VersionIntervals -> Bool+invariant (VersionIntervals intervals) = all validInterval intervals+ && all doesNotTouch' adjacentIntervals+ where+ doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool+ doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l'++ adjacentIntervals :: [(VersionInterval, VersionInterval)]+ adjacentIntervals+ | null intervals = []+ | otherwise = zip intervals (tail intervals)++checkInvariant :: VersionIntervals -> VersionIntervals+checkInvariant is = assert (invariant is) is++-- | Directly construct a 'VersionIntervals' from a list of intervals.+--+-- Each interval must be non-empty. The sequence must be in increasing order+-- and no invervals may overlap or touch. If any of these conditions are not+-- satisfied the function returns @Nothing@.+--+mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals+mkVersionIntervals intervals+ | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals)+ | otherwise = Nothing++validVersion :: Version -> Bool+validVersion (Version [] _) = False+validVersion (Version vs _) = all (>=0) vs++validInterval :: (LowerBound, UpperBound) -> Bool+validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i+ where+ validLower (LowerBound v _) = validVersion v+ validUpper NoUpperBound = True+ validUpper (UpperBound v _) = validVersion v++-- Check an interval is non-empty+--+nonEmpty :: VersionInterval -> Bool+nonEmpty (_, NoUpperBound ) = True+nonEmpty (LowerBound l lb, UpperBound u ub) =+ (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound)++-- Check an upper bound does not intersect, or even touch a lower bound:+--+-- ---| or ---) but not ---] or ---) or ---]+-- |--- (--- (--- [--- [---+--+doesNotTouch :: UpperBound -> LowerBound -> Bool+doesNotTouch NoUpperBound _ = False+doesNotTouch (UpperBound u ub) (LowerBound l lb) =+ u < l+ || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)++-- | Check an upper bound does not intersect a lower bound:+--+-- ---| or ---) or ---] or ---) but not ---]+-- |--- (--- (--- [--- [---+--+doesNotIntersect :: UpperBound -> LowerBound -> Bool+doesNotIntersect NoUpperBound _ = False+doesNotIntersect (UpperBound u ub) (LowerBound l lb) =+ u < l+ || (u == l && not (ub == InclusiveBound && lb == InclusiveBound))++-- | Test if a version falls within the version intervals.+--+-- It exists mostly for completeness and testing. It satisfies the following+-- properties:+--+-- > withinIntervals v (toVersionIntervals vr) = withinRange v vr+-- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs)+--+withinIntervals :: Version -> VersionIntervals -> Bool+withinIntervals v (VersionIntervals intervals) = any withinInterval intervals+ where+ withinInterval (lowerBound, upperBound) = withinLower lowerBound+ && withinUpper upperBound+ withinLower (LowerBound v' ExclusiveBound) = v' < v+ withinLower (LowerBound v' InclusiveBound) = v' <= v++ withinUpper NoUpperBound = True+ withinUpper (UpperBound v' ExclusiveBound) = v' > v+ withinUpper (UpperBound v' InclusiveBound) = v' >= v++-- | Convert a 'VersionRange' to a sequence of version intervals.+--+toVersionIntervals :: VersionRange -> VersionIntervals+toVersionIntervals = foldVersionRange+ ( chkIvl (minLowerBound, NoUpperBound))+ (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound))+ (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound))+ (\v -> if isVersion0 v then VersionIntervals [] else+ chkIvl (minLowerBound, UpperBound v ExclusiveBound))+ (\v v' -> chkIvl (LowerBound v InclusiveBound, UpperBound v' ExclusiveBound))+ unionVersionIntervals+ intersectVersionIntervals+ where+ chkIvl interval = checkInvariant (VersionIntervals [interval])++-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression+-- representing the version intervals.+--+fromVersionIntervals :: VersionIntervals -> VersionRange+fromVersionIntervals (VersionIntervals []) = noVersion+fromVersionIntervals (VersionIntervals intervals) =+ foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ]++ where+ interval (LowerBound v InclusiveBound)+ (UpperBound v' InclusiveBound) | v == v'+ = ThisVersion v+ interval l u = lowerBound l `intersectVersionRanges'` upperBound u++ lowerBound (LowerBound v InclusiveBound)+ | isVersion0 v = AnyVersion+ | otherwise = orLaterVersion v+ lowerBound (LowerBound v ExclusiveBound) = LaterVersion v++ upperBound NoUpperBound = AnyVersion+ upperBound (UpperBound v InclusiveBound) = orEarlierVersion v+ upperBound (UpperBound v ExclusiveBound) = EarlierVersion v++ intersectVersionRanges' vr AnyVersion = vr+ intersectVersionRanges' AnyVersion vr = vr+ intersectVersionRanges' vr vr' = IntersectVersionRanges vr vr'++unionVersionIntervals :: VersionIntervals -> VersionIntervals+ -> VersionIntervals+unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =+ checkInvariant (VersionIntervals (union is0 is'0))+ where+ union is [] = is+ union [] is' = is'+ union (i:is) (i':is') = case unionInterval i i' of+ Left Nothing -> i : union is (i' :is')+ Left (Just i'') -> union is (i'':is')+ Right Nothing -> i' : union (i :is) is'+ Right (Just i'') -> union (i'':is) is'++unionInterval :: VersionInterval -> VersionInterval+ -> Either (Maybe VersionInterval) (Maybe VersionInterval)+unionInterval (lower , upper ) (lower', upper')++ -- Non-intersecting intervals with the left interval ending first+ | upper `doesNotTouch` lower' = Left Nothing++ -- Non-intersecting intervals with the right interval first+ | upper' `doesNotTouch` lower = Right Nothing++ -- Complete or partial overlap, with the left interval ending first+ | upper <= upper' = lowerBound `seq`+ Left (Just (lowerBound, upper'))++ -- Complete or partial overlap, with the left interval ending first+ | otherwise = lowerBound `seq`+ Right (Just (lowerBound, upper))+ where+ lowerBound = min lower lower'++intersectVersionIntervals :: VersionIntervals -> VersionIntervals+ -> VersionIntervals+intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =+ checkInvariant (VersionIntervals (intersect is0 is'0))+ where+ intersect _ [] = []+ intersect [] _ = []+ intersect (i:is) (i':is') = case intersectInterval i i' of+ Left Nothing -> intersect is (i':is')+ Left (Just i'') -> i'' : intersect is (i':is')+ Right Nothing -> intersect (i:is) is'+ Right (Just i'') -> i'' : intersect (i:is) is'++intersectInterval :: VersionInterval -> VersionInterval+ -> Either (Maybe VersionInterval) (Maybe VersionInterval)+intersectInterval (lower , upper ) (lower', upper')++ -- Non-intersecting intervals with the left interval ending first+ | upper `doesNotIntersect` lower' = Left Nothing++ -- Non-intersecting intervals with the right interval first+ | upper' `doesNotIntersect` lower = Right Nothing++ -- Complete or partial overlap, with the left interval ending first+ | upper <= upper' = lowerBound `seq`+ Left (Just (lowerBound, upper))++ -- Complete or partial overlap, with the right interval ending first+ | otherwise = lowerBound `seq`+ Right (Just (lowerBound, upper'))+ where+ lowerBound = max lower lower'+
Main.hs view
@@ -58,6 +58,10 @@ import Distribution.Simple.Program (defaultProgramConfiguration) import Distribution.Simple.Command import Distribution.Simple.Configure (configCompilerAux)+import Distribution.Simple.Compiler+ ( Compiler, CompilerFlavor(GHC), compilerFlavor, compilerVersion )+import Distribution.Version+ ( Version(Version) ) import Distribution.Simple.Utils (cabalVersion, die, intercalate) import Distribution.Text ( display )@@ -72,7 +76,7 @@ import Data.List (intersperse) import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..))-import Control.Monad (unless)+import Control.Monad (unless, when) -- | Entry point --@@ -172,6 +176,7 @@ configExFlags' = savedConfigureExFlags config `mappend` configExFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux configFlags'+ compVersionCheck comp configure verbosity (configPackageDB' configFlags') (globalRepos globalFlags') comp conf configFlags' configExFlags' extraArgs@@ -195,6 +200,7 @@ installFlags' = savedInstallFlags config `mappend` installFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux configFlags'+ compVersionCheck comp install verbosity (configPackageDB' configFlags') (globalRepos globalFlags') comp conf configFlags' configExFlags' installFlags'@@ -208,6 +214,7 @@ let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux configFlags+ compVersionCheck comp list verbosity (configPackageDB' configFlags) (globalRepos globalFlags')@@ -224,6 +231,7 @@ let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux configFlags+ compVersionCheck comp info verbosity (configPackageDB' configFlags) (globalRepos globalFlags')@@ -254,6 +262,7 @@ installFlags' = savedInstallFlags config `mappend` installFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux configFlags'+ compVersionCheck comp upgrade verbosity (configPackageDB' configFlags') (globalRepos globalFlags') comp conf configFlags' configExFlags' installFlags'@@ -268,6 +277,7 @@ let configFlags = savedConfigureFlags config globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux configFlags+ compVersionCheck comp fetch verbosity (configPackageDB' configFlags) (globalRepos globalFlags') comp conf@@ -347,3 +357,16 @@ -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n])) _ -> Verbosity.normal win32SelfUpgradeAction _ = return ()++compVersionCheck :: Compiler -> IO ()+compVersionCheck comp =+ when (compilerFlavor comp == GHC+ && compilerVersion comp > Version [6,11] []) $+ die upgradeMessage+ where+ upgradeMessage = "This version of the cabal program is too old to work "+ ++ "with ghc-6.12+. You will need to install the "+ ++ "'cabal-install' package version 0.8 or higher.\nIf you "+ ++ "still have an older ghc installed (eg 6.10.4), run:\n"+ ++ "$ cabal install -w ghc-6.10.4 'cabal-install >= 0.8'"+
README view
@@ -26,7 +26,8 @@ All of these are available from [Hackage](http://hackage.haskell.org). Note that on some Unix systems you may need to install an additional zlib-development package using your system package manager. This is because the+development package using your system package manager, for example on+debian or ubuntu it is in "zlib1g-dev". It is needed is because the Haskell zlib package uses the system zlib C library and header files. In future, cabal-install will be part of the Haskell Platform so will not need@@ -38,8 +39,8 @@ Quickstart on Unix systems -------------------------- -As a convenience for users on Unix systems there is a bootstrap.sh script which-will download and install each of the dependencies in turn.+As a convenience for users on Unix systems there is a `bootstrap.sh` script+which will download and install each of the dependencies in turn. $ ./bootstrap.sh @@ -50,18 +51,37 @@ You then have two choices: * put `$HOME/.cabal/bin` on your `$PATH`- * move the `cabal` program elsewhere and edit the `$HOME/.cabal/config` file- and set the `symlink-bindir` entry to point to an alternative location where- that is on your `$PATH`, eg a `$HOME/bin` directory.+ * move the `cabal` program somewhere that is on your `$PATH` +The next thing to do is to get the latest list of packages with: + $ cabal update++This will also create a default config file (if it does not already echo exist)+at `$HOME/.cabal/config`++By default cabal will install programs to `$HOME/.cabal/bin`. If you do not+want to add this directory to your `$PATH` then you can change the setting in+the config file, for example you could use:++ symlink-bindir: $HOME/bin++ Quickstart on Windows systems ----------------------------- For Windows users we provide a pre-compiled [cabal.exe] program. Just download-it and put it somewhere on your `%PATH%`.+it and put it somewhere on your `%PATH%`, for example+`C:\Program Files\Haskell\bin`. [cabal.exe]: http://haskell.org/cabal/release/cabal-install-latest/cabal.exe++The next thing to do is to get the latest list of packages with++ cabal update++This will also create a default config file (if it does not already echo exist)+at `C:\Documents and Settings\username\Application Data\cabal\config` Using cabal-install
bootstrap.sh view
@@ -18,8 +18,31 @@ CURL=${CURL:-curl} TAR=${TAR:-tar} GUNZIP=${GUNZIP:-gunzip}+SCOPE_OF_INSTALLATION="--user" +for arg in $*+do+ case "${arg}" in+ "--user")+ SCOPE_OF_INSTALLATION=${arg}+ shift;;+ "--global")+ SCOPE_OF_INSTALLATION=${arg}+ PREFIX="/usr/local"+ shift;;+ *)+ echo "Unknown argument or option, quitting: ${arg}"+ echo "usage: bootstrap.sh [OPTION]"+ echo+ echo "options:"+ echo " --user Install for the local user (default)"+ echo " --global Install systemwide"+ exit;;+ esac+done++ # Versions of the packages to install. # The version regex says what existing installed versions are ok. CABAL_VER="1.6.0.2"; CABAL_VER_REGEXP="1\.6\." # == 1.6.*@@ -58,7 +81,13 @@ need_pkg () { PKG=$1 VER_MATCH=$2- ! grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1+ if grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1+ then+ return 1;+ else+ return 0;+ fi+ #Note: we cannot use "! grep" here as Solaris 9 /bin/sh doesn't like it. } info_pkg () {@@ -132,7 +161,7 @@ || die "Compiling the Setup script failed" [ -x Setup ] || die "The Setup script does not exist or cannot be run" - ./Setup configure --user "--prefix=${HOME}/.cabal" \+ ./Setup configure ${SCOPE_OF_INSTALLATION} "--prefix=${PREFIX}" \ --with-compiler=${GHC} --with-hc-pkg=${GHC_PKG} \ ${EXTRA_CONFIGURE_OPTS} ${VERBOSE} \ || die "Configuring the ${PKG} package failed"@@ -163,7 +192,6 @@ # Actually do something! -dep_pkg "parsec" "2\." dep_pkg "network" "[12]\." info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP}@@ -185,13 +213,19 @@ echo "You should either add $CABAL_BIN to your PATH" echo "or copy the cabal program to a directory that is on your PATH." echo+ echo "The first thing to do is to get the latest list of packages with:"+ echo " cabal update"+ echo "This will also create a default config file (if it does not already"+ echo "exist) at $HOME/.cabal/config"+ echo echo "By default cabal will install programs to $HOME/.cabal/bin"- echo "If you do not want to add this directory to your PATH then"- echo "you can change the setting in the config file $HOME/.cabal/config"- echo "For example you could use:"+ echo "If you do not want to add this directory to your PATH then you can"+ echo "change the setting in the config file, for example you could use:" echo "symlink-bindir: $HOME/bin" else echo "Sorry, something went wrong."+ echo "The 'cabal' executable was not successfully installed into"+ echo "$CABAL_BIN/" fi echo
cabal-install.cabal view
@@ -1,5 +1,5 @@ Name: cabal-install-Version: 0.6.2+Version: 0.6.4 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing@@ -19,12 +19,12 @@ 2006 Paolo Martini <paolo@nemail.it> 2007 Bjorn Bringert <bjorn@bringert.net> 2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>- 2008 Duncan Coutts <duncan@haskell.org>+ 2008-2009 Duncan Coutts <duncan@haskell.org> Stability: Experimental Category: Distribution Build-type: Simple Extra-Source-Files: README bash-completion/cabal bootstrap.sh-Cabal-Version: >= 1.4+Cabal-Version: >= 1.6 flag old-base description: Old, monolithic base@@ -71,6 +71,7 @@ Distribution.Client.Utils Distribution.Client.Win32SelfUpgrade Distribution.Compat.TempFile+ Distribution.Compat.Version Paths_cabal_install build-depends: base >= 2 && < 4,@@ -101,5 +102,5 @@ build-depends: Win32 >= 2 && < 3 cpp-options: -DWIN32 else- build-depends: unix >= 2.0 && < 2.4+ build-depends: unix >= 1.0 && < 2.4 extensions: CPP