diff --git a/cblrepo.cabal b/cblrepo.cabal --- a/cblrepo.cabal +++ b/cblrepo.cabal @@ -1,5 +1,5 @@ name: cblrepo -version: 0.2.3 +version: 0.3.0 cabal-version: >= 1.6 license: OtherLicense license-file: LICENSE-2.0 @@ -26,8 +26,9 @@ executable cblrepo hs-source-dirs: src main-is: Main.hs - other-modules: Util.Misc PkgDB AddBase AddCabal BumpPkgs BuildPkgs IdxSync + other-modules: Util.Misc PkgDB Add BumpPkgs BuildPkgs IdxSync IdxVersion Updates ListPkgs Urls PkgBuild Util.Translation + OldPkgDB ConvertDB build-depends: base ==4.3.*, cmdargs ==0.7.*, filepath ==1.2.*, directory ==1.1.*, Cabal ==1.10.*, json ==0.4.*, bytestring ==0.9.*, tar ==0.3.*, zlib ==0.5.*, mtl ==2.0.*, @@ -39,8 +40,8 @@ main-is: tst.hs other-modules: TestSystem TestPkgDB if flag(BuildTests) - build-depends: base ==4.3.*, test-framework-th ==0.1.*, HUnit ==1.2.*, - test-framework-hunit ==0.2.*, test-framework ==0.3.* + build-depends: base ==4.3.*, test-framework-th ==0.2.*, HUnit ==1.2.*, + test-framework-hunit ==0.2.*, test-framework ==0.4.* else buildable: False diff --git a/src/Add.hs b/src/Add.hs new file mode 100644 --- /dev/null +++ b/src/Add.hs @@ -0,0 +1,157 @@ +{- + - Copyright 2011 Per Magnus Therning + - + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + - + - http://www.apache.org/licenses/LICENSE-2.0 + - + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Add where + +import Debug.Trace + +-- {{{1 imports +-- {{{2 local +import PkgDB +import Util.Misc + +-- {{{2 system +import Codec.Archive.Tar as Tar +import Codec.Compression.GZip as GZip +import Control.Monad +import Control.Monad.Error +import Control.Monad.Reader +import Data.List +import Data.Maybe +import Data.Version +import Distribution.Compiler +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.Parse +import Distribution.System +import Distribution.Text +import Distribution.Verbosity +import Distribution.Version +import System.Directory +import System.FilePath +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Distribution.Package as P +import System.Posix.Files +import System.Unix.Directory +import System.Process +import System.Exit +import System.IO + +-- {{{1 add +add :: ReaderT Cmds IO () +add = do + t <- cfgGet pkgType + case t of + GhcPkgT -> addGhc + DistroPkgT -> addDistro + RepoPkgT -> addRepo + +-- {{{2 Add ghc package +addGhc :: ReaderT Cmds IO () +addGhc = let + unpackPkgVer s = (p, v) + where + (p, _:v) = span (/= ',') s + in do + pkgs <- liftM (map unpackPkgVer) (cfgGet cbls) + dR <- cfgGet dryRun + guard $ isJust $ (sequence $ map (simpleParse . snd) pkgs :: Maybe [Version]) + let ps = map (\ (n, v) -> (n, fromJust $ (simpleParse v :: Maybe Version))) pkgs + dbFn <- cfgGet dbFile + db <- liftIO $ readDb dbFn + case doAddGhc db ps of + Left brkOthrs -> liftIO $ mapM_ printBrksOth brkOthrs + Right newDb -> liftIO $ unless dR $ saveDb newDb dbFn + +doAddGhc db pkgs = let + canBeAdded db n v = null $ checkDependants db n v + (_, fails) = partition (\ (n, v) -> canBeAdded db n v) pkgs + newDb = foldl (\ d (n, v) -> addGhcPkg d n v) db pkgs + brkOthrs = map (\ (n, v) -> ((n, v), checkDependants db n v)) fails + in if null fails + then Right newDb + else Left brkOthrs + +-- {{{2 Add distro package +addDistro :: ReaderT Cmds IO () +addDistro = let + unpackPkgVer s = (p, v, r) + where + (p, _:s2) = span (/= ',') s + (v, _:r) = span (/= ',') s2 + getVersion (_, v, _) = simpleParse v :: Maybe Version + in do + pkgs <- liftM (map unpackPkgVer) (cfgGet cbls) + dR <- cfgGet dryRun + guard $ isJust $ sequence $ map getVersion pkgs + let ps = map (\ p@(n, v, r) -> (n, fromJust $ getVersion p, r)) pkgs + dbFn <- cfgGet dbFile + db <- liftIO $ readDb dbFn + case doAddDistro db ps of + Left brkOthrs -> liftIO $ mapM_ printBrksOth brkOthrs + Right newDb -> liftIO $ unless dR $ saveDb newDb dbFn + +doAddDistro db pkgs = let + canBeAdded db n v = null $ checkDependants db n v + (_, fails) = partition (\ (n, v, _) -> canBeAdded db n v) pkgs + newDb = foldl (\ d (n, v, r) -> addDistroPkg d n v r) db pkgs + brkOthrs = map (\ (n, v, _) -> ((n, v), checkDependants db n v)) fails + in if null fails + then Right newDb + else Left brkOthrs + +-- {{{2 Add repo package +addRepo :: ReaderT Cmds IO () +addRepo = do + dbFn <- cfgGet dbFile + db <- liftIO $ readDb dbFn + pD <- cfgGet patchDir + cbls <- cfgGet cbls + dR <- cfgGet dryRun + genPkgs <- liftIO $ mapM (\ c -> withTemporaryDirectory "/tmp/cblrepo." (readCabal pD c)) cbls + let pkgNames = map ((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) genPkgs + liftIO $ when (or . catMaybes $ map (liftM isBasePkg . lookupPkg db) pkgNames) (putStrLn "Trying to add a base pkg!!" >> exitFailure) + let tmpDb = filter (\ p -> not $ pkgName p `elem` pkgNames) db + case doAddRepo tmpDb genPkgs of + Left (unSats, brksOthrs) -> liftIO (mapM_ printUnSat unSats >> mapM_ printBrksOth brksOthrs) + Right newDb -> liftIO $ unless dR $ saveDb newDb dbFn + +doAddRepo db pkgs = let + (succs, fails) = partition (canBeAdded db) pkgs + newDb = foldl addPkg2 db (map (fromJust . finalizeToCblPkg db) succs) + unSats = catMaybes $ map (finalizeToDeps db) fails + genPkgName = ((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) + genPkgVer = P.pkgVersion . package . packageDescription + brksOthrs = filter (not . null . snd) $ map (\ p -> ((genPkgName p, genPkgVer p), checkDependants db (genPkgName p) (genPkgVer p))) fails + in case (succs, fails) of + (_, []) -> Right newDb + ([], _) -> Left (unSats, brksOthrs) + (_, _) -> doAddRepo newDb fails + +canBeAdded db p = let + finable = either (const False) (const True) (finalizePkg db p) + n = ((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) p + v = P.pkgVersion $ package $ packageDescription p + depsOK = null $ checkDependants db n v + in finable && depsOK + +finalizeToCblPkg db p = case finalizePkg db p of + Right (pd, _) -> Just $ createCblPkg pd + _ -> Nothing + +finalizeToDeps db p = case finalizePkg db p of + Left ds -> Just $ (((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) p, ds) + _ -> Nothing diff --git a/src/AddBase.hs b/src/AddBase.hs deleted file mode 100644 --- a/src/AddBase.hs +++ /dev/null @@ -1,50 +0,0 @@ -{- - - Copyright 2011 Per Magnus Therning - - - - Licensed under the Apache License, Version 2.0 (the "License"); - - you may not use this file except in compliance with the License. - - You may obtain a copy of the License at - - - - http://www.apache.org/licenses/LICENSE-2.0 - - - - Unless required by applicable law or agreed to in writing, software - - distributed under the License is distributed on an "AS IS" BASIS, - - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - - See the License for the specific language governing permissions and - - limitations under the License. - -} - -module AddBase where - -import PkgDB -import Util.Misc - -import Control.Monad -import Control.Monad.Reader -import Data.List -import Data.Maybe -import Distribution.Text -import Distribution.Version -import System.FilePath - -addBase :: ReaderT Cmds IO () -addBase = do - pkgs <- cfgGet pkgVers - dR <- cfgGet dryRun - guard $ isJust $ (sequence $ map (simpleParse . snd) pkgs :: Maybe [Version]) - let ps = map (\ (n, v) -> (n, fromJust $ simpleParse v)) pkgs - dbFn <- cfgGet dbFile - db <- liftIO $ readDb dbFn - case doAddBase db ps of - Left brkOthrs -> liftIO $ mapM_ printBrksOth brkOthrs - Right newDb -> liftIO $ unless dR $ saveDb newDb dbFn - -doAddBase db pkgs = let - (_, fails) = partition (\ (n, v) -> canBeAdded db n v) pkgs - newDb = foldl (\ d (n, v) -> addBasePkg d n v) db pkgs - brkOthrs = map (\ (n, v) -> ((n, v), checkDependants db n v)) fails - in if null fails - then Right newDb - else Left brkOthrs - -canBeAdded db n v = null $ checkDependants db n v diff --git a/src/AddCabal.hs b/src/AddCabal.hs deleted file mode 100644 --- a/src/AddCabal.hs +++ /dev/null @@ -1,87 +0,0 @@ -{- - - Copyright 2011 Per Magnus Therning - - - - Licensed under the Apache License, Version 2.0 (the "License"); - - you may not use this file except in compliance with the License. - - You may obtain a copy of the License at - - - - http://www.apache.org/licenses/LICENSE-2.0 - - - - Unless required by applicable law or agreed to in writing, software - - distributed under the License is distributed on an "AS IS" BASIS, - - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - - See the License for the specific language governing permissions and - - limitations under the License. - -} - -module AddCabal where - -import PkgDB -import Util.Misc - -import Codec.Archive.Tar as Tar -import Codec.Compression.GZip as GZip -import Control.Monad -import Control.Monad.Error -import Control.Monad.Reader -import Data.List -import Data.Maybe -import Data.Version -import Distribution.Compiler -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration -import Distribution.PackageDescription.Parse -import Distribution.System -import Distribution.Text -import Distribution.Verbosity -import Distribution.Version -import System.Directory -import System.FilePath -import qualified Data.ByteString.Lazy.Char8 as BS -import qualified Distribution.Package as P -import System.Posix.Files -import System.Unix.Directory -import System.Process -import System.Exit -import System.IO - -addCabal :: ReaderT Cmds IO () -addCabal = do - dbFn <- cfgGet dbFile - db <- liftIO $ readDb dbFn - pD <- cfgGet patchDir - cbls <- cfgGet cbls - dR <- cfgGet dryRun - genPkgs <- liftIO $ mapM (\ c -> withTemporaryDirectory "/tmp/cblrepo." (readCabal pD c)) cbls - let pkgNames = map ((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) genPkgs - let tmpDb = filter (\ p -> not $ pkgName p `elem` pkgNames) db - case doAddCabal tmpDb genPkgs of - Left (unSats, brksOthrs) -> liftIO (mapM_ printUnSat unSats >> mapM_ printBrksOth brksOthrs) - Right newDb -> liftIO $ unless dR $ saveDb newDb dbFn - -doAddCabal db pkgs = let - (succs, fails) = partition (canBeAdded db) pkgs - newDb = foldl addPkg2 db (map (fromJust . finalizeToCblPkg db) succs) - unSats = catMaybes $ map (finalizeToDeps db) fails - genPkgName = ((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) - genPkgVer = P.pkgVersion . package . packageDescription - brksOthrs = filter (not . null . snd) $ map (\ p -> ((genPkgName p, genPkgVer p), checkDependants db (genPkgName p) (genPkgVer p))) fails - in case (succs, fails) of - (_, []) -> Right newDb - ([], _) -> Left (unSats, brksOthrs) - (_, _) -> doAddCabal newDb fails - -canBeAdded db p = let - finable = either (const False) (const True) (finalizePkg db p) - n = ((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) p - v = P.pkgVersion $ package $ packageDescription p - depsOK = null $ checkDependants db n v - in finable && depsOK - -finalizeToCblPkg db p = case finalizePkg db p of - Right (pd, _) -> Just $ createCblPkg pd - _ -> Nothing - -finalizeToDeps db p = case finalizePkg db p of - Left ds -> Just $ (((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) p, ds) - _ -> Nothing diff --git a/src/ConvertDB.hs b/src/ConvertDB.hs new file mode 100644 --- /dev/null +++ b/src/ConvertDB.hs @@ -0,0 +1,58 @@ +{- + - Copyright 2011 Per Magnus Therning + - + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + - + - http://www.apache.org/licenses/LICENSE-2.0 + - + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module ConvertDB where + +-- {{{1 imports +-- {{{2 local +import Util.Misc +import qualified OldPkgDB as ODB +import qualified PkgDB as NDB + +-- {{{2 system +import Control.Monad.Reader +import Data.Version +import System.IO + +convertDb :: ReaderT Cmds IO () +convertDb = do + inDb <- cfgGet inDbFile >>= \ fn -> liftIO $ ODB.readDb fn + outDbFn <- cfgGet outDbFile + newDb <- liftIO $ mapM doConvert inDb + liftIO $ NDB.saveDb newDb outDbFn + +doConvert :: ODB.CblPkg -> IO NDB.CblPkg +doConvert opkg@(n, (v, d, r)) + | ODB.isBasePkg opkg = let + withNoStdBuffering f = do + old <- hGetBuffering stdin + hSetBuffering stdin NoBuffering + result <- f + hSetBuffering stdin old + return result + getValidChar = do + putStr " (g)hc or (d)istro? " >> hFlush stdout + getChar >>= (\ c -> putStrLn "" >> return c) >>= (\ c -> if c `elem` "gd" then return c else getValidChar) + createPkg c + | c == 'g' = return $ NDB.createGhcPkg n v + | c == 'd' = do + putStr " release? " >> hFlush stdout + rel <- getLine + return $ NDB.createDistroPkg n v rel + in do + putStr n + withNoStdBuffering $ getValidChar >>= createPkg + | otherwise = return $ NDB.createRepoPkg n v d (show r) diff --git a/src/ListPkgs.hs b/src/ListPkgs.hs --- a/src/ListPkgs.hs +++ b/src/ListPkgs.hs @@ -34,5 +34,6 @@ else db liftIO $ mapM_ printCblPkgShort pkgs -printCblPkgShort (p, (v, _, r)) = - putStrLn $ p ++ " ==" ++ (display v) ++ " (" ++ (show r) ++")" +-- printCblPkgShort (p, (v, _, r)) = +printCblPkgShort p = + putStrLn $ pkgName p ++ " " ++ (display $ pkgVersion p) ++ "-" ++ pkgRelease p diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -16,8 +16,7 @@ module Main where -import AddBase -import AddCabal +import Add import BuildPkgs import BumpPkgs import IdxSync @@ -27,6 +26,7 @@ import Util.Misc import Urls import PkgBuild +import ConvertDB import Paths_cblrepo @@ -42,23 +42,22 @@ argDbFile = dbFile := "cblrepo.db" += explicit += name "db" += help "package database" += typFile argDryRun = dryRun := False += explicit += name "n" += help "dry run" -cmdAddBasePkg = record defAddBasePkg - [ argAppDir, argDbFile, argDryRun - , pkgVers := def += args += typ "STRING,STRING" - ] += name "addbasepkg" += help "add base packages" += details - [ "The format for a package is ,." ] - -cmdAddPkg = record defAddPkg +cmdAddPkg = record defCmdAdd [ argAppDir, argDbFile , patchDir := "patches" += explicit += name "patchdir" += help "location of patches" += typDir , argDryRun - , cbls := def += args += typ "CABAL" + , pkgType := RepoPkgT += explicit += name "t" += name "type" += typ "TYPE" += help "type of package ((g)hcpkg, (d)istropkg, or (r)epopkg, default: r)" + --, isBase := False += explicit += name "b" += name "base" += help "add a base package" + , cbls := def += args += typ "PKGVERSPEC" ] += name "add" += help "add a package from a Cabal file" += details - [ "There are three ways to specify the location of the Cabal file:" - , " 1. The filename of the Cabal file." - , " 2. A URL where the Cabal can be found (for file:// URLs the full absolute path is required)." - , " 3. A pair, ,, will load the Cabal file out of an index file (see idxupdate)" - , "All three format may be mixed on the command line." + [ "The package version depends on the type of the package that's added:" + , " 1. For a ghc package specify the name and version, e.g. 'base,4.3'" + , " 2. For a distro package specify the name, version, and release, e.g. 'HUnit,1.2.2.3,2.1" + , " 3. For a repo package provide a Cabal file by either" + , " - provide the filename of the Cabal file" + , " - specify the URL where the Cabal file can be found (for file:// URLs the full absolute path is required" + , " - specify the name and version to load the Cabal file out of an index file (see idxupdate)" + , " All three format may be mixed on the command line." ] cmdBumpPkgs = record defBumpPkgs @@ -99,9 +98,14 @@ , pkgs := def += args += typ "PKG" ] += help "create a PKGBUILD, and other files necessary for an Arch package" +cmdConvertDb = record defConvertDb + [ argAppDir + , inDbFile := "cblrepo.db" += explicit += name "i" += name "indb" += typFile += help "old database" + , outDbFile := "new-cblrepo.db" += explicit += name "o" += name "outdb" += typFile += help "new database" + ] += help "convert an old database to the new format" + cmds = cmdArgsMode_ $ modes_ - [ cmdAddBasePkg - , cmdAddPkg + [ cmdAddPkg , cmdBuildPkgs , cmdBumpPkgs , cmdIdxSync @@ -110,6 +114,7 @@ , cmdUpdates , cmdUrls , cmdPkgBuild + , cmdConvertDb ] += program progName += summary (progName ++ " v" ++ (display version)) @@ -123,8 +128,7 @@ let c' = c { appDir = aD } createDirectoryIfMissing True (aD) case c' of - AddBasePkg {} -> runReaderT addBase c' - AddPkg {} -> runReaderT addCabal c' + CmdAdd {} -> runReaderT add c' BuildPkgs {} -> runReaderT buildPkgs c' BumpPkgs {} -> runReaderT bumpPkgs c' IdxSync {} -> runReaderT idxSync c' @@ -133,3 +137,4 @@ Updates {} -> runReaderT updates c' Urls {} -> runReaderT urls c' PkgBuild {} -> runReaderT pkgBuild c' + ConvertDb {} -> runReaderT convertDb c' diff --git a/src/OldPkgDB.hs b/src/OldPkgDB.hs new file mode 100644 --- /dev/null +++ b/src/OldPkgDB.hs @@ -0,0 +1,125 @@ +{- + - Copyright 2011 Per Magnus Therning + - + - Licensed under the Apache License, Version 2.0 (the "License"); + - you may not use this file except in compliance with the License. + - You may obtain a copy of the License at + - + - http://www.apache.org/licenses/LICENSE-2.0 + - + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module OldPkgDB where + +import Util.Misc + +import Control.Applicative +import Control.Exception as CE +import Data.List +import Data.Maybe +import Data.Maybe +import Distribution.PackageDescription +import Distribution.Text +import Distribution.Version +import System.IO.Error +import Text.JSON +import qualified Distribution.Package as P +import qualified Distribution.Version as V + +type CblPkg = (String, (V.Version, [P.Dependency], Int)) +type CblDB = [CblPkg] + +pkgName :: CblPkg -> String +pkgName (n, _) = n + +pkgVersion :: CblPkg -> V.Version +pkgVersion (_, (v, _, _)) = v + +pkgDeps :: CblPkg -> [P.Dependency] +pkgDeps (_, (_, ds, _)) = ds + +pkgRelease :: CblPkg -> Int +pkgRelease (_, (_, _, i)) = i + +createCblPkg :: PackageDescription -> CblPkg +createCblPkg pd = (name, (version, deps, 1)) + where + name = (\ (P.PackageName n) -> n) (P.pkgName $ package pd) + version = P.pkgVersion $ package pd + deps = buildDepends pd + +getDependencyOn :: String -> CblPkg -> Maybe P.Dependency +getDependencyOn n p = find (\ d -> depName d == n) (pkgDeps p) + +isBasePkg :: CblPkg -> Bool +isBasePkg (_, (_, ds, _)) = null ds + +emptyPkgDB :: CblDB +emptyPkgDB = [] + +addPkg :: CblDB -> String -> V.Version -> [P.Dependency] -> Int -> CblDB +addPkg db n v ds r = nubBy cmp newdb + where + cmp (n1, _) (n2, _) = n1 == n2 + newdb = (n, (v, ds, r)) : db + +addPkg2 db (n, (v, ds, r)) = addPkg db n v ds r + +addBasePkg db n v = addPkg db n v [] 0 + +delPkg :: CblDB -> String -> CblDB +delPkg db n = filter (\ p -> n /= pkgName p) db + +lookupPkg :: CblDB -> String -> Maybe CblPkg +lookupPkg db n = maybe Nothing (\ s -> Just (n, s)) (lookup n db) + +lookupDependencies :: CblDB -> String -> Maybe [String] +lookupDependencies db n = + case lookupPkg db n of + Nothing -> Nothing + Just p -> let + ds = pkgDeps p + in Just $ map depName ds + +lookupDependants :: CblDB -> String -> [String] +lookupDependants db n = map pkgName $ filter (\ p -> doesDependOn p n) db + where + doesDependOn p n = n `elem` (map depName $ pkgDeps p) + +checkDependants db n v = let + d1 = catMaybes $ map (lookupPkg db) (lookupDependants db n) + d2 = map (\ p -> (pkgName p, getDependencyOn n p)) d1 + fails = filter (not . withinRange v . depVersionRange . fromJust . snd) d2 + in fails + +transitiveDependants db pkgs = keepLast $ concat $ map transUsersOfOne pkgs + where + transUsersOfOne pkg = pkg : (keepLast $ concat $ map (transUsersOfOne) (lookupDependants db pkg)) + keepLast = reverse . nub . reverse + +lookupRelease :: CblDB -> String -> Maybe Int +lookupRelease db n = lookupPkg db n >>= return . pkgRelease + +bumpRelease db n = let + bump (n', (v', d', r')) = (n', (v', d', r' + 1)) + in maybe db (addPkg2 db . bump) (lookupPkg db n) +readDb :: FilePath -> IO CblDB +readDb fp = (flip CE.catch) + (\ e -> if isDoesNotExistError e + then return emptyPkgDB + else throwIO e) + $ do + r <- readFile fp >>= return . sequence . map decode . lines + case r of + Ok a -> return a + Error s -> fail s + +saveDb :: CblDB -> FilePath -> IO () +saveDb db fp = writeFile fp s + where + s = unlines $ map (encode . showJSON) db diff --git a/src/PkgDB.hs b/src/PkgDB.hs --- a/src/PkgDB.hs +++ b/src/PkgDB.hs @@ -16,96 +16,127 @@ module PkgDB where -import Util.Misc - +-- {{{1 imports import Control.Exception as CE +import Control.Monad +import Data.Data import Data.List import Data.Maybe -import Data.Maybe +import Data.Typeable import Distribution.PackageDescription import Distribution.Text -import Distribution.Version import System.IO.Error import Text.JSON import qualified Distribution.Package as P import qualified Distribution.Version as V -type CblPkg = (String, (V.Version, [P.Dependency], Int)) +-- {{{ temporary +_depName (P.Dependency (P.PackageName n) _) = n +_depVersionRange (P.Dependency _ vr) = vr + +-- {{{1 types +data Pkg + = GhcPkg { version :: V.Version } + | DistroPkg { version :: V.Version, release :: String } + | RepoPkg { version :: V.Version, deps :: [P.Dependency], release :: String } + deriving (Eq, Show) + +type CblPkg = (String, Pkg) type CblDB = [CblPkg] +-- {{{1 packages pkgName :: CblPkg -> String pkgName (n, _) = n pkgVersion :: CblPkg -> V.Version -pkgVersion (_, (v, _, _)) = v +pkgVersion (_, p) = version p pkgDeps :: CblPkg -> [P.Dependency] -pkgDeps (_, (_, ds, _)) = ds +pkgDeps (_, RepoPkg { deps = d}) = d +pkgDeps _ = [] -pkgRelease :: CblPkg -> Int -pkgRelease (_, (_, _, i)) = i +pkgRelease :: CblPkg -> String +pkgRelease (_, GhcPkg {}) = "xx" +pkgRelease (_, DistroPkg { release = r }) = r +pkgRelease (_, RepoPkg { release = r }) = r +createGhcPkg n v = (n, GhcPkg v) +createDistroPkg n v r = (n, DistroPkg v r) +createRepoPkg n v d r = (n, RepoPkg v d r) + createCblPkg :: PackageDescription -> CblPkg -createCblPkg pd = (name, (version, deps, 1)) +createCblPkg pd = createRepoPkg name version deps "1" where name = (\ (P.PackageName n) -> n) (P.pkgName $ package pd) version = P.pkgVersion $ package pd deps = buildDepends pd getDependencyOn :: String -> CblPkg -> Maybe P.Dependency -getDependencyOn n p = find (\ d -> depName d == n) (pkgDeps p) +getDependencyOn n p = find (\ d -> _depName d == n) (pkgDeps p) -isBasePkg (_, (_, ds, _)) = null ds +isGhcPkg (_, GhcPkg {}) = True +isGhcPkg _ = False +isDistroPkg (_, DistroPkg {}) = True +isDistroPkg _ = False + +isRepoPkg (_, RepoPkg {}) = True +isRepoPkg _ = False + +isBasePkg :: CblPkg -> Bool +isBasePkg = not . isRepoPkg + +-- {{{1 database emptyPkgDB :: CblDB emptyPkgDB = [] -addPkg :: CblDB -> String -> V.Version -> [P.Dependency] -> Int -> CblDB -addPkg db n v ds r = nubBy cmp newdb +addPkg :: CblDB -> String -> Pkg -> CblDB +addPkg db n p = nubBy cmp newdb where cmp (n1, _) (n2, _) = n1 == n2 - newdb = (n, (v, ds, r)) : db + newdb = (n, p):db -addPkg2 db (n, (v, ds, r)) = addPkg db n v ds r +addPkg2 :: CblDB -> CblPkg -> CblDB +addPkg2 db (n, p) = addPkg db n p -addBasePkg db n v = addPkg db n v [] 0 +addGhcPkg :: CblDB -> String -> V.Version -> CblDB +addGhcPkg db n v = addPkg2 db (createGhcPkg n v) +addDistroPkg :: CblDB -> String -> V.Version -> String -> CblDB +addDistroPkg db n v r = addPkg2 db (createDistroPkg n v r) + delPkg :: CblDB -> String -> CblDB delPkg db n = filter (\ p -> n /= pkgName p) db -lookupPkg :: CblDB -> String -> Maybe CblPkg -lookupPkg db n = maybe Nothing (\ s -> Just (n, s)) (lookup n db) +bumpRelease :: CblDB -> String -> CblDB +bumpRelease db n = let + doBump (n', p@RepoPkg { release = r }) = (n', p { release = nr }) + where + nr = show $ (read r) + 1 + doBump p = p + in maybe db (addPkg2 db . doBump) (lookupPkg db n) -lookupDependencies :: CblDB -> String -> Maybe [String] -lookupDependencies db n = - case lookupPkg db n of - Nothing -> Nothing - Just p -> let - ds = pkgDeps p - in Just $ map depName ds +lookupPkg :: CblDB -> String -> Maybe CblPkg +lookupPkg db n = maybe Nothing (\ p -> Just (n, p)) (lookup n db) -lookupDependants :: CblDB -> String -> [String] lookupDependants db n = map pkgName $ filter (\ p -> doesDependOn p n) db where - doesDependOn p n = n `elem` (map depName $ pkgDeps p) + doesDependOn p n = n `elem` (map _depName $ pkgDeps p) +transitiveDependants :: CblDB -> [String] -> [String] +transitiveDependants db names = keepLast $ concat $ map transUsersOfOne names + where + transUsersOfOne n = n : transitiveDependants db (lookupDependants db n) + keepLast = reverse . nub . reverse + +-- Todo: test +checkDependants :: CblDB -> String -> V.Version -> [(String, Maybe P.Dependency)] checkDependants db n v = let d1 = catMaybes $ map (lookupPkg db) (lookupDependants db n) d2 = map (\ p -> (pkgName p, getDependencyOn n p)) d1 - fails = filter (not . withinRange v . depVersionRange . fromJust . snd) d2 + fails = filter (not . V.withinRange v . _depVersionRange . fromJust . snd) d2 in fails -transitiveDependants db pkgs = keepLast $ concat $ map transUsersOfOne pkgs - where - transUsersOfOne pkg = pkg : (keepLast $ concat $ map (transUsersOfOne) (lookupDependants db pkg)) - keepLast = reverse . nub . reverse - -lookupRelease :: CblDB -> String -> Maybe Int -lookupRelease db n = lookupPkg db n >>= return . pkgRelease - -bumpRelease db n = let - bump (n', (v', d', r')) = (n', (v', d', r' + 1)) - in maybe db (addPkg2 db . bump) (lookupPkg db n) readDb :: FilePath -> IO CblDB readDb fp = (flip CE.catch) (\ e -> if isDoesNotExistError e @@ -120,26 +151,46 @@ saveDb :: CblDB -> FilePath -> IO () saveDb db fp = writeFile fp s where - s = unlines $ map (encode . showJSON) db + s = unlines $ map encode db +-- {{{1 JSON instances instance JSON V.Version where showJSON v = makeObj [ ("Version", showJSON $ display v) ] - readJSON (JSObject o) = let - jAssoc = fromJSObject o - resultToMaybe (Ok a) = Just a - resultToMaybe _ = Nothing - version = lookup "Version" jAssoc >>= resultToMaybe . readJSON >>= simpleParse - in - maybe (fail "Not a version object") return version - readJSON _ = fail "Not a version object" + readJSON object = do + obj <- readJSON object + version <- valFromObj "Version" obj + maybe (fail "Not a Version object") return (simpleParse version) + instance JSON P.Dependency where showJSON d = makeObj [ ("Dependency", showJSON $ display d) ] - readJSON (JSObject o) = let - jAssoc = fromJSObject o - resultToMaybe (Ok a) = Just a - resultToMaybe _ = Nothing - dependency = lookup "Dependency" jAssoc >>= resultToMaybe . readJSON >>= simpleParse - in - maybe (fail "Not a dependency object") return dependency - readJSON _ = fail "Not a version object" + + readJSON object = do + obj <- readJSON object + dep <- valFromObj "Dependency" obj + maybe (fail "Not a Dependency object") return (simpleParse dep) + +instance JSON Pkg where + showJSON p@(GhcPkg { version = v}) = makeObj [("GhcPkg", showJSON v)] + showJSON p@(DistroPkg { version = v, release = r}) = + makeObj [("DistroPkg", showJSON (v, r))] + showJSON p@(RepoPkg { version = v, deps = d, release = r }) = + makeObj [("RepoPkg", showJSON (v, d, r))] + + readJSON object = let + readGhc = do + obj <- readJSON object + v <- valFromObj "GhcPkg" obj >>= readJSON + return $ GhcPkg v + + readDistro = do + obj <- readJSON object + (v, r) <- valFromObj "DistroPkg" obj >>= readJSON + return $ DistroPkg v r + + readRepo = do + obj <- readJSON object + (v, d, r) <- valFromObj "RepoPkg" obj >>= readJSON + return $ RepoPkg v d r + + in readGhc `mplus` readDistro `mplus` readRepo `mplus` fail "Not a Pkg object" diff --git a/src/PkgDB.hs-boot b/src/PkgDB.hs-boot deleted file mode 100644 --- a/src/PkgDB.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module PkgDB where - -import qualified Distribution.Package as P -import qualified Distribution.Version as V - -type CblPkg = (String, (V.Version, [P.Dependency], Int)) -type CblDB = [CblPkg] - -lookupPkg :: CblDB -> String -> Maybe CblPkg diff --git a/src/Updates.hs b/src/Updates.hs --- a/src/Updates.hs +++ b/src/Updates.hs @@ -35,8 +35,8 @@ aD <- cfgGet appDir entries <- liftIO $ liftM (Tar.read . GZip.decompress) (BS.readFile $ aD "00-index.tar.gz") - let nonBasePkgs = filter (\ (_, (_, ds, _)) -> not $ null ds) db - let pkgsNVers = map (\ (p, (v, _, _)) -> (p, v)) nonBasePkgs + let nonBasePkgs = filter (not . isBasePkg) db + let pkgsNVers = map (\ p -> (pkgName p, pkgVersion p)) nonBasePkgs let availPkgs = catMaybes $ eMap extractPkgVer entries let outdated = filter (\ (p, v) -> maybe False (> v) (latestVer p availPkgs)) diff --git a/src/Util/Misc.hs b/src/Util/Misc.hs --- a/src/Util/Misc.hs +++ b/src/Util/Misc.hs @@ -17,7 +17,7 @@ module Util.Misc where -import {-# SOURCE #-} PkgDB +import qualified PkgDB as DB import Codec.Archive.Tar as Tar import Codec.Compression.GZip as GZip @@ -64,9 +64,11 @@ dbName = progName ++ ".db" -- {{{1 command line argument type +data PkgType = GhcPkgT | DistroPkgT | RepoPkgT + deriving (Show, Data, Typeable) + data Cmds - = AddBasePkg { appDir :: FilePath, dbFile :: FilePath, dryRun :: Bool, pkgVers :: [(String, String)] } - | AddPkg { appDir :: FilePath, dbFile :: FilePath, patchDir :: FilePath, dryRun :: Bool, cbls :: [FilePath] } + = CmdAdd { appDir :: FilePath, dbFile :: FilePath, patchDir :: FilePath, dryRun :: Bool, pkgType :: PkgType, cbls :: [FilePath] } | BuildPkgs { appDir :: FilePath, dbFile :: FilePath, pkgs :: [String] } | BumpPkgs { appDir :: FilePath, dbFile :: FilePath, dryRun :: Bool, inclusive :: Bool, pkgs :: [String] } | IdxSync { appDir :: FilePath } @@ -75,10 +77,10 @@ | Updates { appDir :: FilePath, dbFile :: FilePath } | Urls { appDir :: FilePath, pkgVers :: [(String, String)] } | PkgBuild { appDir :: FilePath, dbFile :: FilePath, patchDir :: FilePath, pkgs :: [String] } + | ConvertDb { appDir :: FilePath, inDbFile :: FilePath, outDbFile :: FilePath } deriving (Show, Data, Typeable) -defAddBasePkg = AddBasePkg "" "" True [] -defAddPkg = AddPkg "" "" "" True [] +defCmdAdd = CmdAdd "" "" "" True RepoPkgT [] defBuildPkgs = BuildPkgs "" "" [] defBumpPkgs = BumpPkgs "" "" False False [] defIdxSync = IdxSync "" @@ -87,6 +89,7 @@ defUpdates = Updates "" "" defUrls = Urls "" [] defPkgBuild = PkgBuild "" "" "" [] +defConvertDb = ConvertDb "" "" "" cfgGet f = liftM f ask @@ -186,9 +189,9 @@ checkAgainstDb db dep = let dN = depName dep dVR = depVersionRange dep - in case lookupPkg db dN of + in case DB.lookupPkg db dN of Nothing -> False - Just (_, (v, _, _)) -> withinRange v dVR + Just (_, p) -> withinRange (DB.version p) dVR -- {{{1 allPatches allPatches pn patchDir = let diff --git a/src/Util/Translation.hs b/src/Util/Translation.hs --- a/src/Util/Translation.hs +++ b/src/Util/Translation.hs @@ -17,7 +17,7 @@ module Util.Translation where -- -import AddCabal +import Add import Distribution.PackageDescription.Parse import Distribution.Verbosity -- @@ -84,7 +84,7 @@ , apShHkgName :: ShVar String , apShPkgName :: ShVar String , apShPkgVer :: ShVar Version - , apShPkgRel :: ShVar Int + , apShPkgRel :: ShVar String , apShPkgDesc :: ShVar ShQuotedString , apShUrl :: ShVar ShQuotedString , apShLicence :: ShVar ShArray @@ -106,7 +106,7 @@ , apShHkgName = ShVar "_hkgname" "" , apShPkgName = ShVar "pkgname" "" , apShPkgVer = ShVar "pkgver" (Version [] []) - , apShPkgRel = ShVar "pkgrel" 0 + , apShPkgRel = ShVar "pkgrel" "0" , apShPkgDesc = ShVar "pkgdesc" (ShQuotedString "") , apShUrl = ShVar "url" (ShQuotedString "http://hackage.haskell.org/package/${_hkgname}") , apShLicence = ShVar "license" (ShArray []) @@ -268,7 +268,7 @@ ap = baseArchPkg (PackageName hkgName) = packageName pd pkgVer = packageVersion pd - pkgRel = maybe 1 pkgRelease (lookupPkg db hkgName) + pkgRel = maybe "1" pkgRelease (lookupPkg db hkgName) hasLib = maybe False (const True) (library pd) licFn = let l = licenseFile pd in if null l then Nothing else Just l archName = (if hasLib then "haskell-" else "") ++ (map toLower hkgName) @@ -276,7 +276,7 @@ url = if null (homepage pd) then "http://hackage.haskell.org/package/${_hkgname}" else (homepage pd) lic = display (license pd) makeDepends = if hasLib then [] else ["ghc=7.0.3-2"] ++ calcExactDeps db pd - depends = if hasLib then ["ghc=7.0.3-2", "sh"] ++ calcExactDeps db pd else [] + depends = if hasLib then ["ghc=7.0.3-2"] ++ calcExactDeps db pd else [] extraLibDepends = maybe [] (extraLibs . libBuildInfo) (library pd) install = if hasLib then (apShInstall ap) else Nothing in ap @@ -303,9 +303,16 @@ -- • this is most likely too simplistic to create the Arch package names -- correctly for all possible dependencies calcExactDeps db pd = let - deps = filter (not . flip elem ghcPkgs) (map depName (buildDepends pd)) + remPkgs = (map DB.pkgName (filter isGhcPkg db)) ++ ghcPkgs + deps = filter (not . flip elem remPkgs) (map depName (buildDepends pd)) lookupPkgVer = display . DB.pkgVersion . fromJust . lookupPkg db - in map (\ n -> "haskell-" ++ (map toLower n) ++ "=" ++ (lookupPkgVer n)) deps + depString n = let + pkg = fromJust $ lookupPkg db n + name = map toLower $ DB.pkgName pkg + ver = display $ DB.pkgVersion pkg + rel = pkgRelease pkg + in "haskell-" ++ name ++ "=" ++ ver ++ "-" ++ rel + in map depString deps -- {{{2 ghcPkgs -- libraries included in GHC, but not marked as provided by the Arch package diff --git a/tst/TestPkgDB.hs b/tst/TestPkgDB.hs --- a/tst/TestPkgDB.hs +++ b/tst/TestPkgDB.hs @@ -26,18 +26,24 @@ import Test.Framework.Providers.HUnit import Test.Framework.TH import Test.HUnit +import Text.JSON +import qualified Distribution.Package as P +import qualified Distribution.Version as V -- {{{1 transitiveDependants theDb :: CblDB theDb = - [ ("pkgA", (fromJust $ simpleParse "1.0", [])) -- nothing depends on this pkg + [ createRepoPkg "pkgA" (fromJust $ simpleParse "1.0") [] "1" -- nothing depends on this pkg -- a chain of two - , ("pkgB", (fromJust $ simpleParse "1.0", [])) - , ("pkgC", (fromJust $ simpleParse "1.0", map (fromJust . simpleParse) ["pkgB"])) + , createRepoPkg "pkgB" (fromJust $ simpleParse "1.0") [] "1" + , createRepoPkg "pkgC" (fromJust $ simpleParse "1.0") + (map (fromJust . simpleParse) ["pkgB"]) "1" -- a chain of three - , ("pkgD", (fromJust $ simpleParse "1.0", [])) - , ("pkgE", (fromJust $ simpleParse "1.0", map (fromJust . simpleParse) ["pkgD"])) - , ("pkgF", (fromJust $ simpleParse "1.0", map (fromJust . simpleParse) ["pkgE"])) + , createRepoPkg "pkgD" (fromJust $ simpleParse "1.0") [] "1" + , createRepoPkg "pkgE" (fromJust $ simpleParse "1.0") + (map (fromJust . simpleParse) ["pkgD"]) "1" + , createRepoPkg "pkgF" (fromJust $ simpleParse "1.0") + (map (fromJust . simpleParse) ["pkgE"]) "1" ] case_TD_one = do transitiveDependants theDb ["pkgA"] @=? ["pkgA"] @@ -47,6 +53,27 @@ case_TD_ordering1 = do transitiveDependants theDb ["pkgD", "pkgF"] @=? ["pkgD", "pkgE", "pkgF"] -- pass in packages in reverse order case_TD_ordering2 = do transitiveDependants theDb ["pkgF", "pkgD"] @=? ["pkgD", "pkgE", "pkgF"] + +-- {{{1 JSON instances +case_json_version = let + v1_i = V.Version [1, 2, 3] [] + v1_s = "{\"Version\":\"1.2.3\"}" + v2_i = V.Version [1, 2, 3] ["foo"] + in do + assertEqual "JSON Version showJSON 1" v1_s (encode $ showJSON v1_i) + assertEqual "JSON Version showJSON 2" v1_s (encode $ showJSON v2_i) + assertEqual "JSON Version readJSON 1" (Ok v1_i) (decode v1_s) + +case_json_dependency = let + (Just d1_i) = simpleParse "package -any" :: Maybe P.Dependency + d1_s = "{\"Dependency\":\"package -any\"}" + (Just d2_i) = simpleParse "ConfigFile >=1 && <1.1" :: Maybe P.Dependency + d2_s = "{\"Dependency\":\"ConfigFile >=1 && <1.1\"}" + in do + assertEqual "JSON Dependency showJSON 1" d1_s (encode $ showJSON d1_i) + assertEqual "JSON Dependency showJSON 2" d2_s (encode $ showJSON d2_i) + assertEqual "JSON Dependency readJSON 1" (Ok d1_i) (decode d1_s) + assertEqual "JSON Dependency readJSON 2" (Ok d2_i) (decode d2_s) -- {{{1 testGroup testGroup = $(testGroupGenerator)