diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Dmitry Golubovsky + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dmitry Golubovsky nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,442 @@ +------------------------------------------------------------------ +-- | +-- Module : Main +-- Copyright : (c) Dmitry Golubovsky, 2010 +-- License : BSD-style +-- +-- Maintainer : golubovsky@gmail.com +-- Stability : experimental +-- Portability : GHC +-- +-- +-- +-- Main module of capri, wrapper for cabal-install private mode +------------------------------------------------------------------ + +module Main where + +import qualified Paths_capri +import Data.List +import Data.Maybe +import System.IO +import System.Directory +import System.FilePath +import System.Process +import System.Environment +import System.Exit +import Control.Monad +import Distribution.Text +import Distribution.Simple.Setup +import Distribution.Simple.Utils +import Distribution.Simple.Command + +main :: IO () +main = getArgs >>= mainWorker + +-- Toplevel command handler. Any command not recognized in the provided list of +-- commands is forwarded to cabal-install as is, with proper environment set. + +mainWorker :: [String] -> IO () +mainWorker args = topHandler $ + case commandsRun capriGlobalCommand commands args of + CommandHelp help -> printGlobalHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalflags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion globalflags) -> printVersion + | fromFlag (globalNumericVersion globalflags) -> printNumericVersion + CommandHelp help -> printCommandHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action globalflags + where + printCommandHelp help = do + pname <- getProgName + putStr (help pname) + printGlobalHelp help = do + pname <- getProgName + putStr (help pname) + printOptionsList = putStr . unlines + printErrors errs = die $ concat (intersperse "\n" errs) + printNumericVersion = putStrLn $ display Paths_capri.version + printVersion = putStrLn $ "capri version " + ++ display Paths_capri.version + ++ "\nusing version " + ++ display cabalVersion + ++ " of the Cabal library " + + +-- Print global help message + +capriGlobalCommand :: CommandUI GlobalFlags +capriGlobalCommand = CommandUI { + commandName = "", + commandSynopsis = "", + commandUsage = \_ -> + "This program provides a wrapper over cabal-install " + ++ "to operate in project-private mode.\n", + commandDescription = Just $ \pname -> + "For more information about a command use\n" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "Typical steps of building Haskell projects with Capri:\n" + ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" + | x <- ["bootstrap", "clone", "configure", "build", "install"]], + commandDefaultFlags = defaultGlobalFlags, + commandOptions = \_ -> + [option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + ] + } + +bootpkgs = ["ffi", "rts", "ghc-prim", "integer-gmp", "base-4*"] + +subdir = ".capri" +pkgdir = subdir "packages" +instdir = subdir "install" + +commands = [ + bootstrapCommand `commandAddAction` bootstrapAction + ,listCommand `commandAddAction` listAction + ,cloneCommand `commandAddAction` cloneAction + ,ghcpkgCommand `commandAddAction` ghcpkgAction + ,cabalCommand `commandAddAction` cabalAction + ,importCommand `commandAddAction` importAction + ,xCommand "install" `commandAddAction` xAction (CabalFlags False False False) "install" + ,xCommand "configure" `commandAddAction` xAction (CabalFlags False False False) "configure" + ,xCommand "build" `commandAddAction` xAction (CabalFlags True True False) "build"] + +-- Import another package into the private packages database. Importing means building +-- within some other package's directory, but with respect to this package's private +-- database and installation path. + +importCommand :: CommandUI CabalFlags + +importCommand = CommandUI { + commandName = "import" + ,commandSynopsis = "Build another package with respect to this package's private " ++ + "packages database and installation path" + ,commandUsage = (++ " import directory -- ") + ,commandDescription = Just $ \pname -> + "Use this command to build another package with respect to this package private\n" ++ + "packages database. Use double-hyphen (--) before any build program parameters\n" ++ + "to avoid interpretation of them by " ++ pname ++ " as its own options.\n" ++ + "If only import directory is specified, \"cabal install\" will be executed in\n" ++ + "that directory. If the build program complains about unrecognized options\n" ++ + "`--package-db' or `--prefix' use -D or -P options BEFORE the double hyphen to\n" ++ + "omit them. Use -S option to run the package's Setup.{hs|lhs} installation\n" ++ + "program instead of cabal-install.\n\n" + ,commandDefaultFlags = CabalFlags False False False + ,commandOptions = const [ + OptionField { + optionName = "omit-package-db" + ,optionDescr = [ + ChoiceOpt [ + ("Omit the --package-db option for build programs that do not understand it" + ,(['D'], ["omit-package-db"]) + ,(\flags -> flags {pkgdb = True}) + ,pkgdb) + ,("Omit the --prefix option for build programs that do not understand it" + ,(['P'], ["omit-prefix"]) + ,(\flags -> flags {prefix = True}) + ,prefix) + ,("Use the Setup.{hs|lhs} installation program instead of Cabal-install" + ,(['S'], ["setup"]) + ,(\flags -> flags {setup = True}) + ,prefix)] + ] + } + ] +} + +importAction (CabalFlags pkgdb prefix setup) s g = do + when (null s) $ die "at least import directory has to be specified" + let dir = head s + cd <- getCurrentDirectory + doesDirectoryExist dir >>= return . not >>= flip when (die $ "import directory " ++ + dir ++ " does not exist") + let dbopt = if pkgdb then [] else ["--package-db=" ++ (cd pkgdir)] + pfxopt = if prefix then [] else ["--prefix=" ++ (cd instdir)] + (stp, prog) = if setup then (["Setup"], "runghc") else ([], "cabal") + cmds = case s of + [dir] -> ["install"] + _ -> tail s + pp <- privateProcessRaw prog (stp ++ cmds ++ dbopt ++ pfxopt) + (_, _, _, p) <- createProcess pp {cwd = Just dir} + waitForProcess p + return () + +-- Shortcut commands to invoke predefined Cabal actions. + +xCommand :: String -> CommandUI () + +xCommand cmd = CommandUI { + commandName = cmd + ,commandSynopsis = "Short-cut for cabal " ++ cmd ++ " command" + ,commandUsage = (++ " " ++ cmd) + ,commandDescription = Just $ \pname -> "This command is equivalent to:\n\n" ++ + " " ++ pname ++ " cabal -- " ++ cmd ++ "\n\n" ++ + "with package database and install prefix " ++ + "set properly.\n\n" + ,commandDefaultFlags = () + ,commandOptions = const [] +} + +xAction cf cmd f s g = cabalAction cf [cmd] g + +-- Invoke cabal to run arbitrary action as a private process. + +data CabalFlags = CabalFlags { + pkgdb :: Bool -- Include the "--package-db" flag + ,prefix :: Bool -- Include the "--prefix" flag + ,setup :: Bool -- Use Setup.{hs|lhs} instead of cabal +} + +cabalCommand :: CommandUI CabalFlags + +cabalCommand = CommandUI { + commandName = "cabal" + ,commandSynopsis = "Invoke the cabal-install or Setup.{hs|lhs} program to run arbitrary " ++ + "action on private packages" + ,commandUsage = (++ " cabal -- ") + ,commandDescription = Just $ \pname -> + "Use this command to invoke arbitrary action of cabal-install on the privately\n" ++ + "installed packages. Use double-hyphen (--) before any cabal parameters to\n" ++ + "avoid interpretation of them by " ++ pname ++ " as its own options.\n" ++ + "If the cabal command complains about unrecognized options `--package-db' or\n" ++ + "`--prefix' use -D or -P options BEFORE the double hyphen to omit them. Use -S\n" ++ + "option to run the package's Setup.{hs|lhs} installation program instead of\n" ++ + "cabal-install.\n\n" + ,commandDefaultFlags = CabalFlags False False False + ,commandOptions = const [ + OptionField { + optionName = "omit-package-db" + ,optionDescr = [ + ChoiceOpt [ + ("Omit the --package-db option for cabal commands that do not understand it" + ,(['D'], ["omit-package-db"]) + ,(\flags -> flags {pkgdb = True}) + ,pkgdb) + ,("Omit the --prefix option for cabal commands that do not understand it" + ,(['P'], ["omit-prefix"]) + ,(\flags -> flags {prefix = True}) + ,prefix) + ,("Use the Setup.{hs|lhs} installation program instead of Cabal-install" + ,(['S'], ["setup"]) + ,(\flags -> flags {setup = True}) + ,prefix)] + ] + } + ] +} + +cabalAction (CabalFlags pkgdb prefix setup) s g = do + cd <- getCurrentDirectory + let dbopt = if pkgdb then [] else ["--package-db=" ++ (cd pkgdir)] + pfxopt = if prefix then [] else ["--prefix=" ++ (cd instdir)] + (stp, prog) = if setup then (["Setup"], "runghc") else ([], "cabal") + (_, _, _, p) <- privateProcessRaw prog (stp ++ s ++ dbopt ++ pfxopt) >>= createProcess + waitForProcess p + return () + +-- Invoke ghc-pkg to run arbitrary action as a private process. + +ghcpkgCommand :: CommandUI () + +ghcpkgCommand = CommandUI { + commandName = "ghc-pkg" + ,commandSynopsis = "Invoke the ghc-pkg program to run arbitrary action on private packages" + ,commandUsage = (++ " ghc-pkg -- ") + ,commandDescription = Just $ \pname -> + "Use this command to invoke arbitrary action of ghc-pkg on the privately installed\n" ++ + "packages. Use double-hyphen (--) before any ghc-pkg parameters to avoid\n" ++ + "interpretation of them by " ++ pname ++ " as its own options.\n\n" + ,commandDefaultFlags = () + ,commandOptions = const [] +} + +ghcpkgAction f s g = do + (_, _, _, p) <- privateProcessRaw "ghc-pkg" s >>= createProcess + waitForProcess p + return () + +-- Clone a package installed publicly into the private package database. +-- Exactly this action is performed by the bootstrap command on certain +-- essential packages. Note that --force option will not be passed to +-- ghc-pkg, so if some dependencies are missing, this has to be manually resolved. + +cloneCommand :: CommandUI () + +cloneCommand = CommandUI { + commandName = "clone" + ,commandSynopsis = "Clone package(s) installed publicly into the private packages database" + ,commandUsage = (++ " clone [...]") + ,commandDescription = Just $ \pname -> + "Use this command to install previously compiled package(s) from global or user\n" ++ + "database into the private database via running ghc-pkg. Package files (libraries,\n" ++ + "executables) will not be copied; just the description of the package will be\n" ++ + "transferred.\n" ++ + "Note that the --force flag will not be passed to ghc-pkg, so if any package\n" ++ + "dependencies are missing, cloning will not be completed. It is a good idea to\n" ++ + "specify package version explicitly.\n\n" + ,commandDefaultFlags = () + ,commandOptions = const [] +} + +cloneAction f s g = do + when (null s) $ die "at least one package name to clone should be specified" + mapM clonePackage s + return () + +-- List packages installed privately. Equivalent to running ghc-pkg list +-- as a "private" process. + +listCommand :: CommandUI () + +listCommand = CommandUI { + commandName = "list" + ,commandSynopsis = "List packages installed privately" + ,commandUsage = (++ " list") + ,commandDescription = Just $ \pname -> + "Use this command to list packages installed privately for this project.\n" ++ + pname ++ " will run the ghc-pkg utility to perform this action.\n\n" + ,commandDefaultFlags = () + ,commandOptions = const [] +} + +listAction f s g = do + (_, _, _, p) <- privateProcess "ghc-pkg list" >>= createProcess + waitForProcess p + return () + +-- Bootstrap a private per-project package configuration. Create a subdirectory .capri +-- where packages will be installed. Subdirectory .capri/packages will hold packages +-- cache and descriptions; subdirectory .capri/install will hold compiled libraries and +-- executables. + +bootstrapCommand :: CommandUI () + +bootstrapCommand = CommandUI { + commandName = "bootstrap" + ,commandSynopsis = "Bootstrap private packages configuration" + ,commandUsage = (++ " bootstrap") + ,commandDescription = Just $ \pname -> + "Use this command to create an empty per-project database of packages.\n" ++ + pname ++ " will clone the following packages into the per-project packages directory: \n\n" ++ + concat (intersperse " " bootpkgs) ++ ".\n\n" + ,commandDefaultFlags = () + ,commandOptions = const [] +} + +bootstrapAction f s g = do + mapM createDirectory [subdir, instdir] + ex <- runCommand ("ghc-pkg init " ++ pkgdir) >>= waitForProcess + let exfail (ExitFailure _) = True + exfail _ = False + when (exfail ex) $ die "ghc-pkg failed to initialize package configuration:\n" + mapM clonePackage bootpkgs + return () + +-- Clone a package. This is same as running ghc-pkg describe as a "public" process, +-- and running ghc-pkg register as a "private" process. + +clonePackage :: String -> IO () + +clonePackage pkg = do + cwd <- getCurrentDirectory + descr <- publicProcess ("ghc-pkg describe " ++ pkg) cwd + regst <- privateProcess "ghc-pkg register -" + (_, _, p) <- runPipe Inherit Inherit [descr, regst] + mapM waitForProcess p + return () + +-- Utility: create a process descriptor from given command operating in the project's +-- current directory and having environment variable GHC_PACKAGE_PATH set to +-- the project's private package storage. Standard I/O handles are set to Inherit, +-- but may be adjusted later when actually run the process. + +privateProcess :: String -> IO CreateProcess +privateProcess = privateProcess' . ShellCommand + +privateProcessRaw :: FilePath -> [String] -> IO CreateProcess +privateProcessRaw prog args = privateProcess' (RawCommand prog args) + +privateProcess' cmd = do + cd <- getCurrentDirectory + env <- getEnvironment + let env' = filter ((/= "GHC_PACKAGE_PATH") . fst) env + return CreateProcess { + cmdspec = cmd + ,cwd = Just cd + ,env = Just (("GHC_PACKAGE_PATH", cd pkgdir):env') + ,std_in = Inherit + ,std_out = Inherit + ,std_err = Inherit + ,close_fds = False + } + +-- Utility: create a process descriptor to run a command without environment +-- adjustments, in given current directory. + +publicProcess :: String -> FilePath -> IO CreateProcess + +publicProcess cmd dir = return CreateProcess { + cmdspec = ShellCommand cmd + ,cwd = Just dir + ,env = Nothing + ,std_in = Inherit + ,std_out = Inherit + ,std_err = Inherit + ,close_fds = False +} + +-- Utility: pipe processes together. Two StdStream's must be supplied: for pipeline's +-- stdin and stdout. Stderr's of all processes are as set in the process creation +-- descriptors. List of process handles is returned as well as handles for pipe ends. + +runPipe :: StdStream -- stdin + -> StdStream -- stdout + -> [CreateProcess] -- processes (start at left, end at right) + -> IO (Maybe Handle -- pipe in + ,Maybe Handle -- pipe out + ,[ProcessHandle]) -- same order as in the input list of descriptors + +runPipe ins outs [] = return (Nothing, Nothing, []) + +runPipe ins outs [p] = do + let p' = p {std_in = ins, std_out = outs} + (pin, pout, _, ph) <- createProcess p' + return (pin, pout, [ph]) + +runPipe ins outs (pstart:ps) = do + let pstart' = pstart {std_in = ins} + prev@(pend:rps) = reverse (pstart':ps) + pend' = pend {std_out = outs} + piper (pend':rps) [] Nothing Nothing + +piper :: [CreateProcess] + -> [ProcessHandle] + -> Maybe Handle + -> Maybe Handle + -> IO (Maybe Handle, Maybe Handle, [ProcessHandle]) + +piper [] phs pin pend = return (pin, pend, phs) + +piper (p:ps) [] Nothing Nothing = do + let p' = p {std_in = CreatePipe} + (pin, pend, _, ph) <- createProcess p' + piper ps [ph] pin pend + +piper (p:ps) phs pin pend = do + let p' = p {std_in = CreatePipe, std_out = UseHandle (fromJust pin)} + (pin', _, _, ph) <- createProcess p' + piper ps (ph:phs) pin' pend + + + 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/capri.cabal b/capri.cabal new file mode 100644 --- /dev/null +++ b/capri.cabal @@ -0,0 +1,75 @@ +-- capri.cabal auto-generated by cabal init. For additional options, +-- see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: capri + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1 + +-- A short (one-line) description of the package. +Synopsis: A simple wrapper over cabal-install to operate in project-private mode. + +-- A longer description of the package. +Description: Capri (abbreviation of CAbal PRIvate) is a wrapper program on top of + cabal-install to operate it in project-private mode. In this mode, + there is no global or user package databases; only one package + database is defined, private to the project, located under the root + directory of a project. + . + Capri invokes cabal-install and ghc-pkg in the way that only project's + private package database is visible. Starting with minimally required + set of packages, all necessary dependencies will be installed into + that database, not affecting user or global databases. + . + Capri is mainly intended to build executable programs. It depends + on certain features of GHC, and is not usable with other Haskell + compilers. + . + Further reading: + + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Dmitry Golubovsky + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: golubovsky@gmail.com + +-- A copyright notice. +-- Copyright: + +Category: Distribution + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.2 + + +Executable capri + -- .hs or .lhs file containing the Main module. + Main-is: Main.hs + + -- Packages needed in order to build this package. + Build-depends: base >= 4 && < 5, Cabal >= 1.8, process >= 1.0, + directory >= 1.0, filepath >= 1.1 + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: +