diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,5 @@ +0.1.0.0 +======= + +- Initial release. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Abhinav Gupta + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Applicative +import Control.Monad +import Data.List (stripPrefix) +import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.Monoid +import Data.Set (Set) +import Data.Text (Text) +import System.Directory (canonicalizePath, copyFile, + createDirectoryIfMissing, doesDirectoryExist, + doesFileExist, findExecutable, getHomeDirectory, + removeFile) +import System.Exit (ExitCode (..)) +import System.FilePath (splitDirectories, takeDirectory, takeFileName, + ()) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import qualified Distribution.InstalledPackageInfo as PInfo +import qualified Distribution.Text as Cabal +import qualified Options.Applicative as O +import qualified System.Process as Proc + +import Sandman.InstalledPackage +import Sandman.PackageDb +import Sandman.Util + +------------------------------------------------------------------------------ +-- | Main context for the program. +-- +-- Currently this just consists of the root directory where all sandman files +-- will be stored. +newtype Sandman = Sandman { sandmanDirectory :: FilePath } + deriving (Show, Ord, Eq) + + +-- | Build the context with default settings. +defaultSandman :: IO Sandman +defaultSandman = do + home <- getHomeDirectory + return $! Sandman (home ".sandman") + + +-- | Path to the directory which will hold the sandboxes. +sandboxesDirectory :: Sandman -> FilePath +sandboxesDirectory Sandman{sandmanDirectory} = + sandmanDirectory "sandboxes" + + +-- | Get all managed sandboxes. +getSandboxes :: Sandman -> IO [Sandbox] +getSandboxes sandman = do + exists <- doesDirectoryExist sandboxesDir + if exists + then map Sandbox <$> listDirectory sandboxesDir + else return [] + where + sandboxesDir = sandboxesDirectory sandman + + +-- | Get the sandbox with the given name. +getSandbox :: Sandman -> Text -> IO (Maybe Sandbox) +getSandbox sandman name = do + exists <- doesDirectoryExist sandboxDir + if exists + then return . Just . Sandbox $ sandboxDir + else return Nothing + where + sandboxDir = sandboxesDirectory sandman T.unpack name + + +------------------------------------------------------------------------------ +-- | Represents a cabal sandbox. +newtype Sandbox = Sandbox { + sandboxRoot :: FilePath + -- ^ Path to the sandbox root. + -- + -- Note: This is /not/ the project root. It just happens to be that the + -- project root and sandbox root is the same for managed sandboxes. + } deriving (Show, Ord, Eq) + + +-- | Name of the sandbox. +sandboxName :: Sandbox -> Text +sandboxName = T.pack . takeFileName . sandboxRoot + + +-- | Create a new managed sandbox with the given name. +createSandbox :: Sandman -> Text -> IO Sandbox +createSandbox sandman name = do + whenM (doesDirectoryExist sandboxDir) $ + die $ "Sandbox " <> name <> " already exists." + + createDirectoryIfMissing True sandboxDir + + let proc = (Proc.proc "cabal" ["sandbox", "init", "--sandbox=."]) { + Proc.cwd = Just sandboxDir + } + + (_, _, _, procHandle) <- Proc.createProcess proc + exitResult <- Proc.waitForProcess procHandle + case exitResult of + ExitSuccess -> return $! Sandbox sandboxDir + ExitFailure _ -> die $ "Failed to create sandbox " <> name + where + sandboxDir = sandboxesDirectory sandman T.unpack name + +-- | Install the specified packages into the sandbox. +installPackages :: Sandbox -> [Text] -> IO () +installPackages sandbox@Sandbox{sandboxRoot} packages = do + (_, _, _, procHandle) <- Proc.createProcess proc + exitResult <- Proc.waitForProcess procHandle + case exitResult of + ExitSuccess -> return () + ExitFailure _ -> die $ "Failed to install packages to " <> name + where + name = sandboxName sandbox + proc = (Proc.proc "cabal" $ ["install"] <> map T.unpack packages) { + Proc.cwd = Just sandboxRoot + } + +------------------------------------------------------------------------------ + +-- TODO probably need another data type for Projects. + +getPackageGhcPath :: FilePath -> IO (Maybe FilePath) +getPackageGhcPath packageRoot = do + hasConfig <- doesFileExist cabalConfigPath + if not hasConfig + then return Nothing + else TIO.readFile cabalConfigPath + <&> map readField . T.lines + <&> filter (("with-compiler" ==) . fst) + <&> fmap (T.unpack . snd) . listToMaybe + where + readField line = (T.strip k, T.strip $ T.drop 1 v) + where (k, v) = T.breakOn ":" $ T.strip line + cabalConfigPath = packageRoot "cabal.config" + + +setPackageGhcPath :: FilePath -> FilePath -> IO () +setPackageGhcPath packageRoot ghc = do + hasConfig <- doesFileExist cabalConfigPath + if not hasConfig + then TIO.writeFile cabalConfigPath entry + else TIO.readFile cabalConfigPath + <&> T.unlines . loop [] . T.lines + >>= TIO.writeFile cabalConfigPath + where + entry = "with-compiler: " <> T.pack ghc + cabalConfigPath = packageRoot "cabal.config" + loop outLines [] = reverse outLines + loop outLines (x:xs) + | "with-compiler" `T.isPrefixOf` T.strip x + = loop (entry:outLines) xs + | otherwise = loop (x:outLines) xs + + + +-- | Get the PackageDb for the given package. +-- +-- The package root is the directory containing the @cabal.sandbox.config@. +determinePackageDb :: FilePath -> IO (Either String PackageDb) +determinePackageDb packageRoot = do + -- TODO check if sandboxConfig exists + matches <- TIO.readFile sandboxConfig + <&> filter ("package-db:" `T.isPrefixOf`) . T.lines + case listToMaybe matches of + Nothing -> return . Left $ + "Could not determine package DB for " ++ packageRoot + Just line -> + let right = T.drop 1 $ T.dropWhile (/= ':') line + value = T.dropWhile (\c -> c == ' ' || c == '\t') right + root = T.unpack value + in getPackageDb root + where + sandboxConfig = packageRoot "cabal.sandbox.config" + +-- | Get the base package DB given the path to GHC. +-- +-- Uses the default GHC if given @Nothing@. +getBasePackageDb :: Maybe FilePath -> IO (Either String PackageDb) +getBasePackageDb ghcPath' = + Proc.readProcess ghcPath ["--print-global-package-db"] "" + <&> T.unpack . T.strip . T.pack + >>= getPackageDb + where + ghcPath = fromMaybe "ghc" ghcPath' + +-- | Get the number of packages installed in the given package DB. +installedPackageCount :: PackageDb -> Int +installedPackageCount = length . packageDbInstalledPackages + + +------------------------------------------------------------------------------ +list :: IO () +list = do + sandman <- defaultSandman -- FIXME + sandboxes <- getSandboxes sandman + when (null sandboxes) $ + putStrLn "No sandboxes created." + forM_ sandboxes $ \sandbox -> do + let name = sandboxName sandbox + packageDb' <- determinePackageDb (sandboxRoot sandbox) + case packageDb' of + Left err -> do + warn (T.pack err) + TIO.putStrLn $ name <> "(ERROR: could not read package DB)" + Right packageDb -> do + let packageCount = installedPackageCount packageDb + TIO.putStrLn $ T.unwords + [name, "(" <> tshow packageCount, "packages)"] + + +------------------------------------------------------------------------------ +new :: Maybe FilePath -> Text -> IO () +new ghcPath' name = do + ghcPath <- maybe (return Nothing) + (fmap Just . resolveExecutable) + ghcPath' + sandman <- defaultSandman -- FIXME + Sandbox{sandboxRoot} <- createSandbox sandman name + maybe (return ()) + (setPackageGhcPath sandboxRoot) + ghcPath + TIO.putStrLn $ "Created sandbox " <> name <> "." + where + resolveExecutable path = do + exists <- doesFileExist path + if exists + then canonicalizePath path + else + findExecutable path >>= + maybe (die $ "Could not find GHC at " <> T.pack path) return + +------------------------------------------------------------------------------ +destroy :: Text -> IO () +destroy name = do + sandman <- defaultSandman + Sandbox{sandboxRoot} <- getSandbox sandman name + >>= maybe (die $ "Sandbox " <> name <> " does not exist.") return + removeTree sandboxRoot + TIO.putStrLn $ "Removed sandbox " <> name <> "." + + +------------------------------------------------------------------------------ +install :: Text -> [Text] -> IO () +install name packages = do + -- TODO parse package IDs + sandman <- defaultSandman + sandbox <- getSandbox sandman name + >>= maybe (die $ "Sandbox " <> name <> " does not exist.") return + installPackages sandbox packages + + +------------------------------------------------------------------------------ +listPackages :: Text -> IO () +listPackages name = do + sandman <- defaultSandman + -- TODO get rid of all this duplication + sandbox <- getSandbox sandman name + >>= maybe (die $ "Sandbox " <> name <> " does not exist.") return + packageDb <- determinePackageDb (sandboxRoot sandbox) + >>= either fail return + let packageIds = packageDbInstalledPackages packageDb + <&> installedPackageId + + when (null packageIds) $ + dieHappy $ name <> " does not contain any packages." + + forM_ packageIds TIO.putStrLn + + +------------------------------------------------------------------------------ +mix :: [Text] -> Bool -> Text -> IO () +mix packageNames includeExecutables name = do + currentPackageDb <- determinePackageDb "." >>= either fail return + + sandman <- defaultSandman + sandbox <- getSandbox sandman name + >>= maybe (die $ "Sandbox " <> name <> " does not exist.") return + sandboxPackageDb <- determinePackageDb (sandboxRoot sandbox) + >>= either fail return + + let sandboxPackageNames = Set.fromList . map installedPackageName $ + packageDbInstalledPackages sandboxPackageDb + + -- Make sure that all requested packages are installed. + forM_ packageNames $ \requestedPackage -> + unless (requestedPackage `Set.member` sandboxPackageNames) $ + die $ requestedPackage <> " is not installed in " <> name + + basePackageIds <- getPackageGhcPath (sandboxRoot sandbox) + >>= getBasePackageDb >>= either fail return + <&> map installedPackageId . packageDbInstalledPackages + + let -- Returns True if another package with the same name has already been + -- installed to the target sandbox + isAlreadyInstalled = + (`Set.member` alreadyInstalled) . installedPackageName + where + alreadyInstalled = Set.fromList . map installedPackageName $ + packageDbInstalledPackages currentPackageDb + + + -- Reverse mapping from Cabal's InstalledPackageId to InstalledPackage + -- for all packages in the managed sandbox + installedPackageIdIndex = Map.fromList $ do + installedPackage <- packageDbInstalledPackages sandboxPackageDb + let pinfo = installedPackageInfo installedPackage + return (PInfo.installedPackageId pinfo, installedPackage) + + -- Reverse mapping from package names to InstalledPackages for all + -- packages in the managed sandbox + installedPackageNameIndex = Map.fromList $ do + installedPackage <- packageDbInstalledPackages sandboxPackageDb + return (installedPackageName installedPackage, installedPackage) + + isBase pkgId' = any (`T.isPrefixOf` pkgId) basePackageIds + where pkgId = T.pack $ Cabal.display pkgId' + + -- Get the InstalledPackage objects for the direct dependencies of the + -- given InstaledPackage + getDirectDependencies pkg = do + dep <- PInfo.depends (installedPackageInfo pkg) + if isBase dep then mzero else + case dep `Map.lookup` installedPackageIdIndex of + Nothing -> error $ unwords [ + "Installed package", T.unpack (installedPackageName pkg) + , "depends on", Cabal.display dep + , "which is not installed in sandbox", T.unpack name + ] + Just depPkg -> return depPkg + + -- Get the InstalledPackage objects for all dependencies of the given + -- InstaledPackage. + -- + -- This includes dependencies of dependencies and so on. + getDependencies _pkg = loop Set.empty [] [_pkg] + where + loop _ result [] = result + loop visited result (pkg:pkgs) + | pname `Set.member` visited = loop visited result pkgs + | otherwise = + loop (pname `Set.insert` visited) + (pkg:result) + (pkgs ++ getDirectDependencies pkg) + where + pname = installedPackageName pkg + + -- Names of requested packages and their dependencies + requestedPackages :: Set Text + requestedPackages = Set.fromList $ do + pkgName <- packageNames + case pkgName `Map.lookup` installedPackageNameIndex of + Nothing -> error $ unwords [ + "Requested package", T.unpack pkgName + , "is not installed in sandbox", T.unpack name + ] + Just installedPkg -> do + depPkg <- getDependencies installedPkg + [pkgName, installedPackageName depPkg] + + -- Whether a package was requested for installation. + -- + -- Always returns True if --only was skipped. If --only was given, + -- returns true only for requested packages and their dependencies. + isRequested = if null packageNames then const True else + (`Set.member` requestedPackages) . installedPackageName + + -- Returns True if the package should be installed + shouldInstall pkg = isRequested pkg && not (isAlreadyInstalled pkg) + + -- List of packages that will be installed + packagesToInstall = filter shouldInstall $ + packageDbInstalledPackages sandboxPackageDb + + newPackageCount = length packagesToInstall + + when (newPackageCount == 0) $ + dieHappy "No packages to mix in." + + putStrLn $ unwords [ + "Mixing", show newPackageCount + , "new packages into package DB at" + , packageDbRoot currentPackageDb + ] + + let currentPackageDbRoot = packageDbRoot currentPackageDb + forM_ packagesToInstall $ \installedPackage -> do + let currentPath = installedPackageInfoPath installedPackage + newPath = currentPackageDbRoot takeFileName currentPath + copyFile currentPath newPath + + executables <- listDirectory (sandboxRoot sandbox "bin") + when (includeExecutables && not (null executables)) $ do + let newBinDir = takeDirectory currentPackageDbRoot "bin" + createDirectoryIfMissing True newBinDir + forM_ executables $ \exec -> do + let newPath = newBinDir takeFileName exec + alreadyExists <- doesFileExist newPath + unless alreadyExists $ copyFile exec newPath + + ghcPath <- getPackageGhcPath (sandboxRoot sandbox) + case ghcPath of + Nothing -> return () + Just path -> do + putStrLn $ "Setting GHC version for project to " ++ path + setPackageGhcPath "." path + + putStrLn "Rebuilding package cache." + Proc.callProcess "cabal" ["sandbox", "hc-pkg", "recache"] + +------------------------------------------------------------------------------ +clean :: IO () +clean = do + currentPackageDb <- determinePackageDb "." >>= either fail return + sandman <- defaultSandman + putStrLn "Removing all mixed sandboxes." + + let packages = filterPackages sandman $ + packageDbInstalledPackages currentPackageDb + + when (null packages) $ + dieHappy "No packages to remove." + + forM_ packages $ removeFile . installedPackageInfoPath + putStrLn $ "Removed " <> show (length packages) <> " packages." + + putStrLn "Rebuilding package cache." + Proc.callProcess "cabal" ["sandbox", "hc-pkg", "recache"] + where + -- FIXME this will probably cause all kinds of trouble if one managed + -- sandbox is mixed into another. That should be disallowed or this should + -- be smarter. + filterPackages :: Sandman -> [InstalledPackage] -> [InstalledPackage] + filterPackages Sandman{sandmanDirectory} = filter isMixedIn + where + isSandmanPath p = isJust $ + stripPrefix (splitDirectories sandmanDirectory) + (splitDirectories p) + + isMixedIn installedPackage = any isSandmanPath $ + concatMap ($ packageInfo) [ + PInfo.importDirs + , PInfo.libraryDirs + , PInfo.haddockInterfaces + ] + where + packageInfo = installedPackageInfo installedPackage + + +------------------------------------------------------------------------------ +argParser :: O.Parser (IO ()) +argParser = O.subparser $ mconcat [ + -- TODO come up with a better name for managed sandboxes than "sandman + -- sandboxes" + command "list" "List sandman sandboxes or the packages in them" $ + maybe list listPackages <$> listNameArgument + , command "new" "Create a new sandman sandbox" $ + new <$> newOptions + <*> nameArgument + , command "destroy" "Delete a sandman sandbox" $ + destroy <$> nameArgument + , command "install" "Install a new package" $ + install <$> nameArgument <*> packagesArgument + , command "mix" "Mix a sandman sandbox into the current project" $ + mix <$> many (T.pack <$> packageNameOption) + <*> includeExecutablesOption + <*> nameArgument + , command "clean" "Remove all mixed sandboxes from the current project" $ + pure clean + ] + where + includeExecutablesOption = O.switch $ + O.long "executables" <> O.short 'x' <> + O.help "Mix executables from the managed sandbox into the project." + packageNameOption = O.strOption $ + O.long "only" <> O.short 'o' <> O.metavar "PACKAGE" <> + O.help (unwords [ + "If added, only the specified packages (and their dependencies)" + , "will be mixed in. This option may be specified multiple times." + ]) + newOptions = O.optional . O.strOption $ + O.long "with-ghc" <> O.metavar "GHC" <> + O.help (unwords [ + "Use a different version of GHC in this sandbox." + , "When this sandbox is mixed into package sandboxes, their" + , "cabal.config will be updated to use this version of GHC." + ]) + listNameArgument = O.optional . textArgument $ O.metavar "name" <> + O.help (unwords [ + "If given, list packages installed in the specified sandbox," + , "otherwise list all sandman sandboxes" + ]) + packagesArgument = O.some . textArgument $ + O.metavar "PACKAGES" <> O.help "Packages to install" + nameArgument = textArgument $ + O.metavar "NAME" <> O.help "Name of the sandman sandbox" + textArgument = fmap T.pack . O.strArgument + command name desc p = + O.command name (O.info (O.helper <*> p) (O.progDesc desc)) + + +main :: IO () +main = join $ O.execParser opts + where + opts = O.info (O.helper <*> argParser) O.fullDesc diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,131 @@ +`sandman` helps manage Cabal sandboxes so that you can avoid rebuilding +packages that you use often. + +It does so by managing a global collection of sandboxes that were built +separately. You can `mix` any number of these sandboxes into the package +database for your project-specific sandbox. + + Usage: sandman COMMAND + + Available options: + -h,--help Show this help text + + Available commands: + list List sandman sandboxes or the packages in them + new Create a new sandman sandbox + destroy Delete a sandman sandbox + install Install a new package + mix Mix a sandman sandbox into the current project + clean Remove all mixed sandboxes from the current project + +# Example usage + +First, we create a sandbox that will contain packages we commonly use for +development. + + $ sandman list + lens (25 packages) + + $ sandman new common + [..] + Created sandbox common. + +Managed sandboxes can be told to use specific versions of GHC. This information +will be propagated to projects with which this sandbox is mixed. + + $ sandman new common --with-ghc ghc-7.6.3 + +We install our commonly used packages + + $ sandman install common classy-prelude + [..] + Configuring classy-prelude-0.10.2... + Building classy-prelude-0.10.2... + Installed classy-prelude-0.10.2 + + $ sandman list + lens (25 packages) + common (45 packages) + + $ sandman list common + [..] + classy-prelude-0.10.2 + [..] + + $ sandman destroy lens + Removed sandbox lens. + + $ sandman list + common (45 packages) + + $ sandman install common optparse-applicative aeson + +Next, we mix it into an existing project. + + $ cd my_project + $ cabal sandbox init + $ cabal sandbox hc-pkg list | grep classy-prelude + + + $ sandman mix common + Mixing 45 new packages into package DB at [..] + Rebuilding package cache. + + $ cabal sandbox hc-pkg list | grep classy-prelude + classy-prelude-0.10.2 + + $ cabal repl + GHCi, version 7.8.3: http://www.haskell.org/ghc/ :? for help + Loading package ghc-prim ... linking ... done. + Loading package integer-gmp ... linking ... done. + Loading package base ... linking ... done. + λ> import ClassyPrelude + λ> + + $ sandman clean + Removing all mixed sandboxes. + Removed 45 packages. + Rebuilding package cache. + +`sandman` can also mix in only specific packages and their dependencies from +managed sandboxes. + + $ sandman mix common --only system-filepath --only system-fileio + Mixing 3 new packages into package DB at [..] + Rebuilding package cache. + + $ cabal sandbox hc-pkg list + [..] + system-fileio-0.3.16 + system-filepath-0.4.13.1 + text-1.2.0.4 + +The `--executables` option may be used to include executables from a sandbox. + + $ sandman mix common --executables --only hspec + Mixing 15 new packages into package DB at [..] + Rebuilding package cache. + + $ ls .cabal-sandbox/bin + hspec-discover + +# Status + +Sandman is stable enough for basic use cases but there are surely a lot of +unexplored corner cases. Feel free to try it out. Keep in mind that since +you're breaking sandbox boundaries, there is a higher chance of running into +version conflicts. + +# Installation + +You can download and install `sandman` from Hackage by using, + + $ cabal install sandman + +Or if you would rather not pollute your global package database, install it +into a sandbox and copy the executable somewhere on your `$PATH`. + + $ mkdir tmp && cd tmp + $ cabal sandbox init + $ cabal install sandman + $ cp .cabal-sandbox/bin/sandman ~/bin diff --git a/Sandman/InstalledPackage.hs b/Sandman/InstalledPackage.hs new file mode 100644 --- /dev/null +++ b/Sandman/InstalledPackage.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Sandman.InstalledPackage ( + InstalledPackage + , installedPackageInfo + , installedPackageInfoPath + , installedPackageId + , installedPackageName + , installedPackageVersion + + , getInstalledPackage + ) where + +import Data.Text (Text) +import Distribution.Version (Version) +import System.Directory (doesFileExist) + +import qualified Data.Text as Text +import qualified Distribution.InstalledPackageInfo as Cabal +import qualified Distribution.Package as Cabal +import qualified Distribution.Text as Cabal + +-- | Represents a Cabal package installed somewhere in the system. +data InstalledPackage = InstalledPackage { + installedPackageInfo :: Cabal.InstalledPackageInfo + -- ^ 'Cabal.InstalledPackageInfo' for the package. + , installedPackageInfoPath :: FilePath + -- ^ Path where the 'Cabal.InstalledPackageInfo' file is stored. + , cabalPackageId :: Cabal.PackageId + -- ^ Cabal package ID + } + +-- | Get the package ID for the given InstalledPackage +installedPackageId :: InstalledPackage -> Text +installedPackageId = Text.pack . Cabal.display . cabalPackageId + +-- | Get the package name +installedPackageName :: InstalledPackage -> Text +installedPackageName = + Text.pack . Cabal.display . Cabal.pkgName . cabalPackageId + +-- | Get the package version +installedPackageVersion :: InstalledPackage -> Version +installedPackageVersion = Cabal.pkgVersion . cabalPackageId + +-- | Build a 'InstalledPackage' object from the given path. +-- +-- Returns either an error or the 'InstalledPackage' object. +getInstalledPackage :: FilePath -> IO (Either String InstalledPackage) +getInstalledPackage path = + doesFileExist path >>= \exists -> + if not exists + then return (Left $ "File does not exist: " ++ path) + else getInstalledPackage_ path + +getInstalledPackage_ :: FilePath -> IO (Either String InstalledPackage) +getInstalledPackage_ installedPackageInfoPath = + readFile installedPackageInfoPath >>= \contents -> + case Cabal.parseInstalledPackageInfo contents of + Cabal.ParseFailed e -> return . Left $ + "Failed to parse " ++ installedPackageInfoPath ++ ": " ++ show e + Cabal.ParseOk _ installedPackageInfo -> return . Right $ + InstalledPackage{ + installedPackageInfo + , installedPackageInfoPath + , cabalPackageId = Cabal.sourcePackageId installedPackageInfo + } diff --git a/Sandman/PackageDb.hs b/Sandman/PackageDb.hs new file mode 100644 --- /dev/null +++ b/Sandman/PackageDb.hs @@ -0,0 +1,39 @@ +module Sandman.PackageDb ( + PackageDb + , packageDbRoot + , packageDbInstalledPackages + , getPackageDb + ) where + +import Control.Applicative +import Data.Either +import Data.List (isSuffixOf) +import System.Directory (doesDirectoryExist) + +import Sandman.InstalledPackage (InstalledPackage, getInstalledPackage) +import Sandman.Util + +-- | Represents a Cabal package database. +data PackageDb = PackageDb { + packageDbRoot :: FilePath + -- ^ Root directory of the package database. + , packageDbInstalledPackages :: [InstalledPackage] + -- ^ List of packages installed inside the database. + } + +-- | Get the package database for the given root directory. +getPackageDb :: FilePath -> IO (Either String PackageDb) +getPackageDb root = doesDirectoryExist root >>= \exists -> + if not exists + then return $ Left (root ++ " is not a package DB") + else getPackageDb_ root + +getPackageDb_ :: FilePath -> IO (Either String PackageDb) +getPackageDb_ root = do + confFiles <- listDirectory root <&> filter (".conf" `isSuffixOf`) + result <- partitionEithers <$> mapM getInstalledPackage confFiles + return $ case result of + ([], installedPackages) -> Right $ + PackageDb root installedPackages + (errs, _) -> Left . unlines $ + ("Failed to read package DB at " ++ root) : errs diff --git a/Sandman/Util.hs b/Sandman/Util.hs new file mode 100644 --- /dev/null +++ b/Sandman/Util.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE OverloadedStrings #-} +module Sandman.Util ( + (<&>) + , whenM + , tshow + , listDirectory + , removeTree + , die + , dieHappy + , warn + ) where + +import Control.Applicative +import Control.Monad +import Data.Monoid ((<>)) +import Data.Text (Text) +import System.Directory (doesDirectoryExist, getDirectoryContents, + removeDirectory, removeFile) +import System.Exit (exitFailure, exitSuccess) +import System.FilePath (()) +import System.IO (stderr) +import System.PosixCompat.Files (getSymbolicLinkStatus, isDirectory) + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +-- | '<$>' with the arguments flipped. +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip (<$>) +infixl 1 <&> + +whenM :: Monad m => m Bool -> m () -> m () +whenM p m = p >>= \c -> when c m + +tshow :: Show a => a -> Text +tshow = T.pack . show + +listDirectory :: FilePath -> IO [FilePath] +listDirectory d = doesDirectoryExist d >>= \exists -> + if not exists + then return [] + else getDirectoryContents d + <&> filter (`notElem` [".", ".."]) + <&> map (d ) + +removeTree :: FilePath -> IO () +removeTree path = do + status <- getSymbolicLinkStatus path + if isDirectory status + then listDirectory path + >>= mapM_ removeTree + >> removeDirectory path + else removeFile path + +-- | Print the given message and exit with a non-zero status code. +die :: Text -> IO a +die t = TIO.putStrLn t >> exitFailure + + +-- | Print the given message and exit with status code zero. +dieHappy :: Text -> IO a +dieHappy t = TIO.putStrLn t >> exitSuccess + +warn :: Text -> IO () +warn t = TIO.hPutStrLn stderr ("WARNING: " <> t) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sandman.cabal b/sandman.cabal new file mode 100644 --- /dev/null +++ b/sandman.cabal @@ -0,0 +1,43 @@ +name : sandman +version : 0.1.0.0 +synopsis : Manages Cabal sandboxes to avoid rebuilding packages. +homepage : https://github.com/abhinav/sandman +license : MIT +license-file : LICENSE +author : Abhinav Gupta +maintainer : mail@abhinavg.net +copyright : (c) 2015 Abhinav Gupta +category : Development +build-type : Simple +cabal-version : >=1.10 +description : + sandman aims to reduce the amount of time spent rebuilding commonly used + Hackage packages by managing a global set of Cabal sandboxes that can be + mixed into any project's Cabal sandbox. + . + For more information, check the + . +extra-source-files: + README.md + CHANGES.md + +executable sandman + main-is : Main.hs + other-modules : Sandman.InstalledPackage + , Sandman.PackageDb + , Sandman.Util + build-depends : base >= 4.7 && < 4.8 + + , Cabal + , containers >= 0.5 + , directory >= 1.2 + , filepath >= 1.3 + , optparse-applicative >= 0.11 + , process >= 1.2 + , text >= 1.2 + , unix-compat >= 0.4 + default-language : Haskell2010 + +source-repository head + type : git + location: git://github.com/abhinav/sandman.git