diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,26 +7,39 @@ What sets this package apart from other `eval` implementations, is the ability to control which packages and modules are available during evaluation. This is -achieved by calling out to the [Nix package manager](http://nix.nixos.org). +achieved by calling out to the [Nix package manager](http://nixos.org/nix). -# Implementation Details +## Implementation Details `Expr` is the type of expressions, which contains a list of package names, a -list of modules to import and a `String` of Haskell code. All of these are just -`String`s internally, but the wrappers prevent accidentally using package as -modules, etc. A few combinators are provided for common manipulations, and the -`OverloadedStrings` extension allows packages, modules and expressions to be -written as literals. Note that literal expressions are given an empty context; -you will have to specify any required modules or packages separately. +list of modules to import, a list of compiler flags, a list of `String`s to +put in the generated module and a `String` of Haskell code to evaluate. All of +these are just `String`s internally, but we use wrappers to prevent accidentally +using packages as modules, etc. -When evaluated, the Haskell code is prefixed by an import of each module and -wrapped in `main = putStr (..)`, then piped into `runhaskell`. That process is -invoked via the `nix-shell` command, using Nix's standard -`haskellPackages.ghcWithPackages` function to ensure the GHC instance has all of -the given packages available. +A few combinators are provided for common manipulations, for example +`qualified "Foo" "bar"` will produce the expression `"Foo.bar"` with `"Foo"` in +its module list. The `OverloadedStrings` extension allows packages, modules, +flags and expressions to be written as literals. Note that literal expressions +are given an empty context; you will have to specify any required modules, +packages, etc. separately. +When evaluated, the Haskell code is prefixed by an import of each module, the +"preamble" strings (if any) and wrapped in `main = putStr (..)`. This code is +piped into `runhaskell`. If any flags are specified, they are appended as +arguments to the `runhaskell` command. + +The `runhaskell` process itself is invoked via the `nix-shell` command, which +provides all of the required packages via the `ghcWithPackages` mechanism of +nixpkgs. Packages are taken from nixpkgs's `haskellPackages` set by default, +which can be overridden by setting the `NIX_EVAL_HASKELL_PKGS` environment +variable to the path of a Nix file. Note that the package names used in your +Haskell code should correspond to the keys in this package set, which might +differ from those used on Hackage. + If the process exits successfully, its stdout will be returned wrapped in -`Just`; otherwise `Nothing` is returned. +`Just`; otherwise `Nothing` is returned. If you wish to alter the `main` +implementation, use `Language.Eval.Internal.eval'` This implementation is a little rough; for example, you may prefer to use `Text` rather than `String`; use a better representation like the syntax trees from @@ -42,10 +55,11 @@ it into a more appropriate type: it's not our place to choose how the result should be parsed, so we avoid the problem; by that point, our job is done. -# Limitations +## Limitations - Since evaluation takes place in a separate GHC process, there can be no - sharing of data (unless you provide a separate mechanism like a FIFO) + sharing of data outside the strings provided (unless you provide a separate + mechanism like a FIFO) - Expressions are wrapped in `putStr`, so the expression must be a `String`. You may need to marshall your data into a form which is more amenable to serialising/deserialising via `String`. @@ -67,7 +81,7 @@ instances. - Combining both package lists can make modules ambiguous. - If the dependencies of two packages conflict, evaluation will fail. - - Language extensions aren't handled yet. I'll add them as and when the need - arises. - As with any kind of `eval`, there is absolutely no security. Do not pass - potentially-malicious user input to this library. + potentially-malicious user input to this library! Not only can arbitrary + Haskell code be run (eg. using `unsafePerformIO`, but the flags are also a + shell injection vector. diff --git a/ghcEnvWithPkgs.nix b/ghcEnvWithPkgs.nix new file mode 100644 --- /dev/null +++ b/ghcEnvWithPkgs.nix @@ -0,0 +1,17 @@ +with builtins; + +{ hsPkgs ? null, pkgNames, name }: + +let pkgs = import {}; + envPkgs = getEnv "NIX_EVAL_HASKELL_PKGS"; + haskellPackages = if hsPkgs == null + then if envPkgs == "" + then pkgs.haskellPackages + else import envPkgs + else hsPkgs; + + in pkgs.buildEnv { + inherit name; + paths = [ (haskellPackages.ghcWithPackages + (h: map (p: h."${p}") pkgNames)) ]; + } diff --git a/nix-eval.cabal b/nix-eval.cabal --- a/nix-eval.cabal +++ b/nix-eval.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: nix-eval -version: 0.1.0.2 +version: 0.3.3.0 synopsis: Evaluate Haskell expressions using Nix to get packages description: Evaluate Haskell expressions using Nix to get packages homepage: http://chriswarbo.net/git/nix-eval @@ -15,14 +15,22 @@ build-type: Simple extra-source-files: README.md cabal-version: >=1.10 +data-files: wrapper.sh + , ghcEnvWithPkgs.nix +source-repository head + type: git + location: http://chriswarbo.net/git/nix-eval.git + library exposed-modules: Language.Eval.Internal , Language.Eval - -- other-modules: + other-modules: Paths_nix_eval -- other-extensions: - build-depends: base >=4.8 && <4.9 + build-depends: base >=4.8 && < 4.10 , process + , strict + , hindent >= 4.0 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Language/Eval.hs b/src/Language/Eval.hs --- a/src/Language/Eval.hs +++ b/src/Language/Eval.hs @@ -20,6 +20,7 @@ module Language.Eval ( Pkg(..) , Mod(..) + , Flag(..) , Expr(..) , eval , raw @@ -27,6 +28,8 @@ , asString , qualified , withMods - , withPkgs) where + , withPkgs + , withFlags + , withPreamble) where import Language.Eval.Internal diff --git a/src/Language/Eval/Internal.hs b/src/Language/Eval/Internal.hs --- a/src/Language/Eval/Internal.hs +++ b/src/Language/Eval/Internal.hs @@ -22,21 +22,38 @@ import Data.Char import Data.List import Data.String +import Paths_nix_eval (getDataFileName) import System.Exit import System.IO +import qualified System.IO.Strict +import System.IO.Unsafe import System.Process -- We're stringly typed, with a veneer of safety -newtype Pkg = Pkg String deriving (Eq, Ord, Show) -newtype Mod = Mod String deriving (Eq, Ord, Show) -newtype Expr = Expr ([Pkg], [Mod], String) deriving (Show) +newtype Pkg = Pkg String deriving (Eq, Ord, Show) +newtype Mod = Mod String deriving (Eq, Ord, Show) +newtype Flag = Flag String deriving (Eq, Ord, Show) +data Expr = Expr { + ePkgs :: [Pkg] + -- ^ Packages + , eMods :: [Mod] + -- ^ Modules + , eFlags :: [Flag] + -- ^ Required runhaskell arguments + , ePreamble :: [String] + -- ^ Extra lines to add to the generated module's top-level + , eExpr :: String + -- ^ The Haskell expression + } deriving (Show) + -- Allow permutations of package and module lists instance Eq Expr where - (Expr (p1, m1, e1)) == (Expr (p2, m2, e2)) = e1 == e2 && - perm p1 p2 && - perm m1 m2 + e1 == e2 = eExpr e1 == eExpr e2 && + perm (ePkgs e1) (ePkgs e2) && + perm (eMods e1) (eMods e2) && + perm (eFlags e1) (eFlags e2) where perm xs ys = allIn xs ys && allIn ys xs allIn xs ys = all (`elem` ys) xs @@ -51,58 +68,151 @@ instance IsString Mod where fromString = Mod +instance IsString Flag where + fromString = Flag + -- Evaluation via `nix-shell` -- | Evaluate an `Expr`; this is where the magic happens! If successful, returns -- `Just` a `String`, which you can do what you like with. eval :: Expr -> IO (Maybe String) -eval x@(Expr (pkgs, mods, expr)) = do - (code, out, err) <- let (cmd, args) = mkCmd x - in readProcessWithExitCode cmd args (mkHs x) - hPutStr stderr err - return $ case code of - ExitSuccess -> Just (trim out) - ExitFailure _ -> Nothing +eval = eval' mkHs +-- | Same as `eval`, but allows a custom formatting function to be supplied, eg. +-- if you want an alternative to the default "main = putStr (..)" behaviour. +eval' :: (String -> String) -> Expr -> IO (Maybe String) +eval' f x = do + cmd <- decideCmd x + (out, code) <- runCmdStdIO cmd (buildInput f x) + case code of + ExitSuccess -> return $ Just (trim out) + ExitFailure _ -> hPutStr stderr out >> return Nothing + +-- | Runs the given command, piping the given String into stdin, returning +-- stdout and the ExitCode. stderr is inherited. +runCmdStdIO :: CreateProcess -> String -> IO (String, ExitCode) +runCmdStdIO c i = do (Just hIn, Just hOut, Nothing, hProc) <- createProcess c + hPutContents hIn i + out <- System.IO.Strict.hGetContents hOut + code <- waitForProcess hProc + return (out, code) + +buildInput f x = unlines (map mkImport mods ++ ePreamble x ++ [f expr]) + where mods = nub $ eMods x + expr = eExpr x + +decideCmd :: Expr -> IO CreateProcess +decideCmd x = do + newEnv <- needNewEnv (nub $ ePkgs x) + return (buildCmd (if newEnv then mkCmd x + else noShellCmd x)) + +buildCmd (cmd, args) = (proc cmd args) { + std_in = CreatePipe, + std_out = CreatePipe, + std_err = Inherit + } + +noShellCmd :: Expr -> (String, [String]) +noShellCmd x = ("sh", wrapCmd' x) + +flagsOf x = map (\(Flag x) -> x) (nub $ eFlags x) + +hPutContents h c = hPutStr h c >> hClose h + +-- | Construct the nix-shell command. We use wrapper.sh as a layer of +-- indirection, to work around buggy environments. mkCmd :: Expr -> (String, [String]) -mkCmd (Expr (ps, _, _)) = ("nix-shell", ["--run", "runhaskell", - "-p", mkGhcPkg ps]) +mkCmd x = ("nix-shell", ["--show-trace", "--run", cmdLine x, "-p", pkgOf x]) --- The prefix "h." is arbitrary, as long as it matches the argument "h:" -mkGhcPkg ps = let pkgs = map (\(Pkg p) -> "(h." ++ p ++ ")") ps - in concat ["haskellPackages.ghcWithPackages ", - "(h: [", unwords pkgs, "])"] +pkgOf = mkGhcPkg . nub . ePkgs +cmdLine x = unwords (map shellEscape ("sh" : wrapCmd' x ++ [show (pkgsToName pkgs)])) + where pkgs = nub $ ePkgs x + +shellEscape s = if ' ' `elem` s then show s else s + +wrapCmd' x = [wrapperPath, unwords . ("runhaskell" :) . flagsOf $ x] + +wrapperPath :: FilePath +{-# NOINLINE wrapperPath #-} +wrapperPath = unsafePerformIO (getDataFileName "wrapper.sh") + +ghcEnvWithPkgsPath :: FilePath +{-# NOINLINE ghcEnvWithPkgsPath #-} +ghcEnvWithPkgsPath = unsafePerformIO (getDataFileName "ghcEnvWithPkgs.nix") + +-- | Creates a Nix expression which will use ghcEnvWithPkgs.nix to make a +-- Haskell environment containing all of the given packages +mkGhcPkg ps = env ++ " { name = " ++ name ++ "; pkgNames = " ++ args ++ "; }" + where env = "import " ++ show ghcEnvWithPkgsPath + args = "[ " ++ unwords pkgs ++ " ]" + pkgs = map (\(Pkg p) -> show p) ps + name = show (pkgsToName ps) + +-- | This creates a name for our Haskell environment. We make it here once, and +-- pass it into both Nix and wrapper.sh, to ensure consistency +pkgsToName [] = "ghc-env" +pkgsToName ps = "ghc-env-with-" ++ intercalate "-" (map clean pkgs) + where pkgs = map (\(Pkg p) -> p) ps + clean = filter isAlphaNum + +-- | Check if all of the required packages are already available, i.e. whether +-- we need to create a new Haskell environment +havePkgs :: [Pkg] -> IO Bool +havePkgs [] = return True +havePkgs (Pkg p:ps) = do + out <- readProcess "ghc-pkg" ["--simple-output", "list", p] "" + if p `isInfixOf` out + then havePkgs ps + else return False + +-- | Do we need to create a new Haskell environment, because we don't have +-- GHC available or because the packages we need aren't available? +needNewEnv ps = do + hgp <- haveGhcPkg + if hgp then fmap not (havePkgs ps) + else return True + +mkImport :: Mod -> String +mkImport (Mod m) = "import " ++ m + -- | Turn an expression into a Haskell module, complete with imports and `main` -mkHs :: Expr -> String -mkHs (Expr (_, ms, e)) = unlines (imports ++ [main]) - where imports = map (\(Mod m) -> "import " ++ m) ms - main = "main = putStr (" ++ e ++ ")" +mkHs :: String -> String +mkHs e = "main = Prelude.putStr (" ++ e ++ ")" -- | Strip leading and trailing whitespace trim :: String -> String trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace +-- | Check if a shell command is available +haveCommand c = do + (c, _, _) <- readCreateProcessWithExitCode (shell ("hash " ++ c)) "" + return (c == ExitSuccess) + -- | Check if the `nix-shell` command is available via the shell haveNix :: IO Bool -haveNix = do - (c, _, _) <- readCreateProcessWithExitCode (shell "hash nix-shell") "" - return (c == ExitSuccess) +haveNix = haveCommand "nix-shell" +-- | Check if the `ghc-pkg` command is available via the shell +haveGhcPkg = haveCommand "ghc-pkg" + -- User-facing combinators -- | A raw String of Haskell code, with no packages or modules. You can use -- OverloadedStrings to call this automatically. raw :: String -> Expr -raw s = Expr ([], [], s) +raw s = Expr { ePkgs = [], eMods = [], eExpr = s, eFlags = [], ePreamble = [] } -- | Apply the first Expr to the second, eg. `f $$ x` ==> `f x` infixr 8 $$ ($$) :: Expr -> Expr -> Expr -(Expr (p1, m1, e1)) $$ (Expr (p2, m2, e2)) = Expr - (nub (p1 ++ p2), - nub (m1 ++ m2), - concat ["((", e1, ") (", e2, "))"]) +x $$ y = Expr { + ePkgs = nub (ePkgs x ++ ePkgs y), + eMods = nub (eMods x ++ eMods y), + eFlags = nub (eFlags x ++ eFlags y), + ePreamble = ePreamble x ++ ePreamble y , + eExpr = concat ["((", eExpr x, ") (", eExpr y, "))"] } -- | Convert the argument to a String, then send to `raw` asString :: (Show a) => a -> Expr @@ -110,13 +220,21 @@ -- | Qualify an expression, eg. `qualified "Data.Bool" "not"` gives the -- expression `Data.Bool.not` with "Data.Bool" in its module list -qualified :: Mod -> String -> Expr -qualified (Mod m) e = Expr ([], [Mod m], m ++ "." ++ e) +qualified :: Mod -> Expr -> Expr +qualified (Mod m) x = x { eMods = Mod m : eMods x, + eExpr = m ++ "." ++ eExpr x } -- | Append modules to an expression's context withMods :: [Mod] -> Expr -> Expr -withMods ms (Expr (ps, ms', e)) = Expr (ps, ms' ++ ms, e) +withMods ms x = x { eMods = eMods x ++ ms } -- | Append packages to an expression's context withPkgs :: [Pkg] -> Expr -> Expr -withPkgs ps (Expr (ps', ms, e)) = Expr (ps' ++ ps, ms, e) +withPkgs ps x = x { ePkgs = ePkgs x ++ ps } + +-- | Append arguments to an expression's context +withFlags :: [Flag] -> Expr -> Expr +withFlags fs x = x { eFlags = eFlags x ++ fs } + +withPreamble :: String -> Expr -> Expr +withPreamble p x = x { ePreamble = ePreamble x ++ [p] } diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -21,9 +21,10 @@ module Main where +import Data.List import Data.Maybe import Language.Eval -import Language.Eval.Internal (haveNix) +import Language.Eval.Internal import Test.QuickCheck.Monadic import Test.Tasty (defaultMain, testGroup) import Test.Tasty.QuickCheck @@ -38,6 +39,9 @@ , testProperty "Can import modules" modulesImport , testProperty "Can import packages" packagesImport , testProperty "$$ precedence" precedence + , testProperty "Preamble added" preambleAdded + , testProperty "Flags work" checkFlags + , testProperty "Nesting works" checkNesting ] else [] @@ -65,9 +69,71 @@ asString s)) (Just (show s)) +preambleAdded :: Int -> Property +preambleAdded i = + checkIO (withPreamble ("foo = " ++ show i) "foo * foo") + (Just (show (i * i))) + +checkFlags :: Int -> Property +checkFlags i = checkIO e (Just (show i)) + where e = withFlags ["-XTemplateHaskell"] . raw $ + "$([|" ++ show i ++ "|])" + +-- Run nix-shells inside nix-shells, each with different Haskell packages +-- available, to make sure the environments are set up correctly +checkNesting = checkIO' id expr (Just "True") + where expr = unsafe $$ runHaskell nested + -- Runs a String of Haskell in a sub-process + runHaskell s = ((process $$ asString "runhaskell") $$ "[]") $$ asString s + process = withPkgs ["process"] $ qualified "System.Process" "readProcess" + -- A String of Haskell code, which should invoke several `runhaskell` + -- instances inside `nix-shell`s with different elements of `pkgs` + -- available. The inner layer executes `base`, the others just propagate + -- the result back up to us + nested = recursiveHaskell pkgs base + -- A selection of non-default packages/modules + pkgs = [(Pkg "text", Mod "Data.Text"), + (Pkg "containers", Mod "Data.Graph"), + (Pkg "parsec", Mod "Text.Parsec")] + -- This value should be propagated up through each putStrLn + base = "main = putStr \"True\"" + -- Helpers +-- | `checkIO' gen x s` runs `gen x` to get an `Expr`, evaluates it, and asserts +-- that the result equals `s` +checkIO' :: Show a => (a -> Expr) -> a -> Maybe String -> Property +checkIO' pre i o = once $ monadicIO $ do + dbg (("expression", pre i), + ("expected", o)) + result <- run $ eval (pre i) + dbg ("result", result) + assert (result == o) + checkIO :: Expr -> Maybe String -> Property -checkIO i o = once $ ioProperty $ do - result <- eval ("show" $$ i) - return (result === o) +checkIO = checkIO' ("show" $$) + +mkHaskell :: Pkg -> Mod -> String -> String +mkHaskell p (Mod m) str = unlines [ + "import System.Process", + "main = System.Process.readProcess", + indent (show cmd), + indent args', + indent (show inner ++ " >>= putStrLn")] + where inner = "import " ++ m ++ "\n" ++ str + args' = "[" ++ intercalate "," (map show args) ++ "]" + indent = (" " ++) + (cmd, args) = mkCmd expr + expr = withPkgs [p] . withMods [Mod m] $ "undefined" + +pkgString :: [Pkg] -> String +pkgString [Pkg p] = "haskellPackages.ghcWithPackages (h: [ h." ++ p ++ "])" + +recursiveHaskell :: [(Pkg, Mod)] -> String -> String +recursiveHaskell [] base = base +recursiveHaskell ((p, m):xs) base = mkHaskell p m (recursiveHaskell xs base) + +unsafe = qualified "System.IO.Unsafe" "unsafePerformIO" + +dbg :: (Monad m, Show a) => a -> PropertyM m () +dbg = monitor . counterexample . show diff --git a/wrapper.sh b/wrapper.sh new file mode 100644 --- /dev/null +++ b/wrapper.sh @@ -0,0 +1,77 @@ +#!/usr/bin/env bash + +# This script will invoke $CMD, which will usually be "runhaskell" with a bunch +# of flags set. +CMD="$1" + +function shouldDebug { + [[ -n "$NIX_EVAL_DEBUG" ]] +} + +function debugMsg { + # Debug output, if requested + if shouldDebug + then + echo -e "nix-eval: $1" 1>&2 + fi +} + +if [[ -n "$2" ]] +then + # If we're running in a nested nix-shell, the PATH may not be set up + # correctly. To work around this, we accept the desired environment's name + # as $2 (e.g. "ghc-env-with-text") and look for it in PATH. If found, we + # push it to the front of PATH, so its binaries (`ghc`, etc.) will be used. + + NAME="$2" + + debugMsg "Looking for Haskell environment '$NAME'" + + DIR=$(echo "$PATH" | grep -o -- "[^:]*${NAME}/[^:]*") || { + echo "Couldn't find $NAME in PATH: $PATH" 1>&2 + exit 1 + } + + debugMsg "Moving '$DIR' to the front of PATH" 1>&2 + export PATH=$DIR:$PATH +fi + +# Now we can run the given command +debugMsg "Running command '$CMD'" + +debugMsg "PATH is $PATH" + +ORIG_INPUT=$(cat) +INPUT="$ORIG_INPUT" + +# If we're debugging, use hindent if available, so error message line numbers +# are more specific +if shouldDebug && command -v hindent > /dev/null +then + debugMsg "Trying hindent on given input:\n\n$INPUT" + if command -v timeout > /dev/null + then + INPUT=$(echo "$ORIG_INPUT" | timeout 20 hindent --style fundamental) || { + echo "WARNING: hindent failed!" 1>&2 + INPUT="$ORIG_INPUT" + } + else + INPUT=$(echo "$ORIG_INPUT" | hindent --style fundamental) || { + echo "WARNING: hindent failed!" 1>&2 + INPUT="$ORIG_INPUT" + } + fi +fi + +debugMsg "Evaluating:\n\n$INPUT\n---\n" + +OUTPUT=$(echo "$INPUT" | $CMD) +CODE="$?" + +debugMsg "Output:\n\n$OUTPUT" + +echo "$OUTPUT" + +debugMsg "Finished; exit code was '$CODE'" + +exit "$CODE"