diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs --- a/Distribution/Client/Check.hs +++ b/Distribution/Client/Check.hs @@ -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 . ("* "++) diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -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 diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs --- a/Distribution/Client/Dependency/TopDown.hs +++ b/Distribution/Client/Dependency/TopDown.hs @@ -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 diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -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 ] diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -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 diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs --- a/Distribution/Client/InstallSymlink.hs +++ b/Distribution/Client/InstallSymlink.hs @@ -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 -> diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -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 diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs --- a/Distribution/Client/Tar.hs +++ b/Distribution/Client/Tar.hs @@ -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 diff --git a/Distribution/Client/Unpack.hs b/Distribution/Client/Unpack.hs --- a/Distribution/Client/Unpack.hs +++ b/Distribution/Client/Unpack.hs @@ -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." diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs --- a/Distribution/Client/Update.hs +++ b/Distribution/Client/Update.hs @@ -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" + diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -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 = diff --git a/Distribution/Compat/Version.hs b/Distribution/Compat/Version.hs new file mode 100644 --- /dev/null +++ b/Distribution/Compat/Version.hs @@ -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' + diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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'" + diff --git a/README b/README --- a/README +++ b/README @@ -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 diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -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 diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -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 2007 Bjorn Bringert 2007 Isaac Potoczny-Jones - 2008 Duncan Coutts + 2008-2009 Duncan Coutts 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