----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Targets -- Copyright : (c) Duncan Coutts 2011 -- License : BSD-like -- -- Maintainer : duncan@community.haskell.org -- -- Handling for user-specified targets ----------------------------------------------------------------------------- module Distribution.Client.Targets ( -- * User targets UserTarget(..), readUserTargets, -- * Package specifiers PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints, -- * Resolving user targets to package specifiers resolveUserTargets, -- ** Detailed interface UserTargetProblem(..), readUserTarget, reportUserTargetProblems, expandUserTarget, PackageTarget(..), fetchPackageTarget, readPackageTarget, PackageTargetProblem(..), reportPackageTargetProblems, disambiguatePackageTargets, disambiguatePackageName, -- * User constraints UserConstraint(..), readUserConstraint, userToPackageConstraint ) where import Distribution.Package ( Package(..), PackageName(..) , PackageIdentifier(..), packageName, packageVersion , Dependency(Dependency) ) import Distribution.Client.Types ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) ) import Distribution.Client.Dependency.Types ( PackageConstraint(..) ) import qualified Distribution.Client.World as World import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.PackageIndex as PackageIndex import qualified Distribution.Client.Tar as Tar import Distribution.Client.FetchUtils import Distribution.PackageDescription ( GenericPackageDescription, FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Parse ( readPackageDescription, parsePackageDescription, ParseResult(..) ) import Distribution.Version ( Version(Version), thisVersion, anyVersion, isAnyVersion , VersionRange ) import Distribution.Text ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase ) import Data.List ( find, nub ) import Data.Maybe ( listToMaybe ) import Data.Either ( partitionEithers ) import Data.Monoid ( Monoid(..) ) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Distribution.Client.GZipUtils as GZipUtils import Control.Monad (liftM) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ( (<>), (<+>) ) import Data.Char ( isSpace, isAlphaNum ) import System.FilePath ( takeExtension, dropExtension, takeDirectory, splitPath ) import System.Directory ( doesFileExist, doesDirectoryExist ) import Network.URI ( URI(..), URIAuth(..), parseAbsoluteURI ) -- ------------------------------------------------------------ -- * User targets -- ------------------------------------------------------------ -- | Various ways that a user may specify a package or package collection. -- data UserTarget = -- | A partially specified package, identified by name and possibly with -- an exact version or a version constraint. -- -- > cabal install foo -- > cabal install foo-1.0 -- > cabal install 'foo < 2' -- UserTargetNamed Dependency -- | A special virtual package that refers to the collection of packages -- recorded in the world file that the user specifically installed. -- -- > cabal install world -- | UserTargetWorld -- | A specific package that is unpacked in a local directory, often the -- current directory. -- -- > cabal install . -- > cabal install ../lib/other -- -- * Note: in future, if multiple @.cabal@ files are allowed in a single -- directory then this will refer to the collection of packages. -- | UserTargetLocalDir FilePath -- | A specific local unpacked package, identified by its @.cabal@ file. -- -- > cabal install foo.cabal -- > cabal install ../lib/other/bar.cabal -- | UserTargetLocalCabalFile FilePath -- | A specific package that is available as a local tarball file -- -- > cabal install dist/foo-1.0.tar.gz -- > cabal install ../build/baz-1.0.tar.gz -- | UserTargetLocalTarball FilePath -- | A specific package that is available as a remote tarball file -- -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz -- | UserTargetRemoteTarball URI deriving (Show,Eq) -- ------------------------------------------------------------ -- * Package specifier -- ------------------------------------------------------------ -- | A fully or partially resolved reference to a package. -- data PackageSpecifier pkg = -- | A partially specified reference to a package (either source or -- installed). It is specified by package name and optionally some -- additional constraints. Use a dependency resolver to pick a specific -- package satisfying these constraints. -- NamedPackage PackageName [PackageConstraint] -- | A fully specified source package. -- | SpecificSourcePackage pkg deriving Show pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName pkgSpecifierTarget (NamedPackage name _) = name pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg pkgSpecifierConstraints :: Package pkg => PackageSpecifier pkg -> [PackageConstraint] pkgSpecifierConstraints (NamedPackage _ constraints) = constraints pkgSpecifierConstraints (SpecificSourcePackage pkg) = [PackageConstraintVersion (packageName pkg) (thisVersion (packageVersion pkg))] -- ------------------------------------------------------------ -- * Parsing and checking user targets -- ------------------------------------------------------------ readUserTargets :: Verbosity -> [String] -> IO [UserTarget] readUserTargets _verbosity targetStrs = do (problems, targets) <- liftM partitionEithers (mapM readUserTarget targetStrs) reportUserTargetProblems problems return targets data UserTargetProblem = UserTargetUnexpectedFile String | UserTargetNonexistantFile String | UserTargetUnexpectedUriScheme String | UserTargetUnrecognisedUri String | UserTargetUnrecognised String | UserTargetBadWorldPkg deriving Show readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) readUserTarget targetstr = case testNamedTargets targetstr of Just (Dependency (PackageName "world") verrange) | verrange == anyVersion -> return (Right UserTargetWorld) | otherwise -> return (Left UserTargetBadWorldPkg) Just dep -> return (Right (UserTargetNamed dep)) Nothing -> do fileTarget <- testFileTargets targetstr case fileTarget of Just target -> return target Nothing -> case testUriTargets targetstr of Just target -> return target Nothing -> return (Left (UserTargetUnrecognised targetstr)) where testNamedTargets = readPToMaybe parseDependencyOrPackageId testFileTargets filename = do isDir <- doesDirectoryExist filename isFile <- doesFileExist filename parentDirExists <- case takeDirectory filename of [] -> return False dir -> doesDirectoryExist dir let result | isDir = Just (Right (UserTargetLocalDir filename)) | isFile && extensionIsTarGz filename = Just (Right (UserTargetLocalTarball filename)) | isFile && takeExtension filename == ".cabal" = Just (Right (UserTargetLocalCabalFile filename)) | isFile = Just (Left (UserTargetUnexpectedFile filename)) | parentDirExists = Just (Left (UserTargetNonexistantFile filename)) | otherwise = Nothing return result testUriTargets str = case parseAbsoluteURI str of Just uri@URI { uriScheme = scheme, uriAuthority = Just URIAuth { uriRegName = host } } | scheme /= "http:" -> Just (Left (UserTargetUnexpectedUriScheme targetstr)) | null host -> Just (Left (UserTargetUnrecognisedUri targetstr)) | otherwise -> Just (Right (UserTargetRemoteTarball uri)) _ -> Nothing extensionIsTarGz f = takeExtension f == ".gz" && takeExtension (dropExtension f) == ".tar" parseDependencyOrPackageId :: Parse.ReadP r Dependency parseDependencyOrPackageId = parse +++ liftM pkgidToDependency parse where pkgidToDependency :: PackageIdentifier -> Dependency pkgidToDependency p = case packageVersion p of Version [] _ -> Dependency (packageName p) anyVersion version -> Dependency (packageName p) (thisVersion version) readPToMaybe :: Parse.ReadP a a -> String -> Maybe a readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str , all isSpace s ] reportUserTargetProblems :: [UserTargetProblem] -> IO () reportUserTargetProblems problems = do case [ target | UserTargetUnrecognised target <- problems ] of [] -> return () target -> die $ unlines [ "Unrecognised target '" ++ name ++ "'." | name <- target ] ++ "Targets can be:\n" ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n" ++ " - the special 'world' target\n" ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n" ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" case [ () | UserTargetBadWorldPkg <- problems ] of [] -> return () _ -> die "The special 'world' target does not take any version." case [ target | UserTargetNonexistantFile target <- problems ] of [] -> return () target -> die $ unlines [ "The file does not exist '" ++ name ++ "'." | name <- target ] case [ target | UserTargetUnexpectedFile target <- problems ] of [] -> return () target -> die $ unlines [ "Unrecognised file target '" ++ name ++ "'." | name <- target ] ++ "File targets can be either package tarballs 'pkgname.tar.gz' " ++ "or cabal files 'pkgname.cabal'." case [ target | UserTargetUnexpectedUriScheme target <- problems ] of [] -> return () target -> die $ unlines [ "URL target not supported '" ++ name ++ "'." | name <- target ] ++ "Only 'http://' URLs are supported." case [ target | UserTargetUnrecognisedUri target <- problems ] of [] -> return () target -> die $ unlines [ "Unrecognise URL target '" ++ name ++ "'." | name <- target ] -- ------------------------------------------------------------ -- * Resolving user targets to package specifiers -- ------------------------------------------------------------ -- | Given a bunch of user-specified targets, try to resolve what it is they -- refer to. They can either be specific packages (local dirs, tarballs etc) -- or they can be named packages (with or without version info). -- resolveUserTargets :: Package pkg => Verbosity -> FilePath -> PackageIndex pkg -> [UserTarget] -> IO [PackageSpecifier SourcePackage] resolveUserTargets verbosity worldFile available userTargets = do -- given the user targets, get a list of fully or partially resolved -- package references packageTargets <- mapM (readPackageTarget verbosity) =<< mapM (fetchPackageTarget verbosity) . concat =<< mapM (expandUserTarget worldFile) userTargets -- users are allowed to give package names case-insensitively, so we must -- disambiguate named package references let (problems, packageSpecifiers) = disambiguatePackageTargets available availableExtra packageTargets -- use any extra specific available packages to help us disambiguate availableExtra = [ packageName pkg | PackageTargetLocation pkg <- packageTargets ] reportPackageTargetProblems verbosity problems return packageSpecifiers -- ------------------------------------------------------------ -- * Package targets -- ------------------------------------------------------------ -- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'. -- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. -- data PackageTarget pkg = PackageTargetNamed PackageName [PackageConstraint] UserTarget -- | A package identified by name, but case insensitively, so it needs -- to be resolved to the right case-sensitive name. | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget | PackageTargetLocation pkg deriving Show -- ------------------------------------------------------------ -- * Converting user targets to package targets -- ------------------------------------------------------------ -- | Given a user-specified target, expand it to a bunch of package targets -- (each of which refers to only one package). -- expandUserTarget :: FilePath -> UserTarget -> IO [PackageTarget (PackageLocation ())] expandUserTarget worldFile userTarget = case userTarget of UserTargetNamed (Dependency name vrange) -> let constraints = [ PackageConstraintVersion name vrange | not (isAnyVersion vrange) ] in return [PackageTargetNamedFuzzy name constraints userTarget] UserTargetWorld -> do worldPkgs <- World.getContents worldFile --TODO: should we warn if there are no world targets? return [ PackageTargetNamed name constraints userTarget | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs , let constraints = [ PackageConstraintVersion name vrange | not (isAnyVersion vrange) ] ++ [ PackageConstraintFlags name flags | not (null flags) ] ] UserTargetLocalDir dir -> return [ PackageTargetLocation (LocalUnpackedPackage dir) ] UserTargetLocalCabalFile file -> do let dir = takeDirectory file _ <- findPackageDesc dir -- just as a check return [ PackageTargetLocation (LocalUnpackedPackage dir) ] UserTargetLocalTarball tarballFile -> return [ PackageTargetLocation (LocalTarballPackage tarballFile) ] UserTargetRemoteTarball tarballURL -> return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] -- ------------------------------------------------------------ -- * Fetching and reading package targets -- ------------------------------------------------------------ -- | Fetch any remote targets so that they can be read. -- fetchPackageTarget :: Verbosity -> PackageTarget (PackageLocation ()) -> IO (PackageTarget (PackageLocation FilePath)) fetchPackageTarget verbosity target = case target of PackageTargetNamed n cs ut -> return (PackageTargetNamed n cs ut) PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut) PackageTargetLocation location -> do location' <- fetchPackage verbosity (fmap (const Nothing) location) return (PackageTargetLocation location') -- | Given a package target that has been fetched, read the .cabal file. -- -- This only affects targets given by location, named targets are unaffected. -- readPackageTarget :: Verbosity -> PackageTarget (PackageLocation FilePath) -> IO (PackageTarget SourcePackage) readPackageTarget verbosity target = case target of PackageTargetNamed pkgname constraints userTarget -> return (PackageTargetNamed pkgname constraints userTarget) PackageTargetNamedFuzzy pkgname constraints userTarget -> return (PackageTargetNamedFuzzy pkgname constraints userTarget) PackageTargetLocation location -> case location of LocalUnpackedPackage dir -> do pkg <- readPackageDescription verbosity =<< findPackageDesc dir return $ PackageTargetLocation $ SourcePackage { packageInfoId = packageId pkg, packageDescription = pkg, packageSource = fmap Just location, packageDescrOverride = Nothing } LocalTarballPackage tarballFile -> readTarballPackageTarget location tarballFile tarballFile RemoteTarballPackage tarballURL tarballFile -> readTarballPackageTarget location tarballFile (show tarballURL) RepoTarballPackage _repo _pkgid _ -> error "TODO: readPackageTarget RepoTarballPackage" -- For repo tarballs this info should be obtained from the index. where readTarballPackageTarget location tarballFile tarballOriginalLoc = do (filename, content) <- extractTarballPackageCabalFile tarballFile tarballOriginalLoc case parsePackageDescription' content of Nothing -> die $ "Could not parse the cabal file " ++ filename ++ " in " ++ tarballFile Just pkg -> return $ PackageTargetLocation $ SourcePackage { packageInfoId = packageId pkg, packageDescription = pkg, packageSource = fmap Just location, packageDescrOverride = Nothing } extractTarballPackageCabalFile :: FilePath -> String -> IO (FilePath, BS.ByteString) extractTarballPackageCabalFile tarballFile tarballOriginalLoc = either (die . formatErr) return . check . Tar.entriesIndex . Tar.filterEntries isCabalFile . Tar.read . GZipUtils.maybeDecompress =<< BS.readFile tarballFile where formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg check (Left e) = Left e check (Right m) = case Map.elems m of [] -> Left noCabalFile [file] -> case Tar.entryContent file of Tar.NormalFile content _ -> Right (Tar.entryPath file, content) _ -> Left noCabalFile _files -> Left multipleCabalFiles where noCabalFile = "No cabal file found" multipleCabalFiles = "Multiple cabal files found" isCabalFile e = case splitPath (Tar.entryPath e) of [ _dir, file] -> takeExtension file == ".cabal" [".", _dir, file] -> takeExtension file == ".cabal" _ -> False parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription parsePackageDescription' content = case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of ParseOk _ pkg -> Just pkg _ -> Nothing -- ------------------------------------------------------------ -- * Checking package targets -- ------------------------------------------------------------ data PackageTargetProblem = PackageNameUnknown PackageName UserTarget | PackageNameAmbigious PackageName [PackageName] UserTarget deriving Show -- | Users are allowed to give package names case-insensitively, so we must -- disambiguate named package references. -- disambiguatePackageTargets :: Package pkg' => PackageIndex pkg' -> [PackageName] -> [PackageTarget pkg] -> ( [PackageTargetProblem] , [PackageSpecifier pkg] ) disambiguatePackageTargets availablePkgIndex availableExtra targets = partitionEithers (map disambiguatePackageTarget targets) where disambiguatePackageTarget packageTarget = case packageTarget of PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) PackageTargetNamed pkgname constraints userTarget | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) -> Left (PackageNameUnknown pkgname userTarget) | otherwise -> Right (NamedPackage pkgname constraints) PackageTargetNamedFuzzy pkgname constraints userTarget -> case disambiguatePackageName packageNameEnv pkgname of None -> Left (PackageNameUnknown pkgname userTarget) Ambiguous pkgnames -> Left (PackageNameAmbigious pkgname pkgnames userTarget) Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints') where constraints' = map (renamePackageConstraint pkgname') constraints -- use any extra specific available packages to help us disambiguate packageNameEnv :: PackageNameEnv packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex) (extraPackageNameEnv availableExtra) -- | Report problems to the user. That is, if there are any problems -- then raise an exception. reportPackageTargetProblems :: Verbosity -> [PackageTargetProblem] -> IO () reportPackageTargetProblems verbosity problems = do case [ pkg | PackageNameUnknown pkg originalTarget <- problems , not (isUserTagetWorld originalTarget) ] of [] -> return () pkgs -> die $ unlines [ "There is no package named '" ++ display name ++ "'. " | name <- pkgs ] ++ "You may need to run 'cabal update' to get the latest " ++ "list of available packages." case [ (pkg, matches) | PackageNameAmbigious pkg matches _ <- problems ] of [] -> return () ambiguities -> die $ unlines [ "The package name '" ++ display name ++ "' is ambigious. It could be: " ++ intercalate ", " (map display matches) | (name, matches) <- ambiguities ] case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of [] -> return () pkgs -> warn verbosity $ "The following 'world' packages will be ignored because " ++ "they refer to packages that cannot be found: " ++ intercalate ", " (map display pkgs) ++ "\n" ++ "You can suppress this warning by correcting the world file." where isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False -- ------------------------------------------------------------ -- * Disambiguating package names -- ------------------------------------------------------------ data MaybeAmbigious a = None | Unambiguous a | Ambiguous [a] -- | Given a package name and a list of matching names, figure out which one it -- might be referring to. If there is an exact case-sensitive match then that's -- ok. If it matches just one package case-insensitively then that's also ok. -- The only problem is if it matches multiple packages case-insensitively, in -- that case it is ambigious. -- disambiguatePackageName :: PackageNameEnv -> PackageName -> MaybeAmbigious PackageName disambiguatePackageName (PackageNameEnv pkgNameLookup) name = case nub (pkgNameLookup name) of [] -> None [name'] -> Unambiguous name' names -> case find (name==) names of Just name' -> Unambiguous name' Nothing -> Ambiguous names newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName]) instance Monoid PackageNameEnv where mempty = PackageNameEnv (const []) mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) = PackageNameEnv (\name -> lookupA name ++ lookupB name) indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup where pkgNameLookup (PackageName name) = map fst (PackageIndex.searchByName pkgIndex name) extraPackageNameEnv :: [PackageName] -> PackageNameEnv extraPackageNameEnv names = PackageNameEnv pkgNameLookup where pkgNameLookup (PackageName name) = [ PackageName name' | let lname = lowercase name , PackageName name' <- names , lowercase name' == lname ] -- ------------------------------------------------------------ -- * Package constraints -- ------------------------------------------------------------ data UserConstraint = UserConstraintVersion PackageName VersionRange | UserConstraintInstalled PackageName | UserConstraintSource PackageName | UserConstraintFlags PackageName FlagAssignment | UserConstraintStanzas PackageName [OptionalStanza] deriving (Show,Eq) userToPackageConstraint :: UserConstraint -> PackageConstraint -- At the moment, the types happen to be directly equivalent userToPackageConstraint uc = case uc of UserConstraintVersion name ver -> PackageConstraintVersion name ver UserConstraintInstalled name -> PackageConstraintInstalled name UserConstraintSource name -> PackageConstraintSource name UserConstraintFlags name flags -> PackageConstraintFlags name flags UserConstraintStanzas name stanzas -> PackageConstraintStanzas name stanzas renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint renamePackageConstraint name pc = case pc of PackageConstraintVersion _ ver -> PackageConstraintVersion name ver PackageConstraintInstalled _ -> PackageConstraintInstalled name PackageConstraintSource _ -> PackageConstraintSource name PackageConstraintFlags _ flags -> PackageConstraintFlags name flags PackageConstraintStanzas _ stanzas -> PackageConstraintStanzas name stanzas readUserConstraint :: String -> Either String UserConstraint readUserConstraint str = case readPToMaybe parse str of Nothing -> Left msgCannotParse Just c -> Right c where msgCannotParse = "expected a package name followed by a constraint, which is " ++ "either a version range, 'installed', 'source' or flags" --FIXME: use Text instance for FlagName and FlagAssignment instance Text UserConstraint where disp (UserConstraintVersion pkgname verrange) = disp pkgname <+> disp verrange disp (UserConstraintInstalled pkgname) = disp pkgname <+> Disp.text "installed" disp (UserConstraintSource pkgname) = disp pkgname <+> Disp.text "source" disp (UserConstraintFlags pkgname flags) = disp pkgname <+> dispFlagAssignment flags where dispFlagAssignment = Disp.hsep . map dispFlagValue dispFlagValue (f, True) = Disp.char '+' <> dispFlagName f dispFlagValue (f, False) = Disp.char '-' <> dispFlagName f dispFlagName (FlagName f) = Disp.text f disp (UserConstraintStanzas pkgname stanzas) = disp pkgname <+> dispStanzas stanzas where dispStanzas = Disp.hsep . map dispStanza dispStanza TestStanzas = Disp.text "test" dispStanza BenchStanzas = Disp.text "bench" parse = parse >>= parseConstraint where spaces = Parse.satisfy isSpace >> Parse.skipSpaces parseConstraint pkgname = ((parse >>= return . UserConstraintVersion pkgname) +++ (do spaces _ <- Parse.string "installed" return (UserConstraintInstalled pkgname)) +++ (do spaces _ <- Parse.string "source" return (UserConstraintSource pkgname)) +++ (do spaces _ <- Parse.string "test" return (UserConstraintStanzas pkgname [TestStanzas])) +++ (do spaces _ <- Parse.string "bench" return (UserConstraintStanzas pkgname [BenchStanzas]))) <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname)) parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue) parseFlagValue = (do Parse.optional (Parse.char '+') f <- parseFlagName return (f, True)) +++ (do _ <- Parse.char '-' f <- parseFlagName return (f, False)) parseFlagName = liftM FlagName ident ident :: Parse.ReadP r String ident = Parse.munch1 identChar >>= \s -> check s >> return s where identChar c = isAlphaNum c || c == '_' || c == '-' check ('-':_) = Parse.pfail check _ = return ()