packages feed

cblrepo 0.2.3 → 0.3.0

raw patch · 14 files changed

+539/−250 lines, 14 filesdep ~test-frameworkdep ~test-framework-th

Dependency ranges changed: test-framework, test-framework-th

Files

cblrepo.cabal view
@@ -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
+ src/Add.hs view
@@ -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
− src/AddBase.hs 
@@ -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
− src/AddCabal.hs 
@@ -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
+ src/ConvertDB.hs view
@@ -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)
src/ListPkgs.hs view
@@ -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
src/Main.hs view
@@ -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 <name>,<version>." ]--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, <name>,<version>, 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'
+ src/OldPkgDB.hs view
@@ -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
src/PkgDB.hs view
@@ -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"
− src/PkgDB.hs-boot 
@@ -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
src/Updates.hs view
@@ -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))
src/Util/Misc.hs view
@@ -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
src/Util/Translation.hs view
@@ -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
tst/TestPkgDB.hs view
@@ -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)