diff --git a/Action.hs b/Action.hs deleted file mode 100644 --- a/Action.hs +++ /dev/null @@ -1,121 +0,0 @@ -module Action where - -import Config -import Error - -import Control.Monad.State -import Control.Monad.Error -import Network.URI (parseURI) -import System.IO -import System.Environment - -type HPAction = ErrorT HackPortError (StateT HPState IO) - -data HPState = HPState - { config :: Config - , indention :: Int - } - -verbose :: HPAction a -> (String,a->String) -> HPAction a -verbose action (premsg,postmsg) = do - echoIndent - echo premsg - flush - res <- indent action - echoLn (postmsg res) - return res - -sayNormal :: HPAction a -> (String,a->String) -> HPAction a -sayNormal action strs = do - cfg <- getCfg - case verbosity cfg of - Silent -> action - _ -> action `verbose` strs - -sayDebug :: HPAction a -> (String,a->String) -> HPAction a -sayDebug action strs = do - cfg <- getCfg - case verbosity cfg of - Debug -> action `verbose` strs - _ -> action - -info :: String -> HPAction () -info str = do - cfg <- getCfg - case verbosity cfg of - Silent -> return () - _ -> echoLn str - --- | Prints a string iff in debug output mode -whisper :: String -> HPAction () -whisper str = do - cfg <- getCfg - case verbosity cfg of - Debug -> echoLn str - _ -> return () - -getCfg :: HPAction Config -getCfg = gets config - -setOverlayPath :: Maybe String -> HPAction () -setOverlayPath mt = modify $ \hps -> - hps { config = (config hps) { overlayPath = mt } } - -setPortagePath :: Maybe String -> HPAction () -setPortagePath mt = modify $ \hps -> - hps { config = (config hps) { portagePath = mt } } - -lessIndent :: HPAction () -lessIndent = modify $ \s -> s { indention = indention s - 1 } - -moreIndent :: HPAction () -moreIndent = modify $ \s -> s { indention = indention s + 1 } - -echoIndent :: HPAction () -echoIndent = do - ind <- gets indention - echo (replicate ind '\t') - -indent :: HPAction a -> HPAction a -indent action = do - moreIndent - res <- action - lessIndent - return res - -echo :: String -> HPAction () -echo str = liftIO $ hPutStr stderr str - -flush :: HPAction () -flush = liftIO (hFlush stderr) - -echoLn :: String -> HPAction () -echoLn str = echoIndent >> echo str >> liftIO (hPutChar stderr '\n') - -loadConfig :: HPAction OperationMode -loadConfig = do - args <- liftIO getArgs - case parseConfig args of - Left errmsg -> throwError (ArgumentError errmsg) - Right (opts,opmode) -> do - cfg <- foldM optionToConfig defaultConfig opts - modify $ \s -> s { config = cfg } - return opmode - -optionToConfig :: Config -> HackPortOptions -> HPAction Config -optionToConfig cfg opt = case opt of - OverlayPath str -> return cfg { overlayPath = Just str } - PortagePath str -> return cfg { portagePath = Just str } - Server str -> case parseURI str of - Nothing -> throwError (InvalidServer str) - Just uri -> return cfg { server = uri } - TempDir str -> return cfg { tmp = str } - Verbosity str -> case parseVerbosity str of - Nothing -> throwError (UnknownVerbosityLevel str) - Just verb -> return cfg { verbosity=verb } - Help -> return cfg - RefreshCache -> return cfg { refreshCache = True } - -performHPAction :: HPAction a -> IO (Either HackPortError a) -performHPAction action = - evalStateT (runErrorT action) (HPState defaultConfig 0) diff --git a/Bash.hs b/Bash.hs deleted file mode 100644 --- a/Bash.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Bash where - -import Control.Monad.Error -import System.Process -import System.Directory -import System.IO -import System.Exit - -import Action -import Config -import Error - -getSystemPortdir :: HPAction String -getSystemPortdir = do - dir <- runBash "source /etc/make.conf;echo -n $PORTDIR" - case dir of - "" -> return "/usr/portage" - _ -> return dir - -getPortdir :: HPAction String -getPortdir = do - cfg <- getCfg - case portagePath cfg of - Just dir -> return dir - Nothing -> do - sys <- getSystemPortdir - setPortagePath (Just sys) - return sys - -runBash :: - String -> -- ^ The command line - HPAction String -- ^ The command-line's output -runBash command = do - mpath <- liftIO $ findExecutable "bash" - bash <- maybe (throwError BashNotFound) return mpath - (inp,outp,err,pid) <- liftIO $ runInteractiveProcess bash ["-c",command] Nothing Nothing - liftIO $ hClose inp - result <- liftIO $ hGetContents outp - errors <- liftIO $ hGetContents err - length result `seq` liftIO (hClose outp) - length errors `seq` liftIO (hClose err) - exitCode <- liftIO $ waitForProcess pid - case exitCode of - ExitFailure _ -> throwError $ BashError errors - ExitSuccess -> return result diff --git a/BlingBling.hs b/BlingBling.hs --- a/BlingBling.hs +++ b/BlingBling.hs @@ -1,15 +1,52 @@ module BlingBling where +import qualified Progress + import System.IO +import Control.Exception as Exception (bracket) -- what nobody needs but everyone wants... -- FIXME: do something more fun here forMbling :: [a] -> (a -> IO b) -> IO [b] -forMbling lst f = do - origBuffering <- hGetBuffering stdout - hSetBuffering stdout NoBuffering +forMbling lst f = + withBuffering stdout NoBuffering $ do xs <- mapM (\x -> putStr "." >> f x) lst putStrLn "" - hSetBuffering stdout origBuffering return xs + +blingProgress :: Progress.Progress s String a -> IO a +blingProgress progress = do + isTerm <- hIsTerminalDevice stdout + if isTerm + then canIHasTehBling + else boring + + where + boring = Progress.fold (flip const) fail return progress + + canIHasTehBling = + withBuffering stdout NoBuffering $ do + putChar (fst (char 0)) + result <- spin 0 progress + putStr "\b \b" + return result + + spin _ (Progress.Fail e) = fail e + spin _ (Progress.Done r) = return r + spin n (Progress.Step _ p) = do + putStr ['\b', c] + spin n' p + where (c, n') = char n + + char :: Int -> (Char, Int) + char 0 = ('/', 1) + char 1 = ('-', 2) + char 2 = ('\\', 3) + char _ = ('|', 0) + +withBuffering :: Handle -> BufferMode -> IO a -> IO a +withBuffering hnd mode action = + Exception.bracket + (hGetBuffering hnd) (hSetBuffering hnd) + (\_ -> hSetBuffering hnd mode >> action) diff --git a/Cabal2Ebuild.hs b/Cabal2Ebuild.hs --- a/Cabal2Ebuild.hs +++ b/Cabal2Ebuild.hs @@ -23,22 +23,25 @@ -- module Cabal2Ebuild (EBuild(..) + ,Dependency(..) ,cabal2ebuild + ,convertDependencies ,showEBuild) where import qualified Distribution.PackageDescription as Cabal (PackageDescription(..)) -import qualified Distribution.Package as Cabal (PackageIdentifier(..), Dependency(..)) -import qualified Distribution.Version as Cabal (VersionRange(..), versionBranch, Version) +import qualified Distribution.Package as Cabal (PackageIdentifier(..) + , Dependency(..) + , PackageName(..)) +import qualified Distribution.Version as Cabal (VersionRange, foldVersionRange', versionBranch, Version) import qualified Distribution.License as Cabal (License(..)) import qualified Distribution.Text as Cabal (display) ---import qualified Distribution.Compiler as Cabal (CompilerFlavor(..)) import Data.Char (toLower,isUpper) -import Data.List (intercalate, groupBy, partition, nub, sortBy, init, last) -import Data.Ord (comparing) -import Data.Maybe (catMaybes, fromJust) +import Portage.Dependency +import Portage.Version + data EBuild = EBuild { name :: String, version :: String, @@ -49,27 +52,19 @@ slot :: String, keywords :: [String], iuse :: [String], - depend :: [Dependency], + haskell_deps :: [Dependency], + build_tools :: [Dependency], + extra_libs :: [Dependency], + cabal_dep :: Dependency, + ghc_dep :: Dependency, + depend :: [String], + rdepend :: [String], features :: [String], -- comments on various fields for communicating stuff to the user licenseComments :: String, my_pn :: Maybe String --If the package's name contains upper-case } -type Package = String -newtype Version = Version [Int] deriving (Ord, Eq) -type UseFlag = String -data Dependency = AnyVersionOf Package - | ThisVersionOf Version Package -- =package-version - | LaterVersionOf Version Package -- >package-version - | EarlierVersionOf Version Package -- =package-version - | OrEarlierVersionOf Version Package -- <=package-version - | DependEither Dependency Dependency -- depend || depend - | DependIfUse UseFlag Dependency -- use? ( depend ) - | ThisMajorOf Version Package -- =package-version* - deriving Eq - ebuildTemplate :: EBuild ebuildTemplate = EBuild { name = "foobar", @@ -81,14 +76,18 @@ slot = "0", keywords = ["~amd64","~x86"], iuse = [], + haskell_deps = [], + build_tools = [], + extra_libs = [], + cabal_dep = AnyVersionOf "dev-haskell/cabal", + ghc_dep = defaultDepGHC, depend = [], + rdepend = [], features = [], licenseComments = "", my_pn = Nothing } - - cabal2ebuild :: Cabal.PackageDescription -> EBuild cabal2ebuild pkg = ebuildTemplate { name = map toLower cabalPkgName, @@ -99,29 +98,32 @@ src_uri = Cabal.pkgUrl pkg, license = convertLicense (Cabal.license pkg), licenseComments = licenseComment (Cabal.license pkg), - depend = defaultDepGHC - : (simplify_deps $ - convertDependency (Cabal.Dependency "Cabal" - (Cabal.descCabalVersion pkg)) - ++ convertDependencies (Cabal.buildDepends pkg)), + haskell_deps = simplify_deps $ convertDependencies (Cabal.buildDepends pkg), + cabal_dep = head $ convertDependency (Cabal.Dependency (Cabal.PackageName "Cabal") + (Cabal.descCabalVersion pkg)), my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing, features = features ebuildTemplate - ++ (if null (Cabal.executables pkg) then [] else ["bin"]) - ++ maybe [] (const ["lib","profile","haddock"]) (Cabal.library pkg) + ++ (if hasExe then ["bin"] else []) + ++ maybe [] (const (["lib","profile","haddock"] + ++ if cabalPkgName == "hscolour" then [] else ["hscolour"]) + ) (Cabal.library pkg) -- hscolour can't colour its own sources } where - cabalPkgName = Cabal.pkgName (Cabal.package pkg) + cabalPkgName = Cabal.display $ Cabal.pkgName (Cabal.package pkg) + -- hasLib = isJust (Cabal.library pkg) + hasExe = (not . null) (Cabal.executables pkg) defaultDepGHC :: Dependency -defaultDepGHC = OrLaterVersionOf (Version [6,6,1]) "dev-lang/ghc" +defaultDepGHC = OrLaterVersionOf (Version [6,8,1] Nothing [] 0) "dev-lang/ghc" -- map the cabal license type to the gentoo license string format convertLicense :: Cabal.License -> String -convertLicense Cabal.GPL = "GPL-2" -- almost certainly version 2 -convertLicense Cabal.LGPL = "LGPL-2.1" -- probably version 2.1 -convertLicense Cabal.BSD3 = "BSD" -- do we really not -convertLicense Cabal.BSD4 = "BSD" -- distinguish between these? +convertLicense (Cabal.GPL mv) = "GPL-" ++ (maybe "2" Cabal.display mv) -- almost certainly version 2 +convertLicense (Cabal.LGPL mv) = "LGPL-" ++ (maybe "2.1" Cabal.display mv) -- probably version 2.1 +convertLicense Cabal.BSD3 = "BSD" +convertLicense Cabal.BSD4 = "BSD-4" convertLicense Cabal.PublicDomain = "public-domain" convertLicense Cabal.AllRightsReserved = "" +convertLicense Cabal.MIT = "MIT" convertLicense _ = "" licenseComment :: Cabal.License -> String @@ -135,46 +137,48 @@ convertDependencies = concatMap convertDependency convertDependency :: Cabal.Dependency -> [Dependency] -convertDependency (Cabal.Dependency pname _) +convertDependency (Cabal.Dependency pname@(Cabal.PackageName _name) _) | pname `elem` coreLibs = [] -- no explicit dep on core libs convertDependency (Cabal.Dependency pname versionRange) - = case versionRange of - (Cabal.IntersectVersionRanges v1 v2) -> [convert v1, convert v2] - v -> [convert v] - + = convert versionRange where - ebuildName = "dev-haskell/" ++ map toLower pname - - convert :: Cabal.VersionRange -> Dependency - convert Cabal.AnyVersion = AnyVersionOf ebuildName - convert (Cabal.ThisVersion v) = ThisVersionOf (cabalVtoHPv v) ebuildName - convert (Cabal.LaterVersion v) = LaterVersionOf (cabalVtoHPv v) ebuildName - convert (Cabal.EarlierVersion v) = EarlierVersionOf (cabalVtoHPv v) ebuildName - convert (Cabal.UnionVersionRanges (Cabal.ThisVersion v1) (Cabal.LaterVersion v2)) - | v1 == v2 = OrLaterVersionOf (cabalVtoHPv v1) ebuildName - convert (Cabal.UnionVersionRanges (Cabal.ThisVersion v1) (Cabal.EarlierVersion v2)) - | v1 == v2 = OrEarlierVersionOf (cabalVtoHPv v1) ebuildName - convert (Cabal.UnionVersionRanges r1 r2) - = DependEither (convert r1) (convert r2) + -- XXX: not always true, we should look properly for deps in the overlay + -- to find the correct category + ebuildName = "dev-haskell/" ++ map toLower (Cabal.display pname) + convert :: Cabal.VersionRange -> [Dependency] + convert = Cabal.foldVersionRange' + ( [AnyVersionOf ebuildName] -- ^ @\"-any\"@ version + )(\v -> [ThisVersionOf (cabalVtoHPv v) ebuildName] -- ^ @\"== v\"@ + )(\v -> [LaterVersionOf (cabalVtoHPv v) ebuildName] -- ^ @\"> v\"@ + )(\v -> [EarlierVersionOf (cabalVtoHPv v) ebuildName] -- ^ @\"< v\"@ + )(\v -> [OrLaterVersionOf (cabalVtoHPv v) ebuildName] -- ^ @\">= v\"@ + )(\v -> [OrEarlierVersionOf (cabalVtoHPv v) ebuildName] -- ^ @\"<= v\"@ +{- FIXME -} )(\v1 _ -> [ThisMajorOf (cabalVtoHPv v1) ebuildName] -- ^ @\"== v.*\"@ wildcard. (incl lower, excl upper) + )(\r1 r2 -> case (r1,r2) of + ([r1'], [r2']) -> [DependEither r1' r2'] -- ^ @\"_ || _\"@ union + _ -> error "convertDependency: compound either" + )(\r1 r2 -> r1 ++ r2 + ) --- converts Cabal versiion type to hackopr version +-- converts Cabal version type to hackport version cabalVtoHPv :: Cabal.Version -> Version -cabalVtoHPv = Version . Cabal.versionBranch - -instance Show Version where - show (Version v) = intercalate "." $ map show v +cabalVtoHPv = (\v -> Version v Nothing [] 0) . Cabal.versionBranch -coreLibs :: [String] -coreLibs = +coreLibs :: [Cabal.PackageName] +coreLibs = map Cabal.PackageName ["array" ,"base" ---,"bytestring" --already has ebuild + ,"bytestring" -- intentionally no ebuild. use ghc's version + -- to avoid dreaded 'diamond dependency' problem ,"containers" ,"directory" ---,"filepath" --already has ebuild + --,"editline" + ,"filepath" -- intentionally no ebuild. use ghc's version ,"ghc" + ,"ghc-prim" ,"haskell98" ,"hpc" --has ebuild, but only in the overlay + ,"integer" ,"old-locale" ,"old-time" ,"packedstring" @@ -183,13 +187,14 @@ ,"random" ,"readline" --has ebuild, but only in the overlay ,"rts" + ,"syb" -- intentionally no ebuild. use ghc's version ,"template-haskell" ,"unix" --has ebuild, but only in the overlay ] showEBuild :: EBuild -> String showEBuild ebuild = - ss "# Copyright 1999-2008 Gentoo Foundation". nl. + ss "# Copyright 1999-2010 Gentoo Foundation". nl. ss "# Distributed under the terms of the GNU General Public License v2". nl. ss "# $Header: $". nl. nl. @@ -213,27 +218,26 @@ ss "KEYWORDS=". quote' (sepBy " " $ keywords ebuild).nl. ss "IUSE=". quote' (sepBy ", " $ iuse ebuild). nl. nl. - ss "DEPEND=". quote' (sepBy "\n\t\t" $ map showDepend $ depend ebuild). nl. + ( if (not . null . build_tools $ ebuild) + then ss "BUILDTOOLS=". quote' (sepBy "\n\t\t" $ map showDepend $ build_tools ebuild). nl + else id + ). + ( if (not . null . extra_libs $ ebuild ) + then ss "EXTRALIBS=". quote' (sepBy "\n\t\t" $ map showDepend $ extra_libs ebuild). nl + else id + ). + ( if (not . null . haskell_deps $ ebuild) + then ss "HASKELLDEPS=". quote' (sepBy "\n\t\t" $ map showDepend $ haskell_deps ebuild). nl + else id + ). + ss "RDEPEND=". quote' (sepBy "\n\t\t" $ rdepend ebuild). nl. + ss "DEPEND=". quote' (sepBy "\n\t\t" $ depend ebuild). nl. (case my_pn ebuild of Nothing -> id Just _ -> nl. ss "S=". quote ("${WORKDIR}/${MY_P}"). nl) $ [] where replaceVars = replaceCommonVars (name ebuild) (my_pn ebuild) (version ebuild) -showDepend :: Dependency -> Package -showDepend (AnyVersionOf p) = p -showDepend (ThisVersionOf v p) = "~" ++ p ++ "-" ++ show v -showDepend (LaterVersionOf v p) = ">" ++ p ++ "-" ++ show v -showDepend (EarlierVersionOf v p) = "<" ++ p ++ "-" ++ show v -showDepend (OrLaterVersionOf v p) = ">=" ++ p ++ "-" ++ show v -showDepend (OrEarlierVersionOf v p) = "<=" ++ p ++ "-" ++ show v -showDepend (DependEither dep1 dep2) = showDepend dep1 - ++ " || " ++ showDepend dep2 -showDepend (DependIfUse useflag dep@(DependEither _ _)) - = useflag ++ "? " ++ showDepend dep -showDepend (DependIfUse useflag dep) = useflag ++ "? ( " ++ showDepend dep++ " )" -showDepend (ThisMajorOf v p) = "=" ++ p ++ "-" ++ show v ++ "*" - ss :: String -> String -> String ss = showString @@ -294,108 +298,3 @@ ++[("${PN}",pn)] ++ maybe [] (\x->[("${MY_PN}",x)]) mypn ++[("${PV}",pv)]) str - - -{- Here goes code for dependencies simplification -} - -simplify_group_table :: Package -> - Maybe Version -> - Maybe Version -> - Maybe Version -> - Maybe Version -> - Maybe Version -> [Dependency] - --- simplify_group_table p ol l e oe exact --- 1) trivial cases: -simplify_group_table p Nothing Nothing Nothing Nothing Nothing = error $ p ++ ": unsolvable constraints" -simplify_group_table p (Just v) Nothing Nothing Nothing Nothing = [OrLaterVersionOf v p] -simplify_group_table p Nothing (Just v) Nothing Nothing Nothing = [LaterVersionOf v p] -simplify_group_table p Nothing Nothing (Just v) Nothing Nothing = [EarlierVersionOf v p] -simplify_group_table p Nothing Nothing Nothing (Just v) Nothing = [OrEarlierVersionOf v p] -simplify_group_table p Nothing Nothing Nothing Nothing (Just v) = [ThisVersionOf v p] - --- 2) simplification passes -simplify_group_table p (Just (Version v1)) Nothing (Just (Version v2)) Nothing Nothing - -- specian case: >=a-v.N a =a-v.N* - | (init v1 == init v2) && (last v2 == last v1 + 1) = [ThisMajorOf (Version v1) p] - | otherwise = [OrLaterVersionOf (Version v1) p, EarlierVersionOf (Version v2) p] - --- TODO: simplify constraints of type: >=a-v1; > a-v2 and such - --- o3) therwise sink: -simplify_group_table p (Just v) l@(_) e@(_) oe@(_) exact@(_) = OrLaterVersionOf v p : simplify_group_table p Nothing l e oe exact -simplify_group_table p ol@(Nothing) (Just v) e@(_) oe@(_) exact@(_) = LaterVersionOf v p : simplify_group_table p ol Nothing e oe exact -simplify_group_table p ol@(Nothing) l@(Nothing) (Just v) oe@(_) exact@(_) = EarlierVersionOf v p : simplify_group_table p ol l Nothing oe exact -simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) (Just v) exact@(_) = OrEarlierVersionOf v p : simplify_group_table p ol l e Nothing exact --- already defined earlier --- simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) oe@(Nothing) (Just v) = OrEarlierVersionOf v p : simplify_group_table p ol l e oe Nothing - --- >a-v1 >a-v2 => >a-(max v1 v2) --- key idea: all constraints are enforcing constraints, so we can't get --- more, than one interval. -simplify_group :: [Dependency] -> [Dependency] -simplify_group [dep@(AnyVersionOf _package)] = [dep] -simplify_group deps = simplify_group_table package - min_or_later_v -- >= - min_later_v -- > - max_earlier_v -- < - max_or_earlier_v -- <= - exact_this_v -- == - where - package = fromJust.getPackage $ head deps - max_earlier_v = safe_minimum $ map earlier_v deps - max_or_earlier_v = safe_minimum $ map or_earlier_v deps - min_later_v = safe_maximum $ map later_v deps - min_or_later_v = safe_maximum $ map or_later_v deps - exact_this_v = case catMaybes (map this_v deps) of - [] -> Nothing - [v] -> Just v - xs -> error $ "too many exact versions:" ++ show xs - -- - earlier_v (EarlierVersionOf v _p) = Just v - earlier_v _ = Nothing - - or_earlier_v (OrEarlierVersionOf v _p) = Just v - or_earlier_v _ = Nothing - - later_v (LaterVersionOf v _p) = Just v - later_v _ = Nothing - - or_later_v (OrLaterVersionOf v _p) = Just v - or_later_v _ = Nothing - - this_v (ThisVersionOf v _p) = Just v - this_v _ = Nothing - -- - safe_minimum xs = case catMaybes xs of - [] -> Nothing - xs' -> Just $ minimum xs' - safe_maximum xs = case catMaybes xs of - [] -> Nothing - xs' -> Just $ maximum xs' - --- divide packages to groups (by package name), simplify groups, merge again -simplify_deps :: [Dependency] -> [Dependency] -simplify_deps deps = (concatMap (simplify_group.nub) $ - groupBy cmpPkgName $ - sortBy (comparing getPackageString) groupable) - ++ ungroupable - where (ungroupable, groupable) = partition ((==Nothing).getPackage) deps - -- - cmpPkgName p1 p2 = cmpMaybe (getPackage p1) (getPackage p2) - cmpMaybe (Just p1) (Just p2) = p1 == p2 - cmpMaybe _ _ = False - -- -getPackage :: Dependency -> Maybe Package -getPackage (AnyVersionOf package) = Just package -getPackage (ThisVersionOf _version package) = Just package -getPackage (LaterVersionOf _version package) = Just package -getPackage (EarlierVersionOf _version package) = Just package -getPackage (OrLaterVersionOf _version package) = Just package -getPackage (OrEarlierVersionOf _version package) = Just package -getPackage (DependEither _dependency _Dependency) = Nothing -getPackage (DependIfUse _useFlag _Dependency) = Nothing -getPackage (ThisMajorOf _version package) = Just package --- -getPackageString :: Dependency -> Package -getPackageString dep = maybe "" id $ getPackage dep diff --git a/Cache.hs b/Cache.hs deleted file mode 100644 --- a/Cache.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Cache where - -import Action -import CacheFile -import Config -import Error -import Index -import P2 -import Version -import Overlays - -import Distribution.Text ( simpleParse ) - -import Control.Arrow -import Data.Char -import Data.List -import Network.URI (URI, uriPath) -import Network.HTTP (Request(..), RequestMethod(GET), simpleHTTP, rspBody) -import qualified Data.ByteString.Lazy as L -import System.Time -import System.FilePath -import Control.Monad.Error(throwError) -import Control.Monad.Writer -import Control.Monad (unless) -import System.Directory (doesFileExist,createDirectoryIfMissing) - -import qualified Data.Map as Map - --- | A long time. Used in checkCacheDate -alarmingLongTime :: TimeDiff -alarmingLongTime = TimeDiff - { tdYear = 0 - , tdMonth = 0 - , tdDay = 7 - , tdHour = 0 - , tdMin = 0 - , tdSec = 0 - , tdPicosec = 0 - } - -cacheURI :: URI -> URI -cacheURI uri = uri {uriPath = uriPath uri indexFile} - -updateCache :: HPAction () -updateCache = do - path <- getOverlayPath - cfg <- getCfg - let cache = cacheURI $ server cfg - res <- (liftIO $ simpleHTTP (Request cache GET [] "")) `sayNormal` ("Fetching cache from "++show cache++"...",const "done.") - case res of - Left err -> throwError (ConnectionFailed (show cache) (show err)) - Right resp -> liftIO $ do - createDirectoryIfMissing False (path hackportDir) - Prelude.writeFile (cacheFile path) (rspBody resp) - -readCache :: FilePath -> HPAction Index -readCache portdir = do - let cachePath = cacheFile portdir - exists <- liftIO $ doesFileExist cachePath - unless exists $ do - info "No cache file present, attempting to update..." - updateCache - str <- liftIO $ L.readFile cachePath - return $ readIndex str - -readDefaultCache :: HPAction Index -readDefaultCache = do - overlayPath <- getOverlayPath - readCache overlayPath - -indexToPortage :: Index -> Portage -> (Portage, [String]) -indexToPortage index port = second nub . runWriter $ do - pkgs <- forM index $ \(pkg_h_name, pkg_h_ver, pkg_desc) -> do - let pkg_name = map toLower pkg_h_name - pkg_cat <- lookupCat pkg_name - Just ver <- return . simpleParse $ pkg_h_ver - return $ Ebuild (P pkg_cat pkg_name) - (fromCabalVersion ver) - "" - (Just pkg_desc) - return $ Map.map sort $ Map.fromListWith (++) [ (ePackage e, [e]) | e <- pkgs ] - where - catMap = Map.fromListWith (++) [ (p, [c]) | P c p <- Map.keys port ] - lookupCat :: String -> Writer [String] String - lookupCat p = do - case Map.lookup p catMap of - Nothing -> return "hackage" - Just [x] -> return x - Just xs -> do - let c | elem "dev-haskell" xs = "dev-haskell" - | otherwise = head xs - tell ["WARNING: Category clash for package " ++ p ++ ", defaulting to " ++ c ++ ". Other categories: " ++ unwords (delete c xs)] - return c diff --git a/Config.hs b/Config.hs deleted file mode 100644 --- a/Config.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Config where - -import Network.URI -import System.Console.GetOpt -import Text.Regex - -data HackPortOptions - = OverlayPath String - | PortagePath String - | Server String - | TempDir String - | Verbosity String - | Help - | RefreshCache - -data OperationMode - = List String - | Merge String - | DiffTree DiffMode - | Update - | ShowHelp - | Status String - | MakeEbuild String - -data DiffMode - = ShowAll - | ShowMissing - | ShowAdditions - | ShowNewer - | ShowCommon - deriving Eq - -data Config = Config - { overlayPath ::Maybe String - , portagePath ::Maybe String - , server ::URI - , tmp ::String - , verbosity ::Verbosity - , refreshCache ::Bool - } - -data Verbosity - = Debug - | Normal - | Silent - -packageRegex :: Regex -packageRegex = mkRegex "^(.*?)-([0-9].*)$" - -defaultConfig :: Config -defaultConfig = Config - { overlayPath = Nothing - , portagePath = Nothing - , server = URI "http:" (Just $ URIAuth "" "hackage.haskell.org" "") "/packages/archive/" "" "" - , tmp = "/tmp" - , verbosity = Normal - , refreshCache = False - } - -hackageOptions :: [OptDescr HackPortOptions] -hackageOptions = - [Option ['o'] ["overlay-path"] (ReqArg OverlayPath "PATH") "The overlay tree to merge to" - ,Option ['p'] ["portdir"] (ReqArg PortagePath "PATH") "The portage directory to use" - ,Option ['s'] ["server"] (ReqArg Server "URL") "The Hackage server to query" - ,Option ['t'] ["temp-dir"] (ReqArg TempDir "PATH") "A temp directory where tarballs can be stored" - ,Option ['v'] ["verbosity"] (ReqArg Verbosity "debug|normal|silent") "Set verbosity level (default is 'normal')" - ,Option ['h', '?'] ["help"] (NoArg Help) "Display this help message" - ,Option ['r'] ["refresh-cache"] (NoArg RefreshCache) "Refresh the hackport cache before running the command" - ] - -parseConfig :: [String] -> Either String ([HackPortOptions],OperationMode) -parseConfig opts = let - (popts,args,errs) = getOpt Permute hackageOptions opts - mode | not (null errs) = Left $ "Error while parsing flags:\n" - ++ concat errs - | not (null [ () | Help <- popts ]) = Right ShowHelp - | otherwise = case args of - "merge":[] -> Left "Need a package's name and version to merge it.\n" - "merge":package:[] -> Right (Merge package) - "merge":_:rest -> Left ("'merge' takes 1 argument("++show ((length rest)+1)++" given).\n") - "list":[] -> Right (List "") - "list":package:[] -> Right (List package) - "list":rest -> Left ("'list' takes at most one argument ("++show (length rest)++" given).\n") - "diff":[] -> Right (DiffTree ShowAll) - "diff":"all":[] -> Right (DiffTree ShowAll) - "diff":"missing":[] -> Right (DiffTree ShowMissing) - "diff":"additions":[] -> Right (DiffTree ShowAdditions) - "diff":"newer":[] -> Right (DiffTree ShowNewer) - "diff":"common":[] -> Right (DiffTree ShowCommon) - "diff":arg:[] -> Left ("Unknown argument to diff: '" ++ arg ++ "'. Use all,missing,additions,newer or common.\n") - "diff":_:xs -> Left ("'diff' takes one argument("++show ((length xs)+1)++" given).\n") - "update":[] -> Right Update - "update":rest -> Left ("'update' takes zero arguments("++show (length rest)++" given).\n") - "status":[] -> Right (Status "") - "status":"toportage":[] -> Right (Status "toportage") - "status":xs-> Left ("invalid argument(s) to 'status': " ++ show xs) - "make-ebuild":[] -> Left "Need .cabal file to make ebuild." - "make-ebuild":package:[] -> Right (MakeEbuild package) - "make-ebuild":_:rest -> Left ("'make-ebuild' takes 1 argument("++show ((length rest)+1)++" given).\n") - - [] -> Right ShowHelp - _ -> Left "Unknown opertation mode\n" - in case mode of - Left err -> Left err - Right m -> Right (popts,m) - -hackageUsage :: IO () -hackageUsage = putStr $ flip usageInfo hackageOptions $ unlines - [ "Usage:" - , "\t\"hackport [OPTION] MODE [MODETARGET]\"" - , "\t\"hackport [OPTION] list [PKG]\" lists all packages or packages matching search term" - , "\t\"hackport [OPTION] merge PKG-VERSION\" merges a package into the portage tree" - , "\t\"hackport [OPTION] diff\" prints the difference between the portage-tree and the server's packages" - , "\t\"hackport [OPTION] update\" updates the local cache" - , "\t\"hackport [OPTION] status\" compares the overlay with the portage tree" - , "\t\"hackport [OPTION] make-ebuild\" creates standalone ebuild from given .cabal file" - , "Options:" - ] - -parseVerbosity :: String -> Maybe Verbosity -parseVerbosity "debug" = Just Debug -parseVerbosity "normal" = Just Normal -parseVerbosity "silent" = Just Silent -parseVerbosity _ = Nothing - diff --git a/Diff.hs b/Diff.hs --- a/Diff.hs +++ b/Diff.hs @@ -1,70 +1,188 @@ module Diff - ( diffAction + ( runDiff + , DiffMode(..) ) where -import qualified Data.Map as Map +import Control.Monad ( mplus ) +import Control.Exception ( assert ) +import Data.Maybe ( fromJust, listToMaybe ) +import Data.List ( sortBy, groupBy ) +import Data.Ord ( comparing ) -import Control.Monad.Trans -import Data.Char +import qualified Portage.Overlay as Portage +import qualified Portage.Cabal as Portage +import qualified Portage.PackageId as Portage -import Action -import Cache -import Config (DiffMode(..)) -import P2 -import Version -import Overlays +import qualified Data.Version as Cabal -data DiffState a - = OnlyLeft a - | OnlyRight a - | Both a a +-- cabal +import Distribution.Verbosity +import Distribution.Text(display) +import qualified Distribution.Package as Cabal +import qualified Distribution.Client.PackageIndex as Index +import Distribution.Simple.Utils (equating) +-- cabal-install +import qualified Distribution.Client.IndexUtils as Index (getAvailablePackages ) +import qualified Distribution.Client.Types as Cabal +import Distribution.Client.Utils (mergeBy, MergeResult(..)) + +data DiffMode + = ShowAll + | ShowMissing + | ShowAdditions + | ShowNewer + | ShowCommon + | ShowPackages [String] + deriving Eq + + +{- +type DiffState a = MergeResult a a tabs :: String -> String tabs str = let len = length str in str++(if len < 3*8 then replicate (3*8-len) ' ' else "") -showDiffState :: Package -> DiffState Version -> String -showDiffState pkg st = (tabs (show pkg)) ++ " [" ++ (case st of - Both x y -> showVersion x ++ (case compare x y of - EQ -> "=" - GT -> ">" - LT -> "<") ++ showVersion y - OnlyLeft x -> showVersion x ++ ">none" - OnlyRight y -> "none<"++showVersion y)++"]" +-- TODO: is the new showPackageCompareInfo showing the packages in the same +-- way as showDiffState did? -diffAction :: DiffMode -> HPAction () -diffAction dm = do - overlayPath <- getOverlayPath - cache <- readCache overlayPath - overlayTree <- liftIO $ readPortageTree overlayPath - let (hackageTree, clashes) = indexToPortage cache overlayTree - liftIO $ mapM_ putStrLn clashes - diff hackageTree overlayTree dm +showDiffState :: Cabal.PackageName -> DiffState Portage.Version -> String +showDiffState pkg st = (tabs (display pkg)) ++ " [" ++ (case st of + InBoth x y -> display x ++ (case compare x y of + EQ -> "=" + GT -> ">" + LT -> "<") ++ display y + OnlyInLeft x -> display x ++ ">none" + OnlyInRight y -> "none<" ++ display y) ++ "]" +-} -diff :: Portage -> Portage -> DiffMode -> HPAction () -diff pt1 pt2 mode = do - let pkgs1 = Map.map (OnlyLeft . eVersion . maximum) pt1 - let pkgs2 = Map.map (OnlyRight . eVersion . maximum) pt2 - let union = Map.unionWith (\(OnlyLeft x) (OnlyRight y) -> Both x y) pkgs1 pkgs2 - let showFilter st = case mode of - ShowAll -> True - ShowMissing -> case st of - OnlyLeft _ -> True - Both x y -> x > y - OnlyRight _ -> False - ShowAdditions -> case st of - OnlyLeft _ -> False - Both x y -> x < y - OnlyRight _ -> True - ShowNewer -> case st of - OnlyLeft _ -> False - Both x y -> x > y - OnlyRight _ -> False - ShowCommon -> case st of - OnlyLeft _ -> False - Both x y -> x == y - OnlyRight _ -> False - let packages = filter (showFilter . snd) (Map.assocs union) - mapM_ (info . uncurry showDiffState) packages +runDiff :: Verbosity -> FilePath -> DiffMode -> Cabal.Repo -> IO () +runDiff verbosity overlayPath dm repo = do + -- get package list from hackage + pkgDB <- Index.getAvailablePackages verbosity [ repo ] + let (Cabal.AvailablePackageDb hackageIndex _) = pkgDB + + -- get package list from the overlay + overlay0 <- (Portage.loadLazy overlayPath) + let overlayIndex = Portage.fromOverlay (Portage.reduceOverlay overlay0) + + let (subHackage, subOverlay) + = case dm of + ShowPackages pkgs -> + (concatMap (Index.searchByNameSubstring hackageIndex) pkgs + ,concatMap (Index.searchByNameSubstring overlayIndex) pkgs) + _ -> + (Index.allPackages hackageIndex + ,Index.allPackages overlayIndex) + diff subHackage subOverlay dm + +data PackageCompareInfo = PackageCompareInfo { + name :: Cabal.PackageName, +-- hackageVersions :: [ Cabal.Version ], +-- overlayVersions :: [ Cabal.Version ] + hackageVersion :: Maybe Cabal.Version, + overlayVersion :: Maybe Cabal.Version + } deriving Show + +showPackageCompareInfo :: PackageCompareInfo -> String +showPackageCompareInfo pkgCmpInfo = + display (name pkgCmpInfo) ++ " [" + ++ hackageS ++ sign ++ overlayS ++ "]" + where + overlay = overlayVersion pkgCmpInfo + hackage = hackageVersion pkgCmpInfo + hackageS = maybe "none" display hackage + overlayS = maybe "none" display overlay + sign = case compare hackage overlay of + EQ -> "=" + GT -> ">" + LT -> "<" + +diff :: [Cabal.AvailablePackage] + -> [Portage.ExistingEbuild] + -> DiffMode + -> IO () +diff hackage overlay dm = do + mapM_ (putStrLn . showPackageCompareInfo) pkgCmpInfos + where + merged = mergePackages (map (Portage.normalizeCabalPackageId . Cabal.packageId) hackage) + (map Portage.ebuildCabalId overlay) + pkgCmpInfos = filter pkgFilter (map (uncurry mergePackageInfo) merged) + pkgFilter :: PackageCompareInfo -> Bool + pkgFilter pkgCmpInfo = + let om = overlayVersion pkgCmpInfo + hm = hackageVersion pkgCmpInfo + st = case (om,hm) of + (Just ov, Just hv) -> InBoth ov hv + (Nothing, Just hv) -> OnlyInRight hv + (Just ov, Nothing) -> OnlyInLeft ov + _ -> error "impossible" + in + case dm of + ShowAll -> True + ShowPackages _ -> True -- already filtered + ShowNewer -> case st of + InBoth o h -> h>o + _ -> False + ShowMissing -> case st of + OnlyInLeft _ -> False + InBoth x y -> x < y + OnlyInRight _ -> True + ShowAdditions -> case st of + OnlyInLeft _ -> True + InBoth x y -> x > y + OnlyInRight _ -> False + ShowCommon -> case st of + OnlyInLeft _ -> False + InBoth x y -> x == y + OnlyInRight _ -> False + +-- | We get the 'PackageCompareInfo' by combining the info for the overlay +-- and hackage versions of a package. +-- +-- * We're building info about a various versions of a single named package so +-- the input package info records are all supposed to refer to the same +-- package name. +-- +mergePackageInfo :: [Cabal.PackageIdentifier] + -> [Cabal.PackageIdentifier] + -> PackageCompareInfo +mergePackageInfo hackage overlay = + assert (length overlay + length hackage > 0) $ + PackageCompareInfo { + name = combine Cabal.pkgName latestHackage + Cabal.pkgName latestOverlay, +-- hackageVersions = map Cabal.pkgVersion hackage, +-- overlayVersions = map Cabal.pkgVersion overlay + hackageVersion = fmap Cabal.pkgVersion latestHackage, + overlayVersion = fmap Cabal.pkgVersion latestOverlay + } + where + combine f x g y = fromJust (fmap f x `mplus` fmap g y) + latestHackage = latestOf hackage + latestOverlay = latestOf overlay + latestOf :: [Cabal.PackageIdentifier] -> Maybe Cabal.PackageIdentifier + latestOf = listToMaybe . reverse . sortBy (comparing Cabal.pkgVersion) + +-- | Rearrange installed and available packages into groups referring to the +-- same package by name. In the result pairs, the lists are guaranteed to not +-- both be empty. +-- +mergePackages :: [Cabal.PackageIdentifier] -> [Cabal.PackageIdentifier] + -> [([Cabal.PackageIdentifier], [Cabal.PackageIdentifier])] +mergePackages hackage overlay = + map collect + $ mergeBy (\i a -> fst i `compare` fst a) + (groupOn Cabal.pkgName hackage) + (groupOn Cabal.pkgName overlay) + where + collect (OnlyInLeft (_,is) ) = (is, []) + collect ( InBoth (_,is) (_,as)) = (is, as) + collect (OnlyInRight (_,as)) = ([], as) + +groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] +groupOn key = map (\xs -> (key (head xs), xs)) + . groupBy (equating key) + . sortBy (comparing key) diff --git a/DistroMap.hs b/DistroMap.hs new file mode 100644 --- /dev/null +++ b/DistroMap.hs @@ -0,0 +1,159 @@ +{-# OPTIONS -XPatternGuards #-} +{- +Generate a distromap, like these: +http://hackage.haskell.org/packages/archive/00-distromap/ +Format: + +("xmobar","0.8",Just "http://packages.gentoo.org/package/x11-misc/xmobar") +("xmobar","0.9",Just "http://packages.gentoo.org/package/x11-misc/xmobar") +("xmobar","0.9.2",Just "http://packages.gentoo.org/package/x11-misc/xmobar") +("xmonad","0.5",Just "http://packages.gentoo.org/package/x11-wm/xmonad") +("xmonad","0.6",Just "http://packages.gentoo.org/package/x11-wm/xmonad") +("xmonad","0.7",Just "http://packages.gentoo.org/package/x11-wm/xmonad") +("xmonad","0.8",Just "http://packages.gentoo.org/package/x11-wm/xmonad") +("xmonad","0.8.1",Just "http://packages.gentoo.org/package/x11-wm/xmonad") +("xmonad","0.9",Just "http://packages.gentoo.org/package/x11-wm/xmonad") +("xmonad","0.9.1",Just "http://en.gentoo-wiki.com/wiki/Haskell/overlay") + +Multiple entries for each package is allowed, given that there are different versions. + + +Setup: + Join all packages from portage and the overlay into a big map; + From Portage.PackageId: PackageName = category/package + PVULine = (packagename, versionstring, url) + Create such a map: Map PackageName DistroLine + Only one PVULine per version, and prefer portage over the overlay. + +Algorithm; + 1. Take a package from hackage + 2. Look for it in the map + a. For each version: + find a match in the list of versions: + yield the PVULine +-} + +module DistroMap + ( distroMap ) where + +import Control.Applicative +import qualified Data.List as List ( nub ) +import qualified Data.Map as Map +import Data.Map ( Map ) +import System.FilePath ( () ) +import Debug.Trace ( trace ) +import Data.Maybe ( fromJust ) + +import Distribution.Verbosity +import Distribution.Text ( display ) +import Distribution.Client.Types ( Repo, AvailablePackageDb(..), AvailablePackage(..) ) +import Distribution.Simple.Utils ( warn, notice, info ) + +import qualified Data.Version as Cabal +import qualified Distribution.Package as Cabal +import qualified Distribution.Client.PackageIndex as CabalInstall +import qualified Distribution.Client.IndexUtils as CabalInstall + +import Portage.Overlay ( Overlay(..), readOverlayByPackage, getDirectoryTree, DirectoryTree ) +import qualified Portage.PackageId as Portage +import qualified Portage.Version as Portage + +type PVU = (Cabal.PackageName, Cabal.Version, Maybe String) +type PVU_Map = Map Portage.PackageName [(Cabal.Version, Maybe String)] +type PVU_Item = (Portage.PackageName, [(Cabal.Version, Maybe String)]) + +distroMap :: Verbosity -> Repo -> FilePath -> FilePath -> [String] -> IO () +distroMap verbosity repo portagePath overlayPath args = do + info verbosity "distro map called" + info verbosity ("verbosity: " ++ show verbosity) + info verbosity ("portage: " ++ portagePath) + info verbosity ("overlay: " ++ overlayPath) + info verbosity ("args: " ++ show args) + + portage <- readOverlayByPackage <$> getDirectoryTree portagePath + overlay <- readOverlayByPackage <$> getDirectoryTree overlayPath + + info verbosity ("portage packages: " ++ show (length portage)) + info verbosity ("overlay packages: " ++ show (length overlay)) + + let portageMap = buildPortageMap portage + overlayMap = buildOverlayMap overlay + completeMap = unionMap portageMap overlayMap + + info verbosity ("portage map: " ++ show (Map.size portageMap)) + info verbosity ("overlay map: " ++ show (Map.size overlayMap)) + info verbosity ("complete map: " ++ show (Map.size completeMap)) + + AvailablePackageDb { packageIndex = packageIndex } <- + CabalInstall.getAvailablePackages verbosity [repo] + + let pkgs0 = map (map packageInfoId) (CabalInstall.allPackagesByName packageIndex) + hackagePkgs = [ (Cabal.pkgName (head p), map Cabal.pkgVersion p) | p <- pkgs0 ] + + info verbosity ("cabal packages: " ++ show (length hackagePkgs)) + + let pvus = concat $ map (\(p,vs) -> lookupPVU completeMap p vs) hackagePkgs + info verbosity ("found pvus: " ++ show (length pvus)) + + mapM_ (putStrLn . showPVU) pvus + return () + + +showPVU :: PVU -> String +showPVU (p,v,u) = show $ (display p, display v, u) + +-- building the PVU_Map + +reduceVersion :: Portage.Version -> Portage.Version +reduceVersion (Portage.Version ns _ _ _) = Portage.Version ns Nothing [] 0 + +reduceVersions :: [Portage.Version] -> [Portage.Version] +reduceVersions = List.nub . map reduceVersion + +buildMap :: [(Portage.PackageName, [Portage.Version])] + -> (Portage.PackageName -> Portage.Version -> Maybe String) + -> PVU_Map +buildMap pvs f = Map.mapWithKey (\p vs -> [ (fromJust $ Portage.toCabalVersion v, f p v) + | v <- reduceVersions vs ]) + (Map.fromList pvs) + +buildPortageMap :: [(Portage.PackageName, [Portage.Version])] -> PVU_Map +buildPortageMap lst = buildMap lst $ \ (Portage.PackageName c p) _v -> + Just $ "http://packages.gentoo.org/package" display c display p + +buildOverlayMap :: [(Portage.PackageName, [Portage.Version])] -> PVU_Map +buildOverlayMap lst = buildMap lst $ \_ _ -> Just "http://en.gentoo-wiki.com/wiki/Haskell/overlay" + +unionMap :: PVU_Map -> PVU_Map -> PVU_Map +unionMap = Map.unionWith f + where + f :: [(Cabal.Version, Maybe String)] + -> [(Cabal.Version, Maybe String)] + -> [(Cabal.Version, Maybe String)] + f vas vbs = Map.toList (Map.union (Map.fromList vas) (Map.fromList vbs)) + + +-- resolving Cabal.PackageName to Portage.PackageName + +lookupPVU :: PVU_Map -> Cabal.PackageName -> [Cabal.Version] -> [PVU] +lookupPVU pvu_map pn cvs = + case findItems pvu_map (Portage.normalizeCabalPackageName pn) of + [] -> [] + [item] -> ret item + items | [item] <- preferableItem items -> ret item + | otherwise -> trace (noDefaultText items) [] + where + noDefaultText is = unlines $ ("no default for package: " ++ display pn) + : [ " * " ++ (display cat) + | (Portage.PackageName cat _, _) <- is] + + ret (_, vs) = [ (pn, v, u) | (v, u) <- vs, v `elem` cvs ] + preferableItem items = + [ item + | item@(Portage.PackageName cat _pn, _vs) <- items + , cat == Portage.Category "dev-haskell"] + findItems pvu_map cpn = Map.toList $ Map.filterWithKey f pvu_map + where + f (Portage.PackageName _cat pn) _vs = cpn == pn + + diff --git a/Error.hs b/Error.hs --- a/Error.hs +++ b/Error.hs @@ -1,8 +1,9 @@ {-# OPTIONS -fglasgow-exts #-} -module Error where +module Error (HackPortError(..), throwEx, catchEx, hackPortShowError) where import Data.Typeable -import Control.Monad.Error (Error) +import Control.Exception.Extensible as EE +import Control.Monad.Error data HackPortError = ArgumentError String @@ -25,17 +26,23 @@ -- | WrongCacheVersion -- | InvalidCache | InvalidServer String - deriving (Typeable) + deriving (Typeable, Show) -instance Error HackPortError +instance Error HackPortError where -type HackPortResult a = Either +instance Exception HackPortError where +throwEx :: HackPortError -> IO a +throwEx = EE.throw + +catchEx :: IO a -> (HackPortError -> IO a) -> IO a +catchEx = EE.catch + hackPortShowError :: HackPortError -> String hackPortShowError err = case err of ArgumentError str -> "Argument error: "++str ConnectionFailed server reason -> "Connection to hackage server '"++server++"' failed: "++reason - PackageNotFound pkg -> "Package '"++ pkg ++"' not found on server." + PackageNotFound pkg -> "Package '"++ pkg ++"' not found on server. Try 'hackport update'?" InvalidTarballURL url reason -> "Error while downloading tarball '"++url++"': "++reason InvalidSignatureURL url reason -> "Error while downloading signature '"++url++"': "++reason VerificationFailed file signature -> "Error while checking signature('"++signature++"') of '"++file++"'" diff --git a/Fetch.hs b/Fetch.hs deleted file mode 100644 --- a/Fetch.hs +++ /dev/null @@ -1,75 +0,0 @@ -module Fetch(downloadTarball,downloadFileVerify) where - -import Prelude hiding (catch) - -import Network.HTTP (ConnError(..),Request(..),simpleHTTP - ,Response(..),RequestMethod(..)) -import Network.URI (URI,uriPath,parseURI) -import Text.Regex (Regex,mkRegex,matchRegex) -import System.GPG -import Control.Monad.Error -import System.Directory -import System.FilePath -import Data.Typeable - -import Error -import Action - -filenameRegex :: Regex -filenameRegex = mkRegex "^.*?/([^/]*?)" - -uriToFileName :: URI -> Maybe FilePath -uriToFileName uri = maybe Nothing (\x->Just (head x)) (matchRegex filenameRegex (uriPath uri)) - -downloadURI :: FilePath -- ^ a directory to store the file - -> URI -- ^ the url - -> HPAction FilePath -- ^ the path of the downloaded file -downloadURI path uri = do - fileName <- maybe (throwError $ InvalidTarballURL (show uri) "URL doesn't contain a filename") return (uriToFileName uri) - httpResult <- liftIO $ simpleHTTP request - Response {rspCode=code,rspBody=body,rspReason=reason} <- either (\x->throwError $ DownloadFailed (show uri) "Connection failed") return httpResult - if code==(2,0,0) then (do - let writePath=path fileName - liftIO $ writeFile writePath body - return writePath) else throwError $ DownloadFailed (show uri) ("Code "++show code++":"++reason) - where - request = Request - {rqURI=uri - ,rqMethod=GET - ,rqHeaders=[] - ,rqBody=""} - - -downloadFileVerify :: - FilePath -> -- ^ the directory to store the files - String -> -- ^ the url of the tarball - String -> -- ^ the url of the signature - HPAction (FilePath,FilePath) -- ^ the tarballs and signatures path -downloadFileVerify path url sigurl = do - tarballPath <- downloadTarball path url - sigPath <- downloadSig path sigurl `catchError` (\x->liftIO (removeFile tarballPath) >> throwError x) - verified <- liftIO $ verifyFile stdOptions tarballPath sigPath - if verified then return (tarballPath,sigPath) else (do - liftIO $ removeFile tarballPath - liftIO $ removeFile sigPath - throwError $ VerificationFailed url sigurl) - -downloadTarball :: - FilePath -> - String -> - HPAction FilePath -downloadTarball dir url = download dir url InvalidTarballURL - -downloadSig :: - FilePath -> - String -> - HPAction FilePath -downloadSig dir url = download dir url InvalidSignatureURL - -download :: FilePath -- ^ the folder to store the file in - -> String -- ^ the url - -> (String -> String -> HackPortError) -- ^ a function to construct an error - -> HPAction FilePath -- ^ the resulting file's path -download dir url errFunc = do - parsedURL <- maybe (throwError $ errFunc url "Parsing failed") return (parseURI url) - downloadURI dir parsedURL diff --git a/GenerateEbuild.hs b/GenerateEbuild.hs deleted file mode 100644 --- a/GenerateEbuild.hs +++ /dev/null @@ -1,60 +0,0 @@ -module GenerateEbuild where - -import Action -import Cabal2Ebuild -import Config - -import Prelude hiding (catch) -import Control.Monad.Error -import Distribution.Package -import Data.Version (showVersion) -import Network.URI -import System.Directory -import System.FilePath - -mergeEbuild :: FilePath -> String -> EBuild -> IO () -mergeEbuild target category ebuild = do - let edir = target category name ebuild - let epath = edir name ebuild ++"-"++ version ebuild <.> "ebuild" - createDirectoryIfMissing True edir - writeFile epath (showEBuild ebuild) - -fixSrc :: PackageIdentifier -> EBuild -> HPAction EBuild -fixSrc p ebuild = do - cfg <- getCfg - return $ ebuild { - src_uri = show $ (server cfg) { - uriPath = (uriPath (server cfg)) - pkgName p - showVersion (pkgVersion p) - pkgName p ++ "-" ++ - showVersion (pkgVersion p) - <.> "tar.gz" - } - } - -{-hackage2ebuild :: - (PackageIdentifier,String,String) -> -- ^ the package - HPAction EBuild -hackage2ebuild (pkg,tarball,sig) = do - cfg <- getCfg - tarballPath <- (if verify cfg then (do - (tarPath,sigPath) <- downloadFileVerify (tmp cfg) tarball sig - liftIO $ removeFile sigPath - return tarPath) else (downloadTarball (tmp cfg) tarball)) - `sayNormal` ("Downloading tarball from '"++tarball++"' to '"++(tmp cfg)++"'... ",const "done.") - tarType <- maybe (liftIO (removeFile tarballPath) >> throwError (UnknownCompression tarball)) return (tarballGetType tarballPath) - `sayDebug` ("Guessing compression type of tarball... ",const "done.") - filesInTarball <- tarballGetFiles (tarCommand cfg) tarballPath tarType - `sayDebug` ("Getting list of files from tarball... ",const "done.") - `catchError` (\x->liftIO (removeFile tarballPath) >> throwError x) - (cabalDir,cabalName) <- maybe (throwError $ NoCabalFound tarball) return (findCabal filesInTarball) - `sayDebug` ("Trying to find cabal file... ",\(dir,name)->"Found cabal file '"++name++"' in '"++dir++"'.") - cabalFile <- tarballExtractFile tarballPath tarType (cabalDir++"/"++cabalName) - `sayDebug` ("Extracting cabal file... ",const "done.") - packageDescription <- case parseDescription cabalFile of - ParseFailed err -> throwError $ CabalParseFailed cabalName (showError err) - ParseOk descr -> return descr - `sayDebug` ("Parsing '"++cabalName++"'... ",const "done.") - let ebuild=cabal2ebuild (packageDescription{pkgUrl=tarball}) --we don't trust the cabal file as we just successfully downloaded the tarbal somewhere - return ebuild {cabalPath=Just cabalDir}-} diff --git a/Index.hs b/Index.hs deleted file mode 100644 --- a/Index.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Index where - -import qualified Data.Set as Set -import qualified Data.Map as Map -import Data.Version (Version,parseVersion) -import Codec.Compression.GZip(decompress) -import Data.ByteString.Lazy.Char8(ByteString,unpack) -import Codec.Archive.Tar -import Distribution.PackageDescription -import Distribution.Package -import System.FilePath.Posix -import MaybeRead (readPMaybe) - -type Index = [(String,String,GenericPackageDescription)] -type IndexMap = Map.Map String (Set.Set Version) - -readIndex :: ByteString -> Index -readIndex str = do - let unziped = decompress str - untared = readTarArchive unziped - entr <- archiveEntries untared - case splitDirectories (tarFileName (entryHeader entr)) of - [".",pkgname,vers,file] -> do - let descr = case parsePackageDescription (unpack (entryData entr)) of - ParseOk _ pkg_desc -> pkg_desc - _ -> error $ "Couldn't read cabal file "++show file - return (pkgname,vers,descr) - _ -> fail "doesn't look like the proper path" - -filterIndexByPV :: (String -> String -> Bool) -> Index -> Index -filterIndexByPV cond index = [ x | x@(p,v,_d) <- index, cond p v] - -indexMapFromList :: [PackageIdentifier] -> IndexMap -indexMapFromList pids = Map.unionsWith Set.union $ - [ Map.singleton name (Set.singleton vers) - | (PackageIdentifier {pkgName = name,pkgVersion = vers}) <- pids ] - -indexToPackageIdentifier :: Index -> [PackageIdentifier] -indexToPackageIdentifier index = do - (name,vers_str,_) <- index - Just vers <- return $ readPMaybe parseVersion vers_str - return $ PackageIdentifier {pkgName = name,pkgVersion = vers} - -bestVersions :: IndexMap -> Map.Map String Version -bestVersions = Map.map Set.findMax diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,136 +1,581 @@ module Main where -import Control.Monad.Error -import Data.Char +import Control.Applicative +import Control.Monad import Data.Maybe import Data.List -import Data.Version -import Distribution.Package -import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC)) +import Data.Monoid + ( Monoid(..) ) + +-- cabal +import Distribution.Simple.Setup + ( Flag(..), fromFlag + , trueArg + , flagToMaybe, flagToList + , optionVerbosity + ) import Distribution.PackageDescription.Configuration - ( finalizePackageDescription, flattenPackageDescription ) -import Distribution.Simple.PackageIndex (PackageIndex) + ( flattenPackageDescription ) +import Distribution.ReadE ( succeedReadE ) +import Distribution.Simple.Command -- commandsRun +import Distribution.Simple.Utils ( die, cabalVersion, warn ) +import qualified Distribution.PackageDescription.Parse as Cabal +import qualified Distribution.Package as Cabal +import Distribution.Verbosity (Verbosity, normal) import Distribution.Text (display) -import System.IO -import Distribution.System (buildOS, buildArch) -import qualified Data.Map as Map -import Text.ParserCombinators.Parsec -import Action +import Distribution.Client.Types +import Distribution.Client.Update + +import qualified Distribution.Client.PackageIndex as Index +import qualified Distribution.Client.IndexUtils as Index + +import Portage.Overlay as Overlay ( loadLazy, inOverlay ) +import Portage.Host as Host ( getInfo, portage_dir ) +import Portage.PackageId ( normalizeCabalPackageId ) + +import Network.URI +import System.Environment ( getArgs, getProgName ) +import System.Directory ( doesDirectoryExist ) +import System.Exit ( exitFailure ) +import System.FilePath ( () ) + import qualified Cabal2Ebuild as E -import Cache -import Config + import Diff import Error -import GenerateEbuild -import Index import Status -import Package import Overlays -import P2 +import Merge +import DistroMap ( distroMap ) -import qualified Distribution.PackageDescription as Cabal -import Distribution.Verbosity (normal) -import Cabal2Ebuild +import qualified Paths_cabal_install +import qualified Paths_hackport -list :: String -> HPAction () -list name = do - index <- readCache =<< getOverlayPath - let index' | null name = index - | otherwise = filterIndexByPV matchSubstringCaseInsensitive index - pkgs = [ pkg ++ "-" ++ ver | (pkg,ver,_) <- index'] - if null pkgs - then throwError (PackageNotFound name) - else liftIO . putStr . unlines . sort $ pkgs - where - matchSubstringCaseInsensitive pName _pVver = - map toLower name `isInfixOf` map toLower pName +----------------------------------------------------------------------- +-- List +----------------------------------------------------------------------- -merge :: String -> HPAction () -merge pstr = do - (m_category, pname, m_version) <- case parsePVC of - Right v -> return v - Left err -> throwError (ArgumentError ("Could not parse [category/]package[-version]: " ++ show err)) - portdir <- getOverlayPath - overlay <- liftIO $ readPortageTree portdir - cache <- readCache portdir - let (indexTree,clashes) = indexToPortage cache overlay - mapM_ (liftIO . putStrLn) clashes - whisper $ "Searching for: "++ pstr - let pkgs = - Map.elems - . Map.filterWithKey (\(P _ pname') _ -> map toLower pname' == map toLower pname) - $ indexTree - return () - pkg <- case pkgs of - [] -> throwError (PackageNotFound pname) - [xs] -> case m_version of - Nothing -> return (maximum xs) -- highest version - Just v -> do - let ebuilds = filter (\e -> eVersion e == v) xs - case ebuilds of - [] -> throwError (PackageNotFound (pname ++ '-':show v)) - [e] -> return e - _ -> fail "the impossible happened" - _ -> fail "the impossible happened" - category <- do - case m_category of - Just cat -> return cat - Nothing -> do - case pCategory (ePackage pkg) of - "hackage" -> return "dev-haskell" - c -> return c - let Just genericDesc = ePkgDesc pkg - Right (desc, _) = finalizePackageDescription [] - (Nothing :: Maybe (PackageIndex PackageIdentifier)) - buildOS buildArch - (CompilerId GHC (Version [6,8,2] [])) - [] genericDesc - ebuild <- fixSrc (packageId desc) (E.cabal2ebuild desc) - liftIO $ do - putStrLn $ "Merging " ++ category ++ '/': pname ++ "-" ++ display (pkgVersion (packageId desc)) - putStrLn $ "Destination: " ++ portdir - mergeEbuild portdir category ebuild - where - parsePVC = parse readPVC "" pstr - readPVC = do - mc <- option Nothing $ try $ do - c <- readCat - char '/' - return (Just c) - (p, mv) <- readPkgAndVer - eof - return (mc, p, mv) +data ListFlags = ListFlags { + listVerbosity :: Flag Verbosity + -- , listOverlayPath :: Flag FilePath + -- , listServerURI :: Flag String + } -makeEbuild :: String -> HPAction () -makeEbuild cabalFileName = liftIO $ do +instance Monoid ListFlags where + mempty = ListFlags { + listVerbosity = mempty + -- , listOverlayPath = mempty + -- , listServerURI = mempty + } + mappend a b = ListFlags { + listVerbosity = combine listVerbosity + -- , listOverlayPath = combine listOverlayPath + -- , listServerURI = combine listServerURI + } + where combine field = field a `mappend` field b + +defaultListFlags :: ListFlags +defaultListFlags = ListFlags { + listVerbosity = Flag normal + -- , listOverlayPath = NoFlag + -- , listServerURI = Flag defaultHackageServerURI + } + +listCommand :: CommandUI ListFlags +listCommand = CommandUI { + commandName = "list", + commandSynopsis = "List packages", + commandDescription = Just $ \_pname -> + "TODO: this is the commandDescription for listCommand\n", + commandUsage = usagePackages "list", + commandDefaultFlags = defaultListFlags, + commandOptions = \_showOrParseArgs -> + [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) + {- + , option [] ["overlay"] + "Use cached packages list from specified overlay" + listOverlayPath (\v flags -> flags { listOverlayPath = v }) + (reqArgFlag "PATH") + -} + ] + } + +listAction :: ListFlags -> [String] -> GlobalFlags -> IO () +listAction flags extraArgs globalFlags = do + let verbosity = fromFlag (listVerbosity flags) + overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags) + let repo = defaultRepo overlayPath + index <- fmap packageIndex (Index.getAvailablePackages verbosity [ repo ]) + overlay <- Overlay.loadLazy overlayPath + let pkgs | null extraArgs = Index.allPackages index + | otherwise = concatMap (Index.searchByNameSubstring index) extraArgs + normalized = map (normalizeCabalPackageId . packageInfoId) pkgs + let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized + mapM_ (putStrLn . pretty) decorated + where + pretty :: (Bool, Cabal.PackageIdentifier) -> String + pretty (isInOverlay, pkgId) = + let dec | isInOverlay = " * " + | otherwise = " " + in dec ++ display pkgId + + +----------------------------------------------------------------------- +-- Make Ebuild +----------------------------------------------------------------------- + +data MakeEbuildFlags = MakeEbuildFlags { + makeEbuildVerbosity :: Flag Verbosity + } + +instance Monoid MakeEbuildFlags where + mempty = MakeEbuildFlags { + makeEbuildVerbosity = mempty + } + mappend a b = MakeEbuildFlags { + makeEbuildVerbosity = combine makeEbuildVerbosity + } + where combine field = field a `mappend` field b + +defaultMakeEbuildFlags :: MakeEbuildFlags +defaultMakeEbuildFlags = MakeEbuildFlags { + makeEbuildVerbosity = Flag normal + } + +makeEbuildAction :: MakeEbuildFlags -> [String] -> GlobalFlags -> IO () +makeEbuildAction flags args _globalFlags = do + when (null args) $ + die "make-ebuild needs at least one argument" + let _verbosity = fromFlag (makeEbuildVerbosity flags) + forM_ args $ \cabalFileName -> do pkg <- Cabal.readPackageDescription normal cabalFileName - let ebuild = cabal2ebuild (flattenPackageDescription pkg) - let ebuildFileName = name ebuild ++ "-" ++ version ebuild ++ ".ebuild" - writeFile ebuildFileName (showEBuild ebuild) + let ebuild = E.cabal2ebuild (flattenPackageDescription pkg) + let ebuildFileName = E.name ebuild ++ "-" ++ E.version ebuild ++ ".ebuild" + writeFile ebuildFileName (E.showEBuild ebuild) -hpmain :: HPAction () -hpmain = do - mode <- loadConfig - requestedUpdate <- fmap refreshCache getCfg - when requestedUpdate $ - case mode of - Update -> return () - _ -> updateCache - case mode of - ShowHelp -> liftIO hackageUsage - List pkg -> list pkg - Merge pkg -> merge pkg - DiffTree dtmode -> diffAction dtmode - Update -> updateCache - Status action -> statusAction action - MakeEbuild cabalFileName -> makeEbuild cabalFileName +makeEbuildCommand :: CommandUI MakeEbuildFlags +makeEbuildCommand = CommandUI { + commandName = "make-ebuild", + commandSynopsis = "Make an ebuild from a .cabal file", + commandDescription = Just $ \_pname -> + "TODO: this is the commandDescription for makeEbuildCommand\n", + commandUsage = \_ -> [], + commandDefaultFlags = defaultMakeEbuildFlags, + commandOptions = \_showOrParseArgs -> + [ optionVerbosity makeEbuildVerbosity (\v flags -> flags { makeEbuildVerbosity = v }) + ] + } +----------------------------------------------------------------------- +-- Diff +----------------------------------------------------------------------- + +data DiffFlags = DiffFlags { + -- diffMode :: Flag String, -- DiffMode, + diffVerbosity :: Flag Verbosity + -- , diffServerURI :: Flag String + } + +instance Monoid DiffFlags where + mempty = DiffFlags { + -- diffMode = mempty, + diffVerbosity = mempty + -- , diffServerURI = mempty + } + mappend a b = DiffFlags { + -- diffMode = combine diffMode, + diffVerbosity = combine diffVerbosity + -- , diffServerURI = combine diffServerURI + } + where combine field = field a `mappend` field b + +defaultDiffFlags :: DiffFlags +defaultDiffFlags = DiffFlags { + -- diffMode = Flag "all", + diffVerbosity = Flag normal + -- , diffServerURI = Flag defaultHackageServerURI + } + +diffCommand :: CommandUI DiffFlags +diffCommand = CommandUI { + commandName = "diff", + commandSynopsis = "Run diff", + commandDescription = Just $ \_pname -> + "TODO: this is the commandDescription for diffCommand\n", + commandUsage = usagePackages "diff", + commandDefaultFlags = defaultDiffFlags, + commandOptions = \_showOrParseArgs -> + [ optionVerbosity diffVerbosity (\v flags -> flags { diffVerbosity = v }) + {- + , option [] ["mode"] + "Diff mode, one of: all, newer, missing, additions, common" + diffMode (\v flags -> flags { diffMode = v }) + (reqArgFlag "MODE") -- I don't know how to map it strictly to DiffMode + -} + ] + } + +diffAction :: DiffFlags -> [String] -> GlobalFlags -> IO () +diffAction flags args globalFlags = do + let verbosity = fromFlag (diffVerbosity flags) + -- dm0 = fromFlag (diffMode flags) + dm <- case args of + [] -> return ShowAll + ["all"] -> return ShowAll + ["missing"] -> return ShowMissing + ["additions"] -> return ShowAdditions + ["newer"] -> return ShowNewer + ["common"] -> return ShowCommon + ("package": pkgs) -> return (ShowPackages pkgs) + -- TODO: ["package",packagePattern] -> + -- return ShowPackagePattern packagePattern + _ -> die $ "Unknown mode: " ++ unwords args + overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags) + let repo = defaultRepo overlayPath + runDiff verbosity overlayPath dm repo + +----------------------------------------------------------------------- +-- Update +----------------------------------------------------------------------- + +data UpdateFlags = UpdateFlags { + updateVerbosity :: Flag Verbosity + -- , updateServerURI :: Flag String + } + +instance Monoid UpdateFlags where + mempty = UpdateFlags { + updateVerbosity = mempty + -- , updateServerURI = mempty + } + mappend a b = UpdateFlags { + updateVerbosity = combine updateVerbosity + -- , updateServerURI = combine updateServerURI + } + where combine field = field a `mappend` field b + +defaultUpdateFlags :: UpdateFlags +defaultUpdateFlags = UpdateFlags { + updateVerbosity = Flag normal + -- , updateServerURI = Flag defaultHackageServerURI + } + +updateCommand :: CommandUI UpdateFlags +updateCommand = CommandUI { + commandName = "update", + commandSynopsis = "Update the local cache", + commandDescription = Just $ \_pname -> + "TODO: this is the commandDescription for updateCommand\n", + commandUsage = usageFlags "update", + commandDefaultFlags = defaultUpdateFlags, + commandOptions = \_ -> + [ optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v }) + + {- + , option [] ["server"] + "Set the server you'd like to update the cache from" + updateServerURI (\v flags -> flags { updateServerURI = v} ) + (reqArgFlag "SERVER") + -} + ] + } + +updateAction :: UpdateFlags -> [String] -> GlobalFlags -> IO () +updateAction flags extraArgs globalFlags = do + unless (null extraArgs) $ + die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs + let verbosity = fromFlag (updateVerbosity flags) + overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags) + update verbosity [ defaultRepo overlayPath ] + + +----------------------------------------------------------------------- +-- Status +----------------------------------------------------------------------- + +data StatusFlags = StatusFlags { + statusVerbosity :: Flag Verbosity, + statusToPortage :: Flag Bool + } + +instance Monoid StatusFlags where + mempty = StatusFlags { + statusVerbosity = mempty, + statusToPortage = mempty + } + mappend a b = StatusFlags { + statusVerbosity = combine statusVerbosity, + statusToPortage = combine statusToPortage + } + where combine field = field a `mappend` field b + +defaultStatusFlags :: StatusFlags +defaultStatusFlags = StatusFlags { + statusVerbosity = Flag normal, + statusToPortage = Flag False + } + +statusCommand :: CommandUI StatusFlags +statusCommand = CommandUI { + commandName = "status", + commandSynopsis = "Show status(??)", + commandDescription = Just $ \_pname -> + "TODO: this is the commandDescription for statusCommand\n", + commandUsage = usagePackages "status", + commandDefaultFlags = defaultStatusFlags, + commandOptions = \_ -> + [ optionVerbosity statusVerbosity (\v flags -> flags { statusVerbosity = v }) + , option [] ["to-portage"] + "Print only packages likely to be interesting to move to the portage tree." + statusToPortage (\v flags -> flags { statusToPortage = v }) + trueArg + ] + } + +statusAction :: StatusFlags -> [String] -> GlobalFlags -> IO () +statusAction flags args globalFlags = do + let verbosity = fromFlag (statusVerbosity flags) + toPortdir = fromFlag (statusToPortage flags) + portagePath <- getPortageDir verbosity globalFlags + overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags) + runStatus verbosity portagePath overlayPath toPortdir args + +----------------------------------------------------------------------- +-- Merge +----------------------------------------------------------------------- + +data MergeFlags = MergeFlags { + mergeVerbosity :: Flag Verbosity + -- , mergeServerURI :: Flag String + } + +instance Monoid MergeFlags where + mempty = MergeFlags { + mergeVerbosity = mempty + -- , mergeServerURI = mempty + } + mappend a b = MergeFlags { + mergeVerbosity = combine mergeVerbosity + -- , mergeServerURI = combine mergeServerURI + } + where combine field = field a `mappend` field b + +defaultMergeFlags :: MergeFlags +defaultMergeFlags = MergeFlags { + mergeVerbosity = Flag normal + -- , mergeServerURI = Flag defaultHackageServerURI + } + +mergeCommand :: CommandUI MergeFlags +mergeCommand = CommandUI { + commandName = "merge", + commandSynopsis = "Make an ebuild out of hackage package", + commandDescription = Just $ \_pname -> + "TODO: this is the commandDescription for mergeCommand\n", + commandUsage = usagePackages "merge", + commandDefaultFlags = defaultMergeFlags, + commandOptions = \_showOrParseArgs -> + [ optionVerbosity mergeVerbosity (\v flags -> flags { mergeVerbosity = v }) + + {- + , option [] ["server"] + "Set the server you'd like to update the cache from" + mergeServerURI (\v flags -> flags { mergeServerURI = v} ) + (reqArgFlag "SERVER") + -} + ] + } + +mergeAction :: MergeFlags -> [String] -> GlobalFlags -> IO () +mergeAction flags extraArgs globalFlags = do + let verbosity = fromFlag (mergeVerbosity flags) + overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags) + let repo = defaultRepo overlayPath + merge verbosity repo (defaultRepoURI overlayPath) extraArgs overlayPath + +----------------------------------------------------------------------- +-- DistroMap +----------------------------------------------------------------------- + +data DistroMapFlags = DistroMapFlags { + distroMapVerbosity :: Flag Verbosity + } + +instance Monoid DistroMapFlags where + mempty = DistroMapFlags { + distroMapVerbosity = mempty + -- , mergeServerURI = mempty + } + mappend a b = DistroMapFlags { + distroMapVerbosity = combine distroMapVerbosity + } + where combine field = field a `mappend` field b + +defaultDistroMapFlags :: DistroMapFlags +defaultDistroMapFlags = DistroMapFlags { + distroMapVerbosity = Flag normal + } + +distroMapCommand :: CommandUI DistroMapFlags +distroMapCommand = CommandUI { + commandName = "distromap", + commandSynopsis = "Build a distromap file", + commandDescription = Just $ \_pname -> + "TODO: this is the commandDescription for distroMapCommand\n", + commandUsage = usagePackages "distromap", + commandDefaultFlags = defaultDistroMapFlags, + commandOptions = \_showOrParseArgs -> + [ optionVerbosity distroMapVerbosity (\v flags -> flags { distroMapVerbosity = v }) + ] + } + +distroMapAction :: DistroMapFlags-> [String] -> GlobalFlags -> IO () +distroMapAction flags extraArgs globalFlags = do + let verbosity = fromFlag (distroMapVerbosity flags) + overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags) + let repo = defaultRepo overlayPath + portagePath <- getPortageDir verbosity globalFlags + distroMap verbosity repo portagePath overlayPath extraArgs + +----------------------------------------------------------------------- +-- Utils +----------------------------------------------------------------------- + +defaultRepo :: FilePath -> Repo +defaultRepo overlayPath = + Repo { + repoKind = Left hackage, + repoLocalDir = overlayPath ".hackport" + } + where + hackage = RemoteRepo server_name uri + server_name = "hackage.haskell.org" + uri = URI "http:" (Just (URIAuth "" server_name "")) "/packages/archive" "" "" + +defaultRepoURI :: FilePath -> URI +defaultRepoURI overlayPath = + case repoKind (defaultRepo overlayPath) of + Left (RemoteRepo { remoteRepoURI = uri }) -> uri + Right _ -> error $ "defaultRepoURI: unable to get URI for " ++ overlayPath + +getServerURI :: String -> IO URI +getServerURI str = + case parseURI str of + Just uri -> return uri + Nothing -> throwEx (InvalidServer str) + +reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> + (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +usagePackages :: String -> String -> String +usagePackages op_name pname = + "Usage: " ++ pname ++ " " ++ op_name ++ " [FLAGS] [PACKAGE]\n\n" + ++ "Flags for " ++ op_name ++ ":" + +usageFlags :: String -> String -> String +usageFlags flag_name pname = + "Usage: " ++ pname ++ " " ++ flag_name ++ " [FLAGS]\n\n" + ++ "Flags for " ++ flag_name ++ ":" + +getPortageDir :: Verbosity -> GlobalFlags -> IO FilePath +getPortageDir verbosity globalFlags = do + let portagePathM = fromFlag (globalPathToPortage globalFlags) + portagePath <- case portagePathM of + Nothing -> Host.portage_dir <$> Host.getInfo + Just path -> return path + exists <- doesDirectoryExist $ portagePath "dev-haskell" + when (not exists) $ + warn verbosity $ "Looks like an invalid portage directory: " ++ portagePath + return portagePath + +----------------------------------------------------------------------- +-- Main +----------------------------------------------------------------------- + +data GlobalFlags = + GlobalFlags { globalVersion :: Flag Bool + , globalNumericVersion :: Flag Bool + , globalPathToOverlay :: Flag (Maybe FilePath) + , globalPathToPortage :: Flag (Maybe FilePath) + } + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = + GlobalFlags { globalVersion = Flag False + , globalNumericVersion = Flag False + , globalPathToOverlay = Flag Nothing + , globalPathToPortage = Flag Nothing + } + +globalCommand :: CommandUI GlobalFlags +globalCommand = CommandUI { + commandName = "", + commandSynopsis = "", + commandDescription = Just $ \_pname -> + "TODO: this is the commandDescription for globalCommand\n", + commandUsage = \_ -> [], + commandDefaultFlags = defaultGlobalFlags, + commandOptions = \_showOrParseArgs -> + [ option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + , option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + , option ['p'] ["overlay-path"] + "Override search path list where .hackport/ lives (default list: ['.', paludis-ovls or emerge-ovls])" + globalPathToOverlay (\ovrl_path flags -> flags { globalPathToOverlay = ovrl_path }) + (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms])) + , option [] ["portage-path"] + "Override path to your portage tree" + globalPathToPortage (\port_path flags -> flags { globalPathToPortage = port_path }) + (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms])) + ] + } + +mainWorker :: [String] -> IO () +mainWorker args = + case commandsRun globalCommand commands args of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalflags, commandParse) -> do + case commandParse of + _ | fromFlag (globalVersion globalflags) -> printVersion + | fromFlag (globalNumericVersion globalflags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> catchEx (action globalflags) errorHandler + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (concat (intersperse "\n" errs)) + exitFailure + printNumericVersion = putStrLn $ display Paths_hackport.version + printVersion = putStrLn $ "hackport version " + ++ display Paths_hackport.version + ++ "\nusing cabal-install " + ++ display Paths_cabal_install.version + ++ " and the Cabal library version " + ++ display cabalVersion + errorHandler :: HackPortError -> IO () + errorHandler e = do + putStrLn (hackPortShowError e) + commands = + [ listCommand `commandAddAction` listAction + , makeEbuildCommand `commandAddAction` makeEbuildAction + , statusCommand `commandAddAction` statusAction + , diffCommand `commandAddAction` diffAction + , updateCommand `commandAddAction` updateAction + , mergeCommand `commandAddAction` mergeAction + , distroMapCommand `commandAddAction` distroMapAction + ] + main :: IO () -main = do - res <- performHPAction hpmain - case res of - Right _ -> return () - Left err -> do - hPutStrLn stderr "An error occurred. To get more info run with --verbosity=debug" - hPutStrLn stderr (hackPortShowError err) +main = getArgs >>= mainWorker diff --git a/Merge.hs b/Merge.hs new file mode 100644 --- /dev/null +++ b/Merge.hs @@ -0,0 +1,378 @@ +{-# OPTIONS -XPatternGuards #-} +{- | Merge a package from hackage to an ebuild. + +Merging a library +================= + +Compile time: + ghc + cabal + build tools + deps (haskell dependencies) + extra-libs (c-libs) + +Run time: + ghc + deps (haskell dependencies) + extra-libs (c-libs) + +RDEPEND="ghc ${DEPS} ${EXTRALIBS}" +DEPEND="${RDEPEND} cabal ${BUILDTOOLS}" + +Merging an executable +===================== +Packages with both executable and library must be treated as libraries, as it will impose a stricter DEPEND. + +Compile time: + ghc + cabal + build tools + deps + extra-libs (c-libs) + +Run time: + extra-libs (c-libs) + +RDEPEND="${EXTRALIBS}" +DEPEND="${RDEPEND} ghc cabal ${DEPS} ${BUILDTOOLS}" + +-} +module Merge + ( merge ) where + +import Control.Monad.Error +import Control.Exception +import Data.Maybe +import Data.List +import Distribution.Package +import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC)) +import Distribution.PackageDescription ( PackageDescription(..) + , FlagName(..) + , libBuildInfo + , buildInfo + , buildable + , extraLibs + , buildTools + , hasLibs ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Text (display) + +import System.Directory ( getCurrentDirectory + , setCurrentDirectory + , createDirectoryIfMissing + ) +import System.Cmd (system) +import System.FilePath (()) + +import qualified Cabal2Ebuild as E +import Cabal2Ebuild +import Error as E + +import qualified Distribution.Package as Cabal +import qualified Distribution.Version as Cabal + +import Distribution.System (buildPlatform) +import Distribution.Verbosity +import Distribution.Simple.Utils + +import Network.URI + +import Distribution.Client.IndexUtils ( getAvailablePackages ) +import Distribution.Client.HttpUtils ( downloadURI ) +import qualified Distribution.Client.PackageIndex as Index +import Distribution.Client.Types + +import qualified Portage.PackageId as Portage +import qualified Portage.Version as Portage +import qualified Portage.Dependency as Portage +import qualified Portage.Host as Host +import qualified Portage.Overlay as Overlay +import qualified Portage.Resolve as Portage + +import Debug.Trace ( trace ) + +(<->) :: String -> String -> String +a <-> b = a ++ '-':b + +(<.>) :: String -> String -> String +a <.> b = a ++ '.':b + +{- +Requested features: + * Copy the old keywords and ~arch them + * Add files to darcs? + * Print diff with the next latest version? +BUGS: + * Dependencies are always expected to be in dev-haskell +-} + +readPackageString :: [String] + -> Either HackPortError ( Maybe Portage.Category + , Cabal.PackageName + , Maybe Portage.Version + ) +readPackageString args = do + packageString <- + case args of + [] -> Left (ArgumentError "Need an argument, [category/]package[-version]") + [pkg] -> return pkg + _ -> Left (ArgumentError ("Too many arguments: " ++ unwords args)) + case Portage.parseFriendlyPackage packageString of + Just v@(_,_,Nothing) -> return v + -- we only allow versions we can convert into cabal versions + Just v@(_,_,Just (Portage.Version _ Nothing [] 0)) -> return v + _ -> Left (ArgumentError ("Could not parse [category/]package[-version]: " ++ packageString)) + + + +-- | Given a list of available packages, and maybe a preferred version, +-- return the available package with that version. Latest version is chosen +-- if no preference. +resolveVersion :: [AvailablePackage] -> Maybe Cabal.Version -> Maybe AvailablePackage +resolveVersion avails Nothing = Just $ maximumBy (comparing packageInfoId) avails +resolveVersion avails (Just ver) = listToMaybe (filter match avails) + where + match avail = ver == pkgVersion (packageInfoId avail) + +merge :: Verbosity -> Repo -> URI -> [String] -> FilePath -> IO () +merge verbosity repo serverURI args overlayPath = do + (m_category, user_pName, m_version) <- + case readPackageString args of + Left err -> throwEx err + Right (c,p,m_v) -> + case m_v of + Nothing -> return (c,p,Nothing) + Just v -> case Portage.toCabalVersion v of + Nothing -> throwEx (ArgumentError "illegal version") + Just ver -> return (c,p,Just ver) + + debug verbosity $ "Category: " ++ show m_category + debug verbosity $ "Package: " ++ show user_pName + debug verbosity $ "Version: " ++ show m_version + + let (Cabal.PackageName user_pname_str) = user_pName + + overlay <- Overlay.loadLazy overlayPath + portage_path <- Host.portage_dir `fmap` Host.getInfo + portage <- Overlay.loadLazy portage_path + index <- fmap packageIndex $ getAvailablePackages verbosity [ repo ] + + -- find all packages that maches the user specified package name + availablePkgs <- + case Index.searchByName index user_pname_str of + Index.None -> throwEx (PackageNotFound user_pname_str) + Index.Ambiguous pkgs -> throwEx (ArgumentError ("Ambiguous name: " ++ unwords (map show pkgs))) + Index.Unambiguous pkg -> return pkg + + -- select a single package taking into account the user specified version + selectedPkg <- + case resolveVersion availablePkgs m_version of + Nothing -> do + putStrLn "No such version for that package, available versions:" + forM_ availablePkgs $ \ avail -> + putStrLn (display . packageInfoId $ avail) + throwEx (ArgumentError "no such version for that package") + Just avail -> return avail + + -- print some info + info verbosity "Selecting package:" + forM_ availablePkgs $ \ avail -> do + let match_text | packageInfoId avail == packageInfoId selectedPkg = "* " + | otherwise = "- " + info verbosity $ match_text ++ (display . packageInfoId $ avail) + + let cabal_pkgId = packageInfoId selectedPkg + norm_pkgId = Portage.normalizeCabalPackageId cabal_pkgId + norm_pkgName = packageName norm_pkgId + cat <- Portage.resolveCategory verbosity overlay norm_pkgName + + let pkgGenericDesc = packageDescription selectedPkg + Right (pkgDesc0, flags) = + finalizePackageDescription + [ -- XXX: common things we should enable/disable? + -- (FlagName "small_base", True) -- try to use small base + (FlagName "cocoa", False) + ] + (\dep -> trace ("accepting dep(?): " ++ display dep) True) + -- (Nothing :: Maybe (Index.PackageIndex PackageIdentifier)) + buildPlatform + (CompilerId GHC (Cabal.Version [6,10,4] [])) + [] pkgGenericDesc + pkgDesc = let deps = [ Dependency pn (Cabal.simplifyVersionRange vr) + | Dependency pn vr <- buildDepends pkgDesc0 + ] + in pkgDesc0 { buildDepends = deps } + + hasBuildableExes p = + any (buildable . buildInfo) + . executables $ p + treatAsLibrary = (not . hasBuildableExes) pkgDesc && hasLibs pkgDesc + + -- calculate build tools + bt = [ pkg' -- TODO: currently ignoring version range + | Cabal.Dependency (Cabal.PackageName pkg ) _range <- buildToolsDeps pkgDesc + , Just pkg' <- return (lookup pkg buildToolsTable) + ] + + packageNameResolver s = do + (Portage.PackageName (Portage.Category p_cat) (Cabal.PackageName pn)) + <- Portage.resolveFullPortageName portage (Cabal.PackageName s) + return $ E.AnyVersionOf (p_cat pn) + + -- calculate extra-libs + extra <- findCLibs verbosity packageNameResolver pkgDesc + + debug verbosity ("Selected flags: " ++ show flags) + debug verbosity ("extra-libs: ") + mapM_ (debug verbosity . show) extra + + debug verbosity ("build-tools:") + mapM_ (debug verbosity . show) bt + + -- debug verbosity ("Finalized package:\n" ++ showPackageDescription pkgDesc) + + -- TODO: more fixes + -- * inherit keywords from previous ebuilds + let d e = if treatAsLibrary + then Portage.showDepend (cabal_dep e) + : "${RDEPEND}" + : [ "${BUILDTOOLS}" | not . null $ build_tools e ] + else Portage.showDepend (cabal_dep e) + : Portage.showDepend (ghc_dep e) + : "${RDEPEND}" + : [ "${BUILDTOOLS}" | not . null $ build_tools e ] + ++ [ "${HASKELLDEPS}" | not . null $ haskell_deps e ] + rd e = if treatAsLibrary + then Portage.showDepend (ghc_dep e) + : [ "${HASKELLDEPS}" | not . null $ haskell_deps e ] + ++ [ "${EXTRALIBS}" | not . null $ extra_libs e ] + else [ "${EXTRALIBS}" | not . null $ extra_libs e ] + let ebuild = fixSrc serverURI (packageId pkgDesc) + . (\e -> e { depend = d e } ) + . (\e -> e { rdepend = rd e } ) + . (\e -> e { extra_libs = extra_libs e ++ extra } ) + . (\e -> e { build_tools = build_tools e ++ bt } ) + $ E.cabal2ebuild pkgDesc + + debug verbosity ("Treat as library: " ++ show treatAsLibrary) + mergeEbuild verbosity overlayPath (Portage.unCategory cat) ebuild + fetchAndDigest + verbosity + (overlayPath display cat display norm_pkgName) + (display cabal_pkgId <.> "tar.gz") + (mkUri cabal_pkgId) + +findCLibs :: Verbosity -> (String -> Maybe E.Dependency) -> PackageDescription -> IO [E.Dependency] +findCLibs verbosity portageResolver (PackageDescription { library = lib, executables = exes }) = do + debug verbosity "Mapping extra-libraries into portage packages..." + -- for extra libs we don't find, maybe look into into installed packages? + when (not . null $ notFound) $ + warn verbosity ("Could not find portage packages for extra-libraries: " ++ unwords notFound) + when (not . null $ found) $ + debug verbosity ("Found c-libraries deps: " ++ show found) + return found + where + resolvers = [ staticTranslateExtraLib, portageResolver ] + + resolved = [ chain p resolvers + | p <- libE ++ exeE + ] :: [Either String E.Dependency] + + notFound = [ p | Left p <- resolved ] + found = [ p | Right p <- resolved ] + + chain v [] = Left v + chain v (f:fs) = case f v of + Nothing -> chain v fs + Just x -> Right x + + libE = maybe [] (extraLibs.libBuildInfo) lib + exeE = concatMap (extraLibs.buildInfo) exes + +staticTranslateExtraLib :: String -> Maybe E.Dependency +staticTranslateExtraLib lib = lookup lib m + where + m = [ ("z", E.AnyVersionOf "sys-libs/zlib") + , ("bz2", E.AnyVersionOf "sys-libs/bzlib") + , ("mysqlclient", E.LaterVersionOf (Portage.Version [4,0] Nothing [] 0) "virtual/mysql") + , ("pq", E.LaterVersionOf (Portage.Version [7] Nothing [] 0) "virtual/postgresql-base") + , ("ev", E.AnyVersionOf "dev-libs/libev") + ] + +buildToolsDeps :: PackageDescription -> [Cabal.Dependency] +buildToolsDeps (PackageDescription { library = lib, executables = exes }) = cabalDeps + where + cabalDeps = depL ++ depE + depL = maybe [] (buildTools.libBuildInfo) lib + depE = concatMap (buildTools.buildInfo) exes + +buildToolsTable :: [(String, E.Dependency)] +buildToolsTable = + [ ("happy", E.AnyVersionOf "dev-haskell/happy") + , ("alex", E.AnyVersionOf "dev-haskell/alex") + , ("c2hs", E.AnyVersionOf "dev-haskell/c2hs") + ] + +mkUri :: Cabal.PackageIdentifier -> URI +mkUri pid = + -- example: + -- http://hackage.haskell.org/packages/archive/Cabal/1.4.0.2/Cabal-1.4.0.2.tar.gz + fromJust $ parseURI $ + "http://hackage.haskell.org/packages/archive/" + p_name p_ver p_name <-> p_ver <.> "tar.gz" + where + p_ver = display (packageVersion pid) + p_name = display (packageName pid) + +fetchAndDigest :: Verbosity + -> FilePath -- ^ directory of ebuild + -> String -- ^ tarball name + -> URI -- ^ tarball uri + -> IO () +fetchAndDigest verbosity ebuildDir tarballName tarballURI = + withWorkingDirectory ebuildDir $ do + repo_info <- Host.getInfo + let tarDestination = (Host.distfiles_dir repo_info) tarballName + downloadURI verbosity tarballURI tarDestination + -- Just err -> throwEx (E.DownloadFailed (show tarballURI) (show err)) + -- TODO: downloadURI will throw a non-hackport exception if the + -- download fails + notice verbosity $ "Saved to " ++ tarDestination + notice verbosity "Recalculating digests..." + _ <- system "repoman manifest" + return () + +withWorkingDirectory :: FilePath -> IO a -> IO a +withWorkingDirectory newDir action = do + oldDir <- getCurrentDirectory + bracket + (setCurrentDirectory newDir) + (\_ -> setCurrentDirectory oldDir) + (\_ -> action) + +mergeEbuild :: Verbosity -> FilePath -> String -> EBuild -> IO () +mergeEbuild verbosity target cat ebuild = do + let edir = target cat name ebuild + elocal = name ebuild ++"-"++ version ebuild <.> "ebuild" + epath = edir elocal + createDirectoryIfMissing True edir + info verbosity $ "Writing " ++ elocal + writeFile epath (showEBuild ebuild) + +fixSrc :: URI -> PackageIdentifier -> EBuild -> EBuild +fixSrc serverURI p ebuild = + ebuild { + src_uri = show $ serverURI { + uriPath = + uriPath serverURI + display (pkgName p) + display (pkgVersion p) + display (pkgName p) ++ "-" ++ display (pkgVersion p) + <.> "tar.gz" + }, + E.homepage = case E.homepage ebuild of + "" -> "http://hackage.haskell.org/cgi-bin/hackage-scripts/package/" + ++ display (pkgName p) + x -> x + } diff --git a/Overlays.hs b/Overlays.hs --- a/Overlays.hs +++ b/Overlays.hs @@ -1,59 +1,71 @@ -module Overlays where +module Overlays + ( getOverlayPath + ) where -import Control.Monad.Error +import Control.Monad +import Data.List (nub, inits) +import Data.Maybe (maybeToList, listToMaybe, isJust, fromJust) import System.Directory -import Data.Maybe -import Data.List (nub) +import System.FilePath ((), splitPath, joinPath) -import Bash -import Action -import Config import Error import CacheFile +import Portage.Host -getOverlayPath :: HPAction String -getOverlayPath = do - cfg <- getCfg - case overlayPath cfg of - Nothing -> do - tree <- getOverlay `sayDebug` ("Guessing overlay...\n",\tree->"Found '"++tree++"'") - setOverlayPath $ Just tree - return tree - Just tree -> return tree +-- cabal +import Distribution.Verbosity +import Distribution.Simple.Utils ( info ) -getOverlay :: HPAction String -getOverlay = do - overlays <- getOverlays - case overlays of - [] -> throwError NoOverlay - [x] -> return x - mul -> search mul +getOverlayPath :: Verbosity -> Maybe FilePath -> IO String +getOverlayPath verbosity override_overlay = do + overlays <- if isJust override_overlay + then do info verbosity $ "Forced " ++ fromJust override_overlay + return [fromJust override_overlay] + else getOverlays + case overlays of + [] -> throwEx NoOverlay + [x] -> return x + mul -> search mul where - search :: [String] -> HPAction String + search :: [String] -> IO String search mul = do - let loop [] = throwError $ MultipleOverlays mul - loop (x:xs) = (do - found <- liftIO (doesFileExist (cacheFile x)) - `sayDebug` ("Checking '"++x++"'...\n",\res->if res then "found.\n" else "not found.") + let loop [] = throwEx (MultipleOverlays mul) + loop (x:xs) = do + info verbosity $ "Checking '" ++ x ++ "'..." + found <- doesFileExist (cacheFile x) if found - then return x - else loop xs) - whisper "There are several overlays in your /etc/make.conf" - mapM (\x-> whisper (" * " ++x)) mul - whisper "Looking for one with a HackPort cache..." + then do + info verbosity "OK!" + return x + else do + info verbosity "Not ok." + loop xs + info verbosity "There are several overlays in your configuration." + mapM_ (info verbosity . (" * " ++)) mul + info verbosity "Looking for one with a HackPort cache..." overlay <- loop mul - whisper ("I choose " ++ overlay) - whisper "Override my decision with hackport -p /my/overlay" + info verbosity $ "I choose " ++ overlay + info verbosity "Override my decision with hackport --overlay /my/overlay" return overlay -portageOverlays :: HPAction [String] -portageOverlays = runBash "source /etc/make.conf;echo -n $PORTDIR_OVERLAY" >>= (return.words) +getOverlays :: IO [String] +getOverlays = do + local <- getLocalOverlay + overlays <- overlay_list `fmap` getInfo + return $ nub $ map clean $ + maybeToList local + ++ overlays + where + clean path = case reverse path of + '/':p -> reverse p + _ -> path -paludisOverlays :: HPAction [String] -paludisOverlays = return [] +getLocalOverlay :: IO (Maybe FilePath) +getLocalOverlay = do + curDir <- getCurrentDirectory + let lookIn = map joinPath . reverse . inits . splitPath $ curDir + fmap listToMaybe (filterM probe lookIn) -getOverlays :: HPAction [String] -getOverlays = do - portage <- portageOverlays - paludis <- paludisOverlays - return (nub (portage ++ paludis)) + where + probe dir = doesDirectoryExist (dir "dev-haskell") + diff --git a/P2.hs b/P2.hs --- a/P2.hs +++ b/P2.hs @@ -13,23 +13,23 @@ import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe import qualified Data.List as List import System.Directory -import System.IO import System.FilePath import Text.Regex -import Version +import qualified Portage.Version as Portage +import Distribution.Text + type Portage = PortageMap [Ebuild] type PortageMap a = Map Package a data Ebuild = Ebuild { ePackage :: Package, - eVersion :: Version, + eVersion :: Portage.Version, eFilePath :: FilePath, ePkgDesc :: Maybe Cabal.GenericPackageDescription } deriving (Show) @@ -77,12 +77,10 @@ | (Just v, fn) <- map ((filterVersion package) &&& id) files ] return (map (uncurry (\v f -> Ebuild (P category package) v f Nothing)) ebuilds) - filterVersion :: String -> String -> Maybe Version + filterVersion :: String -> String -> Maybe Portage.Version filterVersion p fn = do [vstring] <- matchRegex (ebuildVersionRegex p) fn - case (parseVersion vstring) of - Left e -> fail (show e) - Right v -> return v + simpleParse vstring ebuildVersionRegex name = mkRegex ("^"++name++"-(.*)\\.ebuild$") diff --git a/Package.hs b/Package.hs deleted file mode 100644 --- a/Package.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-| - Maintainer : Andres Loeh - Stability : provisional - Portability : haskell98 - - Parser for categories and packages. - - Shamelessly borrowed from exi, somewhat modified --} - -module Package - where - -import Control.Monad -import Text.ParserCombinators.Parsec - -import Version - -type Category = String -type Package = String -type Slot = String - -getPV :: String -> (Category, Package, Version) -getPV xs = case parsePV xs of - Left e -> - error $ "getPV: cat/pkg-ver parse error '" ++ xs ++ "'\n" ++ show e - Right x -> x - -getP :: String -> (Category, Package) -getP xs = case parseP xs of - Left e -> - error $ "getCatPkg: cat/pkg parse error '" ++ xs ++ "'\n" ++ show e - Right x -> x - -parsePV :: String -> Either ParseError (Category, Package, Version) -parsePV = parse (readPV >>= \x -> eof >> return x) "" - -readPV :: GenParser Char st (Category, Package, Version) -readPV = do cat <- readCat - char '/' - (pkg,mver) <- readPkgAndVer - case mver of - Nothing -> fail "readPV: version expected" - Just ver -> return (cat, pkg, ver) - -parseP :: String -> Either ParseError (Category, Package) -parseP = parse (readP >>= \x -> eof >> return x) "" - -readP :: GenParser Char st (Category, Package) -readP = do cat <- readCat - char '/' - (pkg,mver) <- readPkgAndVer - case mver of - Nothing -> return (cat, pkg) - Just _ -> error "readCatPkg: unexpected version" - -readCat :: CharParser st Category -readPkgAndVer :: CharParser st (Package,Maybe Version) - -readCat = many1 (letter <|> digit <|> oneOf "_-") -readPkgAndVer = do pre <- many1 (letter <|> digit <|> oneOf "_+") - (p,v) <- option ("",Nothing) - (do char '-' - liftM (\v -> ("",Just v)) readVerOrFail - <|> liftM (\(p,v) -> ('-':p,v)) readPkgAndVer - ) - return (pre ++ p,v) - -readVerOrFail :: CharParser st Version -readVerOrFail = try $ - do ver <- many1 (letter <|> digit <|> oneOf "_+.-") - case parseVersion ver of - Left _ -> - fail $ "version parse error" - Right x -> return x - diff --git a/Portage/Cabal.hs b/Portage/Cabal.hs new file mode 100644 --- /dev/null +++ b/Portage/Cabal.hs @@ -0,0 +1,15 @@ +module Portage.Cabal + (fromOverlay) where + +import qualified Data.Map as Map + +import qualified Distribution.Client.PackageIndex as Cabal + +import qualified Portage.Overlay as Portage + +fromOverlay :: Portage.Overlay -> Cabal.PackageIndex Portage.ExistingEbuild +fromOverlay overlay = Cabal.fromList $ + [ ebuild + | (_pn, ebuilds) <- Map.toAscList (Portage.overlayMap overlay) + , ebuild <- ebuilds + ] diff --git a/Portage/Dependency.hs b/Portage/Dependency.hs new file mode 100644 --- /dev/null +++ b/Portage/Dependency.hs @@ -0,0 +1,145 @@ +module Portage.Dependency ( + Dependency(..), + showDepend, + simplify_deps + ) where + +import Portage.Version +import Distribution.Text (display) + +import Data.Maybe ( fromJust, catMaybes ) +import Data.List ( nub, groupBy, partition, sortBy ) +import Data.Ord (comparing) + +type Package = String +type UseFlag = String + +data Dependency = AnyVersionOf Package + | ThisVersionOf Version Package -- =package-version + | LaterVersionOf Version Package -- >package-version + | EarlierVersionOf Version Package -- =package-version + | OrEarlierVersionOf Version Package -- <=package-version + | DependEither Dependency Dependency -- depend || depend + | DependIfUse UseFlag Dependency -- use? ( depend ) + | ThisMajorOf Version Package -- =package-version* + deriving (Eq,Show) + +showDepend :: Dependency -> Package +showDepend (AnyVersionOf p) = p +showDepend (ThisVersionOf v p) = "~" ++ p ++ "-" ++ display v +showDepend (LaterVersionOf v p) = ">" ++ p ++ "-" ++ display v +showDepend (EarlierVersionOf v p) = "<" ++ p ++ "-" ++ display v +showDepend (OrLaterVersionOf v p) = ">=" ++ p ++ "-" ++ display v +showDepend (OrEarlierVersionOf v p) = "<=" ++ p ++ "-" ++ display v +showDepend (DependEither dep1 dep2) = showDepend dep1 + ++ " || " ++ showDepend dep2 +showDepend (DependIfUse useflag dep@(DependEither _ _)) + = useflag ++ "? " ++ showDepend dep +showDepend (DependIfUse useflag dep) = useflag ++ "? ( " ++ showDepend dep++ " )" +showDepend (ThisMajorOf v p) = "=" ++ p ++ "-" ++ display v ++ "*" + +{- Here goes code for dependencies simplification -} + +simplify_group_table :: Package -> + Maybe Version -> + Maybe Version -> + Maybe Version -> + Maybe Version -> + Maybe Version -> [Dependency] + +-- simplify_group_table p ol l e oe exact +-- 1) trivial cases: +simplify_group_table p Nothing Nothing Nothing Nothing Nothing = error $ p ++ ": unsolvable constraints" +simplify_group_table p (Just v) Nothing Nothing Nothing Nothing = [OrLaterVersionOf v p] +simplify_group_table p Nothing (Just v) Nothing Nothing Nothing = [LaterVersionOf v p] +simplify_group_table p Nothing Nothing (Just v) Nothing Nothing = [EarlierVersionOf v p] +simplify_group_table p Nothing Nothing Nothing (Just v) Nothing = [OrEarlierVersionOf v p] +simplify_group_table p Nothing Nothing Nothing Nothing (Just v) = [ThisVersionOf v p] + +-- 2) simplification passes +simplify_group_table p (Just (Version v1 _ _ _)) Nothing (Just (Version v2 _ _ _)) Nothing Nothing + -- special case: >=a-v.N a =a-v.N* + | (init v1 == init v2) && (last v2 == last v1 + 1) = [ThisMajorOf (Version v1 Nothing [] 0) p] + | otherwise = [OrLaterVersionOf (Version v1 Nothing [] 0) p, EarlierVersionOf (Version v2 Nothing [] 0) p] + +-- TODO: simplify constraints of type: >=a-v1; > a-v2 and such + +-- o3) therwise sink: +simplify_group_table p (Just v) l@(_) e@(_) oe@(_) exact@(_) = OrLaterVersionOf v p : simplify_group_table p Nothing l e oe exact +simplify_group_table p ol@(Nothing) (Just v) e@(_) oe@(_) exact@(_) = LaterVersionOf v p : simplify_group_table p ol Nothing e oe exact +simplify_group_table p ol@(Nothing) l@(Nothing) (Just v) oe@(_) exact@(_) = EarlierVersionOf v p : simplify_group_table p ol l Nothing oe exact +simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) (Just v) exact@(_) = OrEarlierVersionOf v p : simplify_group_table p ol l e Nothing exact +-- already defined earlier +-- simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) oe@(Nothing) (Just v) = OrEarlierVersionOf v p : simplify_group_table p ol l e oe Nothing + +-- >a-v1 >a-v2 => >a-(max v1 v2) +-- key idea: all constraints are enforcing constraints, so we can't get +-- more, than one interval. +simplify_group :: [Dependency] -> [Dependency] +simplify_group [dep@(AnyVersionOf _package)] = [dep] +simplify_group [dep@(ThisMajorOf _v _p)] = [dep] +simplify_group deps = simplify_group_table package + min_or_later_v -- >= + min_later_v -- > + max_earlier_v -- < + max_or_earlier_v -- <= + exact_this_v -- == + where + package = fromJust.getPackage $ head deps + max_earlier_v = safe_minimum $ map earlier_v deps + max_or_earlier_v = safe_minimum $ map or_earlier_v deps + min_later_v = safe_maximum $ map later_v deps + min_or_later_v = safe_maximum $ map or_later_v deps + exact_this_v = case catMaybes (map this_v deps) of + [] -> Nothing + [v] -> Just v + xs -> error $ "too many exact versions:" ++ show xs + -- + earlier_v (EarlierVersionOf v _p) = Just v + earlier_v _ = Nothing + + or_earlier_v (OrEarlierVersionOf v _p) = Just v + or_earlier_v _ = Nothing + + later_v (LaterVersionOf v _p) = Just v + later_v _ = Nothing + + or_later_v (OrLaterVersionOf v _p) = Just v + or_later_v _ = Nothing + + this_v (ThisVersionOf v _p) = Just v + this_v _ = Nothing + -- + safe_minimum xs = case catMaybes xs of + [] -> Nothing + xs' -> Just $ minimum xs' + safe_maximum xs = case catMaybes xs of + [] -> Nothing + xs' -> Just $ maximum xs' + +-- divide packages to groups (by package name), simplify groups, merge again +simplify_deps :: [Dependency] -> [Dependency] +simplify_deps deps = (concatMap (simplify_group.nub) $ + groupBy cmpPkgName $ + sortBy (comparing getPackageString) groupable) + ++ ungroupable + where (ungroupable, groupable) = partition ((==Nothing).getPackage) deps + -- + cmpPkgName p1 p2 = cmpMaybe (getPackage p1) (getPackage p2) + cmpMaybe (Just p1) (Just p2) = p1 == p2 + cmpMaybe _ _ = False + -- +getPackage :: Dependency -> Maybe Package +getPackage (AnyVersionOf package) = Just package +getPackage (ThisVersionOf _version package) = Just package +getPackage (LaterVersionOf _version package) = Just package +getPackage (EarlierVersionOf _version package) = Just package +getPackage (OrLaterVersionOf _version package) = Just package +getPackage (OrEarlierVersionOf _version package) = Just package +getPackage (DependEither _dependency _Dependency) = Nothing +getPackage (DependIfUse _useFlag _Dependency) = Nothing +getPackage (ThisMajorOf _version package) = Just package +-- +getPackageString :: Dependency -> Package +getPackageString dep = maybe "" id $ getPackage dep diff --git a/Portage/Host.hs b/Portage/Host.hs new file mode 100644 --- /dev/null +++ b/Portage/Host.hs @@ -0,0 +1,102 @@ +module Portage.Host + ( getInfo -- :: IO [(String, String)] + , LocalInfo(..) + ) where + +import Util (run_cmd) +import Data.Char (isSpace) +import Data.Maybe (fromJust, isJust) + + +data LocalInfo = + LocalInfo { distfiles_dir :: String + , overlay_list :: [FilePath] + , portage_dir :: FilePath + } + +defaultInfo :: LocalInfo +defaultInfo = LocalInfo { distfiles_dir = "/usr/portage/distfiles" + , overlay_list = [] + , portage_dir = "/usr/portage" + } + +-- query paludis and then emerge +getInfo :: IO LocalInfo +getInfo = fromJust `fmap` + performMaybes [ (fmap . fmap) parse_paludis_output (run_cmd "paludis --info") + , (fmap . fmap) parse_emerge_output (run_cmd "emerge --info") + , return (Just defaultInfo) + ] + where performMaybes [] = return Nothing + performMaybes (act:acts) = + do r <- act + if isJust r + then return r + else performMaybes acts + +data LocalPaludisOverlay = + LocalPaludisOverlay { repo_name :: String + , format :: String + , location :: FilePath + , distdir :: FilePath + } + +bad_paludis_overlay :: LocalPaludisOverlay +bad_paludis_overlay = + LocalPaludisOverlay { repo_name = undefined + , format = undefined + , location = undefined + , distdir = undefined + } + +parse_paludis_output :: String -> LocalInfo +parse_paludis_output raw_data = + foldl updateInfo defaultInfo $ parse_paludis_overlays raw_data + where updateInfo info po = + case (format po) of + "ebuild" | (repo_name po) /= "gentoo" -- hack, skip main repo + -> info{ distfiles_dir = distdir po -- we override last distdir here (FIXME?) + , overlay_list = (location po) : overlay_list info + } + "ebuild" -- hack, main repo -- (repo_name po) == "gentoo" + -> info{ portage_dir = location po } + + _ -> info + +parse_paludis_overlays :: String -> [LocalPaludisOverlay] +parse_paludis_overlays raw_data = + parse_paludis_overlays' (reverse $ lines raw_data) bad_paludis_overlay + +-- parse in reverse order :] +parse_paludis_overlays' :: [String] -> LocalPaludisOverlay -> [LocalPaludisOverlay] +parse_paludis_overlays' [] _ = [] +parse_paludis_overlays' (l:ls) info = + case (words l) of + -- look for "Repository :" + ["Repository", r_name] -> info{repo_name = init r_name} : + go bad_paludis_overlay + -- else - parse attributes + _ -> case (break (== ':') (refine l)) of + ("location", ':':value) + -> go info{location = refine value} + ("distdir", ':':value) + -> go info{distdir = refine value} + ("format", ':':value) + -> go info{format = refine value} + _ -> go info + where go = parse_paludis_overlays' ls + refine = dropWhile isSpace + +parse_emerge_output :: String -> LocalInfo +parse_emerge_output raw_data = + foldl updateInfo defaultInfo $ lines raw_data + where updateInfo info str = + case (break (== '=') str) of + ("DISTDIR", '=':value) + -> info{distfiles_dir = unquote value} + ("PORTDIR", '=':value) + -> info{portage_dir = unquote value} + ("PORTDIR_OVERLAY", '=':value) + -> info{overlay_list = words $ unquote value} + _ -> info + unquote = init . tail diff --git a/Portage/Overlay.hs b/Portage/Overlay.hs new file mode 100644 --- /dev/null +++ b/Portage/Overlay.hs @@ -0,0 +1,169 @@ +module Portage.Overlay + ( ExistingEbuild(..) + , Overlay(..) + , load, loadLazy + , readOverlayByPackage, getDirectoryTree, DirectoryTree + + , reduceOverlay + , inOverlay + ) + where + +import qualified Portage.PackageId as Portage + +import qualified Distribution.Package as Cabal + +import Distribution.Text (simpleParse, display) +import Distribution.Simple.Utils ( comparing, equating ) + +import Data.List as List +import qualified Data.Map as Map +import Data.Map (Map) +import System.Directory (getDirectoryContents, doesDirectoryExist) +import System.IO.Unsafe (unsafeInterleaveIO) +import System.FilePath ((), splitExtension) + +--main = do +-- pkgs <- blingProgress . Progress.fromList . readOverlay +-- =<< getDirectoryTree "." +-- putStrLn $ unlines [ display pkg +-- | pkg <- pkgs +-- , isNothing (Portage.toCabalPackageId pkg) ] + +--TODO: move this to another module: +data ExistingEbuild = ExistingEbuild { + ebuildId :: Portage.PackageId, + ebuildCabalId :: Cabal.PackageIdentifier, + ebuildPath :: FilePath + } deriving (Show,Ord,Eq) + +instance Cabal.Package ExistingEbuild where packageId = ebuildCabalId + +data Overlay = Overlay { + overlayPath :: FilePath, + overlayMap :: Map Portage.PackageName [ExistingEbuild] + } deriving Show + +inOverlay :: Overlay -> Cabal.PackageId -> Bool +inOverlay overlay pkgId = not (Map.null packages) + where + packages = Map.filterWithKey + (\(Portage.PackageName _cat overlay_pn) ebuilds -> + let cabal_pn = Cabal.pkgName pkgId + ebs = [ () + | e <- ebuilds + , let ebuild_cabal_id = ebuildCabalId e + , ebuild_cabal_id == pkgId + ] + in cabal_pn == overlay_pn && (not (null ebs))) om + om = overlayMap overlay + +load :: FilePath -> IO Overlay +load dir = fmap (mkOverlay . readOverlay) (getDirectoryTree dir) + where + mkOverlay _packages = Overlay { + overlayPath = dir +-- TODO: ignore all ebuilds that have no Cabal version number +-- , overlayIndex = PackageIndex.fromList packages + , overlayMap = undefined + } + +loadLazy :: FilePath -> IO Overlay +loadLazy dir = fmap (mkOverlay . readOverlayByPackage) (getDirectoryTree dir) + where + allowed v = case v of + (Portage.Version _ Nothing [] _) -> True + _ -> False + a <-> b = a ++ '-':b + a <.> b = a ++ '.':b + + mkOverlay :: [(Portage.PackageName, [Portage.Version])] -> Overlay + mkOverlay packages = Overlay { + overlayPath = dir, + overlayMap = + Map.fromList + [ (pkgName, [ ExistingEbuild portageId cabalId filepath + | version <- allowedVersions + , let portageId = Portage.PackageId pkgName version + , Just cabalId <- [ Portage.toCabalPackageId portageId ] + , let filepath = + dir display pkgName <-> display version <.> "ebuild" + ]) + | (pkgName, allVersions) <- packages + , let allowedVersions = filter allowed allVersions + ] + } + +-- make sure there is only one ebuild for each version number (by selecting +-- the highest ebuild version revision) +reduceOverlay :: Overlay -> Overlay +reduceOverlay overlay = overlay { overlayMap = Map.map reduceVersions (overlayMap overlay) } + where + versionNumbers (Portage.Version nums _ _ _) = nums + reduceVersions :: [ExistingEbuild] -> [ExistingEbuild] + reduceVersions ebuilds = -- gah! + map (maximumBy (comparing (Portage.pkgVersion . ebuildId))) + . groupBy (equating (versionNumbers . Portage.pkgVersion . ebuildId)) + . sortBy (comparing (Portage.pkgVersion . ebuildId)) + $ ebuilds + +readOverlayByPackage :: DirectoryTree -> [(Portage.PackageName, [Portage.Version])] +readOverlayByPackage tree = + [ (name, versions name pkgTree) + | (category, catTree) <- categories tree + , (name, pkgTree) <- packages category catTree + ] + + where + categories :: DirectoryTree -> [(Portage.Category, DirectoryTree)] + categories entries = + [ (category, entries') + | Directory dir entries' <- entries + , Just category <- [simpleParse dir] ] + + packages :: Portage.Category -> DirectoryTree + -> [(Portage.PackageName, DirectoryTree)] + packages category entries = + [ (Portage.PackageName category name, entries') + | Directory dir entries' <- entries + , Just name <- [simpleParse dir] ] + + versions :: Portage.PackageName -> DirectoryTree -> [Portage.Version] + versions name@(Portage.PackageName (Portage.Category category) _) entries = + [ version + | File fileName <- entries + , let (baseName, ext) = splitExtension fileName + , ext == ".ebuild" + , let fullName = category ++ '/' : baseName + , Just (Portage.PackageId name' version) <- [simpleParse fullName] + , name == name' ] + +readOverlay :: DirectoryTree -> [Portage.PackageId] +readOverlay tree = [ Portage.PackageId pkgId version + | (pkgId, versions) <- readOverlayByPackage tree + , version <- versions + ] + +type DirectoryTree = [DirectoryEntry] +data DirectoryEntry = File FilePath | Directory FilePath [DirectoryEntry] + +getDirectoryTree :: FilePath -> IO DirectoryTree +getDirectoryTree = dirEntries + + where + dirEntries :: FilePath -> IO [DirectoryEntry] + dirEntries dir = do + names <- getDirectoryContents dir + sequence + [ do isDirectory <- doesDirectoryExist path + if isDirectory + then do entries <- unsafeInterleaveIO (dirEntries path) + return (Directory name entries) + else return (File name) + | name <- names + , not (ignore name) + , let path = dir name ] + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False diff --git a/Portage/PackageId.hs b/Portage/PackageId.hs new file mode 100644 --- /dev/null +++ b/Portage/PackageId.hs @@ -0,0 +1,113 @@ +-- | Portage package identifiers, which unlike Cabal ones include a category. +-- +module Portage.PackageId ( + Category(..), + PackageName(..), + PackageId(..), + Portage.Version(..), + fromCabalPackageId, + toCabalPackageId, + parseFriendlyPackage, + normalizeCabalPackageName, + normalizeCabalPackageId + ) where + +import qualified Distribution.Package as Cabal +import Distribution.Text (Text(..)) + +import qualified Distribution.Compat.ReadP as Parse + +import qualified Portage.Version as Portage + +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) +import qualified Data.Char as Char (isAlphaNum, isSpace, toLower) +-- import qualified Data.Char as Char (isDigit) +-- import Data.List (intersperse) + +newtype Category = Category { unCategory :: String } + deriving (Eq, Ord, Show, Read) + +data PackageName = PackageName Category Cabal.PackageName + deriving (Eq, Ord, Show, Read) + +data PackageId = PackageId { packageId :: PackageName, pkgVersion :: Portage.Version } + deriving (Eq, Ord, Show, Read) + +{- +instance Text PN where + disp (PN n) = Disp.text n + parse = do + ns <- Parse.sepBy1 component (Parse.char '-') + return (PN (concat (intersperse "-" ns))) + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). +-} + +fromCabalPackageId :: Category -> Cabal.PackageIdentifier -> PackageId +fromCabalPackageId category (Cabal.PackageIdentifier name version) = + PackageId (PackageName category (normalizeCabalPackageName name)) + (Portage.fromCabalVersion version) + +normalizeCabalPackageName :: Cabal.PackageName -> Cabal.PackageName +normalizeCabalPackageName (Cabal.PackageName name) = + Cabal.PackageName (map Char.toLower name) + +normalizeCabalPackageId :: Cabal.PackageIdentifier -> Cabal.PackageIdentifier +normalizeCabalPackageId (Cabal.PackageIdentifier name version) = + Cabal.PackageIdentifier (normalizeCabalPackageName name) version + +toCabalPackageId :: PackageId -> Maybe Cabal.PackageIdentifier +toCabalPackageId (PackageId (PackageName _cat name) version) = + fmap (Cabal.PackageIdentifier name) + (Portage.toCabalVersion version) + +instance Text Category where + disp (Category c) = Disp.text c + parse = fmap Category (Parse.munch1 categoryChar) + where + categoryChar c = Char.isAlphaNum c || c == '-' + +instance Text PackageName where + disp (PackageName category name) = + disp category <> Disp.char '/' <> disp name + + parse = do + category <- parse + _ <- Parse.char '/' + name <- parse + return (PackageName category name) + +instance Text PackageId where + disp (PackageId name version) = + disp name <> Disp.char '-' <> disp version + + parse = do + name <- parse + _ <- Parse.char '-' + version <- parse + return (PackageId name version) + +parseFriendlyPackage :: String -> Maybe (Maybe Category, Cabal.PackageName, Maybe Portage.Version) +parseFriendlyPackage str = + case [ p | (p,s) <- Parse.readP_to_S parser str + , all Char.isSpace s ] of + [] -> Nothing + (x:_) -> Just x + where + parser = do + mc <- Parse.option Nothing $ do + c <- parse + _ <- Parse.char '/' + return (Just c) + p <- parse + mv <- Parse.option Nothing $ do + _ <- Parse.char '-' + v <- parse + return (Just v) + return (mc, p, mv) + diff --git a/Portage/Resolve.hs b/Portage/Resolve.hs new file mode 100644 --- /dev/null +++ b/Portage/Resolve.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE PatternGuards #-} + +module Portage.Resolve where + +import qualified Portage.Overlay as Overlay +import qualified Portage.PackageId as Portage + +import Distribution.Verbosity +import Distribution.Text (display) +import qualified Distribution.Package as Cabal +import Distribution.Simple.Utils + +import qualified Data.Map as Map + +import Error + +import Debug.Trace (trace) + +-- | If a package already exist in the overlay, find which category it has. +-- If it does not exist, we default to \'dev-haskell\'. +resolveCategory :: Verbosity -> Overlay.Overlay -> Cabal.PackageName -> IO Portage.Category +resolveCategory verbosity overlay pn = do + info verbosity "Searching for which category to use..." + case resolveCategories overlay pn of + [] -> do + info verbosity "No previous version of this package, defaulting category to dev-haskell." + return devhaskell + [cat] -> do + info verbosity $ "Exact match of already existing package, using category: " + ++ display cat + return cat + cats -> do + warn verbosity $ "Multiple matches of categories: " ++ unwords (map display cats) + if devhaskell `elem` cats + then do notice verbosity "Defaulting to dev-haskell" + return devhaskell + else do warn verbosity "Multiple matches and no known default. Override by specifying " + warn verbosity "package category like so 'hackport merge categoryname/package[-version]." + throwEx (ArgumentError "Specify package category and try again.") + where + devhaskell = Portage.Category "dev-haskell" + +resolveCategories :: Overlay.Overlay -> Cabal.PackageName -> [Portage.Category] +resolveCategories overlay pn = + [ cat + | (Portage.PackageName cat pn') <- Map.keys om + , pn == Portage.normalizeCabalPackageName pn' + ] + where + om = Overlay.overlayMap overlay + +resolveFullPortageName :: Overlay.Overlay -> Cabal.PackageName -> Maybe Portage.PackageName +resolveFullPortageName overlay pn = + case resolveCategories overlay pn of + [] -> Nothing + [cat] -> ret cat + cats | (cat:_) <- (filter (`elem` cats) priority) -> ret cat + | otherwise -> trace ("Ambiguous package name: " ++ show pn ++ ", hits: " ++ show cats) Nothing + where + ret c = return (Portage.PackageName c pn) + mkC = Portage.Category + -- if any of these categories show up in the result list, the match isn't + -- ambiguous, pick the first match in the list + priority = [ mkC "dev-haskell" + , mkC "sys-libs" + , mkC "dev-libs" + , mkC "x11-libs" + , mkC "media-libs" + , mkC "net-libs" + , mkC "sci-libs" + ] + diff --git a/Portage/Version.hs b/Portage/Version.hs new file mode 100644 --- /dev/null +++ b/Portage/Version.hs @@ -0,0 +1,86 @@ +{-| + Author : Andres Loeh + Stability : provisional + Portability : haskell98 + + Version parser, according to Portage spec. + + Shamelessly borrowed from exi, ported from Parsec to ReadP + +-} + +module Portage.Version ( + Version(..), + Suffix(..), + fromCabalVersion, + toCabalVersion, + ) where + +import qualified Distribution.Version as Cabal + +import Distribution.Text (Text(..)) + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) +import qualified Data.Char as Char (isAlpha, isDigit) + +data Version = Version [Int] -- [1,42,3] ~= 1.42.3 + (Maybe Char) -- optional letter + [Suffix] + Int -- revision, 0 means none + deriving (Eq, Ord, Show, Read) + +data Suffix = Alpha Int | Beta Int | Pre Int | RC Int | P Int + deriving (Eq, Ord, Show, Read) + +fromCabalVersion :: Cabal.Version -> Version +fromCabalVersion (Cabal.Version nums _tags) = Version nums Nothing [] 0 + +toCabalVersion :: Version -> Maybe Cabal.Version +toCabalVersion (Version nums Nothing [] _) = Just (Cabal.Version nums []) +toCabalVersion _ = Nothing + +instance Text Version where + disp (Version ver c suf rev) = + dispVer ver <> dispC c <> dispSuf suf <> dispRev rev + where + dispVer = Disp.hcat . Disp.punctuate (Disp.char '.') . map Disp.int + dispC = maybe Disp.empty Disp.char + dispSuf = Disp.hcat . map disp + dispRev 0 = Disp.empty + dispRev n = Disp.text "-r" <> Disp.int n + + parse = do + ver <- Parse.sepBy1 digits (Parse.char '.') + c <- Parse.option Nothing (fmap Just (Parse.satisfy Char.isAlpha)) + suf <- Parse.many parse + rev <- Parse.option 0 (Parse.string "-r" >> digits) + return (Version ver c suf rev) + +instance Text Suffix where + disp suf = case suf of + Alpha n -> Disp.text "_alpha" <> dispPos n + Beta n -> Disp.text "_beta" <> dispPos n + Pre n -> Disp.text "_pre" <> dispPos n + RC n -> Disp.text "_rc" <> dispPos n + P n -> Disp.text "_p" <> dispPos n + + where + dispPos :: Int -> Disp.Doc + dispPos 0 = Disp.empty + dispPos n = Disp.int n + + parse = Parse.char '_' + >> Parse.choice + [ Parse.string "alpha" >> fmap Alpha maybeDigits + , Parse.string "beta" >> fmap Beta maybeDigits + , Parse.string "pre" >> fmap Pre maybeDigits + , Parse.string "rc" >> fmap RC maybeDigits + , Parse.string "p" >> fmap P maybeDigits + ] + where + maybeDigits = Parse.option 0 digits + +digits :: Parse.ReadP r Int +digits = fmap read (Parse.munch1 Char.isDigit) diff --git a/Progress.hs b/Progress.hs new file mode 100644 --- /dev/null +++ b/Progress.hs @@ -0,0 +1,62 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Progress +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@haskell.org +-- Portability : portable +-- +-- Common types for dependency resolution. +----------------------------------------------------------------------------- +module Progress ( + Progress(..), + fold, unfold, fromList, + ) where + +import Prelude hiding (fail) + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail. We may get intermediate steps before the final +-- retult which may be used to indicate progress and\/or logging messages. +-- +data Progress step fail done = Step step (Progress step fail done) + | Fail fail + | Done done + +-- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with +-- two base cases, one for a final result and one for failure. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +-- +fold :: (step -> a -> a) -> (fail -> a) -> (done -> a) + -> Progress step fail done -> a +fold step fail done = go + where + go (Step s p) = step s (go p) + go (Fail f) = fail f + go (Done r) = done r + +unfold :: (s -> Either (Either fail done) (step, s)) + -> s -> Progress step fail done +unfold f = go + where + go s = case f s of + Left (Left fail) -> Fail fail + Left (Right done) -> Done done + Right (step, s') -> Step step (go s') + +fromList :: [a] -> Progress () b [a] +fromList xs0 = unfold next xs0 + where + next [] = Left (Right xs0) + next (_:xs) = Right ((), xs) + +instance Functor (Progress step fail) where + fmap f = fold Step Fail (Done . f) + +instance Monad (Progress step fail) where + return a = Done a + p >>= f = fold Step Fail f p diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,111 @@ +Hackport +======== + +About +----- + +Hackport is a utility application for Gentoo Linux to ease the tasks for the +Haskell Project. + +The main purpose for Hackport is to interact with Hackage and create +Ebuilds from Cabal packages. It also does handy functions to compare +hackage, the overlay and the portage tree. + +Features +-------- + + 'hackport update' + Update the local copy of hackage's package list. You should run this + every once in a while to get a more recent copy. + + 'hackport list [FILTER]' + Print packages from hackage, with an optional substring matching. + + 'hackport merge ' + Create a Gentoo Linux Ebuild for hackage package named . + The category defaults to dev-haskell, but is overridden if an older + version has been merged previously to another category. The category + can also be overridden with the syntax category/package. Example: + + $ hackport merge x11-wm/xmonad + + Hackport will make an ebuild that uses the haskell-cabal eclass, and + set the following properties: + + PN (package name) + Package name converted into lower case + PV (package version) + Package version with tags dropped. + KEYWORDS + Defaults to ~amd64 ~x86 + CABAL_FEATURES + Set to "bin" for executables, and "lib haddock profile" for + libraries. Packages that contains both a binary and library will + get the union. + DEPEND + GHC dependency defaults to >=dev-lang/ghc-6.6.1. + Cabal dependency is fetched from Cabal field 'Cabal-Version'. + All other package dependencies are converted into gentoo syntax. + Range dependencies are flattened and usually needs manual + tweaking. + DESCRIPTION + From Synopsis if it is non-empty, otherwise Description. + HOMEPAGE + From Homepage + SRC_URI + From package url + LICENSE + From cabal license converted into gentoo licenses + SLOT + Defaults to "0" + + 'hackport diff [missing|additions|newer|common]' + Prints a list showing a diff between hackage and the overlay. + For each package it shows the latest version in both hackage and the + overlay. + + + Optional parameters: + 'all', the default action + List all packages. + 'missing' + List packages that exist in hackage but not in the overlay, + or where the hackage version is more recent. + 'additions' + List packages only in the overlay, or where the overlay has + a more recent version. + 'newer' + List packages where hackage has a more recent version. + 'common' + List packages where hackage and the overlay has the same + version. + + 'hackport status [toportage]' + Provides an overview comparing the overlay to the portage tree. + It will teel you, for each package and version, if the package exist + + - only in the portage tree + - only in the overlay + - both in the portage tree and the overlay + - both in the portage tree and the overlay, + but the ebuilds are not identical + + Optional parameters: + '--to-portage' + Only print packages that are likely to be interesting to + move to the portage tree. + It will print packages when they exist in both portage and + the overlay, and: + - the ebuilds differ, or + - the overlay has a more recent version + + 'hackport make-ebuild ' + Generates standalone .ebuild file from .cabal spec and stores result in same + directory. + Option is useful for packages not-on-hackage and for debug purposes. + +------- + + Henning Günther + Duncan Coutts + Lennart Kolmodin diff --git a/Status.hs b/Status.hs --- a/Status.hs +++ b/Status.hs @@ -2,15 +2,11 @@ ( FileStatus(..) , fromStatus , status - , statusAction + , runStatus ) where -import Action import AnsiColor -import Bash import P2 -import Utils -import Overlays import Control.Monad.State @@ -24,6 +20,11 @@ import qualified Data.Traversable as T +-- cabal +import Distribution.Verbosity +import Distribution.Simple.Utils (equating, comparing) +import Distribution.Text(display) + data FileStatus a = Same a | Differs a a @@ -32,7 +33,7 @@ deriving (Show,Eq) instance Ord a => Ord (FileStatus a) where - compare x y = compare (fromStatus x) (fromStatus y) + compare = comparing fromStatus instance Functor FileStatus where fmap f st = @@ -50,19 +51,17 @@ OverlayOnly a -> a PortageOnly a -> a -status :: HPAction (Map Package [FileStatus Ebuild]) -status = do - portdir <- getPortdir - overlayPath <- getOverlayPath - overlay <- liftIO $ readPortageTree overlayPath - portage <- liftIO $ readPortagePackages portdir (Map.keys overlay) +status :: Verbosity -> FilePath -> FilePath -> IO (Map Package [FileStatus Ebuild]) +status _verbosity portdir overlayPath = do + overlay <- readPortageTree overlayPath + portage <- readPortagePackages portdir (Map.keys overlay) let (over, both, port) = portageDiff overlay portage both' <- T.forM both $ mapM $ \e -> liftIO $ do -- can't fail, we know the ebuild exists in both portagedirs -- also, one of them is already bound to 'e' - let (Just e1) = lookupEbuildWith portage (ePackage e) (comparing eVersion e) - (Just e2) = lookupEbuildWith overlay (ePackage e) (comparing eVersion e) + let (Just e1) = lookupEbuildWith portage (ePackage e) (equating eVersion e) + (Just e2) = lookupEbuildWith overlay (ePackage e) (equating eVersion e) eq <- equals (eFilePath e1) (eFilePath e2) return $ if eq then Same e @@ -75,14 +74,17 @@ ] return meld -statusAction :: String -> HPAction () -statusAction action = do - let pkgFilter = - case action of - "" -> id - "toportage" -> toPortageFilter - pkgs <- status - statusPrinter (pkgFilter pkgs) +runStatus :: Verbosity -> FilePath -> FilePath -> Bool -> [String] -> IO () +runStatus verbosity portdir overlayPath toPortageFlag pkgs = do + let pkgFilter | toPortageFlag = toPortageFilter + | otherwise = id + tree0 <- status verbosity portdir overlayPath + let tree = pkgFilter tree0 + if (null pkgs) + then statusPrinter tree + else forM_ pkgs $ \pkg -> do + let filteredTree = Map.filterWithKey (\k _ -> pPackage k == pkg) tree + statusPrinter filteredTree -- |Only return packages that seems interesting to sync to portage; -- @@ -104,18 +106,18 @@ then Just sts else Nothing -statusPrinter :: Map Package [FileStatus Ebuild] -> HPAction () +statusPrinter :: Map Package [FileStatus Ebuild] -> IO () statusPrinter packages = do - liftIO $ putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same" - liftIO $ putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs" - liftIO $ putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay" - liftIO $ putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree" - forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> liftIO $ do + putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same" + putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs" + putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay" + putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree" + forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> do let (P c p) = pkg putStr $ c ++ '/' : bold p putStr " " forM_ ebuilds $ \e -> do - putStr $ toColor (fmap (show . eVersion) e) + putStr $ toColor (fmap (display . eVersion) e) putChar ' ' putStrLn "" @@ -131,12 +133,12 @@ portageDiff :: Portage -> Portage -> (Portage, Portage, Portage) portageDiff p1 p2 = (in1, ins, in2) where ins = Map.filter (not . null) $ - Map.intersectionWith (List.intersectBy $ comparing eVersion) p1 p2 + Map.intersectionWith (List.intersectBy $ equating eVersion) p1 p2 in1 = difference p1 p2 in2 = difference p2 p1 difference x y = Map.filter (not . null) $ Map.differenceWith (\xs ys -> - let lst = foldr (List.deleteBy (comparing eVersion)) xs ys in + let lst = foldr (List.deleteBy (equating eVersion)) xs ys in if null lst then Nothing else Just lst @@ -151,7 +153,7 @@ return (equal' f1 f2) equal' :: L.ByteString -> L.ByteString -> Bool -equal' = comparing essence +equal' = equating essence where essence = filter (not . isEmpty) . filter (not . isComment) . L.lines isComment = L.isPrefixOf (L.pack "#") . L.dropWhile isSpace diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,35 @@ + +Easier +==== + +* Document the commands in Main.hs with text from README. + commandDescription and commandSynopsis fields in the CommandUI records + +* continue on the CLI. see what additional flags the commands need, if there + still are any missing. set good default values, and make sure we don't + get any 'fromFlag' errors due to missing defaults for all commands + +* catch baseconstraints and upgrade ghc requirement + (like in vty-4.0.0.1: base >= 4 leads to ghc >= 6.10) + +Harder +====== + +* translate the dev-db/libpq dependency into virtual/postgresql-base + the cabal field to describe c libs should be translated if we know the + proper gentoo package name. + +* see if PackageIndex and IndexUtils from cabal install can be used instead of Index + see Distribution.Simple.PackageIndex + PackageIndex Ebuild? + +* make clear destinction of Hackage.Package and Portage.Package (notice the namespaces) + Look into Portage, P2 and whatever other hacks there might be and + properly separate them into the two categories. + See the already existing Portage.PackageId + +* look into Ebuild's field ePkgDesc and its uses + +* Merge the separate tool keyword-stat into hackport, and make it use the + hackport API. + See http://code.haskell.org/gentoo/keyword-stat/ diff --git a/Util.hs b/Util.hs new file mode 100644 --- /dev/null +++ b/Util.hs @@ -0,0 +1,31 @@ +{-| + Author : Sergei Trofimovich + Stability : experimental + Portability : haskell98 + + Ungrouped utilitary stuff lays here until someone finds better place for it :] +-} + +module Util + ( run_cmd -- :: String -> IO (Maybe String) + ) where + +import System.IO +import System.Process +import System.Exit (ExitCode(..)) + +-- 'run_cmd' executes command and returns it's standard output +-- as 'String'. + +run_cmd :: String -> IO (Maybe String) +run_cmd cmd = do (hI, hO, hE, hProcess) <- runInteractiveCommand cmd + hClose hI + output <- hGetContents hO + errors <- hGetContents hE -- TODO: propagate error to caller + length output `seq` hClose hO + length errors `seq` hClose hE + + exitCode <- waitForProcess hProcess + return $ if (output == "" || exitCode /= ExitSuccess) + then Nothing + else Just output diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 --- a/Utils.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Utils where - -comparing :: (Eq b) => (a -> b) -> a -> a -> Bool -comparing f x y = f x == f y - -compareWith :: (Ord b) => (a -> b) -> a -> a -> Ordering -compareWith f x y = compare (f x) (f y) diff --git a/Version.hs b/Version.hs deleted file mode 100644 --- a/Version.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-| - Maintainer : Andres Loeh - Stability : provisional - Portability : haskell98 - - Version parser, according to Portage spec. - - Shamelessly borrowed from exi, somewhat modified - --} - -module Version - ( - Version(), - Suffix(..), - fromCabalVersion, - showVersion, - showSuffix, - readVersion, - parseVersion, - getVersion, - showRevPR - ) where - -import qualified Distribution.Version as Cabal -import Control.Monad -import Data.List -import Data.Maybe -import Text.ParserCombinators.Parsec - -data Version = Version [Int] -- [1,42,3] ~= 1.42.3 - (Maybe Char) -- optional letter - [Suffix] - Int -- revision, 0 means none - deriving (Eq, Ord) - -data Suffix = Alpha Int | Beta Int | Pre Int | RC Int | P_ Int - deriving (Eq,Ord) - -instance Show Version where - show = showVersion - -instance Show Suffix where - show = showSuffix - -showVersion :: Version -> String -showVersion (Version ver c suf rev) - = showver ++ showc ++ concatMap showSuffix suf ++ showRev rev - where showver = concat . intersperse "." . map show $ ver - showc = maybe "" (:[]) c - -showSuffix :: Suffix -> String -showSuffix (Alpha n) = "_alpha" ++ showPos n -showSuffix (Beta n) = "_beta" ++ showPos n -showSuffix (Pre n) = "_pre" ++ showPos n -showSuffix (RC n) = "_rc" ++ showPos n -showSuffix (P_ n) = "_p" ++ showPos n - -showPos :: Int -> String -showPos 0 = "" -showPos n = show n - -showRev :: Int -> String -showRev 0 = "" -showRev n = "-r" ++ show n - -showRevPR :: Int -> String -showRevPR n = "r" ++ show n - -fromCabalVersion :: Cabal.Version -> Version -fromCabalVersion (Cabal.Version nums _tags) = - Version nums Nothing [] 0 - --- | Function to call if you want to parse a version number. -getVersion :: String -> Version -getVersion ver = case parseVersion ver of - Left _ -> - error $ "getVersion: version parse error '" ++ ver ++ "'" - Right x -> x - -parseVersion :: String -> Either ParseError Version -parseVersion = parse (readVersion >>= \x -> eof >> return x) "" - -readVersion :: CharParser st Version -readVersion = do (ver, _verr) <- readVer - (c, _cr ) <- readC - (suf, _sufr) <- readSufs - (rev, _revr) <- readRev - return (Version ver c suf rev) - -readVer :: CharParser st ([Int], String) -readNum :: CharParser st (Int, String) -readC :: CharParser st (Maybe Char, String) -readSuf :: CharParser st (Suffix, String) -readSufType :: CharParser st (Int -> Suffix, String) -readSufs :: CharParser st ([Suffix], String) -readRev :: CharParser st (Int, String) - -readVer = liftM ((\(x,y) -> (x, concat . intersperse "." $ y)) . unzip) (sepBy1 readNum (char '.')) -readNum = do ds <- many1 digit - case read ds of - n -> return (n,ds) -readC = option (Nothing, "") (liftM (\x -> (Just x, [x])) letter) -readSuf = do char '_' - (f,sr) <- readSufType - (n,nr) <- option (0, "") readNum - return (f n,"_" ++ sr ++ nr) - -readSufType = choice [ - liftM (\x -> (Alpha, x)) (try $ string "alpha"), - liftM (\x -> (Beta, x)) (try $ string "beta" ), - liftM (\x -> (Pre, x)) (try $ string "pre" ), - liftM (\x -> (RC, x)) (try $ string "rc" ), - liftM (\x -> (P_, x)) (try $ string "p" ) - ] - -readSufs = fmap ( ( \ (x,y) -> (x, concat y) ) . unzip ) (many readSuf) - -readRev = option (0, "") ( do rr <- string "-r" - (n,nr) <- readNum - return (n,rr ++ nr) - ) diff --git a/cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs @@ -0,0 +1,311 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Anonymous ( + BuildReport(..), + InstallOutcome(..), + Outcome(..), + + -- * Constructing and writing reports + new, + + -- * parsing and pretty printing + parse, + parseList, + show, +-- showList, + ) where + +import Distribution.Client.Types + ( ConfiguredPackage(..) ) +import qualified Distribution.Client.Types as BR + ( BuildResult, BuildFailure(..), BuildSuccess(..) + , DocsResult(..), TestsResult(..) ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) +import qualified Paths_cabal_install (version) + +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(packageId) ) +import Distribution.PackageDescription + ( FlagName(..), FlagAssignment ) +--import Distribution.Version +-- ( Version ) +import Distribution.System + ( OS, Arch ) +import Distribution.Compiler + ( CompilerId ) +import qualified Distribution.Text as Text + ( Text(disp, parse) ) +import Distribution.ParseUtils + ( FieldDescr(..), ParseResult(..), Field(..) + , simpleField, listField, ppFields, readFields + , syntaxError, locatedErrorMsg ) +import Distribution.Simple.Utils + ( comparing ) + +import qualified Distribution.Compat.ReadP as Parse + ( ReadP, pfail, munch1, skipSpaces ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( Doc, render, char, text ) +import Text.PrettyPrint.HughesPJ + ( (<+>), (<>) ) + +import Data.List + ( unfoldr, sortBy ) +import Data.Char as Char + ( isAlpha, isAlphaNum ) + +import Prelude hiding (show) + +data BuildReport + = BuildReport { + -- | The package this build report is about + package :: PackageIdentifier, + + -- | The OS and Arch the package was built on + os :: OS, + arch :: Arch, + + -- | The Haskell compiler (and hopefully version) used + compiler :: CompilerId, + + -- | The uploading client, ie cabal-install-x.y.z + client :: PackageIdentifier, + + -- | Which configurations flags we used + flagAssignment :: FlagAssignment, + + -- | Which dependent packages we were using exactly + dependencies :: [PackageIdentifier], + + -- | Did installing work ok? + installOutcome :: InstallOutcome, + + -- Which version of the Cabal library was used to compile the Setup.hs +-- cabalVersion :: Version, + + -- Which build tools we were using (with versions) +-- tools :: [PackageIdentifier], + + -- | Configure outcome, did configure work ok? + docsOutcome :: Outcome, + + -- | Configure outcome, did configure work ok? + testsOutcome :: Outcome + } + +data InstallOutcome + = DependencyFailed PackageIdentifier + | DownloadFailed + | UnpackFailed + | SetupFailed + | ConfigureFailed + | BuildFailed + | InstallFailed + | InstallOk + deriving Eq + +data Outcome = NotTried | Failed | Ok + deriving Eq + +new :: OS -> Arch -> CompilerId -- -> Version + -> ConfiguredPackage -> BR.BuildResult + -> BuildReport +new os' arch' comp (ConfiguredPackage pkg flags deps) result = + BuildReport { + package = packageId pkg, + os = os', + arch = arch', + compiler = comp, + client = cabalInstallID, + flagAssignment = flags, + dependencies = deps, + installOutcome = convertInstallOutcome, +-- cabalVersion = undefined + docsOutcome = convertDocsOutcome, + testsOutcome = convertTestsOutcome + } + where + convertInstallOutcome = case result of + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _) -> InstallOk + convertDocsOutcome = case result of + Left _ -> NotTried + Right (BR.BuildOk BR.DocsNotTried _) -> NotTried + Right (BR.BuildOk BR.DocsFailed _) -> Failed + Right (BR.BuildOk BR.DocsOk _) -> Ok + convertTestsOutcome = case result of + Left _ -> NotTried + Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried + Right (BR.BuildOk _ BR.TestsFailed) -> Failed + Right (BR.BuildOk _ BR.TestsOk) -> Ok + +cabalInstallID :: PackageIdentifier +cabalInstallID = + PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version + +-- ------------------------------------------------------------ +-- * External format +-- ------------------------------------------------------------ + +initialBuildReport :: BuildReport +initialBuildReport = BuildReport { + package = requiredField "package", + os = requiredField "os", + arch = requiredField "arch", + compiler = requiredField "compiler", + client = requiredField "client", + flagAssignment = [], + dependencies = [], + installOutcome = requiredField "install-outcome", +-- cabalVersion = Nothing, +-- tools = [], + docsOutcome = NotTried, + testsOutcome = NotTried + } + where + requiredField fname = error ("required field: " ++ fname) + +-- ----------------------------------------------------------------------------- +-- Parsing + +parse :: String -> Either String BuildReport +parse s = case parseFields s of + ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror + ParseOk _ report -> Right report + +--FIXME: this does not allow for optional or repeated fields +parseFields :: String -> ParseResult BuildReport +parseFields input = do + fields <- mapM extractField =<< readFields input + let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name) + sortedFieldDescrs + (sortBy (comparing (\(_,name,_) -> name)) fields) + checkMerged initialBuildReport merged + + where + extractField :: Field -> ParseResult (Int, String, String) + extractField (F line name value) = return (line, name, value) + extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza" + extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza" + + checkMerged report [] = return report + checkMerged report (merged:remaining) = case merged of + InBoth fieldDescr (line, _name, value) -> do + report' <- fieldSet fieldDescr line value report + checkMerged report' remaining + OnlyInRight (line, name, _) -> + syntaxError line ("Unrecognized field " ++ name) + OnlyInLeft fieldDescr -> + fail ("Missing field " ++ fieldName fieldDescr) + +parseList :: String -> [BuildReport] +parseList str = + [ report | Right report <- map parse (split str) ] + + where + split :: String -> [String] + split = filter (not . null) . unfoldr chunk . lines + chunk [] = Nothing + chunk ls = case break null ls of + (r, rs) -> Just (unlines r, dropWhile null rs) + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +show :: BuildReport -> String +show = Disp.render . ppFields fieldDescrs + +-- ----------------------------------------------------------------------------- +-- Description of the fields, for parsing/printing + +fieldDescrs :: [FieldDescr BuildReport] +fieldDescrs = + [ simpleField "package" Text.disp Text.parse + package (\v r -> r { package = v }) + , simpleField "os" Text.disp Text.parse + os (\v r -> r { os = v }) + , simpleField "arch" Text.disp Text.parse + arch (\v r -> r { arch = v }) + , simpleField "compiler" Text.disp Text.parse + compiler (\v r -> r { compiler = v }) + , simpleField "client" Text.disp Text.parse + client (\v r -> r { client = v }) + , listField "flags" dispFlag parseFlag + flagAssignment (\v r -> r { flagAssignment = v }) + , listField "dependencies" Text.disp Text.parse + dependencies (\v r -> r { dependencies = v }) + , simpleField "install-outcome" Text.disp Text.parse + installOutcome (\v r -> r { installOutcome = v }) + , simpleField "docs-outcome" Text.disp Text.parse + docsOutcome (\v r -> r { docsOutcome = v }) + , simpleField "tests-outcome" Text.disp Text.parse + testsOutcome (\v r -> r { testsOutcome = v }) + ] + +sortedFieldDescrs :: [FieldDescr BuildReport] +sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs + +dispFlag :: (FlagName, Bool) -> Disp.Doc +dispFlag (FlagName name, True) = Disp.text name +dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name + +parseFlag :: Parse.ReadP r (FlagName, Bool) +parseFlag = do + name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + case name of + ('-':flag) -> return (FlagName flag, False) + flag -> return (FlagName flag, True) + +instance Text.Text InstallOutcome where + disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid + disp DownloadFailed = Disp.text "DownloadFailed" + disp UnpackFailed = Disp.text "UnpackFailed" + disp SetupFailed = Disp.text "SetupFailed" + disp ConfigureFailed = Disp.text "ConfigureFailed" + disp BuildFailed = Disp.text "BuildFailed" + disp InstallFailed = Disp.text "InstallFailed" + disp InstallOk = Disp.text "InstallOk" + + parse = do + name <- Parse.munch1 Char.isAlphaNum + case name of + "DependencyFailed" -> do Parse.skipSpaces + pkgid <- Text.parse + return (DependencyFailed pkgid) + "DownloadFailed" -> return DownloadFailed + "UnpackFailed" -> return UnpackFailed + "SetupFailed" -> return SetupFailed + "ConfigureFailed" -> return ConfigureFailed + "BuildFailed" -> return BuildFailed + "InstallFailed" -> return InstallFailed + "InstallOk" -> return InstallOk + _ -> Parse.pfail + +instance Text.Text Outcome where + disp NotTried = Disp.text "NotTried" + disp Failed = Disp.text "Failed" + disp Ok = Disp.text "Ok" + parse = do + name <- Parse.munch1 Char.isAlpha + case name of + "NotTried" -> return NotTried + "Failed" -> return Failed + "Ok" -> return Ok + _ -> Parse.pfail diff --git a/cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs @@ -0,0 +1,129 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Storage ( + + -- * Storing and retrieving build reports + storeAnonymous, + storeLocal, +-- retrieve, + + -- * 'InstallPlan' support + fromInstallPlan, + ) where + +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (BuildReport) + +import Distribution.Client.Types + ( ConfiguredPackage(..), AvailablePackage(..) + , AvailablePackageSource(..), Repo(..), RemoteRepo(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( InstallPlan ) + +import Distribution.Simple.InstallDirs + ( PathTemplate, fromPathTemplate + , initialPathTemplateEnv, substPathTemplate ) +import Distribution.System + ( Platform(Platform) ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.Simple.Utils + ( comparing, equating ) + +import Data.List + ( groupBy, sortBy ) +import Data.Maybe + ( catMaybes ) +import System.FilePath + ( (), takeDirectory ) +import System.Directory + ( createDirectoryIfMissing ) + +storeAnonymous :: [(BuildReport, Repo)] -> IO () +storeAnonymous reports = sequence_ + [ appendFile file (concatMap format reports') + | (repo, reports') <- separate reports + , let file = repoLocalDir repo "build-reports.log" ] + --TODO: make this concurrency safe, either lock the report file or make sure + -- the writes for each report are atomic (under 4k and flush at boundaries) + + where + format r = '\n' : BuildReport.show r ++ "\n" + separate :: [(BuildReport, Repo)] + -> [(Repo, [BuildReport])] + separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ])) + . map concat + . groupBy (equating (repoName . head)) + . sortBy (comparing (repoName . head)) + . groupBy (equating repoName) + . onlyRemote + repoName (_,_,rrepo) = remoteRepoName rrepo + + onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)] + onlyRemote rs = + [ (report, repo, remoteRepo) + | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ] + +storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO () +storeLocal templates reports = sequence_ + [ do createDirectoryIfMissing True (takeDirectory file) + appendFile file output + --TODO: make this concurrency safe, either lock the report file or make + -- sure the writes for each report are atomic + | (file, reports') <- groupByFileName + [ (reportFileName template report, report) + | template <- templates + , (report, _repo) <- reports ] + , let output = concatMap format reports' + ] + where + format r = '\n' : BuildReport.show r ++ "\n" + + reportFileName template report = + fromPathTemplate (substPathTemplate env template) + where env = initialPathTemplateEnv + (BuildReport.package report) + (BuildReport.compiler report) + + groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) + . groupBy (equating fst) + . sortBy (comparing fst) + +-- ------------------------------------------------------------ +-- * InstallPlan support +-- ------------------------------------------------------------ + +fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)] +fromInstallPlan plan = catMaybes + . map (fromPlanPackage platform comp) + . InstallPlan.toList + $ plan + where platform = InstallPlan.planPlatform plan + comp = InstallPlan.planCompiler plan + +fromPlanPackage :: Platform -> CompilerId + -> InstallPlan.PlanPackage + -> Maybe (BuildReport, Repo) +fromPlanPackage (Platform arch os) comp planPackage = case planPackage of + + InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage { + packageSource = RepoTarballPackage repo }) _ _) result + -> Just $ (BuildReport.new os arch comp pkg (Right result), repo) + + InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage { + packageSource = RepoTarballPackage repo }) _ _) result + -> Just $ (BuildReport.new os arch comp pkg (Left result), repo) + + _ -> Nothing diff --git a/cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.BuildReports.Types +-- Copyright : (c) Duncan Coutts 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Types related to build reporting +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Types ( + ReportLevel(..), + ) where + +import qualified Distribution.Text as Text + ( Text(..) ) + +import qualified Distribution.Compat.ReadP as Parse + ( pfail, munch1 ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( text ) + +import Data.Char as Char + ( isAlpha, toLower ) + +data ReportLevel = NoReports | AnonymousReports | DetailedReports + deriving (Eq, Ord, Show) + +instance Text.Text ReportLevel where + disp NoReports = Disp.text "none" + disp AnonymousReports = Disp.text "anonymous" + disp DetailedReports = Disp.text "detailed" + parse = do + name <- Parse.munch1 Char.isAlpha + case lowercase name of + "none" -> return NoReports + "anonymous" -> return AnonymousReports + "detailed" -> return DetailedReports + _ -> Parse.pfail + +lowercase :: String -> String +lowercase = map Char.toLower diff --git a/cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE PatternGuards #-} +-- This is a quick hack for uploading build reports to Hackage. + +module Distribution.Client.BuildReports.Upload + ( BuildLog + , BuildReportId + , uploadReports + , postBuildReport + , putBuildLog + ) where + +import Network.Browser + ( BrowserAction, request, setAllowRedirects ) +import Network.HTTP + ( Header(..), HeaderName(..) + , Request(..), RequestMethod(..), Response(..) ) +import Network.TCP (HandleStream) +import Network.URI (URI, uriPath, parseRelativeReference, relativeTo) + +import Control.Monad + ( forM_ ) +import System.FilePath.Posix + ( () ) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (BuildReport) + +type BuildReportId = URI +type BuildLog = String + +uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] + -> BrowserAction (HandleStream BuildLog) () +uploadReports uri reports + = forM_ reports $ \(report, mbBuildLog) -> + do buildId <- postBuildReport uri report + case mbBuildLog of + Just buildLog -> putBuildLog buildId buildLog + Nothing -> return () + +postBuildReport :: URI -> BuildReport + -> BrowserAction (HandleStream BuildLog) BuildReportId +postBuildReport uri buildReport = do + setAllowRedirects False + (_, response) <- request Request { + rqURI = uri { uriPath = "/buildreports" }, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + case rspCode response of + (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location + relativeTo rel uri + | Header HdrLocation location <- rspHeaders response ] + -> return $ buildId + _ -> error "Unrecognised response from server." + where body = BuildReport.show buildReport + +putBuildLog :: BuildReportId -> BuildLog + -> BrowserAction (HandleStream BuildLog) () +putBuildLog reportId buildLog = do + --FIXME: do something if the request fails + (_, response) <- request Request { + rqURI = reportId{uriPath = uriPath reportId "buildlog"}, + rqMethod = PUT, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (length buildLog)), + Header HdrAccept ("text/plain")], + rqBody = buildLog + } + return () diff --git a/cabal-install-0.8.2/Distribution/Client/Check.hs b/cabal-install-0.8.2/Distribution/Client/Check.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Check.hs @@ -0,0 +1,85 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Check +-- Copyright : (c) Lennart Kolmodin 2008 +-- License : BSD-like +-- +-- Maintainer : kolmodin@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Check a package for common mistakes +-- +----------------------------------------------------------------------------- +module Distribution.Client.Check ( + check + ) where + +import Control.Monad ( when, unless ) + +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Check +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Simple.Utils + ( defaultPackageDesc, toUTF8, wrapText ) + +check :: Verbosity -> IO Bool +check verbosity = do + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + -- flatten the generic package description into a regular package + -- description + -- TODO: this may give more warnings than it should give; + -- consider two branches of a condition, one saying + -- ghc-options: -Wall + -- and the other + -- ghc-options: -Werror + -- joined into + -- ghc-options: -Wall -Werror + -- checkPackages will yield a warning on the last line, but it + -- would not on each individual branch. + -- Hovever, this is the same way hackage does it, so we will yield + -- the exact same errors as it will. + let pkg_desc = flattenPackageDescription ppd + ioChecks <- checkPackageFiles pkg_desc "." + let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) + buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] + buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] + distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] + distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] + + unless (null buildImpossible) $ do + putStrLn "The package will not build sanely due to these errors:" + printCheckMessages buildImpossible + + unless (null buildWarning) $ do + putStrLn "The following warnings are likely affect your build negatively:" + printCheckMessages buildWarning + + unless (null distSuspicious) $ do + putStrLn "These warnings may cause trouble when distributing the package:" + printCheckMessages distSuspicious + + unless (null distInexusable) $ do + putStrLn "The following errors will cause portability problems on other environments:" + printCheckMessages distInexusable + + let isDistError (PackageDistSuspicious {}) = False + isDistError _ = True + errors = filter isDistError packageChecks + + unless (null errors) $ do + putStrLn "Hackage would reject this package." + + when (null packageChecks) $ do + 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/cabal-install-0.8.2/Distribution/Client/Config.hs b/cabal-install-0.8.2/Distribution/Client/Config.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Config.hs @@ -0,0 +1,565 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Config +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Utilities for handling saved state such as known packages, known servers and downloaded packages. +----------------------------------------------------------------------------- +module Distribution.Client.Config ( + SavedConfig(..), + loadConfig, + + showConfig, + showConfigWithComments, + parseConfig, + + defaultCabalDir, + defaultConfigFile, + defaultCacheDir, + defaultLogsDir, + ) where + + +import Distribution.Client.Types + ( RemoteRepo(..), Username(..), Password(..) ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand + , ConfigExFlags(..), configureExOptions, defaultConfigExFlags + , InstallFlags(..), installOptions, defaultInstallFlags + , UploadFlags(..), uploadCommand + , showRepo, parseRepo ) + +import Distribution.Simple.Setup + ( ConfigFlags(..), configureOptions, defaultConfigFlags + , Flag, toFlag, flagToMaybe, fromFlagOrDefault, flagToList ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), defaultInstallDirs + , PathTemplate, toPathTemplate, fromPathTemplate ) +import Distribution.ParseUtils + ( FieldDescr(..), liftField + , ParseResult(..), locatedErrorMsg, showPWarning + , readFields, warning, lineNo + , simpleField, listField, parseFilePathQ, showFilePath, parseTokenQ ) +import qualified Distribution.ParseUtils as ParseUtils + ( Field(..) ) +import qualified Distribution.Text as Text + ( Text(..) ) +import Distribution.ReadE + ( readP_to_E ) +import Distribution.Simple.Command + ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) + , viewAsFieldDescr, OptionField, option, reqArg ) +import Distribution.Simple.Program + ( defaultProgramConfiguration ) +import Distribution.Simple.Utils + ( notice, warn, lowercase ) +import Distribution.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor ) +import Distribution.Verbosity + ( Verbosity, normal ) + +import Data.List + ( partition, find ) +import Data.Maybe + ( fromMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Control.Monad + ( when, foldM, liftM ) +import qualified Data.Map as Map +import qualified Distribution.Compat.ReadP as Parse + ( option ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( Doc, render, text, colon, vcat, empty, isEmpty, nest ) +import Text.PrettyPrint.HughesPJ + ( (<>), (<+>), ($$), ($+$) ) +import System.Directory + ( createDirectoryIfMissing, getAppUserDataDirectory ) +import Network.URI + ( URI(..), URIAuth(..) ) +import System.FilePath + ( (), takeDirectory ) +import System.Environment + ( getEnvironment ) +import System.IO.Error + ( isDoesNotExistError ) + +-- +-- * Configuration saved in the config file +-- + +data SavedConfig = SavedConfig { + savedGlobalFlags :: GlobalFlags, + savedInstallFlags :: InstallFlags, + savedConfigureFlags :: ConfigFlags, + savedConfigureExFlags :: ConfigExFlags, + savedUserInstallDirs :: InstallDirs (Flag PathTemplate), + savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate), + savedUploadFlags :: UploadFlags + } + +instance Monoid SavedConfig where + mempty = SavedConfig { + savedGlobalFlags = mempty, + savedInstallFlags = mempty, + savedConfigureFlags = mempty, + savedConfigureExFlags = mempty, + savedUserInstallDirs = mempty, + savedGlobalInstallDirs = mempty, + savedUploadFlags = mempty + } + mappend a b = SavedConfig { + savedGlobalFlags = combine savedGlobalFlags, + savedInstallFlags = combine savedInstallFlags, + savedConfigureFlags = combine savedConfigureFlags, + savedConfigureExFlags = combine savedConfigureExFlags, + savedUserInstallDirs = combine savedUserInstallDirs, + savedGlobalInstallDirs = combine savedGlobalInstallDirs, + savedUploadFlags = combine savedUploadFlags + } + where combine field = field a `mappend` field b + +updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig +updateInstallDirs userInstallFlag + savedConfig@SavedConfig { + savedConfigureFlags = configureFlags, + savedUserInstallDirs = userInstallDirs, + savedGlobalInstallDirs = globalInstallDirs + } = + savedConfig { + savedConfigureFlags = configureFlags { + configInstallDirs = installDirs + } + } + where + installDirs | userInstall = userInstallDirs + | otherwise = globalInstallDirs + userInstall = fromFlagOrDefault defaultUserInstall $ + configUserInstall configureFlags `mappend` userInstallFlag + +-- +-- * Default config +-- + +-- | These are the absolute basic defaults. The fields that must be +-- initialised. When we load the config from the file we layer the loaded +-- values over these ones, so any missing fields in the file take their values +-- from here. +-- +baseSavedConfig :: IO SavedConfig +baseSavedConfig = do + userPrefix <- defaultCabalDir + return mempty { + savedConfigureFlags = mempty { + configHcFlavor = toFlag defaultCompiler, + configUserInstall = toFlag defaultUserInstall, + configVerbosity = toFlag normal + }, + savedUserInstallDirs = mempty { + prefix = toFlag (toPathTemplate userPrefix) + } + } + +-- | This is the initial configuration that we write out to to the config file +-- if the file does not exist (or the config we use if the file cannot be read +-- for some other reason). When the config gets loaded it gets layered on top +-- of 'baseSavedConfig' so we do not need to include it into the initial +-- values we save into the config file. +-- +initialSavedConfig :: IO SavedConfig +initialSavedConfig = do + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + return mempty { + savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, + globalRemoteRepos = [defaultRemoteRepo] + }, + savedInstallFlags = mempty { + installSummaryFile = [toPathTemplate (logsDir "build.log")], + installBuildReports= toFlag AnonymousReports + } + } + +defaultCabalDir :: IO FilePath +defaultCabalDir = getAppUserDataDirectory "cabal" + +defaultConfigFile :: IO FilePath +defaultConfigFile = do + dir <- defaultCabalDir + return $ dir "config" + +defaultCacheDir :: IO FilePath +defaultCacheDir = do + dir <- defaultCabalDir + return $ dir "packages" + +defaultLogsDir :: IO FilePath +defaultLogsDir = do + dir <- defaultCabalDir + return $ dir "logs" + +defaultCompiler :: CompilerFlavor +defaultCompiler = fromMaybe GHC defaultCompilerFlavor + +defaultUserInstall :: Bool +defaultUserInstall = True +-- We do per-user installs by default on all platforms. We used to default to +-- global installs on Windows but that no longer works on Windows Vista or 7. + +defaultRemoteRepo :: RemoteRepo +defaultRemoteRepo = RemoteRepo name uri + where + name = "hackage.haskell.org" + uri = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" "" + +-- +-- * Config file reading +-- + +loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig +loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do + 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 + initialConf <- initialSavedConfig + writeConfigFile configFile commentConf initialConf + return initialConf + Just (ParseOk ws conf) -> do + when (not $ null ws) $ warn verbosity $ + unlines (map (showPWarning configFile) ws) + return conf + Just (ParseFailed err) -> do + let (line, msg) = locatedErrorMsg err + warn verbosity $ + "Error parsing config file " ++ configFile + ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg + warn verbosity $ "Using default configuration." + initialSavedConfig + + where + addBaseConf body = do + base <- baseSavedConfig + extra <- body + return (updateInstallDirs userInstallFlag (base `mappend` extra)) + +readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) +readConfigFile initial file = handleNotExists $ + fmap (Just . parseConfig initial) (readFile file) + + where + handleNotExists action = catch action $ \ioe -> + if isDoesNotExistError ioe + then return Nothing + else ioError ioe + +writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () +writeConfigFile file comments vals = do + createDirectoryIfMissing True (takeDirectory file) + writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n" + where + explanation = unlines + ["-- This is the configuration file for the 'cabal' command line tool." + ,"" + ,"-- The available configuration options are listed below." + ,"-- Some of them have default values listed." + ,"" + ,"-- Lines (like this one) beginning with '--' are comments." + ,"-- Be careful with spaces and indentation because they are" + ,"-- used to indicate layout for nested sections." + ,"","" + ] + +-- | These are the default values that get used in Cabal if a no value is +-- given. We use these here to include in comments when we write out the +-- initial config file so that the user can see what default value they are +-- overriding. +-- +commentSavedConfig :: IO SavedConfig +commentSavedConfig = do + userInstallDirs <- defaultInstallDirs defaultCompiler True True + globalInstallDirs <- defaultInstallDirs defaultCompiler False True + return SavedConfig { + savedGlobalFlags = commandDefaultFlags globalCommand, + savedInstallFlags = defaultInstallFlags, + savedConfigureExFlags = defaultConfigExFlags, + savedConfigureFlags = (defaultConfigFlags defaultProgramConfiguration) { + configUserInstall = toFlag defaultUserInstall + }, + savedUserInstallDirs = fmap toFlag userInstallDirs, + savedGlobalInstallDirs = fmap toFlag globalInstallDirs, + savedUploadFlags = commandDefaultFlags uploadCommand + } + +-- | All config file fields. +-- +configFieldDescriptions :: [FieldDescr SavedConfig] +configFieldDescriptions = + + toSavedConfig liftGlobalFlag + (commandOptions globalCommand ParseArgs) + ["version", "numeric-version", "config-file"] [] + + ++ toSavedConfig liftConfigFlag + (configureOptions ParseArgs) + (["builddir", "configure-option"] ++ map fieldName installDirsFields) + + --FIXME: this is only here because viewAsFieldDescr gives us a parser + -- that only recognises 'ghc' etc, the case-sensitive flag names, not + -- what the normal case-insensitive parser gives us. + [simpleField "compiler" + (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + ] + + ++ toSavedConfig liftConfigExFlag + (configureExOptions ParseArgs) + [] [] + + ++ toSavedConfig liftInstallFlag + (installOptions ParseArgs) + ["dry-run", "reinstall", "only"] [] + + ++ toSavedConfig liftUploadFlag + (commandOptions uploadCommand ParseArgs) + ["verbose", "check"] [] + + where + toSavedConfig lift options exclusions replacements = + [ lift (fromMaybe field replacement) + | opt <- options + , let field = viewAsFieldDescr opt + name = fieldName field + replacement = find ((== name) . fieldName) replacements + , name `notElem` exclusions ] + optional = Parse.option mempty . fmap toFlag + +-- TODO: next step, make the deprecated fields elicit a warning. +-- +deprecatedFieldDescriptions :: [FieldDescr SavedConfig] +deprecatedFieldDescriptions = + [ liftGlobalFlag $ + listField "repos" + (Disp.text . showRepo) parseRepo + globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs }) + , liftGlobalFlag $ + simpleField "cachedir" + (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ) + globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) + , liftUploadFlag $ + simpleField "hackage-username" + (Disp.text . fromFlagOrDefault "" . fmap unUsername) + (optional (fmap Username parseTokenQ)) + uploadUsername (\d cfg -> cfg { uploadUsername = d }) + , liftUploadFlag $ + simpleField "hackage-password" + (Disp.text . fromFlagOrDefault "" . fmap unPassword) + (optional (fmap Password parseTokenQ)) + uploadPassword (\d cfg -> cfg { uploadPassword = d }) + ] + ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) installDirsFields + ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields + where + optional = Parse.option mempty . fmap toFlag + modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a + modifyFieldName f d = d { fieldName = f (fieldName d) } + +liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftUserInstallDirs = liftField + savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) + +liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftGlobalInstallDirs = liftField + savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags }) + +liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig +liftGlobalFlag = liftField + savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) + +liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig +liftConfigFlag = liftField + savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) + +liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig +liftConfigExFlag = liftField + savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags }) + +liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig +liftInstallFlag = liftField + savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) + +liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig +liftUploadFlag = liftField + savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) + +parseConfig :: SavedConfig -> String -> ParseResult SavedConfig +parseConfig initial = \str -> do + fields <- readFields str + let (knownSections, others) = partition isKnownSection fields + config <- parse others + let user0 = savedUserInstallDirs config + global0 = savedGlobalInstallDirs config + (user, global) <- foldM parseSections (user0, global0) knownSections + return config { + savedUserInstallDirs = user, + savedGlobalInstallDirs = global + } + + where + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection _ = False + + parse = parseFields (configFieldDescriptions + ++ deprecatedFieldDescriptions) initial + + parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs) + | name' == "user" = do u' <- parseFields installDirsFields u fs + return (u', g) + | name' == "global" = do g' <- parseFields installDirsFields g fs + return (u, g') + | otherwise = do + warning "The install-paths section should be for 'user' or 'global'" + return accum + where name' = lowercase name + parseSections accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +showConfig :: SavedConfig -> String +showConfig = showConfigWithComments mempty + +showConfigWithComments :: SavedConfig -> SavedConfig -> String +showConfigWithComments comment vals = Disp.render $ + ppFields configFieldDescriptions comment vals + $+$ Disp.text "" + $+$ installDirsSection "user" savedUserInstallDirs + $+$ Disp.text "" + $+$ installDirsSection "global" savedGlobalInstallDirs + where + installDirsSection name field = + ppSection "install-dirs" name installDirsFields + (field comment) (field vals) + +------------------------ +-- * Parsing utils +-- + +--FIXME: replace this with something better in Cabal-1.5 +parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a +parseFields fields initial = foldM setField initial + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning $ "Unrecognized field " ++ name ++ " on line " ++ show line + return accum + setField accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +-- | This is a customised version of the function from Cabal that also prints +-- default values for empty fields as comments. +-- +ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc +ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur) + | FieldDescr name getter _ <- fields] + +ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc +ppField name def cur + | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def + | otherwise = Disp.text name <> Disp.colon <+> cur + +ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc +ppSection name arg fields def cur = + Disp.text name <+> Disp.text arg + $$ Disp.nest 2 (ppFields fields def cur) + +installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] +installDirsFields = map viewAsFieldDescr installDirsOptions + +--TODO: this is now exported in Cabal-1.5 +installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] +installDirsOptions = + [ option "" ["prefix"] + "bake this prefix in preparation of installation" + prefix (\v flags -> flags { prefix = v }) + installDirArg + + , option "" ["bindir"] + "installation directory for executables" + bindir (\v flags -> flags { bindir = v }) + installDirArg + + , option "" ["libdir"] + "installation directory for libraries" + libdir (\v flags -> flags { libdir = v }) + installDirArg + + , option "" ["libsubdir"] + "subdirectory of libdir in which libs are installed" + libsubdir (\v flags -> flags { libsubdir = v }) + installDirArg + + , option "" ["libexecdir"] + "installation directory for program executables" + libexecdir (\v flags -> flags { libexecdir = v }) + installDirArg + + , option "" ["datadir"] + "installation directory for read-only data" + datadir (\v flags -> flags { datadir = v }) + installDirArg + + , option "" ["datasubdir"] + "subdirectory of datadir in which data files are installed" + datasubdir (\v flags -> flags { datasubdir = v }) + installDirArg + + , option "" ["docdir"] + "installation directory for documentation" + docdir (\v flags -> flags { docdir = v }) + installDirArg + + , option "" ["htmldir"] + "installation directory for HTML documentation" + htmldir (\v flags -> flags { htmldir = v }) + installDirArg + + , option "" ["haddockdir"] + "installation directory for haddock interfaces" + haddockdir (\v flags -> flags { haddockdir = v }) + installDirArg + ] + where + installDirArg _sf _lf d get set = + reqArgFlag "DIR" _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + + reqArgFlag ad = reqArg ad (fmap toFlag (readP_to_E err parseFilePathQ)) + (map (show . showFilePath) . flagToList) + where err _ = "paths with spaces must use Haskell String syntax" diff --git a/cabal-install-0.8.2/Distribution/Client/Configure.hs b/cabal-install-0.8.2/Distribution/Client/Configure.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Configure.hs @@ -0,0 +1,205 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Configure +-- Copyright : (c) David Himmelstrup 2005, +-- Duncan Coutts 2005 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- High level interface to configuring a package. +----------------------------------------------------------------------------- +module Distribution.Client.Configure ( + configure, + ) where + +import Data.Monoid + ( Monoid(mempty) ) +import qualified Data.Map as Map + +import Distribution.Client.Dependency + ( resolveDependenciesWithProgress + , PackageConstraint(..) + , PackagesPreference(..), PackagesPreferenceDefault(..) + , PackagePreference(..) + , Progress(..), foldProgress, ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, getInstalledPackages ) +import Distribution.Client.Setup + ( ConfigExFlags(..), configureCommand, filterConfigureFlags ) +import Distribution.Client.Types as Available + ( AvailablePackage(..), AvailablePackageSource(..), Repo(..) + , AvailablePackageDb(..), ConfiguredPackage(..), InstalledPackage ) +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) + +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId) + , PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration ) +import Distribution.Simple.Setup + ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Simple.Utils + ( defaultPackageDesc ) +import Distribution.Package + ( PackageName, packageName, packageVersion + , Package(..), Dependency(..), thisPackageVersion ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Version + ( VersionRange, anyVersion, thisVersion ) +import Distribution.Simple.Utils as Utils + ( notice, info, die ) +import Distribution.System + ( Platform, buildPlatform ) +import Distribution.Verbosity as Verbosity + ( Verbosity ) + +-- | Configure the package found in the local directory +configure :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ConfigFlags + -> ConfigExFlags + -> [String] + -> IO () +configure verbosity packageDBs repos comp conf + configFlags configExFlags extraArgs = do + + installed <- getInstalledPackages verbosity comp packageDBs conf + available <- getAvailablePackages verbosity repos + + progress <- planLocalPackage verbosity comp configFlags configExFlags + installed available + + notice verbosity "Resolving dependencies..." + maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) + (return . Left) (return . Right) progress + case maybePlan of + Left message -> do + info verbosity message + setupWrapper verbosity (setupScriptOptions installed) Nothing + configureCommand (const configFlags) extraArgs + + Right installPlan -> case InstallPlan.ready installPlan of + [pkg@(ConfiguredPackage (AvailablePackage _ _ LocalUnpackedPackage) _ _)] -> + configurePackage verbosity + (InstallPlan.planPlatform installPlan) + (InstallPlan.planCompiler installPlan) + (setupScriptOptions installed) + configFlags pkg extraArgs + + _ -> die $ "internal error: configure install plan should have exactly " + ++ "one local ready package." + + where + setupScriptOptions index = SetupScriptOptions { + useCabalVersion = maybe anyVersion thisVersion + (flagToMaybe (configCabalVersion configExFlags)), + useCompiler = Just comp, + -- Hack: we typically want to allow the UserPackageDB for finding the + -- Cabal lib when compiling any Setup.hs even if we're doing a global + -- install. However we also allow looking in a specific package db. + usePackageDB = if UserPackageDB `elem` packageDBs + then packageDBs + else packageDBs ++ [UserPackageDB], + usePackageIndex = if UserPackageDB `elem` packageDBs + then index + else Nothing, + useProgramConfig = conf, + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags), + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + +-- | Make an 'InstallPlan' for the unpacked package in the current directory, +-- and all its dependencies. +-- +planLocalPackage :: Verbosity -> Compiler + -> ConfigFlags -> ConfigExFlags + -> Maybe (PackageIndex InstalledPackage) + -> AvailablePackageDb + -> IO (Progress String String InstallPlan) +planLocalPackage verbosity comp configFlags configExFlags installed + (AvailablePackageDb _ availablePrefs) = do + pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity + let -- The trick is, we add the local package to the available index and + -- remove it from the installed index. Then we ask to resolve a + -- dependency on exactly that package. So the resolver ends up having + -- to pick the local package. + available' = PackageIndex.insert localPkg mempty + installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed + localPkg = AvailablePackage { + packageInfoId = packageId pkg, + Available.packageDescription = pkg, + packageSource = LocalUnpackedPackage + } + targets = [packageName pkg] + constraints = [PackageVersionConstraint (packageName pkg) + (thisVersion (packageVersion pkg)) + ,PackageFlagsConstraint (packageName pkg) + (configConfigurationsFlags configFlags)] + ++ [ PackageVersionConstraint name ver + | Dependency name ver <- configConstraints configFlags ] + preferences = mergePackagePrefs PreferLatestForSelected + availablePrefs configExFlags + + return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) + installed' available' preferences constraints targets + + +mergePackagePrefs :: PackagesPreferenceDefault + -> Map.Map PackageName VersionRange + -> ConfigExFlags + -> PackagesPreference +mergePackagePrefs defaultPref availablePrefs configExFlags = + PackagesPreference defaultPref $ + -- The preferences that come from the hackage index + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList availablePrefs ] + -- additional preferences from the config file or command line + ++ [ PackageVersionPreference name ver + | Dependency name ver <- configPreferences configExFlags ] + +-- | Call an installer for an 'AvailablePackage' but override the configure +-- flags with the ones given by the 'ConfiguredPackage'. In particular the +-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +configurePackage :: Verbosity + -> Platform -> CompilerId + -> SetupScriptOptions + -> ConfigFlags + -> ConfiguredPackage + -> [String] + -> IO () +configurePackage verbosity platform comp scriptOptions configFlags + (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs = + + setupWrapper verbosity + scriptOptions (Just pkg) configureCommand configureFlags extraArgs + + where + configureFlags = filterConfigureFlags configFlags { + configConfigurationsFlags = flags, + configConstraints = map thisPackageVersion deps, + configVerbosity = toFlag verbosity + } + + pkg = case finalizePackageDescription flags + (const True) + platform comp [] gpkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency.hs b/cabal-install-0.8.2/Distribution/Client/Dependency.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Dependency.hs @@ -0,0 +1,233 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007 +-- Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Top level interface to dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency ( + module Distribution.Client.Dependency.Types, + resolveDependencies, + resolveDependenciesWithProgress, + + dependencyConstraints, + dependencyTargets, + + PackagesPreference(..), + PackagesPreferenceDefault(..), + PackagePreference(..), + + upgradableDependencies, + ) where + +import Distribution.Client.Dependency.Bogus (bogusResolver) +import Distribution.Client.Dependency.TopDown (topDownResolver) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Types + ( UnresolvedDependency(..), AvailablePackage(..), InstalledPackage ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) + , PackagePreferences(..), InstalledPreference(..) + , Progress(..), foldProgress ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), packageVersion, packageName + , Dependency(..), Package(..), PackageFixedDeps(..) ) +import Distribution.Version + ( VersionRange, anyVersion, orLaterVersion, isAnyVersion ) +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.System + ( Platform ) +import Distribution.Simple.Utils (comparing) +import Distribution.Client.Utils (mergeBy, MergeResult(..)) + +import Data.List (maximumBy) +import Data.Monoid (Monoid(mempty)) +import Data.Maybe (fromMaybe) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Set (Set) +import Control.Exception (assert) + +defaultResolver :: DependencyResolver +defaultResolver = topDownResolver + +-- | Global policy for the versions of all packages. +-- +data PackagesPreference = PackagesPreference + PackagesPreferenceDefault + [PackagePreference] + +dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint] +dependencyConstraints deps = + [ PackageVersionConstraint name versionRange + | UnresolvedDependency (Dependency name versionRange) _ <- deps + , not (isAnyVersion versionRange) ] + + ++ [ PackageFlagsConstraint name flags + | UnresolvedDependency (Dependency name _) flags <- deps + , not (null flags) ] + +dependencyTargets :: [UnresolvedDependency] -> [PackageName] +dependencyTargets deps = + [ name | UnresolvedDependency (Dependency name _) _ <- deps ] + +-- | Global policy for all packages to say if we prefer package versions that +-- are already installed locally or if we just prefer the latest available. +-- +data PackagesPreferenceDefault = + + -- | Always prefer the latest version irrespective of any existing + -- installed version. + -- + -- * This is the standard policy for upgrade. + -- + PreferAllLatest + + -- | Always prefer the installed versions over ones that would need to be + -- installed. Secondarily, prefer latest versions (eg the latest installed + -- version or if there are none then the latest available version). + | PreferAllInstalled + + -- | Prefer the latest version for packages that are explicitly requested + -- but prefers the installed version for any other packages. + -- + -- * This is the standard policy for install. + -- + | PreferLatestForSelected + +data PackagePreference + = PackageVersionPreference PackageName VersionRange + | PackageInstalledPreference PackageName InstalledPreference + +resolveDependencies :: Platform + -> CompilerId + -> Maybe (PackageIndex InstalledPackage) + -> PackageIndex AvailablePackage + -> PackagesPreference + -> [PackageConstraint] + -> [PackageName] + -> Either String InstallPlan +resolveDependencies platform comp installed available + preferences constraints targets = + foldProgress (flip const) Left Right $ + resolveDependenciesWithProgress platform comp installed available + preferences constraints targets + +resolveDependenciesWithProgress :: Platform + -> CompilerId + -> Maybe (PackageIndex InstalledPackage) + -> PackageIndex AvailablePackage + -> PackagesPreference + -> [PackageConstraint] + -> [PackageName] + -> Progress String String InstallPlan +resolveDependenciesWithProgress platform comp (Just installed) = + dependencyResolver defaultResolver platform comp installed + +resolveDependenciesWithProgress platform comp Nothing = + dependencyResolver bogusResolver platform comp mempty + +hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p +hideBrokenPackages index = + check (null . PackageIndex.brokenPackages) + . foldr (PackageIndex.deletePackageId . packageId) index + . PackageIndex.reverseDependencyClosure index + . map (packageId . fst) + $ PackageIndex.brokenPackages index + where + check p x = assert (p x) x + +dependencyResolver + :: DependencyResolver + -> Platform -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> PackagesPreference + -> [PackageConstraint] + -> [PackageName] + -> Progress String String InstallPlan +dependencyResolver resolver platform comp installed available + pref constraints targets = + let installed' = hideBrokenPackages installed + -- If the user is not explicitly asking to upgrade base then lets + -- prevent that from happening accidentally since it is usually not what + -- you want and it probably does not work anyway. We do it by adding a + -- constraint to only pick an installed version of base and ghc-prim. + extraConstraints = + [ PackageInstalledConstraint pkgname + | all (/=PackageName "base") targets + , pkgname <- [ PackageName "base", PackageName "ghc-prim" ] + , not (null (PackageIndex.lookupPackageName installed pkgname)) ] + preferences = interpretPackagesPreference (Set.fromList targets) pref + in fmap toPlan + $ resolver platform comp installed' available + preferences (extraConstraints ++ constraints) targets + + where + toPlan pkgs = + case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of + Right plan -> plan + Left problems -> error $ unlines $ + "internal error: could not construct a valid install plan." + : "The proposed (invalid) plan contained the following problems:" + : map InstallPlan.showPlanProblem problems + +-- | Give an interpretation to the global 'PackagesPreference' as +-- specific per-package 'PackageVersionPreference'. +-- +interpretPackagesPreference :: Set PackageName + -> PackagesPreference + -> (PackageName -> PackagePreferences) +interpretPackagesPreference selected (PackagesPreference defaultPref prefs) = + \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname) + + where + versionPref pkgname = + fromMaybe anyVersion (Map.lookup pkgname versionPrefs) + versionPrefs = Map.fromList + [ (pkgname, pref) + | PackageVersionPreference pkgname pref <- prefs ] + + installPref pkgname = + fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) + installPrefs = Map.fromList + [ (pkgname, pref) + | PackageInstalledPreference pkgname pref <- prefs ] + installPrefDefault = case defaultPref of + PreferAllLatest -> \_ -> PreferLatest + PreferAllInstalled -> \_ -> PreferInstalled + PreferLatestForSelected -> \pkgname -> + -- When you say cabal install foo, what you really mean is, prefer the + -- latest version of foo, but the installed version of everything else + if pkgname `Set.member` selected then PreferLatest + else PreferInstalled + +-- | Given the list of installed packages and available packages, figure +-- out which packages can be upgraded. +-- +upgradableDependencies :: PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> [Dependency] +upgradableDependencies installed available = + [ Dependency name (orLaterVersion latestVersion) + -- This is really quick (linear time). The trick is that we're doing a + -- merge join of two tables. We can do it as a merge because they're in + -- a comparable order because we're getting them from the package indexs. + | InBoth latestInstalled allAvailable + <- mergeBy (\a (b:_) -> packageName a `compare` packageName b) + [ maximumBy (comparing packageVersion) pkgs + | pkgs <- PackageIndex.allPackagesByName installed ] + (PackageIndex.allPackagesByName available) + , let (PackageIdentifier name latestVersion) = packageId latestInstalled + , any (\p -> packageVersion p > latestVersion) allAvailable ] diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs @@ -0,0 +1,129 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.Bogus +-- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007 +-- Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A dependency resolver for when we do not know what packages are installed. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.Bogus ( + bogusResolver + ) where + +import Distribution.Client.Types + ( AvailablePackage(..), ConfiguredPackage(..) ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, Progress(..) + , PackageConstraint(..), PackagePreferences(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan + +import Distribution.Package + ( PackageName, PackageIdentifier(..), Dependency(..) + , Package(..), packageVersion ) +import Distribution.PackageDescription + ( GenericPackageDescription(..), CondTree(..), FlagAssignment ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Version + ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) +import Distribution.Simple.Utils + ( comparing ) +import Distribution.Text + ( display ) + +import Data.List + ( maximumBy ) +import Data.Maybe + ( fromMaybe ) +import qualified Data.Map as Map + +-- | This resolver thinks that every package is already installed. +-- +-- We need this for hugs and nhc98 which do not track installed packages. +-- We just pretend that everything is installed and hope for the best. +-- +bogusResolver :: DependencyResolver +bogusResolver platform comp _ available + preferences constraints targets = + resolveFromAvailable [] + (combineConstraints preferences constraints targets) + where + resolveFromAvailable chosen [] = Done chosen + resolveFromAvailable chosen ((name, verConstraint, flags, verPref): deps) = + case latestAvailableSatisfying available name verConstraint verPref of + Nothing -> Fail ("Unresolved dependency: " ++ display dep) + Just apkg@(AvailablePackage _ pkg _) -> + case finalizePackageDescription flags none platform comp [] pkg of + Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps) + where + msg = "selecting " ++ display (packageId pkg) + cpkg = fudgeChosenPackage apkg flags' + chosen' = InstallPlan.Configured cpkg : chosen + _ -> error "bogusResolver: impossible happened" + where + none :: Dependency -> Bool + none = const True + where + dep = Dependency name verConstraint + +fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage +fudgeChosenPackage (AvailablePackage pkgid pkg source) flags = + ConfiguredPackage (AvailablePackage pkgid (stripDependencies pkg) source) + flags ([] :: [PackageIdentifier]) -- empty list of deps + where + -- | Pretend that a package has no dependencies. Go through the + -- 'GenericPackageDescription' and strip them all out. + -- + stripDependencies :: GenericPackageDescription -> GenericPackageDescription + stripDependencies gpkg = gpkg { + condLibrary = fmap stripDeps (condLibrary gpkg), + condExecutables = [ (name, stripDeps tree) + | (name, tree) <- condExecutables gpkg ] + } + stripDeps :: CondTree v [Dependency] a -> CondTree v [Dependency] a + stripDeps = mapTreeConstrs (const []) + + mapTreeConstrs :: (c -> c) -> CondTree v c a -> CondTree v c a + mapTreeConstrs f (CondNode a c ifs) = CondNode a (f c) (map g ifs) + where + g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me) + +combineConstraints :: (PackageName -> PackagePreferences) + -> [PackageConstraint] + -> [PackageName] + -> [(PackageName, VersionRange, FlagAssignment, VersionRange)] +combineConstraints preferences constraints targets = + [ (name, ver, flags, pref) + | name <- targets + , let ver = fromMaybe anyVersion (Map.lookup name versionConstraints) + flags = fromMaybe [] (Map.lookup name flagsConstraints) + PackagePreferences pref _ = preferences name ] + where + versionConstraints = Map.fromListWith intersectVersionRanges + [ (name, versionRange) + | PackageVersionConstraint name versionRange <- constraints ] + + flagsConstraints = Map.fromListWith (++) + [ (name, flags) + | PackageFlagsConstraint name flags <- constraints ] + +-- | Gets the best available package satisfying a dependency. +-- +latestAvailableSatisfying :: PackageIndex AvailablePackage + -> PackageName -> VersionRange -> VersionRange + -> Maybe AvailablePackage +latestAvailableSatisfying index name versionConstraint versionPreference = + case PackageIndex.lookupDependency index dep of + [] -> Nothing + pkgs -> Just (maximumBy best pkgs) + where + dep = Dependency name versionConstraint + best = comparing (\p -> (isPreferred p, packageVersion p)) + isPreferred p = packageVersion p `withinRange` versionPreference diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs @@ -0,0 +1,776 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Common types for dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown ( + topDownResolver + ) where + +import Distribution.Client.Dependency.TopDown.Types +import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints +import Distribution.Client.Dependency.TopDown.Constraints + ( Satisfiable(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( PlanPackage(..) ) +import Distribution.Client.Types + ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) + , PackagePreferences(..), InstalledPreference(..) + , Progress(..), foldProgress ) + +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Package + ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName + , Dependency(Dependency), thisPackageVersion, notThisPackageVersion + , PackageFixedDeps(depends) ) +import Distribution.PackageDescription + ( PackageDescription(buildDepends) ) +import Distribution.Client.PackageUtils + ( externalBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription, flattenPackageDescription ) +import Distribution.Version + ( VersionRange, anyVersion, withinRange, simplifyVersionRange + , UpperBound(..), asVersionIntervals ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( Platform ) +import Distribution.Simple.Utils + ( equating, comparing ) +import Distribution.Text + ( display ) + +import Data.List + ( foldl', maximumBy, minimumBy, nub, sort, groupBy ) +import Data.Maybe + ( fromJust, fromMaybe, catMaybes ) +import Data.Monoid + ( Monoid(mempty) ) +import Control.Monad + ( guard ) +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Graph as Graph +import qualified Data.Array as Array +import Control.Exception + ( assert ) + +-- ------------------------------------------------------------ +-- * Search state types +-- ------------------------------------------------------------ + +type Constraints = Constraints.Constraints + InstalledPackageEx UnconfiguredPackage ExclusionReason +type SelectedPackages = PackageIndex SelectedPackage + +-- ------------------------------------------------------------ +-- * The search tree type +-- ------------------------------------------------------------ + +data SearchSpace inherited pkg + = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]] + | Failure Failure + +-- ------------------------------------------------------------ +-- * Traverse a search tree +-- ------------------------------------------------------------ + +explore :: (PackageName -> PackagePreferences) + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage + -> Progress Log Failure (SelectedPackages, Constraints) + +explore _ (Failure failure) = Fail failure +explore _ (ChoiceNode (s,c,_) []) = Done (s,c) +explore pref (ChoiceNode _ choices) = + case [ choice | [choice] <- choices ] of + ((_, node'):_) -> Step (logInfo node') (explore pref node') + [] -> Step (logInfo node') (explore pref node') + where + choice = minimumBy (comparing topSortNumber) choices + pkgname = packageName . fst . head $ choice + (_, node') = maximumBy (bestByPref pkgname) choice + where + topSortNumber choice = case fst (head choice) of + InstalledOnly (InstalledPackageEx _ i _) -> i + AvailableOnly (UnconfiguredPackage _ i _) -> i + InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i + + bestByPref pkgname = case packageInstalledPreference of + PreferLatest -> + comparing (\(p,_) -> ( isPreferred p, packageId p)) + PreferInstalled -> + comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p)) + where + isInstalled (AvailableOnly _) = False + isInstalled _ = True + isPreferred p = packageVersion p `withinRange` preferredVersions + (PackagePreferences preferredVersions packageInstalledPreference) + = pref pkgname + + logInfo node = Select selected discarded + where (selected, discarded) = case node of + Failure _ -> ([], []) + ChoiceNode (_,_,changes) _ -> changes + +-- ------------------------------------------------------------ +-- * Generate a search tree +-- ------------------------------------------------------------ + +type ConfigurePackage = PackageIndex SelectablePackage + -> SelectablePackage + -> Either [Dependency] SelectedPackage + +-- | (packages selected, packages discarded) +type SelectionChanges = ([SelectedPackage], [PackageIdentifier]) + +searchSpace :: ConfigurePackage + -> Constraints + -> SelectedPackages + -> SelectionChanges + -> Set PackageName + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage +searchSpace configure constraints selected changes next = + ChoiceNode (selected, constraints, changes) + [ [ (pkg, select name pkg) + | pkg <- PackageIndex.lookupPackageName available name ] + | name <- Set.elems next ] + where + available = Constraints.choices constraints + + select name pkg = case configure available pkg of + Left missing -> Failure $ ConfigureFailed pkg + [ (dep, Constraints.conflicting constraints dep) + | dep <- missing ] + Right pkg' -> case constrainDeps pkg' newDeps constraints [] of + Left failure -> Failure failure + Right (constraints', newDiscarded) -> + searchSpace configure + constraints' selected' (newSelected, newDiscarded) next' + where + selected' = foldl' (flip PackageIndex.insert) selected newSelected + newSelected = + case Constraints.isPaired constraints (packageId pkg) of + Nothing -> [pkg'] + Just pkgid' -> [pkg', pkg''] + where + Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p) + (PackageIndex.lookupPackageId available pkgid') + + newPkgs = [ name' + | dep <- newDeps + , let (Dependency name' _) = untagDependency dep + , null (PackageIndex.lookupPackageName selected' name') ] + newDeps = concatMap packageConstraints newSelected + next' = Set.delete name + $ foldl' (flip Set.insert) next newPkgs + +packageConstraints :: SelectedPackage -> [TaggedDependency] +packageConstraints = either installedConstraints availableConstraints + . preferAvailable + where + preferAvailable (InstalledOnly pkg) = Left pkg + preferAvailable (AvailableOnly pkg) = Right pkg + preferAvailable (InstalledAndAvailable _ pkg) = Right pkg + installedConstraints (InstalledPackageEx _ _ deps) = + [ TaggedDependency InstalledConstraint (thisPackageVersion dep) + | dep <- deps ] + availableConstraints (SemiConfiguredPackage _ _ deps) = + [ TaggedDependency NoInstalledConstraint dep | dep <- deps ] + +constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints + -> [PackageIdentifier] + -> Either Failure (Constraints, [PackageIdentifier]) +constrainDeps pkg [] cs discard = + case addPackageSelectConstraint (packageId pkg) cs of + Satisfiable cs' discard' -> Right (cs', discard' ++ discard) + _ -> impossible +constrainDeps pkg (dep:deps) cs discard = + case addPackageDependencyConstraint (packageId pkg) dep cs of + Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard) + Unsatisfiable -> impossible + ConflictsWith conflicts -> + Left (DependencyConflict pkg dep conflicts) + +-- ------------------------------------------------------------ +-- * The main algorithm +-- ------------------------------------------------------------ + +search :: ConfigurePackage + -> (PackageName -> PackagePreferences) + -> Constraints + -> Set PackageName + -> Progress Log Failure (SelectedPackages, Constraints) +search configure pref constraints = + explore pref . searchSpace configure constraints mempty ([], []) + +-- ------------------------------------------------------------ +-- * The top level resolver +-- ------------------------------------------------------------ + +-- | The main exported resolver, with string logging and failure types to fit +-- the standard 'DependencyResolver' interface. +-- +topDownResolver :: DependencyResolver +topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver' + where + mapMessages :: Progress Log Failure a -> Progress String String a + mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done + +-- | The native resolver with detailed structured logging and failure types. +-- +topDownResolver' :: Platform -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> (PackageName -> PackagePreferences) + -> [PackageConstraint] + -> [PackageName] + -> Progress Log Failure [PlanPackage] +topDownResolver' platform comp installed available + preferences constraints targets = + fmap (uncurry finalise) + . (\cs -> search configure preferences cs initialPkgNames) + =<< addTopLevelConstraints constraints constraintSet + + where + configure = configurePackage platform comp + constraintSet :: Constraints + constraintSet = Constraints.empty + (annotateInstalledPackages topSortNumber installed') + (annotateAvailablePackages constraints topSortNumber available') + (installed', available') = selectNeededSubset installed available + initialPkgNames + topSortNumber = topologicalSortNumbering installed' available' + + initialPkgNames = Set.fromList targets + + finalise selected' constraints' = + PackageIndex.allPackages + . fst . improvePlan installed' constraints' + . PackageIndex.fromList + $ finaliseSelectedPackages preferences selected' constraints' + +addTopLevelConstraints :: [PackageConstraint] -> Constraints + -> Progress a Failure Constraints +addTopLevelConstraints [] cs = Done cs +addTopLevelConstraints (PackageFlagsConstraint _ _ :deps) cs = + addTopLevelConstraints deps cs + +addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs = + case addTopLevelVersionConstraint pkg ver cs of + Satisfiable cs' _ -> + addTopLevelConstraints deps cs' + + Unsatisfiable -> + Fail (TopLevelVersionConstraintUnsatisfiable pkg ver) + + ConflictsWith conflicts -> + Fail (TopLevelVersionConstraintConflict pkg ver conflicts) + +addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs = + case addTopLevelInstalledConstraint pkg cs of + Satisfiable cs' _ -> addTopLevelConstraints deps cs' + + Unsatisfiable -> + Fail (TopLevelInstallConstraintUnsatisfiable pkg) + + ConflictsWith conflicts -> + Fail (TopLevelInstallConstraintConflict pkg conflicts) + +configurePackage :: Platform -> CompilerId -> ConfigurePackage +configurePackage platform comp available spkg = case spkg of + InstalledOnly ipkg -> Right (InstalledOnly ipkg) + AvailableOnly apkg -> fmap AvailableOnly (configure apkg) + InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg) + (configure apkg) + where + configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) = + case finalizePackageDescription flags dependencySatisfiable + platform comp [] p of + Left missing -> Left missing + Right (pkg, flags') -> Right $ + SemiConfiguredPackage apkg flags' (externalBuildDepends pkg) + + dependencySatisfiable = not . null . PackageIndex.lookupDependency available + +-- | Annotate each installed packages with its set of transative dependencies +-- and its topological sort number. +-- +annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) + -> PackageIndex InstalledPackage + -> PackageIndex InstalledPackageEx +annotateInstalledPackages dfsNumber installed = PackageIndex.fromList + [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) + | pkg <- PackageIndex.allPackages installed ] + where + transitiveDepends :: InstalledPackage -> [PackageIdentifier] + transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph + . fromJust . toVertex . packageId + (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed + + +-- | Annotate each available packages with its topological sort number and any +-- user-supplied partial flag assignment. +-- +annotateAvailablePackages :: [PackageConstraint] + -> (PackageName -> TopologicalSortNumber) + -> PackageIndex AvailablePackage + -> PackageIndex UnconfiguredPackage +annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList + [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) + | pkg <- PackageIndex.allPackages available + , let name = packageName pkg ] + where + flagsFor = fromMaybe [] . flip Map.lookup flagsMap + flagsMap = Map.fromList + [ (name, flags) + | PackageFlagsConstraint name flags <- constraints ] + +-- | One of the heuristics we use when guessing which path to take in the +-- search space is an ordering on the choices we make. It's generally better +-- to make decisions about packages higer in the dep graph first since they +-- place constraints on packages lower in the dep graph. +-- +-- To pick them in that order we annotate each package with its topological +-- sort number. So if package A depends on package B then package A will have +-- a lower topological sort number than B and we'll make a choice about which +-- version of A to pick before we make a choice about B (unless there is only +-- one possible choice for B in which case we pick that immediately). +-- +-- To construct these topological sort numbers we combine and flatten the +-- installed and available package sets. We consider only dependencies between +-- named packages, not including versions and for not-yet-configured packages +-- we look at all the possible dependencies, not just those under any single +-- flag assignment. This means we can actually get impossible combinations of +-- edges and even cycles, but that doesn't really matter here, it's only a +-- heuristic. +-- +topologicalSortNumbering :: PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> (PackageName -> TopologicalSortNumber) +topologicalSortNumbering installed available = + \pkgname -> let Just vertex = toVertex pkgname + in topologicalSortNumbers Array.! vertex + where + topologicalSortNumbers = Array.array (Array.bounds graph) + (zip (Graph.topSort graph) [0..]) + (graph, _, toVertex) = Graph.graphFromEdges $ + [ ((), packageName pkg, nub deps) + | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed + , let deps = [ packageName dep + | pkg' <- pkgs + , dep <- depends pkg' ] ] + ++ [ ((), packageName pkg, nub deps) + | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available + , let deps = [ depName + | AvailablePackage _ pkg' _ <- pkgs + , Dependency depName _ <- + buildDepends (flattenPackageDescription pkg') ] ] + +-- | We don't need the entire index (which is rather large and costly if we +-- force it by examining the whole thing). So trace out the maximul subset of +-- each index that we could possibly ever need. Do this by flattening packages +-- and looking at the names of all possible dependencies. +-- +selectNeededSubset :: PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> Set PackageName + -> (PackageIndex InstalledPackage + ,PackageIndex AvailablePackage) +selectNeededSubset installed available = select mempty mempty + where + select :: PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> Set PackageName + -> (PackageIndex InstalledPackage + ,PackageIndex AvailablePackage) + select installed' available' remaining + | Set.null remaining = (installed', available') + | otherwise = select installed'' available'' remaining'' + where + (next, remaining') = Set.deleteFindMin remaining + moreInstalled = PackageIndex.lookupPackageName installed next + moreAvailable = PackageIndex.lookupPackageName available next + moreRemaining = -- we filter out packages already included in the indexes + -- this avoids an infinite loop if a package depends on itself + -- like base-3.0.3.0 with base-4.0.0.0 + filter notAlreadyIncluded + $ [ packageName dep + | pkg <- moreInstalled + , dep <- depends pkg ] + ++ [ name + | AvailablePackage _ pkg _ <- moreAvailable + , Dependency name _ <- + buildDepends (flattenPackageDescription pkg) ] + installed'' = foldl' (flip PackageIndex.insert) installed' moreInstalled + available'' = foldl' (flip PackageIndex.insert) available' moreAvailable + remaining'' = foldl' (flip Set.insert) remaining' moreRemaining + notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name) + && null (PackageIndex.lookupPackageName available' name) + +-- ------------------------------------------------------------ +-- * Post processing the solution +-- ------------------------------------------------------------ + +finaliseSelectedPackages :: (PackageName -> PackagePreferences) + -> SelectedPackages + -> Constraints + -> [PlanPackage] +finaliseSelectedPackages pref selected constraints = + map finaliseSelected (PackageIndex.allPackages selected) + where + remainingChoices = Constraints.choices constraints + finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg + finaliseSelected (AvailableOnly apkg) = finaliseAvailable Nothing apkg + finaliseSelected (InstalledAndAvailable ipkg apkg) = + case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of + Nothing -> impossible --picked package not in constraints + Just (AvailableOnly _) -> impossible --to constrain to avail only + Just (InstalledOnly _) -> finaliseInstalled ipkg + Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg + + finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg + finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) = + InstallPlan.Configured (ConfiguredPackage pkg flags deps') + where + 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 = + comparing (\p -> (isCurrent p, isPreferred p, packageVersion p)) + -- Is the package already used by the installed version of this + -- package? If so we should pick that first. This stops us from doing + -- silly things like deciding to rebuild haskell98 against base 3. + isCurrent = case mipkg :: Maybe InstalledPackageEx of + Nothing -> \_ -> False + Just ipkg -> \p -> packageId p `elem` depends ipkg + -- 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] = + case Constraints.isPaired constraints (packageId p1) of + Just p2' -> packageId p2' == packageId p2 + Nothing -> False + checkIsPaired _ = False + +-- | Improve an existing installation plan by, where possible, swapping +-- packages we plan to install with ones that are already installed. +-- This may add additional constraints due to the dependencies of installed +-- packages on other installed packages. +-- +improvePlan :: PackageIndex InstalledPackage + -> Constraints + -> PackageIndex PlanPackage + -> (PackageIndex PlanPackage, Constraints) +improvePlan installed constraints0 selected0 = + foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0) + where + improve (selected, constraints) = fromMaybe (selected, constraints) + . improvePkg selected constraints + + -- The idea is to improve the plan by swapping a configured package for + -- an equivalent installed one. For a particular package the condition is + -- that the package be in a configured state, that a the same version be + -- already installed with the exact same dependencies and all the packages + -- in the plan that it depends on are in the installed state + improvePkg selected constraints pkgid = do + Configured pkg <- PackageIndex.lookupPackageId selected pkgid + ipkg <- PackageIndex.lookupPackageId installed pkgid + guard $ all (isInstalled selected) (depends pkg) + tryInstalled selected constraints [ipkg] + + isInstalled selected pkgid = + case PackageIndex.lookupPackageId selected pkgid of + Just (PreExisting _) -> True + _ -> False + + tryInstalled :: PackageIndex PlanPackage -> Constraints + -> [InstalledPackage] + -> Maybe (PackageIndex PlanPackage, Constraints) + tryInstalled selected constraints [] = Just (selected, constraints) + tryInstalled selected constraints (pkg:pkgs) = + case constraintsOk (packageId pkg) (depends pkg) constraints of + Nothing -> Nothing + Just constraints' -> tryInstalled selected' constraints' pkgs' + where + selected' = PackageIndex.insert (PreExisting pkg) selected + pkgs' = catMaybes (map notSelected (depends pkg)) ++ pkgs + notSelected pkgid = + case (PackageIndex.lookupPackageId installed pkgid + ,PackageIndex.lookupPackageId selected pkgid) of + (Just pkg', Nothing) -> Just pkg' + _ -> Nothing + + constraintsOk _ [] constraints = Just constraints + constraintsOk pkgid (pkgid':pkgids) constraints = + case addPackageDependencyConstraint pkgid dep constraints of + Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints' + _ -> Nothing + where + dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid') + + reverseTopologicalOrder :: PackageFixedDeps pkg + => PackageIndex pkg -> [PackageIdentifier] + reverseTopologicalOrder index = map (packageId . toPkg) + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkg, _) = PackageIndex.dependencyGraph index + +-- ------------------------------------------------------------ +-- * Adding and recording constraints +-- ------------------------------------------------------------ + +addPackageSelectConstraint :: PackageIdentifier -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addPackageSelectConstraint pkgid constraints = + Constraints.constrain dep reason constraints + where + dep = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid) + reason = SelectedOther pkgid + +addPackageExcludeConstraint :: PackageIdentifier -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addPackageExcludeConstraint pkgid constraints = + Constraints.constrain dep reason constraints + where + dep = TaggedDependency NoInstalledConstraint + (notThisPackageVersion pkgid) + reason = ExcludedByConfigureFail + +addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addPackageDependencyConstraint pkgid dep constraints = + Constraints.constrain dep reason constraints + where + reason = ExcludedByPackageDependency pkgid dep + +addTopLevelVersionConstraint :: PackageName -> VersionRange + -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addTopLevelVersionConstraint pkg ver constraints = + Constraints.constrain taggedDep reason constraints + where + dep = Dependency pkg ver + taggedDep = TaggedDependency NoInstalledConstraint dep + reason = ExcludedByTopLevelDependency dep + +addTopLevelInstalledConstraint :: PackageName + -> Constraints + -> Satisfiable Constraints + [PackageIdentifier] ExclusionReason +addTopLevelInstalledConstraint pkg constraints = + Constraints.constrain taggedDep reason constraints + where + dep = Dependency pkg anyVersion + taggedDep = TaggedDependency InstalledConstraint dep + reason = ExcludedByTopLevelDependency dep + +-- ------------------------------------------------------------ +-- * Reasons for constraints +-- ------------------------------------------------------------ + +-- | For every constraint we record we also record the reason that constraint +-- is needed. So if we end up failing due to conflicting constraints then we +-- can give an explnanation as to what was conflicting and why. +-- +data ExclusionReason = + + -- | We selected this other version of the package. That means we exclude + -- all the other versions. + SelectedOther PackageIdentifier + + -- | We excluded this version of the package because it failed to + -- configure probably because of unsatisfiable deps. + | ExcludedByConfigureFail + + -- | We excluded this version of the package because another package that + -- we selected imposed a dependency which this package did not satisfy. + | ExcludedByPackageDependency PackageIdentifier TaggedDependency + + -- | We excluded this version of the package because it did not satisfy + -- a dependency given as an original top level input. + -- + | ExcludedByTopLevelDependency Dependency + +-- | Given an excluded package and the reason it was excluded, produce a human +-- readable explanation. +-- +showExclusionReason :: PackageIdentifier -> ExclusionReason -> String +showExclusionReason pkgid (SelectedOther pkgid') = + display pkgid ++ " was excluded because " ++ + display pkgid' ++ " was selected instead" +showExclusionReason pkgid ExcludedByConfigureFail = + display pkgid ++ " was excluded because it could not be configured" +showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) = + display pkgid ++ " was excluded because " ++ + display pkgid' ++ " requires " ++ displayDep (untagDependency dep) +showExclusionReason pkgid (ExcludedByTopLevelDependency dep) = + display pkgid ++ " was excluded because of the top level dependency " ++ + displayDep dep + + +-- ------------------------------------------------------------ +-- * Logging progress and failures +-- ------------------------------------------------------------ + +data Log = Select [SelectedPackage] [PackageIdentifier] +data Failure + = ConfigureFailed + SelectablePackage + [(Dependency, [(PackageIdentifier, [ExclusionReason])])] + | DependencyConflict + SelectedPackage TaggedDependency + [(PackageIdentifier, [ExclusionReason])] + | TopLevelVersionConstraintConflict + PackageName VersionRange + [(PackageIdentifier, [ExclusionReason])] + | TopLevelVersionConstraintUnsatisfiable + PackageName VersionRange + | TopLevelInstallConstraintConflict + PackageName + [(PackageIdentifier, [ExclusionReason])] + | TopLevelInstallConstraintUnsatisfiable + PackageName + +showLog :: Log -> String +showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of + ("", y) -> y + (x, "") -> x + (x, y) -> x ++ " and " ++ y + + where + selectedMsg = "selecting " ++ case selected of + [] -> "" + [s] -> display (packageId s) ++ " " ++ kind s + (s:ss) -> listOf id + $ (display (packageId s) ++ " " ++ kind s) + : [ display (packageVersion s') ++ " " ++ kind s' + | s' <- ss ] + + kind (InstalledOnly _) = "(installed)" + kind (AvailableOnly _) = "(hackage)" + kind (InstalledAndAvailable _ _) = "(installed or hackage)" + + discardedMsg = case discarded of + [] -> "" + _ -> "discarding " ++ listOf id + [ element + | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded) + , element <- display pkgid : map (display . packageVersion) pkgids ] + +showFailure :: Failure -> String +showFailure (ConfigureFailed pkg missingDeps) = + "cannot configure " ++ displayPkg pkg ++ ". It requires " + ++ 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 " ++ displayVer ver + + whyNot dep conflicts = + "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 + | (pkg', reasons) <- conflicts, reason <- reasons ] + + where pkgs = map fst conflicts + +showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) = + "dependencies conflict: " + ++ 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 " ++ 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 " ++ displayVer ver + +showFailure (TopLevelInstallConstraintConflict name conflicts) = + "constraints conflict: " + ++ "top level constraint " ++ display name ++ "-installed however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +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 +-- ------------------------------------------------------------ + +impossible :: a +impossible = internalError "impossible" + +internalError :: String -> a +internalError msg = error $ "internal error: " ++ msg + +displayPkg :: Package pkg => pkg -> String +displayPkg = display . packageId + +listOf :: (a -> String) -> [a] -> String +listOf _ [] = [] +listOf disp [x0] = disp x0 +listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs + where go x [] = " and " ++ disp x + go x (x':xs') = ", " ++ disp x ++ go x' xs' diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs @@ -0,0 +1,316 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.TopDown.Constraints +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A set of satisfiable dependencies (package version constraints). +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown.Constraints ( + Constraints, + empty, + choices, + isPaired, + + constrain, + Satisfiable(..), + conflicting, + ) where + +import Distribution.Client.Dependency.TopDown.Types +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Package + ( PackageName, PackageIdentifier(..) + , Package(packageId), packageName, packageVersion + , PackageFixedDeps(depends) + , Dependency(Dependency) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) + +import Data.List + ( foldl' ) +import Data.Monoid + ( Monoid(mempty) ) +import Data.Maybe + ( catMaybes ) +import qualified Data.Map as Map +import Data.Map (Map) +import Control.Exception + ( assert ) + +-- | A set of constraints on package versions. For each package name we record +-- what other packages depends on it and what constraints they impose on the +-- version of the package. +-- +data (Package installed, Package available) + => Constraints installed available reason + = Constraints + + -- Remaining available choices + (PackageIndex (InstalledOrAvailable installed available)) + + -- Paired choices + (Map PackageName (Version, Version)) + + -- Choices that we have excluded for some reason + -- usually by applying constraints + (PackageIndex (ExcludedPackage PackageIdentifier reason)) + + -- Purely for the invariant, we keep a copy of the original index + (PackageIndex (InstalledOrAvailable installed available)) + + +data ExcludedPackage pkg reason + = ExcludedPackage pkg [reason] -- reasons for excluding just the available + [reason] -- reasons for excluding installed and avail + +instance Package pkg => Package (ExcludedPackage pkg reason) where + packageId (ExcludedPackage p _ _) = packageId p + +-- | There is a conservation of packages property. Packages are never gained or +-- lost, they just transfer from the remaining pot to the excluded pot. +-- +invariant :: (Package installed, Package available) + => Constraints installed available a -> Bool +invariant (Constraints available _ excluded original) = all check merged + where + merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b) + (PackageIndex.allPackages original) + (mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages available) + (PackageIndex.allPackages excluded)) + where + mergedPackageId (OnlyInLeft p ) = packageId p + mergedPackageId (OnlyInRight p) = packageId p + mergedPackageId (InBoth p _) = packageId p + + check (InBoth (InstalledOnly _) cur) = case cur of + -- If the package was originally installed only then + -- now it's either still remaining as installed only + -- or it has been excluded in which case we excluded both + -- installed and available since it was only installed + OnlyInLeft (InstalledOnly _) -> True + OnlyInRight (ExcludedPackage _ [] (_:_)) -> True + _ -> False + + check (InBoth (AvailableOnly _) cur) = case cur of + -- If the package was originally available only then + -- now it's either still remaining as available only + -- or it has been excluded in which case we excluded both + -- installed and available since it was only available + OnlyInLeft (AvailableOnly _) -> True + OnlyInRight (ExcludedPackage _ [] (_:_)) -> True + _ -> True + + -- If the package was originally installed and available + -- then there are three cases. + check (InBoth (InstalledAndAvailable _ _) cur) = case cur of + -- We can have both remaining: + OnlyInLeft (InstalledAndAvailable _ _) -> True + -- both excluded, in particular it can have had the available excluded + -- and later had both excluded so we do not mind if the available excluded + -- is empty or non-empty. + OnlyInRight (ExcludedPackage _ _ (_:_)) -> True + -- the installed remaining and the available excluded: + InBoth (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> True + _ -> False + + check _ = False + +-- | An update to the constraints can move packages between the two piles +-- but not gain or loose packages. +transitionsTo :: (Package installed, Package available) + => Constraints installed available a + -> Constraints installed available a -> Bool +transitionsTo constraints @(Constraints available _ excluded _) + constraints'@(Constraints available' _ excluded' _) = + invariant constraints && invariant constraints' + && null availableGained && null excludedLost + && map packageId availableLost == map packageId excludedGained + + where + availableLost = foldr lost [] availableChange where + lost (OnlyInLeft pkg) rest = pkg : rest + lost (InBoth (InstalledAndAvailable _ pkg) + (InstalledOnly _)) rest = AvailableOnly pkg : rest + lost _ rest = rest + availableGained = [ pkg | OnlyInRight pkg <- availableChange ] + excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ] + excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ] + ++ [ pkg | InBoth (ExcludedPackage _ (_:_) []) + pkg@(ExcludedPackage _ (_:_) (_:_)) + <- excludedChange ] + availableChange = mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages available) + (PackageIndex.allPackages available') + excludedChange = mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages excluded) + (PackageIndex.allPackages excluded') + +-- | We construct 'Constraints' with an initial 'PackageIndex' of all the +-- packages available. +-- +empty :: (PackageFixedDeps installed, Package available) + => PackageIndex installed + -> PackageIndex available + -> Constraints installed available reason +empty installed available = Constraints pkgs pairs mempty pkgs + where + pkgs = PackageIndex.fromList + . map toInstalledOrAvailable + $ mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages installed) + (PackageIndex.allPackages available) + toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i + toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a + toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a + + -- pick up cases like base-3 and 4 where one version depends on the other: + pairs = Map.fromList + [ (name, (packageVersion pkgid1, packageVersion pkgid2)) + | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed + , let name = packageName pkg1 + pkgid1 = packageId pkg1 + pkgid2 = packageId pkg2 + , any ((pkgid1==) . packageId) (depends pkg2) + || any ((pkgid2==) . packageId) (depends pkg1) ] + +-- | The package choices that are still available. +-- +choices :: (Package installed, Package available) + => Constraints installed available reason + -> PackageIndex (InstalledOrAvailable installed available) +choices (Constraints available _ _ _) = available + +isPaired :: (Package installed, Package available) + => Constraints installed available reason + -> PackageIdentifier -> Maybe PackageIdentifier +isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) = + case Map.lookup name pairs of + Just (v1, v2) + | version == v1 -> Just (PackageIdentifier name v2) + | version == v2 -> Just (PackageIdentifier name v1) + _ -> Nothing + +data Satisfiable constraints discarded reason + = Satisfiable constraints discarded + | Unsatisfiable + | ConflictsWith [(PackageIdentifier, [reason])] + +constrain :: (Package installed, Package available) + => TaggedDependency + -> reason + -> Constraints installed available reason + -> Satisfiable (Constraints installed available reason) + [PackageIdentifier] reason +constrain (TaggedDependency installedConstraint (Dependency name versionRange)) + reason constraints@(Constraints available paired excluded original) + + | not anyRemaining + = if null conflicts then Unsatisfiable + else ConflictsWith conflicts + + | otherwise + = let constraints' = Constraints available' paired excluded' original + in assert (constraints `transitionsTo` constraints') $ + Satisfiable constraints' (map packageId newExcluded) + + where + -- This tells us if any packages would remain at all for this package name if + -- we applied this constraint. This amounts to checking if any package + -- satisfies the given constraint, including version range and installation + -- status. + -- + anyRemaining = any satisfiesConstraint availableChoices + + conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll) + | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices + , satisfiesVersionConstraint pkg ] + + -- Applying this constraint may involve deleting some choices for this + -- package name, or restricting which install states are available. + available' = updateAvailable available + updateAvailable = flip (foldl' (flip update)) availableChoices where + update pkg | not (satisfiesVersionConstraint pkg) + = PackageIndex.deletePackageId (packageId pkg) + update _ | installedConstraint == NoInstalledConstraint + = id + update pkg = case pkg of + InstalledOnly _ -> id + AvailableOnly _ -> PackageIndex.deletePackageId (packageId pkg) + InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i) + + -- Applying the constraint means adding exclusions for the packages that + -- we're just freshly excluding, ie the ones we're removing from available. + excluded' = foldl' (flip PackageIndex.insert) excluded + (newExcluded ++ oldExcluded) + + newExcluded = catMaybes (map exclude availableChoices) where + exclude pkg + | not (satisfiesVersionConstraint pkg) + = Just (ExcludedPackage pkgid [] [reason]) + | installedConstraint == NoInstalledConstraint + = Nothing + | otherwise = case pkg of + InstalledOnly _ -> Nothing + AvailableOnly _ -> Just (ExcludedPackage pkgid [] [reason]) + InstalledAndAvailable _ _ -> + case PackageIndex.lookupPackageId excluded pkgid of + Just (ExcludedPackage _ avail both) + -> Just (ExcludedPackage pkgid (reason:avail) both) + Nothing -> Just (ExcludedPackage pkgid [reason] []) + where pkgid = packageId pkg + + -- Additionally we have to add extra exclusions for any already-excluded + -- packages that happen to be covered by the (inverse of the) constraint. + oldExcluded = catMaybes (map exclude excludedChoices) where + exclude (ExcludedPackage pkgid avail both) + -- if it doesn't satisfy the version constraint then we exclude the + -- package as a whole, the available or the installed instances or both. + | not (satisfiesVersionConstraint pkgid) + = Just (ExcludedPackage pkgid avail (reason:both)) + -- if on the other hand it does satisfy the constraint and we were also + -- constraining to just the installed version then we exclude just the + -- available instance. + | installedConstraint == InstalledConstraint + = Just (ExcludedPackage pkgid (reason:avail) both) + | otherwise = Nothing + + -- util definitions + availableChoices = PackageIndex.lookupPackageName available name + excludedChoices = PackageIndex.lookupPackageName excluded name + + satisfiesConstraint pkg = satisfiesVersionConstraint pkg + && satisfiesInstallStateConstraint pkg + + satisfiesVersionConstraint :: Package pkg => pkg -> Bool + satisfiesVersionConstraint = case Map.lookup name paired of + Nothing -> \pkg -> + packageVersion pkg `withinRange` versionRange + Just (v1, v2) -> \pkg -> case packageVersion pkg of + v | v == v1 + || v == v2 -> v1 `withinRange` versionRange + || v2 `withinRange` versionRange + | otherwise -> v `withinRange` versionRange + + satisfiesInstallStateConstraint = case installedConstraint of + NoInstalledConstraint -> \_ -> True + InstalledConstraint -> \pkg -> case pkg of + AvailableOnly _ -> False + _ -> True + +conflicting :: (Package installed, Package available) + => Constraints installed available reason + -> Dependency + -> [(PackageIdentifier, [reason])] +conflicting (Constraints _ _ excluded _) dep = + [ (pkgid, reasonsAvail ++ reasonsAll) --TODO + | ExcludedPackage pkgid reasonsAvail reasonsAll <- + PackageIndex.lookupDependency excluded dep ] diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.TopDown.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Types for the top-down dependency resolver. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown.Types where + +import Distribution.Client.Types + ( AvailablePackage(..), InstalledPackage ) + +import Distribution.Package + ( PackageIdentifier, Dependency + , Package(packageId), PackageFixedDeps(depends) ) +import Distribution.PackageDescription + ( FlagAssignment ) + +-- ------------------------------------------------------------ +-- * The various kinds of packages +-- ------------------------------------------------------------ + +type SelectablePackage + = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage + +type SelectedPackage + = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage + +data InstalledOrAvailable installed available + = InstalledOnly installed + | AvailableOnly available + | InstalledAndAvailable installed available + +type TopologicalSortNumber = Int + +data InstalledPackageEx + = InstalledPackageEx + InstalledPackage + !TopologicalSortNumber + [PackageIdentifier] -- transative closure of installed deps + +data UnconfiguredPackage + = UnconfiguredPackage + AvailablePackage + !TopologicalSortNumber + FlagAssignment + +data SemiConfiguredPackage + = SemiConfiguredPackage + AvailablePackage -- package info + FlagAssignment -- total flag assignment for the package + [Dependency] -- dependencies we end up with when we apply + -- the flag assignment + +instance Package InstalledPackageEx where + packageId (InstalledPackageEx p _ _) = packageId p + +instance PackageFixedDeps InstalledPackageEx where + depends (InstalledPackageEx _ _ deps) = deps + +instance Package UnconfiguredPackage where + packageId (UnconfiguredPackage p _ _) = packageId p + +instance Package SemiConfiguredPackage where + packageId (SemiConfiguredPackage p _ _) = packageId p + +instance (Package installed, Package available) + => Package (InstalledOrAvailable installed available) where + packageId (InstalledOnly p ) = packageId p + packageId (AvailableOnly p ) = packageId p + packageId (InstalledAndAvailable p _) = packageId p + +-- ------------------------------------------------------------ +-- * Tagged Dependency type +-- ------------------------------------------------------------ + +-- | Installed packages can only depend on other installed packages while +-- packages that are not yet installed but which we plan to install can depend +-- on installed or other not-yet-installed packages. +-- +-- This makes life more complex as we have to remember these constraints. +-- +data TaggedDependency = TaggedDependency InstalledConstraint Dependency +data InstalledConstraint = InstalledConstraint | NoInstalledConstraint + deriving Eq + +untagDependency :: TaggedDependency -> Dependency +untagDependency (TaggedDependency _ dep) = dep diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Common types for dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.Types ( + DependencyResolver, + + PackageConstraint(..), + PackagePreferences(..), + InstalledPreference(..), + + Progress(..), + foldProgress, + ) where + +import Distribution.Client.Types + ( AvailablePackage(..), InstalledPackage ) +import qualified Distribution.Client.InstallPlan as InstallPlan + +import Distribution.PackageDescription + ( FlagAssignment ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import Distribution.Package + ( PackageName ) +import Distribution.Version + ( VersionRange ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( Platform ) + +import Prelude hiding (fail) + +-- | A dependency resolver is a function that works out an installation plan +-- given the set of installed and available packages and a set of deps to +-- solve for. +-- +-- The reason for this interface is because there are dozens of approaches to +-- solving the package dependency problem and we want to make it easy to swap +-- in alternatives. +-- +type DependencyResolver = Platform + -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex AvailablePackage + -> (PackageName -> PackagePreferences) + -> [PackageConstraint] + -> [PackageName] + -> Progress String String [InstallPlan.PlanPackage] + +-- | Per-package constraints. Package constraints must be respected by the +-- solver. Multiple constraints for each package can be given, though obviously +-- it is possible to construct conflicting constraints (eg impossible version +-- range or inconsistent flag assignment). +-- +data PackageConstraint + = PackageVersionConstraint PackageName VersionRange + | PackageInstalledConstraint PackageName + | PackageFlagsConstraint PackageName FlagAssignment + +-- | A per-package preference on the version. It is a soft constraint that the +-- 'DependencyResolver' should try to respect where possible. It consists of +-- a 'InstalledPreference' which says if we prefer versions of packages +-- that are already installed. It also hase a 'PackageVersionPreference' which +-- is a suggested constraint on the version number. The resolver should try to +-- use package versions that satisfy the suggested version constraint. +-- +-- It is not specified if preferences on some packages are more important than +-- others. +-- +data PackagePreferences = PackagePreferences VersionRange InstalledPreference + +-- | Wether we prefer an installed version of a package or simply the latest +-- version. +-- +data InstalledPreference = PreferInstalled | PreferLatest + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail. We may get intermediate steps before the final +-- retult which may be used to indicate progress and\/or logging messages. +-- +data Progress step fail done = Step step (Progress step fail done) + | Fail fail + | Done done + +-- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with +-- two base cases, one for a final result and one for failure. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +-- +foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) + -> Progress step fail done -> a +foldProgress step fail done = fold + where fold (Step s p) = step s (fold p) + fold (Fail f) = fail f + fold (Done r) = done r + +instance Functor (Progress step fail) where + fmap f = foldProgress Step Fail (Done . f) + +instance Monad (Progress step fail) where + return a = Done a + p >>= f = foldProgress Step Fail f p diff --git a/cabal-install-0.8.2/Distribution/Client/Fetch.hs b/cabal-install-0.8.2/Distribution/Client/Fetch.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Fetch.hs @@ -0,0 +1,192 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Fetch +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Fetch ( + + -- * Commands + fetch, + + -- * Utilities + fetchPackage, + isFetched, + downloadIndex, + ) where + +import Distribution.Client.Types + ( UnresolvedDependency (..), AvailablePackage(..) + , AvailablePackageSource(..), AvailablePackageDb(..) + , Repo(..), RemoteRepo(..), LocalRepo(..) ) +import Distribution.Client.Dependency + ( resolveDependenciesWithProgress + , dependencyConstraints, dependencyTargets + , PackagesPreference(..), PackagesPreferenceDefault(..) + , PackagePreference(..) ) +import Distribution.Client.Dependency.Types + ( foldProgress ) +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, disambiguateDependencies + , getInstalledPackages ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.HttpUtils + ( downloadURI, isOldHackageURI ) + +import Distribution.Package + ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Simple.Compiler + ( Compiler(compilerId), PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import Distribution.Simple.Utils + ( die, notice, info, debug, setupMessage ) +import Distribution.System + ( buildPlatform ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import qualified Data.Map as Map +import Control.Monad + ( when, filterM ) +import System.Directory + ( doesFileExist, createDirectoryIfMissing ) +import System.FilePath + ( (), (<.>) ) +import qualified System.FilePath.Posix as FilePath.Posix + ( combine, joinPath ) +import Network.URI + ( URI(uriPath) ) + + +-- Downloads a package to [config-dir/packages/package-id] and returns the path to the package. +downloadPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String +downloadPackage _ repo@Repo{ repoKind = Right LocalRepo } pkgid = + return (packageFile repo pkgid) + +downloadPackage verbosity repo@Repo{ repoKind = Left remoteRepo } pkgid = do + let uri = packageURI remoteRepo pkgid + dir = packageDir repo pkgid + path = packageFile repo pkgid + debug verbosity $ "GET " ++ show uri + createDirectoryIfMissing True dir + downloadURI verbosity uri path + return path + +-- Downloads an index file to [config-dir/packages/serv-id]. +downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath +downloadIndex verbosity repo cacheDir = do + let uri = (remoteRepoURI repo) { + uriPath = uriPath (remoteRepoURI repo) + `FilePath.Posix.combine` "00-index.tar.gz" + } + path = cacheDir "00-index" <.> "tar.gz" + createDirectoryIfMissing True cacheDir + downloadURI verbosity uri path + return path + +-- |Returns @True@ if the package has already been fetched. +isFetched :: AvailablePackage -> IO Bool +isFetched (AvailablePackage pkgid _ source) = case source of + LocalUnpackedPackage -> return True + RepoTarballPackage repo -> doesFileExist (packageFile repo pkgid) + +-- |Fetch a package if we don't have it already. +fetchPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String +fetchPackage verbosity repo pkgid = do + fetched <- doesFileExist (packageFile repo pkgid) + if fetched + then do info verbosity $ display pkgid ++ " has already been downloaded." + return (packageFile repo pkgid) + else do setupMessage verbosity "Downloading" pkgid + downloadPackage verbosity repo pkgid + +-- |Fetch a list of packages and their dependencies. +fetch :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> [UnresolvedDependency] + -> IO () +fetch verbosity packageDBs repos comp conf deps = do + installed <- getInstalledPackages verbosity comp packageDBs conf + AvailablePackageDb available availablePrefs + <- getAvailablePackages verbosity repos + deps' <- IndexUtils.disambiguateDependencies available deps + + let -- Hide the packages given on the command line so that the dep resolver + -- will decide that they need fetching, even if they're already + -- installed. Sicne we want to get the source packages of things we might + -- have installed (but not have the sources for). + installed' = fmap (hideGivenDeps deps') installed + hideGivenDeps pkgs index = + foldr PackageIndex.deletePackageName index + [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] + + let progress = resolveDependenciesWithProgress + buildPlatform (compilerId comp) + installed' available + (PackagesPreference PreferLatestForSelected + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList availablePrefs ]) + (dependencyConstraints deps') + (dependencyTargets deps') + notice verbosity "Resolving dependencies..." + maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) + (return . Left) (return . Right) progress + case maybePlan of + Left message -> die message + Right pkgs -> do + ps <- filterM (fmap not . isFetched) + [ pkg | (InstallPlan.Configured + (InstallPlan.ConfiguredPackage pkg _ _)) + <- InstallPlan.toList pkgs ] + when (null ps) $ + notice verbosity $ "No packages need to be fetched. " + ++ "All the requested packages are already cached." + + sequence_ + [ fetchPackage verbosity repo pkgid + | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- ps ] + +-- |Generate the full path to the locally cached copy of +-- the tarball for a given @PackageIdentifer@. +packageFile :: Repo -> PackageIdentifier -> FilePath +packageFile repo pkgid = packageDir repo pkgid + display pkgid + <.> "tar.gz" + +-- |Generate the full path to the directory where the local cached copy of +-- the tarball for a given @PackageIdentifer@ is stored. +packageDir :: Repo -> PackageIdentifier -> FilePath +packageDir repo pkgid = repoLocalDir repo + display (packageName pkgid) + display (packageVersion pkgid) + +-- | Generate the URI of the tarball for a given package. +packageURI :: RemoteRepo -> PackageIdentifier -> URI +packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,display (packageName pkgid) + ,display (packageVersion pkgid) + ,display pkgid <.> "tar.gz"] + } +packageURI repo pkgid = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,"package" + ,display pkgid <.> "tar.gz"] + } diff --git a/cabal-install-0.8.2/Distribution/Client/Haddock.hs b/cabal-install-0.8.2/Distribution/Client/Haddock.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Haddock.hs @@ -0,0 +1,101 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Haddock +-- Copyright : (c) Andrea Vezzosi 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Interfacing with Haddock +-- +----------------------------------------------------------------------------- +module Distribution.Client.Haddock + ( + regenerateHaddockIndex + ) + where + +import Data.Maybe (listToMaybe) +import Data.List (maximumBy) +import Control.Monad (guard) +import System.Directory (createDirectoryIfMissing, doesFileExist, + renameFile) +import System.FilePath ((), splitFileName) +import Distribution.Package (Package(..)) +import Distribution.Simple.Program (haddockProgram, ProgramConfiguration + , rawSystemProgram, requireProgramVersion) +import Distribution.Version (Version(Version), orLaterVersion) +import Distribution.Verbosity (Verbosity) +import Distribution.Text (display) +import Distribution.Client.PackageIndex(PackageIndex, allPackages, + allPackagesByName, fromList) +import Distribution.Simple.Utils + ( comparing, intercalate, debug + , installDirectoryContents, withTempDirectory ) +import Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo + , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) ) +import Distribution.Client.Types + ( InstalledPackage(..) ) + +regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO () +regenerateHaddockIndex verbosity pkgs conf index = do + (paths,warns) <- haddockPackagePaths pkgs' + case warns of + Nothing -> return () + Just m -> debug verbosity m + + (confHaddock, _, _) <- + requireProgramVersion verbosity haddockProgram + (orLaterVersion (Version [0,6] [])) conf + + createDirectoryIfMissing True destDir + + withTempDirectory verbosity destDir "htemp" $ \tempDir -> do + + let flags = ["--gen-contents", "--gen-index", "--odir="++tempDir] + ++ map (\(i,h) -> "--read-interface=" ++ h ++ "," ++ i) paths + rawSystemProgram verbosity confHaddock flags + renameFile (tempDir "index.html") (tempDir destFile) + installDirectoryContents verbosity tempDir destDir + + where + (destDir,destFile) = splitFileName index + pkgs' = map (maximumBy $ comparing packageId) + . allPackagesByName + . fromList + . filter exposed + . map (\(InstalledPackage pkg _) -> pkg) + . allPackages + $ pkgs + +haddockPackagePaths :: [InstalledPackageInfo] + -> IO ([(FilePath, FilePath)], Maybe [Char]) +haddockPackagePaths pkgs = do + interfaces <- sequence + [ case interfaceAndHtmlPath pkg of + Just (interface, html) -> do + exists <- doesFileExist interface + if exists + then return (pkgid, Just (interface, html)) + else return (pkgid, Nothing) + Nothing -> return (pkgid, Nothing) + | pkg <- pkgs, let pkgid = packageId pkg ] + + let missing = [ pkgid | (pkgid, Nothing) <- interfaces ] + + warning = "The documentation for the following packages are not " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map display missing) + + flags = [ x | (_, Just x) <- interfaces ] + + return (flags, if null missing then Nothing else Just warning) + + where + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + guard (not . null $ html) + return (interface, html) diff --git a/cabal-install-0.8.2/Distribution/Client/HttpUtils.hs b/cabal-install-0.8.2/Distribution/Client/HttpUtils.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/HttpUtils.hs @@ -0,0 +1,197 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | Separate module for HTTP actions, using a proxy server if one exists +----------------------------------------------------------------------------- +module Distribution.Client.HttpUtils ( + downloadURI, + getHTTP, + proxy, + isOldHackageURI + ) where + +import Network.HTTP + ( Request (..), Response (..), RequestMethod (..) + , Header(..), HeaderName(..) ) +import Network.URI + ( URI (..), URIAuth (..), parseAbsoluteURI ) +import Network.Stream + ( Result, ConnError(..) ) +import Network.Browser + ( Proxy (..), Authority (..), browse + , setOutHandler, setErrHandler, setProxy, request) +import Control.Monad + ( mplus, join, liftM2 ) +import qualified Data.ByteString.Lazy.Char8 as ByteString +import Data.ByteString.Lazy (ByteString) +#ifdef WIN32 +import System.Win32.Types + ( DWORD, HKEY ) +import System.Win32.Registry + ( hKEY_CURRENT_USER, regOpenKey, regCloseKey + , regQueryValue, regQueryValueEx ) +import Control.Exception + ( bracket ) +import Distribution.Compat.Exception + ( handleIO ) +import Foreign + ( toBool, Storable(peek, sizeOf), castPtr, alloca ) +#endif +import System.Environment (getEnvironment) + +import qualified Paths_cabal_install (version) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils + ( die, info, warn, debug + , copyFileVerbose, writeFileAtomic ) +import Distribution.Text + ( display ) +import qualified System.FilePath.Posix as FilePath.Posix + ( splitDirectories ) + +-- FIXME: all this proxy stuff is far too complicated, especially parsing +-- the proxy strings. Network.Browser should have a way to pick up the +-- proxy settings hiding all this system-dependent stuff below. + +-- try to read the system proxy settings on windows or unix +proxyString, envProxyString, registryProxyString :: IO (Maybe String) +#ifdef WIN32 +-- read proxy settings from the windows registry +registryProxyString = handleIO (\_ -> return Nothing) $ + bracket (regOpenKey hive path) regCloseKey $ \hkey -> do + enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" + if enable + then fmap Just $ regQueryValue hkey (Just "ProxyServer") + else return Nothing + where + -- some sources say proxy settings should be at + -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows + -- \CurrentVersion\Internet Settings\ProxyServer + -- but if the user sets them with IE connection panel they seem to + -- end up in the following place: + hive = hKEY_CURRENT_USER + path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" + + regQueryValueDWORD :: HKEY -> String -> IO DWORD + regQueryValueDWORD hkey name = alloca $ \ptr -> do + regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) + peek ptr +#else +registryProxyString = return Nothing +#endif + +-- read proxy settings by looking for an env var +envProxyString = do + env <- getEnvironment + return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) + +proxyString = liftM2 mplus envProxyString registryProxyString + + +-- |Get the local proxy settings +proxy :: Verbosity -> IO Proxy +proxy verbosity = do + mstr <- proxyString + case mstr of + Nothing -> return NoProxy + Just str -> case parseHttpProxy str of + Nothing -> do + warn verbosity $ "invalid http proxy uri: " ++ show str + warn verbosity $ "proxy uri must be http with a hostname" + warn verbosity $ "ignoring http proxy, trying a direct connection" + return NoProxy + Just p -> return p +--TODO: print info message when we're using a proxy + +-- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ +-- which lack the @\"http://\"@ URI scheme. The problem is that +-- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme +-- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. +-- +-- So our strategy is to try parsing as normal uri first and if it lacks the +-- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. +-- +parseHttpProxy :: String -> Maybe Proxy +parseHttpProxy str = join + . fmap uri2proxy + $ parseHttpURI str + `mplus` parseHttpURI ("http://" ++ str) + where + parseHttpURI str' = case parseAbsoluteURI str' of + Just uri@URI { uriAuthority = Just _ } + -> Just (fixUserInfo uri) + _ -> Nothing + +fixUserInfo :: URI -> URI +fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } + where + f a@URIAuth{ uriUserInfo = s } = + a{ uriUserInfo = case reverse s of + '@':s' -> reverse s' + _ -> s + } +uri2proxy :: URI -> Maybe Proxy +uri2proxy uri@URI{ uriScheme = "http:" + , uriAuthority = Just (URIAuth auth' host port) + } = Just (Proxy (host ++ port) auth) + where auth = if null auth' + then Nothing + else Just (AuthBasic "" usr pwd uri) + (usr,pwd') = break (==':') auth' + pwd = case pwd' of + ':':cs -> cs + _ -> pwd' +uri2proxy _ = Nothing + +mkRequest :: URI -> Request ByteString +mkRequest uri = Request{ rqURI = uri + , rqMethod = GET + , rqHeaders = [Header HdrUserAgent userAgent] + , rqBody = ByteString.empty } + where userAgent = "cabal-install/" ++ display Paths_cabal_install.version + +-- |Carry out a GET request, using the local proxy settings +getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString)) +getHTTP verbosity uri = do + p <- proxy verbosity + let req = mkRequest uri + (_, resp) <- browse $ do + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + setProxy p + request req + return (Right resp) + +downloadURI :: Verbosity + -> URI -- ^ What to download + -> FilePath -- ^ Where to put it + -> IO () +downloadURI verbosity uri path | uriScheme uri == "file:" = + copyFileVerbose verbosity (uriPath uri) path +downloadURI verbosity uri path = do + result <- getHTTP verbosity uri + let result' = case result of + Left err -> Left err + Right rsp -> case rspCode rsp of + (2,0,0) -> Right (rspBody rsp) + (a,b,c) -> Left err + where + err = ErrorMisc $ "Unsucessful HTTP code: " + ++ concatMap show [a,b,c] + + case result' of + Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err + Right body -> do + info verbosity ("Downloaded to " ++ path) + writeFileAtomic path (ByteString.unpack body) + --FIXME: check the content-length header matches the body length. + --TODO: stream the download into the file rather than buffering the whole + -- thing in memory. + -- remember the ETag so we can not re-download if nothing changed. + +-- Utility function for legacy support. +isOldHackageURI :: URI -> Bool +isOldHackageURI uri + = case uriAuthority uri of + Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> + FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"] + _ -> False diff --git a/cabal-install-0.8.2/Distribution/Client/IndexUtils.hs b/cabal-install-0.8.2/Distribution/Client/IndexUtils.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/IndexUtils.hs @@ -0,0 +1,301 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Extra utils related to the package indexes. +----------------------------------------------------------------------------- +module Distribution.Client.IndexUtils ( + getInstalledPackages, + getAvailablePackages, + + readPackageIndexFile, + readRepoIndex, + parseRepoIndex, + + disambiguatePackageName, + disambiguateDependencies + ) where + +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Types + ( UnresolvedDependency(..), AvailablePackage(..) + , AvailablePackageSource(..), Repo(..), RemoteRepo(..) + , AvailablePackageDb(..), InstalledPackage(..) ) + +import Distribution.Package + ( PackageId, PackageIdentifier(..), PackageName(..), Package(..) + , Dependency(Dependency), InstalledPackageId(..) ) +import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.PackageDescription + ( GenericPackageDescription ) +import Distribution.PackageDescription.Parse + ( parsePackageDescription ) +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import qualified Distribution.Simple.Configure as Configure + ( getInstalledPackages ) +import Distribution.ParseUtils + ( ParseResult(..) ) +import Distribution.Version + ( Version(Version), intersectVersionRanges ) +import Distribution.Text + ( display, simpleParse ) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8) + +import Data.Maybe (catMaybes, fromMaybe) +import Data.List (isPrefixOf) +import Data.Monoid (Monoid(..)) +import qualified Data.Map as Map +import Control.Monad (MonadPlus(mplus), when) +import Control.Exception (evaluate) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import Data.ByteString.Lazy (ByteString) +import qualified Codec.Compression.GZip as GZip (decompress) +import System.FilePath ((), takeExtension, splitDirectories, normalise) +import System.FilePath.Posix as FilePath.Posix + ( takeFileName ) +import System.IO.Error (isDoesNotExistError) +import System.Directory + ( getModificationTime ) +import System.Time + ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) ) + +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -> ProgramConfiguration + -> IO (Maybe (PackageIndex InstalledPackage)) +getInstalledPackages verbosity comp packageDbs conf = + fmap (fmap convert) + (Configure.getInstalledPackages verbosity comp packageDbs conf) + where + convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage + convert index = PackageIndex.fromList $ + reverse -- because later ones mask earlier ones, but + -- InstalledPackageIndex.allPackages gives us the most preferred + -- instances first, when packages share a package id, like when + -- the same package is installed in the global & user dbs. + [ InstalledPackage ipkg (sourceDeps index ipkg) + | ipkg <- InstalledPackageIndex.allPackages index ] + + -- The InstalledPackageInfo only lists dependencies by the + -- InstalledPackageId, which means we do not directly know the corresponding + -- source dependency. The only way to find out is to lookup the + -- InstalledPackageId to get the InstalledPackageInfo and look at its + -- source PackageId. But if the package is broken because it depends on + -- other packages that do not exist then we have a problem we cannot find + -- the original source package id. Instead we make up a bogus package id. + -- This should have the same effect since it should be a dependency on a + -- non-existant package. + sourceDeps index ipkg = + [ maybe (brokenPackageId depid) packageId mdep + | let depids = InstalledPackageInfo.depends ipkg + getpkg = InstalledPackageIndex.lookupInstalledPackageId index + , (depid, mdep) <- zip depids (map getpkg depids) ] + + brokenPackageId (InstalledPackageId str) = + PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) + +-- | Read a repository index from disk, from the local files specified by +-- a list of 'Repo's. +-- +-- All the 'AvailablePackage's are marked as having come from the appropriate +-- 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb +getAvailablePackages verbosity [] = do + warn verbosity $ "No remote package servers have been specified. Usually " + ++ "you would have one specified in the config file." + return AvailablePackageDb { + packageIndex = mempty, + packagePreferences = mempty + } +getAvailablePackages verbosity repos = do + info verbosity "Reading available packages..." + pkgss <- mapM (readRepoIndex verbosity) repos + let (pkgs, prefs) = mconcat pkgss + prefs' = Map.fromListWith intersectVersionRanges + [ (name, range) | Dependency name range <- prefs ] + _ <- evaluate pkgs + _ <- evaluate prefs' + return AvailablePackageDb { + packageIndex = pkgs, + packagePreferences = prefs' + } + +-- | Read a repository index from disk, from the local file specified by +-- the 'Repo'. +-- +-- All the 'AvailablePackage's are marked as having come from the given 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +readRepoIndex :: Verbosity -> Repo + -> IO (PackageIndex AvailablePackage, [Dependency]) +readRepoIndex verbosity repo = handleNotFound $ do + let indexFile = repoLocalDir repo "00-index.tar" + (pkgs, prefs) <- either fail return + . foldlTarball extract ([], []) + =<< BS.readFile indexFile + + pkgIndex <- evaluate $ PackageIndex.fromList + [ AvailablePackage { + packageInfoId = pkgid, + packageDescription = pkg, + packageSource = RepoTarballPackage repo + } + | (pkgid, pkg) <- pkgs] + + warnIfIndexIsOld indexFile + return (pkgIndex, prefs) + + where + extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $ + (do pkg <- extractPkg entry; return (pkg:pkgs, prefs)) + `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs)) + + extractPrefs :: Tar.Entry -> Maybe [Dependency] + 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 + case repoKind repo of + Left remoteRepo -> warn verbosity $ + "The package list for '" ++ remoteRepoName remoteRepo + ++ "' does not exist. Run 'cabal update' to download it." + Right _localRepo -> warn verbosity $ + "The package list for the local repo '" ++ repoLocalDir repo + ++ "' is missing. The repo is invalid." + return mempty + else ioError e + + isOldThreshold = 15 --days + warnIfIndexIsOld indexFile = do + indexTime <- getModificationTime indexFile + currentTime <- getClockTime + let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime) + when (tdDay diff >= isOldThreshold) $ case repoKind repo of + Left remoteRepo -> warn verbosity $ + "The package list for '" ++ remoteRepoName remoteRepo + ++ "' is " ++ show (tdDay diff) ++ " days old.\nRun " + ++ "'cabal update' to get the latest list of available packages." + Right _localRepo -> return () + +parsePreferredVersions :: String -> [Dependency] +parsePreferredVersions = catMaybes + . map simpleParse + . filter (not . isPrefixOf "--") + . lines + +-- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. +-- +-- This is supposed to be an \"all in one\" way to easily get at the info in +-- the hackage package index. +-- +-- It takes a function to map a 'GenericPackageDescription' into any more +-- specific instance of 'Package' that you might want to use. In the simple +-- case you can just use @\_ p -> p@ here. +-- +readPackageIndexFile :: Package pkg + => (PackageId -> GenericPackageDescription -> pkg) + -> FilePath -> IO (PackageIndex pkg) +readPackageIndexFile mkPkg indexFile = do + pkgs <- either fail return + . parseRepoIndex + . GZip.decompress + =<< BS.readFile indexFile + + evaluate $ PackageIndex.fromList + [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs] + +-- | Parse an uncompressed \"00-index.tar\" repository index file represented +-- as a 'ByteString'. +-- +parseRepoIndex :: ByteString + -> Either String [(PackageId, GenericPackageDescription)] +parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) [] + +extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) +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 + where + fileName = Tar.entryPath entry + +foldlTarball :: (a -> Tar.Entry -> a) -> a + -> ByteString -> Either String a +foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read + where + check _ (Tar.Fail err) = Left err + check ok Tar.Done = Right ok + check ok (Tar.Next e es) = check (e:ok) es + +-- | Disambiguate a set of packages using 'disambiguatePackage' and report any +-- ambiguities to the user. +-- +disambiguateDependencies :: PackageIndex AvailablePackage + -> [UnresolvedDependency] + -> IO [UnresolvedDependency] +disambiguateDependencies index deps = do + let names = [ (name, disambiguatePackageName index name) + | UnresolvedDependency (Dependency name _) _ <- deps ] + in case [ (name, matches) | (name, Right matches) <- names ] of + [] -> return + [ UnresolvedDependency (Dependency name vrange) flags + | (UnresolvedDependency (Dependency _ vrange) flags, + (_, Left name)) <- zip deps names ] + ambigious -> die $ unlines + [ if null matches + 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 ] + +-- | Given an index of known packages and a package name, 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 :: PackageIndex AvailablePackage + -> PackageName + -> Either PackageName [PackageName] +disambiguatePackageName index (PackageName name) = + case PackageIndex.searchByName index name of + PackageIndex.None -> Right [] + PackageIndex.Unambiguous pkgs -> Left (pkgName (packageId (head pkgs))) + PackageIndex.Ambiguous pkgss -> Right [ pkgName (packageId pkg) + | (pkg:_) <- pkgss ] diff --git a/cabal-install-0.8.2/Distribution/Client/Init.hs b/cabal-install-0.8.2/Distribution/Client/Init.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Init.hs @@ -0,0 +1,556 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Implementation of the 'cabal init' command, which creates an initial .cabal +-- file for a project. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init ( + + -- * Commands + initCabal + + ) where + +import System.IO + ( hSetBuffering, stdout, BufferMode(..) ) +import System.Directory + ( getCurrentDirectory ) +import Data.Time + ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) + +import Data.List + ( intersperse ) +import Data.Maybe + ( fromMaybe, isJust ) +import Data.Traversable + ( traverse ) +import Control.Monad + ( when ) +#if MIN_VERSION_base(3,0,0) +import Control.Monad + ( (>=>) ) +#endif + +import Text.PrettyPrint.HughesPJ hiding (mode, cat) + +import Data.Version + ( Version(..) ) +import Distribution.Version + ( orLaterVersion ) + +import Distribution.Client.Init.Types + ( InitFlags(..), PackageType(..), Category(..) ) +import Distribution.Client.Init.Licenses + ( bsd3, gplv2, gplv3, lgpl2, lgpl3 ) +import Distribution.Client.Init.Heuristics + ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms ) + +import Distribution.License + ( License(..), knownLicenses ) +import Distribution.ModuleName + ( ) -- for the Text instance + +import Distribution.ReadE + ( runReadE, readP_to_E ) +import Distribution.Simple.Setup + ( Flag(..), flagToMaybe ) +import Distribution.Text + ( display, Text(..) ) + +initCabal :: InitFlags -> IO () +initCabal initFlags = do + hSetBuffering stdout NoBuffering + + initFlags' <- extendFlags initFlags + + writeLicense initFlags' + writeSetupFile initFlags' + success <- writeCabalFile initFlags' + + when success $ generateWarnings initFlags' + +--------------------------------------------------------------------------- +-- Flag acquisition ----------------------------------------------------- +--------------------------------------------------------------------------- + +-- | Fill in more details by guessing, discovering, or prompting the +-- user. +extendFlags :: InitFlags -> IO InitFlags +extendFlags = getPackageName + >=> getVersion + >=> getLicense + >=> getAuthorInfo + >=> getHomepage + >=> getSynopsis + >=> getCategory + >=> getLibOrExec + >=> getSrcDir + >=> getModulesAndBuildTools + +-- | Combine two actions which may return a value, preferring the first. That +-- is, run the second action only if the first doesn't return a value. +infixr 1 ?>> +(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) +f ?>> g = do + ma <- f + if isJust ma + then return ma + else g + +-- | Witness the isomorphism between Maybe and Flag. +maybeToFlag :: Maybe a -> Flag a +maybeToFlag = maybe NoFlag Flag + +-- | Get the package name: use the package directory (supplied, or the current +-- directory by default) as a guess. +getPackageName :: InitFlags -> IO InitFlags +getPackageName flags = do + guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) + ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) + + pkgName' <- return (flagToMaybe $ packageName flags) + ?>> maybePrompt flags (promptStr "Package name" guess) + ?>> return guess + + return $ flags { packageName = maybeToFlag pkgName' } + +-- | Package version: use 0.1 as a last resort, but try prompting the user if +-- possible. +getVersion :: InitFlags -> IO InitFlags +getVersion flags = do + let v = Just $ Version { versionBranch = [0,1], versionTags = [] } + v' <- return (flagToMaybe $ version flags) + ?>> maybePrompt flags (prompt "Package version" v) + ?>> return v + return $ flags { version = maybeToFlag v' } + +-- | Choose a license. +getLicense :: InitFlags -> IO InitFlags +getLicense flags = do + lic <- return (flagToMaybe $ license flags) + ?>> fmap (fmap (either UnknownLicense id)) + (maybePrompt flags + (promptList "Please choose a license" + knownLicenses (Just BSD3) True)) + return $ flags { license = maybeToFlag lic } + +-- | The author's name and email. Prompt, or try to guess from an existing +-- darcs repo. +getAuthorInfo :: InitFlags -> IO InitFlags +getAuthorInfo flags = do + (authorName, authorEmail) <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail + authorName' <- return (flagToMaybe $ author flags) + ?>> maybePrompt flags (promptStr "Author name" authorName) + ?>> return authorName + + authorEmail' <- return (flagToMaybe $ email flags) + ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) + ?>> return authorEmail + + return $ flags { author = maybeToFlag authorName' + , email = maybeToFlag authorEmail' + } + +-- | Prompt for a homepage URL. +getHomepage :: InitFlags -> IO InitFlags +getHomepage flags = do + hp <- queryHomepage + hp' <- return (flagToMaybe $ homepage flags) + ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp) + ?>> return hp + + return $ flags { homepage = maybeToFlag hp' } + +-- | Right now this does nothing, but it could be changed to do some +-- intelligent guessing. +queryHomepage :: IO (Maybe String) +queryHomepage = return Nothing -- get default remote darcs repo? + +-- | Prompt for a project synopsis. +getSynopsis :: InitFlags -> IO InitFlags +getSynopsis flags = do + syn <- return (flagToMaybe $ synopsis flags) + ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) + + return $ flags { synopsis = maybeToFlag syn } + +-- | Prompt for a package category. +-- Note that it should be possible to do some smarter guessing here too, i.e. +-- look at the name of the top level source directory. +getCategory :: InitFlags -> IO InitFlags +getCategory flags = do + cat <- return (flagToMaybe $ category flags) + ?>> maybePrompt flags (promptList "Project category" [Codec ..] + Nothing True) + return $ flags { category = maybeToFlag cat } + +-- | Ask whether the project builds a library or executable. +getLibOrExec :: InitFlags -> IO InitFlags +getLibOrExec flags = do + isLib <- return (flagToMaybe $ packageType flags) + ?>> maybePrompt flags (either (const Library) id `fmap` + (promptList "What does the package build" + [Library, Executable] + Nothing False)) + ?>> return (Just Library) + + return $ flags { packageType = maybeToFlag isLib } + +-- | Try to guess the source root directory (don't prompt the user). +getSrcDir :: InitFlags -> IO InitFlags +getSrcDir flags = do + srcDirs <- return (sourceDirs flags) + ?>> guessSourceDirs + + return $ flags { sourceDirs = srcDirs } + +-- XXX +-- | Try to guess source directories. +guessSourceDirs :: IO (Maybe [String]) +guessSourceDirs = return Nothing + +-- | Get the list of exposed modules and extra tools needed to build them. +getModulesAndBuildTools :: InitFlags -> IO InitFlags +getModulesAndBuildTools flags = do + dir <- fromMaybe getCurrentDirectory + (fmap return . flagToMaybe $ packageDir flags) + + -- XXX really should use guessed source roots. + sourceFiles <- scanForModules dir + + mods <- return (exposedModules flags) + ?>> (return . Just . map moduleName $ sourceFiles) + + tools <- return (buildTools flags) + ?>> (return . Just . neededBuildPrograms $ sourceFiles) + + return $ flags { exposedModules = mods + , buildTools = tools } + +--------------------------------------------------------------------------- +-- Prompting/user interaction ------------------------------------------- +--------------------------------------------------------------------------- + +-- | Run a prompt or not based on the nonInteractive flag of the +-- InitFlags structure. +maybePrompt :: InitFlags -> IO t -> IO (Maybe t) +maybePrompt flags p = + case nonInteractive flags of + Flag True -> return Nothing + _ -> Just `fmap` p + +-- | Create a prompt with optional default value that returns a +-- String. +promptStr :: String -> Maybe String -> IO String +promptStr = promptDefault' Just id + +-- | Create a prompt with optional default value that returns a value +-- of some Text instance. +prompt :: Text t => String -> Maybe t -> IO t +prompt = promptDefault' + (either (const Nothing) Just . runReadE (readP_to_E id parse)) + display + +-- | Create a prompt with an optional default value. +promptDefault' :: (String -> Maybe t) -- ^ parser + -> (t -> String) -- ^ pretty-printer + -> String -- ^ prompt message + -> Maybe t -- ^ optional default value + -> IO t +promptDefault' parser pretty pr def = do + putStr $ mkDefPrompt pr (pretty `fmap` def) + inp <- getLine + case (inp, def) of + ("", Just d) -> return d + _ -> case parser inp of + Just t -> return t + Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" + promptDefault' parser pretty pr def + +-- | Create a prompt from a prompt string and a String representation +-- of an optional default value. +mkDefPrompt :: String -> Maybe String -> String +mkDefPrompt pr def = pr ++ defStr def ++ "? " + where defStr Nothing = "" + defStr (Just s) = " [default \"" ++ s ++ "\"]" + +-- | Create a prompt from a list of items. +promptList :: (Text t, Eq t) + => String -- ^ prompt + -> [t] -- ^ choices + -> Maybe t -- ^ optional default value + -> Bool -- ^ whether to allow an 'other' option + -> IO (Either String t) +promptList pr choices def other = do + putStrLn $ pr ++ ":" + let options1 = map (\c -> (Just c == def, display c)) choices + options2 = zip ([1..]::[Int]) + (options1 ++ if other then [(False, "Other (specify)")] + else []) + mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 + promptList' (length options2) choices def other + where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest + | otherwise = " " ++ star i ++ rest + where rest = show n ++ ") " + star True = "*" + star False = " " + +promptList' :: Text t => Int -> [t] -> Maybe t -> Bool -> IO (Either String t) +promptList' numChoices choices def other = do + putStr $ mkDefPrompt "Your choice" (display `fmap` def) + inp <- getLine + case (inp, def) of + ("", Just d) -> return $ Right d + _ -> case readMaybe inp of + Nothing -> invalidChoice inp + Just n -> getChoice n + where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." + promptList' numChoices choices def other + getChoice n | n < 1 || n > numChoices = invalidChoice (show n) + | n < numChoices || + (n == numChoices && not other) + = return . Right $ choices !! (n-1) + | otherwise = Left `fmap` promptStr "Please specify" Nothing + +readMaybe :: (Read a) => String -> Maybe a +readMaybe s = case reads s of + [(a,"")] -> Just a + _ -> Nothing + +--------------------------------------------------------------------------- +-- File generation ------------------------------------------------------ +--------------------------------------------------------------------------- + +writeLicense :: InitFlags -> IO () +writeLicense flags = do + message flags "Generating LICENSE..." + year <- getYear + let licenseFile = + case license flags of + Flag BSD3 -> Just $ bsd3 (fromMaybe "???" + . flagToMaybe + . author + $ flags) + (show year) + + Flag (GPL (Just (Version {versionBranch = [2]}))) + -> Just gplv2 + + Flag (GPL (Just (Version {versionBranch = [3]}))) + -> Just gplv3 + + Flag (LGPL (Just (Version {versionBranch = [2]}))) + -> Just lgpl2 + + Flag (LGPL (Just (Version {versionBranch = [3]}))) + -> Just lgpl3 + + _ -> Nothing + + case licenseFile of + Just licenseText -> writeFile "LICENSE" licenseText + Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." + +getYear :: IO Integer +getYear = do + u <- getCurrentTime + z <- getCurrentTimeZone + let l = utcToLocalTime z u + (y, _, _) = toGregorian $ localDay l + return y + +writeSetupFile :: InitFlags -> IO () +writeSetupFile flags = do + message flags "Generating Setup.hs..." + writeFile "Setup.hs" setupFile + where + setupFile = unlines + [ "import Distribution.Simple" + , "main = defaultMain" + ] + +writeCabalFile :: InitFlags -> IO Bool +writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do + message flags "Error: no package name provided." + return False +writeCabalFile flags@(InitFlags{packageName = Flag p}) = do + let cabalFileName = p ++ ".cabal" + message flags $ "Generating " ++ cabalFileName ++ "..." + writeFile cabalFileName (generateCabalFile cabalFileName flags) + return True + +-- | Generate a .cabal file from an InitFlags structure. NOTE: this +-- is rather ad-hoc! What we would REALLY like is to have a +-- standard low-level AST type representing .cabal files, which +-- preserves things like comments, and to write an *inverse* +-- parser/pretty-printer pair between .cabal files and this AST. +-- Then instead of this ad-hoc code we could just map an InitFlags +-- structure onto a low-level AST structure and use the existing +-- pretty-printing code to generate the file. +generateCabalFile :: String -> InitFlags -> String +generateCabalFile fileName c = render $ + (if (minimal c /= Flag True) + then showComment (Just $ fileName ++ " auto-generated by cabal init. For additional options, see http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.") + else empty) + $$ + vcat [ fieldS "Name" (packageName c) + (Just "The name of the package.") + True + + , field "Version" (version c) + (Just "The package version. See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.") + True + + , fieldS "Synopsis" (synopsis c) + (Just "A short (one-line) description of the package.") + True + + , fieldS "Description" NoFlag + (Just "A longer description of the package.") + True + + , fieldS "Homepage" (homepage c) + (Just "URL for the project homepage or repository.") + False + + , fieldS "Bug-reports" NoFlag + (Just "A URL where users can report bugs.") + False + + , field "License" (license c) + (Just "The license under which the package is released.") + True + + , fieldS "License-file" (Flag "LICENSE") + (Just "The file containing the license text.") + True + + , fieldS "Author" (author c) + (Just "The package author(s).") + True + + , fieldS "Maintainer" (email c) + (Just "An email address to which users can send suggestions, bug reports, and patches.") + True + + , fieldS "Copyright" NoFlag + (Just "A copyright notice.") + True + + , fieldS "Category" (either id display `fmap` category c) + Nothing + True + + , fieldS "Build-type" (Flag "Simple") + Nothing + True + + , fieldS "Extra-source-files" NoFlag + (Just "Extra files to be distributed with the package, such as examples or a README.") + True + + , field "Cabal-version" (Flag $ orLaterVersion (Version [1,2] [])) + (Just "Constraint on the version of Cabal needed to build this package.") + False + + , case packageType c of + Flag Executable -> + text "\nExecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat + [ fieldS "Main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True + + , generateBuildInfo c + ]) + Flag Library -> text "\nLibrary" $$ (nest 2 $ vcat + [ fieldS "Exposed-modules" (listField (exposedModules c)) + (Just "Modules exported by the library.") + True + + , generateBuildInfo c + ]) + _ -> empty + ] + where + generateBuildInfo :: InitFlags -> Doc + generateBuildInfo c' = vcat + [ fieldS "Build-depends" (listField (dependencies c')) + (Just "Packages needed in order to build this package.") + True + + , fieldS "Other-modules" (listField (otherModules c')) + (Just "Modules not exported by this package.") + True + + , fieldS "hs-source-dirs" (listFieldS (sourceDirs c')) + (Just "Directories other than the root containing source files.") + False + + , fieldS "Build-tools" (listFieldS (buildTools c')) + (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") + True + ] + + listField :: Text s => Maybe [s] -> Flag String + listField = listFieldS . fmap (map display) + + listFieldS :: Maybe [String] -> Flag String + listFieldS = Flag . maybe "" (concat . intersperse ", ") + + field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc + field s f = fieldS s (fmap display f) + + fieldS :: String -- ^ Name of the field + -> Flag String -- ^ Field contents + -> Maybe String -- ^ Comment to explain the field + -> Bool -- ^ Should the field be included (commented out) even if blank? + -> Doc + fieldS _ NoFlag _ inc | not inc || (minimal c == Flag True) = empty + fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty + fieldS s f com _ = case (isJust com, noComments c, minimal c) of + (_, _, Flag True) -> id + (_, Flag True, _) -> id + (True, _, _) -> (showComment com $$) . ($$ text "") + (False, _, _) -> ($$ text "") + $ + comment f <> text s <> colon + <> text (take (20 - length s) (repeat ' ')) + <> text (fromMaybe "" . flagToMaybe $ f) + comment NoFlag = text "-- " + comment (Flag "") = text "-- " + comment _ = text "" + + showComment :: Maybe String -> Doc + showComment (Just t) = vcat . map text + . map ("-- "++) . lines + . render . fsep . map text . words $ t + showComment Nothing = text "" + +-- | Generate warnings for missing fields etc. +generateWarnings :: InitFlags -> IO () +generateWarnings flags = do + message flags "" + when (synopsis flags `elem` [NoFlag, Flag ""]) + (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") + + message flags "You may want to edit the .cabal file and add a Description field." + +-- | Possibly generate a message to stdout, taking into account the +-- --quiet flag. +message :: InitFlags -> String -> IO () +message (InitFlags{quiet = Flag True}) _ = return () +message _ s = putStrLn s + +#if MIN_VERSION_base(3,0,0) +#else +(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) +f >=> g = \x -> f x >>= g +#endif diff --git a/cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs b/cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Heuristics +-- Copyright : (c) Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Heuristics for creating initial cabal files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Heuristics ( + guessPackageName, + scanForModules, SourceFileEntry(..), + neededBuildPrograms, + guessAuthorNameMail, + knownCategories, +) where +import Distribution.Simple.Setup(Flag(..)) +import Distribution.ModuleName ( ModuleName, fromString ) +import Distribution.Client.PackageIndex + ( allPackagesByName ) +import qualified Distribution.PackageDescription as PD + ( category, packageDescription ) +import Distribution.Simple.Utils + ( intercalate ) + +import Distribution.Client.Types ( packageDescription, AvailablePackageDb(..) ) +import Control.Monad (liftM ) +import Data.Char ( isUpper, isLower, isSpace ) +#if MIN_VERSION_base(3,0,3) +import Data.Either ( partitionEithers ) +#endif +import Data.Maybe ( catMaybes ) +import Data.Monoid ( mempty, mappend ) +import qualified Data.Set as Set ( fromList, toList ) +import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist, + getHomeDirectory, canonicalizePath ) +import System.Environment ( getEnvironment ) +import System.FilePath ( takeExtension, takeBaseName, dropExtension, + (), splitDirectories, makeRelative ) + +-- |Guess the package name based on the given root directory +guessPackageName :: FilePath -> IO String +guessPackageName = liftM (last . splitDirectories) . canonicalizePath + +-- |Data type of source files found in the working directory +data SourceFileEntry = SourceFileEntry + { relativeSourcePath :: FilePath + , moduleName :: ModuleName + , fileExtension :: String + } deriving Show + +-- |Search for source files in the given directory +-- and return pairs of guessed haskell source path and +-- module names. +scanForModules :: FilePath -> IO [SourceFileEntry] +scanForModules rootDir = scanForModulesIn rootDir rootDir + +scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry] +scanForModulesIn projectRoot srcRoot = scan srcRoot [] + where + scan dir hierarchy = do + entries <- getDirectoryContents (projectRoot dir) + (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries) + let modules = catMaybes [ guessModuleName hierarchy file | file <- files ] + recMods <- mapM (scanRecursive dir hierarchy) dirs + return $ concat (modules : recMods) + tagIsDir parent entry = do + isDir <- doesDirectoryExist (parent entry) + return $ (if isDir then Right else Left) entry + guessModuleName hierarchy entry + | takeBaseName entry == "Setup" = Nothing + | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext + | otherwise = Nothing + where + relRoot = makeRelative projectRoot srcRoot + unqualModName = dropExtension entry + modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy) + ext = case takeExtension entry of '.':e -> e; e -> e + scanRecursive parent hierarchy entry + | isUpper (head entry) = scan (parent entry) (entry : hierarchy) + | isLower (head entry) && entry /= "dist" = + scanForModulesIn projectRoot $ foldl () srcRoot (entry : hierarchy) + | otherwise = return [] + +-- Unfortunately we cannot use the version exported by Distribution.Simple.Program +knownSuffixHandlers :: [(String,String)] +knownSuffixHandlers = + [ ("gc", "greencard") + , ("chs", "chs") + , ("hsc", "hsc2hs") + , ("x", "alex") + , ("y", "happy") + , ("ly", "happy") + , ("cpphs", "cpp") + ] + +sourceExtensions :: [String] +sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers + +neededBuildPrograms :: [SourceFileEntry] -> [String] +neededBuildPrograms entries = + [ handler + | ext <- nubSet (map fileExtension entries) + , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers) + ] + +-- |Guess author and email +guessAuthorNameMail :: IO (Flag String, Flag String) +guessAuthorNameMail = + update (readFromFile authorRepoFile) mempty >>= + update (getAuthorHome >>= readFromFile) >>= + update readFromEnvironment + where + update _ info@(Flag _, Flag _) = return info + update extract info = liftM (`mappend` info) extract -- prefer info + readFromFile file = do + exists <- doesFileExist file + if exists then liftM nameAndMail (readFile file) else return mempty + readFromEnvironment = fmap extractFromEnvironment getEnvironment + extractFromEnvironment env = + let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env) + emailEnv = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env) + in darcsEmailEnv `mappend` emailEnv + getAuthorHome = liftM ( (".darcs" "author")) getHomeDirectory + authorRepoFile = "_darcs" "prefs" "author" + +-- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached +knownCategories :: AvailablePackageDb -> [String] +knownCategories (AvailablePackageDb available _) = nubSet $ + [ cat | pkg <- map head (allPackagesByName available) + , let catList = (PD.category . PD.packageDescription . packageDescription) pkg + , cat <- splitString ',' catList + ] + +-- Parse name and email, from darcs pref files or environment variable +nameAndMail :: String -> (Flag String, Flag String) +nameAndMail str + | all isSpace nameOrEmail = mempty + | null erest = (mempty, Flag $ trim nameOrEmail) + | otherwise = (Flag $ trim nameOrEmail, Flag email) + where + (nameOrEmail,erest) = break (== '<') str + (email,_) = break (== '>') (tail erest) + trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse + removeLeadingSpace = dropWhile isSpace + +-- split string at given character, and remove whitespaces +splitString :: Char -> String -> [String] +splitString sep str = go str where + go s = if null s' then [] else tok : go rest where + s' = dropWhile (\c -> c == sep || isSpace c) s + (tok,rest) = break (==sep) s' + +nubSet :: (Ord a) => [a] -> [a] +nubSet = Set.toList . Set.fromList + +{- +test db testProjectRoot = do + putStrLn "Guessed package name" + (guessPackageName >=> print) testProjectRoot + putStrLn "Guessed name and email" + guessAuthorNameMail >>= print + + mods <- scanForModules testProjectRoot + + putStrLn "Guessed modules" + mapM_ print mods + putStrLn "Needed build programs" + print (neededBuildPrograms mods) + + putStrLn "List of known categories" + print $ knownCategories db +-} + +#if MIN_VERSION_base(3,0,3) +#else +partitionEithers :: [Either a b] -> ([a],[b]) +partitionEithers = foldr (either left right) ([],[]) + where + left a (l, r) = (a:l, r) + right a (l, r) = (l, a:r) +#endif diff --git a/cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs b/cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs @@ -0,0 +1,1722 @@ +module Distribution.Client.Init.Licenses + ( License + , bsd3 + , gplv2 + , gplv3 + , lgpl2 + , lgpl3 + + ) where + +type License = String + +bsd3 :: String -> String -> License +bsd3 authors year = unlines + [ "Copyright (c)" ++ year ++ ", " ++ authors + , "" + , "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 " ++ authors ++ " 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." + ] + +gplv2 :: License +gplv2 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "License is intended to guarantee your freedom to share and change free" + , "software--to make sure the software is free for all its users. This" + , "General Public License applies to most of the Free Software" + , "Foundation's software and to any other program whose authors commit to" + , "using it. (Some other Free Software Foundation software is covered by" + , "the GNU Lesser General Public License instead.) You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "this service if you wish), that you receive source code or can get it" + , "if you want it, that you can change the software or use pieces of it" + , "in new free programs; and that you know you can do these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if you" + , "distribute copies of the software, or if you modify it." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must give the recipients all the rights that" + , "you have. You must make sure that they, too, receive or can get the" + , "source code. And you must show them these terms so they know their" + , "rights." + , "" + , " We protect your rights with two steps: (1) copyright the software, and" + , "(2) offer you this license which gives you legal permission to copy," + , "distribute and/or modify the software." + , "" + , " Also, for each author's protection and ours, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "software. If the software is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original, so" + , "that any problems introduced by others will not reflect on the original" + , "authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that redistributors of a free" + , "program will individually obtain patent licenses, in effect making the" + , "program proprietary. To prevent this, we have made it clear that any" + , "patent must be licensed for everyone's free use or not licensed at all." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " GNU GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License applies to any program or other work which contains" + , "a notice placed by the copyright holder saying it may be distributed" + , "under the terms of this General Public License. The \"Program\", below," + , "refers to any such program or work, and a \"work based on the Program\"" + , "means either the Program or any derivative work under copyright law:" + , "that is to say, a work containing the Program or a portion of it," + , "either verbatim or with modifications and/or translated into another" + , "language. (Hereinafter, translation is included without limitation in" + , "the term \"modification\".) Each licensee is addressed as \"you\"." + , "" + , "Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running the Program is not restricted, and the output from the Program" + , "is covered only if its contents constitute a work based on the" + , "Program (independent of having been made by running the Program)." + , "Whether that is true depends on what the Program does." + , "" + , " 1. You may copy and distribute verbatim copies of the Program's" + , "source code as you receive it, in any medium, provided that you" + , "conspicuously and appropriately publish on each copy an appropriate" + , "copyright notice and disclaimer of warranty; keep intact all the" + , "notices that refer to this License and to the absence of any warranty;" + , "and give any other recipients of the Program a copy of this License" + , "along with the Program." + , "" + , "You may charge a fee for the physical act of transferring a copy, and" + , "you may at your option offer warranty protection in exchange for a fee." + , "" + , " 2. You may modify your copy or copies of the Program or any portion" + , "of it, thus forming a work based on the Program, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) You must cause the modified files to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " b) You must cause any work that you distribute or publish, that in" + , " whole or in part contains or is derived from the Program or any" + , " part thereof, to be licensed as a whole at no charge to all third" + , " parties under the terms of this License." + , "" + , " c) If the modified program normally reads commands interactively" + , " when run, you must cause it, when started running for such" + , " interactive use in the most ordinary way, to print or display an" + , " announcement including an appropriate copyright notice and a" + , " notice that there is no warranty (or else, saying that you provide" + , " a warranty) and that users may redistribute the program under" + , " these conditions, and telling the user how to view a copy of this" + , " License. (Exception: if the Program itself is interactive but" + , " does not normally print such an announcement, your work based on" + , " the Program is not required to print an announcement.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Program," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Program, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Program." + , "" + , "In addition, mere aggregation of another work not based on the Program" + , "with the Program (or with a work based on the Program) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may copy and distribute the Program (or a work based on it," + , "under Section 2) in object code or executable form under the terms of" + , "Sections 1 and 2 above provided that you also do one of the following:" + , "" + , " a) Accompany it with the complete corresponding machine-readable" + , " source code, which must be distributed under the terms of Sections" + , " 1 and 2 above on a medium customarily used for software interchange; or," + , "" + , " b) Accompany it with a written offer, valid for at least three" + , " years, to give any third party, for a charge no more than your" + , " cost of physically performing source distribution, a complete" + , " machine-readable copy of the corresponding source code, to be" + , " distributed under the terms of Sections 1 and 2 above on a medium" + , " customarily used for software interchange; or," + , "" + , " c) Accompany it with the information you received as to the offer" + , " to distribute corresponding source code. (This alternative is" + , " allowed only for noncommercial distribution and only if you" + , " received the program in object code or executable form with such" + , " an offer, in accord with Subsection b above.)" + , "" + , "The source code for a work means the preferred form of the work for" + , "making modifications to it. For an executable work, complete source" + , "code means all the source code for all modules it contains, plus any" + , "associated interface definition files, plus the scripts used to" + , "control compilation and installation of the executable. However, as a" + , "special exception, the source code distributed need not include" + , "anything that is normally distributed (in either source or binary" + , "form) with the major components (compiler, kernel, and so on) of the" + , "operating system on which the executable runs, unless that component" + , "itself accompanies the executable." + , "" + , "If distribution of executable or object code is made by offering" + , "access to copy from a designated place, then offering equivalent" + , "access to copy the source code from the same place counts as" + , "distribution of the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 4. You may not copy, modify, sublicense, or distribute the Program" + , "except as expressly provided under this License. Any attempt" + , "otherwise to copy, modify, sublicense or distribute the Program is" + , "void, and will automatically terminate your rights under this License." + , "However, parties who have received copies, or rights, from you under" + , "this License will not have their licenses terminated so long as such" + , "parties remain in full compliance." + , "" + , " 5. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Program or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Program (or any work based on the" + , "Program), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Program or works based on it." + , "" + , " 6. Each time you redistribute the Program (or any work based on the" + , "Program), the recipient automatically receives a license from the" + , "original licensor to copy, distribute or modify the Program subject to" + , "these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 7. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Program at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Program by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Program." + , "" + , "If any portion of this section is held invalid or unenforceable under" + , "any particular circumstance, the balance of the section is intended to" + , "apply and the section as a whole is intended to apply in other" + , "circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system, which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 8. If the distribution and/or use of the Program is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Program under this License" + , "may add an explicit geographical distribution limitation excluding" + , "those countries, so that distribution is permitted only in or among" + , "countries not thus excluded. In such case, this License incorporates" + , "the limitation as if written in the body of this License." + , "" + , " 9. The Free Software Foundation may publish revised and/or new versions" + , "of the General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Program" + , "specifies a version number of this License which applies to it and \"any" + , "later version\", you have the option of following the terms and conditions" + , "either of that version or of any later version published by the Free" + , "Software Foundation. If the Program does not specify a version number of" + , "this License, you may choose any version ever published by the Free Software" + , "Foundation." + , "" + , " 10. If you wish to incorporate parts of the Program into other free" + , "programs whose distribution conditions are different, write to the author" + , "to ask for permission. For software which is copyrighted by the Free" + , "Software Foundation, write to the Free Software Foundation; we sometimes" + , "make exceptions for this. Our decision will be guided by the two goals" + , "of preserving the free status of all derivatives of our free software and" + , "of promoting the sharing and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY" + , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN" + , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES" + , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED" + , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF" + , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS" + , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE" + , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING," + , "REPAIR OR CORRECTION." + , "" + , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" + , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES," + , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING" + , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED" + , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY" + , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER" + , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE" + , "POSSIBILITY OF SUCH DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software; you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation; either version 2 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License along" + , " with this program; if not, write to the Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "If the program is interactive, make it output a short notice like this" + , "when it starts in an interactive mode:" + , "" + , " Gnomovision version 69, Copyright (C) year name of author" + , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, the commands you use may" + , "be called something other than `show w' and `show c'; they could even be" + , "mouse-clicks or menu items--whatever suits your program." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the program, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" + , " `Gnomovision' (which makes passes at compilers) written by James Hacker." + , "" + , " , 1 April 1989" + , " Ty Coon, President of Vice" + , "" + , "This General Public License does not permit incorporating your program into" + , "proprietary programs. If your program is a subroutine library, you may" + , "consider it more useful to permit linking proprietary applications with the" + , "library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License." + ] + +gplv3 :: License +gplv3 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The GNU General Public License is a free, copyleft license for" + , "software and other kinds of works." + , "" + , " The licenses for most software and other practical works are designed" + , "to take away your freedom to share and change the works. By contrast," + , "the GNU General Public License is intended to guarantee your freedom to" + , "share and change all versions of a program--to make sure it remains free" + , "software for all its users. We, the Free Software Foundation, use the" + , "GNU General Public License for most of our software; it applies also to" + , "any other work released this way by its authors. You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "them if you wish), that you receive source code or can get it if you" + , "want it, that you can change the software or use pieces of it in new" + , "free programs, and that you know you can do these things." + , "" + , " To protect your rights, we need to prevent others from denying you" + , "these rights or asking you to surrender the rights. Therefore, you have" + , "certain responsibilities if you distribute copies of the software, or if" + , "you modify it: responsibilities to respect the freedom of others." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must pass on to the recipients the same" + , "freedoms that you received. You must make sure that they, too, receive" + , "or can get the source code. And you must show them these terms so they" + , "know their rights." + , "" + , " Developers that use the GNU GPL protect your rights with two steps:" + , "(1) assert copyright on the software, and (2) offer you this License" + , "giving you legal permission to copy, distribute and/or modify it." + , "" + , " For the developers' and authors' protection, the GPL clearly explains" + , "that there is no warranty for this free software. For both users' and" + , "authors' sake, the GPL requires that modified versions be marked as" + , "changed, so that their problems will not be attributed erroneously to" + , "authors of previous versions." + , "" + , " Some devices are designed to deny users access to install or run" + , "modified versions of the software inside them, although the manufacturer" + , "can do so. This is fundamentally incompatible with the aim of" + , "protecting users' freedom to change the software. The systematic" + , "pattern of such abuse occurs in the area of products for individuals to" + , "use, which is precisely where it is most unacceptable. Therefore, we" + , "have designed this version of the GPL to prohibit the practice for those" + , "products. If such problems arise substantially in other domains, we" + , "stand ready to extend this provision to those domains in future versions" + , "of the GPL, as needed to protect the freedom of users." + , "" + , " Finally, every program is threatened constantly by software patents." + , "States should not allow patents to restrict development and use of" + , "software on general-purpose computers, but in those that do, we wish to" + , "avoid the special danger that patents applied to a free program could" + , "make it effectively proprietary. To prevent this, the GPL assures that" + , "patents cannot be used to render the program non-free." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " TERMS AND CONDITIONS" + , "" + , " 0. Definitions." + , "" + , " \"This License\" refers to version 3 of the GNU General Public License." + , "" + , " \"Copyright\" also means copyright-like laws that apply to other kinds of" + , "works, such as semiconductor masks." + , " " + , " \"The Program\" refers to any copyrightable work licensed under this" + , "License. Each licensee is addressed as \"you\". \"Licensees\" and" + , "\"recipients\" may be individuals or organizations." + , "" + , " To \"modify\" a work means to copy from or adapt all or part of the work" + , "in a fashion requiring copyright permission, other than the making of an" + , "exact copy. The resulting work is called a \"modified version\" of the" + , "earlier work or a work \"based on\" the earlier work." + , "" + , " A \"covered work\" means either the unmodified Program or a work based" + , "on the Program." + , "" + , " To \"propagate\" a work means to do anything with it that, without" + , "permission, would make you directly or secondarily liable for" + , "infringement under applicable copyright law, except executing it on a" + , "computer or modifying a private copy. Propagation includes copying," + , "distribution (with or without modification), making available to the" + , "public, and in some countries other activities as well." + , "" + , " To \"convey\" a work means any kind of propagation that enables other" + , "parties to make or receive copies. Mere interaction with a user through" + , "a computer network, with no transfer of a copy, is not conveying." + , "" + , " An interactive user interface displays \"Appropriate Legal Notices\"" + , "to the extent that it includes a convenient and prominently visible" + , "feature that (1) displays an appropriate copyright notice, and (2)" + , "tells the user that there is no warranty for the work (except to the" + , "extent that warranties are provided), that licensees may convey the" + , "work under this License, and how to view a copy of this License. If" + , "the interface presents a list of user commands or options, such as a" + , "menu, a prominent item in the list meets this criterion." + , "" + , " 1. Source Code." + , "" + , " The \"source code\" for a work means the preferred form of the work" + , "for making modifications to it. \"Object code\" means any non-source" + , "form of a work." + , "" + , " A \"Standard Interface\" means an interface that either is an official" + , "standard defined by a recognized standards body, or, in the case of" + , "interfaces specified for a particular programming language, one that" + , "is widely used among developers working in that language." + , "" + , " The \"System Libraries\" of an executable work include anything, other" + , "than the work as a whole, that (a) is included in the normal form of" + , "packaging a Major Component, but which is not part of that Major" + , "Component, and (b) serves only to enable use of the work with that" + , "Major Component, or to implement a Standard Interface for which an" + , "implementation is available to the public in source code form. A" + , "\"Major Component\", in this context, means a major essential component" + , "(kernel, window system, and so on) of the specific operating system" + , "(if any) on which the executable work runs, or a compiler used to" + , "produce the work, or an object code interpreter used to run it." + , "" + , " The \"Corresponding Source\" for a work in object code form means all" + , "the source code needed to generate, install, and (for an executable" + , "work) run the object code and to modify the work, including scripts to" + , "control those activities. However, it does not include the work's" + , "System Libraries, or general-purpose tools or generally available free" + , "programs which are used unmodified in performing those activities but" + , "which are not part of the work. For example, Corresponding Source" + , "includes interface definition files associated with source files for" + , "the work, and the source code for shared libraries and dynamically" + , "linked subprograms that the work is specifically designed to require," + , "such as by intimate data communication or control flow between those" + , "subprograms and other parts of the work." + , "" + , " The Corresponding Source need not include anything that users" + , "can regenerate automatically from other parts of the Corresponding" + , "Source." + , "" + , " The Corresponding Source for a work in source code form is that" + , "same work." + , "" + , " 2. Basic Permissions." + , "" + , " All rights granted under this License are granted for the term of" + , "copyright on the Program, and are irrevocable provided the stated" + , "conditions are met. This License explicitly affirms your unlimited" + , "permission to run the unmodified Program. The output from running a" + , "covered work is covered by this License only if the output, given its" + , "content, constitutes a covered work. This License acknowledges your" + , "rights of fair use or other equivalent, as provided by copyright law." + , "" + , " You may make, run and propagate covered works that you do not" + , "convey, without conditions so long as your license otherwise remains" + , "in force. You may convey covered works to others for the sole purpose" + , "of having them make modifications exclusively for you, or provide you" + , "with facilities for running those works, provided that you comply with" + , "the terms of this License in conveying all material for which you do" + , "not control copyright. Those thus making or running the covered works" + , "for you must do so exclusively on your behalf, under your direction" + , "and control, on terms that prohibit them from making any copies of" + , "your copyrighted material outside their relationship with you." + , "" + , " Conveying under any other circumstances is permitted solely under" + , "the conditions stated below. Sublicensing is not allowed; section 10" + , "makes it unnecessary." + , "" + , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." + , "" + , " No covered work shall be deemed part of an effective technological" + , "measure under any applicable law fulfilling obligations under article" + , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" + , "similar laws prohibiting or restricting circumvention of such" + , "measures." + , "" + , " When you convey a covered work, you waive any legal power to forbid" + , "circumvention of technological measures to the extent such circumvention" + , "is effected by exercising rights under this License with respect to" + , "the covered work, and you disclaim any intention to limit operation or" + , "modification of the work as a means of enforcing, against the work's" + , "users, your or third parties' legal rights to forbid circumvention of" + , "technological measures." + , "" + , " 4. Conveying Verbatim Copies." + , "" + , " You may convey verbatim copies of the Program's source code as you" + , "receive it, in any medium, provided that you conspicuously and" + , "appropriately publish on each copy an appropriate copyright notice;" + , "keep intact all notices stating that this License and any" + , "non-permissive terms added in accord with section 7 apply to the code;" + , "keep intact all notices of the absence of any warranty; and give all" + , "recipients a copy of this License along with the Program." + , "" + , " You may charge any price or no price for each copy that you convey," + , "and you may offer support or warranty protection for a fee." + , "" + , " 5. Conveying Modified Source Versions." + , "" + , " You may convey a work based on the Program, or the modifications to" + , "produce it from the Program, in the form of source code under the" + , "terms of section 4, provided that you also meet all of these conditions:" + , "" + , " a) The work must carry prominent notices stating that you modified" + , " it, and giving a relevant date." + , "" + , " b) The work must carry prominent notices stating that it is" + , " released under this License and any conditions added under section" + , " 7. This requirement modifies the requirement in section 4 to" + , " \"keep intact all notices\"." + , "" + , " c) You must license the entire work, as a whole, under this" + , " License to anyone who comes into possession of a copy. This" + , " License will therefore apply, along with any applicable section 7" + , " additional terms, to the whole of the work, and all its parts," + , " regardless of how they are packaged. This License gives no" + , " permission to license the work in any other way, but it does not" + , " invalidate such permission if you have separately received it." + , "" + , " d) If the work has interactive user interfaces, each must display" + , " Appropriate Legal Notices; however, if the Program has interactive" + , " interfaces that do not display Appropriate Legal Notices, your" + , " work need not make them do so." + , "" + , " A compilation of a covered work with other separate and independent" + , "works, which are not by their nature extensions of the covered work," + , "and which are not combined with it such as to form a larger program," + , "in or on a volume of a storage or distribution medium, is called an" + , "\"aggregate\" if the compilation and its resulting copyright are not" + , "used to limit the access or legal rights of the compilation's users" + , "beyond what the individual works permit. Inclusion of a covered work" + , "in an aggregate does not cause this License to apply to the other" + , "parts of the aggregate." + , "" + , " 6. Conveying Non-Source Forms." + , "" + , " You may convey a covered work in object code form under the terms" + , "of sections 4 and 5, provided that you also convey the" + , "machine-readable Corresponding Source under the terms of this License," + , "in one of these ways:" + , "" + , " a) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by the" + , " Corresponding Source fixed on a durable physical medium" + , " customarily used for software interchange." + , "" + , " b) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by a" + , " written offer, valid for at least three years and valid for as" + , " long as you offer spare parts or customer support for that product" + , " model, to give anyone who possesses the object code either (1) a" + , " copy of the Corresponding Source for all the software in the" + , " product that is covered by this License, on a durable physical" + , " medium customarily used for software interchange, for a price no" + , " more than your reasonable cost of physically performing this" + , " conveying of source, or (2) access to copy the" + , " Corresponding Source from a network server at no charge." + , "" + , " c) Convey individual copies of the object code with a copy of the" + , " written offer to provide the Corresponding Source. This" + , " alternative is allowed only occasionally and noncommercially, and" + , " only if you received the object code with such an offer, in accord" + , " with subsection 6b." + , "" + , " d) Convey the object code by offering access from a designated" + , " place (gratis or for a charge), and offer equivalent access to the" + , " Corresponding Source in the same way through the same place at no" + , " further charge. You need not require recipients to copy the" + , " Corresponding Source along with the object code. If the place to" + , " copy the object code is a network server, the Corresponding Source" + , " may be on a different server (operated by you or a third party)" + , " that supports equivalent copying facilities, provided you maintain" + , " clear directions next to the object code saying where to find the" + , " Corresponding Source. Regardless of what server hosts the" + , " Corresponding Source, you remain obligated to ensure that it is" + , " available for as long as needed to satisfy these requirements." + , "" + , " e) Convey the object code using peer-to-peer transmission, provided" + , " you inform other peers where the object code and Corresponding" + , " Source of the work are being offered to the general public at no" + , " charge under subsection 6d." + , "" + , " A separable portion of the object code, whose source code is excluded" + , "from the Corresponding Source as a System Library, need not be" + , "included in conveying the object code work." + , "" + , " A \"User Product\" is either (1) a \"consumer product\", which means any" + , "tangible personal property which is normally used for personal, family," + , "or household purposes, or (2) anything designed or sold for incorporation" + , "into a dwelling. In determining whether a product is a consumer product," + , "doubtful cases shall be resolved in favor of coverage. For a particular" + , "product received by a particular user, \"normally used\" refers to a" + , "typical or common use of that class of product, regardless of the status" + , "of the particular user or of the way in which the particular user" + , "actually uses, or expects or is expected to use, the product. A product" + , "is a consumer product regardless of whether the product has substantial" + , "commercial, industrial or non-consumer uses, unless such uses represent" + , "the only significant mode of use of the product." + , "" + , " \"Installation Information\" for a User Product means any methods," + , "procedures, authorization keys, or other information required to install" + , "and execute modified versions of a covered work in that User Product from" + , "a modified version of its Corresponding Source. The information must" + , "suffice to ensure that the continued functioning of the modified object" + , "code is in no case prevented or interfered with solely because" + , "modification has been made." + , "" + , " If you convey an object code work under this section in, or with, or" + , "specifically for use in, a User Product, and the conveying occurs as" + , "part of a transaction in which the right of possession and use of the" + , "User Product is transferred to the recipient in perpetuity or for a" + , "fixed term (regardless of how the transaction is characterized), the" + , "Corresponding Source conveyed under this section must be accompanied" + , "by the Installation Information. But this requirement does not apply" + , "if neither you nor any third party retains the ability to install" + , "modified object code on the User Product (for example, the work has" + , "been installed in ROM)." + , "" + , " The requirement to provide Installation Information does not include a" + , "requirement to continue to provide support service, warranty, or updates" + , "for a work that has been modified or installed by the recipient, or for" + , "the User Product in which it has been modified or installed. Access to a" + , "network may be denied when the modification itself materially and" + , "adversely affects the operation of the network or violates the rules and" + , "protocols for communication across the network." + , "" + , " Corresponding Source conveyed, and Installation Information provided," + , "in accord with this section must be in a format that is publicly" + , "documented (and with an implementation available to the public in" + , "source code form), and must require no special password or key for" + , "unpacking, reading or copying." + , "" + , " 7. Additional Terms." + , "" + , " \"Additional permissions\" are terms that supplement the terms of this" + , "License by making exceptions from one or more of its conditions." + , "Additional permissions that are applicable to the entire Program shall" + , "be treated as though they were included in this License, to the extent" + , "that they are valid under applicable law. If additional permissions" + , "apply only to part of the Program, that part may be used separately" + , "under those permissions, but the entire Program remains governed by" + , "this License without regard to the additional permissions." + , "" + , " When you convey a copy of a covered work, you may at your option" + , "remove any additional permissions from that copy, or from any part of" + , "it. (Additional permissions may be written to require their own" + , "removal in certain cases when you modify the work.) You may place" + , "additional permissions on material, added by you to a covered work," + , "for which you have or can give appropriate copyright permission." + , "" + , " Notwithstanding any other provision of this License, for material you" + , "add to a covered work, you may (if authorized by the copyright holders of" + , "that material) supplement the terms of this License with terms:" + , "" + , " a) Disclaiming warranty or limiting liability differently from the" + , " terms of sections 15 and 16 of this License; or" + , "" + , " b) Requiring preservation of specified reasonable legal notices or" + , " author attributions in that material or in the Appropriate Legal" + , " Notices displayed by works containing it; or" + , "" + , " c) Prohibiting misrepresentation of the origin of that material, or" + , " requiring that modified versions of such material be marked in" + , " reasonable ways as different from the original version; or" + , "" + , " d) Limiting the use for publicity purposes of names of licensors or" + , " authors of the material; or" + , "" + , " e) Declining to grant rights under trademark law for use of some" + , " trade names, trademarks, or service marks; or" + , "" + , " f) Requiring indemnification of licensors and authors of that" + , " material by anyone who conveys the material (or modified versions of" + , " it) with contractual assumptions of liability to the recipient, for" + , " any liability that these contractual assumptions directly impose on" + , " those licensors and authors." + , "" + , " All other non-permissive additional terms are considered \"further" + , "restrictions\" within the meaning of section 10. If the Program as you" + , "received it, or any part of it, contains a notice stating that it is" + , "governed by this License along with a term that is a further" + , "restriction, you may remove that term. If a license document contains" + , "a further restriction but permits relicensing or conveying under this" + , "License, you may add to a covered work material governed by the terms" + , "of that license document, provided that the further restriction does" + , "not survive such relicensing or conveying." + , "" + , " If you add terms to a covered work in accord with this section, you" + , "must place, in the relevant source files, a statement of the" + , "additional terms that apply to those files, or a notice indicating" + , "where to find the applicable terms." + , "" + , " Additional terms, permissive or non-permissive, may be stated in the" + , "form of a separately written license, or stated as exceptions;" + , "the above requirements apply either way." + , "" + , " 8. Termination." + , "" + , " You may not propagate or modify a covered work except as expressly" + , "provided under this License. Any attempt otherwise to propagate or" + , "modify it is void, and will automatically terminate your rights under" + , "this License (including any patent licenses granted under the third" + , "paragraph of section 11)." + , "" + , " However, if you cease all violation of this License, then your" + , "license from a particular copyright holder is reinstated (a)" + , "provisionally, unless and until the copyright holder explicitly and" + , "finally terminates your license, and (b) permanently, if the copyright" + , "holder fails to notify you of the violation by some reasonable means" + , "prior to 60 days after the cessation." + , "" + , " Moreover, your license from a particular copyright holder is" + , "reinstated permanently if the copyright holder notifies you of the" + , "violation by some reasonable means, this is the first time you have" + , "received notice of violation of this License (for any work) from that" + , "copyright holder, and you cure the violation prior to 30 days after" + , "your receipt of the notice." + , "" + , " Termination of your rights under this section does not terminate the" + , "licenses of parties who have received copies or rights from you under" + , "this License. If your rights have been terminated and not permanently" + , "reinstated, you do not qualify to receive new licenses for the same" + , "material under section 10." + , "" + , " 9. Acceptance Not Required for Having Copies." + , "" + , " You are not required to accept this License in order to receive or" + , "run a copy of the Program. Ancillary propagation of a covered work" + , "occurring solely as a consequence of using peer-to-peer transmission" + , "to receive a copy likewise does not require acceptance. However," + , "nothing other than this License grants you permission to propagate or" + , "modify any covered work. These actions infringe copyright if you do" + , "not accept this License. Therefore, by modifying or propagating a" + , "covered work, you indicate your acceptance of this License to do so." + , "" + , " 10. Automatic Licensing of Downstream Recipients." + , "" + , " Each time you convey a covered work, the recipient automatically" + , "receives a license from the original licensors, to run, modify and" + , "propagate that work, subject to this License. You are not responsible" + , "for enforcing compliance by third parties with this License." + , "" + , " An \"entity transaction\" is a transaction transferring control of an" + , "organization, or substantially all assets of one, or subdividing an" + , "organization, or merging organizations. If propagation of a covered" + , "work results from an entity transaction, each party to that" + , "transaction who receives a copy of the work also receives whatever" + , "licenses to the work the party's predecessor in interest had or could" + , "give under the previous paragraph, plus a right to possession of the" + , "Corresponding Source of the work from the predecessor in interest, if" + , "the predecessor has it or can get it with reasonable efforts." + , "" + , " You may not impose any further restrictions on the exercise of the" + , "rights granted or affirmed under this License. For example, you may" + , "not impose a license fee, royalty, or other charge for exercise of" + , "rights granted under this License, and you may not initiate litigation" + , "(including a cross-claim or counterclaim in a lawsuit) alleging that" + , "any patent claim is infringed by making, using, selling, offering for" + , "sale, or importing the Program or any portion of it." + , "" + , " 11. Patents." + , "" + , " A \"contributor\" is a copyright holder who authorizes use under this" + , "License of the Program or a work on which the Program is based. The" + , "work thus licensed is called the contributor's \"contributor version\"." + , "" + , " A contributor's \"essential patent claims\" are all patent claims" + , "owned or controlled by the contributor, whether already acquired or" + , "hereafter acquired, that would be infringed by some manner, permitted" + , "by this License, of making, using, or selling its contributor version," + , "but do not include claims that would be infringed only as a" + , "consequence of further modification of the contributor version. For" + , "purposes of this definition, \"control\" includes the right to grant" + , "patent sublicenses in a manner consistent with the requirements of" + , "this License." + , "" + , " Each contributor grants you a non-exclusive, worldwide, royalty-free" + , "patent license under the contributor's essential patent claims, to" + , "make, use, sell, offer for sale, import and otherwise run, modify and" + , "propagate the contents of its contributor version." + , "" + , " In the following three paragraphs, a \"patent license\" is any express" + , "agreement or commitment, however denominated, not to enforce a patent" + , "(such as an express permission to practice a patent or covenant not to" + , "sue for patent infringement). To \"grant\" such a patent license to a" + , "party means to make such an agreement or commitment not to enforce a" + , "patent against the party." + , "" + , " If you convey a covered work, knowingly relying on a patent license," + , "and the Corresponding Source of the work is not available for anyone" + , "to copy, free of charge and under the terms of this License, through a" + , "publicly available network server or other readily accessible means," + , "then you must either (1) cause the Corresponding Source to be so" + , "available, or (2) arrange to deprive yourself of the benefit of the" + , "patent license for this particular work, or (3) arrange, in a manner" + , "consistent with the requirements of this License, to extend the patent" + , "license to downstream recipients. \"Knowingly relying\" means you have" + , "actual knowledge that, but for the patent license, your conveying the" + , "covered work in a country, or your recipient's use of the covered work" + , "in a country, would infringe one or more identifiable patents in that" + , "country that you have reason to believe are valid." + , " " + , " If, pursuant to or in connection with a single transaction or" + , "arrangement, you convey, or propagate by procuring conveyance of, a" + , "covered work, and grant a patent license to some of the parties" + , "receiving the covered work authorizing them to use, propagate, modify" + , "or convey a specific copy of the covered work, then the patent license" + , "you grant is automatically extended to all recipients of the covered" + , "work and works based on it." + , "" + , " A patent license is \"discriminatory\" if it does not include within" + , "the scope of its coverage, prohibits the exercise of, or is" + , "conditioned on the non-exercise of one or more of the rights that are" + , "specifically granted under this License. You may not convey a covered" + , "work if you are a party to an arrangement with a third party that is" + , "in the business of distributing software, under which you make payment" + , "to the third party based on the extent of your activity of conveying" + , "the work, and under which the third party grants, to any of the" + , "parties who would receive the covered work from you, a discriminatory" + , "patent license (a) in connection with copies of the covered work" + , "conveyed by you (or copies made from those copies), or (b) primarily" + , "for and in connection with specific products or compilations that" + , "contain the covered work, unless you entered into that arrangement," + , "or that patent license was granted, prior to 28 March 2007." + , "" + , " Nothing in this License shall be construed as excluding or limiting" + , "any implied license or other defenses to infringement that may" + , "otherwise be available to you under applicable patent law." + , "" + , " 12. No Surrender of Others' Freedom." + , "" + , " If conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot convey a" + , "covered work so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you may" + , "not convey it at all. For example, if you agree to terms that obligate you" + , "to collect a royalty for further conveying from those to whom you convey" + , "the Program, the only way you could satisfy both those terms and this" + , "License would be to refrain entirely from conveying the Program." + , "" + , " 13. Use with the GNU Affero General Public License." + , "" + , " Notwithstanding any other provision of this License, you have" + , "permission to link or combine any covered work with a work licensed" + , "under version 3 of the GNU Affero General Public License into a single" + , "combined work, and to convey the resulting work. The terms of this" + , "License will continue to apply to the part which is the covered work," + , "but the special requirements of the GNU Affero General Public License," + , "section 13, concerning interaction through a network will apply to the" + , "combination as such." + , "" + , " 14. Revised Versions of this License." + , "" + , " The Free Software Foundation may publish revised and/or new versions of" + , "the GNU General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Program specifies that a certain numbered version of the GNU General" + , "Public License \"or any later version\" applies to it, you have the" + , "option of following the terms and conditions either of that numbered" + , "version or of any later version published by the Free Software" + , "Foundation. If the Program does not specify a version number of the" + , "GNU General Public License, you may choose any version ever published" + , "by the Free Software Foundation." + , "" + , " If the Program specifies that a proxy can decide which future" + , "versions of the GNU General Public License can be used, that proxy's" + , "public statement of acceptance of a version permanently authorizes you" + , "to choose that version for the Program." + , "" + , " Later license versions may give you additional or different" + , "permissions. However, no additional obligations are imposed on any" + , "author or copyright holder as a result of your choosing to follow a" + , "later version." + , "" + , " 15. Disclaimer of Warranty." + , "" + , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" + , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" + , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" + , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," + , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" + , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" + , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. Limitation of Liability." + , "" + , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" + , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" + , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" + , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" + , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" + , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," + , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" + , "SUCH DAMAGES." + , "" + , " 17. Interpretation of Sections 15 and 16." + , "" + , " If the disclaimer of warranty and limitation of liability provided" + , "above cannot be given local legal effect according to their terms," + , "reviewing courts shall apply local law that most closely approximates" + , "an absolute waiver of all civil liability in connection with the" + , "Program, unless a warranty or assumption of liability accompanies a" + , "copy of the Program in return for a fee." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "state the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software: you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation, either version 3 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License" + , " along with this program. If not, see ." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , " If the program does terminal interaction, make it output a short" + , "notice like this when it starts in an interactive mode:" + , "" + , " Copyright (C) " + , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, your program's commands" + , "might be different; for a GUI interface, you would use an \"about box\"." + , "" + , " You should also get your employer (if you work as a programmer) or school," + , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." + , "For more information on this, and how to apply and follow the GNU GPL, see" + , "." + , "" + , " The GNU General Public License does not permit incorporating your program" + , "into proprietary programs. If your program is a subroutine library, you" + , "may consider it more useful to permit linking proprietary applications with" + , "the library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License. But first, please read" + , "." + , "" + ] + +lgpl2 :: License +lgpl2 = unlines + [ " GNU LIBRARY GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1991 Free Software Foundation, Inc." + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "[This is the first released version of the library GPL. It is" + , " numbered 2 because it goes with version 2 of the ordinary GPL.]" + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "Licenses are intended to guarantee your freedom to share and change" + , "free software--to make sure the software is free for all its users." + , "" + , " This license, the Library General Public License, applies to some" + , "specially designated Free Software Foundation software, and to any" + , "other libraries whose authors decide to use it. You can use it for" + , "your libraries, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "this service if you wish), that you receive source code or can get it" + , "if you want it, that you can change the software or use pieces of it" + , "in new free programs; and that you know you can do these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if" + , "you distribute copies of the library, or if you modify it." + , "" + , " For example, if you distribute copies of the library, whether gratis" + , "or for a fee, you must give the recipients all the rights that we gave" + , "you. You must make sure that they, too, receive or can get the source" + , "code. If you link a program with the library, you must provide" + , "complete object files to the recipients so that they can relink them" + , "with the library, after making changes to the library and recompiling" + , "it. And you must show them these terms so they know their rights." + , "" + , " Our method of protecting your rights has two steps: (1) copyright" + , "the library, and (2) offer you this license which gives you legal" + , "permission to copy, distribute and/or modify the library." + , "" + , " Also, for each distributor's protection, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "library. If the library is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original" + , "version, so that any problems introduced by others will not reflect on" + , "the original authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that companies distributing free" + , "software will individually obtain patent licenses, thus in effect" + , "transforming the program into proprietary software. To prevent this," + , "we have made it clear that any patent must be licensed for everyone's" + , "free use or not licensed at all." + , "" + , " Most GNU software, including some libraries, is covered by the ordinary" + , "GNU General Public License, which was designed for utility programs. This" + , "license, the GNU Library General Public License, applies to certain" + , "designated libraries. This license is quite different from the ordinary" + , "one; be sure to read it in full, and don't assume that anything in it is" + , "the same as in the ordinary license." + , "" + , " The reason we have a separate public license for some libraries is that" + , "they blur the distinction we usually make between modifying or adding to a" + , "program and simply using it. Linking a program with a library, without" + , "changing the library, is in some sense simply using the library, and is" + , "analogous to running a utility program or application program. However, in" + , "a textual and legal sense, the linked executable is a combined work, a" + , "derivative of the original library, and the ordinary General Public License" + , "treats it as such." + , "" + , " Because of this blurred distinction, using the ordinary General" + , "Public License for libraries did not effectively promote software" + , "sharing, because most developers did not use the libraries. We" + , "concluded that weaker conditions might promote sharing better." + , "" + , " However, unrestricted linking of non-free programs would deprive the" + , "users of those programs of all benefit from the free status of the" + , "libraries themselves. This Library General Public License is intended to" + , "permit developers of non-free programs to use free libraries, while" + , "preserving your freedom as a user of such programs to change the free" + , "libraries that are incorporated in them. (We have not seen how to achieve" + , "this as regards changes in header files, but we have achieved it as regards" + , "changes in the actual functions of the Library.) The hope is that this" + , "will lead to faster development of free libraries." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow. Pay close attention to the difference between a" + , "\"work based on the library\" and a \"work that uses the library\". The" + , "former contains code derived from the library, while the latter only" + , "works together with the library." + , "" + , " Note that it is possible for a library to be covered by the ordinary" + , "General Public License rather than by this special one." + , "" + , " GNU LIBRARY GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License Agreement applies to any software library which" + , "contains a notice placed by the copyright holder or other authorized" + , "party saying it may be distributed under the terms of this Library" + , "General Public License (also called \"this License\"). Each licensee is" + , "addressed as \"you\"." + , "" + , " A \"library\" means a collection of software functions and/or data" + , "prepared so as to be conveniently linked with application programs" + , "(which use some of those functions and data) to form executables." + , "" + , " The \"Library\", below, refers to any such software library or work" + , "which has been distributed under these terms. A \"work based on the" + , "Library\" means either the Library or any derivative work under" + , "copyright law: that is to say, a work containing the Library or a" + , "portion of it, either verbatim or with modifications and/or translated" + , "straightforwardly into another language. (Hereinafter, translation is" + , "included without limitation in the term \"modification\".)" + , "" + , " \"Source code\" for a work means the preferred form of the work for" + , "making modifications to it. For a library, complete source code means" + , "all the source code for all modules it contains, plus any associated" + , "interface definition files, plus the scripts used to control compilation" + , "and installation of the library." + , "" + , " Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running a program using the Library is not restricted, and output from" + , "such a program is covered only if its contents constitute a work based" + , "on the Library (independent of the use of the Library in a tool for" + , "writing it). Whether that is true depends on what the Library does" + , "and what the program that uses the Library does." + , " " + , " 1. You may copy and distribute verbatim copies of the Library's" + , "complete source code as you receive it, in any medium, provided that" + , "you conspicuously and appropriately publish on each copy an" + , "appropriate copyright notice and disclaimer of warranty; keep intact" + , "all the notices that refer to this License and to the absence of any" + , "warranty; and distribute a copy of this License along with the" + , "Library." + , "" + , " You may charge a fee for the physical act of transferring a copy," + , "and you may at your option offer warranty protection in exchange for a" + , "fee." + , "" + , " 2. You may modify your copy or copies of the Library or any portion" + , "of it, thus forming a work based on the Library, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) The modified work must itself be a software library." + , "" + , " b) You must cause the files modified to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " c) You must cause the whole of the work to be licensed at no" + , " charge to all third parties under the terms of this License." + , "" + , " d) If a facility in the modified Library refers to a function or a" + , " table of data to be supplied by an application program that uses" + , " the facility, other than as an argument passed when the facility" + , " is invoked, then you must make a good faith effort to ensure that," + , " in the event an application does not supply such function or" + , " table, the facility still operates, and performs whatever part of" + , " its purpose remains meaningful." + , "" + , " (For example, a function in a library to compute square roots has" + , " a purpose that is entirely well-defined independent of the" + , " application. Therefore, Subsection 2d requires that any" + , " application-supplied function or table used by this function must" + , " be optional: if the application does not supply it, the square" + , " root function must still compute square roots.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Library," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Library, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote" + , "it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Library." + , "" + , "In addition, mere aggregation of another work not based on the Library" + , "with the Library (or with a work based on the Library) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may opt to apply the terms of the ordinary GNU General Public" + , "License instead of this License to a given copy of the Library. To do" + , "this, you must alter all the notices that refer to this License, so" + , "that they refer to the ordinary GNU General Public License, version 2," + , "instead of to this License. (If a newer version than version 2 of the" + , "ordinary GNU General Public License has appeared, then you can specify" + , "that version instead if you wish.) Do not make any other change in" + , "these notices." + , "" + , " Once this change is made in a given copy, it is irreversible for" + , "that copy, so the ordinary GNU General Public License applies to all" + , "subsequent copies and derivative works made from that copy." + , "" + , " This option is useful when you wish to copy part of the code of" + , "the Library into a program that is not a library." + , "" + , " 4. You may copy and distribute the Library (or a portion or" + , "derivative of it, under Section 2) in object code or executable form" + , "under the terms of Sections 1 and 2 above provided that you accompany" + , "it with the complete corresponding machine-readable source code, which" + , "must be distributed under the terms of Sections 1 and 2 above on a" + , "medium customarily used for software interchange." + , "" + , " If distribution of object code is made by offering access to copy" + , "from a designated place, then offering equivalent access to copy the" + , "source code from the same place satisfies the requirement to" + , "distribute the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 5. A program that contains no derivative of any portion of the" + , "Library, but is designed to work with the Library by being compiled or" + , "linked with it, is called a \"work that uses the Library\". Such a" + , "work, in isolation, is not a derivative work of the Library, and" + , "therefore falls outside the scope of this License." + , "" + , " However, linking a \"work that uses the Library\" with the Library" + , "creates an executable that is a derivative of the Library (because it" + , "contains portions of the Library), rather than a \"work that uses the" + , "library\". The executable is therefore covered by this License." + , "Section 6 states terms for distribution of such executables." + , "" + , " When a \"work that uses the Library\" uses material from a header file" + , "that is part of the Library, the object code for the work may be a" + , "derivative work of the Library even though the source code is not." + , "Whether this is true is especially significant if the work can be" + , "linked without the Library, or if the work is itself a library. The" + , "threshold for this to be true is not precisely defined by law." + , "" + , " If such an object file uses only numerical parameters, data" + , "structure layouts and accessors, and small macros and small inline" + , "functions (ten lines or less in length), then the use of the object" + , "file is unrestricted, regardless of whether it is legally a derivative" + , "work. (Executables containing this object code plus portions of the" + , "Library will still fall under Section 6.)" + , "" + , " Otherwise, if the work is a derivative of the Library, you may" + , "distribute the object code for the work under the terms of Section 6." + , "Any executables containing that work also fall under Section 6," + , "whether or not they are linked directly with the Library itself." + , "" + , " 6. As an exception to the Sections above, you may also compile or" + , "link a \"work that uses the Library\" with the Library to produce a" + , "work containing portions of the Library, and distribute that work" + , "under terms of your choice, provided that the terms permit" + , "modification of the work for the customer's own use and reverse" + , "engineering for debugging such modifications." + , "" + , " You must give prominent notice with each copy of the work that the" + , "Library is used in it and that the Library and its use are covered by" + , "this License. You must supply a copy of this License. If the work" + , "during execution displays copyright notices, you must include the" + , "copyright notice for the Library among them, as well as a reference" + , "directing the user to the copy of this License. Also, you must do one" + , "of these things:" + , "" + , " a) Accompany the work with the complete corresponding" + , " machine-readable source code for the Library including whatever" + , " changes were used in the work (which must be distributed under" + , " Sections 1 and 2 above); and, if the work is an executable linked" + , " with the Library, with the complete machine-readable \"work that" + , " uses the Library\", as object code and/or source code, so that the" + , " user can modify the Library and then relink to produce a modified" + , " executable containing the modified Library. (It is understood" + , " that the user who changes the contents of definitions files in the" + , " Library will not necessarily be able to recompile the application" + , " to use the modified definitions.)" + , "" + , " b) Accompany the work with a written offer, valid for at" + , " least three years, to give the same user the materials" + , " specified in Subsection 6a, above, for a charge no more" + , " than the cost of performing this distribution." + , "" + , " c) If distribution of the work is made by offering access to copy" + , " from a designated place, offer equivalent access to copy the above" + , " specified materials from the same place." + , "" + , " d) Verify that the user has already received a copy of these" + , " materials or that you have already sent this user a copy." + , "" + , " For an executable, the required form of the \"work that uses the" + , "Library\" must include any data and utility programs needed for" + , "reproducing the executable from it. However, as a special exception," + , "the source code distributed need not include anything that is normally" + , "distributed (in either source or binary form) with the major" + , "components (compiler, kernel, and so on) of the operating system on" + , "which the executable runs, unless that component itself accompanies" + , "the executable." + , "" + , " It may happen that this requirement contradicts the license" + , "restrictions of other proprietary libraries that do not normally" + , "accompany the operating system. Such a contradiction means you cannot" + , "use both them and the Library together in an executable that you" + , "distribute." + , "" + , " 7. You may place library facilities that are a work based on the" + , "Library side-by-side in a single library together with other library" + , "facilities not covered by this License, and distribute such a combined" + , "library, provided that the separate distribution of the work based on" + , "the Library and of the other library facilities is otherwise" + , "permitted, and provided that you do these two things:" + , "" + , " a) Accompany the combined library with a copy of the same work" + , " based on the Library, uncombined with any other library" + , " facilities. This must be distributed under the terms of the" + , " Sections above." + , "" + , " b) Give prominent notice with the combined library of the fact" + , " that part of it is a work based on the Library, and explaining" + , " where to find the accompanying uncombined form of the same work." + , "" + , " 8. You may not copy, modify, sublicense, link with, or distribute" + , "the Library except as expressly provided under this License. Any" + , "attempt otherwise to copy, modify, sublicense, link with, or" + , "distribute the Library is void, and will automatically terminate your" + , "rights under this License. However, parties who have received copies," + , "or rights, from you under this License will not have their licenses" + , "terminated so long as such parties remain in full compliance." + , "" + , " 9. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Library or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Library (or any work based on the" + , "Library), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Library or works based on it." + , "" + , " 10. Each time you redistribute the Library (or any work based on the" + , "Library), the recipient automatically receives a license from the" + , "original licensor to copy, distribute, link with or modify the Library" + , "subject to these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 11. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Library at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Library by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Library." + , "" + , "If any portion of this section is held invalid or unenforceable under any" + , "particular circumstance, the balance of the section is intended to apply," + , "and the section as a whole is intended to apply in other circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 12. If the distribution and/or use of the Library is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Library under this License may add" + , "an explicit geographical distribution limitation excluding those countries," + , "so that distribution is permitted only in or among countries not thus" + , "excluded. In such case, this License incorporates the limitation as if" + , "written in the body of this License." + , "" + , " 13. The Free Software Foundation may publish revised and/or new" + , "versions of the Library General Public License from time to time." + , "Such new versions will be similar in spirit to the present version," + , "but may differ in detail to address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Library" + , "specifies a version number of this License which applies to it and" + , "\"any later version\", you have the option of following the terms and" + , "conditions either of that version or of any later version published by" + , "the Free Software Foundation. If the Library does not specify a" + , "license version number, you may choose any version ever published by" + , "the Free Software Foundation." + , "" + , " 14. If you wish to incorporate parts of the Library into other free" + , "programs whose distribution conditions are incompatible with these," + , "write to the author to ask for permission. For software which is" + , "copyrighted by the Free Software Foundation, write to the Free" + , "Software Foundation; we sometimes make exceptions for this. Our" + , "decision will be guided by the two goals of preserving the free status" + , "of all derivatives of our free software and of promoting the sharing" + , "and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" + , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." + , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" + , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY" + , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE" + , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE" + , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" + , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" + , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" + , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU" + , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR" + , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE" + , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING" + , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A" + , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" + , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" + , "DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Libraries" + , "" + , " If you develop a new library, and you want it to be of the greatest" + , "possible use to the public, we recommend making it free software that" + , "everyone can redistribute and change. You can do so by permitting" + , "redistribution under these terms (or, alternatively, under the terms of the" + , "ordinary General Public License)." + , "" + , " To apply these terms, attach the following notices to the library. It is" + , "safest to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least the" + , "\"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This library is free software; you can redistribute it and/or" + , " modify it under the terms of the GNU Library General Public" + , " License as published by the Free Software Foundation; either" + , " version 2 of the License, or (at your option) any later version." + , "" + , " This library is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" + , " Library General Public License for more details." + , "" + , " You should have received a copy of the GNU Library General Public" + , " License along with this library; if not, write to the Free" + , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the library, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" + , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." + , "" + , " , 1 April 1990" + , " Ty Coon, President of Vice" + , "" + , "That's all there is to it!" + ] + +lgpl3 :: License +lgpl3 = unlines + [ " GNU LESSER GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "" + , " This version of the GNU Lesser General Public License incorporates" + , "the terms and conditions of version 3 of the GNU General Public" + , "License, supplemented by the additional permissions listed below." + , "" + , " 0. Additional Definitions. " + , "" + , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" + , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" + , "General Public License." + , "" + , " \"The Library\" refers to a covered work governed by this License," + , "other than an Application or a Combined Work as defined below." + , "" + , " An \"Application\" is any work that makes use of an interface provided" + , "by the Library, but which is not otherwise based on the Library." + , "Defining a subclass of a class defined by the Library is deemed a mode" + , "of using an interface provided by the Library." + , "" + , " A \"Combined Work\" is a work produced by combining or linking an" + , "Application with the Library. The particular version of the Library" + , "with which the Combined Work was made is also called the \"Linked" + , "Version\"." + , "" + , " The \"Minimal Corresponding Source\" for a Combined Work means the" + , "Corresponding Source for the Combined Work, excluding any source code" + , "for portions of the Combined Work that, considered in isolation, are" + , "based on the Application, and not on the Linked Version." + , "" + , " The \"Corresponding Application Code\" for a Combined Work means the" + , "object code and/or source code for the Application, including any data" + , "and utility programs needed for reproducing the Combined Work from the" + , "Application, but excluding the System Libraries of the Combined Work." + , "" + , " 1. Exception to Section 3 of the GNU GPL." + , "" + , " You may convey a covered work under sections 3 and 4 of this License" + , "without being bound by section 3 of the GNU GPL." + , "" + , " 2. Conveying Modified Versions." + , "" + , " If you modify a copy of the Library, and, in your modifications, a" + , "facility refers to a function or data to be supplied by an Application" + , "that uses the facility (other than as an argument passed when the" + , "facility is invoked), then you may convey a copy of the modified" + , "version:" + , "" + , " a) under this License, provided that you make a good faith effort to" + , " ensure that, in the event an Application does not supply the" + , " function or data, the facility still operates, and performs" + , " whatever part of its purpose remains meaningful, or" + , "" + , " b) under the GNU GPL, with none of the additional permissions of" + , " this License applicable to that copy." + , "" + , " 3. Object Code Incorporating Material from Library Header Files." + , "" + , " The object code form of an Application may incorporate material from" + , "a header file that is part of the Library. You may convey such object" + , "code under terms of your choice, provided that, if the incorporated" + , "material is not limited to numerical parameters, data structure" + , "layouts and accessors, or small macros, inline functions and templates" + , "(ten or fewer lines in length), you do both of the following:" + , "" + , " a) Give prominent notice with each copy of the object code that the" + , " Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the object code with a copy of the GNU GPL and this license" + , " document." + , "" + , " 4. Combined Works." + , "" + , " You may convey a Combined Work under terms of your choice that," + , "taken together, effectively do not restrict modification of the" + , "portions of the Library contained in the Combined Work and reverse" + , "engineering for debugging such modifications, if you also do each of" + , "the following:" + , "" + , " a) Give prominent notice with each copy of the Combined Work that" + , " the Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" + , " document." + , "" + , " c) For a Combined Work that displays copyright notices during" + , " execution, include the copyright notice for the Library among" + , " these notices, as well as a reference directing the user to the" + , " copies of the GNU GPL and this license document." + , "" + , " d) Do one of the following:" + , "" + , " 0) Convey the Minimal Corresponding Source under the terms of this" + , " License, and the Corresponding Application Code in a form" + , " suitable for, and under terms that permit, the user to" + , " recombine or relink the Application with a modified version of" + , " the Linked Version to produce a modified Combined Work, in the" + , " manner specified by section 6 of the GNU GPL for conveying" + , " Corresponding Source." + , "" + , " 1) Use a suitable shared library mechanism for linking with the" + , " Library. A suitable mechanism is one that (a) uses at run time" + , " a copy of the Library already present on the user's computer" + , " system, and (b) will operate properly with a modified version" + , " of the Library that is interface-compatible with the Linked" + , " Version. " + , "" + , " e) Provide Installation Information, but only if you would otherwise" + , " be required to provide such information under section 6 of the" + , " GNU GPL, and only to the extent that such information is" + , " necessary to install and execute a modified version of the" + , " Combined Work produced by recombining or relinking the" + , " Application with a modified version of the Linked Version. (If" + , " you use option 4d0, the Installation Information must accompany" + , " the Minimal Corresponding Source and Corresponding Application" + , " Code. If you use option 4d1, you must provide the Installation" + , " Information in the manner specified by section 6 of the GNU GPL" + , " for conveying Corresponding Source.)" + , "" + , " 5. Combined Libraries." + , "" + , " You may place library facilities that are a work based on the" + , "Library side by side in a single library together with other library" + , "facilities that are not Applications and are not covered by this" + , "License, and convey such a combined library under terms of your" + , "choice, if you do both of the following:" + , "" + , " a) Accompany the combined library with a copy of the same work based" + , " on the Library, uncombined with any other library facilities," + , " conveyed under the terms of this License." + , "" + , " b) Give prominent notice with the combined library that part of it" + , " is a work based on the Library, and explaining where to find the" + , " accompanying uncombined form of the same work." + , "" + , " 6. Revised Versions of the GNU Lesser General Public License." + , "" + , " The Free Software Foundation may publish revised and/or new versions" + , "of the GNU Lesser General Public License from time to time. Such new" + , "versions will be similar in spirit to the present version, but may" + , "differ in detail to address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Library as you received it specifies that a certain numbered version" + , "of the GNU Lesser General Public License \"or any later version\"" + , "applies to it, you have the option of following the terms and" + , "conditions either of that published version or of any later version" + , "published by the Free Software Foundation. If the Library as you" + , "received it does not specify a version number of the GNU Lesser" + , "General Public License, you may choose any version of the GNU Lesser" + , "General Public License ever published by the Free Software Foundation." + , "" + , " If the Library as you received it specifies that a proxy can decide" + , "whether future versions of the GNU Lesser General Public License shall" + , "apply, that proxy's public statement of acceptance of any version is" + , "permanent authorization for you to choose that version for the" + , "Library." + ] + diff --git a/cabal-install-0.8.2/Distribution/Client/Init/Types.hs b/cabal-install-0.8.2/Distribution/Client/Init/Types.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Init/Types.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Types +-- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Some types used by the 'cabal init' command. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Types where + +import Distribution.Simple.Setup + ( Flag(..) ) + +import Distribution.Version +import qualified Distribution.Package as P +import Distribution.License +import Distribution.ModuleName + +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Text + +import Data.Monoid + +-- | InitFlags is really just a simple type to represent certain +-- portions of a .cabal file. Rather than have a flag for EVERY +-- possible field, we just have one for each field that the user is +-- likely to want and/or that we are likely to be able to +-- intelligently guess. +data InitFlags = + InitFlags { nonInteractive :: Flag Bool + , quiet :: Flag Bool + , packageDir :: Flag FilePath + , noComments :: Flag Bool + , minimal :: Flag Bool + + , packageName :: Flag String + , version :: Flag Version + , cabalVersion :: Flag VersionRange + , license :: Flag License + , author :: Flag String + , email :: Flag String + , homepage :: Flag String + + , synopsis :: Flag String + , category :: Flag (Either String Category) + + , packageType :: Flag PackageType + + , exposedModules :: Maybe [ModuleName] + , otherModules :: Maybe [ModuleName] + + , dependencies :: Maybe [P.Dependency] + , sourceDirs :: Maybe [String] + , buildTools :: Maybe [String] + } + deriving (Show) + +data PackageType = Library | Executable + deriving (Show, Read, Eq) + +instance Text PackageType where + disp = Disp.text . show + parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] + +instance Monoid InitFlags where + mempty = InitFlags + { nonInteractive = mempty + , quiet = mempty + , packageDir = mempty + , noComments = mempty + , minimal = mempty + , packageName = mempty + , version = mempty + , cabalVersion = mempty + , license = mempty + , author = mempty + , email = mempty + , homepage = mempty + , synopsis = mempty + , category = mempty + , packageType = mempty + , exposedModules = mempty + , otherModules = mempty + , dependencies = mempty + , sourceDirs = mempty + , buildTools = mempty + } + mappend a b = InitFlags + { nonInteractive = combine nonInteractive + , quiet = combine quiet + , packageDir = combine packageDir + , noComments = combine noComments + , minimal = combine minimal + , packageName = combine packageName + , version = combine version + , cabalVersion = combine cabalVersion + , license = combine license + , author = combine author + , email = combine email + , homepage = combine homepage + , synopsis = combine synopsis + , category = combine category + , packageType = combine packageType + , exposedModules = combine exposedModules + , otherModules = combine otherModules + , dependencies = combine dependencies + , sourceDirs = combine sourceDirs + , buildTools = combine buildTools + } + where combine field = field a `mappend` field b + +-- | Some common package categories. +data Category + = Codec + | Concurrency + | Control + | Data + | Database + | Development + | Distribution + | Game + | Graphics + | Language + | Math + | Network + | Sound + | System + | Testing + | Text + | Web + deriving (Read, Show, Eq, Ord, Bounded, Enum) + +instance Text Category where + disp = Disp.text . show + parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] + +#if MIN_VERSION_base(3,0,0) +#else +-- Compat instance for ghc-6.6 era +instance Monoid a => Monoid (Maybe a) where + mempty = Nothing + Nothing `mappend` m = m + m `mappend` Nothing = m + Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) +#endif diff --git a/cabal-install-0.8.2/Distribution/Client/Install.hs b/cabal-install-0.8.2/Distribution/Client/Install.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Install.hs @@ -0,0 +1,786 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Install +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- High level interface to package installation. +----------------------------------------------------------------------------- +module Distribution.Client.Install ( + install, + upgrade, + ) where + +import Data.List + ( unfoldr, find, nub, sort ) +import Data.Maybe + ( isJust, fromMaybe ) +import qualified Data.Map as Map +import Control.Exception as Exception + ( handleJust ) +#if MIN_VERSION_base(4,0,0) +import Control.Exception as Exception + ( Exception(toException), catches, Handler(Handler), IOException ) +import System.Exit + ( ExitCode ) +#else +import Control.Exception as Exception + ( Exception(IOException, ExitException) ) +#endif +import Distribution.Compat.Exception + ( SomeException, catchIO, catchExit ) +import Control.Monad + ( when, unless ) +import System.Directory + ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing ) +import System.FilePath + ( (), (<.>), takeDirectory ) +import System.IO + ( openFile, IOMode(AppendMode) ) +import System.IO.Error + ( isDoesNotExistError, ioeGetFileName ) + +import Distribution.Client.Dependency + ( resolveDependenciesWithProgress + , PackageConstraint(..), dependencyConstraints, dependencyTargets + , PackagesPreference(..), PackagesPreferenceDefault(..) + , PackagePreference(..) + , upgradableDependencies + , Progress(..), foldProgress, ) +import Distribution.Client.Fetch (fetchPackage) +import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) +-- import qualified Distribution.Client.Info as Info +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, disambiguateDependencies + , getInstalledPackages ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Setup + ( ConfigFlags(..), configureCommand, filterConfigureFlags + , ConfigExFlags(..), InstallFlags(..) ) +import Distribution.Client.Config + ( defaultLogsDir, defaultCabalDir ) +import Distribution.Client.Tar (extractTarGzFile) +import Distribution.Client.Types as Available + ( UnresolvedDependency(..), AvailablePackage(..) + , AvailablePackageSource(..), AvailablePackageDb(..) + , Repo(..), ConfiguredPackage(..) + , BuildResult, BuildFailure(..), BuildSuccess(..) + , DocsResult(..), TestsResult(..), RemoteRepo(..) + , InstalledPackage ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReports +import qualified Distribution.Client.BuildReports.Storage as BuildReports + ( storeAnonymous, storeLocal, fromInstallPlan ) +import qualified Distribution.Client.InstallSymlink as InstallSymlink + ( symlinkBinaries ) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade +import Paths_cabal_install (getBinDir) + +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId), compilerFlavor + , PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Simple.Setup + ( haddockCommand, HaddockFlags(..), emptyHaddockFlags + , buildCommand, BuildFlags(..), emptyBuildFlags + , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.Setup as Cabal + ( installCommand, InstallFlags(..), emptyInstallFlags ) +import Distribution.Simple.Utils + ( defaultPackageDesc, rawSystemExit, comparing ) +import Distribution.Simple.InstallDirs as InstallDirs + ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate + , initialPathTemplateEnv, installDirsTemplateEnv ) +import Distribution.Package + ( PackageName, PackageIdentifier, packageName, packageVersion + , Package(..), PackageFixedDeps(..) + , Dependency(..), thisPackageVersion ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Version + ( Version, VersionRange, anyVersion, thisVersion ) +import Distribution.Simple.Utils as Utils + ( notice, info, warn, die, intercalate, withTempDirectory ) +import Distribution.Client.Utils + ( inDir, mergeBy, MergeResult(..) ) +import Distribution.System + ( Platform, buildPlatform, OS(Windows), buildOS ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, showForCabal, verbose ) +import Distribution.Simple.BuildPaths ( exeExtension ) + +data InstallMisc = InstallMisc { + rootCmd :: Maybe FilePath, + libVersion :: Maybe Version + } + +-- |Installs the packages needed to satisfy a list of dependencies. +install, upgrade + :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> [UnresolvedDependency] + -> IO () +install verbosity packageDB repos comp conf + configFlags configExFlags installFlags deps = + + installWithPlanner planner + verbosity packageDB repos comp conf + configFlags configExFlags installFlags + where + planner :: Planner + planner | null deps = planLocalPackage verbosity + comp configFlags configExFlags + | otherwise = planRepoPackages PreferLatestForSelected + comp configFlags configExFlags installFlags deps + +upgrade verbosity packageDB repos comp conf + configFlags configExFlags installFlags deps = + + installWithPlanner planner + verbosity packageDB repos comp conf + configFlags configExFlags installFlags + where + planner :: Planner + planner | null deps = planUpgradePackages + comp configFlags configExFlags + | otherwise = planRepoPackages PreferAllLatest + comp configFlags configExFlags installFlags deps + +type Planner = Maybe (PackageIndex InstalledPackage) + -> AvailablePackageDb + -> IO (Progress String String InstallPlan) + +-- |Installs the packages generated by a planner. +installWithPlanner :: + Planner + -> Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> IO () +installWithPlanner planner verbosity packageDBs repos comp conf + configFlags configExFlags installFlags = do + + installed <- getInstalledPackages verbosity comp packageDBs conf + available <- getAvailablePackages verbosity repos + + progress <- planner installed available + + notice verbosity "Resolving dependencies..." + maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) + (return . Left) (return . Right) progress + case maybePlan of + Left message -> die message + Right installPlan -> do + let nothingToInstall = null (InstallPlan.ready installPlan) + when nothingToInstall $ + notice verbosity $ + "No packages to be installed. All the requested packages are " + ++ "already installed.\n If you want to reinstall anyway then use " + ++ "the --reinstall flag." + + when (dryRun || verbosity >= verbose) $ + printDryRun verbosity installed installPlan + + unless dryRun $ do + logsDir <- defaultLogsDir + let platform = InstallPlan.planPlatform installPlan + compid = InstallPlan.planCompiler installPlan + installPlan' <- + executeInstallPlan installPlan $ \cpkg -> + installConfiguredPackage platform compid configFlags + cpkg $ \configFlags' src pkg -> + installAvailablePackage verbosity (packageId pkg) src $ \mpath -> + installUnpackedPackage verbosity (setupScriptOptions installed) + miscOptions configFlags' installFlags + compid pkg mpath (useLogFile logsDir) + + -- build reporting, local and remote + let buildReports = BuildReports.fromInstallPlan installPlan' + BuildReports.storeLocal (installSummaryFile installFlags) buildReports + when (reportingLevel >= AnonymousReports) $ + BuildReports.storeAnonymous buildReports + when (reportingLevel == DetailedReports) $ + storeDetailedBuildReports verbosity logsDir buildReports + regenerateHaddockIndex verbosity packageDBs comp conf + configFlags installFlags installPlan' + symlinkBinaries verbosity configFlags installFlags installPlan' + printBuildFailures installPlan' + + where + setupScriptOptions index = SetupScriptOptions { + useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), + useCompiler = Just comp, + -- Hack: we typically want to allow the UserPackageDB for finding the + -- Cabal lib when compiling any Setup.hs even if we're doing a global + -- install. However we also allow looking in a specific package db. + usePackageDB = if UserPackageDB `elem` packageDBs + then packageDBs + else let (db@GlobalPackageDB:dbs) = packageDBs + in db : UserPackageDB : dbs, + --TODO: use Ord instance: + -- insert UserPackageDB packageDBs + usePackageIndex = if UserPackageDB `elem` packageDBs + then index + else Nothing, + useProgramConfig = conf, + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags), + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + reportingLevel = fromFlag (installBuildReports installFlags) + useLogFile :: FilePath -> Maybe (PackageIdentifier -> FilePath) + useLogFile logsDir = fmap substLogFileName logFileTemplate + where + logFileTemplate :: Maybe PathTemplate + logFileTemplate --TODO: separate policy from mechanism + | reportingLevel == DetailedReports + = Just $ toPathTemplate $ logsDir "$pkgid" <.> "log" + | otherwise + = flagToMaybe (installLogFile installFlags) + substLogFileName template pkg = fromPathTemplate + . substPathTemplate env + $ template + where env = initialPathTemplateEnv (packageId pkg) (compilerId comp) + dryRun = fromFlag (installDryRun installFlags) + miscOptions = InstallMisc { + rootCmd = if fromFlag (configUserInstall configFlags) + then Nothing -- ignore --root-cmd if --user. + else flagToMaybe (installRootCmd installFlags), + libVersion = flagToMaybe (configCabalVersion configExFlags) + } + +storeDetailedBuildReports :: Verbosity -> FilePath + -> [(BuildReports.BuildReport, Repo)] -> IO () +storeDetailedBuildReports verbosity logsDir reports = sequence_ + [ do dotCabal <- defaultCabalDir + let logFileName = display (BuildReports.package report) <.> "log" + logFile = logsDir logFileName + reportsDir = dotCabal "reports" remoteRepoName remoteRepo + reportFile = reportsDir logFileName + + handleMissingLogFile $ do + buildLog <- readFile logFile + createDirectoryIfMissing True reportsDir -- FIXME + writeFile reportFile (show (BuildReports.show report, buildLog)) + + | (report, Repo { repoKind = Left remoteRepo }) <- reports + , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] + + where + isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True + isLikelyToHaveLogFile BuildReports.BuildFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallOk {} = True + isLikelyToHaveLogFile _ = False + + handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> + warn verbosity $ "Missing log file for build report: " + ++ fromMaybe "" (ioeGetFileName ioe) + +#if MIN_VERSION_base(4,0,0) + missingFile ioe +#else + missingFile (IOException ioe) +#endif + | isDoesNotExistError ioe = Just ioe + missingFile _ = Nothing + +regenerateHaddockIndex :: Verbosity + -> [PackageDB] + -> Compiler + -> ProgramConfiguration + -> ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO () +regenerateHaddockIndex verbosity packageDBs comp conf + configFlags installFlags installPlan + | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do + + defaultDirs <- InstallDirs.defaultInstallDirs + (compilerFlavor comp) + (fromFlag (configUserInstall configFlags)) + True + let indexFileTemplate = fromFlag (installHaddockIndex installFlags) + indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate + + notice verbosity $ + "Updating documentation index " ++ indexFile + + --TODO: might be nice if the install plan gave us the new InstalledPackageInfo + installed <- getInstalledPackages verbosity comp packageDBs conf + case installed of + Nothing -> return () -- warning ? + Just index -> Haddock.regenerateHaddockIndex verbosity index conf indexFile + + | otherwise = return () + where + haddockIndexFileIsRequested = + fromFlag (installDocumentation installFlags) + && isJust (flagToMaybe (installHaddockIndex installFlags)) + + -- We want to regenerate the index if some new documentation was actually + -- installed. Since the index is per-user, we don't do it for global + -- installs or special cases where we're installing into a specific db. + shouldRegenerateHaddockIndex = normalUserInstall + && someDocsWereInstalled installPlan + where + someDocsWereInstalled = any installedDocs . InstallPlan.toList + normalUserInstall = (UserPackageDB `elem` packageDBs) + && all (not . isSpecificPackageDB) packageDBs + + installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True + installedDocs _ = False + isSpecificPackageDB (SpecificPackageDB _) = True + isSpecificPackageDB _ = False + + substHaddockIndexFileName defaultDirs = fromPathTemplate + . substPathTemplate env + where + env = env0 ++ installDirsTemplateEnv absoluteDirs + env0 = InstallDirs.compilerTemplateEnv (compilerId comp) + ++ InstallDirs.platformTemplateEnv (buildPlatform) + absoluteDirs = InstallDirs.substituteInstallDirTemplates + env0 templateDirs + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + + +-- | Make an 'InstallPlan' for the unpacked package in the current directory, +-- and all its dependencies. +-- +planLocalPackage :: Verbosity -> Compiler + -> ConfigFlags -> ConfigExFlags -> Planner +planLocalPackage verbosity comp configFlags configExFlags installed + (AvailablePackageDb available availablePrefs) = do + pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity + let -- The trick is, we add the local package to the available index and + -- remove it from the installed index. Then we ask to resolve a + -- dependency on exactly that package. So the resolver ends up having + -- to pick the local package. + available' = PackageIndex.insert localPkg available + installed' = PackageIndex.deletePackageId (packageId localPkg) `fmap` installed + localPkg = AvailablePackage { + packageInfoId = packageId pkg, + Available.packageDescription = pkg, + packageSource = LocalUnpackedPackage + } + targets = [packageName pkg] + constraints = [PackageVersionConstraint (packageName pkg) + (thisVersion (packageVersion pkg)) + ,PackageFlagsConstraint (packageName pkg) + (configConfigurationsFlags configFlags)] + ++ [ PackageVersionConstraint name ver + | Dependency name ver <- configConstraints configFlags ] + preferences = mergePackagePrefs PreferLatestForSelected + availablePrefs configExFlags + + return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) + installed' available' preferences constraints targets + +-- | Make an 'InstallPlan' for the given dependencies. +-- +planRepoPackages :: PackagesPreferenceDefault -> Compiler + -> ConfigFlags -> ConfigExFlags -> InstallFlags + -> [UnresolvedDependency] -> Planner +planRepoPackages defaultPref comp configFlags configExFlags installFlags + deps installed (AvailablePackageDb available availablePrefs) = do + + deps' <- IndexUtils.disambiguateDependencies available deps + let installed' + | fromFlag (installReinstall installFlags) + = fmap (hideGivenDeps deps') installed + | otherwise = installed + targets = dependencyTargets deps' + constraints = dependencyConstraints deps' + ++ [ PackageVersionConstraint name ver + | Dependency name ver <- configConstraints configFlags ] + preferences = mergePackagePrefs defaultPref availablePrefs configExFlags + return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) + installed' available preferences constraints targets + where + hideGivenDeps pkgs index = + foldr PackageIndex.deletePackageName index + [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] + +planUpgradePackages :: Compiler -> ConfigFlags -> ConfigExFlags -> Planner +planUpgradePackages _comp _configFlags _configExFlags (Just installed) + (AvailablePackageDb available _availablePrefs) = die $ + "the 'upgrade' command (when used without any package arguments) has " + ++ "been disabled in this release. It has been disabled because it has " + ++ "frequently led people to accidentally break their set of installed " + ++ "packages. It will be re-enabled when it is safer to use.\n" + ++ "Below is the list of packages that it would have tried to upgrade. You " + ++ "can use the 'install' command to install the ones you want. Note that " + ++ "it is generally not recommended to upgrade core packages.\n" + ++ unlines [ display pkgid | Dependency pkgid _ <- deps ] + +--TODO: improve upgrade so we can re-enable it +-- return $ +-- resolveDependenciesWithProgress buildPlatform (compilerId comp) +-- (Just installed) available preferences constraints targets + where + deps = upgradableDependencies installed available +-- preferences = mergePackagePrefs PreferAllLatest availablePrefs configExFlags +-- constraints = [ PackageVersionConstraint name ver +-- | Dependency name ver <- deps ] +-- ++ [ PackageVersionConstraint name ver +-- | Dependency name ver <- configConstraints configFlags ] +-- targets = [ name | Dependency name _ <- deps ] + +planUpgradePackages comp _ _ _ _ = + die $ display (compilerId comp) + ++ " does not track installed packages so cabal cannot figure out what" + ++ " packages need to be upgraded." + +mergePackagePrefs :: PackagesPreferenceDefault + -> Map.Map PackageName VersionRange + -> ConfigExFlags + -> PackagesPreference +mergePackagePrefs defaultPref availablePrefs configExFlags = + PackagesPreference defaultPref $ + -- The preferences that come from the hackage index + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList availablePrefs ] + -- additional preferences from the config file or command line + ++ [ PackageVersionPreference name ver + | Dependency name ver <- configPreferences configExFlags ] + +printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackage) + -> InstallPlan -> IO () +printDryRun verbosity minstalled plan = case unfoldr next plan of + [] -> return () + pkgs + | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ + "In order, the following would be installed:" + : map showPkgAndReason pkgs + | otherwise -> notice verbosity $ unlines $ + "In order, the following would be installed (use -v for more details):" + : map (display . packageId) pkgs + where + next plan' = case InstallPlan.ready plan' of + [] -> Nothing + (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan') + where pkgid = packageId pkg + result = BuildOk DocsNotTried TestsNotTried + --FIXME: This is a bit of a hack, + -- pretending that each package is installed + + showPkgAndReason pkg' = display (packageId pkg') ++ " " ++ + case minstalled of + Nothing -> "" + Just installed -> + case PackageIndex.lookupPackageName installed (packageName pkg') of + [] -> "(new package)" + ps -> case find ((==packageId pkg') . packageId) ps of + Nothing -> "(new version)" + Just pkg -> "(reinstall)" ++ case changes pkg pkg' of + [] -> "" + diff -> " changes: " ++ intercalate ", " diff + changes pkg pkg' = map change . filter changed + $ mergeBy (comparing packageName) + (nub . sort . depends $ pkg) + (nub . sort . depends $ pkg') + change (OnlyInLeft pkgid) = display pkgid ++ " removed" + change (InBoth pkgid pkgid') = display pkgid ++ " -> " + ++ display (packageVersion pkgid') + change (OnlyInRight pkgid') = display pkgid' ++ " added" + changed (InBoth pkgid pkgid') = pkgid /= pkgid' + changed _ = True + +symlinkBinaries :: Verbosity + -> ConfigFlags + -> InstallFlags + -> InstallPlan -> IO () +symlinkBinaries verbosity configFlags installFlags plan = do + failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan + case failed of + [] -> return () + [(_, exe, path)] -> + warn verbosity $ + "could not create a symlink in " ++ bindir ++ " for " + ++ exe ++ " because the file exists there already but is not " + ++ "managed by cabal. You can create a symlink for this executable " + ++ "manually if you wish. The executable file has been installed at " + ++ path + exes -> + warn verbosity $ + "could not create symlinks in " ++ bindir ++ " for " + ++ intercalate ", " [ exe | (_, exe, _) <- exes ] + ++ " because the files exist there already and are not " + ++ "managed by cabal. You can create symlinks for these executables " + ++ "manually if you wish. The executable files have been installed at " + ++ intercalate ", " [ path | (_, _, path) <- exes ] + where + bindir = fromFlag (installSymlinkBinDir installFlags) + +printBuildFailures :: InstallPlan -> IO () +printBuildFailures plan = + case [ (pkg, reason) + | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of + [] -> return () + failed -> die . unlines + $ "Error: some packages failed to install:" + : [ display (packageId pkg) ++ printFailureReason reason + | (pkg, reason) <- failed ] + where + printFailureReason reason = case reason of + DependentFailed pkgid -> " depends on " ++ display pkgid + ++ " which failed to install." + DownloadFailed e -> " failed while downloading the package." + ++ " The exception was:\n " ++ show e + UnpackFailed e -> " failed while unpacking the package." + ++ " The exception was:\n " ++ show e + ConfigureFailed e -> " failed during the configure step." + ++ " The exception was:\n " ++ show e + BuildFailed e -> " failed during the building phase." + ++ " The exception was:\n " ++ show e + InstallFailed e -> " failed during the final install step." + ++ " The exception was:\n " ++ show e + +executeInstallPlan :: Monad m + => InstallPlan + -> (ConfiguredPackage -> m BuildResult) + -> m InstallPlan +executeInstallPlan plan installPkg = case InstallPlan.ready plan of + [] -> return plan + (pkg: _) -> do buildResult <- installPkg pkg + let plan' = updatePlan (packageId pkg) buildResult plan + executeInstallPlan plan' installPkg + where + updatePlan pkgid (Right buildSuccess) = + InstallPlan.completed pkgid buildSuccess + + updatePlan pkgid (Left buildFailure) = + InstallPlan.failed pkgid buildFailure depsFailure + where + depsFailure = DependentFailed pkgid + -- So this first pkgid failed for whatever reason (buildFailure). + -- All the other packages that depended on this pkgid, which we + -- now cannot build, we mark as failing due to 'DependentFailed' + -- which kind of means it was not their fault. + +-- | Call an installer for an 'AvailablePackage' but override the configure +-- flags with the ones given by the 'ConfiguredPackage'. In particular the +-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +installConfiguredPackage :: Platform -> CompilerId + -> ConfigFlags -> ConfiguredPackage + -> (ConfigFlags -> AvailablePackageSource + -> PackageDescription -> a) + -> a +installConfiguredPackage platform comp configFlags + (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps) + installPkg = installPkg configFlags { + configConfigurationsFlags = flags, + configConstraints = map thisPackageVersion deps + } source pkg + where + pkg = case finalizePackageDescription flags + (const True) + platform comp [] gpkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc + +installAvailablePackage + :: Verbosity -> PackageIdentifier -> AvailablePackageSource + -> (Maybe FilePath -> IO BuildResult) + -> IO BuildResult +installAvailablePackage _ _ LocalUnpackedPackage installPkg = + installPkg Nothing + +installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg = + onFailure DownloadFailed $ do + pkgPath <- fetchPackage verbosity repo pkgid + onFailure UnpackFailed $ do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> do + info verbosity $ "Extracting " ++ pkgPath + ++ " to " ++ tmpDirPath ++ "..." + 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 absUnpackedPath) + +installUnpackedPackage :: Verbosity + -> SetupScriptOptions + -> InstallMisc + -> ConfigFlags + -> InstallFlags + -> CompilerId + -> PackageDescription + -> Maybe FilePath -- ^ Directory to change to before starting the installation. + -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any) + -> IO BuildResult +installUnpackedPackage verbosity scriptOptions miscOptions + configFlags installConfigFlags + compid pkg workingDir useLogFile = + + -- Configure phase + onFailure ConfigureFailed $ do + setup configureCommand configureFlags + + -- Build phase + onFailure BuildFailed $ do + setup buildCommand' buildFlags + + -- Doc generation phase + docsResult <- if shouldHaddock + then (do setup haddockCommand haddockFlags + return DocsOk) + `catchIO` (\_ -> return DocsFailed) + `catchExit` (\_ -> return DocsFailed) + else return DocsNotTried + + -- Tests phase + testsResult <- return TestsNotTried --TODO: add optional tests + + -- Install phase + onFailure InstallFailed $ + withWin32SelfUpgrade verbosity configFlags compid pkg $ do + case rootCmd miscOptions of + (Just cmd) -> reexec cmd + Nothing -> setup Cabal.installCommand installFlags + return (Right (BuildOk docsResult testsResult)) + + where + configureFlags = filterConfigureFlags configFlags { + configVerbosity = toFlag verbosity' + } + buildCommand' = buildCommand defaultProgramConfiguration + buildFlags _ = emptyBuildFlags { + buildDistPref = configDistPref configFlags, + buildVerbosity = toFlag verbosity' + } + shouldHaddock = fromFlag (installDocumentation installConfigFlags) + haddockFlags _ = emptyHaddockFlags { + haddockDistPref = configDistPref configFlags, + haddockVerbosity = toFlag verbosity' + } + installFlags _ = Cabal.emptyInstallFlags { + Cabal.installDistPref = configDistPref configFlags, + Cabal.installVerbosity = toFlag verbosity' + } + verbosity' | isJust useLogFile = max Verbosity.verbose verbosity + | otherwise = verbosity + setup cmd flags = do + logFileHandle <- case useLogFile of + Nothing -> return Nothing + Just mkLogFileName -> do + let logFileName = mkLogFileName (packageId pkg) + logDir = takeDirectory logFileName + unless (null logDir) $ createDirectoryIfMissing True logDir + logFile <- openFile logFileName AppendMode + return (Just logFile) + + setupWrapper verbosity + scriptOptions { useLoggingHandle = logFileHandle + , useWorkingDir = workingDir } + (Just pkg) + cmd flags [] + reexec cmd = do + -- look for our on executable file and re-exec ourselves using + -- a helper program like sudo to elevate priviledges: + bindir <- getBinDir + let self = bindir "cabal" <.> exeExtension + weExist <- doesFileExist self + if weExist + then inDir workingDir $ + rawSystemExit verbosity cmd + [self, "install", "--only" + ,"--verbose=" ++ showForCabal verbosity] + else die $ "Unable to find cabal executable at: " ++ self + +-- helper +onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult +onFailure result action = +#if MIN_VERSION_base(4,0,0) + action `catches` + [ Handler $ \ioe -> handler (ioe :: IOException) + , Handler $ \exit -> handler (exit :: ExitCode) + ] + where + handler :: Exception e => e -> IO BuildResult + handler = return . Left . result . toException +#else + action + `catchIO` (return . Left . result . IOException) + `catchExit` (return . Left . result . ExitException) +#endif + +withWin32SelfUpgrade :: Verbosity + -> ConfigFlags + -> CompilerId + -> PackageDescription + -> IO a -> IO a +withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action +withWin32SelfUpgrade verbosity configFlags compid pkg action = do + + defaultDirs <- InstallDirs.defaultInstallDirs + compFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + + Win32SelfUpgrade.possibleSelfUpgrade verbosity + (exeInstallPaths defaultDirs) action + + where + pkgid = packageId pkg + (CompilerId compFlavor _) = compid + + exeInstallPaths defaultDirs = + [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension + | exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) + , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix + prefix = substTemplate prefixTemplate + suffix = substTemplate suffixTemplate ] + where + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + pkgid compid InstallDirs.NoCopyDest templateDirs + substTemplate = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid compid diff --git a/cabal-install-0.8.2/Distribution/Client/InstallPlan.hs b/cabal-install-0.8.2/Distribution/Client/InstallPlan.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/InstallPlan.hs @@ -0,0 +1,495 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallPlan +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Package installation plan +-- +----------------------------------------------------------------------------- +module Distribution.Client.InstallPlan ( + InstallPlan, + ConfiguredPackage(..), + PlanPackage(..), + + -- * Operations on 'InstallPlan's + new, + toList, + ready, + completed, + failed, + + -- ** Query functions + planPlatform, + planCompiler, + + -- * Checking valididy of plans + valid, + closed, + consistent, + acyclic, + configuredPackageValid, + + -- ** Details on invalid plans + PlanProblem(..), + showPlanProblem, + PackageProblem(..), + showPackageProblem, + problems, + configuredPackageProblems + ) where + +import Distribution.Client.Types + ( AvailablePackage(packageDescription), ConfiguredPackage(..) + , InstalledPackage + , BuildFailure, BuildSuccess ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(..), packageName + , PackageFixedDeps(..), Dependency(..) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.PackageDescription + ( GenericPackageDescription(genPackageFlags) + , Flag(flagName), FlagName(..) ) +import Distribution.Client.PackageUtils + ( externalBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Text + ( display ) +import Distribution.System + ( Platform ) +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.Client.Utils + ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) +import Distribution.Simple.Utils + ( comparing, intercalate ) + +import Data.List + ( sort, sortBy ) +import Data.Maybe + ( fromMaybe ) +import qualified Data.Graph as Graph +import Data.Graph (Graph) +import Control.Exception + ( assert ) + +-- When cabal tries to install a number of packages, including all their +-- dependencies it has a non-trivial problem to solve. +-- +-- The Problem: +-- +-- In general we start with a set of installed packages and a set of available +-- packages. +-- +-- Installed packages have fixed dependencies. They have already been built and +-- we know exactly what packages they were built against, including their exact +-- versions. +-- +-- Available package have somewhat flexible dependencies. They are specified as +-- version ranges, though really they're predicates. To make matters worse they +-- have conditional flexible dependencies. Configuration flags can affect which +-- packages are required and can place additional constraints on their +-- versions. +-- +-- These two sets of package can and usually do overlap. There can be installed +-- packages that are also available which means they could be re-installed if +-- required, though there will also be packages which are not available and +-- cannot be re-installed. Very often there will be extra versions available +-- than are installed. Sometimes we may like to prefer installed packages over +-- available ones or perhaps always prefer the latest available version whether +-- installed or not. +-- +-- The goal is to calculate an installation plan that is closed, acyclic and +-- consistent and where every configured package is valid. +-- +-- An installation plan is a set of packages that are going to be used +-- together. It will consist of a mixture of installed packages and available +-- packages along with their exact version dependencies. An installation plan +-- is closed if for every package in the set, all of its dependencies are +-- also in the set. It is consistent if for every package in the set, all +-- dependencies which target that package have the same version. + +-- Note that plans do not necessarily compose. You might have a valid plan for +-- package A and a valid plan for package B. That does not mean the composition +-- is simultaniously valid for A and B. In particular you're most likely to +-- have problems with inconsistent dependencies. +-- On the other hand it is true that every closed sub plan is valid. + +data PlanPackage = PreExisting InstalledPackage + | Configured ConfiguredPackage + | Installed ConfiguredPackage BuildSuccess + | Failed ConfiguredPackage BuildFailure + +instance Package PlanPackage where + packageId (PreExisting pkg) = packageId pkg + packageId (Configured pkg) = packageId pkg + packageId (Installed pkg _) = packageId pkg + packageId (Failed pkg _) = packageId pkg + +instance PackageFixedDeps PlanPackage where + depends (PreExisting pkg) = depends pkg + depends (Configured pkg) = depends pkg + depends (Installed pkg _) = depends pkg + depends (Failed pkg _) = depends pkg + +data InstallPlan = InstallPlan { + planIndex :: PackageIndex PlanPackage, + planGraph :: Graph, + planGraphRev :: Graph, + planPkgOf :: Graph.Vertex -> PlanPackage, + planVertexOf :: PackageIdentifier -> Graph.Vertex, + planPlatform :: Platform, + planCompiler :: CompilerId + } + +invariant :: InstallPlan -> Bool +invariant plan = + valid (planPlatform plan) (planCompiler plan) (planIndex plan) + +internalError :: String -> a +internalError msg = error $ "InstallPlan: internal error: " ++ msg + +-- | Build an installation plan from a valid set of resolved packages. +-- +new :: Platform -> CompilerId -> PackageIndex PlanPackage + -> Either [PlanProblem] InstallPlan +new platform compiler index = + case problems platform compiler index of + [] -> Right InstallPlan { + planIndex = index, + planGraph = graph, + planGraphRev = Graph.transposeG graph, + planPkgOf = vertexToPkgId, + planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, + planPlatform = platform, + planCompiler = compiler + } + where (graph, vertexToPkgId, pkgIdToVertex) = + PackageIndex.dependencyGraph index + noSuchPkgId = internalError "package is not in the graph" + probs -> Left probs + +toList :: InstallPlan -> [PlanPackage] +toList = PackageIndex.allPackages . planIndex + +-- | The packages that are ready to be installed. That is they are in the +-- configured state and have all their dependencies installed already. +-- The plan is complete if the result is @[]@. +-- +ready :: InstallPlan -> [ConfiguredPackage] +ready plan = assert check readyPackages + where + check = if null readyPackages then null configuredPackages else True + configuredPackages = + [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ] + readyPackages = filter (all isInstalled . depends) configuredPackages + isInstalled pkg = + case PackageIndex.lookupPackageId (planIndex plan) pkg of + Just (Configured _) -> False + Just (Failed _ _) -> internalError depOnFailed + Just (PreExisting _) -> True + Just (Installed _ _) -> True + Nothing -> internalError incomplete + incomplete = "install plan is not closed" + depOnFailed = "configured package depends on failed package" + +-- | Marks a package in the graph as completed. Also saves the build result for +-- the completed package in the plan. +-- +-- * The package must exist in the graph. +-- * The package must have had no uninstalled dependent packages. +-- +completed :: PackageIdentifier + -> BuildSuccess + -> InstallPlan -> InstallPlan +completed pkgid buildResult plan = assert (invariant plan') plan' + where + plan' = plan { + planIndex = PackageIndex.insert installed (planIndex plan) + } + installed = Installed (lookupConfiguredPackage plan pkgid) buildResult + +-- | Marks a package in the graph as having failed. It also marks all the +-- packages that depended on it as having failed. +-- +-- * The package must exist in the graph and be in the configured state. +-- +failed :: PackageIdentifier -- ^ The id of the package that failed to install + -> BuildFailure -- ^ The build result to use for the failed package + -> BuildFailure -- ^ The build result to use for its dependencies + -> InstallPlan + -> InstallPlan +failed pkgid buildResult buildResult' plan = assert (invariant plan') plan' + where + plan' = plan { + planIndex = PackageIndex.merge (planIndex plan) failures + } + pkg = lookupConfiguredPackage plan pkgid + failures = PackageIndex.fromList + $ Failed pkg buildResult + : [ Failed pkg' buildResult' + | Just pkg' <- map checkConfiguredPackage + $ packagesThatDependOn plan pkgid ] + +-- | lookup the reachable packages in the reverse dependency graph +-- +packagesThatDependOn :: InstallPlan + -> PackageIdentifier -> [PlanPackage] +packagesThatDependOn plan = map (planPkgOf plan) + . tail + . Graph.reachable (planGraphRev plan) + . planVertexOf plan + +-- | lookup a package that we expect to be in the configured state +-- +lookupConfiguredPackage :: InstallPlan + -> PackageIdentifier -> ConfiguredPackage +lookupConfiguredPackage plan pkgid = + case PackageIndex.lookupPackageId (planIndex plan) pkgid of + Just (Configured pkg) -> pkg + _ -> internalError $ "not configured or no such pkg " ++ display pkgid + +-- | check a package that we expect to be in the configured or failed state +-- +checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage +checkConfiguredPackage (Configured pkg) = Just pkg +checkConfiguredPackage (Failed _ _) = Nothing +checkConfiguredPackage pkg = + internalError $ "not configured or no such pkg " ++ display (packageId pkg) + +-- ------------------------------------------------------------ +-- * Checking valididy of plans +-- ------------------------------------------------------------ + +-- | A valid installation plan is a set of packages that is 'acyclic', +-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the +-- plan has to have a valid configuration (see 'configuredPackageValid'). +-- +-- * if the result is @False@ use 'problems' to get a detailed list. +-- +valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool +valid platform comp index = null (problems platform comp index) + +data PlanProblem = + PackageInvalid ConfiguredPackage [PackageProblem] + | PackageMissingDeps PlanPackage [PackageIdentifier] + | PackageCycle [PlanPackage] + | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageStateInvalid PlanPackage PlanPackage + +showPlanProblem :: PlanProblem -> String +showPlanProblem (PackageInvalid pkg packageProblems) = + "Package " ++ display (packageId pkg) + ++ " has an invalid configuration, in particular:\n" + ++ unlines [ " " ++ showPackageProblem problem + | problem <- packageProblems ] + +showPlanProblem (PackageMissingDeps pkg missingDeps) = + "Package " ++ display (packageId pkg) + ++ " depends on the following packages which are missing from the plan " + ++ intercalate ", " (map display missingDeps) + +showPlanProblem (PackageCycle cycleGroup) = + "The following packages are involved in a dependency cycle " + ++ intercalate ", " (map (display.packageId) cycleGroup) + +showPlanProblem (PackageInconsistency name inconsistencies) = + "Package " ++ display name + ++ " is required by several packages," + ++ " but they require inconsistent versions:\n" + ++ unlines [ " package " ++ display pkg ++ " requires " + ++ display (PackageIdentifier name ver) + | (pkg, ver) <- inconsistencies ] + +showPlanProblem (PackageStateInvalid pkg pkg') = + "Package " ++ display (packageId pkg) + ++ " is in the " ++ showPlanState pkg + ++ " state but it depends on package " ++ display (packageId pkg') + ++ " which is in the " ++ showPlanState pkg' + ++ " state" + where + showPlanState (PreExisting _) = "pre-existing" + showPlanState (Configured _) = "configured" + showPlanState (Installed _ _) = "installed" + showPlanState (Failed _ _) = "failed" + +-- | For an invalid plan, produce a detailed list of problems as human readable +-- error messages. This is mainly intended for debugging purposes. +-- Use 'showPlanProblem' for a human readable explanation. +-- +problems :: Platform -> CompilerId + -> PackageIndex PlanPackage -> [PlanProblem] +problems platform comp index = + [ PackageInvalid pkg packageProblems + | Configured pkg <- PackageIndex.allPackages index + , let packageProblems = configuredPackageProblems platform comp pkg + , not (null packageProblems) ] + + ++ [ PackageMissingDeps pkg missingDeps + | (pkg, missingDeps) <- PackageIndex.brokenPackages index ] + + ++ [ PackageCycle cycleGroup + | cycleGroup <- PackageIndex.dependencyCycles index ] + + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ] + + ++ [ PackageStateInvalid pkg pkg' + | pkg <- PackageIndex.allPackages index + , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg) + , not (stateDependencyRelation pkg pkg') ] + +-- | The graph of packages (nodes) and dependencies (edges) must be acyclic. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out +-- which packages are involved in dependency cycles. +-- +acyclic :: PackageIndex PlanPackage -> Bool +acyclic = null . PackageIndex.dependencyCycles + +-- | An installation plan is closed if for every package in the set, all of +-- its dependencies are also in the set. That is, the set is closed under the +-- dependency relation. +-- +-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out +-- which packages depend on packages not in the index. +-- +closed :: PackageIndex PlanPackage -> Bool +closed = null . PackageIndex.brokenPackages + +-- | An installation plan is consistent if all dependencies that target a +-- single package name, target the same version. +-- +-- This is slightly subtle. It is not the same as requiring that there be at +-- most one version of any package in the set. It only requires that of +-- packages which have more than one other package depending on them. We could +-- actually make the condition even more precise and say that different +-- versions are ok so long as they are not both in the transative closure of +-- any other package (or equivalently that their inverse closures do not +-- intersect). The point is we do not want to have any packages depending +-- directly or indirectly on two different versions of the same package. The +-- current definition is just a safe aproximation of that. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to +-- find out which packages are. +-- +consistent :: PackageIndex PlanPackage -> Bool +consistent = null . PackageIndex.dependencyInconsistencies + +-- | The states of packages have that depend on each other must respect +-- this relation. That is for very case where package @a@ depends on +-- package @b@ we require that @dependencyStatesOk a b = True@. +-- +stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool +stateDependencyRelation (PreExisting _) (PreExisting _) = True + +stateDependencyRelation (Configured _) (PreExisting _) = True +stateDependencyRelation (Configured _) (Configured _) = True +stateDependencyRelation (Configured _) (Installed _ _) = True + +stateDependencyRelation (Installed _ _) (PreExisting _) = True +stateDependencyRelation (Installed _ _) (Installed _ _) = True + +stateDependencyRelation (Failed _ _) (PreExisting _) = True +-- failed can depends on configured because a package can depend on +-- several other packages and if one of the deps fail then we fail +-- but we still depend on the other ones that did not fail: +stateDependencyRelation (Failed _ _) (Configured _) = True +stateDependencyRelation (Failed _ _) (Installed _ _) = True +stateDependencyRelation (Failed _ _) (Failed _ _) = True + +stateDependencyRelation _ _ = False + +-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if +-- in the configuration given by the flag assignment, all the package +-- dependencies are satisfied by the specified packages. +-- +configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool +configuredPackageValid platform comp pkg = + null (configuredPackageProblems platform comp pkg) + +data PackageProblem = DuplicateFlag FlagName + | MissingFlag FlagName + | ExtraFlag FlagName + | DuplicateDeps [PackageIdentifier] + | MissingDep Dependency + | ExtraDep PackageIdentifier + | InvalidDep Dependency PackageIdentifier + +showPackageProblem :: PackageProblem -> String +showPackageProblem (DuplicateFlag (FlagName flag)) = + "duplicate flag in the flag assignment: " ++ flag + +showPackageProblem (MissingFlag (FlagName flag)) = + "missing an assignment for the flag: " ++ flag + +showPackageProblem (ExtraFlag (FlagName flag)) = + "extra flag given that is not used by the package: " ++ flag + +showPackageProblem (DuplicateDeps pkgids) = + "duplicate packages specified as selected dependencies: " + ++ intercalate ", " (map display pkgids) + +showPackageProblem (MissingDep dep) = + "the package has a dependency " ++ display dep + ++ " but no package has been selected to satisfy it." + +showPackageProblem (ExtraDep pkgid) = + "the package configuration specifies " ++ display pkgid + ++ " but (with the given flag assignment) the package does not actually" + ++ " depend on any version of that package." + +showPackageProblem (InvalidDep dep pkgid) = + "the package depends on " ++ display dep + ++ " but the configuration specifies " ++ display pkgid + ++ " which does not satisfy the dependency." + +configuredPackageProblems :: Platform -> CompilerId + -> ConfiguredPackage -> [PackageProblem] +configuredPackageProblems platform comp + (ConfiguredPackage pkg specifiedFlags specifiedDeps) = + [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] + ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] + ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] + ++ [ DuplicateDeps pkgs + | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ] + ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] + ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] + ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps + , not (packageSatisfiesDependency pkgid dep) ] + where + mergedFlags = mergeBy compare + (sort $ map flagName (genPackageFlags (packageDescription pkg))) + (sort $ map fst specifiedFlags) + + mergedDeps = mergeBy + (\dep pkgid -> dependencyName dep `compare` packageName pkgid) + (sortBy (comparing dependencyName) requiredDeps) + (sortBy (comparing packageName) specifiedDeps) + + packageSatisfiesDependency + (PackageIdentifier name version) + (Dependency name' versionRange) = assert (name == name') $ + version `withinRange` versionRange + + dependencyName (Dependency name _) = name + + requiredDeps :: [Dependency] + requiredDeps = + --TODO: use something lower level than finalizePackageDescription + case finalizePackageDescription specifiedFlags + (const True) + platform comp + [] + (packageDescription pkg) of + Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg + Left _ -> error "configuredPackageInvalidDeps internal error" diff --git a/cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs b/cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs @@ -0,0 +1,238 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallSymlink +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Managing installing binaries with symlinks. +----------------------------------------------------------------------------- +module Distribution.Client.InstallSymlink ( + symlinkBinaries, + symlinkBinary, + ) where + +#if mingw32_HOST_OS || mingw32_TARGET_OS + +import Distribution.Package (PackageIdentifier) +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Setup (InstallFlags) +import Distribution.Simple.Setup (ConfigFlags) + +symlinkBinaries :: ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO [(PackageIdentifier, String, FilePath)] +symlinkBinaries _ _ _ = return [] + +symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool +symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" + +#else + +import Distribution.Client.Types + ( AvailablePackage(..), ConfiguredPackage(..) ) +import Distribution.Client.Setup + ( InstallFlags(installSymlinkBinDir) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) + +import Distribution.Package + ( PackageIdentifier, Package(packageId) ) +import Distribution.Compiler + ( CompilerId(..) ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Simple.Setup + ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.InstallDirs as InstallDirs + +import System.Posix.Files + ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink + , removeLink ) +import System.Directory + ( canonicalizePath ) +import System.FilePath + ( (), splitPath, joinPath, isAbsolute ) + +import Prelude hiding (catch, ioError) +import System.IO.Error + ( catch, isDoesNotExistError, ioError ) +import Control.Exception + ( assert ) +import Data.Maybe + ( catMaybes ) + +-- | We would like by default to install binaries into some location that is on +-- the user's PATH. For per-user installations on Unix systems that basically +-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ +-- directory will be on the user's PATH. However some people are a bit nervous +-- about letting a package manager install programs into @~/bin/@. +-- +-- A comprimise solution is that instead of installing binaries directly into +-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ +-- and then create symlinks in @~/bin/@. We can be careful when setting up the +-- symlinks that we do not overwrite any binary that the user installed. We can +-- check if it was a symlink we made because it would point to the private dir +-- where we install our binaries. This means we can install normally without +-- worrying and in a later phase set up symlinks, and if that fails then we +-- report it to the user, but even in this case the package is still in an ok +-- installed state. +-- +-- This is an optional feature that users can choose to use or not. It is +-- controlled from the config file. Of course it only works on posix systems +-- with symlinks so is not available to Windows users. +-- +symlinkBinaries :: ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO [(PackageIdentifier, String, FilePath)] +symlinkBinaries configFlags installFlags plan = + case flagToMaybe (installSymlinkBinDir installFlags) of + Nothing -> return [] + Just symlinkBinDir + | null exes -> return [] + | otherwise -> do + publicBinDir <- canonicalizePath symlinkBinDir +-- TODO: do we want to do this here? : +-- createDirectoryIfMissing True publicBinDir + fmap catMaybes $ sequence + [ do privateBinDir <- pkgBinDir pkg + ok <- symlinkBinary + publicBinDir privateBinDir + publicExeName privateExeName + if ok + then return Nothing + else return (Just (pkgid, publicExeName, + privateBinDir privateExeName)) + | (pkg, exe) <- exes + , let publicExeName = PackageDescription.exeName exe + privateExeName = prefix ++ publicExeName ++ suffix + pkgid = packageId pkg + prefix = substTemplate pkgid prefixTemplate + suffix = substTemplate pkgid suffixTemplate ] + where + exes = + [ (pkg, exe) + | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan + , let pkg = pkgDescription cpkg + , exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) ] + + pkgDescription :: ConfiguredPackage -> PackageDescription + pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) = + case finalizePackageDescription flags + (const True) + platform compilerId [] pkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc + + -- This is sadly rather complicated. We're kind of re-doing part of the + -- configuration for the package. :-( + pkgBinDir :: PackageDescription -> IO FilePath + pkgBinDir pkg = do + defaultDirs <- InstallDirs.defaultInstallDirs + compilerFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + (packageId pkg) compilerId InstallDirs.NoCopyDest + templateDirs + canonicalizePath (InstallDirs.bindir absoluteDirs) + + substTemplate pkgid = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid compilerId + + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + platform = InstallPlan.planPlatform plan + compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan + +symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir + -- eg @/home/user/bin@ + -> FilePath -- ^ The canonical path of the private bin dir + -- eg @/home/user/.cabal/bin@ + -> String -- ^ The name of the executable to go in the public + -- bin dir, eg @foo@ + -> String -- ^ The name of the executable to in the private bin + -- dir, eg @foo-1.0@ + -> IO Bool -- ^ If creating the symlink was sucessful. @False@ + -- if there was another file there already that we + -- did not own. Other errors like permission errors + -- just propagate as exceptions. +symlinkBinary publicBindir privateBindir publicName privateName = do + ok <- targetOkToOverwrite (publicBindir publicName) + (privateBindir privateName) + case ok of + NotOurFile -> return False + NotExists -> mkLink >> return True + OkToOverwrite -> rmLink >> mkLink >> return True + where + relativeBindir = makeRelative publicBindir privateBindir + mkLink = createSymbolicLink (relativeBindir privateName) + (publicBindir publicName) + rmLink = removeLink (publicBindir publicName) + +-- | 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 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 binary. + -- Use 'canonicalizePath' to make this. + -> IO SymlinkStatus +targetOkToOverwrite symlink target = handleNotExist $ do + status <- getSymbolicLinkStatus symlink + if not (isSymbolicLink status) + then return NotOurFile + 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 -> + -- If the target doesn't exist then there's no problem overwriting it! + if isDoesNotExistError ioexception + then return NotExists + else ioError ioexception + +data SymlinkStatus + = NotExists -- ^ The file doesn't exist so we can make a symlink. + | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll + -- have to delete it first bemore we make a new symlink. + | NotOurFile -- ^ A file already exists and it is not one of our existing + -- symlinks (either because it is not a symlink or because + -- it points somewhere other than our managed space). + deriving Show + +-- | Take two canonical paths and produce a relative path to get from the first +-- to the second, even if it means adding @..@ path components. +-- +makeRelative :: FilePath -> FilePath -> FilePath +makeRelative a b = assert (isAbsolute a && isAbsolute b) $ + let as = splitPath a + bs = splitPath b + commonLen = length $ takeWhile id $ zipWith (==) as bs + in joinPath $ [ ".." | _ <- drop commonLen as ] + ++ [ b' | b' <- drop commonLen bs ] + +#endif diff --git a/cabal-install-0.8.2/Distribution/Client/List.hs b/cabal-install-0.8.2/Distribution/Client/List.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/List.hs @@ -0,0 +1,368 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.List +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2008-2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- +-- Search for and print information about packages +----------------------------------------------------------------------------- +module Distribution.Client.List ( + list, info + ) where + +import Distribution.Package + ( PackageName(..), packageName, packageVersion + , Dependency(..), thisPackageVersion, depends ) +import Distribution.ModuleName (ModuleName) +import Distribution.License (License) +import qualified Distribution.InstalledPackageInfo as Installed +import qualified Distribution.PackageDescription as Available +import Distribution.PackageDescription + ( Flag(..), FlagName(..) ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) + +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration) +import Distribution.Simple.Utils (equating, comparing, notice) +import Distribution.Simple.Setup (fromFlag) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Version (Version) +import Distribution.Verbosity (Verbosity) +import Distribution.Text + ( Text(disp), display ) + +import Distribution.Client.Types + ( AvailablePackage(..), Repo, AvailablePackageDb(..) + , UnresolvedDependency(..), InstalledPackage(..) ) +import Distribution.Client.Setup + ( ListFlags(..), InfoFlags(..) ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) +import Distribution.Client.IndexUtils as IndexUtils + ( getAvailablePackages, disambiguateDependencies + , getInstalledPackages ) +import Distribution.Client.Fetch + ( isFetched ) + +import Data.List + ( sortBy, groupBy, sort, nub, intersperse, maximumBy ) +import Data.Maybe + ( listToMaybe, fromJust, fromMaybe, isJust, isNothing ) +import Control.Monad + ( MonadPlus(mplus), join ) +import Control.Exception + ( assert ) +import Text.PrettyPrint.HughesPJ as Disp +import System.Directory + ( doesDirectoryExist ) + + +-- |Show information about packages +list :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ListFlags + -> [String] + -> IO () +list verbosity packageDBs repos comp conf listFlags pats = do + Just installed <- getInstalledPackages verbosity comp packageDBs conf + AvailablePackageDb available _ <- getAvailablePackages verbosity repos + let pkgs | null pats = (PackageIndex.allPackages installed + ,PackageIndex.allPackages available) + | otherwise = + (concatMap (PackageIndex.searchByNameSubstring installed) pats + ,concatMap (PackageIndex.searchByNameSubstring available) pats) + matches = installedFilter + . map (uncurry mergePackageInfo) + $ uncurry mergePackages pkgs + + if simpleOutput + then putStr $ unlines + [ display (pkgname pkg) ++ " " ++ display version + | pkg <- matches + , version <- if onlyInstalled + then installedVersions pkg + else nub . sort $ installedVersions pkg + ++ availableVersions pkg ] + else + if null matches + then notice verbosity "No matches found." + else putStr $ unlines (map showPackageSummaryInfo matches) + where + installedFilter + | onlyInstalled = filter (not . null . installedVersions) + | otherwise = id + onlyInstalled = fromFlag (listInstalled listFlags) + simpleOutput = fromFlag (listSimpleOutput listFlags) + +info :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> InfoFlags + -> [UnresolvedDependency] --FIXME: just package names? or actually use the constraint + -> IO () +info verbosity packageDBs repos comp conf _listFlags deps = do + AvailablePackageDb available _ <- getAvailablePackages verbosity repos + deps' <- IndexUtils.disambiguateDependencies available deps + Just installed <- getInstalledPackages verbosity comp packageDBs conf + let deps'' = [ name | UnresolvedDependency (Dependency name _) _ <- deps' ] + let pkgs = (concatMap (PackageIndex.lookupPackageName installed) deps'' + ,concatMap (PackageIndex.lookupPackageName available) deps'') + pkgsinfo = map (uncurry mergePackageInfo) + $ uncurry mergePackages pkgs + + pkgsinfo' <- mapM updateFileSystemPackageDetails pkgsinfo + putStr $ unlines (map showPackageDetailedInfo pkgsinfo') + +-- | The info that we can display for each package. It is information per +-- package name and covers all installed and avilable versions. +-- +data PackageDisplayInfo = PackageDisplayInfo { + pkgname :: PackageName, + allInstalled :: [InstalledPackage], + allAvailable :: [AvailablePackage], + latestInstalled :: Maybe InstalledPackage, + latestAvailable :: Maybe AvailablePackage, + homepage :: String, + bugReports :: String, + sourceRepo :: String, + synopsis :: String, + description :: String, + category :: String, + license :: License, +-- copyright :: String, --TODO: is this useful? + author :: String, + maintainer :: String, + dependencies :: [Dependency], + flags :: [Flag], + hasLib :: Bool, + hasExe :: Bool, + executables :: [String], + modules :: [ModuleName], + haddockHtml :: FilePath, + haveTarball :: Bool + } + +installedVersions :: PackageDisplayInfo -> [Version] +installedVersions = map packageVersion . allInstalled + +availableVersions :: PackageDisplayInfo -> [Version] +availableVersions = map packageVersion . allAvailable + +showPackageSummaryInfo :: PackageDisplayInfo -> String +showPackageSummaryInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> disp (pkgname pkginfo) + $+$ + (nest 4 $ vcat [ + maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs + , text "Latest version available:" <+> + case latestAvailable pkginfo of + Nothing -> text "[ Not available from server ]" + Just pkg -> disp (packageVersion pkg) + , text "Latest version installed:" <+> + case latestInstalled pkginfo of + Nothing | hasLib pkginfo -> text "[ Not installed ]" + | otherwise -> text "[ Unknown ]" + Just pkg -> disp (packageVersion pkg) + , maybeShow (homepage pkginfo) "Homepage:" text + , text "License: " <+> text (display (license pkginfo)) + ]) + $+$ text "" + where + maybeShow [] _ _ = empty + maybeShow l s f = text s <+> (f l) + +showPackageDetailedInfo :: PackageDisplayInfo -> String +showPackageDetailedInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> disp (pkgname pkginfo) + <+> text (replicate (16 - length (display (pkgname pkginfo))) ' ') + <> parens pkgkind + $+$ + (nest 4 $ vcat [ + entry "Synopsis" synopsis alwaysShow reflowParagraphs + , entry "Latest version available" latestAvailable + (altText isNothing "[ Not available from server ]") + (disp . packageVersion . fromJust) + , entry "Latest version installed" latestInstalled + (altText isNothing (if hasLib pkginfo then "[ Not installed ]" + else "[ Unknown ]")) + (disp . packageVersion . fromJust) + , entry "Homepage" homepage orNotSpecified text + , entry "Bug reports" bugReports orNotSpecified text + , entry "Description" description alwaysShow reflowParagraphs + , entry "Category" category hideIfNull text + , entry "License" license alwaysShow disp + , entry "Author" author hideIfNull reflowLines + , entry "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep text) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep disp) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) then empty else + text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) + ]) + $+$ text "" + where + entry fname field cond format = case cond (field pkginfo) of + Nothing -> label <+> format (field pkginfo) + Just Nothing -> empty + Just (Just other) -> label <+> text other + where + label = text fname <> char ':' <> padding + padding = text (replicate (13 - length fname ) ' ') + + normal = Nothing + hide = Just Nothing + replace msg = Just (Just msg) + + alwaysShow = const normal + hideIfNull v = if null v then hide else normal + showIfInstalled v + | not isInstalled = hide + | null v = replace "[ Not installed ]" + | otherwise = normal + altText nul msg v = if nul v then replace msg else normal + orNotSpecified = altText null "[ Not specified ]" + + commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f + dispFlag f = case flagName f of FlagName n -> text n + dispYesNo True = text "Yes" + dispYesNo False = text "No" + + isInstalled = not (null (installedVersions pkginfo)) + hasExes = length (executables pkginfo) >= 2 + --TODO: exclude non-buildable exes + pkgkind | hasLib pkginfo && hasExes = text "programs and library" + | hasLib pkginfo && hasExe pkginfo = text "program and library" + | hasLib pkginfo = text "library" + | hasExes = text "programs" + | hasExe pkginfo = text "program" + | otherwise = empty + +reflowParagraphs :: String -> Doc +reflowParagraphs = + vcat + . intersperse (text "") -- re-insert blank lines + . map (fsep . map text . concatMap words) -- reflow paragraphs + . filter (/= [""]) + . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines + . lines + +reflowLines :: String -> Doc +reflowLines = vcat . map text . lines + +-- | We get the 'PackageDisplayInfo' by combining the info for the installed +-- and available versions of a package. +-- +-- * We're building info about a various versions of a single named package so +-- the input package info records are all supposed to refer to the same +-- package name. +-- +mergePackageInfo :: [InstalledPackage] + -> [AvailablePackage] + -> PackageDisplayInfo +mergePackageInfo installedPkgs availablePkgs = + assert (length installedPkgs + length availablePkgs > 0) $ + PackageDisplayInfo { + pkgname = combine packageName available + packageName installed, + allInstalled = installedPkgs, + allAvailable = availablePkgs, + latestInstalled = latest installedPkgs, + latestAvailable = latest availablePkgs, + license = combine Available.license available + Installed.license installed, + maintainer = combine Available.maintainer available + Installed.maintainer installed, + author = combine Available.author available + Installed.author installed, + homepage = combine Available.homepage available + Installed.homepage installed, + bugReports = maybe "" Available.bugReports available, + sourceRepo = fromMaybe "" . join + . fmap (uncons Nothing Available.repoLocation + . sortBy (comparing Available.repoKind) + . Available.sourceRepos) + $ available, + synopsis = combine Available.synopsis available + Installed.description installed, + description = combine Available.description available + Installed.description installed, + category = combine Available.category available + Installed.category installed, + flags = maybe [] Available.genPackageFlags availableGeneric, + hasLib = isJust installed + || fromMaybe False + (fmap (isJust . Available.condLibrary) availableGeneric), + hasExe = fromMaybe False + (fmap (not . null . Available.condExecutables) availableGeneric), + executables = map fst (maybe [] Available.condExecutables availableGeneric), + modules = combine Installed.exposedModules installed + (maybe [] Available.exposedModules + . Available.library) available, + dependencies = combine Available.buildDepends available + (map thisPackageVersion . depends) installed', + haddockHtml = fromMaybe "" . join + . fmap (listToMaybe . Installed.haddockHTMLs) + $ installed, + haveTarball = False + } + where + combine f x g y = fromJust (fmap f x `mplus` fmap g y) + installed' = latest installedPkgs + installed = fmap (\(InstalledPackage p _) -> p) installed' + availableGeneric = fmap packageDescription (latest availablePkgs) + available = fmap flattenPackageDescription availableGeneric + latest [] = Nothing + latest pkgs = Just (maximumBy (comparing packageVersion) pkgs) + + uncons :: b -> (a -> b) -> [a] -> b + uncons z _ [] = z + uncons _ f (x:_) = f x + +-- | Not all the info is pure. We have to check if the docs really are +-- installed, because the registered package info lies. Similarly we have to +-- check if the tarball has indeed been fetched. +-- +updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo +updateFileSystemPackageDetails pkginfo = do + fetched <- maybe (return False) isFetched (latestAvailable pkginfo) + docsExist <- doesDirectoryExist (haddockHtml pkginfo) + return pkginfo { + haveTarball = fetched, + haddockHtml = if docsExist then haddockHtml pkginfo else "" + } + +-- | Rearrange installed and available packages into groups referring to the +-- same package by name. In the result pairs, the lists are guaranteed to not +-- both be empty. +-- +mergePackages :: [InstalledPackage] -> [AvailablePackage] + -> [([InstalledPackage], [AvailablePackage])] +mergePackages installed available = + map collect + $ mergeBy (\i a -> fst i `compare` fst a) + (groupOn packageName installed) + (groupOn packageName available) + where + collect (OnlyInLeft (_,is) ) = (is, []) + collect ( InBoth (_,is) (_,as)) = (is, as) + collect (OnlyInRight (_,as)) = ([], as) + +groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] +groupOn key = map (\xs -> (key (head xs), xs)) + . groupBy (equating key) + . sortBy (comparing key) diff --git a/cabal-install-0.8.2/Distribution/Client/PackageIndex.hs b/cabal-install-0.8.2/Distribution/Client/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/PackageIndex.hs @@ -0,0 +1,479 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Client.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + insert, + deletePackageName, + deletePackageId, + deleteDependency, + + -- * Queries + + -- ** Precise lookups + lookupPackageName, + lookupPackageId, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + + -- ** Bulk queries + allPackages, + allPackagesByName, + + -- ** Special queries + brokenPackages, + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, + dependencyInconsistencies, + dependencyCycles, + dependencyGraph, + ) where + +import Prelude hiding (lookup) +import Control.Exception (assert) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Tree as Tree +import qualified Data.Graph as Graph +import qualified Data.Array as Array +import Data.Array ((!)) +import Data.List (groupBy, sortBy, nub, find, isInfixOf) +import Data.Monoid (Monoid(..)) +import Data.Maybe (isNothing, fromMaybe) + +import Distribution.Package + ( PackageName(..), PackageIdentifier(..) + , Package(..), packageName, packageVersion + , Dependency(Dependency), PackageFixedDeps(..) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.Simple.Utils (lowercase, equating, comparing) + + +-- | The collection of information about packages from one or more 'PackageDB's. +-- +-- It can be searched effeciently by package name and version. +-- +newtype Package pkg => PackageIndex pkg = PackageIndex + -- This index package names to all the package records matching that package + -- name case-sensitively. It includes all versions. + -- + -- This allows us to find all versions satisfying a dependency. + -- Most queries are a map lookup followed by a linear scan of the bucket. + -- + (Map PackageName [pkg]) + + deriving (Show, Read) + +instance Package pkg => Monoid (PackageIndex pkg) where + mempty = PackageIndex (Map.empty) + mappend = merge + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = foldr1 mappend xs + +invariant :: Package pkg => PackageIndex pkg -> Bool +invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) + where + goodBucket _ [] = False + goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 + where + check pkgid [] = packageName pkgid == name + check pkgid (pkg':pkgs) = packageName pkgid == name + && pkgid < pkgid' + && check pkgid' pkgs + where pkgid' = packageId pkg' + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg +mkPackageIndex index = assert (invariant (PackageIndex index)) + (PackageIndex index) + +internalError :: String -> a +internalError name = error ("PackageIndex." ++ name ++ ": internal error") + +-- | Lookup a name in the index to get all packages that match that name +-- case-sensitively. +-- +lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates, later ones mask earlier ones. +-- +fromList :: Package pkg => [pkg] -> PackageIndex pkg +fromList pkgs = mkPackageIndex + . Map.map fixBucket + . Map.fromListWith (++) + $ [ (packageName pkg, [pkg]) + | pkg <- pkgs ] + where + fixBucket = -- out of groups of duplicates, later ones mask earlier ones + -- but Map.fromListWith (++) constructs groups in reverse order + map head + -- Eq instance for PackageIdentifier is wrong, so use Ord: + . groupBy (\a b -> EQ == comparing packageId a b) + -- relies on sortBy being a stable sort so we + -- can pick consistently among duplicates + . sortBy (comparing packageId) + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +merge i1@(PackageIndex m1) i2@(PackageIndex m2) = + assert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith mergeBuckets m1 m2) + +-- | Elements in the second list mask those in the first. +mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] +mergeBuckets [] ys = ys +mergeBuckets xs [] = xs +mergeBuckets xs@(x:xs') ys@(y:ys') = + case packageId x `compare` packageId y of + GT -> y : mergeBuckets xs ys' + EQ -> y : mergeBuckets xs' ys' + LT -> x : mergeBuckets xs' ys + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg +insert pkg (PackageIndex index) = mkPackageIndex $ + Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index + where + pkgid = packageId pkg + insertNoDup [] = [pkg] + insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of + LT -> pkg : pkgs + EQ -> pkg : pkgs' + GT -> pkg' : insertNoDup pkgs' + +-- | Internal delete helper. +-- +delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg +delete name p (PackageIndex index) = mkPackageIndex $ + Map.update filterBucket name index + where + filterBucket = deleteEmptyBucket + . filter (not . p) + deleteEmptyBucket [] = Nothing + deleteEmptyBucket remaining = Just remaining + +-- | Removes a single package from the index. +-- +deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg +deletePackageId pkgid = + delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg +deletePackageName name = + delete name (\pkg -> packageName pkg == name) + +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg +deleteDependency (Dependency name verstionRange) = + delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: Package pkg => PackageIndex pkg -> [pkg] +allPackages (PackageIndex m) = concat (Map.elems m) + +-- | Get all the packages from the index. +-- +-- They are grouped by package name, case-sensitively. +-- +allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]] +allPackagesByName (PackageIndex m) = Map.elems m + +-- +-- * Lookups +-- + +-- | Does a lookup by package id (name & version). +-- +-- Since multiple package DBs mask each other case-sensitively by package name, +-- then we get back at most one package. +-- +lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg +lookupPackageId index pkgid = + case [ pkg | pkg <- lookup index (packageName pkgid) + , packageId pkg == pkgid ] of + [] -> Nothing + [pkg] -> Just pkg + _ -> internalError "lookupPackageIdentifier" + +-- | Does a case-sensitive search by package name. +-- +lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookupPackageName index name = + [ pkg | pkg <- lookup index name + , packageName pkg == name ] + +-- | Does a case-sensitive search by package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] +lookupDependency index (Dependency name versionRange) = + [ pkg | pkg <- lookup index name + , packageName pkg == name + , packageVersion pkg `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insentiviely to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insentiviely but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insentiviely and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg] +searchByName (PackageIndex m) name = + case [ pkgs | pkgs@(PackageName name',_) <- Map.toList m + , lowercase name' == lname ] of + [] -> None + [(_,pkgs)] -> Unambiguous pkgs + pkgss -> case find ((PackageName name==) . fst) pkgss of + Just (_,pkgs) -> Unambiguous pkgs + Nothing -> Ambiguous (map snd pkgss) + where lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg] +searchByNameSubstring (PackageIndex m) searchterm = + [ pkg + | (PackageName name, pkgs) <- Map.toList m + , lsearchterm `isInfixOf` lowercase name + , pkg <- pkgs ] + where lsearchterm = lowercase searchterm + +-- +-- * Special queries +-- + +-- | All packages that have dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +-- +brokenPackages :: PackageFixedDeps pkg + => PackageIndex pkg + -> [(pkg, [PackageIdentifier])] +brokenPackages index = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = [ pkg' | pkg' <- depends pkg + , isNothing (lookupPackageId index pkg') ] + , not (null missing) ] + +-- | Tries to take the transative closure of the package dependencies. +-- +-- If the transative closure is complete then it returns that subset of the +-- index. Otherwise it returns the broken packages as in 'brokenPackages'. +-- +-- * Note that if the result is @Right []@ it is because at least one of +-- the original given 'PackageIdentifier's do not occur in the index. +-- +dependencyClosure :: PackageFixedDeps pkg + => PackageIndex pkg + -> [PackageIdentifier] + -> Either (PackageIndex pkg) + [(pkg, [PackageIdentifier])] +dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of + (completed, []) -> Left completed + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of + Nothing -> closure completed (pkgid:failed) pkgids + Just pkg -> case lookupPackageId completed (packageId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where completed' = insert pkg completed + pkgids' = depends pkg ++ pkgids + +-- | Takes the transative closure of the packages reverse dependencies. +-- +-- * The given 'PackageIdentifier's must be in the index. +-- +reverseDependencyClosure :: PackageFixedDeps pkg + => PackageIndex pkg + -> [PackageIdentifier] + -> [pkg] +reverseDependencyClosure index = + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) + + where + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index + reverseDepGraph = Graph.transposeG depGraph + noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" + +topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies :: PackageFixedDeps pkg + => PackageIndex pkg + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies index = + [ (name, inconsistencies) + | (name, uses) <- Map.toList inverseIndex + , let inconsistencies = duplicatesBy uses + versions = map snd inconsistencies + , reallyIsInconsistent name (nub versions) ] + + where inverseIndex = Map.fromListWith (++) + [ (packageName dep, [(packageId pkg, packageVersion dep)]) + | pkg <- allPackages index + , dep <- depends pkg ] + + duplicatesBy = (\groups -> if length groups == 1 + then [] + else concat groups) + . groupBy (equating snd) + . sortBy (comparing snd) + + reallyIsInconsistent :: PackageName -> [Version] -> Bool + reallyIsInconsistent _ [] = False + reallyIsInconsistent name [v1, v2] = + case (mpkg1, mpkg2) of + (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2 + && pkgid2 `notElem` depends pkg1 + _ -> True + where + pkgid1 = PackageIdentifier name v1 + pkgid2 = PackageIdentifier name v2 + mpkg1 = lookupPackageId index pkgid1 + mpkg2 = lookupPackageId index pkgid2 + + reallyIsInconsistent _ _ = True + +-- | Find if there are any cycles in the dependency graph. If there are no +-- cycles the result is @[]@. +-- +-- This actually computes the strongly connected components. So it gives us a +-- list of groups of packages where within each group they all depend on each +-- other, directly or indirectly. +-- +dependencyCycles :: PackageFixedDeps pkg + => PackageIndex pkg + -> [[pkg]] +dependencyCycles index = + [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + where + adjacencyList = [ (pkg, packageId pkg, depends pkg) + | pkg <- allPackages index ] + +-- | Builds a graph of the package dependencies. +-- +-- Dependencies on other packages that are not in the index are discarded. +-- You can check if there are any such dependencies with 'brokenPackages'. +-- +dependencyGraph :: PackageFixedDeps pkg + => PackageIndex pkg + -> (Graph.Graph, + Graph.Vertex -> pkg, + PackageIdentifier -> Maybe Graph.Vertex) +dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex) + where + graph = Array.listArray bounds + [ [ v | Just v <- map pkgIdToVertex (depends pkg) ] + | pkg <- pkgs ] + vertexToPkg vertex = pkgTable ! vertex + pkgIdToVertex = binarySearch 0 topBound + + pkgTable = Array.listArray bounds pkgs + pkgIdTable = Array.listArray bounds (map packageId pkgs) + pkgs = sortBy (comparing packageId) (allPackages index) + topBound = length pkgs - 1 + bounds = (0, topBound) + + binarySearch a b key + | a > b = Nothing + | otherwise = case compare key (pkgIdTable ! mid) of + LT -> binarySearch a (mid-1) key + EQ -> Just mid + GT -> binarySearch (mid+1) b key + where mid = (a + b) `div` 2 diff --git a/cabal-install-0.8.2/Distribution/Client/PackageUtils.hs b/cabal-install-0.8.2/Distribution/Client/PackageUtils.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/PackageUtils.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PackageUtils +-- Copyright : (c) Duncan Coutts 2010 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Various package description utils that should be in the Cabal lib +----------------------------------------------------------------------------- +module Distribution.Client.PackageUtils ( + externalBuildDepends, + ) where + +import Distribution.Package + ( packageVersion, packageName, Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..) ) +import Distribution.Version + ( withinRange ) + +-- | The list of dependencies that refer to external packages +-- rather than internal package components. +-- +externalBuildDepends :: PackageDescription -> [Dependency] +externalBuildDepends pkg = filter (not . internal) (buildDepends pkg) + where + -- True if this dependency is an internal one (depends on a library + -- defined in the same package). + internal (Dependency depName versionRange) = + depName == packageName pkg && + packageVersion pkg `withinRange` versionRange diff --git a/cabal-install-0.8.2/Distribution/Client/Setup.hs b/cabal-install-0.8.2/Distribution/Client/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Setup.hs @@ -0,0 +1,876 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Setup +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Setup + ( globalCommand, GlobalFlags(..), globalRepos + , configureCommand, ConfigFlags(..), filterConfigureFlags + , configureExCommand, ConfigExFlags(..), defaultConfigExFlags + , configureExOptions + , installCommand, InstallFlags(..), installOptions, defaultInstallFlags + , listCommand, ListFlags(..) + , updateCommand + , upgradeCommand + , infoCommand, InfoFlags(..) + , fetchCommand + , checkCommand + , uploadCommand, UploadFlags(..) + , reportCommand + , unpackCommand, UnpackFlags(..) + , initCommand, IT.InitFlags(..) + + , parsePackageArgs + --TODO: stop exporting these: + , showRepo + , parseRepo + ) where + +import Distribution.Client.Types + ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import qualified Distribution.Client.Init.Types as IT + ( InitFlags(..), PackageType(..) ) + +import Distribution.Simple.Program + ( defaultProgramConfiguration ) +import Distribution.Simple.Command hiding (boolOpt) +import qualified Distribution.Simple.Command as Command +import qualified Distribution.Simple.Setup as Cabal + ( configureCommand ) +import Distribution.Simple.Setup + ( ConfigFlags(..) ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe + , optionVerbosity, trueArg ) +import Distribution.Simple.InstallDirs + ( PathTemplate, toPathTemplate, fromPathTemplate ) +import Distribution.Version + ( Version(Version), anyVersion, thisVersion ) +import Distribution.Package + ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) +import Distribution.Text + ( Text(parse), display ) +import Distribution.ReadE + ( readP_to_E, succeedReadE ) +import qualified Distribution.Compat.ReadP as Parse + ( ReadP, readP_to_S, char, munch1, pfail, (+++) ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText ) + +import Data.Char + ( isSpace, isAlphaNum ) +import Data.Maybe + ( listToMaybe, maybeToList, fromMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Control.Monad + ( liftM ) +import System.FilePath + ( () ) +import Network.URI + ( parseAbsoluteURI, uriToString ) + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- | Flags that apply at the top level, not to any sub-command. +data GlobalFlags = GlobalFlags { + globalVersion :: Flag Bool, + globalNumericVersion :: Flag Bool, + globalConfigFile :: Flag FilePath, + globalRemoteRepos :: [RemoteRepo], -- ^Available Hackage servers. + globalCacheDir :: Flag FilePath, + globalLocalRepos :: [FilePath] + } + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags { + globalVersion = Flag False, + globalNumericVersion = Flag False, + globalConfigFile = mempty, + globalRemoteRepos = [], + globalCacheDir = mempty, + globalLocalRepos = mempty + } + +globalCommand :: CommandUI GlobalFlags +globalCommand = CommandUI { + commandName = "", + commandSynopsis = "", + commandUsage = \_ -> + "This program is the command line interface " + ++ "to the Haskell Cabal infrastructure.\n" + ++ "See http://www.haskell.org/cabal/ for more information.\n", + commandDescription = Just $ \pname -> + "For more information about a command use:\n" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "To install Cabal packages from hackage use:\n" + ++ " " ++ pname ++ " install foo [--dry-run]\n\n" + ++ "Occasionally you need to update the list of available packages:\n" + ++ " " ++ pname ++ " update\n", + commandDefaultFlags = defaultGlobalFlags, + commandOptions = \showOrParseArgs -> + (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id) + [option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + + ,option [] ["config-file"] + "Set an alternate location for the config file" + globalConfigFile (\v flags -> flags { globalConfigFile = v }) + (reqArgFlag "FILE") + + ,option [] ["remote-repo"] + "The name and url for a remote repository" + globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) + (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo)) + + ,option [] ["remote-repo-cache"] + "The location where downloads from all remote repos are cached" + globalCacheDir (\v flags -> flags { globalCacheDir = v }) + (reqArgFlag "DIR") + + ,option [] ["local-repo"] + "The location of a local repository" + globalLocalRepos (\v flags -> flags { globalLocalRepos = v }) + (reqArg' "DIR" (\x -> [x]) id) + ] + } + +instance Monoid GlobalFlags where + mempty = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty, + globalConfigFile = mempty, + globalRemoteRepos = mempty, + globalCacheDir = mempty, + globalLocalRepos = mempty + } + mappend a b = GlobalFlags { + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion, + globalConfigFile = combine globalConfigFile, + globalRemoteRepos = combine globalRemoteRepos, + globalCacheDir = combine globalCacheDir, + globalLocalRepos = combine globalLocalRepos + } + where combine field = field a `mappend` field b + +globalRepos :: GlobalFlags -> [Repo] +globalRepos globalFlags = remoteRepos ++ localRepos + where + remoteRepos = + [ Repo (Left remote) cacheDir + | remote <- globalRemoteRepos globalFlags + , let cacheDir = fromFlag (globalCacheDir globalFlags) + remoteRepoName remote ] + localRepos = + [ Repo (Right LocalRepo) local + | local <- globalLocalRepos globalFlags ] + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +configureCommand :: CommandUI ConfigFlags +configureCommand = (Cabal.configureCommand defaultProgramConfiguration) { + commandDefaultFlags = mempty + } + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions = commandOptions configureCommand + +filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags +filterConfigureFlags flags cabalLibVersion + | cabalLibVersion >= Version [1,3,10] [] = flags + -- older Cabal does not grok the constraints flag: + | otherwise = flags { configConstraints = [] } + + +-- ------------------------------------------------------------ +-- * Config extra flags +-- ------------------------------------------------------------ + +-- | cabal configure takes some extra flags beyond runghc Setup configure +-- +data ConfigExFlags = ConfigExFlags { + configCabalVersion :: Flag Version, + configPreferences :: [Dependency] + } + +defaultConfigExFlags :: ConfigExFlags +defaultConfigExFlags = mempty + +configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) +configureExCommand = configureCommand { + commandDefaultFlags = (mempty, defaultConfigExFlags), + commandOptions = \showOrParseArgs -> + liftOptions fst setFst (configureOptions showOrParseArgs) + ++ liftOptions snd setSnd (configureExOptions showOrParseArgs) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + +configureExOptions :: ShowOrParseArgs -> [OptionField ConfigExFlags] +configureExOptions _showOrParseArgs = + [ option [] ["cabal-lib-version"] + ("Select which version of the Cabal lib to use to build packages " + ++ "(useful for testing).") + configCabalVersion (\v flags -> flags { configCabalVersion = v }) + (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++) + (fmap toFlag parse)) + (map display . flagToList)) + + , option [] ["preference"] + "Specify preferences (soft constraints) on the version of a package" + configPreferences (\v flags -> flags { configPreferences = v }) + (reqArg "DEPENDENCY" + (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) + (map (\x -> display x))) + ] + +instance Monoid ConfigExFlags where + mempty = ConfigExFlags { + configCabalVersion = mempty, + configPreferences = mempty + } + mappend a b = ConfigExFlags { + configCabalVersion = combine configCabalVersion, + configPreferences = combine configPreferences + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Other commands +-- ------------------------------------------------------------ + +fetchCommand :: CommandUI (Flag Verbosity) +fetchCommand = CommandUI { + commandName = "fetch", + commandSynopsis = "Downloads packages for later installation.", + commandDescription = Nothing, + commandUsage = usagePackages "fetch", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +updateCommand :: CommandUI (Flag Verbosity) +updateCommand = CommandUI { + commandName = "update", + commandSynopsis = "Updates list of known packages", + commandDescription = Nothing, + commandUsage = usagePackages "update", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) +upgradeCommand = configureCommand { + commandName = "upgrade", + commandSynopsis = "Upgrades installed packages to the latest available version", + commandDescription = Nothing, + commandUsage = usagePackages "upgrade", + commandDefaultFlags = (mempty, mempty, mempty), + commandOptions = commandOptions installCommand + } + +{- +cleanCommand :: CommandUI () +cleanCommand = makeCommand name shortDesc longDesc emptyFlags options + where + name = "clean" + shortDesc = "Removes downloaded files" + longDesc = Nothing + emptyFlags = () + options _ = [] +-} + +checkCommand :: CommandUI (Flag Verbosity) +checkCommand = CommandUI { + commandName = "check", + commandSynopsis = "Check the package for common mistakes", + commandDescription = Nothing, + commandUsage = \pname -> "Usage: " ++ pname ++ " check\n", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [] + } + +reportCommand :: CommandUI (Flag Verbosity) +reportCommand = CommandUI { + commandName = "report", + commandSynopsis = "Upload build reports to a remote server.", + commandDescription = Nothing, + commandUsage = \pname -> "Usage: " ++ pname ++ " report\n", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +-- ------------------------------------------------------------ +-- * Unpack flags +-- ------------------------------------------------------------ + +data UnpackFlags = UnpackFlags { + unpackDestDir :: Flag FilePath, + unpackVerbosity :: Flag Verbosity + } + +defaultUnpackFlags :: UnpackFlags +defaultUnpackFlags = UnpackFlags { + unpackDestDir = mempty, + unpackVerbosity = toFlag normal + } + +unpackCommand :: CommandUI UnpackFlags +unpackCommand = CommandUI { + commandName = "unpack", + commandSynopsis = "Unpacks packages for user inspection.", + commandDescription = Nothing, + commandUsage = usagePackages "unpack", + commandDefaultFlags = mempty, + commandOptions = \_ -> [ + optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v }) + + ,option "d" ["destdir"] + "where to unpack the packages, defaults to the current directory." + unpackDestDir (\v flags -> flags { unpackDestDir = v }) + (reqArgFlag "PATH") + ] + } + +instance Monoid UnpackFlags where + mempty = defaultUnpackFlags + mappend a b = UnpackFlags { + unpackDestDir = combine unpackDestDir + ,unpackVerbosity = combine unpackVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * List flags +-- ------------------------------------------------------------ + +data ListFlags = ListFlags { + listInstalled :: Flag Bool, + listSimpleOutput :: Flag Bool, + listVerbosity :: Flag Verbosity + } + +defaultListFlags :: ListFlags +defaultListFlags = ListFlags { + listInstalled = Flag False, + listSimpleOutput = Flag False, + listVerbosity = toFlag normal + } + +listCommand :: CommandUI ListFlags +listCommand = CommandUI { + commandName = "list", + commandSynopsis = "List packages matching a search string.", + commandDescription = Nothing, + commandUsage = usagePackages "list", + commandDefaultFlags = defaultListFlags, + commandOptions = \_ -> [ + optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) + + , option [] ["installed"] + "Only print installed packages" + listInstalled (\v flags -> flags { listInstalled = v }) + trueArg + + , option [] ["simple-output"] + "Print in a easy-to-parse format" + listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) + trueArg + + ] + } + +instance Monoid ListFlags where + mempty = defaultListFlags + mappend a b = ListFlags { + listInstalled = combine listInstalled, + listSimpleOutput = combine listSimpleOutput, + listVerbosity = combine listVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Info flags +-- ------------------------------------------------------------ + +data InfoFlags = InfoFlags { + infoVerbosity :: Flag Verbosity + } + +defaultInfoFlags :: InfoFlags +defaultInfoFlags = InfoFlags { + infoVerbosity = toFlag normal + } + +infoCommand :: CommandUI InfoFlags +infoCommand = CommandUI { + commandName = "info", + commandSynopsis = "Display detailed information about a particular package.", + commandDescription = Nothing, + commandUsage = usagePackages "info", + commandDefaultFlags = defaultInfoFlags, + commandOptions = \_ -> [ + optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) + ] + } + +instance Monoid InfoFlags where + mempty = defaultInfoFlags + mappend a b = InfoFlags { + infoVerbosity = combine infoVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Install takes the same flags as configure along with a few extras. +-- +data InstallFlags = InstallFlags { + installDocumentation:: Flag Bool, + installHaddockIndex :: Flag PathTemplate, + installDryRun :: Flag Bool, + installReinstall :: Flag Bool, + installOnly :: Flag Bool, + installRootCmd :: Flag String, + installSummaryFile :: [PathTemplate], + installLogFile :: Flag PathTemplate, + installBuildReports :: Flag ReportLevel, + installSymlinkBinDir:: Flag FilePath + } + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installDocumentation= Flag False, + installHaddockIndex = Flag docIndexFile, + installDryRun = Flag False, + installReinstall = Flag False, + installOnly = Flag False, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = Flag NoReports, + installSymlinkBinDir= mempty + } + where + docIndexFile = toPathTemplate ("$datadir" "doc" "index.html") + +installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) +installCommand = CommandUI { + commandName = "install", + commandSynopsis = "Installs a list of packages.", + commandUsage = usagePackages "install", + commandDescription = Just $ \pname -> + let original = case commandDescription configureCommand of + Just desc -> desc pname ++ "\n" + Nothing -> "" + in original + ++ "Examples:\n" + ++ " " ++ pname ++ " install " + ++ " Package in the current directory\n" + ++ " " ++ pname ++ " install foo " + ++ " Package from the hackage server\n" + ++ " " ++ pname ++ " install foo-1.0 " + ++ " Specific version of a package\n" + ++ " " ++ pname ++ " install 'foo < 2' " + ++ " Constrained package version\n", + commandDefaultFlags = (mempty, mempty, mempty), + commandOptions = \showOrParseArgs -> + liftOptions get1 set1 (configureOptions showOrParseArgs) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs) + ++ liftOptions get3 set3 (installOptions showOrParseArgs) + } + where + get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c) + get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) + get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions showOrParseArgs = + [ option "" ["documentation"] + "building of documentation" + installDocumentation (\v flags -> flags { installDocumentation = v }) + (boolOpt [] []) + + , option [] ["doc-index-file"] + "A central index of haddock API documentation (template cannot use $pkgid)" + installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + installDryRun (\v flags -> flags { installDryRun = v }) + trueArg + + , option [] ["reinstall"] + "Install even if it means installing the same version again." + installReinstall (\v flags -> flags { installReinstall = v }) + trueArg + + , option [] ["root-cmd"] + "Command used to gain root privileges, when installing with --global." + installRootCmd (\v flags -> flags { installRootCmd = v }) + (reqArg' "COMMAND" toFlag flagToList) + + , option [] ["symlink-bindir"] + "Add symlinks to installed executables into this directory." + installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) + (reqArgFlag "DIR") + + , option [] ["build-summary"] + "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" + installSummaryFile (\v flags -> flags { installSummaryFile = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate)) + + , option [] ["build-log"] + "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" + installLogFile (\v flags -> flags { installLogFile = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["remote-build-reporting"] + "Generate build reports to send to a remote server (none, anonymous or detailed)." + installBuildReports (\v flags -> flags { installBuildReports = v }) + (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', " + ++ "'anonymous' or 'detailed'") + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids + ParseArgs -> + option [] ["only"] + "Only installs the package in the current directory." + installOnly (\v flags -> flags { installOnly = v }) + trueArg + : [] + _ -> [] + +instance Monoid InstallFlags where + mempty = InstallFlags { + installDocumentation= mempty, + installHaddockIndex = mempty, + installDryRun = mempty, + installReinstall = mempty, + installOnly = mempty, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = mempty, + installSymlinkBinDir= mempty + } + mappend a b = InstallFlags { + installDocumentation= combine installDocumentation, + installHaddockIndex = combine installHaddockIndex, + installDryRun = combine installDryRun, + installReinstall = combine installReinstall, + installOnly = combine installOnly, + installRootCmd = combine installRootCmd, + installSummaryFile = combine installSummaryFile, + installLogFile = combine installLogFile, + installBuildReports = combine installBuildReports, + installSymlinkBinDir= combine installSymlinkBinDir + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Upload flags +-- ------------------------------------------------------------ + +data UploadFlags = UploadFlags { + uploadCheck :: Flag Bool, + uploadUsername :: Flag Username, + uploadPassword :: Flag Password, + uploadVerbosity :: Flag Verbosity + } + +defaultUploadFlags :: UploadFlags +defaultUploadFlags = UploadFlags { + uploadCheck = toFlag False, + uploadUsername = mempty, + uploadPassword = mempty, + uploadVerbosity = toFlag normal + } + +uploadCommand :: CommandUI UploadFlags +uploadCommand = CommandUI { + commandName = "upload", + commandSynopsis = "Uploads source packages to Hackage", + commandDescription = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n", + commandUsage = \pname -> + "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n" + ++ "Flags for upload:", + commandDefaultFlags = defaultUploadFlags, + commandOptions = \_ -> + [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v }) + + ,option ['c'] ["check"] + "Do not upload, just do QA checks." + uploadCheck (\v flags -> flags { uploadCheck = v }) + trueArg + + ,option ['u'] ["username"] + "Hackage username." + uploadUsername (\v flags -> flags { uploadUsername = v }) + (reqArg' "USERNAME" (toFlag . Username) + (flagToList . fmap unUsername)) + + ,option ['p'] ["password"] + "Hackage password." + uploadPassword (\v flags -> flags { uploadPassword = v }) + (reqArg' "PASSWORD" (toFlag . Password) + (flagToList . fmap unPassword)) + ] + } + +instance Monoid UploadFlags where + mempty = UploadFlags { + uploadCheck = mempty, + uploadUsername = mempty, + uploadPassword = mempty, + uploadVerbosity = mempty + } + mappend a b = UploadFlags { + uploadCheck = combine uploadCheck, + uploadUsername = combine uploadUsername, + uploadPassword = combine uploadPassword, + uploadVerbosity = combine uploadVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Init flags +-- ------------------------------------------------------------ + +emptyInitFlags :: IT.InitFlags +emptyInitFlags = mempty + +defaultInitFlags :: IT.InitFlags +defaultInitFlags = emptyInitFlags + +initCommand :: CommandUI IT.InitFlags +initCommand = CommandUI { + commandName = "init", + commandSynopsis = "Interactively create a .cabal file.", + commandDescription = Just $ \_ -> wrapText $ + "Cabalise a project by creating a .cabal, Setup.hs, and " + ++ "optionally a LICENSE file.\n\n" + ++ "Calling init with no arguments (recommended) uses an " + ++ "interactive mode, which will try to guess as much as " + ++ "possible and prompt you for the rest. Command-line " + ++ "arguments are provided for scripting purposes. " + ++ "If you don't want interactive mode, be sure to pass " + ++ "the -n flag.\n", + commandUsage = \pname -> + "Usage: " ++ pname ++ " init [FLAGS]\n\n" + ++ "Flags for init:", + commandDefaultFlags = defaultInitFlags, + commandOptions = \_ -> + [ option ['n'] ["non-interactive"] + "Non-interactive mode." + IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v }) + trueArg + + , option ['q'] ["quiet"] + "Do not generate log messages to stdout." + IT.quiet (\v flags -> flags { IT.quiet = v }) + trueArg + + , option [] ["no-comments"] + "Do not generate explanatory comments in the .cabal file." + IT.noComments (\v flags -> flags { IT.noComments = v }) + trueArg + + , option ['m'] ["minimal"] + "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." + IT.minimal (\v flags -> flags { IT.minimal = v }) + trueArg + + , option [] ["package-dir"] + "Root directory of the package (default = current directory)." + IT.packageDir (\v flags -> flags { IT.packageDir = v }) + (reqArgFlag "DIRECTORY") + + , option ['p'] ["package-name"] + "Name of the Cabal package to create." + IT.packageName (\v flags -> flags { IT.packageName = v }) + (reqArgFlag "PACKAGE") + + , option [] ["version"] + "Initial version of the package." + IT.version (\v flags -> flags { IT.version = v }) + (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option [] ["cabal-version"] + "Required version of the Cabal library." + IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) + (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option ['l'] ["license"] + "Project license." + IT.license (\v flags -> flags { IT.license = v }) + (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option ['a'] ["author"] + "Name of the project's author." + IT.author (\v flags -> flags { IT.author = v }) + (reqArgFlag "NAME") + + , option ['e'] ["email"] + "Email address of the maintainer." + IT.email (\v flags -> flags { IT.email = v }) + (reqArgFlag "EMAIL") + + , option ['u'] ["homepage"] + "Project homepage and/or repository." + IT.homepage (\v flags -> flags { IT.homepage = v }) + (reqArgFlag "URL") + + , option ['s'] ["synopsis"] + "Short project synopsis." + IT.synopsis (\v flags -> flags { IT.synopsis = v }) + (reqArgFlag "TEXT") + + , option ['c'] ["category"] + "Project category." + IT.category (\v flags -> flags { IT.category = v }) + (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) + (flagToList . fmap (either id show))) + + , option [] ["is-library"] + "Build a library." + IT.packageType (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Library)) + + , option [] ["is-executable"] + "Build an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Executable)) + + , option ['o'] ["expose-module"] + "Export a module from the package." + IT.exposedModules + (\v flags -> flags { IT.exposedModules = v }) + (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++) + ((Just . (:[])) `fmap` parse)) + (fromMaybe [] . fmap (fmap display))) + + , option ['d'] ["dependency"] + "Package dependency." + IT.dependencies (\v flags -> flags { IT.dependencies = v }) + (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++) + ((Just . (:[])) `fmap` parse)) + (fromMaybe [] . fmap (fmap display))) + + , option [] ["source-dir"] + "Directory containing package source." + IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) + (reqArg' "DIR" (Just . (:[])) + (fromMaybe [])) + + , option [] ["build-tool"] + "Required external build tool." + IT.buildTools (\v flags -> flags { IT.buildTools = v }) + (reqArg' "TOOL" (Just . (:[])) + (fromMaybe [])) + ] + } + where readMaybe s = case reads s of + [(x,"")] -> Just x + _ -> Nothing + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag + +reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> + (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +liftOptions :: (b -> a) -> (a -> b -> b) + -> [OptionField a] -> [OptionField b] +liftOptions get set = map (liftOption get set) + +usagePackages :: String -> String -> String +usagePackages name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" + ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" + ++ "Flags for " ++ name ++ ":" + +--TODO: do we want to allow per-package flags? +parsePackageArgs :: [String] -> Either String [Dependency] +parsePackageArgs = parsePkgArgs [] + where + parsePkgArgs ds [] = Right (reverse ds) + parsePkgArgs ds (arg:args) = + case readPToMaybe parseDependencyOrPackageId arg of + Just dep -> parsePkgArgs (dep:ds) args + 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 + , all isSpace s ] + +parseDependencyOrPackageId :: Parse.ReadP r Dependency +parseDependencyOrPackageId = parse 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) + +showRepo :: RemoteRepo -> String +showRepo repo = remoteRepoName repo ++ ":" + ++ uriToString id (remoteRepoURI repo) [] + +readRepo :: String -> Maybe RemoteRepo +readRepo = readPToMaybe parseRepo + +parseRepo :: Parse.ReadP r RemoteRepo +parseRepo = do + name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") + _ <- Parse.char ':' + uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") + uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr) + return $ RemoteRepo { + remoteRepoName = name, + remoteRepoURI = uri + } diff --git a/cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs b/cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs @@ -0,0 +1,321 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.SetupWrapper +-- Copyright : (c) The University of Glasgow 2006, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : alpha +-- Portability : portable +-- +-- An interface to building and installing Cabal packages. +-- If the @Built-Type@ field is specified as something other than +-- 'Custom', and the current version of Cabal is acceptable, this performs +-- setup actions directly. Otherwise it builds the setup script and +-- runs it with the given arguments. + +module Distribution.Client.SetupWrapper ( + setupWrapper, + SetupScriptOptions(..), + defaultSetupScriptOptions, + ) where + +import Distribution.Client.Types + ( InstalledPackage ) + +import qualified Distribution.Make as Make +import qualified Distribution.Simple as Simple +import Distribution.Version + ( Version(..), VersionRange, anyVersion, intersectVersionRanges + , withinRange ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(..), packageName + , packageVersion, Dependency(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(packageDescription) + , PackageDescription(..), BuildType(..) ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.Simple.Configure + ( configCompiler ) +import Distribution.Simple.Compiler + ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration, emptyProgramConfiguration + , rawSystemProgramConf, ghcProgram ) +import Distribution.Simple.BuildPaths + ( defaultDistPref, exeExtension ) +import Distribution.Simple.Command + ( CommandUI(..), commandShowOptions ) +import Distribution.Simple.GHC + ( ghcVerbosityOptions ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Client.IndexUtils + ( getInstalledPackages ) +import Distribution.Simple.Utils + ( die, debug, info, cabalVersion, findPackageDesc, comparing + , createDirectoryIfMissingVerbose, rewriteFile ) +import Distribution.Client.Utils + ( moreRecentFile, inDir ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import System.Directory ( doesFileExist, getCurrentDirectory ) +import System.FilePath ( (), (<.>) ) +import System.IO ( Handle ) +import System.Exit ( ExitCode(..), exitWith ) +import System.Process ( runProcess, waitForProcess ) +import Control.Monad ( when, unless ) +import Data.List ( maximumBy ) +import Data.Maybe ( fromMaybe, isJust ) +import Data.Monoid ( Monoid(mempty) ) +import Data.Char ( isSpace ) + +data SetupScriptOptions = SetupScriptOptions { + useCabalVersion :: VersionRange, + useCompiler :: Maybe Compiler, + usePackageDB :: PackageDBStack, + usePackageIndex :: Maybe (PackageIndex InstalledPackage), + useProgramConfig :: ProgramConfiguration, + useDistPref :: FilePath, + useLoggingHandle :: Maybe Handle, + useWorkingDir :: Maybe FilePath + } + +defaultSetupScriptOptions :: SetupScriptOptions +defaultSetupScriptOptions = SetupScriptOptions { + useCabalVersion = anyVersion, + useCompiler = Nothing, + usePackageDB = [GlobalPackageDB, UserPackageDB], + usePackageIndex = Nothing, + useProgramConfig = emptyProgramConfiguration, + useDistPref = defaultDistPref, + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + +setupWrapper :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> CommandUI flags + -> (Version -> flags) + -> [String] + -> IO () +setupWrapper verbosity options mpkg cmd flags extraArgs = do + pkg <- maybe getPkg return mpkg + let setupMethod = determineSetupMethod options' buildType' + options' = options { + useCabalVersion = intersectVersionRanges + (useCabalVersion options) + (descCabalVersion pkg) + } + buildType' = fromMaybe Custom (buildType pkg) + mkArgs cabalLibVersion = commandName cmd + : commandShowOptions cmd (flags cabalLibVersion) + ++ extraArgs + setupMethod verbosity options' (packageId pkg) buildType' mkArgs + where + getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options)) + >>= readPackageDescription verbosity + >>= return . packageDescription + +-- | Decide if we're going to be able to do a direct internal call to the +-- entry point in the Cabal library or if we're going to have to compile +-- and execute an external Setup.hs script. +-- +determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod +determineSetupMethod options buildType' + | isJust (useLoggingHandle options) + || buildType' == Custom = externalSetupMethod + | cabalVersion `withinRange` + useCabalVersion options = internalSetupMethod + | otherwise = externalSetupMethod + +type SetupMethod = Verbosity + -> SetupScriptOptions + -> PackageIdentifier + -> BuildType + -> (Version -> [String]) -> IO () + +-- ------------------------------------------------------------ +-- * Internal SetupMethod +-- ------------------------------------------------------------ + +internalSetupMethod :: SetupMethod +internalSetupMethod verbosity options _ bt mkargs = do + let args = mkargs cabalVersion + debug verbosity $ "Using internal setup method with build-type " ++ show bt + ++ " and args:\n " ++ show args + inDir (useWorkingDir options) $ + buildTypeAction bt args + +buildTypeAction :: BuildType -> ([String] -> IO ()) +buildTypeAction Simple = Simple.defaultMainArgs +buildTypeAction Configure = Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks +buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Custom = error "buildTypeAction Custom" +buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" + +-- ------------------------------------------------------------ +-- * External SetupMethod +-- ------------------------------------------------------------ + +externalSetupMethod :: SetupMethod +externalSetupMethod verbosity options pkg bt mkargs = do + debug verbosity $ "Using external setup method with build-type " ++ show bt + createDirectoryIfMissingVerbose verbosity True setupDir + (cabalLibVersion, options') <- cabalLibVersionToUse + debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion + setupHs <- updateSetupScript cabalLibVersion bt + debug verbosity $ "Using " ++ setupHs ++ " as setup script." + compileSetupExecutable options' cabalLibVersion setupHs + invokeSetupScript (mkargs cabalLibVersion) + + where + workingDir = case fromMaybe "" (useWorkingDir options) of + [] -> "." + dir -> dir + setupDir = workingDir useDistPref options "setup" + setupVersionFile = setupDir "setup" <.> "version" + setupProgFile = setupDir "setup" <.> exeExtension + + cabalLibVersionToUse :: IO (Version, SetupScriptOptions) + cabalLibVersionToUse = do + savedVersion <- savedCabalVersion + case savedVersion of + Just version | version `withinRange` useCabalVersion options + -> return (version, options) + _ -> do (comp, conf, options') <- configureCompiler options + version <- installedCabalVersion options comp conf + writeFile setupVersionFile (show version ++ "\n") + return (version, options') + + savedCabalVersion = do + versionString <- readFile setupVersionFile `catch` \_ -> return "" + case reads versionString of + [(version,s)] | all isSpace s -> return (Just version) + _ -> return Nothing + + installedCabalVersion :: SetupScriptOptions -> Compiler + -> ProgramConfiguration -> IO Version + installedCabalVersion _ _ _ | packageName pkg == PackageName "Cabal" = + return (packageVersion pkg) + installedCabalVersion options' comp conf = do + index <- case usePackageIndex options' of + Just index -> return index + Nothing -> fromMaybe mempty + `fmap` getInstalledPackages verbosity + comp (usePackageDB options') conf + + let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options) + case PackageIndex.lookupDependency index cabalDep of + [] -> die $ "The package requires Cabal library version " + ++ display (useCabalVersion options) + ++ " but no suitable version is installed." + pkgs -> return $ bestVersion (map packageVersion pkgs) + where + bestVersion = maximumBy (comparing preference) + preference version = (sameVersion, sameMajorVersion + ,stableVersion, latestVersion) + where + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionBranch + stableVersion = case versionBranch version of + (_:x:_) -> even x + _ -> False + latestVersion = version + + configureCompiler :: SetupScriptOptions + -> IO (Compiler, ProgramConfiguration, SetupScriptOptions) + configureCompiler options' = do + (comp, conf) <- case useCompiler options' of + Just comp -> return (comp, useProgramConfig options') + Nothing -> configCompiler (Just GHC) Nothing Nothing + (useProgramConfig options') verbosity + return (comp, conf, options' { useCompiler = Just comp, + useProgramConfig = conf }) + + -- | Decide which Setup.hs script to use, creating it if necessary. + -- + updateSetupScript :: Version -> BuildType -> IO FilePath + updateSetupScript _ Custom = do + useHs <- doesFileExist setupHs + useLhs <- doesFileExist setupLhs + unless (useHs || useLhs) $ die + "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." + return (if useHs then setupHs else setupLhs) + where + setupHs = workingDir "Setup.hs" + setupLhs = workingDir "Setup.lhs" + + updateSetupScript cabalLibVersion _ = do + rewriteFile setupHs (buildTypeScript cabalLibVersion) + return setupHs + where + setupHs = setupDir "setup.hs" + + buildTypeScript :: Version -> String + buildTypeScript cabalLibVersion = case bt of + Simple -> "import Distribution.Simple; main = defaultMain\n" + Configure -> "import Distribution.Simple; main = defaultMainWithHooks " + ++ if cabalLibVersion >= Version [1,3,10] [] + then "autoconfUserHooks\n" + else "defaultUserHooks\n" + Make -> "import Distribution.Make; main = defaultMain\n" + Custom -> error "buildTypeScript Custom" + UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" + + -- | If the Setup.hs is out of date wrt the executable then recompile it. + -- Currently this is GHC only. It should really be generalised. + -- + compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> IO () + compileSetupExecutable options' cabalLibVersion setupHsFile = do + setupHsNewer <- setupHsFile `moreRecentFile` setupProgFile + cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile + let outOfDate = setupHsNewer || cabalVersionNewer + when outOfDate $ do + debug verbosity "Setup script is out of date, compiling..." + (_, conf, _) <- configureCompiler options' + --TODO: get Cabal's GHC module to export a GhcOptions type and render func + rawSystemProgramConf verbosity ghcProgram conf $ + ghcVerbosityOptions verbosity + ++ ["--make", setupHsFile, "-o", setupProgFile + ,"-odir", setupDir, "-hidir", setupDir + ,"-i", "-i" ++ workingDir ] + ++ ghcPackageDbOptions (usePackageDB options') + ++ if packageName pkg == PackageName "Cabal" + then [] + else ["-package", display cabalPkgid] + where + cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + + ghcPackageDbOptions :: PackageDBStack -> [String] + ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error "internal error: unexpected package db stack" + + + invokeSetupScript :: [String] -> IO () + invokeSetupScript args = do + info verbosity $ unwords (setupProgFile : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " + ++ show logHandle + currentDir <- getCurrentDirectory + process <- runProcess (currentDir setupProgFile) args + (useWorkingDir options) Nothing + Nothing (useLoggingHandle options) (useLoggingHandle options) + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode diff --git a/cabal-install-0.8.2/Distribution/Client/SrcDist.hs b/cabal-install-0.8.2/Distribution/Client/SrcDist.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/SrcDist.hs @@ -0,0 +1,80 @@ +-- Implements the \"@.\/cabal sdist@\" command, which creates a source +-- distribution for this package. That is, packs up the source code +-- into a tarball, making use of the corresponding Cabal module. +module Distribution.Client.SrcDist ( + sdist + ) where +import Distribution.Simple.SrcDist + ( printPackageProblems, prepareTree + , prepareSnapshotTree, snapshotPackage ) +import Distribution.Client.Tar (createTarGzFile) + +import Distribution.Package + ( Package(..) ) +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.Simple.Utils + ( defaultPackageDesc, warn, notice, setupMessage + , createDirectoryIfMissingVerbose, withTempDirectory ) +import Distribution.Simple.Setup (SDistFlags(..), fromFlag) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.PreProcess (knownSuffixHandlers) +import Distribution.Simple.BuildPaths ( srcPref) +import Distribution.Simple.Configure(maybeGetPersistBuildConfig) +import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) +import Distribution.Text + ( display ) + +import System.Time (getClockTime, toCalendarTime) +import System.FilePath ((), (<.>)) +import Control.Monad (when) +import Data.Maybe (isNothing) + +-- |Create a source distribution. +sdist :: SDistFlags -> IO () +sdist flags = do + pkg <- return . flattenPackageDescription + =<< readPackageDescription verbosity + =<< defaultPackageDesc verbosity + mb_lbi <- maybeGetPersistBuildConfig distPref + let tmpTargetDir = srcPref distPref + + -- do some QA + printPackageProblems verbosity pkg + + when (isNothing mb_lbi) $ + warn verbosity "Cannot run preprocessors. Run 'configure' command first." + + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + + date <- toCalendarTime =<< getClockTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg + setupMessage verbosity "Building source dist for" (packageId pkg') + + _ <- if snapshot + then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps + else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps + targzFile <- createArchive verbosity pkg' tmpDir distPref + notice verbosity $ "Source tarball created: " ++ targzFile + + where + verbosity = fromFlag (sDistVerbosity flags) + snapshot = fromFlag (sDistSnapshot flags) + distPref = fromFlag (sDistDistPref flags) + pps = knownSuffixHandlers + +-- |Create an archive from a tree of source files, and clean up the tree. +createArchive :: Verbosity + -> PackageDescription + -> FilePath + -> FilePath + -> IO FilePath +createArchive _verbosity pkg tmpDir targetPref = do + let tarBallName = display (packageId pkg) + tarBallFilePath = targetPref tarBallName <.> "tar.gz" + createTarGzFile tarBallFilePath tmpDir tarBallName + return tarBallFilePath diff --git a/cabal-install-0.8.2/Distribution/Client/Tar.hs b/cabal-install-0.8.2/Distribution/Client/Tar.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Tar.hs @@ -0,0 +1,870 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Tar +-- Copyright : (c) 2007 Bjorn Bringert, +-- 2008 Andrea Vezzosi, +-- 2008-2009 Duncan Coutts +-- License : BSD3 +-- +-- Maintainer : duncan@haskell.org +-- Portability : portable +-- +-- Reading, writing and manipulating \"@.tar@\" archive files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Tar ( + -- * High level \"all in one\" operations + createTarGzFile, + extractTarGzFile, + + -- * Converting between internal and external representation + read, + write, + + -- * Packing and unpacking files to\/from internal representation + pack, + unpack, + + -- * Tar entry and associated types + Entry(..), + entryPath, + EntryContent(..), + Ownership(..), + FileSize, + Permissions, + EpochTime, + DevMajor, + DevMinor, + TypeCode, + Format(..), + + -- * Constructing simple entry values + simpleEntry, + fileEntry, + directoryEntry, + + -- * TarPath type + TarPath, + toTarPath, + fromTarPath, + + -- ** Sequences of tar entries + Entries(..), + foldEntries, + unfoldEntries, + mapEntries, + + ) where + +import Data.Char (ord) +import Data.Int (Int64) +import Data.Bits (Bits, shiftL) +import Data.List (foldl') +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 +import Data.ByteString.Lazy (ByteString) +import qualified Codec.Compression.GZip as GZip + +import System.FilePath + ( () ) +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 + , getPermissions, createDirectoryIfMissing, copyFile ) +import qualified System.Directory as Permissions + ( Permissions(executable) ) +import System.Posix.Types + ( FileMode ) +import System.Time + ( ClockTime(..) ) +import System.IO + ( IOMode(ReadMode), openBinaryFile, hFileSize ) +import System.IO.Unsafe (unsafeInterleaveIO) + +import Prelude hiding (read) + + +-- +-- * High level operations +-- + +createTarGzFile :: FilePath -- ^ Full Tarball path + -> FilePath -- ^ Base directory + -> FilePath -- ^ Directory to archive, relative to base dir + -> IO () +createTarGzFile tar 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 expected tar = + unpack dir . checkTarbomb expected . read . GZip.decompress =<< BS.readFile tar + +-- +-- * Entry type +-- + +type FileSize = Int64 +-- | The number of seconds since the UNIX epoch +type EpochTime = Int64 +type DevMajor = Int +type DevMinor = Int +type TypeCode = Char +type Permissions = FileMode + +-- | Tar archive entry. +-- +data Entry = Entry { + + -- | 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, + + -- | The real content of the entry. For 'NormalFile' this includes the + -- file data. An entry usually contains a 'NormalFile' or a 'Directory'. + entryContent :: !EntryContent, + + -- | File permissions (Unix style file mode). + entryPermissions :: !Permissions, + + -- | The user and group to which this file belongs. + entryOwnership :: !Ownership, + + -- | The time the file was last modified. + entryTime :: !EpochTime, + + -- | The tar format the archive is using. + entryFormat :: !Format + } + +-- | Native 'FilePath' of the file or directory within the archive. +-- +entryPath :: Entry -> FilePath +entryPath = fromTarPath . entryTarPath + +-- | 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, + + -- | Numeric owner user id. Should be set to @0@ if unknown. + ownerId :: !Int, + + -- | Numeric owner group id. Should be set to @0@ if unknown. + groupId :: !Int + } + +-- | 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 = + + -- | 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 + + -- | 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 + + -- | 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 + +-- | @rw-r--r--@ for normal files +ordinaryFilePermissions :: Permissions +ordinaryFilePermissions = 0o0644 + +-- | @rwxr-xr-x@ for executable files +executableFilePermissions :: Permissions +executableFilePermissions = 0o0755 + +-- | @rwxr-xr-x@ for directories +directoryPermissions :: Permissions +directoryPermissions = 0o0755 + +-- | 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 + } + +-- | 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 +-- + +-- | The classic tar format allowed just 100 charcters for the file name. The +-- USTAR format extended this with an extra 155 characters, however it uses a +-- complex method of splitting the name between the two sections. +-- +-- Instead of just putting any overflow into the extended area, it uses the +-- extended area as a prefix. The agrevating insane bit however is that the +-- prefix (if any) must only contain a directory prefix. That is the split +-- between the two areas must be on a directory separator boundary. So there is +-- 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 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 +-- probably better than ending up with the wrong names too. +-- +-- So it's understandable but rather annoying. +-- +-- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective +-- of the local path conventions. +-- +-- * The directory separator between the prefix and name is /not/ stored. +-- +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'. +-- +-- The native 'FilePath' will use the native directory separator but it is not +-- otherwise checked for validity or sanity. In particular: +-- +-- * 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 (eg using 'checkSecurity'). +-- +fromTarPath :: TarPath -> FilePath +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 conversion may fail if the 'FilePath' is too long. See 'TarPath' for a +-- description of the problem with splitting long 'FilePath's. +-- +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 | isDir = FilePath.Posix.addTrailingPathSeparator + | otherwise = id + +-- | 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 +-- and try to fit as many components into the 100 long name area as possible. +-- If all the remaining components fit in the 155 name area then we win. +-- +splitLongPath :: FilePath -> Either String TarPath +splitLongPath path = + case packName nameMax (reverse (FilePath.Posix.splitPath path)) of + Left err -> Left err + Right (name, []) -> Right (TarPath name "") + Right (name, first:rest) -> case packName prefixMax remainder of + Left err -> Left err + Right (_ , (_:_)) -> Left "File name too long (cannot split)" + Right (prefix, []) -> Right (TarPath name prefix) + where + -- drop the '/' between the name and prefix: + remainder = init first : rest + + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + packName _ [] = Left "File name empty" + packName maxLen (c:cs) + | n > maxLen = Left "File name too long" + | otherwise = Right (packName' maxLen n [c] cs) + where n = length c + + packName' maxLen n ok (c:cs) + | n' <= maxLen = packName' maxLen n' (c:ok) cs + 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 +-- + +-- | A tar archive is a sequence of entries. +data Entries = Next Entry Entries + | Done + | Fail String + +unfoldEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries +unfoldEntries f = unfold + where + unfold x = case f x of + Left err -> Fail err + Right Nothing -> Done + Right (Just (e, x')) -> Next e (unfold x') + +foldEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a +foldEntries next done fail' = fold + where + fold (Next e es) = next e (fold es) + fold Done = done + fold (Fail err) = fail' err + +mapEntries :: (Entry -> Either String Entry) -> Entries -> Entries +mapEntries f = + foldEntries (\entry rest -> either Fail (flip Next rest) (f entry)) Done Fail + +-- +-- * Checking +-- + +-- | 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 + +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 + | 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 +-- + +read :: ByteString -> Entries +read = unfoldEntries getEntry + +getEntry :: ByteString -> Either String (Maybe (Entry, ByteString)) +getEntry bs + | BS.length header < 512 = Left "truncated tar archive" + + -- 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 + 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 + prefix = getString 345 155 header +-- trailing = getBytes 500 12 header + + 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' + where + -- sum of all 512 bytes in the header block, + -- treating each byte as an 8-bit unsigned value + checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header' + -- treating the 8 bytes of chksum as blank characters. + header' = BS.concat [BS.take 148 header, + BS.Char8.replicate 8 ' ', + BS.drop 156 header] + +-- * TAR format primitive input + +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 + 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 + +getByte :: Int64 -> ByteString -> Char +getByte off bs = BS.Char8.index bs off + +getChars :: Int64 -> Int64 -> ByteString -> String +getChars off len = BS.Char8.unpack . getBytes off len + +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 +-- + +-- | 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 = 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 + padding size = BS.replicate paddingSize 0 + where paddingSize = fromIntegral (negate size `mod` 512) + +putHeader :: Entry -> ByteString +putHeader entry = + BS.Char8.pack $ take 148 block + ++ putOct 7 checksum + ++ ' ' : drop 156 block + where + block = putHeaderNoChkSum entry + checksum = foldl' (\x y -> x + ord y) 0 block + +putHeaderNoChkSum :: Entry -> String +putHeaderNoChkSum Entry { + entryTarPath = TarPath name prefix, + entryContent = content, + entryPermissions = permissions, + entryOwnership = ownership, + entryTime = modTime, + entryFormat = format + } = + + concat + [ putString 100 $ name + , putOct 8 $ permissions + , putOct 8 $ ownerId ownership + , putOct 8 $ groupId ownership + , putOct 12 $ contentSize + , putOct 12 $ modTime + , fill 8 $ ' ' -- dummy checksum + , putChar8 $ typeCode + , putString 100 $ linkTarget + ] ++ + case format of + V7Format -> + fill 255 '\NUL' + UstarFormat -> concat + [ putString 8 $ "ustar\NUL00" + , putString 32 $ ownerName ownership + , putString 32 $ groupName ownership + , putOct 8 $ deviceMajor + , putOct 8 $ deviceMinor + , putString 155 $ prefix + , fill 12 $ '\NUL' + ] + GnuFormat -> concat + [ putString 8 $ "ustar \NUL" + , putString 32 $ ownerName ownership + , putString 32 $ groupName ownership + , putGnuDev 8 $ deviceMajor + , putGnuDev 8 $ deviceMinor + , putString 155 $ prefix + , fill 12 $ '\NUL' + ] + where + (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 + +type FieldWidth = Int + +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 "" + in fill (n - length octStr - 1) '0' + ++ octStr + ++ putChar8 '\NUL' + +putChar8 :: Char -> String +putChar8 c = [c] + +fill :: FieldWidth -> Char -> String +fill n c = replicate n c + +-- +-- * Unpacking +-- + +unpack :: FilePath -> Entries -> IO () +unpack baseDir entries = unpackEntries [] (checkSecurity entries) + >>= emulateLinks + + where + -- We're relying here on 'checkSecurity' to make sure we're not scribbling + -- files all over the place. + + 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 + path = entryPath entry + + 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 + absDir = baseDir FilePath.Native.takeDirectory path + absPath = baseDir 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 +-- + +pack :: FilePath -- ^ Base directory + -> [FilePath] -- ^ Files and directories to pack, relative to the base dir + -> IO [Entry] +pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir + +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 ] + +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 + dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry + isDirectory <- doesDirectoryExist (base dirEntry) + if isDirectory + then collect files (dirEntry':dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +getModTime :: FilePath -> IO EpochTime +getModTime path = do + (TOD s _) <- getModificationTime path + return $! fromIntegral s diff --git a/cabal-install-0.8.2/Distribution/Client/Types.hs b/cabal-install-0.8.2/Distribution/Client/Types.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Types.hs @@ -0,0 +1,148 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Types +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- All data types for the entire cabal-install system gathered here to avoid some .hs-boot files. +----------------------------------------------------------------------------- +module Distribution.Client.Types where + +import Distribution.Package + ( PackageName, PackageId, Package(..) + , PackageFixedDeps(..), Dependency ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.PackageDescription + ( GenericPackageDescription, FlagAssignment ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import Distribution.Version + ( VersionRange ) + +import Data.Map (Map) +import Network.URI (URI) +import Distribution.Compat.Exception + ( SomeException ) + +newtype Username = Username { unUsername :: String } +newtype Password = Password { unPassword :: String } + +-- | This is the information we get from a @00-index.tar.gz@ hackage index. +-- +data AvailablePackageDb = AvailablePackageDb { + packageIndex :: PackageIndex AvailablePackage, + packagePreferences :: Map PackageName VersionRange +} + +-- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8. +-- What is new in 1.8 is that installed packages and dependencies between +-- installed packages are now identified by an opaque InstalledPackageId +-- rather than a source PackageId. +-- +-- We should use simply an 'InstalledPackageInfo' here but to ease the +-- transition we are temporarily using this variant where we pretend that +-- installed packages still specify their deps in terms of PackageIds. +-- +-- Crucially this means that 'InstalledPackage' can be an instance of +-- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance +-- of that class. This means we can make 'PackageIndex'es of InstalledPackage +-- where as the InstalledPackageInfo now has its own monomorphic index type. +-- +data InstalledPackage = InstalledPackage + InstalledPackageInfo + [PackageId] + +instance Package InstalledPackage where + packageId (InstalledPackage pkg _) = packageId pkg +instance PackageFixedDeps InstalledPackage where + depends (InstalledPackage _ deps) = deps + +-- | A 'ConfiguredPackage' is a not-yet-installed package along with the +-- total configuration information. The configuration information is total in +-- the sense that it provides all the configuration information and so the +-- final configure process will be independent of the environment. +-- +data ConfiguredPackage = ConfiguredPackage + AvailablePackage -- package info, including repo + FlagAssignment -- complete flag assignment for the package + [PackageId] -- set of exact dependencies. These must be + -- consistent with the 'buildDepends' in the + -- 'PackageDescrption' that you'd get by applying + -- the flag assignment. + deriving Show + +instance Package ConfiguredPackage where + packageId (ConfiguredPackage pkg _ _) = packageId pkg + +instance PackageFixedDeps ConfiguredPackage where + depends (ConfiguredPackage _ _ deps) = deps + + +-- | We re-use @GenericPackageDescription@ and use the @package-url@ +-- field to store the tarball URI. +data AvailablePackage = AvailablePackage { + packageInfoId :: PackageId, + packageDescription :: GenericPackageDescription, + packageSource :: AvailablePackageSource + } + deriving Show + +instance Package AvailablePackage where packageId = packageInfoId + +data AvailablePackageSource = + + -- | The unpacked package in the current dir + LocalUnpackedPackage + + -- | A package available as a tarball from a repository. + -- + -- It may be from a local repository or from a remote repository, with a + -- locally cached copy. ie a package available from hackage + | RepoTarballPackage Repo + +-- | ScmPackage + deriving Show + +--TODO: +-- * generalise local package to any local unpacked package, not just in the +-- current dir, ie add a FilePath param +-- * add support for darcs and other SCM style remote repos with a local cache + +data LocalRepo = LocalRepo + deriving (Show,Eq) + +data RemoteRepo = RemoteRepo { + remoteRepoName :: String, + remoteRepoURI :: URI + } + deriving (Show,Eq) + +data Repo = Repo { + repoKind :: Either RemoteRepo LocalRepo, + repoLocalDir :: FilePath + } + deriving (Show,Eq) + +data UnresolvedDependency + = UnresolvedDependency + { dependency :: Dependency + , depFlags :: FlagAssignment + } + deriving (Show) + +type BuildResult = Either BuildFailure BuildSuccess +data BuildFailure = DependentFailed PackageId + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | InstallFailed SomeException +data BuildSuccess = BuildOk DocsResult TestsResult + +data DocsResult = DocsNotTried | DocsFailed | DocsOk +data TestsResult = TestsNotTried | TestsFailed | TestsOk diff --git a/cabal-install-0.8.2/Distribution/Client/Unpack.hs b/cabal-install-0.8.2/Distribution/Client/Unpack.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Unpack.hs @@ -0,0 +1,116 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Unpack +-- Copyright : (c) Andrea Vezzosi 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Unpack ( + + -- * Commands + unpack, + + ) where + +import Distribution.Package + ( PackageId, packageId, Dependency(..) ) +import Distribution.Client.PackageIndex as PackageIndex (lookupDependency) +import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault) +import Distribution.Simple.Utils + ( notice, die ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Text(display) +import Distribution.Version + ( anyVersion, intersectVersionRanges ) + +import Distribution.Client.Setup(UnpackFlags(unpackVerbosity, + unpackDestDir)) +import Distribution.Client.Types(UnresolvedDependency(..), + Repo, AvailablePackageSource(..), + AvailablePackage(AvailablePackage), + AvailablePackageDb(AvailablePackageDb)) +import Distribution.Client.Fetch(fetchPackage) +import qualified Distribution.Client.Tar as Tar (extractTarGzFile) +import Distribution.Client.IndexUtils as IndexUtils + (getAvailablePackages, disambiguateDependencies) + +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) +import Control.Monad + ( unless, when ) +import Data.Ord (comparing) +import Data.List(maximumBy) +import System.FilePath + ( (), addTrailingPathSeparator ) +import qualified Data.Map as Map + +unpack :: UnpackFlags -> [Repo] -> [Dependency] -> IO () +unpack flags repos deps + | null deps = notice verbosity + "No packages requested. Nothing to do." + | otherwise = do + db@(AvailablePackageDb available _) + <- getAvailablePackages verbosity repos + deps' <- fmap (map dependency) + . IndexUtils.disambiguateDependencies available + . map toUnresolved $ deps + + let pkgs = resolvePackages db deps' + + unless (null prefix) $ + createDirectoryIfMissing True prefix + + flip mapM_ pkgs $ \pkg -> + case pkg of + + Left (Dependency name ver) -> + die $ "There is no available version of " ++ display name + ++ " that satisfies " ++ display ver + + Right (AvailablePackage pkgid _ (RepoTarballPackage repo)) -> do + pkgPath <- fetchPackage verbosity repo pkgid + unpackPackage verbosity prefix pkgid pkgPath + + Right (AvailablePackage _ _ LocalUnpackedPackage) -> + error "Distribution.Client.Unpack.unpack: the impossible happened." + where + verbosity = fromFlag (unpackVerbosity flags) + prefix = fromFlagOrDefault "" (unpackDestDir flags) + toUnresolved d = UnresolvedDependency d [] + +unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO () +unpackPackage verbosity prefix pkgid pkgPath = do + let pkgdirname = display pkgid + pkgdir = prefix pkgdirname + pkgdir' = addTrailingPathSeparator pkgdir + existsDir <- doesDirectoryExist pkgdir + when existsDir $ die $ + "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." + existsFile <- doesFileExist pkgdir + when existsFile $ die $ + "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." + notice verbosity $ "Unpacking to " ++ pkgdir' + Tar.extractTarGzFile prefix pkgdirname pkgPath + +resolvePackages :: AvailablePackageDb + -> [Dependency] + -> [Either Dependency AvailablePackage] +resolvePackages (AvailablePackageDb available prefs) deps = + map (\d -> best d (candidates d)) deps + where + candidates dep@(Dependency name ver) = + let [x,y] = map (PackageIndex.lookupDependency available) + [ Dependency name + (maybe anyVersion id (Map.lookup name prefs) + `intersectVersionRanges` ver) + , dep ] + in if null x then y else x + best d [] = Left d + best _ xs = Right $ maximumBy (comparing packageId) xs + diff --git a/cabal-install-0.8.2/Distribution/Client/Update.hs b/cabal-install-0.8.2/Distribution/Client/Update.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Update.hs @@ -0,0 +1,82 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Update +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Update + ( update + ) where + +import Distribution.Client.Types + ( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) ) +import Distribution.Client.Fetch + ( downloadIndex ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.IndexUtils + ( getAvailablePackages ) +import qualified Paths_cabal_install + ( version ) + +import Distribution.Package + ( PackageName(..), packageVersion ) +import Distribution.Version + ( anyVersion, withinRange ) +import Distribution.Simple.Utils + ( warn, notice, writeFileAtomic ) +import Distribution.Verbosity + ( Verbosity ) + +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import qualified Codec.Compression.GZip as GZip (decompress) +import qualified Data.Map as Map +import System.FilePath (dropExtension) +import Data.Maybe (fromMaybe) +import Control.Monad (when) + +-- | 'update' downloads the package list from all known servers +update :: Verbosity -> [Repo] -> IO () +update verbosity [] = do + warn verbosity $ "No remote package servers have been specified. Usually " + ++ "you would have one specified in the config file." +update verbosity repos = do + mapM_ (updateRepo verbosity) repos + checkForSelfUpgrade verbosity repos + +updateRepo :: Verbosity -> Repo -> IO () +updateRepo verbosity repo = case repoKind repo of + Right LocalRepo -> return () + Left remoteRepo -> do + notice verbosity $ "Downloading the latest package list from " + ++ remoteRepoName remoteRepo + indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo) + writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack + . GZip.decompress + =<< BS.readFile indexPath + +checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () +checkForSelfUpgrade verbosity repos = do + AvailablePackageDb available prefs <- getAvailablePackages verbosity repos + + let self = PackageName "cabal-install" + 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 ] + + 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/cabal-install-0.8.2/Distribution/Client/Upload.hs b/cabal-install-0.8.2/Distribution/Client/Upload.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Upload.hs @@ -0,0 +1,177 @@ +-- This is a quick hack for uploading packages to Hackage. +-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload + +module Distribution.Client.Upload (check, upload, report) where + +import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..)) +import Distribution.Client.HttpUtils (proxy, isOldHackageURI) + +import Distribution.Simple.Utils (debug, notice, warn, info) +import Distribution.Verbosity (Verbosity) +import Distribution.Text (display) +import Distribution.Client.Config + +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import qualified Distribution.Client.BuildReports.Upload as BuildReport + +import Network.Browser + ( BrowserAction, browse, request + , Authority(..), addAuthority, setAuthorityGen + , setOutHandler, setErrHandler, setProxy ) +import Network.HTTP + ( Header(..), HeaderName(..), findHeader + , Request(..), RequestMethod(..), Response(..) ) +import Network.TCP (HandleStream) +import Network.URI (URI(uriPath), parseURI) + +import Data.Char (intToDigit) +import Numeric (showHex) +import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho + ,openBinaryFile, IOMode(ReadMode), hGetContents) +import Control.Exception (bracket) +import System.Random (randomRIO) +import System.FilePath ((), takeExtension, takeFileName) +import qualified System.FilePath.Posix as FilePath.Posix (combine) +import System.Directory +import Control.Monad (forM_) + + +--FIXME: how do we find this path for an arbitrary hackage server? +-- is it always at some fixed location relative to the server root? +legacyUploadURI :: URI +Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg" + +checkURI :: URI +Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg" + + +upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO () +upload verbosity repos mUsername mPassword paths = do + let uploadURI = if isOldHackageURI targetRepoURI + then legacyUploadURI + else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"} + Username username <- maybe promptUsername return mUsername + Password password <- maybe promptPassword return mPassword + let auth = addAuthority AuthBasic { + auRealm = "Hackage", + auUsername = username, + auPassword = password, + auSite = uploadURI + } + flip mapM_ paths $ \path -> do + notice verbosity $ "Uploading " ++ path ++ "... " + handlePackage verbosity uploadURI auth path + where + targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given + promptUsername :: IO Username + promptUsername = do + putStr "Hackage username: " + hFlush stdout + fmap Username getLine + + promptPassword :: IO Password + promptPassword = do + putStr "Hackage password: " + hFlush stdout + -- save/restore the terminal echoing status + passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do + hSetEcho stdin False -- no echoing for entering the password + fmap Password getLine + putStrLn "" + return passwd + +report :: Verbosity -> [Repo] -> IO () +report verbosity repos + = forM_ repos $ \repo -> + case repoKind repo of + Left remoteRepo + -> do dotCabal <- defaultCabalDir + let srcDir = dotCabal "reports" remoteRepoName remoteRepo + contents <- getDirectoryContents srcDir + forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile -> + do inp <- readFile (srcDir logFile) + let (reportStr, buildLog) = read inp :: (String,String) + case BuildReport.parse reportStr of + Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME + Right report' -> + do info verbosity $ "Uploading report for " ++ display (BuildReport.package report') + browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] + return () + Right{} -> return () + +check :: Verbosity -> [FilePath] -> IO () +check verbosity paths = do + flip mapM_ paths $ \path -> do + notice verbosity $ "Checking " ++ path ++ "... " + handlePackage verbosity checkURI (return ()) path + +handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) () + -> FilePath -> IO () +handlePackage verbosity uri auth path = + do req <- mkRequest uri path + p <- proxy verbosity + debug verbosity $ "\n" ++ show req + (_,resp) <- browse $ do + setProxy p + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + auth + setAuthorityGen (\_ _ -> return Nothing) + 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 ++ ": " + ++ map intToDigit [x,y,z] ++ " " + ++ rspReason resp + case findHeader HdrContentType resp of + Just contenttype + | takeWhile (/= ';') contenttype == "text/plain" + -> notice verbosity $ rspBody resp + _ -> debug verbosity $ rspBody resp + +mkRequest :: URI -> FilePath -> IO (Request String) +mkRequest uri path = + do pkg <- readBinaryFile path + boundary <- genBoundary + let body = printMultiPart boundary (mkFormData path pkg) + return $ Request { + rqURI = uri, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary), + Header HdrContentLength (show (length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + +readBinaryFile :: FilePath -> IO String +readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents + +genBoundary :: IO String +genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer + return $ showHex i "" + +mkFormData :: FilePath -> String -> [BodyPart] +mkFormData path pkg = + -- yes, web browsers are that stupid (re quoting) + [BodyPart [Header hdrContentDisposition $ + "form-data; name=package; filename=\""++takeFileName path++"\"", + Header HdrContentType "application/x-gzip"] + pkg] + +hdrContentDisposition :: HeaderName +hdrContentDisposition = HdrCustom "Content-disposition" + +-- * Multipart, partly stolen from the cgi package. + +data BodyPart = BodyPart [Header] String + +printMultiPart :: String -> [BodyPart] -> String +printMultiPart boundary xs = + concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf + +printBodyPart :: String -> BodyPart -> String +printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c + +crlf :: String +crlf = "\r\n" diff --git a/cabal-install-0.8.2/Distribution/Client/Utils.hs b/cabal-install-0.8.2/Distribution/Client/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Utils.hs @@ -0,0 +1,60 @@ +module Distribution.Client.Utils where + +import Data.List + ( sortBy, groupBy ) +import System.Directory + ( doesFileExist, getModificationTime + , getCurrentDirectory, setCurrentDirectory ) +import qualified Control.Exception as Exception + ( finally ) + +-- | Generic merging utility. For sorted input lists this is a full outer join. +-- +-- * The result list never contains @(Nothing, Nothing)@. +-- +mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] +mergeBy cmp = merge + where + merge [] ys = [ OnlyInRight y | y <- ys] + merge xs [] = [ OnlyInLeft x | x <- xs] + merge (x:xs) (y:ys) = + case x `cmp` y of + GT -> OnlyInRight y : merge (x:xs) ys + EQ -> InBoth x y : merge xs ys + LT -> OnlyInLeft x : merge xs (y:ys) + +data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b + +duplicates :: Ord a => [a] -> [[a]] +duplicates = duplicatesBy compare + +duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]] +duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp + where + eq a b = case cmp a b of + EQ -> True + _ -> False + moreThanOne (_:_:_) = True + moreThanOne _ = False + +-- | Compare the modification times of two files to see if the first is newer +-- than the second. The first file must exist but the second need not. +-- The expected use case is when the second file is generated using the first. +-- In this use case, if the result is True then the second file is out of date. +-- +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) + +-- | Executes the action in the specified directory. +inDir :: Maybe FilePath -> IO () -> IO () +inDir Nothing m = m +inDir (Just d) m = do + old <- getCurrentDirectory + setCurrentDirectory d + m `Exception.finally` setCurrentDirectory old diff --git a/cabal-install-0.8.2/Distribution/Client/Win32SelfUpgrade.hs b/cabal-install-0.8.2/Distribution/Client/Win32SelfUpgrade.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Client/Win32SelfUpgrade.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Win32SelfUpgrade +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Support for self-upgrading executables on Windows platforms. +----------------------------------------------------------------------------- +module Distribution.Client.Win32SelfUpgrade ( +-- * Explanation +-- +-- | Windows inherited a design choice from DOS that while initially innocuous +-- has rather unfortunate consequences. It maintains the invariant that every +-- open file has a corresponding name on disk. One positive consequence of this +-- is that an executable can always find it's own executable file. The downside +-- is that a program cannot be deleted or upgraded while it is running without +-- hideous workarounds. This module implements one such hideous workaround. +-- +-- The basic idea is: +-- +-- * Move our own exe file to a new name +-- * Copy a new exe file to the previous name +-- * Run the new exe file, passing our own pid and new path +-- * Wait for the new process to start +-- * Close the new exe file +-- * Exit old process +-- +-- Then in the new process: +-- +-- * Inform the old process that we've started +-- * Wait for the old process to die +-- * Delete the old exe file +-- * Exit new process +-- + + possibleSelfUpgrade, + deleteOldExeFile, + ) where + +#if mingw32_HOST_OS || mingw32_TARGET_OS + +import qualified System.Win32 as Win32 +import qualified System.Win32.DLL as Win32 +import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) +import Foreign.Ptr (Ptr, nullPtr) +import System.Process (runProcess) +import System.Directory (canonicalizePath) +import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) + +import Distribution.Verbosity as Verbosity (Verbosity, showForCabal) +import Distribution.Simple.Utils (debug, info) + +import Prelude hiding (log) + +-- | If one of the given files is our own exe file then we arrange things such +-- that the nested action can replace our own exe file. +-- +-- We require that the new process accepts a command line invocation that +-- calls 'deleteOldExeFile', passing in the pid and exe file. +-- +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade verbosity newPaths action = do + dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE + + newPaths' <- mapM canonicalizePath newPaths + let doingSelfUpgrade = any (equalFilePath dstPath) newPaths' + + if not doingSelfUpgrade + then action + else do + info verbosity $ "cabal-install does the replace-own-exe-file dance..." + tmpPath <- moveOurExeOutOfTheWay verbosity + result <- action + scheduleOurDemise verbosity dstPath tmpPath + (\pid path -> ["win32selfupgrade", pid, path + ,"--verbose=" ++ Verbosity.showForCabal verbosity]) + return result + +-- | The name of a Win32 Event object that we use to synchronise between the +-- old and new processes. We need to synchronise to make sure that the old +-- process has not yet terminated by the time the new one starts up and looks +-- for the old process. Otherwise the old one might have already terminated +-- and we could not wait on it terminating reliably (eg the pid might get +-- re-used). +-- +syncEventName :: String +syncEventName = "Local\\cabal-install-upgrade" + +-- | The first part of allowing our exe file to be replaced is to move the +-- existing exe file out of the way. Although we cannot delete our exe file +-- while we're still running, fortunately we can rename it, at least within +-- the same directory. +-- +moveOurExeOutOfTheWay :: Verbosity -> IO FilePath +moveOurExeOutOfTheWay verbosity = do + ourPID <- getCurrentProcessId + dstPath <- Win32.getModuleFileName Win32.nullHANDLE + + let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID) + + debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath + Win32.moveFile dstPath tmpPath + return tmpPath + +-- | Assuming we've now installed the new exe file in the right place, we +-- launch it and ask it to delete our exe file when we eventually terminate. +-- +scheduleOurDemise :: Verbosity -> FilePath -> FilePath + -> (String -> FilePath -> [String]) -> IO () +scheduleOurDemise verbosity dstPath tmpPath mkArgs = do + ourPID <- getCurrentProcessId + event <- createEvent syncEventName + + let args = mkArgs (show ourPID) tmpPath + log $ "launching child " ++ unwords (dstPath : map show args) + runProcess dstPath args Nothing Nothing Nothing Nothing Nothing + + log $ "waiting for the child to start up" + waitForSingleObject event (10*1000) -- wait at most 10 sec + log $ "child started ok" + + where + log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg) + +-- | Assuming we're now in the new child process, we've been asked by the old +-- process to wait for it to terminate and then we can remove the old exe file +-- that it renamted itself to. +-- +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile verbosity oldPID tmpPath = do + log $ "process started. Will delete exe file of process " + ++ show oldPID ++ " at path " ++ tmpPath + + log $ "getting handle of parent process " ++ show oldPID + oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID) + + log $ "synchronising with parent" + event <- openEvent syncEventName + setEvent event + + log $ "waiting for parent process to terminate" + waitForSingleObject oldPHANDLE Win32.iNFINITE + log $ "parent process terminated" + + log $ "deleting parent's old .exe file" + Win32.deleteFile tmpPath + + where + log msg = debug verbosity ("Win32Reinstall.child: " ++ msg) + +------------------------ +-- Win32 foreign imports +-- + +-- A bunch of functions sadly not provided by the Win32 package. + +foreign import stdcall unsafe "windows.h GetCurrentProcessId" + getCurrentProcessId :: IO DWORD + +foreign import stdcall unsafe "windows.h WaitForSingleObject" + waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD + +waitForSingleObject :: HANDLE -> DWORD -> IO () +waitForSingleObject handle timeout = + Win32.failIf_ bad "WaitForSingleObject" $ + waitForSingleObject_ handle timeout + where + bad result = not (result == 0 || result == wAIT_TIMEOUT) + wAIT_TIMEOUT = 0x00000102 + +foreign import stdcall unsafe "windows.h CreateEventW" + createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE + +createEvent :: String -> IO HANDLE +createEvent name = do + Win32.failIfNull "CreateEvent" $ + Win32.withTString name $ + createEvent_ nullPtr False False + +foreign import stdcall unsafe "windows.h OpenEventW" + openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +openEvent :: String -> IO HANDLE +openEvent name = do + Win32.failIfNull "OpenEvent" $ + Win32.withTString name $ + openEvent_ eVENT_MODIFY_STATE False + where + eVENT_MODIFY_STATE :: DWORD + eVENT_MODIFY_STATE = 0x0002 + +foreign import stdcall unsafe "windows.h SetEvent" + setEvent_ :: HANDLE -> IO BOOL + +setEvent :: HANDLE -> IO () +setEvent handle = + Win32.failIfFalse_ "SetEvent" $ + setEvent_ handle + +#else + +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils (die) + +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade _ _ action = action + +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32" + +#endif diff --git a/cabal-install-0.8.2/Distribution/Compat/Exception.hs b/cabal-install-0.8.2/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Distribution/Compat/Exception.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Distribution.Compat.Exception ( + SomeException, + onException, + catchIO, + handleIO, + catchExit, + throwIOIO + ) where + +import System.Exit +import qualified Control.Exception as Exception +#if MIN_VERSION_base(4,0,0) +import Control.Exception (SomeException) +#else +import Control.Exception (Exception) +type SomeException = Exception +#endif + +onException :: IO a -> IO b -> IO a +#if MIN_VERSION_base(4,0,0) +onException = Exception.onException +#else +onException io what = io `Exception.catch` \e -> do what + Exception.throw e +#endif + +throwIOIO :: Exception.IOException -> IO a +#if MIN_VERSION_base(4,0,0) +throwIOIO = Exception.throwIO +#else +throwIOIO = Exception.throwIO . Exception.IOException +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#if MIN_VERSION_base(4,0,0) +catchIO = Exception.catch +#else +catchIO = Exception.catchJust Exception.ioErrors +#endif + +handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a +handleIO = flip catchIO + +catchExit :: IO a -> (ExitCode -> IO a) -> IO a +#if MIN_VERSION_base(4,0,0) +catchExit = Exception.catch +#else +catchExit = Exception.catchJust exitExceptions + where exitExceptions (Exception.ExitException ee) = Just ee + exitExceptions _ = Nothing +#endif diff --git a/cabal-install-0.8.2/LICENSE b/cabal-install-0.8.2/LICENSE new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, + Bjorn Bringert, Krasimir Angelov, + Malcolm Wallace, Ross Patterson, + Lemmih, Paolo Martini, Don Stewart, + Duncan Coutts +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. diff --git a/cabal-install-0.8.2/Paths_cabal_install.hs b/cabal-install-0.8.2/Paths_cabal_install.hs new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/Paths_cabal_install.hs @@ -0,0 +1,8 @@ +module Paths_cabal_install ( + version, + ) where + +import Data.Version (Version(..)) + +version :: Version +version = Version {versionBranch = [0,8,2], versionTags = []} diff --git a/cabal-install-0.8.2/cabal-install.cabal b/cabal-install-0.8.2/cabal-install.cabal new file mode 100644 --- /dev/null +++ b/cabal-install-0.8.2/cabal-install.cabal @@ -0,0 +1,122 @@ +Name: cabal-install +Version: 0.8.2 +Synopsis: The command-line interface for Cabal and Hackage. +Description: + The \'cabal\' command-line program simplifies the process of managing + Haskell software by automating the fetching, configuration, compilation + and installation of Haskell libraries and programs. +homepage: http://www.haskell.org/cabal/ +bug-reports: http://hackage.haskell.org/trac/hackage/ +License: BSD3 +License-File: LICENSE +Author: Lemmih + Paolo Martini + Bjorn Bringert + Isaac Potoczny-Jones + Duncan Coutts +Maintainer: cabal-devel@haskell.org +Copyright: 2005 Lemmih + 2006 Paolo Martini + 2007 Bjorn Bringert + 2007 Isaac Potoczny-Jones + 2008-2009 Duncan Coutts +Category: Distribution +Build-type: Simple +Extra-Source-Files: README bash-completion/cabal bootstrap.sh +Cabal-Version: >= 1.6 +Tested-With: GHC==6.6.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.1 + +source-repository head + type: darcs + location: http://darcs.haskell.org/cabal-install/ + +source-repository this + type: darcs + location: http://darcs.haskell.org/cabal-branches/cabal-install-0.8/ + tag: 0.8.2 + +flag old-base + description: Old, monolithic base + default: False + +flag bytestring-in-base + +Executable cabal + Main-Is: Main.hs + -- We want assertion checking on even if people build with -O + -- although it is expensive, we want to catch problems early: + ghc-options: -Wall -fno-ignore-asserts + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + Other-Modules: + Distribution.Client.BuildReports.Anonymous + Distribution.Client.BuildReports.Storage + Distribution.Client.BuildReports.Types + Distribution.Client.BuildReports.Upload + Distribution.Client.Check + Distribution.Client.Config + Distribution.Client.Configure + Distribution.Client.Dependency + Distribution.Client.Dependency.Bogus + Distribution.Client.Dependency.TopDown + Distribution.Client.Dependency.TopDown.Constraints + Distribution.Client.Dependency.TopDown.Types + Distribution.Client.Dependency.Types + Distribution.Client.Fetch + Distribution.Client.Haddock + Distribution.Client.HttpUtils + Distribution.Client.IndexUtils + Distribution.Client.Init + Distribution.Client.Init.Heuristics + Distribution.Client.Init.Licenses + Distribution.Client.Init.Types + Distribution.Client.Install + Distribution.Client.InstallPlan + Distribution.Client.InstallSymlink + Distribution.Client.List + Distribution.Client.PackageIndex + Distribution.Client.PackageUtils + Distribution.Client.Setup + Distribution.Client.SetupWrapper + Distribution.Client.SrcDist + Distribution.Client.Tar + Distribution.Client.Types + Distribution.Client.Unpack + Distribution.Client.Update + Distribution.Client.Upload + Distribution.Client.Utils + Distribution.Client.Win32SelfUpgrade + Distribution.Compat.Exception + Paths_cabal_install + + build-depends: base >= 2 && < 5, + Cabal >= 1.8 && < 1.9, + filepath >= 1.0, + network >= 1 && < 3, + HTTP >= 4000.0.2 && < 4001, + zlib >= 0.4 && < 0.6, + time >= 1.1 && < 1.2 + + if flag(old-base) + build-depends: base < 3 + else + build-depends: base >= 3, + process >= 1 && < 1.1, + directory >= 1 && < 1.1, + pretty >= 1 && < 1.1, + random >= 1 && < 1.1, + containers >= 0.1 && < 0.4, + array >= 0.1 && < 0.4, + old-time >= 1 && < 1.1 + + if flag(bytestring-in-base) + build-depends: base >= 2.0 && < 2.2 + else + build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9 + + if os(windows) + build-depends: Win32 >= 2 && < 3 + cpp-options: -DWIN32 + else + build-depends: unix >= 1.0 && < 2.5 + extensions: CPP diff --git a/cabal2ebuild.hs b/cabal2ebuild.hs new file mode 100644 --- /dev/null +++ b/cabal2ebuild.hs @@ -0,0 +1,17 @@ +module Main where + +import System.Environment +import qualified Distribution.PackageDescription as Cabal +import Distribution.Verbosity (normal) +import Cabal2Ebuild + +main :: IO () +main = do + args <- getArgs + case args of + [cabalFileName] -> do + pkg <- Cabal.readPackageDescription normal cabalFileName + let ebuild = cabal2ebuild (Cabal.flattenPackageDescription pkg) + let ebuildFileName = name ebuild ++ "-" ++ version ebuild ++ ".ebuild" + writeFile ebuildFileName (showEBuild ebuild) + _ -> putStrLn "usage: cabal2ebuild package.cabal" diff --git a/hackport.cabal b/hackport.cabal --- a/hackport.cabal +++ b/hackport.cabal @@ -1,6 +1,7 @@ Name: hackport -Version: 0.2.1 +Version: 0.2.6 License: GPL +License-file: LICENSE Author: Henning Günther, Duncan Coutts, Lennart Kolmodin Maintainer: Gentoo Haskell team Category: Distribution @@ -8,57 +9,65 @@ Description: A command line tool to manage an overlay of Gentoo ebuilds that are generated from a hackage repo of Cabal packages. Build-Type: Simple -Cabal-Version: >=1.2 +Cabal-Version: >=1.8 +source-repository head + type: darcs + location: http://code.haskell.org/gentoo/hackport/ + Flag split-base Executable hackport Main-Is: Main.hs + Hs-Source-Dirs: ., cabal-install-0.8.2 Build-Depends: - base >= 2.0, + base >= 2.0 && < 5, filepath, parsec, mtl, network, + pretty, regex-compat, - Cabal >= 1.4 && < 1.5, - HTTP >= 3000 && < 3002, + Cabal == 1.8.*, + HTTP >= 4000.0.3, zlib, - tar + tar, + array, + -- array is inherited from cabal-install + -- tar >= 0.3.0.0 && < 0.4 + extensible-exceptions if flag(split-base) Build-Depends: - base >= 3, + base >= 3 && < 5, directory, containers, process, old-time, bytestring else - Build-Depends: base < 3 + Build-Depends: base < 3 ghc-options: -Wall other-modules: - Action AnsiColor - Bash BlingBling Cabal2Ebuild - Cache CacheFile - Config Diff Error - Fetch - GenerateEbuild - Index Main MaybeRead Overlays P2 - Package Portage + Portage.Version + Portage.Dependency + Portage.PackageId + Portage.Overlay + Portage.Resolve + Portage.Host Setup Status - Utils - Version + Merge + Util diff --git a/tests/resolveCat.hs b/tests/resolveCat.hs new file mode 100644 --- /dev/null +++ b/tests/resolveCat.hs @@ -0,0 +1,21 @@ +import Test.HUnit + +import qualified Portage.Overlay as Portage +import qualified Portage.Resolve as Portage +import qualified Portage.PackageId as Portage + +import qualified Distribution.Package as Cabal + +tests = TestList [ TestLabel "resolve cabal" (test_resolveCategory "dev-haskell" "cabal") + , TestLabel "resolve ghc" (test_resolveCategory "dev-lang" "ghc") + ] + +test_resolveCategory :: String -> String -> Test +test_resolveCategory cat pkg = TestCase $ do + portage <- Portage.loadLazy "/usr/portage" + let cabal = Cabal.PackageName pkg + hits = Portage.resolveFullPortageName portage cabal + expected = Just (Portage.PackageName (Portage.Category cat) cabal) + assertEqual ("expecting to find package " ++ pkg) hits expected + +main = runTestTT tests diff --git a/unused/Fetch.hs b/unused/Fetch.hs new file mode 100644 --- /dev/null +++ b/unused/Fetch.hs @@ -0,0 +1,78 @@ +-- module unused +module Fetch(downloadTarball,downloadFileVerify) where + +import Prelude hiding (catch) + +import Network.HTTP (ConnError(..),Request(..),simpleHTTP + ,Response(..),RequestMethod(..)) +import Network.URI (URI,uriPath,parseURI) +import Text.Regex (Regex,mkRegex,matchRegex) +import System.GPG +import Control.Monad.Error +import System.Directory +import System.FilePath +import Data.Typeable + +import Error +import Action + +filenameRegex :: Regex +filenameRegex = mkRegex "^.*?/([^/]*?)" + +uriToFileName :: URI -> Maybe FilePath +uriToFileName uri = maybe Nothing (\x->Just (head x)) (matchRegex filenameRegex (uriPath uri)) + +downloadURI :: FilePath -- ^ a directory to store the file + -> URI -- ^ the url + -> IO FilePath -- ^ the path of the downloaded file +downloadURI path uri = do + fileName <- maybe (throwEx $ InvalidTarballURL (show uri) "URL doesn't contain a filename") return (uriToFileName uri) + httpResult <- simpleHTTP request + Response {rspCode=code,rspBody=body,rspReason=reason} <- either (\x->throwError $ DownloadFailed (show uri) "Connection failed") return httpResult + if code==(2,0,0) then (do + let writePath=path fileName + writeFile writePath body + return writePath) else throwEx $ DownloadFailed (show uri) ("Code "++show code++":"++reason) + where + request = Request + {rqURI=uri + ,rqMethod=GET + ,rqHeaders=[] + ,rqBody=""} + + +downloadFileVerify :: + FilePath -> -- ^ the directory to store the files + String -> -- ^ the url of the tarball + String -> -- ^ the url of the signature + IO (FilePath,FilePath) -- ^ the tarballs and signatures path +downloadFileVerify path url sigurl = do + tarballPath <- downloadTarball path url + sigPath <- downloadSig path sigurl `catchEx` \e-> do + removeFile tarballPath + throwEx x + verified <- verifyFile stdOptions tarballPath sigPath + if verified then return (tarballPath,sigPath) else (do + removeFile tarballPath + removeFile sigPath + throwEx $ VerificationFailed url sigurl) + +downloadTarball :: + FilePath -> + String -> + IO FilePath +downloadTarball dir url = download dir url InvalidTarballURL + +downloadSig :: + FilePath -> + String -> + IO FilePath +downloadSig dir url = download dir url InvalidSignatureURL + +download :: FilePath -- ^ the folder to store the file in + -> String -- ^ the url + -> (String -> String -> HackPortError) -- ^ a function to construct an error + -> IO FilePath -- ^ the resulting file's path +download dir url errFunc = do + parsedURL <- maybe (throwEx $ errFunc url "Parsing failed") return (parseURI url) + downloadURI dir parsedURL