diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2012 Silk +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of Universiteit Utrecht nor the names of its 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bumper.cabal b/bumper.cabal new file mode 100644 --- /dev/null +++ b/bumper.cabal @@ -0,0 +1,41 @@ +Name: bumper +Version: 0.5 +Synopsis: Automatically bump package versions, also transitively. +Description: Automatically bump package versions, also transitively. +Author: Silk +Copyright: (c) 2012, Silk +Maintainer: code@silkapp.com +Homepage: http://github.com/silkapp/bumper +Category: Development +License: BSD3 +License-File: LICENSE +Cabal-Version: >= 1.6 +Build-Type: Simple + +Executable bumper + Build-Depends: base == 4.* + , Cabal >= 1.6 && < 1.15 + , ConfigFile >= 1.0 && < 1.2 + , HTTP >= 4000.0 && < 4000.3 + , bytestring == 0.9.* + , containers == 0.4.* + , directory >= 1.0 && < 1.2 + , fclabels >= 1.0 && < 1.2 + , filepath >= 1.1 && < 1.4 + , mtl >= 1.1 && < 2.2 + , network >= 2.2 && < 2.4 + , process >= 1.0 && < 1.2 + , random == 1.0.* + , regex-compat >= 0.93 && < 0.96 + , split == 0.1.* + , strict == 0.3.2 + GHC-Options: -Wall + HS-Source-Dirs: src + Main-is: Bumper.hs + Other-Modules: Config + Package + Version + +Source-Repository head + Type: git + Location: git://github.com/silkapp/bumper.git diff --git a/src/Bumper.hs b/src/Bumper.hs new file mode 100644 --- /dev/null +++ b/src/Bumper.hs @@ -0,0 +1,79 @@ +module Main where + +import Config +import Data.Label +import Data.List +import Data.Version +import Distribution.Package hiding (Package) +import Distribution.Text +import Distribution.Version +import Package +import Version +import qualified Data.Map as M +import qualified Paths_bumper as Paths + +main :: IO () +main = + do conf <- getConfig + case get action conf of + ShowHelp -> printUsage options + ShowVersion -> putStrLn $ "bumper, version " ++ showVersion Paths.version + ShowDeps -> run conf showDeps + Run -> run conf updateDeps + where + showDeps _ changed = putStr $ intercalate " " $ map display $ M.keys changed + updateDeps base changed = mapM_ (\p -> updatePackage p (makeUpdates p)) base + where + makeUpdates p = (M.lookup (get name p) changed, dependencyUpdates changed p) + +run :: Config -> (Packages -> Changes -> IO ()) -> IO () +run conf act = + do -- Load packages + ps <- packages + -- Retrieve base versions + base <- maybe (return ps) (flip getBaseVersions ps) $ get global conf + let changed = (if get transitive conf then trans base else id) + $ concatChanges (map (\(p,pks) -> bumpVersions p pks base) (M.toAscList (get bump conf))) + <.> userVersions (get setVersion conf) base + act base changed + +type Changes = M.Map PackageName Version + +-- Combine changes, not updating already changed packages +infixr 5 <.> +(<.>) :: Changes -> Changes -> Changes +(<.>) = M.unionWith (flip const) + +concatChanges :: [Changes] -> Changes +concatChanges = foldr (<.>) M.empty + +-- | Update versions +userVersions :: [(PackageName, Version)] -> Packages -> Changes +userVersions vs ps = M.fromList $ filter (\nv -> hasPackage (fst nv) ps) vs + +bumpVersions :: Int -> [PackageName] -> Packages -> Changes +bumpVersions pos ns ps = M.fromList $ map (\p -> (get name p, bumpPosition pos (get version p))) $ lookupPackages ns ps + +-- | Make transitive changes +trans :: Packages -> Changes -> Changes +trans ps = fix (transStep ps) + +transStep :: Packages -> Changes -> Changes +transStep ps old = new <.> old + where deps = filter (not . null . dependencyUpdates old) ps + new = M.fromList . map (\p -> (get name p, bumpPosition 2 (get version p))) $ deps + +fix :: (Eq a) => (a -> a) -> a -> a +fix f a | b == a = a + | otherwise = fix f b + where b = f a + +-- | Caclulate updated dependencies +dependencyUpdates :: Changes -> Package -> [Dependency] +dependencyUpdates ch = foldr addDep [] . get dependencies + where addDep (Dependency n r) dps = + case M.lookup n ch of + Just v -> if withinRange v r + then dps + else Dependency n (addVersionToRange v r) : dps + Nothing -> dps diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE + TypeOperators + , TemplateHaskell + #-} +module Config where + +import Data.Label +import Data.List.Split +import Data.Version +import Distribution.Package +import Distribution.Text +import System.Console.GetOpt +import System.Environment +import qualified Data.Map as M + +data Action = Run + | ShowDeps + | ShowHelp + | ShowVersion + deriving Show + +data Config = Config + { _bump :: M.Map Int [PackageName] -- Map of which packages to bump at which position + , _setVersion :: [(PackageName,Version)] + , _transitive :: Bool + , _ignore :: [PackageName] + , _global :: Maybe String + , _action :: Action + } deriving Show + +$(mkLabels [''Config]) + +defaultConfig :: Config +defaultConfig = Config + { _bump = M.empty + , _setVersion = [] + , _transitive = True + , _ignore = [] + , _global = Nothing + , _action = Run + } + +versionPar :: String -> [(PackageName, Version)] +versionPar = foldr addVer [] . splitOn "," + where addVer fld ac = + case splitOn "@" fld of + [p,v] -> case simpleParse v of + (Just ver) -> (PackageName p, ver) : ac + Nothing -> ac + _ -> ac + +options :: [OptDescr (Config -> Config)] +options = [ Option ['m'] ["major"] (ReqArg (addBumps 1) "PACKAGE(,PACKAGE)*") "Comma-separated list of packages which will get a major bump (bump at position 1)." + , Option ['n'] ["minor"] (ReqArg (addBumps 2) "PACKAGE(,PACKAGE)*") "Comma-separated list of packages which will get a minor bump (bump at position 2)." + , Option ['0'] ["bump-0"] (ReqArg (addBumps 0) "PACKAGE(,PACKAGE)*") "Comma-separated list of packages which will get a bump at position 0." + , Option ['1'] ["bump-1"] (ReqArg (addBumps 1) "PACKAGE(,PACKAGE)*") "Comma-separated list of packages which will get a bump at position 1." + , Option ['2'] ["bump-2"] (ReqArg (addBumps 2) "PACKAGE(,PACKAGE)*") "Comma-separated list of packages which will get a bump at position 2." + , Option ['3'] ["bump-3"] (ReqArg (addBumps 3) "PACKAGE(,PACKAGE)*") "Comma-separated list of packages which will get a bump at position 3." + , Option [] ["set-versions"] (ReqArg (\v -> modify setVersion (++ versionPar v)) "PACKAGE@VERSION(,PACKAGE@VERSION)*") "Comma-separated list of packages and their versions." + , Option ['t'] ["no-transitive"] (NoArg (set transitive False)) "Do not apply bumping transitively." + , Option ['i'] ["ignore"] (ReqArg (\v -> modify ignore (++ map PackageName (splitOn "," v))) "PACKAGE(,PACKAGE)*") "Comma-separated list of packages which will be ignored when transitive bumping." + , Option ['g'] ["global"] (ReqArg (\v -> set global (Just v)) "PATH") "Bump according to latest version number in the given package database." + , Option ['d'] ["dry-run"] (NoArg (set action ShowDeps)) "Just output the dependencies that will be updated." + , Option ['?'] ["help"] (NoArg (set action ShowHelp)) "Show usage help and exit." + , Option ['v'] ["version"] (NoArg (set action ShowVersion)) "Show version info and exit." + ] + where addBumps :: Int -> String -> Config -> Config + addBumps p pks = modify bump (M.insertWith (++) p (map PackageName $ splitOn "," pks)) + +getConfig :: IO Config +getConfig = + do args <- getArgs + (opts, _) <- processArgs defaultConfig options header args + return opts + +processArgs :: a -> [OptDescr (a -> a)] -> String -> [String] -> IO (a, [String]) +processArgs def opts hdr args = + case getOpt Permute opts args of + (oargs, nonopts, [] ) -> return (foldl (flip ($)) def oargs, nonopts) + (_ , _ , errors) -> ioError $ userError $ (concat errors) ++ usageInfo hdr opts + +header :: String +header = "Usage: bumper [OPTIONS...], with the following options:" + +printUsage :: [OptDescr a] -> IO () +printUsage opts = putStrLn $ usageInfo header opts diff --git a/src/Package.hs b/src/Package.hs new file mode 100644 --- /dev/null +++ b/src/Package.hs @@ -0,0 +1,108 @@ +-- * Contains helper functions to load and manipulate .cabal files +{-# LANGUAGE + TypeOperators + , TemplateHaskell + , TupleSections + #-} +module Package where + +import Prelude hiding (readFile) + +import Control.Applicative +import Control.Monad +import Data.Label +import Data.List +import Data.List.Split +import Data.Maybe +import Data.Version +import Distribution.Package hiding (Package) +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.Parse +import Distribution.Text +import Distribution.Verbosity +import System.IO.Strict +import System.Process +import Text.Regex +import Version +import qualified Data.Map as M + +data Package = Package + { _name :: PackageName + , _path :: String + , _version :: Version + , _dependencies :: [Dependency] + } deriving (Show, Eq) + +$(mkLabels [''Package]) + +type Packages = [Package] + +-- | Helper functions + +lookupPackage :: PackageName -> Packages -> Maybe Package +lookupPackage s = find ((== s) . _name) + +lookupPackages :: [PackageName] -> Packages -> Packages +lookupPackages ns ps = catMaybes . map (flip lookupPackage ps) $ ns + +hasPackage :: PackageName -> Packages -> Bool +hasPackage n = isJust . lookupPackage n + +removePackage :: PackageName -> Packages -> Packages +removePackage s = filter ((/= s). _name) + +removeAll :: [PackageName] -> Packages -> Packages +removeAll = flip $ foldr removePackage + +-- | Loading packages +packages :: IO Packages +packages = + do (_, hOut, _, _) <- runInteractiveCommand "find . -name *.cabal -type f" + paths <- lines <$> hGetContents hOut + forM paths $ \p -> + do pkg <- flattenPackageDescription `liftM` readPackageDescription normal p + return $ Package + { _name = pkgName $ package pkg + , _path = p + , _version = pkgVersion $ package pkg + , _dependencies = buildDepends pkg + } + +getBaseVersions :: String -> Packages -> IO Packages +getBaseVersions ind ps = + do (_, hOut, _, _) <- runInteractiveCommand $ "tar -tf " ++ ind + gps <- lines <$> hGetContents hOut + let vs = catMaybes $ map (parseVer . splitOn "/") gps + parseVer (n:v:_) = fmap (PackageName n, ) $ simpleParse v + parseVer _ = Nothing + globver = M.fromListWith (\a b -> if a > b then a else b) vs + updVer p = modify version (maybe id (\v -> if get version p < v then const v else id) $ M.lookup (_name p) globver) p + return $ map updVer ps + +-- | Manipulating package contents +whiteReg :: String +whiteReg = "[ \n\t]*" + +modifyVersion :: Version -> String -> String +modifyVersion v s = subRegex (mkRegexWithOpts regex False False) s result + where regex = "(version" ++ whiteReg ++ ":" ++ whiteReg ++ ") ([0-9.a-zA-Z]+)" + result = "\\1 " ++ display v + +modifyDependency :: Dependency -> String -> String +modifyDependency (Dependency nm range) s = subRegex (mkRegexWithOpts regex False False) s result + where regex = "(build-depends" ++ whiteReg ++ ":" ++ "[^:]*" + ++ "[ ,\n\t]" ++ display nm ++ whiteReg ++ ")[, ]([" ++ rangeChar ++ " \t\n]*[" ++ rangeChar ++ "])" + rangeChar = "0-9.*&|()<>=" + result = "\\1 " ++ printRange range + +-- | Data structure containing package modifications +type PackageChanges = (Maybe Version, [Dependency]) + +-- | Writing to packages +modifyPackage :: PackageChanges -> String -> String +modifyPackage (mv, deps) = flip (foldr modifyDependency) deps + . maybe id modifyVersion mv + +updatePackage :: Package -> PackageChanges -> IO () +updatePackage p ch = readFile (get path p) >>= writeFile (get path p) . modifyPackage ch diff --git a/src/Version.hs b/src/Version.hs new file mode 100644 --- /dev/null +++ b/src/Version.hs @@ -0,0 +1,70 @@ +-- * Manipulation functions for cabal versions and version ranges +{-# LANGUAGE + TypeOperators + , TemplateHaskell + #-} +module Version where + +import Data.Label +import Distribution.Text +import Distribution.Version + +$(mkLabels [''Version]) +$(mkLabels [''VersionRange]) + +-- | Function to bump the nth position in a version to a higher number +-- trailing version number will be discarded +bumpPosition :: Int -> Version -> Version +bumpPosition p = modify lVersionBranch (addPos p) + where + addPos 0 [] = [1] + addPos 0 (v: _) = [v+1] + addPos x [] = 0 : addPos (x - 1) [] + addPos x (v: vs) = v : addPos (x - 1) vs + +previousVersion :: Version -> Version +previousVersion = modify lVersionBranch mkPrevious + where mkPrevious = reverse . prevHelp . reverse + prevHelp [] = [] + prevHelp (x:xs) = if x <= 1 then xs else (x - 1): xs -- No trailing zeros + +nextVersion :: Version -> Version +nextVersion = modify lVersionBranch mkNext + where mkNext = reverse . nextHelp . reverse + nextHelp [] = [] + nextHelp (x:xs) = (x + 1) : xs + +addVersionToRange :: Version -> VersionRange -> VersionRange +addVersionToRange new r = + if withinRange new r + then r + else + let cVersion = const (thisVersion new) + c2Version = const $ const (thisVersion new) + in foldVersionRange' + anyVersion -- any + cVersion -- (==) + cVersion -- > + cVersion -- < + cVersion -- >= + cVersion -- <= + (\v _ -> withinVersion $ v { versionBranch = take (length $ versionBranch v) $ versionBranch new }) -- .* + c2Version -- (||) + c2Version -- (&&) + id -- (_) + r + +printRange :: VersionRange -> String +printRange = + let sShow s = ((s ++ " ") ++) . display + in foldVersionRange' + "*" + (sShow "==") + (sShow ">") + (sShow "<") + (sShow ">=") + (sShow "<=") + (\v _ -> "== " ++ display v ++ ".*") + (\v1 v2 -> v1 ++ " || " ++ v2) + (\v1 v2 -> v1 ++ " && " ++ v2) + (\v -> "(" ++ v ++ ")")