diff options
| -rw-r--r-- | .envrc | 1 | ||||
| -rw-r--r-- | .gitignore | 1 | ||||
| -rw-r--r-- | CHANGELOG.md | 5 | ||||
| -rw-r--r-- | LICENSE | 30 | ||||
| -rw-r--r-- | README.md | 13 | ||||
| -rw-r--r-- | default.nix | 24 | ||||
| -rw-r--r-- | nix/sources.json | 14 | ||||
| -rw-r--r-- | nix/sources.nix | 198 | ||||
| -rw-r--r-- | sh.cabal | 37 | ||||
| -rw-r--r-- | shell.nix | 1 | ||||
| -rw-r--r-- | src/Process/Shell.hs | 153 | ||||
| -rw-r--r-- | test/Main.hs | 57 |
12 files changed, 534 insertions, 0 deletions
@@ -0,0 +1 @@ +use nix diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8075013 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/dist-newstyle diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..3dab14f --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for sh + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. @@ -0,0 +1,30 @@ +Copyright (c) 2024, Alexander Foremny + +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 Alexander Foremny 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 index 0000000..0ad027d --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# sh + +Conveniently call external processes from Haskell. + +## Description + +This library makes it convenient to run external processes in your Haskell program. + +It offers a single quasi quoter `sh` to run external processes. + +The program's exit code, standard output and standard error can be obtained by parameterizing its output type to ``ExitCode``, `(ExitCode, String)`, `(ExitCode, String, String)`, `String`, `(String, String)`, respectively. Instead of `String`, you may chose `ByteString` or `Text`, in both lazy and strict variants, as outputs. + +Arguments passed to `sh` are automatically passed to the process in a type-safe way, and appropriately quoted. diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..0545c15 --- /dev/null +++ b/default.nix @@ -0,0 +1,24 @@ +{ pkgs ? import (import ./nix/sources.nix).nixpkgs { } +}: +let + haskellPackages = pkgs.haskellPackages.override + { + overrides = self: super: { + sh = self.callCabal2nix "sh" ./. { }; + }; + }; +in +{ + shell = haskellPackages.shellFor { + packages = (_: [ + haskellPackages.sh + ]); + buildInputs = [ + pkgs.cabal-install + pkgs.niv + pkgs.ormolu + ]; + withHoogle = true; + withHaddock = true; + }; +} diff --git a/nix/sources.json b/nix/sources.json new file mode 100644 index 0000000..747350b --- /dev/null +++ b/nix/sources.json @@ -0,0 +1,14 @@ +{ + "nixpkgs": { + "branch": "nixos-23.11", + "description": "Nix Packages collection", + "homepage": null, + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "79baff8812a0d68e24a836df0a364c678089e2c7", + "sha256": "1aa16r5rkj2iab37q1wmz4kj2kdcjykqn1p79pbd43wmf6sl34am", + "type": "tarball", + "url": "https://github.com/NixOS/nixpkgs/archive/79baff8812a0d68e24a836df0a364c678089e2c7.tar.gz", + "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" + } +} diff --git a/nix/sources.nix b/nix/sources.nix new file mode 100644 index 0000000..fe3dadf --- /dev/null +++ b/nix/sources.nix @@ -0,0 +1,198 @@ +# This file has been generated by Niv. + +let + + # + # The fetchers. fetch_<type> fetches specs of type <type>. + # + + fetch_file = pkgs: name: spec: + let + name' = sanitizeName name + "-src"; + in + if spec.builtin or true then + builtins_fetchurl { inherit (spec) url sha256; name = name'; } + else + pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; + + fetch_tarball = pkgs: name: spec: + let + name' = sanitizeName name + "-src"; + in + if spec.builtin or true then + builtins_fetchTarball { name = name'; inherit (spec) url sha256; } + else + pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; + + fetch_git = name: spec: + let + ref = + spec.ref or ( + if spec ? branch then "refs/heads/${spec.branch}" else + if spec ? tag then "refs/tags/${spec.tag}" else + abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!" + ); + submodules = spec.submodules or false; + submoduleArg = + let + nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0; + emptyArgWithWarning = + if submodules + then + builtins.trace + ( + "The niv input \"${name}\" uses submodules " + + "but your nix's (${builtins.nixVersion}) builtins.fetchGit " + + "does not support them" + ) + { } + else { }; + in + if nixSupportsSubmodules + then { inherit submodules; } + else emptyArgWithWarning; + in + builtins.fetchGit + ({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg); + + fetch_local = spec: spec.path; + + fetch_builtin-tarball = name: throw + ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=tarball -a builtin=true''; + + fetch_builtin-url = name: throw + ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. + $ niv modify ${name} -a type=file -a builtin=true''; + + # + # Various helpers + # + + # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 + sanitizeName = name: + ( + concatMapStrings (s: if builtins.isList s then "-" else s) + ( + builtins.split "[^[:alnum:]+._?=-]+" + ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) + ) + ); + + # The set of packages used when specs are fetched using non-builtins. + mkPkgs = sources: system: + let + sourcesNixpkgs = + import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; + hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; + hasThisAsNixpkgsPath = <nixpkgs> == ./.; + in + if builtins.hasAttr "nixpkgs" sources + then sourcesNixpkgs + else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then + import <nixpkgs> { } + else + abort + '' + Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or + add a package called "nixpkgs" to your sources.json. + ''; + + # The actual fetching function. + fetch = pkgs: name: spec: + + if ! builtins.hasAttr "type" spec then + abort "ERROR: niv spec ${name} does not have a 'type' attribute" + else if spec.type == "file" then fetch_file pkgs name spec + else if spec.type == "tarball" then fetch_tarball pkgs name spec + else if spec.type == "git" then fetch_git name spec + else if spec.type == "local" then fetch_local spec + else if spec.type == "builtin-tarball" then fetch_builtin-tarball name + else if spec.type == "builtin-url" then fetch_builtin-url name + else + abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; + + # If the environment variable NIV_OVERRIDE_${name} is set, then use + # the path directly as opposed to the fetched source. + replace = name: drv: + let + saneName = stringAsChars (c: if (builtins.match "[a-zA-Z0-9]" c) == null then "_" else c) name; + ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; + in + if ersatz == "" then drv else + # this turns the string into an actual Nix path (for both absolute and + # relative paths) + if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; + + # Ports of functions for older nix versions + + # a Nix version of mapAttrs if the built-in doesn't exist + mapAttrs = builtins.mapAttrs or ( + f: set: with builtins; + listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) + ); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 + range = first: last: if first > last then [ ] else builtins.genList (n: first + n) (last - first + 1); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 + stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); + + # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 + stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); + concatMapStrings = f: list: concatStrings (map f list); + concatStrings = builtins.concatStringsSep ""; + + # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 + optionalAttrs = cond: as: if cond then as else { }; + + # fetchTarball version that is compatible between all the versions of Nix + builtins_fetchTarball = { url, name ? null, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchTarball; + in + if lessThan nixVersion "1.12" then + fetchTarball ({ inherit url; } // (optionalAttrs (name != null) { inherit name; })) + else + fetchTarball attrs; + + # fetchurl version that is compatible between all the versions of Nix + builtins_fetchurl = { url, name ? null, sha256 }@attrs: + let + inherit (builtins) lessThan nixVersion fetchurl; + in + if lessThan nixVersion "1.12" then + fetchurl ({ inherit url; } // (optionalAttrs (name != null) { inherit name; })) + else + fetchurl attrs; + + # Create the final "sources" from the config + mkSources = config: + mapAttrs + ( + name: spec: + if builtins.hasAttr "outPath" spec + then + abort + "The values in sources.json should not have an 'outPath' attribute" + else + spec // { outPath = replace name (fetch config.pkgs name spec); } + ) + config.sources; + + # The "config" used by the fetchers + mkConfig = + { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null + , sources ? if sourcesFile == null then { } else builtins.fromJSON (builtins.readFile sourcesFile) + , system ? builtins.currentSystem + , pkgs ? mkPkgs sources system + }: rec { + # The sources, i.e. the attribute set of spec name to spec + inherit sources; + + # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers + inherit pkgs; + }; + +in +mkSources (mkConfig { }) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/sh.cabal b/sh.cabal new file mode 100644 index 0000000..4948851 --- /dev/null +++ b/sh.cabal @@ -0,0 +1,37 @@ +cabal-version: 3.4 +name: sh +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +maintainer: aforemny@posteo.de +author: Alexander Foremny + +build-type: Simple +extra-doc-files: CHANGELOG.md + +library + exposed-modules: Process.Shell + hs-source-dirs: src + default-language: GHC2021 + ghc-options: -Wall + build-depends: + base, + bytestring, + megaparsec, + template-haskell, + text, + typed-process, + utf8-string + +test-suite sh-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: GHC2021 + ghc-options: -Wall + build-depends: + base, + bytestring, + hspec, + sh, + text diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..a6bdf20 --- /dev/null +++ b/shell.nix @@ -0,0 +1 @@ +(import ./. { }).shell diff --git a/src/Process/Shell.hs b/src/Process/Shell.hs new file mode 100644 index 0000000..94ba3c9 --- /dev/null +++ b/src/Process/Shell.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Process.Shell + ( sh, + Quotable (..), + ) +where + +import Control.Monad +import Data.ByteString qualified as B +import Data.ByteString.Lazy qualified as LB +import Data.ByteString.Lazy.UTF8 qualified as LB +import Data.ByteString.UTF8 qualified as B +import Data.Functor.Identity +import Data.Maybe +import Data.String +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Lazy qualified as LT +import Data.Text.Lazy.Encoding qualified as LT +import Data.Void +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import System.Process.Typed +import Text.Megaparsec +import Text.Megaparsec.Char + +class Processable a r where + sh_ :: a -> r + +instance (Processable a r) => Processable (String -> a) (String -> r) where + sh_ f x = sh_ (f x) + +instance Processable String (IO ()) where + sh_ s = do + runProcess_ (fromString s) + +instance (Outputable a) => Processable String (IO a) where + sh_ s = do + fromLBS <$> readProcessInterleaved_ (fromString s) + +instance (Outputable stdout, Outputable stderr) => Processable String (IO (stdout, stderr)) where + sh_ s = do + (\(out, err) -> (fromLBS out, fromLBS err)) <$> readProcess_ (fromString s) + +instance (Outputable stdout, Outputable stderr) => Processable String (IO (ExitCode, stdout, stderr)) where + sh_ s = do + (\(exitCode, out, err) -> (exitCode, fromLBS out, fromLBS err)) <$> readProcess (fromString s) + +class Outputable a where + fromLBS :: LB.ByteString -> a + +instance Outputable String where + fromLBS = LB.toString + +instance Outputable B.ByteString where + fromLBS = LB.toStrict + +instance Outputable LB.ByteString where + fromLBS = id + +instance Outputable T.Text where + fromLBS = T.decodeUtf8 . fromLBS + +instance Outputable LT.Text where + fromLBS = LT.decodeUtf8 + +class Quotable a where + squote :: a -> String + squote = squote . toString + + dquote :: a -> String + dquote = dquote . toString + + toString :: a -> String + default toString :: (Show a) => a -> String + toString = show + +instance Quotable String where + squote s = "'" <> quote' s <> "'" + where + quote' [] = [] + quote' ('\'' : cs) = '\'' : '\\' : '\'' : '\'' : quote' cs + quote' (c : cs) = c : quote' cs + + dquote s = "\"" <> quote' s <> "\"" + where + quote' [] = [] + quote' ('\\' : c : cs) = c : quote' cs + quote' ('"' : cs) = '\\' : '"' : quote' cs + quote' (c : cs) = c : quote' cs + +instance Quotable Int + +instance Quotable B.ByteString where + toString = B.toString + +instance Quotable LB.ByteString where + toString = LB.toString + +instance Quotable T.Text where + toString = T.unpack + +instance Quotable LT.Text where + toString = LT.unpack + +data Expr a + = Lit String + | Var Bool a + deriving (Show) + +expr :: (String -> b) -> (Bool -> a -> b) -> Expr a -> b +expr f _ (Lit a) = f a +expr _ g (Var q a) = g q a + +unVar :: Expr a -> Maybe a +unVar (Lit _) = Nothing +unVar (Var _ a) = Just a + +sh :: QuasiQuoter +sh = QuasiQuoter quoteExp undefined undefined undefined + where + quoteExp :: String -> Q Exp + quoteExp = + either (fail . errorBundlePretty) makeExp + . parse (parser <* eof) "" + + parser :: ParsecT Void String Identity [Expr ()] + parser = + many . choice $ + [ const (Lit "%") <$> string "%%", + const (Var True ()) <$> string "'%'", + const (Var False ()) <$> satisfy (== '%'), + Lit <$> takeWhile1P Nothing (not . (`elem` "'%")), + Lit <$> string "'%", + Lit <$> string "'" + ] + + makeExp :: [Expr ()] -> Q Exp + makeExp exprs' = do + exprs <- + mapM + (expr (pure . Lit) (\q _ -> Var q <$> newName "x")) + exprs' + lamE (map varP (mapMaybe unVar exprs)) . appE [|sh_|] $ + flip (foldM (flip go)) exprs =<< [|""|] + + go (Lit s) = appE [|flip (++) s|] . pure + go (Var q n) = appE (appE [|flip (++)|] (appE [|if q then squote else dquote|] (varE n))) . pure diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..ad69469 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE QuasiQuotes #-} + +module Main (main) where + +import Data.ByteString.Char8 qualified as B +import Data.ByteString.Lazy.Char8 qualified as LB +import Data.Text qualified as T +import Data.Text.Lazy qualified as LT +import Process.Shell +import Test.Hspec + +main :: IO () +main = hspec do + describe "output" do + it "capture stdout" do + (`shouldBe` "stdout") . fst @String @String =<< [sh|echo -n stdout|] + it "capture stderr" do + (`shouldBe` "stderr") . snd @String =<< [sh|>&2 echo -n stderr|] + it "capture stdout and stderr interleaved" do + (`shouldBe` ("stdout", "stderr")) + =<< [sh| + echo -n stdout + >&2 echo -n stderr + |] + it "capture interleaved" do + (`shouldBe` "stdout\nstderr\n") + =<< [sh| + echo stdout + >&2 echo stderr + |] + describe "arguments" do + it "passes `Int`" do + (`shouldBe` "1") =<< [sh|echo -n %|] (1 :: Int) + it "passes `Text`" do + (`shouldBe` "foobar") =<< [sh|echo -n %|] (T.pack "foobar") + (`shouldBe` "foobar") =<< [sh|echo -n %|] (LT.pack "foobar") + it "passes `ByteString`" do + (`shouldBe` "foobar") =<< [sh|echo -n %|] (B.pack "foobar") + (`shouldBe` "foobar") =<< [sh|echo -n %|] (LB.pack "foobar") + describe "quoting" do + it "preserves arguments" do + (`shouldBe` "foo\\ bar") + =<< [sh|printf %%q %|] "foo bar" + it "preserves special characters" do + (`shouldBe` "foo\\ bar") + =<< [sh|foo=foo; bar=bar; ( printf %%q % )|] "$foo $bar" + it "escapes special characters" do + (`shouldBe` "\\$foo\\ \\$bar") + =<< [sh|printf %%q '%'|] "$foo $bar" + it "preserves empty arguments" do + (`shouldBe` "''") =<< [sh|printf %%q %|] "" + (`shouldBe` "''") =<< [sh|printf %%q '%'|] "" + describe "parsing" do + it "parses garbled arguments" do + (`shouldBe` "% foo") =<< [sh|echo -n '% ' %|] "foo" + (`shouldBe` " foo") =<< [sh|echo -n ' ' %|] "foo" |