cpkg 0.2.2.0 → 0.2.3.0
raw patch · 16 files changed
+271/−105 lines, 16 filesdep +composition-prelude
Dependencies added: composition-prelude
Files
- CHANGELOG.md +6/−0
- README.md +7/−7
- app/Main.hs +26/−3
- cpkg.cabal +5/−3
- dhall/cpkg-prelude.dhall +3/−4
- pkgs/pkg-set.dhall +25/−51
- src/CPkgPrelude.hs +4/−0
- src/Package/C.hs +4/−0
- src/Package/C/Build.hs +6/−4
- src/Package/C/Build/Tree.hs +8/−6
- src/Package/C/Db/GarbageCollect.hs +84/−0
- src/Package/C/Db/Register.hs +71/−13
- src/Package/C/Db/Type.hs +2/−0
- src/Package/C/Error.hs +11/−5
- src/Package/C/PackageSet.hs +6/−6
- src/Package/C/Type/Tree.hs +3/−3
CHANGELOG.md view
@@ -1,5 +1,11 @@ # cpkg +## 0.2.3.0++ * Add `garbage-collect` subcommand+ * Add `uninstall` subcommand+ * Add `nuke-cache` subcommand+ ## 0.2.2.0 * Add `printLdLibFlags` function and add functionality to CLI interface
README.md view
@@ -255,14 +255,14 @@ ------------------------------------------------------------------------------- Language Files Lines Code Comments Blanks -------------------------------------------------------------------------------- Bash 5 52 44 3 5- Cabal 1 154 140 0 14+ Bash 3 50 40 5 5+ Cabal 1 157 143 0 14 Cabal Project 1 4 3 0 1- Dhall 3 4660 4190 3 467- Haskell 31 1741 1428 29 284- Markdown 6 534 450 0 84- YAML 4 157 142 0 15+ Dhall 3 5191 4681 8 502+ Haskell 32 1949 1602 37 310+ Markdown 3 516 426 0 90+ YAML 4 148 133 0 15 -------------------------------------------------------------------------------- Total 51 7302 6397 35 870+ Total 47 8015 7028 50 937 ------------------------------------------------------------------------------- ```
app/Main.hs view
@@ -14,18 +14,21 @@ data DumpTarget = Linker { _pkgGet :: String } | Compiler { _pkgGet :: String }- | PkgConfig { _pkgGet :: String }+ | PkgConfig { _pkgGets :: [String] } | IncludePath { _pkgGet :: String } | LibPath { _pkgGet :: String } | LdLibPath { _pkgGets :: [String] } data Command = Install { _pkgName :: String, _verbosity :: Verbosity, _target :: Maybe Platform, _static :: Bool, _global :: Bool, _packageSet :: Maybe String }+ | Uninstall { _pkgStr :: String, _verbosity :: Verbosity, _target :: Maybe Platform } | Check { _dhallFile :: String, _verbosity :: Verbosity } | CheckSet { _dhallFile :: String, _verbosity :: Verbosity } | Dump { _dumpTarget :: DumpTarget, _host :: Maybe Platform } | DumpCabal { _pkgGetsCabal :: [String], _host :: Maybe Platform } | List { _packageSet :: Maybe String } | Nuke+ | NukeCache+ | GarbageCollect { _verbosity :: Verbosity } verbosityInt :: Parser Int verbosityInt = length <$>@@ -54,7 +57,7 @@ dumpTarget = hsubparser (command "linker" (info (Linker <$> package) (progDesc "Dump linker flags for a package")) <> command "compiler" (info (Compiler <$> package) (progDesc "Dump compiler flags for a package"))- <> command "pkg-config" (info (PkgConfig <$> package) (progDesc "Dump pkg-config path for a package")) -- TODO: make pkg-config recursive or something?+ <> command "pkg-config" (info (PkgConfig <$> some package) (progDesc "Dump pkg-config path for a package")) -- TODO: make pkg-config recursive or something? <> command "include" (info (IncludePath <$> package) (progDesc "Dump C_INCLUDE_PATH for a package")) <> command "library" (info (LibPath <$> package) (progDesc "Dump LD_LIBRARY_PATH or LIBRARY_PATH info for a package")) <> command "ld-path" (info (LdLibPath <$> some package) (progDesc "Dump LD_LIBRARY_PATH or LIBRARY_PATH for a package"))@@ -63,12 +66,15 @@ userCmd :: Parser Command userCmd = hsubparser (command "install" (info install (progDesc "Install a package from the global package set"))+ <> command "uninstall" (info uninstall (progDesc "Uninstall a package")) <> command "check" (info check (progDesc "Check a Dhall expression to ensure it can be used to build a package")) <> command "check-set" (info checkSet (progDesc "Check a package set defined in Dhall")) <> command "dump" (info dump (progDesc "Display flags to link against a particular library")) <> command "dump-cabal" (info dumpCabal (progDesc "Display flags to use with cabal new-build")) <> command "list" (info list (progDesc "List all available packages")) <> command "nuke" (info (pure Nuke) (progDesc "Remove all globally installed libraries"))+ <> command "nuke-cache" (info (pure NukeCache) (progDesc "Remove cached soure tarballs"))+ <> command "garbage-collect" (info garbageCollect' (progDesc "Garbage collect redundant packages")) ) list :: Parser Command@@ -80,6 +86,15 @@ dhallCompletions :: Mod ArgumentFields a dhallCompletions = ftypeCompletions "dhall" +uninstall :: Parser Command+uninstall = Uninstall+ <$> argument str+ (metavar "PACKAGE"+ <> help "Name of package to uninstall"+ <> completer (listIOCompleter allPackages))+ <*> verbosity+ <*> target+ install :: Parser Command install = Install <$> argument str@@ -108,6 +123,9 @@ (long "static" <> help "Build static libaries") +garbageCollect' :: Parser Command+garbageCollect' = GarbageCollect <$> verbosity+ check :: Parser Command check = Check <$> dhallFile <*> verbosity @@ -149,6 +167,9 @@ ) run :: Command -> IO ()+run (Uninstall pkId v host') = do+ parsedHost <- parseHostIO host'+ runPkgM v $ uninstallPkgByName pkId parsedHost run (Install pkId v host' sta glob pkSet) = do parsedHost <- parseHostIO host' runPkgM v $ buildByName (T.pack pkId) parsedHost pkSet sta glob@@ -156,7 +177,7 @@ run (CheckSet file' v) = void $ getPkgs v file' run (Dump (Linker name) host) = runPkgM Normal $ printLinkerFlags name host run (Dump (Compiler name) host) = runPkgM Normal $ printCompilerFlags name host-run (Dump (PkgConfig name) host) = runPkgM Normal $ printPkgConfigPath name host+run (Dump (PkgConfig names) host) = runPkgM Normal $ printPkgConfigPath names host run (Dump (IncludePath name) host) = runPkgM Normal $ printIncludePath name host run (Dump (LibPath name) host) = runPkgM Normal $ printLibPath name host run (Dump (LdLibPath names) host) = runPkgM Normal $ printLdLibPath names host@@ -166,7 +187,9 @@ exists <- doesDirectoryExist pkgDir when exists $ removeDirectoryRecursive pkgDir+run NukeCache = cleanCache run (List pkSet) = displayPackageSet pkSet+run (GarbageCollect v) = runPkgM v garbageCollect main :: IO () main = run =<< execParser wrapper
cpkg.cabal view
@@ -1,10 +1,10 @@ cabal-version: 1.18 name: cpkg-version: 0.2.2.0+version: 0.2.3.0 license: BSD3 license-file: LICENSE copyright: Copyright: (c) 2018-2019 Vanessa McHale-maintainer: vanessa.mchale@iohk.io+maintainer: vamchale@gmail.com author: Vanessa McHale synopsis: Build tool for C description:@@ -58,6 +58,7 @@ Package.C.Db.Register Package.C.Db.Monad Package.C.Db.Memory+ Package.C.Db.GarbageCollect Package.C.PackageSet Package.C.Logging System.Process.Ext@@ -95,7 +96,8 @@ network-uri -any, megaparsec -any, libarchive >=1.0.4.0,- dir-traverse >=0.2.1.0+ dir-traverse >=0.2.1.0,+ composition-prelude >=1.5.2.0 if (flag(development) && impl(ghc <=8.2)) ghc-options: -Werror
dhall/cpkg-prelude.dhall view
@@ -555,7 +555,6 @@ { pkgName = pkg.name , pkgVersion = pkg.version , pkgSubdir = "${pkg.name}-${showVersion pkg.version}"- , pkgBuildDeps = [ unbounded "make" ] } in @@ -1116,9 +1115,9 @@ let installPrefix = λ(cfg : types.BuildVars) → [ call (defaultCall ⫽ { program = "make"- , arguments = [ "prefix=${cfg.installDir}", "PREFIX=${cfg.installDir}", "install" ]- , environment = Some (buildEnv cfg)- })+ , arguments = [ "prefix=${cfg.installDir}", "PREFIX=${cfg.installDir}", "install" ]+ , environment = Some (buildEnv cfg)+ }) ] in
pkgs/pkg-set.dhall view
@@ -127,7 +127,6 @@ , prelude.copyFile wrapped wrapped , prelude.symlinkBinary wrapped ]- , pkgBuildDeps = [ prelude.unbounded "make" ] } in @@ -258,7 +257,6 @@ , pkgBuildDeps = [ prelude.unbounded "bison" , prelude.unbounded "gawk" , prelude.unbounded "python3"- , prelude.unbounded "make" ] } in@@ -355,7 +353,6 @@ { pkgUrl = "http://www.nasm.us/pub/nasm/releasebuilds/${prelude.showVersion v}.02/nasm-${prelude.showVersion v}.02.tar.xz" , pkgSubdir = "nasm-${prelude.showVersion v}.02" , installCommand = prelude.installWithBinaries [ "bin/nasm", "bin/ndisasm" ]- , pkgBuildDeps = [ prelude.unbounded "make" ] } in @@ -373,7 +370,6 @@ prelude.configureWithFlags ([ "--with-shared", "--enable-widec" ] # crossArgs) cfg -- enable-widec is necessary because util-linux uses libncursesw- , pkgBuildDeps = [ prelude.unbounded "make" ] } in @@ -386,9 +382,7 @@ let pcre = λ(v : List Natural) → prelude.simplePackage { name = "pcre", version = v } ⫽- { pkgUrl = "https://ftp.pcre.org/pub/pcre/pcre-${prelude.showVersion v}.tar.bz2"- , pkgBuildDeps = [ prelude.unbounded "make" ]- }+ { pkgUrl = "https://ftp.pcre.org/pub/pcre/pcre-${prelude.showVersion v}.tar.bz2" } in let perl5 =@@ -426,7 +420,6 @@ prelude.simplePackage { name = "libpng", version = v } ⫽ { pkgUrl = "https://download.sourceforge.net/libpng/libpng-${prelude.showVersion v}.tar.xz" , pkgDeps = [ prelude.unbounded "zlib" ]- , pkgBuildDeps = [ prelude.unbounded "make" ] } in @@ -536,9 +529,7 @@ let gettext = λ(v : List Natural) → prelude.makeGnuExe { name = "gettext", version = v } ⫽- { installCommand = prelude.installWithBinaries [ "bin/gettext", "bin/msgfmt", "bin/autopoint" ]- , pkgBuildDeps = [ prelude.unbounded "make" ]- }+ { installCommand = prelude.installWithBinaries [ "bin/gettext", "bin/msgfmt", "bin/autopoint" ] } in let gzip =@@ -653,7 +644,11 @@ let patch = λ(v : List Natural) → prelude.makeGnuExe { name = "patch", version = v } ⫽- { pkgBuildDeps = [] : List types.Dep }+ { installCommand =+ λ(cfg : types.BuildVars) →+ prelude.installWithBinaries [ "bin/patch" ] cfg+ # prelude.symlinkManpages [ { file = "share/man/man1/patch.1", section = 1 } ]+ } in let m4 =@@ -665,9 +660,7 @@ # prelude.defaultConfigure cfg , installCommand = prelude.installWithManpages [ { file = "share/man/man1/m4.1", section = 1 } ]- , pkgBuildDeps = [ prelude.unbounded "patch"- , prelude.unbounded "make"- ]+ , pkgBuildDeps = [ prelude.unbounded "patch" ] } in @@ -721,9 +714,7 @@ let giflib = λ(v : List Natural) → prelude.simplePackage { name = "giflib", version = v } ⫽- { pkgUrl = "https://downloads.sourceforge.net/giflib/giflib-${prelude.showVersion v}.tar.bz2"- , pkgBuildDeps = [ prelude.unbounded "make" ]- }+ { pkgUrl = "https://downloads.sourceforge.net/giflib/giflib-${prelude.showVersion v}.tar.bz2" } in let emacs =@@ -921,9 +912,7 @@ let libffi = λ(v : List Natural) → prelude.simplePackage { name = "libffi", version = v } ⫽- { pkgUrl = "https://sourceware.org/ftp/libffi/libffi-${prelude.showVersion v}.tar.gz"- , pkgBuildDeps = [ prelude.unbounded "make" ]- }+ { pkgUrl = "https://sourceware.org/ftp/libffi/libffi-${prelude.showVersion v}.tar.gz" } in let gdb =@@ -947,7 +936,6 @@ prelude.simplePackage { name = "pkg-config", version = v } ⫽ { pkgUrl = "https://pkg-config.freedesktop.org/releases/pkg-config-${prelude.showVersion v}.tar.gz" , configureCommand = prelude.configureWithFlags [ "--with-internal-glib" ]- , pkgBuildDeps = [ prelude.unbounded "make" ] } in @@ -1095,9 +1083,7 @@ λ(name : Text) → λ(v : List Natural) → prelude.simplePackage { name = name, version = v } ⫽- { pkgUrl = "https://www.x.org/releases/individual/proto/${name}-${prelude.showVersion v}.tar.bz2"- , pkgBuildDeps = [ prelude.unbounded "make" ]- }+ { pkgUrl = "https://www.x.org/releases/individual/proto/${name}-${prelude.showVersion v}.tar.bz2" } in let mkXProtoWithPatch =@@ -1106,9 +1092,7 @@ λ(v : List Natural) → mkXProto name v ⫽ { configureCommand = prelude.configureWithPatch patch- , pkgBuildDeps = [ prelude.unbounded "patch"- , prelude.unbounded "make"- ]+ , pkgBuildDeps = [ prelude.unbounded "patch" ] } in @@ -1757,9 +1741,7 @@ let xcb-proto = λ(v : List Natural) → prelude.simplePackage { name = "xcb-proto", version = v } ⫽- { pkgUrl = "https://xorg.freedesktop.org/archive/individual/xcb/xcb-proto-${prelude.showVersion v}.tar.bz2"- , pkgBuildDeps = [ prelude.unbounded "make" ]- }+ { pkgUrl = "https://xorg.freedesktop.org/archive/individual/xcb/xcb-proto-${prelude.showVersion v}.tar.bz2" } in let libxcb =@@ -1777,9 +1759,7 @@ let libpthread-stubs = λ(v : List Natural) → prelude.simplePackage { name = "libpthread-stubs", version = v } ⫽- { pkgUrl = "https://www.x.org/archive/individual/xcb/libpthread-stubs-${prelude.showVersion v}.tar.bz2"- , pkgBuildDeps = [ prelude.unbounded "make" ]- }+ { pkgUrl = "https://www.x.org/archive/individual/xcb/libpthread-stubs-${prelude.showVersion v}.tar.bz2" } in let xorgConfigure =@@ -1815,9 +1795,7 @@ λ(name : Text) → λ(v : List Natural) → prelude.simplePackage { name = name, version = v } ⫽- { pkgUrl = "https://www.x.org/releases/individual/util/${name}-${prelude.showVersion v}.tar.bz2"- , pkgBuildDeps = [ prelude.unbounded "make" ]- }+ { pkgUrl = "https://www.x.org/releases/individual/util/${name}-${prelude.showVersion v}.tar.bz2" } in let libXrender =@@ -1957,9 +1935,7 @@ let expat = λ(v : List Natural) → prelude.simplePackage { name = "expat", version = v } ⫽- { pkgUrl = "https://github.com/libexpat/libexpat/releases/download/R_${prelude.underscoreVersion v}/expat-${prelude.showVersion v}.tar.bz2"- , pkgBuildDeps = [ prelude.unbounded "make" ]- }+ { pkgUrl = "https://github.com/libexpat/libexpat/releases/download/R_${prelude.underscoreVersion v}/expat-${prelude.showVersion v}.tar.bz2" } in let gperf =@@ -2179,6 +2155,7 @@ , prelude.lowerBound { name = "libepoxy", lower = [1,4] } , prelude.unbounded "libXi" ]+ , pkgBuildDeps = [ prelude.unbounded "binutils" ] } in @@ -2285,6 +2262,7 @@ let libarchive = λ(v : List Natural) → prelude.simplePackage { name = "libarchive", version = v } ⫽+ -- https://github.com/libarchive/libarchive/releases/download/v3.4.0/libarchive-3.4.0.tar.gz { pkgUrl = "https://www.libarchive.org/downloads/libarchive-${prelude.showVersion v}.tar.gz" -- , pkgDeps = [ prelude.unbounded "libxml2" ] , pkgDeps = [ prelude.unbounded "xz"@@ -2424,6 +2402,7 @@ λ(cfg : types.BuildVars) → [ prelude.call (prelude.defaultCall ⫽ { program = prelude.makeExe cfg.buildOS }) ] , pkgDeps = [ prelude.unbounded "libXt" ]+ , pkgBuildDeps = [ prelude.unbounded "binutils" ] } in @@ -3274,7 +3253,7 @@ λ(v : List Natural) → prelude.simplePackage { name = "pHash", version = v } ⫽ { pkgUrl = "http://phash.org/releases/pHash-${prelude.showVersion v}.tar.gz"- , pkgDeps = [ prelude.unbounded "CImg"+ , pkgDeps = [ prelude.lowerBound { name = "CImg", lower = [1,3] } , prelude.unbounded "ffmpeg" , prelude.unbounded "libsndfile" , prelude.unbounded "libsamplerate"@@ -3530,9 +3509,7 @@ prelude.simplePackage { name = "blas", version = v } ⫽ { pkgUrl = "http://www.netlib.org/blas/blas-${prelude.showVersion v}.tgz" , pkgSubdir = "BLAS-${prelude.showVersion v}"- , pkgBuildDeps = [ prelude.unbounded "make"- , prelude.unbounded "gcc"- ]+ , pkgBuildDeps = [ prelude.unbounded "gcc" ] , configureCommand = prelude.doNothing , installCommand = λ(_ : types.BuildVars) →@@ -3546,9 +3523,7 @@ prelude.simplePackage { name = "openblas", version = v } ⫽ { pkgUrl = "https://github.com/xianyi/OpenBLAS/archive/v${versionString}.tar.gz" , pkgSubdir = "OpenBLAS-${versionString}"- , pkgBuildDeps = [ prelude.unbounded "make"- , prelude.unbounded "gcc"- ]+ , pkgBuildDeps = [ prelude.unbounded "gcc" ] , pkgDeps = [ prelude.unbounded "gcc" ] , configureCommand = prelude.doNothing , installCommand = prelude.installPrefix@@ -3565,13 +3540,12 @@ , pkgDeps = [ prelude.unbounded "readline" , prelude.unbounded "libXt" ]- , pkgBuildDeps = [ prelude.unbounded "make"- , prelude.unbounded "gcc"- ]+ , pkgBuildDeps = [ prelude.unbounded "gcc" ] , installCommand = prelude.installWithBinaries [ "bin/R", "bin/Rscript" ] } in +-- http://www.linuxfromscratch.org/lfs/view/development/chapter06/findutils.html -- TODO: musl-ghc? -- https://hub.darcs.net/raichoo/hikari -- https://versaweb.dl.sourceforge.net/project/schilytools/schily-2019-03-29.tar.bz2@@ -3585,7 +3559,7 @@ , at-spi-core { version = [2,33], patch = 2 } , atk { version = [2,33], patch = 3 } , babl { version = [0,1], patch = 60 }-, binutils [2,31]+, binutils [2,32] , bison [3,3,1] , blas [3,8,0] , bzip2 [1,0,6]
src/CPkgPrelude.hs view
@@ -8,8 +8,10 @@ , fold , toList , filterM+ , forM_ , ($>) , (<=<)+ , (<=*<) , MonadIO (..) , Void -- * Dhall reëxports@@ -30,9 +32,11 @@ , (</>) -- * Exports from "System.Directory" , doesFileExist+ , removeDirectoryRecursive , getAppUserDataDirectory ) where +import Control.Composition ((<=*<)) import Control.Monad import Control.Monad.IO.Class (MonadIO (..)) import Data.Binary (Binary)
src/Package/C.hs view
@@ -29,6 +29,9 @@ , printLdLibPath , printCabalFlags , buildByName+ , uninstallPkgByName+ , garbageCollect+ , cleanCache -- * Dhall functionality , cPkgDhallToCPkg , getCPkg@@ -44,6 +47,7 @@ import Package.C.Build import Package.C.Build.Tree+import Package.C.Db.GarbageCollect import Package.C.Db.Monad import Package.C.Db.Register import Package.C.Db.Type
src/Package/C/Build.hs view
@@ -117,12 +117,13 @@ -> Maybe TargetTriple -> Bool -- ^ Should we build static libraries? -> Bool -- ^ Should we install globally?+ -> Bool -- ^ Was this package installed manually? -> [FilePath] -- ^ Shared data directories -> [FilePath] -- ^ Library directories -> [FilePath] -- ^ Include directories -> [FilePath] -- ^ Directories to add to @PATH@ -> PkgM ()-buildCPkg cpkg host sta glob shr libs incls bins = do+buildCPkg cpkg host sta glob usr shr libs incls bins = do buildVars <- getVars host sta shr libs incls bins @@ -133,7 +134,7 @@ putDiagnostic ("Package " ++ pkgName cpkg ++ " already installed, skipping.") unless installed $- forceBuildCPkg cpkg host glob buildVars+ forceBuildCPkg cpkg host glob usr buildVars getPreloads :: [ FilePath ] -> IO [ FilePath ] getPreloads =@@ -170,9 +171,10 @@ forceBuildCPkg :: CPkg -> Maybe TargetTriple -> Bool+ -> Bool -- ^ Manually installed? -> BuildVars -> PkgM ()-forceBuildCPkg cpkg host glob buildVars = do+forceBuildCPkg cpkg host glob usr buildVars = do pkgDir <- cPkgToDir cpkg host glob buildVars @@ -202,4 +204,4 @@ installInDir cpkg buildConfigured p' pkgDir - registerPkg cpkg host glob buildVars -- not configured+ registerPkg cpkg host glob usr buildVars -- not configured
src/Package/C/Build/Tree.hs view
@@ -21,7 +21,7 @@ getAll :: [BuildDirs] -> BuildDirs getAll bds =- let go f = fold (f <$> bds)+ let go f = concat (f <$> bds) in BuildDirs (go libraries) (go share) (go include) (go binaries) -- in order to prevent the "vanilla" libffi from preceding the *cross* libffi,@@ -51,12 +51,13 @@ buildWithContext cTree host sta glob = zygoM' dirAlg buildAlg cTree where buildAlg :: DepTreeF CPkg (BuildDirs, ()) -> PkgM ()- buildAlg (DepNodeF c preBds) =- buildCPkg c host sta glob ds (immoralFilter host ls) is (filterCross host bs)+ buildAlg (DepNodeF c usr preBds) =+ buildCPkg c host sta glob usr ds (immoralFilter host ls) is (filterCross host bs) where (BuildDirs ls ds is bs) = getAll (fst <$> preBds) buildAlg (BldDepNodeF c preBds) =- buildCPkg c Nothing False False ds ls is bs -- don't use static libraries for build dependencies- -- also don't install them globally for obvious reasons+ buildCPkg c Nothing False False False ds ls is bs -- don't use static libraries for build dependencies+ -- also don't install them globally+ -- build dependencies are not manual! where (BuildDirs ls ds is bs) = getAll (fst <$> preBds) mkBuildDirs :: MonadIO m => FilePath -> BuildDirs -> m BuildDirs@@ -79,7 +80,7 @@ pure (BuildDirs (nubOrd links) (nubOrd shares) (nubOrd includes) (nubOrd bins)) dirAlg :: DepTreeF CPkg BuildDirs -> PkgM BuildDirs- dirAlg (DepNodeF c bds) = do+ dirAlg (DepNodeF c _ bds) = do let bldDirs@(BuildDirs ls ds is bs) = getAll bds @@ -100,6 +101,7 @@ mkBuildDirs pkgDir bldDirs -- TODO: should this parse a string into a TargetTriple instead?+-- | Manually install a package buildByName :: PackId -> Maybe TargetTriple -> Maybe String -> Bool -> Bool -> PkgM () buildByName pkId host pkSet sta glob = do allPkgs <- liftIO (pkgsM pkId pkSet)
+ src/Package/C/Db/GarbageCollect.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE FlexibleContexts #-}++module Package.C.Db.GarbageCollect ( cleanSymlinks+ , cleanCache+ , garbageCollect+ ) where++import Control.Monad.Reader (MonadReader)+import CPkgPrelude+import qualified Data.Set as S+import qualified Data.Text as T+import Package.C.Db.Memory (globalPkgDir)+import Package.C.Db.Monad (MonadDb)+import Package.C.Db.Register+import Package.C.Db.Type+import Package.C.Logging (putDiagnostic)+import Package.C.Type (TargetTriple, Verbosity)+import System.Directory (doesDirectoryExist, doesFileExist, getSymbolicLinkTarget, listDirectory, removeDirectoryRecursive, removeFile)+import System.FilePath ((</>))++getTransitiveDepsByName :: (MonadIO m, MonadDb m) => String -> Maybe TargetTriple -> m (S.Set BuildCfg)+getTransitiveDepsByName = getTransitiveDeps <=*< lookupOrFail++garbageCollect :: (MonadIO m, MonadDb m, MonadReader Verbosity m)+ => m ()+garbageCollect = garbageCollectPkgs *> cleanSymlinks++-- TODO: garbage collect old packages as well, and things which are broken b/c+-- their dependencies are gone+--+-- | @since 0.2.3.0+garbageCollectPkgs :: (MonadIO m, MonadDb m, MonadReader Verbosity m)+ => m ()+garbageCollectPkgs = do+ allPkgs <- installedDb+ let manuals = (toList . S.filter manual) allPkgs+ putDiagnostic ("Manually installed packages: " ++ show (buildName <$> manuals))+ allDeps <- S.unions <$> traverse getTransitiveDeps manuals+ let redundant = allPkgs S.\\ allDeps+ putDiagnostic ("Redundant packages: " ++ show (buildName <$> toList redundant))+ traverse_ uninstallPkg redundant++getTransitiveDeps :: (MonadIO m, MonadDb m) => BuildCfg -> m (S.Set BuildCfg)+getTransitiveDeps cfg = do+ let names = fst <$> pinnedDeps cfg+ host = targetArch cfg+ next <- traverse (\n -> getTransitiveDepsByName n host) (T.unpack <$> names)+ pure $ S.insert cfg (S.unions next)++-- | @since 0.2.3.0+cleanCache :: MonadIO m => m ()+cleanCache = liftIO $ do+ ccDir <- (</> "cache") <$> globalPkgDir+ exists <- doesDirectoryExist ccDir+ when exists $+ removeDirectoryRecursive ccDir++cleanSymlinks :: (MonadReader Verbosity m, MonadIO m) => m ()+cleanSymlinks = do+ pkDir <- liftIO globalPkgDir+ let binDir = pkDir </> "bin"+ manDir = pkDir </> "share" </> "man"+ man1Dir = manDir </> "man1"+ man3Dir = manDir </> "man3"+ traverse_ cleanDir+ [binDir, man1Dir, man3Dir]+++cleanDir :: (MonadReader Verbosity m, MonadIO m) => FilePath -> m ()+cleanDir dir = do+ exists <- liftIO $ doesDirectoryExist dir+ when exists $ do+ links <- liftIO $ listDirectory dir+ forM_ links $ \link -> do+ let linkAbs = dir </> link+ brk <- liftIO $ isBroken linkAbs+ when brk $+ putDiagnostic ("Removing link " ++ linkAbs ++ "...") *>+ liftIO (removeFile linkAbs)++isBroken :: FilePath -> IO Bool+isBroken = (fmap not . doesFileExist) <=< getSymbolicLinkTarget++-- getSymbolicLinkTarget
src/Package/C/Db/Register.hs view
@@ -4,6 +4,11 @@ -- TODO: a lot of the stuff in this module could be made pure so that it only -- gets called once module Package.C.Db.Register ( registerPkg+ , unregisterPkg+ , uninstallPkg+ , uninstallPkgByName+ , installedDb+ , lookupOrFail , cPkgToDir , globalPkgDir , printCompilerFlags@@ -50,8 +55,8 @@ printLinkerFlags :: (MonadIO m, MonadDb m) => String -> Maybe Platform -> m () printLinkerFlags = printFlagsWith buildCfgToLinkerFlags -printPkgConfigPath :: (MonadIO m, MonadDb m) => String -> Maybe Platform -> m ()-printPkgConfigPath = printFlagsWith buildCfgToPkgConfigPath+printPkgConfigPath :: (MonadIO m, MonadDb m) => [String] -> Maybe Platform -> m ()+printPkgConfigPath = printMany (liftIO . putStrLn <=< (fmap (intercalate ":") . traverse buildCfgToPkgConfigPath)) printIncludePath :: (MonadIO m, MonadDb m) => String -> Maybe Platform -> m () printIncludePath = printFlagsWith buildCfgToIncludePath@@ -111,6 +116,11 @@ buildCfgToIncludePath :: MonadIO m => BuildCfg -> m String buildCfgToIncludePath = fmap (</> "include") . buildCfgToDir +installedDb :: (MonadIO m, MonadDb m)+ => m (S.Set BuildCfg)+installedDb =+ _installedPackages <$> memIndex+ packageInstalled :: (MonadIO m, MonadDb m) => CPkg -> Maybe TargetTriple@@ -119,34 +129,77 @@ -> m Bool packageInstalled pkg host glob b = do - indexContents <- memIndex+ packs <- installedDb - pure (pkgToBuildCfg pkg host glob b `S.member` _installedPackages indexContents)+ pure $+ (pkgToBuildCfg pkg host glob True b `S.member` packs)+ || (pkgToBuildCfg pkg host glob False b `S.member` packs) lookupPackage :: (MonadIO m, MonadDb m) => String -> Maybe TargetTriple -> m (Maybe BuildCfg) lookupPackage name host = do - indexContents <- memIndex+ packs <- installedDb - let matches = S.filter (\pkg -> buildName pkg == name && targetArch pkg == host) (_installedPackages indexContents)+ let matches = S.filter (\pkg -> buildName pkg == name && targetArch pkg == host) packs pure (S.lookupMax matches) +lookupOrFail :: (MonadIO m, MonadDb m) => String -> Maybe TargetTriple -> m BuildCfg+lookupOrFail name host = do+ pk <- lookupPackage name host+ case pk of+ Just cfg -> pure cfg+ Nothing -> notInstalled name++-- | @since 0.2.3.0+uninstallPkgByName :: (MonadReader Verbosity m, MonadIO m, MonadDb m)+ => String+ -> Maybe TargetTriple+ -> m ()+uninstallPkgByName name host =+ uninstallPkg =<< lookupOrFail name host++uninstallPkg :: (MonadIO m, MonadDb m, MonadReader Verbosity m)+ => BuildCfg+ -> m ()+uninstallPkg cpkg = do+ unregisterPkg cpkg+ (liftIO . removeDirectoryRecursive)+ =<< buildCfgToDir cpkg++unregisterPkg :: (MonadIO m, MonadDb m, MonadReader Verbosity m)+ => BuildCfg+ -> m ()+unregisterPkg buildCfg = do++ putLoud ("Unregistering package " ++ buildName buildCfg ++ "...")++ indexFile <- pkgIndex+ indexContents <- memIndex++ let modIndex = over installedPackages (S.delete buildCfg)+ newIndex = modIndex indexContents++ modify modIndex++ liftIO $ BSL.writeFile indexFile (encode newIndex)+ -- TODO: replace this with a proper/sensible database registerPkg :: (MonadIO m, MonadDb m, MonadReader Verbosity m) => CPkg -> Maybe TargetTriple- -> Bool+ -> Bool -- ^ Globally installed?+ -> Bool -- ^ Manually installed? -> BuildVars -> m ()-registerPkg cpkg host glob b = do+registerPkg cpkg host glob usr b = do putDiagnostic ("Registering package " ++ pkgName cpkg ++ "...") indexFile <- pkgIndex indexContents <- memIndex - let buildCfg = pkgToBuildCfg cpkg host glob b+ let buildCfg = pkgToBuildCfg cpkg host glob usr b modIndex = over installedPackages (S.insert buildCfg) newIndex = modIndex indexContents @@ -157,10 +210,13 @@ pkgToBuildCfg :: CPkg -> Maybe TargetTriple -> Bool+ -> Bool -- ^ Was this package manually installed? -> BuildVars -> BuildCfg-pkgToBuildCfg (CPkg n v _ _ _ _ _ cCmd bCmd iCmd) host glob bVar =- BuildCfg n v mempty mempty host glob (cCmd bVar) (bCmd bVar) (iCmd bVar) -- TODO: fix pinned build deps &c.+pkgToBuildCfg (CPkg n v _ _ _ bds ds cCmd bCmd iCmd) host glob usr bVar =+ BuildCfg n v (go <$> bds) (go <$> ds) host glob (cCmd bVar) (bCmd bVar) (iCmd bVar) usr -- TODO: fix pinned build deps &c.+ where placeholderVersion = Version [0,1,0,0]+ go (Dep n' _) = (n', placeholderVersion) platformString :: Maybe TargetTriple -> (FilePath -> FilePath -> FilePath) platformString Nothing = (</>)@@ -169,7 +225,9 @@ buildCfgToDir :: MonadIO m => BuildCfg -> m FilePath buildCfgToDir buildCfg = do global' <- globalPkgDir- let hashed = showHex (abs (hash buildCfg)) mempty+ -- when hashing, pretend everything has was NOT manually installed so they+ -- all have the same hash+ let hashed = showHex (abs (hash (buildCfg { manual = False}))) mempty (<?>) = platformString (targetArch buildCfg) pure (global' <?> buildName buildCfg ++ "-" ++ showVersion (buildVersion buildCfg) ++ "-" ++ hashed) @@ -183,5 +241,5 @@ -> Bool -> BuildVars -> m FilePath-cPkgToDir pk host False bv = buildCfgToDir (pkgToBuildCfg pk host False bv)+cPkgToDir pk host False bv = buildCfgToDir (pkgToBuildCfg pk host False undefined bv) cPkgToDir _ host _ _ = pure (globDir host)
src/Package/C/Db/Type.hs view
@@ -32,4 +32,6 @@ , configureCmds :: [ Command ] , buildCmds :: [ Command ] , installCmds :: [ Command ]+ -- , tarball :: FilePath+ , manual :: Bool -- ^ Was this package manually installed? } deriving (Eq, Ord, Generic, Binary, Hashable)
src/Package/C/Error.hs view
@@ -6,6 +6,7 @@ , corruptedDatabase , unfoundPackage , parseErr+ , notInstalled , PackageError (..) ) where @@ -19,18 +20,23 @@ | IndexError String -- package name | CorruptedDatabase | UnfoundPackage -- TODO: this should take the package name as an argument+ | NotInstalled String | ParseFailed String -- TODO: libarchive error instance Pretty PackageError where- pretty (Unrecognized t) = "Error: Unrecognized archive format when unpacking" <#> hang 2 (pretty t) <> hardline- pretty (IndexError str) = "Error: Package" <+> pretty str <+> "not found in your indices. Try 'cpkg install" <+> pretty str <> "'." <> hardline- pretty CorruptedDatabase = "Error: Package database corrupted. Please try 'cpkg nuke'" <> hardline- pretty UnfoundPackage = "Error: Package not found" <> hardline- pretty (ParseFailed str) = "Parse error:" <+> pretty str+ pretty (Unrecognized t) = "Error: Unrecognized archive format when unpacking" <#> hang 2 (pretty t) <> hardline+ pretty (IndexError str) = "Error: Package" <+> pretty str <+> "not found in your indices. Try 'cpkg install" <+> pretty str <> "'." <> hardline+ pretty CorruptedDatabase = "Error: Package database corrupted. Please try 'cpkg nuke'" <> hardline+ pretty UnfoundPackage = "Error: Package not found" <> hardline+ pretty (ParseFailed str) = "Parse error:" <+> pretty str+ pretty (NotInstalled pkg) = "Package" <+> pretty pkg <+> "is not installed, so not removed." <> hardline printErr :: MonadIO m => PackageError -> m a printErr e = liftIO (putDoc (pretty e) *> exitFailure)++notInstalled :: MonadIO m => String -> m a+notInstalled = printErr . NotInstalled unrecognized :: MonadIO m => String -> m a unrecognized = printErr . Unrecognized
src/Package/C/PackageSet.hs view
@@ -45,20 +45,20 @@ in PackageSet $ M.fromList (zip names pkgs') -getDeps :: PackId -> PackageSet -> Maybe (DepTree PackId)-getDeps pkgName' set@(PackageSet ps) = do+getDeps :: PackId -> Bool -> PackageSet -> Maybe (DepTree PackId)+getDeps pkgName' usr set@(PackageSet ps) = do cpkg <- M.lookup pkgName' ps let depNames = name <$> pkgDeps cpkg bldDepNames = name <$> pkgBuildDeps cpkg ds = nubOrd depNames bds = nubOrd bldDepNames- nextDeps <- traverse (\p -> getDeps p set) ds- nextBldDeps <- traverse (\p -> asBldDep <$> getDeps p set) bds- pure $ DepNode pkgName' (nextDeps ++ nextBldDeps)+ nextDeps <- traverse (\p -> getDeps p False set) ds+ nextBldDeps <- traverse (\p -> asBldDep <$> getDeps p False set) bds+ pure $ DepNode pkgName' usr (nextDeps ++ nextBldDeps) -- TODO: use dfsForest but check for cycles pkgPlan :: PackId -> PackageSet -> Maybe (DepTree PackId)-pkgPlan = getDeps+pkgPlan pkId = getDeps pkId True -- manually installed pkgs :: PackId -> PackageSet -> Maybe (DepTree CPkg) pkgs pkId set@(PackageSet pset) = do
src/Package/C/Type/Tree.hs view
@@ -12,16 +12,16 @@ import Control.Recursion import GHC.Generics (Generic) -data DepTree p = DepNode p [DepTree p]+data DepTree p = DepNode p Bool [DepTree p] | BldDepNode p [DepTree p] deriving (Functor, Foldable, Traversable, Generic, Recursive) -data DepTreeF p x = DepNodeF { self :: p, deps :: [x] }+data DepTreeF p x = DepNodeF { self :: p, man :: Bool, deps :: [x] } | BldDepNodeF { self :: p, deps :: [x] } deriving (Functor, Foldable, Traversable, Generic) type instance Base (DepTree a) = DepTreeF a asBldDep :: DepTree p -> DepTree p-asBldDep (DepNode p ps) = BldDepNode p (fmap asBldDep ps)+asBldDep (DepNode p _ ps) = BldDepNode p (fmap asBldDep ps) asBldDep (BldDepNode p ps) = BldDepNode p (fmap asBldDep ps)