sandman (empty) → 0.1.0.0
raw patch · 9 files changed
+884/−0 lines, 9 filesdep +Cabaldep +basedep +containerssetup-changed
Dependencies added: Cabal, base, containers, directory, filepath, optparse-applicative, process, text, unix-compat
Files
- CHANGES.md +5/−0
- LICENSE +20/−0
- Main.hs +513/−0
- README.md +131/−0
- Sandman/InstalledPackage.hs +66/−0
- Sandman/PackageDb.hs +39/−0
- Sandman/Util.hs +65/−0
- Setup.hs +2/−0
- sandman.cabal +43/−0
+ CHANGES.md view
@@ -0,0 +1,5 @@+0.1.0.0+=======++- Initial release.+
+ LICENSE view
@@ -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.
+ Main.hs view
@@ -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
+ README.md view
@@ -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+ <nothing>++ $ 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
+ Sandman/InstalledPackage.hs view
@@ -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+ }
+ Sandman/PackageDb.hs view
@@ -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
+ Sandman/Util.hs view
@@ -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)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ sandman.cabal view
@@ -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+ <https://github.com/abhinav/sandman/blob/master/README.md README>.+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