diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Bartosz Ćwikłowski + +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 Bartosz Ćwikłowski 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,154 @@ +Virtual Haskell Environment +=========================== + +What is it? +----------- +virthualenv is a tool (inspired by Python's virtualenv) +to create isolated Haskell environments. + + +What does it do? +---------------- +It creates a sandboxed environment in a .virthualenv/ sub-directory +of your project, which, when activated, allows you to use regular Haskell tools +(ghc, ghci, ghc-pkg, cabal) to manage your Haskell code and environment. +It's possible to create an environment, that uses different GHC version +than your currently installed. Very simple emacs integration mode is included. + +Basic usage +----------- +First, choose a directory where you want to keep your +sandboxed Haskell environment, usually a good choice is a directory containing +your cabalized project (if you want to work on a few projects +(perhaps an app and its dependent library), just choose any of them, +it doesn't really matter). Enter that directory: + +> cd ~/projects/foo + +Next, create your new isolated Haskell environment +(this is a one time only (per environment) step): + +> virthualenv + +Now, every time you want to use this environment, you have to activate it: + +> source .virthualenv/bin/activate + +That's it! Now it's possible to use all regular Haskell tools like usual, +but it won't affect your global/system's Haskell environment, and also +your per-user environment (from ~/.cabal and ~/.ghc) will stay the same. +All cabal-installed packages will be private to this environment, +and also the external environments (global and user) will not affect it +(this environment will only inherit very basic packages, +mostly ghc and Cabal and their deps). + +When you're done working with this environment, enter command 'deactivate', +or just close the current shell (with exit). + +> deactivate + +Advanced usage +-------------- +Here's the most advanced usage of virthualenv. Let's say you want to: + +* hack on json library +* do so comfortably +* use your own version of parsec library +* and do all this using nightly version of GHC + +First, download binary distribution of GHC for your platform +(e.g. ghc-7.3.20111105-i386-unknown-linux.tar.bz2). + +Create a directory for you environment: + +> mkdir /tmp/test; cd /tmp/test + +Then, create a new environment using that GHC: + +> virthualenv --ghc=/path/to/ghc-7.3.20111105-i386-unknown-linux.tar.bz2 + +Activate it: + +> source .virthualenv/bin/activate + +Download a copy of json library and your private version of parsec: + +> darcs get http://patch-tag.com/r/Paczesiowa/parsec; cabal unpack json + +Install parsec: + +> cd parsec2; cabal install + +Install the rest of json deps: + +> cd ../json-0.5; cabal install --only-dependencies + +Now, let's say you want to hack on Parsec module of json library. +Open it in emacs: + +> emacsclient Text/JSON/Parsec.hs + +Activate the virtual environment (virthualenv must be required earlier): + +> M-x virthualenv-activate /tmp/test/ + +Edit some code and load it in ghci using 'C-c C-l'. If it type checks, +you can play around with the code using nightly version of ghci running +in your virtual environment. When you're happy with the code, exit emacs +and install your edited json library: + +> cabal install + +And that's it. + +Misc +---- +virthualenv has been tested on i386 Linux and FreeBSD systems, +but it should work on any Posix platform. External (from tarball) GHC feature +requires binary GHC distribution compiled for your platform, +that can be extracted with tar and installed with +"./configure --prefix=PATH; make install". + +FAQ +--- +Q: Can I use it together with tools like cabal-dev or capri? +A: No. All these tools work more or less the same (wrapping cabal command, + setting GHC_PACKAGE_PATH env variable), so something will probably break. + +Q: Using GHC from tarball fails, when using FreeBSD with a bunch of make tool + gibberish. What do I do? +A: Try '--make-cmd=gmake' switch. + +Q: Can I use virthualenv inside virthualenv? +A: No. It may be supported in future versions. + +Q: Does it work on x64 systems? +A: It hasn't been tested, but there's no reason why it shouldn't. + +Q: Will it work on Mac? +A: I doubt it. It should be easy to make it work there with system's GHC, + Using GHC from tarball will be probably harder. I don't have any mac + machines, so you're on your own, but patches/ideas/questions are welcome. + +Q: Will it work on Windows? +A: I really doubt it would even compile. I don't have access to any windows + machines, so you're on your own, but patches/ideas/questions are welcome. + Maybe it would work on cygwin. + +Q: Does it require bash? +A: No, it should work with any POSIX-compliant shell. It's been tested with + bash, bash --posix, dash, zsh and ksh. + +Q: Can I use it with a different haskell package repository than hackage? +A: Yes, just adjust the url in .virthualenv/cabal/config file. + +Q: How do I remove the whole virtual environment? +A: If it's activated - 'deactivate' it. Then, delete + the .virthualenv/ directory. + +Q: Is every environment completely separate from other environments and + the system environment? +A: Yes. The only (minor) exception is ghci history - there's only one + per user history file. Also, if you alter your system's GHC, then + virtual environments using system's GHC copy will probably break. + Virtual environments using GHC from a tarball should continue to work. 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/skeletons/activate b/skeletons/activate new file mode 100644 --- /dev/null +++ b/skeletons/activate @@ -0,0 +1,52 @@ +if [ -n "${VIRTHUALENV}" ]; then + if [ "" = "${VIRTHUALENV}" ]; then + echo "${VIRTHUALENV_NAME} Virtual Haskell Environment is already active." + else + echo "There is already ${VIRTHUALENV_NAME} Virtual Haskell Environment activated." + echo "Deactivate it first (using command 'deactivate'), to activate" + echo " environment." + fi + return 1 +fi + +export VIRTHUALENV="" +export VIRTHUALENV_NAME="" + +echo "Activating ${VIRTHUALENV_NAME} Virtual Haskell Environment (at ${VIRTHUALENV})." +echo "" +echo "Use regular Haskell tools (ghc, ghci, ghc-pkg, cabal) to manage your Haskell environment." +echo "" +echo "To exit from this virtual environment, enter command 'deactivate'." + +export "VIRTHUALENV_PATH_BACKUP"="${PATH}" +export "VIRTHUALENV_PS1_BACKUP"="${PS1}" + +deactivate() { + echo "Deactivating ${VIRTHUALENV_NAME} Virtual Haskell Environment (at ${VIRTHUALENV})." + echo "Restoring previous environment settings." + + export "PATH"="${VIRTHUALENV_PATH_BACKUP}" + unset -v "VIRTHUALENV_PATH_BACKUP" + export "PS1"="${VIRTHUALENV_PS1_BACKUP}" + unset -v "VIRTHUALENV_PS1_BACKUP" + + unset -v VIRTHUALENV + unset -v VIRTHUALENV_NAME + unset -v GHC_PACKAGE_PATH + unset -f deactivate + + if [ -n "$BASH" -o -n "$ZSH_VERSION" ]; then + hash -r + fi +} + +PATH_PREPENDIX="$(cat /path_var_prependix)" +export PATH="${PATH_PREPENDIX}:${PATH}" +unset -v PATH_PREPENDIX + +export GHC_PACKAGE_PATH="$(cat /ghc_package_path_var)" +export PS1="(${VIRTHUALENV_NAME})${PS1}" + +if [ -n "$BASH" -o -n "$ZSH_VERSION" ]; then + hash -r +fi diff --git a/skeletons/cabal b/skeletons/cabal new file mode 100644 --- /dev/null +++ b/skeletons/cabal @@ -0,0 +1,25 @@ +#!/bin/sh + +PATH_ELEMS="$(echo ${PATH} | tr -s ':' '\n')" + +ORIG_CABAL_BINARY="" + +for PATH_ELEM in ${PATH_ELEMS}; do + CABAL_CANDIDATE="${PATH_ELEM}/cabal" + if command -v "${CABAL_CANDIDATE}" > /dev/null 2> /dev/null; then + if [ "${0}" != "${CABAL_CANDIDATE}" ]; then + if [ -z "${ORIG_CABAL_BINARY}" ]; then + ORIG_CABAL_BINARY="${CABAL_CANDIDATE}" + fi + fi + fi +done + +if [ -z "${ORIG_CABAL_BINARY}" ]; then + echo "cabal wrapper: Couldn't find real cabal program" + exit 1 +fi + +CABAL_CONFIG="" + +exec "${ORIG_CABAL_BINARY}" --config-file="${CABAL_CONFIG}" "${@}" diff --git a/skeletons/cabal_config b/skeletons/cabal_config new file mode 100644 --- /dev/null +++ b/skeletons/cabal_config @@ -0,0 +1,9 @@ +remote-repo: hackage.haskell.org:http://hackage.haskell.org/packages/archive +remote-repo-cache: /packages +logs-dir: /logs +world-file: /world +package-db: +build-summary: /logs/build.log +remote-build-reporting: anonymous +install-dirs user + prefix: diff --git a/src/Actions.hs b/src/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Actions.hs @@ -0,0 +1,206 @@ +module Actions ( cabalUpdate + , installCabalConfig + , installCabalWrapper + , installActivateScript + , copyBaseSystem + , initGhcDb + , installGhc + , createDirStructure + ) where + +import System.Directory (setCurrentDirectory, getCurrentDirectory, createDirectory, removeDirectoryRecursive) +import System.FilePath (()) +import Distribution.Version (Version (..)) +import Distribution.Package (PackageName(..)) +import Safe (lastMay) +import Data.List (intercalate) + +import MyMonad +import Types +import Paths +import PackageManagement +import Process +import Util.Template (substs) +import Util.IO (makeExecutable, createTemporaryDirectory) +import Skeletons + +-- update cabal package info inside Virtual Haskell Environmentn +cabalUpdate :: MyMonad () +cabalUpdate = do + env <- getVirtualEnvironment + cabalConfig <- cabalConfigLocation + info "Updating cabal package database inside Virtual Haskell Environment." + _ <- indentMessages $ runProcess (Just env) "cabal" ["--config-file=" ++ cabalConfig, "update"] Nothing + return () + +-- install cabal wrapper (in bin/ directory) inside virtual environment dir structure +installCabalWrapper :: MyMonad () +installCabalWrapper = do + cabalConfig <- cabalConfigLocation + dirStructure <- vheDirStructure + let cabalWrapper = virthualEnvBinDir dirStructure "cabal" + info $ concat [ "Installing cabal wrapper using " + , cabalConfig + , " at " + , cabalWrapper + ] + let cabalWrapperContents = substs [("", cabalConfig)] cabalWrapperSkel + indentMessages $ do + trace "cabal wrapper contents:" + indentMessages $ mapM_ trace $ lines cabalWrapperContents + liftIO $ writeFile cabalWrapper cabalWrapperContents + liftIO $ makeExecutable cabalWrapper + +installActivateScriptSupportFiles :: MyMonad () +installActivateScriptSupportFiles = do + debug "installing supporting files" + dirStructure <- vheDirStructure + ghc <- asks ghcSource + indentMessages $ do + let pathVarPrependixLocation = virthualEnvDir dirStructure "path_var_prependix" + pathVarElems = + case ghc of + System -> [virthualEnvBinDir dirStructure, cabalBinDir dirStructure] + Tarball _ -> [ virthualEnvBinDir dirStructure + , cabalBinDir dirStructure + , ghcBinDir dirStructure + ] + pathVarPrependix = intercalate ":" pathVarElems + debug $ "installing path_var_prependix file to " ++ pathVarPrependixLocation + indentMessages $ trace $ "path_var_prependix contents: " ++ pathVarPrependix + liftIO $ writeFile pathVarPrependixLocation pathVarPrependix + ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation + let ghcPackagePathVarLocation = virthualEnvDir dirStructure "ghc_package_path_var" + ghcPackagePathVar = ghcPkgDbPath + debug $ "installing ghc_package_path_var file to " ++ ghcPackagePathVarLocation + indentMessages $ trace $ "path_var_prependix contents: " ++ ghcPackagePathVar + liftIO $ writeFile ghcPackagePathVarLocation ghcPackagePathVar + +-- install activate script (in bin/ directory) inside virtual environment dir structure +installActivateScript :: MyMonad () +installActivateScript = do + info "Installing activate script" + virthualEnvName <- asks vheName + dirStructure <- vheDirStructure + ghcPkgDbPath <- indentMessages ghcPkgDbPathLocation + let activateScript = virthualEnvBinDir dirStructure "activate" + indentMessages $ debug $ "using location: " ++ activateScript + let activateScriptContents = substs [ ("", virthualEnvName) + , ("", virthualEnvDir dirStructure) + , ("", virthualEnv dirStructure) + , ("", ghcPkgDbPath) + , ("", virthualEnvBinDir dirStructure) + , ("", cabalBinDir dirStructure) + , ("", ghcBinDir dirStructure) + ] activateSkel + indentMessages $ do + trace "activate script contents:" + indentMessages $ mapM_ trace $ lines activateScriptContents + liftIO $ writeFile activateScript activateScriptContents + indentMessages installActivateScriptSupportFiles + +-- install cabal's config file (in cabal/ directory) inside virtual environment dir structure +installCabalConfig :: MyMonad () +installCabalConfig = do + cabalConfig <- cabalConfigLocation + dirStructure <- vheDirStructure + info $ "Installing cabal config at " ++ cabalConfig + let cabalConfigContents = substs [ ("", ghcPackagePath dirStructure) + , ("", cabalDir dirStructure) + ] cabalConfigSkel + indentMessages $ do + trace "cabal config contents:" + indentMessages $ mapM_ trace $ lines cabalConfigContents + liftIO $ writeFile cabalConfig cabalConfigContents + +createDirStructure :: MyMonad () +createDirStructure = do + dirStructure <- vheDirStructure + info "Creating Virtual Haskell directory structure" + indentMessages $ do + debug $ "virthualenv directory: " ++ virthualEnvDir dirStructure + liftIO $ createDirectory $ virthualEnvDir dirStructure + debug $ "cabal directory: " ++ cabalDir dirStructure + liftIO $ createDirectory $ cabalDir dirStructure + debug $ "virthualenv bin directory: " ++ virthualEnvBinDir dirStructure + liftIO $ createDirectory $ virthualEnvBinDir dirStructure + +-- initialize private GHC package database inside virtual environment +initGhcDb :: MyMonad () +initGhcDb = do + dirStructure <- vheDirStructure + info $ "Initializing GHC Package database at " ++ ghcPackagePath dirStructure + out <- indentMessages $ outsideGhcPkg ["--version"] + case lastMay $ words out of + Nothing -> throwError $ MyException $ "Couldn't extract ghc-pkg version number from: " ++ out + Just versionString -> do + indentMessages $ trace $ "Found version string: " ++ versionString + version <- parseVersion versionString + let ghc_6_12_1_version = Version [6,12,1] [] + if version < ghc_6_12_1_version then do + indentMessages $ debug "Detected GHC older than 6.12, initializing GHC_PACKAGE_PATH to file with '[]'" + liftIO $ writeFile (ghcPackagePath dirStructure) "[]" + else do + _ <- indentMessages $ outsideGhcPkg ["init", ghcPackagePath dirStructure] + return () + +-- copy optional packages and don't fail completely if this copying fails +-- some packages mail fail to copy and it's not fatal (e.g. older GHCs don't have haskell2010) +transplantOptionalPackage :: String -> MyMonad () +transplantOptionalPackage name = transplantPackage (PackageName name) `catchError` handler + where handler e = do + warning $ "Failed to copy optional package " ++ name ++ " from system's GHC: " + indentMessages $ warning $ getExceptionMessage e + +-- copy base system +-- base - needed for ghci and everything else +-- Cabal - needed to install non-trivial cabal packages with cabal-install +-- haskell98 - some packages need it but they don't specify it (seems it's an implicit dependancy) +-- haskell2010 - maybe it's similar to haskell98? +-- ghc and ghc-binary - two packages that are provided with GHC and cannot be installed any other way +-- also include dependant packages of all the above +-- when using GHC from tarball, just reuse its package database +-- cannot do the same when using system's GHC, because there might be additional packages installed +-- then it wouldn't be possible to work on them insie virtual environment +copyBaseSystem :: MyMonad () +copyBaseSystem = do + info "Copying necessary packages from original GHC package database" + indentMessages $ do + ghc <- asks ghcSource + case ghc of + System -> do + transplantPackage $ PackageName "base" + transplantPackage $ PackageName "Cabal" + mapM_ transplantOptionalPackage ["haskell98", "haskell2010", "ghc", "ghc-binary"] + Tarball _ -> + debug "Using external GHC - nothing to copy, Virtual environment will reuse GHC package database" + +installGhc :: MyMonad () +installGhc = do + info "Installing GHC" + ghc <- asks ghcSource + case ghc of + System -> indentMessages $ debug "Using system version of GHC - nothing to install." + Tarball tarballPath -> indentMessages $ installExternalGhc tarballPath + +installExternalGhc :: FilePath -> MyMonad () +installExternalGhc tarballPath = do + info $ "Installing GHC from " ++ tarballPath + indentMessages $ do + dirStructure <- vheDirStructure + tmpGhcDir <- liftIO $ createTemporaryDirectory (virthualEnv dirStructure) "ghc" + debug $ "Unpacking GHC tarball to " ++ tmpGhcDir + _ <- indentMessages $ runProcess Nothing "tar" ["xf", tarballPath, "-C", tmpGhcDir, "--strip-components", "1"] Nothing + let configureScript = tmpGhcDir "configure" + debug $ "Configuring GHC with prefix " ++ ghcDir dirStructure + cwd <- liftIO getCurrentDirectory + liftIO $ setCurrentDirectory tmpGhcDir + make <- asks makeCmd + let configureAndInstall = do + _ <- indentMessages $ runProcess Nothing configureScript ["--prefix=" ++ ghcDir dirStructure] Nothing + debug $ "Installing GHC with " ++ make ++ " install" + _ <- indentMessages $ runProcess Nothing make ["install"] Nothing + return () + configureAndInstall `finally` liftIO (setCurrentDirectory cwd) + liftIO $ removeDirectoryRecursive tmpGhcDir + return () diff --git a/src/Args.hs b/src/Args.hs new file mode 100644 --- /dev/null +++ b/src/Args.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Args ( usage + , parseArgs + ) where + +import System.Directory (getCurrentDirectory) +import Data.List (isPrefixOf, isInfixOf) +import Data.Char (isAlphaNum) +import Data.Maybe (fromMaybe) +import Control.Monad (when) +import Data.Monoid (Monoid(..)) +import System.Environment (getProgName) +import System.FilePath (splitPath) +import Control.Monad.Error (MonadError, ErrorT, runErrorT, throwError) +import Control.Monad.State (MonadState, StateT, runStateT, get, put) +import Control.Monad.Trans (MonadIO, liftIO) + +import Types + +usage :: IO () +usage = do + name <- getProgName + putStrLn $ "usage: " ++ name ++ " [FLAGS]" + putStrLn "" + putStrLn "Flags:" + putStrLn "-h --help Show this help message" + putStrLn "--version Print version number" + putStrLn "--verbose Print some debugging info" + putStrLn "--very-verbose Print some debugging info" + putStrLn "--skip-sanity-check Skip all the sanity checks (use at your own risk)" + putStrLn "--name=NAME Use NAME for name of Virthual Haskell Environment" + putStrLn " (defaults to the name of the current directory)" + putStrLn "--ghc=FILE Use GHC from provided tarball (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2)" + putStrLn " Without this flag virthualenv will use system's copy of GHC" + putStrLn "--make-cmd=NAME Used as make substitute for installing GHC from tarball (e.g. gmake)," + putStrLn " defaults to 'make'" + putStrLn "" + putStrLn "Creates Virtual Haskell Environment in the current directory." + putStrLn "All files will be stored in the .virthualenv/ subdirectory." + +newtype ArgMonad a = ArgMonad (ErrorT String (StateT Args IO) a) + deriving (MonadState Args, MonadError String, Monad, MonadIO) + +data Args = Args { shortArgs :: [Char] + , longArgs :: [String] + , longValArgs :: [(String, String)] + , positionalArgs :: [String] + } + deriving Show + +emptyArgs :: Args +emptyArgs = Args [] [] [] [] + +instance Monoid Args where + mempty = Args [] [] [] [] + Args x1 y1 z1 t1 `mappend` Args x2 y2 z2 t2 = Args (x1 ++ x2) (y1 ++ y2) (z1 ++ z2) (t1 ++ t2) + +runArgMonad :: ArgMonad a -> [String] -> IO (Either String a) +runArgMonad (ArgMonad m) args = + case parseArguments args of + Left err -> return $ Left err + Right parsedArgs -> do + (result, leftOverArgs) <- runStateT (runErrorT m) parsedArgs + case leftOverArgs of + Args [] [] [] [] -> return result + Args shortOptions _ _ _ | not (null shortOptions) -> + return $ Left $ "Unknown short option identifiers: " ++ shortOptions + Args _ longOptions _ _ | not (null longOptions) -> + return $ Left $ "Unknown long option identifiers: " ++ unwords longOptions + Args _ _ longKeyValOptions _ | not (null longKeyValOptions) -> + return $ Left $ "Unknown long key-value options: " ++ unwords (map (\(k,v) -> k++"="++v) longKeyValOptions) + Args _ _ _ _ -> return $ Left $ "Unknown positional options: " ++ unwords (positionalArgs leftOverArgs) + +parseArguments :: [String] -> Either String Args +parseArguments args = + case break (== "--") args of + (keywordArgs, "--":rest) -> do + parsedKeywordArgs <- mapM parseArgument keywordArgs + return $ mconcat parsedKeywordArgs `mappend` emptyArgs{positionalArgs = rest} + + (_, []) -> mconcat `fmap` mapM parseArgument args + _ -> error "I'm stupid and I cannot code. I'm sorry." + +parseArgument :: String -> Either String Args +parseArgument arg | "--" `isPrefixOf` arg + && "=" `isInfixOf` arg = + let (x, y) = break (=='=') arg + key = drop (length "--") x + val = drop (length "=") y + in return emptyArgs{longValArgs = [(key, val)]} + | "--" `isPrefixOf` arg = + return emptyArgs{longArgs = [drop (length "--") arg]} + | "-" `isPrefixOf` arg = + let symbols = tail arg + in case symbols of + [] -> throwError "Empty list of short options (after '-')" + _ | any (not . isAlphaNum) symbols -> throwError "Non alpha-numeric short option" + | otherwise -> return emptyArgs{shortArgs = symbols} + | otherwise = return emptyArgs{positionalArgs = [arg]} + +getSingleLongValueArg :: String -> ArgMonad (Maybe String) +getSingleLongValueArg argName = do + args <- get + case filter (\(k,_) -> k == argName) $ longValArgs args of + [] -> return Nothing + [(_, val)] -> do + put args{longValArgs = filter (\(k,_) -> k /= argName) $ longValArgs args} + return $ Just val + _ -> throwError $ "Multiple values with key " ++ argName + +isSingleValueSet :: String -> ArgMonad Bool +isSingleValueSet argName = do + args <- get + case filter (==argName) $ longArgs args of + [] -> return False + [_] -> do + put args{longArgs = filter (/=argName) $ longArgs args} + return True + _ -> throwError $ "Multiple values named " ++ argName + +realParseArgs :: ArgMonad Options +realParseArgs = do + verbosityFlag <- isSingleValueSet "verbose" + verbosityFlag2 <- isSingleValueSet "very-verbose" + let verboseness = case (verbosityFlag, verbosityFlag2) of + (_, True) -> VeryVerbose + (True, False) -> Verbose + (False, False) -> Quiet + nameFlag <- getSingleLongValueArg "name" + name <- case nameFlag of + Just name' -> return name' + Nothing -> do + cwd <- liftIO getCurrentDirectory + let dirs = splitPath cwd + name = last dirs + when (verboseness > Quiet) $ liftIO $ putStrLn $ "Using current directory name as Virtual Haskell Environment name: " ++ name + return name + ghcFlag <- getSingleLongValueArg "ghc" + let ghc = case ghcFlag of + Nothing -> System + Just path -> Tarball path + skipSanityCheckFlag <- isSingleValueSet "skip-sanity-check" + makeCmdFlag <- getSingleLongValueArg "make-cmd" + let make = fromMaybe "make" makeCmdFlag + return Options{ verbosity = verboseness + , skipSanityCheck = skipSanityCheckFlag + , vheName = name + , ghcSource = ghc + , makeCmd = make + } + +parseArgs :: [String] -> IO (Either String Options) +parseArgs = runArgMonad realParseArgs diff --git a/src/MyMonad.hs b/src/MyMonad.hs new file mode 100644 --- /dev/null +++ b/src/MyMonad.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module MyMonad ( MyMonad + , runMyMonad + , indentMessages + , debug + , info + , trace + , warning + , finally + , throwError + , catchError + , asks + , gets + , tell + , modify + , liftIO + ) where + +import Types + +import Control.Monad.Trans (MonadIO, liftIO) +import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, asks) +import Control.Monad.Writer (WriterT, MonadWriter, runWriterT, tell) +import Control.Monad.State (StateT, MonadState, evalStateT, modify, gets) +import Control.Monad.Error (ErrorT, MonadError, runErrorT, throwError, catchError) +import Control.Monad (when) +import System.IO (stderr, hPutStrLn) + +import Prelude hiding (log) + +newtype MyMonad a = MyMonad (StateT MyState (ReaderT Options (ErrorT MyException (WriterT [String] IO))) a) + deriving (Functor, Monad, MonadReader Options, MonadState MyState, MonadError MyException, MonadWriter [String]) + +instance MonadIO MyMonad where + liftIO m = MyMonad $ do + x <- liftIO $ (Right `fmap` m) `catch` (return . Left) + case x of + Left e -> throwError $ MyException $ "IO error: " ++ show e + Right y -> return y + +runMyMonad :: MyMonad a -> Options -> IO (Either MyException a, [String]) +runMyMonad (MyMonad m) = runWriterT . runErrorT . runReaderT (evalStateT m (MyState 0)) + +finally :: MyMonad a -> MyMonad b -> MyMonad a +finally m sequel = do + result <- (Right `fmap` m) `catchError` (return . Left) + _ <- sequel + case result of + Left e -> throwError e + Right x -> return x + +indentMessages :: MyMonad a -> MyMonad a +indentMessages m = do + modify (\s -> s{logDepth = logDepth s + 2}) + result <- m + modify (\s -> s{logDepth = logDepth s - 2}) + return result + +-- add message to private log and return adjusted message (with log depth) +-- that can be printed somewhere else +privateLog :: String -> MyMonad String +privateLog str = do + depth <- gets logDepth + let text = replicate (fromInteger depth) ' ' ++ str + tell [text] + return text + +log :: Verbosity -> String -> MyMonad () +log minLevel str = do + text <- privateLog str + flag <- asks verbosity + when (flag >= minLevel) $ + liftIO $ putStrLn text + +debug :: String -> MyMonad () +debug = log Verbose + +info :: String -> MyMonad () +info = log Quiet + +trace :: String -> MyMonad () +trace = log VeryVerbose + +warning :: String -> MyMonad () +warning str = do + text <- privateLog str + liftIO $ hPutStrLn stderr text diff --git a/src/PackageManagement.hs b/src/PackageManagement.hs new file mode 100644 --- /dev/null +++ b/src/PackageManagement.hs @@ -0,0 +1,103 @@ +module PackageManagement ( Transplantable(..) + , parseVersion + , parsePkgInfo + ) where + +import Distribution.Package (PackageIdentifier(..), PackageName(..)) +import Distribution.Version (Version(..)) +import Control.Monad (unless) + +import Types +import MyMonad +import Process (outsideGhcPkg, insideGhcPkg) +import Util.Cabal (prettyPkgInfo, prettyVersion) +import qualified Util.Cabal (parseVersion, parsePkgInfo) + +parseVersion :: String -> MyMonad Version +parseVersion s = case Util.Cabal.parseVersion s of + Nothing -> throwError $ MyException $ "Couldn't parse " ++ s ++ " as a package version" + Just version -> return version + +parsePkgInfo :: String -> MyMonad PackageIdentifier +parsePkgInfo s = case Util.Cabal.parsePkgInfo s of + Nothing -> throwError $ MyException $ "Couldn't parse package identifier " ++ s + Just pkgInfo -> return pkgInfo + +getDeps :: PackageIdentifier -> MyMonad [PackageIdentifier] +getDeps pkgInfo = do + let prettyPkg = prettyPkgInfo pkgInfo + debug $ "Extracting dependencies of " ++ prettyPkg + out <- indentMessages $ outsideGhcPkg ["field", prettyPkg, "depends"] + -- example output: + -- depends: ghc-prim-0.2.0.0-3fbcc20c802efcd7c82089ec77d92990 + -- integer-gmp-0.2.0.0-fa82a0df93dc30b4a7c5654dd7c68cf4 builtin_rts + case words out of + [] -> throwError $ MyException $ "Couldn't parse ghc-pkg output to find dependencies of " ++ prettyPkg + _:depStrings -> do -- skip 'depends:' + indentMessages $ trace $ "Found dependency strings: " ++ unwords depStrings + mapM parsePkgInfo depStrings + +-- things that can be copied from system's GHC pkg database +-- to GHC pkg database inside virtual environment +class Transplantable a where + transplantPackage :: a -> MyMonad () + +-- choose the highest installed version of package with this name +instance Transplantable PackageName where + transplantPackage (PackageName packageName) = do + debug $ "Copying package " ++ packageName ++ " to Virtual Haskell Environment." + indentMessages $ do + debug "Choosing package with highest version number." + out <- indentMessages $ outsideGhcPkg ["field", packageName, "version"] + -- example output: + -- version: 1.1.4 + -- version: 1.2.0.3 + let extractVersionString :: String -> MyMonad String + extractVersionString line = case words line of + [_, x] -> return x + _ -> throwError $ MyException $ "Couldn't extract version string from: " ++ line + versionStrings <- mapM extractVersionString $ lines out + indentMessages $ trace $ "Found version strings: " ++ unwords versionStrings + versions <- mapM parseVersion versionStrings + case versions of + [] -> throwError $ MyException $ "No versions of package " ++ packageName ++ " found" + (v:vs) -> do + indentMessages $ debug $ "Found: " ++ unwords (map prettyVersion versions) + let highestVersion = foldr max v vs + indentMessages $ debug $ "Using version: " ++ prettyVersion highestVersion + let pkgInfo = PackageIdentifier (PackageName packageName) highestVersion + transplantPackage pkgInfo + +-- check if this package is already installed in Virtual Haskell Environment +checkIfInstalled :: PackageIdentifier -> MyMonad Bool +checkIfInstalled pkgInfo = do + let package = prettyPkgInfo pkgInfo + debug $ "Checking if " ++ package ++ " is already installed." + (do + _ <- indentMessages $ insideGhcPkg ["describe", package] Nothing + indentMessages $ debug "It is." + return True) `catchError` handler + where handler _ = do + debug "It's not." + return False + +instance Transplantable PackageIdentifier where + transplantPackage pkgInfo = do + let prettyPkg = prettyPkgInfo pkgInfo + debug $ "Copying package " ++ prettyPkg ++ " to Virtual Haskell Environment." + indentMessages $ do + flag <- checkIfInstalled pkgInfo + unless flag $ do + deps <- getDeps pkgInfo + debug $ "Found: " ++ unwords (map prettyPkgInfo deps) + mapM_ transplantPackage deps + movePackage pkgInfo + +-- copy single package that already has all deps satisfied +movePackage :: PackageIdentifier -> MyMonad () +movePackage pkgInfo = do + let prettyPkg = prettyPkgInfo pkgInfo + debug $ "Moving package " ++ prettyPkg ++ " to Virtual Haskell Environment." + out <- outsideGhcPkg ["describe", prettyPkg] + _ <- insideGhcPkg ["register", "-"] (Just out) + return () diff --git a/src/Paths.hs b/src/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Paths.hs @@ -0,0 +1,45 @@ +module Paths ( vheDirStructure + , cabalConfigLocation + , getVirtualEnvironment + ) where + +import System.FilePath (()) +import System.Directory (getCurrentDirectory) +import System.Environment (getEnvironment) + +import Types +import MyMonad + +-- returns record containing paths to all important directories +-- inside virtual environment dir structure +vheDirStructure :: MyMonad DirStructure +vheDirStructure = do + cwd <- liftIO getCurrentDirectory + let virthualEnvLocation = cwd + virthualEnvDirLocation = virthualEnvLocation ".virthualenv" + cabalDirLocation = virthualEnvDirLocation "cabal" + ghcDirLocation = virthualEnvDirLocation "ghc" + return DirStructure { virthualEnv = virthualEnvLocation + , virthualEnvDir = virthualEnvDirLocation + , ghcPackagePath = virthualEnvDirLocation "ghc_pkg_db" + , cabalDir = cabalDirLocation + , cabalBinDir = cabalDirLocation "bin" + , virthualEnvBinDir = virthualEnvDirLocation "bin" + , ghcDir = ghcDirLocation + , ghcBinDir = ghcDirLocation "bin" + } + +-- returns location of cabal's config file inside virtual environment dir structure +cabalConfigLocation :: MyMonad FilePath +cabalConfigLocation = do + dirStructure <- vheDirStructure + return $ cabalDir dirStructure "config" + +-- returns environment dictionary used in Virtual Haskell Environment +-- it's inherited from the current process, but variable +-- GHC_PACKAGE_PATH is altered. +getVirtualEnvironment :: MyMonad [(String, String)] +getVirtualEnvironment = do + env <- liftIO getEnvironment + dirStructure <- vheDirStructure + return $ ("GHC_PACKAGE_PATH", ghcPackagePath dirStructure) : filter (\(k,_) -> k /= "GHC_PACKAGE_PATH") env diff --git a/src/Process.hs b/src/Process.hs new file mode 100644 --- /dev/null +++ b/src/Process.hs @@ -0,0 +1,108 @@ +module Process ( externalGhcPkgDb + , outsideGhcPkg + , insideGhcPkg + , runProcess + , ghcPkgDbPathLocation + ) where + +import Types +import MyMonad +import Paths + +import Util.IO (readProcessWithExitCodeInEnv, Environment) + +import Control.Monad (forM_) +import Data.Maybe (fromMaybe) +import System.FilePath (()) +import System.Process (readProcessWithExitCode) +import System.Exit (ExitCode(..)) + +runProcess :: Maybe Environment -> FilePath -> [String] -> Maybe String -> MyMonad String +runProcess env prog args input = do + debug $ unwords $ ["Executing:", prog] ++ args + indentMessages $ case env of + Nothing -> trace "using inherited variable environment" + Just env' -> do + trace "using following environment:" + indentMessages $ forM_ env' $ \(var,val) -> trace $ var ++ ": " ++ val + indentMessages $ case input of + Nothing -> return () + Just inp -> do + trace "using the following input:" + indentMessages $ forM_ (lines inp) trace + let execProcess = case env of + Nothing -> readProcessWithExitCode prog args (fromMaybe "" input) + Just env' -> readProcessWithExitCodeInEnv env' prog args input + (exitCode, output, errors) <- liftIO execProcess + indentMessages $ debug $ case exitCode of + ExitSuccess -> "Process exited successfully" + ExitFailure errCode -> "Process failed with exit code " ++ show errCode + indentMessages $ do + trace "Process output:" + indentMessages $ forM_ (lines output) trace + indentMessages $ do + trace "Process error output:" + indentMessages $ forM_ (lines errors) trace + case exitCode of + ExitSuccess -> return output + ExitFailure errCode -> throwError $ MyException $ prog ++ " process failed with status " ++ show errCode + +-- run outside ghc-pkg tool (uses system's or from ghc installed from tarball) +outsideGhcPkg :: [String] -> MyMonad String +outsideGhcPkg args = do + ghc <- asks ghcSource + dirStructure <- vheDirStructure + ghcPkg <- case ghc of + System -> do + debug "Running system's version of ghc-pkg" + return "ghc-pkg" + Tarball _ -> do + debug "Running ghc-pkg installed from GHC's tarball" + return $ ghcDir dirStructure "bin" "ghc-pkg" + indentMessages $ runProcess Nothing ghcPkg args Nothing + +-- returns path to GHC (installed from tarball) builtin package database +externalGhcPkgDb :: MyMonad FilePath +externalGhcPkgDb = do + debug "Checking where GHC (installed from tarball) keeps its package database" + out <- indentMessages $ outsideGhcPkg ["list"] + indentMessages $ debug "Trying to parse ghc-pkg's output" + case lines out of + [] -> throwError $ MyException "ghc-pkg returned empty output" + lineWithPath:_ -> + case lineWithPath of + "" -> throwError $ MyException "ghc-pkg's first line of output is empty" + _ -> do + -- ghc-pkg ends pkg db path with trailing colon + -- but only when not run from the terminal + let path = init lineWithPath + indentMessages $ debug $ "Found: " ++ path + return path + +-- run ghc-pkg tool (uses system's or from ghc installed from tarball) +-- from the inside of Virtual Haskell Environment +insideGhcPkg :: [String] -> Maybe String -> MyMonad String +insideGhcPkg args input = do + ghc <- asks ghcSource + dirStructure <- vheDirStructure + env <- getVirtualEnvironment + ghcPkg <- case ghc of + System -> do + debug "Running system's version of ghc-pkg inside virtual environment" + return "ghc-pkg" + Tarball _ -> do + debug "Running ghc-pkg, installed from GHC's tarball, inside virtual environment" + return $ ghcDir dirStructure "bin" "ghc-pkg" + indentMessages $ runProcess (Just env) ghcPkg args input + +-- returns value of GHC_PACKAGE_PATH that should be used inside virtual environment +ghcPkgDbPathLocation :: MyMonad String +ghcPkgDbPathLocation = do + debug "Determining value of GHC_PACKAGE_PATH to be used inside virtual environment" + dirStructure <- vheDirStructure + ghc <- asks ghcSource + case ghc of + System -> return $ ghcPackagePath dirStructure + Tarball _ -> do + externalGhcPkgDbPath <- indentMessages externalGhcPkgDb + return $ ghcPackagePath dirStructure ++ ":" ++ externalGhcPkgDbPath diff --git a/src/SanityCheck.hs b/src/SanityCheck.hs new file mode 100644 --- /dev/null +++ b/src/SanityCheck.hs @@ -0,0 +1,63 @@ +module SanityCheck (sanityCheck) where + +import Control.Monad (when) +import System.Directory (doesDirectoryExist) + +import Util.IO (getEnvVar, which) +import Types +import MyMonad +import Paths (vheDirStructure) + +-- check if any virtual env is already active +checkVHE :: MyMonad () +checkVHE = do + virthualEnvVar <- liftIO $ getEnvVar "VIRTHUALENV" + case virthualEnvVar of + Nothing -> return () + Just path -> do + virthualEnvName <- liftIO $ getEnvVar "VIRTHUALENV_NAME" + case virthualEnvName of + Nothing -> do + debug $ "warning: VIRTHUALENV environment variable is defined" ++ ", but no VIRHTUALENV_NAME environment variable defined." + throwError $ MyException $ "There is already active Virtual Haskell Environment (at " ++ path ++ ")." + Just name -> + throwError $ MyException $ "There is already active " ++ name ++ " Virtual Haskell Environment (at " ++ path ++ ")." + +checkVirthualEnvAlreadyExists :: MyMonad () +checkVirthualEnvAlreadyExists = do + dirStructure <- vheDirStructure + flag <- liftIO $ doesDirectoryExist $ virthualEnvDir dirStructure + when flag $ throwError $ MyException $ "There is already .virthualenv directory at " ++ virthualEnv dirStructure + +-- check if cabal binary exist on PATH +checkCabalInstall :: MyMonad () +checkCabalInstall = do + cabalInstallPath <- liftIO $ which "cabal" + case cabalInstallPath of + Just _ -> return () + Nothing -> throwError $ MyException "Couldn't find cabal binary (from cabal-install package) in your $PATH." + +-- check if GHC tools (ghc, ghc-pkg) exist on PATH +-- skip the check if using GHC from a tarball +checkGhc :: MyMonad () +checkGhc = do + ghcSrc <- asks ghcSource + case ghcSrc of + Tarball _ -> return () + System -> do + ghcPath <- liftIO $ which "ghc" + case ghcPath of + Just _ -> return () + Nothing -> throwError $ MyException "Couldn't find ghc binary in your $PATH." + ghc_pkgPath <- liftIO $ which "ghc-pkg" + case ghc_pkgPath of + Just _ -> return () + Nothing -> throwError $ MyException "Couldn't find ghc-pkg binary in your $PATH." + +-- check if everything is sane +sanityCheck :: MyMonad () +sanityCheck = do + checkVHE + checkVirthualEnvAlreadyExists + checkCabalInstall + checkGhc diff --git a/src/Skeletons.hs b/src/Skeletons.hs new file mode 100644 --- /dev/null +++ b/src/Skeletons.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Skeletons where + +import Data.FileEmbed (embedFile) +import Data.ByteString.Char8 (unpack) +import System.FilePath (()) + +activateSkel :: String +activateSkel = unpack $(embedFile $ "skeletons" "activate") + +cabalWrapperSkel :: String +cabalWrapperSkel = unpack $(embedFile $ "skeletons" "cabal") + +cabalConfigSkel :: String +cabalConfigSkel = unpack $(embedFile $ "skeletons" "cabal_config") diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Types ( GhcSource(..) + , Options(..) + , MyState(..) + , DirStructure(..) + , MyException(..) + , Verbosity(..) + ) where + +import Control.Monad.Error (Error) + +data GhcSource = System -- Use System's copy of GHC + | Tarball FilePath -- Use GHC from tarball + +data Verbosity = Quiet + | Verbose + | VeryVerbose + deriving (Eq, Ord) + +data Options = Options { verbosity :: Verbosity + , skipSanityCheck :: Bool + , vheName :: String -- Virtual Haskell Environment name + , ghcSource :: GhcSource + , makeCmd :: String -- make substitute used for 'make install' of external GHC + } + +data MyState = MyState { logDepth :: Integer -- used for indentation of logging messages + } + +newtype MyException = MyException { getExceptionMessage :: String } + deriving Error + +-- Only absolute paths! +data DirStructure = DirStructure { virthualEnv :: FilePath -- dir containing .virthualenv dir (usually dir with cabal project) + , virthualEnvDir :: FilePath -- .virthualenv dir + , ghcPackagePath :: FilePath -- file (=ghc-6.12) containing private GHC pkg db + , cabalDir :: FilePath -- directory with private cabal dir + , cabalBinDir :: FilePath -- cabal's bin/ dir (used in $PATH) + , virthualEnvBinDir :: FilePath -- dir with haskell tools wrappers and activate script + , ghcDir :: FilePath -- directory with private copy of external GHC (only used when using GHC from tarball) + , ghcBinDir :: FilePath -- ghc's bin/ dir (with ghc[i|-pkg]) (only used when using GHC from tarball) + } diff --git a/src/Util/Cabal.hs b/src/Util/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Util/Cabal.hs @@ -0,0 +1,39 @@ +module Util.Cabal ( prettyVersion + , prettyPkgInfo + , parseVersion + , parsePkgInfo + ) where + +import Distribution.Version (Version(..)) +import Distribution.Package (PackageIdentifier(..), PackageName(..)) +import Distribution.Compat.ReadP (readP_to_S) +import Distribution.Text (parse, Text) + +import Data.Char (isSpace) +import Data.List (isPrefixOf, intercalate) + +-- render Version to human and ghc-pkg readable string +prettyVersion :: Version -> String +prettyVersion (Version [] _) = "" +prettyVersion (Version numbers _) = intercalate "." $ map show numbers + +-- render PackageIdentifier to human and ghc-pkg readable string +prettyPkgInfo :: PackageIdentifier -> String +prettyPkgInfo (PackageIdentifier (PackageName name) (Version [] _)) = name +prettyPkgInfo (PackageIdentifier (PackageName name) version) = + name ++ "-" ++ prettyVersion version + +parseVersion :: String -> Maybe Version +parseVersion = parseCheck + +parseCheck :: Text a => String -> Maybe a +parseCheck str = + case [ x | (x,ys) <- readP_to_S parse str, all isSpace ys ] of + [x] -> Just x + _ -> Nothing + +parsePkgInfo :: String -> Maybe PackageIdentifier +parsePkgInfo str | "builtin_" `isPrefixOf` str = + let name = drop (length "builtin_") str -- ghc-pkg doesn't like builtin_ prefix + in Just $ PackageIdentifier (PackageName name) $ Version [] [] + | otherwise = parseCheck str diff --git a/src/Util/IO.hs b/src/Util/IO.hs new file mode 100644 --- /dev/null +++ b/src/Util/IO.hs @@ -0,0 +1,81 @@ +module Util.IO ( getEnvVar + , makeExecutable + , readProcessWithExitCodeInEnv + , Environment + , createTemporaryDirectory + , which + ) where + +import System.Environment (getEnv) +import System.IO.Error (isDoesNotExistError) +import System.Directory (getPermissions, setPermissions, executable, removeFile, createDirectory, doesFileExist) +import Control.Concurrent (forkIO, putMVar, takeMVar, newEmptyMVar) +import Control.Exception (evaluate) +import System.Process (runInteractiveProcess, waitForProcess) +import System.IO (hGetContents, hPutStr, hFlush, hClose, openTempFile) +import System.Exit (ExitCode) +import Data.List.Split (splitOn) +import Control.Monad (foldM) +import System.FilePath (()) + +-- Computation getEnvVar var returns Just the value of the environment variable var, +-- or Nothing if the environment variable does not exist +getEnvVar :: String -> IO (Maybe String) +getEnvVar var = Just `fmap` getEnv var `catch` noValueHandler + where noValueHandler e | isDoesNotExistError e = return Nothing + | otherwise = ioError e + +makeExecutable :: FilePath -> IO () +makeExecutable path = do + perms <- getPermissions path + setPermissions path perms{executable = True} + +type Environment = [(String, String)] + +-- like readProcessWithExitCode, but takes additional environment argument +readProcessWithExitCodeInEnv :: Environment -> FilePath -> [String] -> Maybe String -> IO (ExitCode, String, String) +readProcessWithExitCodeInEnv env progName args input = do + (inh, outh, errh, pid) <- runInteractiveProcess progName args Nothing (Just env) + out <- hGetContents outh + outMVar <- newEmptyMVar + _ <- forkIO $ evaluate (length out) >> putMVar outMVar () + err <- hGetContents errh + errMVar <- newEmptyMVar + _ <- forkIO $ evaluate (length err) >> putMVar errMVar () + case input of + Just inp | not (null inp) -> hPutStr inh inp >> hFlush inh + _ -> return () + hClose inh + takeMVar outMVar + hClose outh + takeMVar errMVar + hClose errh + ex <- waitForProcess pid + return (ex, out, err) + +-- similar to openTempFile, but creates a temporary directory +-- and returns its path +createTemporaryDirectory :: FilePath -> String -> IO FilePath +createTemporaryDirectory parentDir templateName = do + (path, handle) <- openTempFile parentDir templateName + hClose handle + removeFile path + createDirectory path + return path + +which :: String -> IO (Maybe FilePath) +which name = do + path <- getEnvVar "PATH" + case path of + Nothing -> return Nothing + Just path' -> do + let pathElems = splitOn ":" path' + aux x@(Just _) _ = return x + aux Nothing pathDir = do + let programPath = pathDir name + flag <- doesFileExist programPath + if flag then + return $ Just programPath + else + return Nothing + foldM aux Nothing pathElems diff --git a/src/Util/Template.hs b/src/Util/Template.hs new file mode 100644 --- /dev/null +++ b/src/Util/Template.hs @@ -0,0 +1,22 @@ +module Util.Template ( substs + ) where + +import Data.List (isPrefixOf) + +-- Simple templating system +-- most of the existing tools are either too complicated +-- or use $ (or even ${}) chars for variables, which is unfortunate +-- for use with [ba]sh templates. + +type Substitution = (String, String) + +-- substitute all occurences of FROM to TO +subst :: Substitution -> String -> String +subst _ [] = [] +subst phi@(from, to) input@(x:xs) + | from `isPrefixOf` input = to ++ subst phi (drop (length from) input) + | otherwise = x:subst phi xs + +-- multi version of subst +substs :: [Substitution] -> String -> String +substs phis str = foldr subst str phis diff --git a/src/virthualenv.hs b/src/virthualenv.hs new file mode 100644 --- /dev/null +++ b/src/virthualenv.hs @@ -0,0 +1,55 @@ +import System.Environment (getArgs) +import System.IO (stderr, hPutStrLn) +import System.Exit (exitFailure) +import System.FilePath (()) + +import Types +import MyMonad +import Actions +import SanityCheck (sanityCheck) +import Args (usage, parseArgs) + +main :: IO () +main = do + args <- getArgs + case args of + ["--version"] -> putStrLn "0.2" + ["--help"] -> usage + ["-h"] -> usage + _ -> + do + opts <- parseArgs args + case opts of + Left err -> do + hPutStrLn stderr err + usage + exitFailure + Right options -> do + (result, messageLog) <- runMyMonad realMain options + case result of + Left err -> do + hPutStrLn stderr $ getExceptionMessage err + hPutStrLn stderr "" + hPutStrLn stderr "virthualenv.log file contains detailed description of the process." + let errorLog = unlines $ messageLog ++ ["", getExceptionMessage err] + writeFile "virthualenv.log" errorLog + exitFailure + Right () -> writeFile (".virthualenv" "virthualenv.log") $ unlines messageLog + +realMain :: MyMonad () +realMain = do + skipSanityCheckFlag <- asks skipSanityCheck + if skipSanityCheckFlag then + info "WARNING: sanity checks are disabled." + else + sanityCheck + createDirStructure + installGhc + initGhcDb + copyBaseSystem + installCabalConfig + installActivateScript + installCabalWrapper + cabalUpdate + info "" + info "To activate the new environment use 'source .virthualenv/bin/activate'" diff --git a/virthualenv.cabal b/virthualenv.cabal new file mode 100644 --- /dev/null +++ b/virthualenv.cabal @@ -0,0 +1,127 @@ +Name: virthualenv + +Version: 0.2 + +Synopsis: Virtual Haskell Environment builder + +Description: virthualenv is a tool (inspired by Python's virtualenv) to create isolated Haskell environments. + . + It creates a sandboxed environment in a .virthualenv/ directory, which, when activated, + allows you to use regular Haskell tools (ghc, ghci, ghc-pkg, cabal) to manage your Haskell + code and environment. It's possible to create an environment, that uses different GHC version + than your currently installed. virthualenv is supposed to be easier to learn (and use) than + similar packages (like cabal-dev or capri). + . + Basic usage. + . + First, choose a directory where you want to keep your sandboxed Haskell environment, + usually a good choice is a directory containing your cabalized project (if you want to work + on a few projects (perhaps an app and its dependent library), just choose any of them, + it doesn't really matter). Enter that directory: + . + > cd ~/projects/foo + . + Next, create your new isolated Haskell environment (this is a one time only (per environment) step): + . + > virthualenv + . + Now, every time you want to use this enviroment, you have to activate it: + . + > source .virthualenv/bin/activate + . + That's it! Now it's possible to use all regular Haskell tools like usual, but it won't affect + your global/system's Haskell environment, and also your per-user environment (from ~/.cabal and + ~/.ghc) will stay the same. All cabal-installed packages will be private to this environment, + and also the external environments (global and user) will not affect it (this environment + will only inherit very basic packages - mostly ghc and Cabal and their deps). + . + When you're done working with this environment, enter command 'deactivate', + or just close the current shell (with exit). + . + > deactivate + . + Advanced usage. + . + The only advanced usage is using different GHC version. This can be useful to test your code + against different GHC version (even against nightly builds). + . + First, download binary distribution of GHC for your platform + (e.g. ghc-7.0.4-i386-unknown-linux.tar.bz2), then create a new environment using that GHC + . + > virthualenv --ghc=/path/to/ghc_something.tar.bz2 + . + Then, proceed (with [de]activation) as in basic case. + . + Misc. + . + virthualenv has been tested on i386 Linux systems, but it should work on any Posix platform. + External (from tarball) GHC feature requires binary GHC distribution compiled for your platform, + that can be extracted with tar and installed with "./configure --prefix=PATH; make install". + . + For more info please consult "virthualenv --help" or the attached README file. + +Homepage: https://github.com/Paczesiowa/virthualenv + +License: BSD3 + +License-file: LICENSE + +Author: Bartosz Ćwikłowski + +Maintainer: paczesiowa@gmail.com + +Copyright: (c) 2011 Bartosz Ćwikłowski + +Category: Development + +Build-type: Simple + +Stability: alpha + +Bug-reports: https://github.com/Paczesiowa/virthualenv/issues + +Package-url: http://hackage.haskell.org/package/virthualenv + +Tested-with: GHC == 6.12.3, GHC == 7.0.4 + +Data-files: virthualenv.el, README.md + +Extra-source-files: skeletons/activate, skeletons/cabal, skeletons/cabal_config + +Cabal-version: >=1.6 + +Executable virthualenv + + Main-is: virthualenv.hs + + Hs-source-dirs: src + + Ghc-options: -threaded -Wall + + Build-depends: base >= 4.2.0.0 && < 4.5 + , process >= 1.0.1.2 && < 1.2 + , filepath >= 1.1.0.3 && < 1.3 + , directory >= 1.0.1.0 && < 1.2 + , Cabal >= 1.8.0.6 && < 1.13 + , mtl >= 1.1.0.2 && < 2.1 + , bytestring >= 0.9.1.7 && < 0.10 + , file-embed >= 0.0.4.1 && < 0.1 + , split >= 0.1.4 && < 0.2 + , safe >= 0.3 && < 0.4 + + Other-modules: Util.Cabal + , Util.Template + , Util.IO + , Skeletons + , Types + , MyMonad + , Args + , Paths + , SanityCheck + , Process + , PackageManagement + , Actions + +Source-repository head + Type: git + Location: git://github.com/Paczesiowa/virthualenv.git diff --git a/virthualenv.el b/virthualenv.el new file mode 100644 --- /dev/null +++ b/virthualenv.el @@ -0,0 +1,42 @@ +(setq virthualenv nil) +(setq virthualenv-path-backup nil) +(setq virthualenv-exec-path-backup nil) + +(defun virthualenv-read-file (fpath) + (with-temp-buffer + (insert-file-contents fpath) + (buffer-string))) + +(defun virthualenv-activate (dir) + "Activate the Virtual Haskell Environment in DIR" + (interactive "Dvirthualenv directory: ") + (when (equal (char-list-to-string (last (string-to-list dir))) + "/") + (setq dir (subseq dir + 0 + (- (length dir) 1)))) + (let* ((virthualenv-dir (concat dir "/.virthualenv/")) + (path-var-prependix-location (concat virthualenv-dir "path_var_prependix")) + (ghc-package-path-var-location (concat virthualenv-dir "ghc_package_path_var")) + (path-var-prependix (virthualenv-read-file path-var-prependix-location)) + (ghc-package-path-var (virthualenv-read-file ghc-package-path-var-location)) + (new-path-var (concat path-var-prependix ":" (getenv "PATH"))) + (exec-path-prependix (split-string path-var-prependix ":"))) + (setq virthualenv-path-backup (getenv "PATH")) + (setenv "PATH" new-path-var) + (setq virthualenv-exec-path-backup exec-path) + (setq exec-path (append exec-path-prependix exec-path)) + (setenv "GHC_PACKAGE_PATH" ghc-package-path-var) + (setq virthualenv dir))) + +(defun virthualenv-deactivate () + "Deactivate the Virtual Haskell Environment" + (interactive) + (setenv "PATH" virthualenv-path-backup) + (setq exec-path virthualenv-exec-path-backup) + (setenv "GHC_PACKAGE_PATH" nil) + (setq virthualenv nil) + (setq virthualenv-path-backup nil) + (setq virthualenv-exec-path-backup nil)) + +(provide 'virthualenv)