diff --git a/cblrepo.cabal b/cblrepo.cabal --- a/cblrepo.cabal +++ b/cblrepo.cabal @@ -1,5 +1,5 @@ name: cblrepo -version: 0.17.1 +version: 0.18.0 cabal-version: >= 1.6 license: OtherLicense license-file: LICENSE-2.0 @@ -23,12 +23,12 @@ executable cblrepo hs-source-dirs: src main-is: Main.hs - other-modules: PkgDB Add BumpPkgs BuildPkgs Sync Versions Updates ListPkgs PkgBuild OldPkgDB ConvertDB Remove Extract - Util.Translation Util.Cabal Util.HackageIndex Util.Misc Util.Dist + other-modules: Add BumpPkgs BuildPkgs Update Versions Upgrades ListPkgs PkgBuild OldPkgDB ConvertDB Remove Extract CreateConfig + PkgDB Util.Translation Util.Cabal Util.HackageIndex Util.Misc Util.Dist Util.Cfg build-depends: base ==4.8.*, filepath ==1.4.*, directory ==1.2.*, Cabal ==1.22.*, transformers ==0.4.*, - bytestring ==0.10.*, tar ==0.4.*, zlib ==0.5.*, mtl ==2.2.*, - process ==1.2.*, Unixutils ==1.53.*, unix ==2.7.*, + bytestring ==0.10.*, tar ==0.4.*, zlib ==0.6.*, mtl ==2.2.*, + process ==1.2.*, Unixutils ==1.54.*, unix ==2.7.*, ansi-wl-pprint ==0.6.*, aeson ==0.9.*, stringsearch ==0.3.*, optparse-applicative ==0.11.*, safe ==0.3.*, containers ==0.5.*, utf8-string ==1 diff --git a/src/Add.hs b/src/Add.hs --- a/src/Add.hs +++ b/src/Add.hs @@ -22,6 +22,7 @@ import qualified Util.Cabal as Cbl import Util.Misc import Util.Dist +import Util.Cfg -- {{{2 system import Control.Monad.Reader @@ -45,15 +46,15 @@ -- {{{1 add add :: Command () add = do - dbFn <- asks dbFile + dbFn <- asks $ dbFile . fst db <- liftIO $ readDb dbFn - dr <- asks dryRun - ghcVersion <- asks $ ghcVer . optsCmd - filePkgs <- asks $ cmdAddFileCbls . optsCmd - idxPkgs <- asks $ cmdAddCbls . optsCmd + dr <- asks $ dryRun . fst + ghcVersion <- asks $ ghcVer . optsCmd . fst + filePkgs <- asks $ cmdAddFileCbls . optsCmd . fst + idxPkgs <- asks $ cmdAddCbls . optsCmd . fst -- - ghcPkgs <- asks $ map (uncurry GhcType) . cmdAddGhcPkgs . optsCmd - distroPkgs <- asks $ map (\ (n, v, x, r) -> DistroType n v x r) . cmdAddDistroPkgs . optsCmd + ghcPkgs <- asks $ map (uncurry GhcType) . cmdAddGhcPkgs . optsCmd . fst + distroPkgs <- asks $ map (\ (n, v, x, r) -> DistroType n v x r) . cmdAddDistroPkgs . optsCmd . fst genFilePkgs <- mapM (runCabalParseWithTempDir . fmap snd . Cbl.readFromFile . fst) filePkgs genIdxPkgs <- mapM ((runCabalParseWithTempDir . fmap snd . Cbl.readFromIdx) . (\ (a, b, _) -> (a, b))) idxPkgs genPkgs <- liftM (map RepoType) $ exitOnAnyLefts (genFilePkgs ++ genIdxPkgs) @@ -72,10 +73,11 @@ runCabalParseWithTempDir :: Cbl.CabalParse a -> Command (Either String a) runCabalParseWithTempDir f = do - aD <- asks appDir - pD <- asks $ patchDir . optsCmd + aD <- asks $ appDir . fst + pD <- asks $ patchDir . optsCmd . fst + cfg <- asks snd liftIO $ withTemporaryDirectory "/tmp/cblrepo." $ \ destDir -> do - let cpe = Cbl.CabalParseEnv aD pD destDir + let cpe = Cbl.CabalParseEnv aD pD destDir (getIndexFileName cfg) Cbl.runCabalParse cpe f getName (GhcType n _) = n diff --git a/src/BuildPkgs.hs b/src/BuildPkgs.hs --- a/src/BuildPkgs.hs +++ b/src/BuildPkgs.hs @@ -23,6 +23,6 @@ buildPkgs :: Command () buildPkgs = do - db <- asks dbFile >>= liftIO . readDb - pkgs <- asks $ pkgs . optsCmd + db <- asks (dbFile . fst) >>= liftIO . readDb + pkgs <- asks $ pkgs . optsCmd . fst liftIO $ mapM_ putStrLn $ transitiveDependants db pkgs diff --git a/src/BumpPkgs.hs b/src/BumpPkgs.hs --- a/src/BumpPkgs.hs +++ b/src/BumpPkgs.hs @@ -23,11 +23,11 @@ bumpPkgs :: Command () bumpPkgs = do - dbFn <- asks dbFile + dbFn <- asks $ dbFile . fst db <- liftIO $ readDb dbFn - dR <- asks dryRun - pkgs <- asks $ pkgs . optsCmd - incl <- asks $ inclusive . optsCmd + dR <- asks (dryRun . fst) + pkgs <- asks $ pkgs . optsCmd . fst + incl <- asks $ inclusive . optsCmd . fst let bpkgs = transDependants db incl pkgs let newDb = foldl bumpRelease db bpkgs liftIO $ if dR diff --git a/src/ConvertDB.hs b/src/ConvertDB.hs --- a/src/ConvertDB.hs +++ b/src/ConvertDB.hs @@ -25,8 +25,8 @@ convertDb :: Command () convertDb = do - inDbFn <- asks $ inDbFile . optsCmd - outDbFn <- asks $ outDbFile . optsCmd + inDbFn <- asks $ inDbFile . optsCmd . fst + outDbFn <- asks $ outDbFile . optsCmd . fst dbExist <- liftIO $ doesFileExist inDbFn when dbExist $ do newDb <- fmap doConvertDB (liftIO $ ODB.readDb inDbFn) diff --git a/src/CreateConfig.hs b/src/CreateConfig.hs new file mode 100644 --- /dev/null +++ b/src/CreateConfig.hs @@ -0,0 +1,34 @@ +{- + - Copyright 2015 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 CreateConfig + where + +import Util.Cfg +import Util.Misc + +import Data.Aeson +import Control.Monad +import Control.Monad.IO.Class +import System.Exit +import System.Posix.Files + +createConfig :: Command () +createConfig = liftIO $ do + exists <- fileExist "cblrepo.cfg" + if exists + then putStrLn "Configuration file already exists" >> exitFailure + else saveDefCfg "cblrepo.cfg" diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/src/Extract.hs @@ -1,9 +1,26 @@ +{- + - Copyright 2014 - 2015 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. + -} + {-# LANGUAGE FlexibleContexts #-} module Extract where import Util.HackageIndex import Util.Misc +import Util.Cfg import Control.Monad.Trans.Except import Control.Monad.Reader @@ -14,10 +31,11 @@ extract :: Command () extract = do - aD <- asks appDir - pkgsNVersions <- asks $ cmdExtractPkgs . optsCmd + aD <- asks $ appDir . fst + pkgsNVersions <- asks $ cmdExtractPkgs . optsCmd . fst + cfg <- asks snd -- - idx <- liftIO $ readIndexFile aD + idx <- liftIO $ readIndexFile aD (getIndexFileName cfg) _ <- mapM (runExceptT . extractAndSave idx) pkgsNVersions >>= exitOnAnyLefts return () diff --git a/src/ListPkgs.hs b/src/ListPkgs.hs --- a/src/ListPkgs.hs +++ b/src/ListPkgs.hs @@ -26,26 +26,30 @@ listPkgs :: Command () listPkgs = do - lG <- asks $ listGhc . optsCmd - lD <- asks $ listDistro . optsCmd - lR <- asks $ noListRepo . optsCmd - lH <- asks $ hackageFmt . optsCmd - ps <- asks $ pkgs . optsCmd - db <- asks dbFile >>= liftIO . readDb + lG <- asks $ listGhc . optsCmd . fst + lD <- asks $ listDistro . optsCmd . fst + lR <- asks $ noListRepo . optsCmd . fst + lF <- asks $ listFmt . optsCmd . fst + ps <- asks $ pkgs . optsCmd . fst + db <- asks (dbFile . fst) >>= liftIO . readDb let allPkgs = filter (pkgFilter lG lD lR) db let pkgsToList = if null ps then allPkgs else filter (\p -> pkgName p `elem` ps) allPkgs - let printer = if lH - then printCblPkgHackage - else printCblPkgShort + let printer = case lF of + CmdListShortFmt -> printCblPkgShort + CmdListNormalFmt -> printCblPkgNormal + CmdListHackageFmt -> printCblPkgHackage liftIO $ mapM_ printer pkgsToList pkgFilter :: Bool -> Bool -> Bool -> CblPkg -> Bool pkgFilter g d r p = (g && isGhcPkg p) || (d && isDistroPkg p) || (not r && isRepoPkg p) printCblPkgShort :: CblPkg -> IO () -printCblPkgShort p = +printCblPkgShort p = putStrLn $ (pkgName p) ++ "," ++ (display $ pkgVersion p) + +printCblPkgNormal :: CblPkg -> IO () +printCblPkgNormal p = putStrLn $ pkgName p ++ " " ++ v ++ "-" ++ r ++ showFlagsIfPresent p where v = display (pkgVersion p) ++ if (not $ isGhcPkg p) then ("_" ++ show (pkgXRev p)) else "" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -20,15 +20,17 @@ import Add import BuildPkgs import BumpPkgs -import Sync +import Update import Versions import ListPkgs -import Updates +import Upgrades import Util.Misc import PkgBuild import ConvertDB import Remove import Extract +import CreateConfig +import Util.Cfg import Paths_cblrepo @@ -66,8 +68,8 @@ cmdBuildPkgsCmd = command "build" (info (helper <*> cmdBuildPkgsOpts) (fullDesc <> progDesc "Re-order packages into a good build order")) -cmdSyncOpts = CmdSync <$> switch (internal <> hidden) -cmdSyncCmd = command "sync" (info (helper <*> cmdSyncOpts) +cmdUpdateOpts = CmdUpdate <$> switch (internal <> hidden) +cmdUpdateCmd = command "update" (info (helper <*> cmdUpdateOpts) (fullDesc <> progDesc "Update the index")) cmdVersionsOpts = CmdVersions @@ -76,16 +78,17 @@ cmdVersionsCmd = command "versions" (info (helper <*> cmdVersionsOpts) (fullDesc <> progDesc "List available versions of packages")) -cmdUpdatesOpts = CmdUpdates +cmdUpgradesOpts = CmdUpgrades <$> switch (short 's' <> help "A shorter output suitable for scripting") -cmdUpdatesCmd = command "updates" (info (helper <*> cmdUpdatesOpts) - (fullDesc <> progDesc "Check for available updates")) +cmdUpgradesCmd = command "upgrades" (info (helper <*> cmdUpgradesOpts) + (fullDesc <> progDesc "Check for packages that can be upgraded")) cmdListPkgsOpts = CmdListPkgs <$> switch (short 'g' <> long "ghc" <> help "List ghc packages") <*> switch (short 'd' <> long "distro" <> help "List distro packages") <*> switch (long "no-repo" <> help "Do not list repo packages") - <*> switch (long "hackage" <> help "List in hackage format") + <*> option listFormatReader (short 'f' <> long "format" <> value CmdListNormalFmt <> + help "Output format: short, normal (default), hackage") <*> many (argument str (metavar "PKGNAME ...")) cmdListPkgsCmd = command "list" (info (helper <*> cmdListPkgsOpts) (fullDesc <> progDesc "List packages in repo")) @@ -113,12 +116,16 @@ <$> many (argument pkgNVersionArgReader (metavar "PKGNAME,VERSION")) cmdExtractCmd = command "extract" (info (helper <*> cmdExtractOpts) (fullDesc <> progDesc "Extract Cabal file from index")) +cmdCreateConfigOpts = pure CmdCreateConfig +cmdCreateConfigCmd = command "create-config" (info (helper <*> cmdCreateConfigOpts) (fullDesc <> progDesc "Create configuration file with defaults")) + argParser = info (helper <*> opts) (fullDesc <> header (progName ++ " v" ++ display version) <> progDesc "Maintain a datatbase of dependencies of CABAL packages") where opts = Opts <$> argAppDir <*> argDbFile <*> argDryRun <*> subparser ( cmdAddPkgCmd - <> cmdBumpPkgsCmd <> cmdBuildPkgsCmd <> cmdSyncCmd <> cmdVersionsCmd <> cmdUpdatesCmd + <> cmdBumpPkgsCmd <> cmdBuildPkgsCmd <> cmdUpdateCmd <> cmdVersionsCmd <> cmdUpgradesCmd <> cmdListPkgsCmd <> cmdPkgBuildCmd <> cmdConvertDbCmd <> cmdRemovePkgCmd <> cmdExtractCmd + <> cmdCreateConfigCmd ) -- {{{1 main @@ -127,17 +134,19 @@ defAppDir <- getAppUserDataDirectory progName execParser argParser >>= \ o -> do let aD = if null (appDir o) then defAppDir else appDir o - let o' = o { appDir = aD } createDirectoryIfMissing True aD - case optsCmd o' of - CmdAdd {} -> runCommand o' add - CmdBuildPkgs {} -> runCommand o' buildPkgs - CmdBumpPkgs {} -> runCommand o' bumpPkgs - CmdSync {} -> runCommand o' sync - CmdVersions {} -> runCommand o' versions - CmdListPkgs {} -> runCommand o' listPkgs - CmdUpdates {} -> runCommand o' updates - CmdPkgBuild {} -> runCommand o' pkgBuild - CmdConvertDb {} -> runCommand o' convertDb - CmdRemovePkg {} -> runCommand o' remove - CmdExtract {} -> runCommand o' extract + cfg <- readCfg "cblrepo.cfg" + let e = (o { appDir = aD }, cfg) + case optsCmd o of + CmdAdd {} -> runCommand e add + CmdBuildPkgs {} -> runCommand e buildPkgs + CmdBumpPkgs {} -> runCommand e bumpPkgs + CmdUpdate {} -> runCommand e update + CmdVersions {} -> runCommand e versions + CmdListPkgs {} -> runCommand e listPkgs + CmdUpgrades {} -> runCommand e upgrades + CmdPkgBuild {} -> runCommand e pkgBuild + CmdConvertDb {} -> runCommand e convertDb + CmdRemovePkg {} -> runCommand e remove + CmdExtract {} -> runCommand e extract + CmdCreateConfig -> runCommand e createConfig diff --git a/src/PkgBuild.hs b/src/PkgBuild.hs --- a/src/PkgBuild.hs +++ b/src/PkgBuild.hs @@ -20,6 +20,7 @@ import Util.Misc import Util.Translation import qualified Util.Cabal as Cbl +import Util.Cfg import Control.Arrow import Control.Monad.Reader @@ -33,15 +34,15 @@ pkgBuild :: Command () pkgBuild = do - pkgs <- asks $ pkgs . optsCmd + pkgs <- asks $ pkgs . optsCmd . fst void $ mapM (runExceptT . generatePkgBuild) pkgs >>= exitOnAnyLefts generatePkgBuild :: String -> ExceptT String Command () generatePkgBuild pkg = do - db <- asks dbFile >>= liftIO . readDb - patchDir <- asks $ patchDir . optsCmd - ghcVer <- asks $ ghcVer . optsCmd - ghcRel <- asks $ ghcRel . optsCmd + db <- asks (dbFile . fst) >>= liftIO . readDb + patchDir <- asks $ patchDir . optsCmd . fst + ghcVer <- asks $ ghcVer . optsCmd . fst + ghcRel <- asks $ ghcRel . optsCmd . fst (ver, fa) <- maybe (throwE $ "Unknown package: " ++ pkg) (return . (pkgVersion &&& pkgFlags)) $ lookupPkg db pkg --- (cblFile, genericPkgDesc) <- runCabalParseWithTempDir $ Cbl.readFromIdx (pkg, ver) @@ -69,9 +70,10 @@ runCabalParseWithTempDir :: Cbl.CabalParse a -> ExceptT String Command a runCabalParseWithTempDir f = do - aD <- asks appDir - pD <- asks $ patchDir . optsCmd + aD <- asks (appDir . fst) + pD <- asks $ patchDir . optsCmd . fst + cfg <- asks snd r <- liftIO $ withTemporaryDirectory "/tmp/cblrepo." $ \ destDir -> do - let cpe = Cbl.CabalParseEnv aD pD destDir + let cpe = Cbl.CabalParseEnv aD pD destDir (getIndexFileName cfg) Cbl.runCabalParse cpe f reThrowE r diff --git a/src/Remove.hs b/src/Remove.hs --- a/src/Remove.hs +++ b/src/Remove.hs @@ -30,10 +30,10 @@ -- {{{1 remove remove :: Command () remove = do - dbFn <- asks dbFile + dbFn <- asks (dbFile . fst) db <- liftIO $ readDb dbFn - pkgs <- asks $ pkgs . optsCmd - dR <- asks dryRun + pkgs <- asks $ pkgs . optsCmd . fst + dR <- asks (dryRun . fst) liftIO $ either (\ s -> putStrLn s >> exitFailure) (\ newDb -> unless dR $ saveDb newDb dbFn) diff --git a/src/Sync.hs b/src/Sync.hs deleted file mode 100644 --- a/src/Sync.hs +++ /dev/null @@ -1,27 +0,0 @@ -{- - - Copyright 2011-2013 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 Sync where - -import Util.Misc - -import Control.Monad.Reader -import System.FilePath - -sync :: Command () -sync = do - aD <- asks appDir - liftIO $ getFromURL indexUrl (aD indexFileName) diff --git a/src/Update.hs b/src/Update.hs new file mode 100644 --- /dev/null +++ b/src/Update.hs @@ -0,0 +1,30 @@ +{- + - Copyright 2011-2013 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 Update where + +import Util.Misc +import Util.Cfg + +import Control.Monad.Reader +import System.FilePath + +update :: Command () +update = do + aD <- asks $ appDir . fst + cfg <- asks snd + let idxFn = getIndexFileName cfg + liftIO $ getFromURL (cfgIdxUrl cfg) (aD idxFn) diff --git a/src/Updates.hs b/src/Updates.hs deleted file mode 100644 --- a/src/Updates.hs +++ /dev/null @@ -1,56 +0,0 @@ -{- - - Copyright 2011-2014 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 Updates - ( updates - ) where - -import PkgDB -import Util.Misc -import Util.HackageIndex - -import Control.Applicative -import Control.Arrow -import Control.Monad.Reader -import Data.Maybe -import Distribution.Text -import Distribution.Version - -updates :: Command () -updates = do - db <- asks dbFile >>= liftIO . readDb - aD <- asks appDir - aCS <- asks $ idxStyle .optsCmd - availPkgsNVers <- liftIO $ buildPkgVersions <$> readIndexFile aD - let nonBasePkgs = filter (not . isBasePkg) db - pkgsNVers = map (pkgName &&& pkgVersion &&& pkgXRev) nonBasePkgs - outdated = filter - (\ (p, vx) -> maybe False (> vx) (latestVersion availPkgsNVers p)) - pkgsNVers - printer = if aCS - then printOutdatedShort - else printOutdated - liftIO $ mapM_ (printer availPkgsNVers) outdated - -printOutdated :: PkgVersions -> (String, (Version, Int)) -> IO () -printOutdated avail (p, (v, x)) = putStrLn $ p ++ ": " ++ display v ++ ":x" ++ show x ++ " (" ++ display lv ++ ":x" ++ show lx ++ ")" - where - (lv, lx) = fromJust $ latestVersion avail p - -printOutdatedShort :: PkgVersions -> (String, (Version, Int)) -> IO () -printOutdatedShort avail (p, _) = putStrLn $ p ++ "," ++ display l - where - l = fst $ fromJust $ latestVersion avail p diff --git a/src/Upgrades.hs b/src/Upgrades.hs new file mode 100644 --- /dev/null +++ b/src/Upgrades.hs @@ -0,0 +1,58 @@ +{- + - Copyright 2011-2014 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 Upgrades + ( upgrades + ) where + +import PkgDB +import Util.Misc +import Util.HackageIndex +import Util.Cfg + +import Control.Applicative +import Control.Arrow +import Control.Monad.Reader +import Data.Maybe +import Distribution.Text +import Distribution.Version + +upgrades :: Command () +upgrades = do + db <- asks (dbFile . fst) >>= liftIO . readDb + aD <- asks $ appDir . fst + aCS <- asks $ idxStyle .optsCmd . fst + cfg <- asks snd + availPkgsNVers <- liftIO $ buildPkgVersions <$> readIndexFile aD (getIndexFileName cfg) + let nonBasePkgs = filter (not . isBasePkg) db + pkgsNVers = map (pkgName &&& pkgVersion &&& pkgXRev) nonBasePkgs + outdated = filter + (\ (p, vx) -> maybe False (> vx) (latestVersion availPkgsNVers p)) + pkgsNVers + printer = if aCS + then printOldShort + else printOld + liftIO $ mapM_ (printer availPkgsNVers) outdated + +printOld :: PkgVersions -> (String, (Version, Int)) -> IO () +printOld avail (p, (v, x)) = putStrLn $ p ++ ": " ++ display v ++ ":x" ++ show x ++ " (" ++ display lv ++ ":x" ++ show lx ++ ")" + where + (lv, lx) = fromJust $ latestVersion avail p + +printOldShort :: PkgVersions -> (String, (Version, Int)) -> IO () +printOldShort avail (p, _) = putStrLn $ p ++ "," ++ display l + where + l = fst $ fromJust $ latestVersion avail p diff --git a/src/Util/Cabal.hs b/src/Util/Cabal.hs --- a/src/Util/Cabal.hs +++ b/src/Util/Cabal.hs @@ -40,6 +40,7 @@ { cpeAppDir :: FilePath , cpePatchDir :: FilePath , cpeDestDir :: FilePath + , cpeIdxFn :: FilePath } deriving (Eq, Show) -- | Type used for reading Cabal files @@ -67,15 +68,16 @@ readFromIdx (pN, pV) = do destDir <- asks cpeDestDir appDir <- asks cpeAppDir + idxFn <- asks cpeIdxFn let destFn = destDir pN <.> ".cabal" - lift $ copyCabal appDir destFn + lift $ copyCabal appDir idxFn destFn cblFile <- patch destFn gpd <- liftIO $ readPackageDescription silent destFn return (cblFile, gpd) where - copyCabal appDir destFn = do - idx <- liftIO $ readIndexFile appDir + copyCabal appDir idxFn destFn = do + idx <- liftIO $ readIndexFile appDir idxFn cbl <- maybe (throwE $ "Failed to extract contents for " ++ pN ++ " " ++ display pV) return (extractCabal idx pN pV) liftIO $ BSL.writeFile destFn cbl diff --git a/src/Util/Cfg.hs b/src/Util/Cfg.hs new file mode 100644 --- /dev/null +++ b/src/Util/Cfg.hs @@ -0,0 +1,53 @@ +{- + - Copyright 2015 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. + -} + +{-# LANGUAGE TemplateHaskell #-} + +module Util.Cfg + ( Cfg(..) + , readCfg + , saveDefCfg + , getIndexFileName + ) where + +import Control.Monad +import Data.Aeson +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe +import System.Posix.Files + +data Cfg = Cfg { cfgIdxUrl :: String } + deriving (Show) + +defCfg = Cfg "http://hackage.fpcomplete.com/00-index.tar.gz" + +readCfg :: FilePath -> IO Cfg +readCfg fn = do + exists <- fileExist fn + if exists + then (fromMaybe defCfg . decode) `fmap` BSL.readFile fn + else return defCfg + +saveDefCfg :: FilePath -> IO () +saveDefCfg fn = BSL.writeFile fn (encode defCfg) + +getIndexFileName :: Cfg -> String +getIndexFileName cfg = map repSlash $ drop 7 $ cfgIdxUrl cfg + where + repSlash c = if c == '/' then '_' else c + +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''Cfg) diff --git a/src/Util/HackageIndex.hs b/src/Util/HackageIndex.hs --- a/src/Util/HackageIndex.hs +++ b/src/Util/HackageIndex.hs @@ -19,6 +19,7 @@ import Util.Misc import Util.Dist +import Util.Cfg import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip @@ -36,10 +37,10 @@ import Distribution.Text import System.FilePath -readIndexFile :: FilePath -> IO BSL.ByteString -readIndexFile indexLocation = exitOnException +readIndexFile :: FilePath -> FilePath -> IO BSL.ByteString +readIndexFile indexLocation indexFilename = exitOnException "Cannot open index file, have you run the 'sync' command?" - (BSL.readFile $ indexLocation indexFileName) + (BSL.readFile $ indexLocation indexFilename) type PkgVersions = M.Map String [(Version, Int)] @@ -51,14 +52,16 @@ where entries = Tar.read $ GZip.decompress idx - createPkgVerMap acc (Tar.Next e es) = createPkgVerMap (M.insertWith (++) (parts !! 0) [(ver, xrev)] acc) es + createPkgVerMap acc (Tar.Next e es) = case ver of + Nothing -> createPkgVerMap acc es + Just ver -> createPkgVerMap (M.insertWith (++) (head parts) [(ver, xrev)] acc) es where parts = splitDirectories (Tar.entryPath e) - ver = fromJust . simpleParse $ parts !! 1 + ver = simpleParse $ parts !! 1 content = case Tar.entryContent e of Tar.NormalFile c _ -> Just $ BSLU.toString c _ -> Nothing - xrev = case (parsePackageDescription <$> content) of + xrev = case parsePackageDescription <$> content of Just (ParseOk _ gpd) -> pkgXRev (packageDescription gpd) _ -> 0 diff --git a/src/Util/Misc.hs b/src/Util/Misc.hs --- a/src/Util/Misc.hs +++ b/src/Util/Misc.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {- - - Copyright 2011-2014 Per Magnus Therning + - Copyright 2011-2015 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. @@ -20,6 +20,7 @@ -- {{{1 imports import qualified PkgDB as DB import Util.Dist +import Util.Cfg import Control.Exception (onException) import Control.Monad @@ -55,13 +56,10 @@ progName = "cblrepo" dbName = progName ++ ".db" -ghcDefVersion = Version [7, 10, 1] [] +ghcDefVersion = Version [7, 10, 2] [] ghcVersionDep :: Version -> Int -> String ghcVersionDep ghcVer ghcRel = "ghc=" ++ display ghcVer ++ "-" ++ show ghcRel -indexUrl = "http://hackage.haskell.org/packages/index.tar.gz" -indexFileName = "index.tar.gz" - -- {{{1 command line parser helpers readPkgNVersion :: ReadP (String, Version) readPkgNVersion = do @@ -152,7 +150,19 @@ Just (r, "") -> return r _ -> fail $ "Cannot parse: " ++ s +listFormatReader :: ReadM CmdListFormat +listFormatReader = do + s <- readerAsk + case s of + "normal" -> return CmdListNormalFmt + "short" -> return CmdListShortFmt + "hackage" -> return CmdListHackageFmt + _ -> fail $ "Cannot parse: " ++ s + -- {{{1 command line argument type +data CmdListFormat = CmdListNormalFmt | CmdListShortFmt | CmdListHackageFmt + deriving (Eq, Show) + data Cmds = CmdAdd { patchDir :: FilePath, ghcVer :: Version, cmdAddGhcPkgs :: [(String, Version)] @@ -160,16 +170,17 @@ , cmdAddCbls :: [(String, Version, FlagAssignment)] } | CmdBuildPkgs { pkgs :: [String] } | CmdBumpPkgs { inclusive :: Bool, pkgs :: [String] } - | CmdSync { unused :: Bool } + | CmdUpdate { unused :: Bool } | CmdVersions { latest :: Bool, pkgs :: [String] } | CmdListPkgs { listGhc :: Bool, listDistro :: Bool, noListRepo :: Bool - , hackageFmt :: Bool, pkgs :: [String] } - | CmdUpdates { idxStyle :: Bool } + , listFmt :: CmdListFormat, pkgs :: [String] } + | CmdUpgrades { idxStyle :: Bool } | CmdPkgBuild { ghcVer :: Version, ghcRel :: Int, patchDir :: FilePath, pkgs :: [String] } | CmdConvertDb { inDbFile :: FilePath, outDbFile :: FilePath } | CmdRemovePkg { pkgs :: [String] } | CmdExtract { cmdExtractPkgs :: [(String, Version)] } + | CmdCreateConfig deriving (Show) data Opts = Opts @@ -212,7 +223,7 @@ n = pkgNameStr gpd -- {{{1 Command type -type Command = ReaderT Opts IO +type Command = ReaderT (Opts, Cfg) IO runCommand cmds func = runReaderT func cmds @@ -233,3 +244,12 @@ else return (rights vs) exitOnException msg a = onException a $ hPutStrLn stderr msg >> exitFailure + +-- {{{1 shell escaping +shEsc :: String -> String +shEsc s = concatMap escChar s + where + escChar '\"' = "\\\"" + escChar '`' = "\\`" + escChar '\'' = "\\\'" + escChar c = [c] diff --git a/src/Util/Translation.hs b/src/Util/Translation.hs --- a/src/Util/Translation.hs +++ b/src/Util/Translation.hs @@ -47,7 +47,9 @@ deriving (Eq, Show) instance Pretty ShQuotedString where - pretty (ShQuotedString s) = char '"' <> text s <> char '"' + pretty (ShQuotedString s) = char '"' <> text quotStr <> char '"' + where + quotStr = shEsc $ unwords $ lines s -- {{{1 ShArray newtype ShArray = ShArray [String] diff --git a/src/Versions.hs b/src/Versions.hs --- a/src/Versions.hs +++ b/src/Versions.hs @@ -18,6 +18,7 @@ import Util.HackageIndex import Util.Misc +import Util.Cfg import Control.Applicative import Control.Monad.Reader @@ -27,12 +28,13 @@ versions :: Command () versions = do - aD <- asks appDir - l <- asks $ latest . optsCmd - pkgs <- asks $ pkgs . optsCmd + aD <- asks (appDir . fst) + l <- asks $ latest . optsCmd . fst + pkgs <- asks $ pkgs . optsCmd . fst + cfg <- asks snd let printFunc = if l then printLatestVersion else printAllVersions liftIO $ do - pkgsNVers <- buildPkgVersions <$> readIndexFile aD + pkgsNVers <- buildPkgVersions <$> readIndexFile aD (getIndexFileName cfg) mapM_ (\ pkg -> printFunc (pkg, M.lookup pkg pkgsNVers)) pkgs printAllVersions :: (String, Maybe [(Version, Int)]) -> IO ()