------------------------------------------------------------------ -- | -- 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