diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2014, Matvey Aksenov + +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. + +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.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,10 @@ +envparse +======== +[![Hackage](https://budueba.com/hackage/envparse)](https://hackage.haskell.org/package/envparse) +[![Build Status](https://secure.travis-ci.org/supki/envparse.png?branch=master)](https://travis-ci.org/supki/envparse) + +[optparse-applicative][0], but for environment variables + +See `example/Main.hs` for an executable example + + [0]: https://hackage.haskell.org/package/optparse-applicative 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/envparse.cabal b/envparse.cabal new file mode 100644 --- /dev/null +++ b/envparse.cabal @@ -0,0 +1,74 @@ +name: envparse +version: 0.1.0 +synopsis: Parse environment variables +description: + Here's a simple example + . + @ + module Main (main) where + . + import Control.Monad (unless) + import Env + . + data Hello = Hello { name :: String, quiet :: Bool } + . + hello :: IO Hello + hello = Env.parse (header \"envparse example\") $ + Hello \<$\> var (str <=< nonempty) \"NAME\" (help \"Target for the greeting\") + \<*\> switch \"QUIET\" (help \"Whether to actually print the greeting\") + + main :: IO () + main = do + Hello { name, quiet } <- hello + unless quiet $ + putStrLn (\"Hello, \" ++ name ++ \"!\") + @ +homepage: http://example.com/ +license: BSD2 +license-file: LICENSE +author: Matvey Aksenov +maintainer: matvey.aksenov@gmail.com +copyright: 2014 Matvey Aksenov +category: System +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + README.markdown + example/Main.hs + +source-repository head + type: git + location: https://github.com/supki/envparse + +library + default-language: + Haskell2010 + build-depends: + base >= 4.6 && < 5 + , containers + hs-source-dirs: + src + exposed-modules: + Env + other-modules: + Env.Free + Env.Help + Env.Parse + Env.Val + ghc-options: + -Wall + +test-suite spec + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + build-depends: + base >= 4.6 && < 5 + , containers + , hspec + hs-source-dirs: + src + test + main-is: + Spec.hs diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE NamedFieldPuns #-} +-- | Greetings for $NAME +-- +-- @ +-- % NAME=a5579150 runhaskell -isrc example/Main.hs +-- Hello, a5579150! +-- % NAME=a5579150 QUIET=1 runhaskell -isrc example/Main.hs +-- % +-- @ +module Main (main) where + +import Control.Monad (unless) +import Env + + +data Hello = Hello { name :: String, quiet :: Bool } + + +main :: IO () +main = do + Hello { name, quiet } <- hello + unless quiet $ + putStrLn ("Hello, " ++ name ++ "!") + +hello :: IO Hello +hello = Env.parse (header "envparse example") $ + Hello <$> var (str <=< nonempty) "NAME" (help "Target for the greeting") + <*> switch "QUIET" (help "Whether to actually print the greeting") diff --git a/src/Env.hs b/src/Env.hs new file mode 100644 --- /dev/null +++ b/src/Env.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE Safe #-} +-- | Here's a simple example +-- +-- @ +-- module Main (main) where +-- +-- import Control.Monad (unless) +-- import Env +-- +-- data Hello = Hello { name :: String, quiet :: Bool } +-- +-- hello :: IO Hello +-- hello = 'Env.parse' ('header' \"envparse example\") $ +-- Hello \<$\> 'var' ('str' <=< 'nonempty') \"NAME\" ('help' \"Target for the greeting\") +-- \<*\> 'switch' \"QUIET\" ('help' \"Whether to actually print the greeting\") +-- +-- main :: IO () +-- main = do +-- Hello { name, quiet } <- hello +-- unless quiet $ +-- putStrLn (\"Hello, \" ++ name ++ \"!\") +-- @ +module Env + ( parse + , Parser + , Mod + , Info + , header + , desc + , footer + , var + , Var + , Reader + , str + , nonempty + , auto + , def + , helpDef + , flag + , switch + , Flag + , HasHelp + , help + -- * Re-exports + -- $re-exports + , pure, (<$>), (<*>), (*>), (<*), optional + , empty, (<|>) + , (<=<), (>=>) + , (<>), mempty, mconcat + , asum + -- * Testing + -- $testing + , parseTest + ) where + +import Control.Applicative +import Control.Monad ((>=>), (<=<)) +import Data.Foldable (asum) +import Data.Monoid (Monoid(..), (<>)) +import System.Environment (getEnvironment) +import System.Exit (exitFailure) +import qualified System.IO as IO + +import Env.Help (helpDoc) +import Env.Parse + +-- $re-exports +-- External functions that may be useful to the consumer of the library + +-- $testing +-- Utilities to test—without dabbling in IO—that your parsers do +-- what you want them to do + + +-- | Parse the environment +-- +-- Prints the help text and exits with @EXIT_FAILURE@ if it encounters a parse error +-- +-- @ +-- >>> parse ('header' \"env-parse 0.1.0\") ('var' 'str' \"USER\" ('def' \"nobody\")) +-- @ +parse :: Mod Info a -> Parser a -> IO a +parse i p = either (die . helpDoc i p) return . static p =<< getEnvironment + +die :: String -> IO a +die m = do IO.hPutStrLn IO.stderr m; exitFailure + +-- | Parse a static environment +parseTest :: Parser a -> [(String, String)] -> Maybe a +parseTest p = hush . static p + +hush :: Either a b -> Maybe b +hush = either (const Nothing) Just diff --git a/src/Env/Free.hs b/src/Env/Free.hs new file mode 100644 --- /dev/null +++ b/src/Env/Free.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- @Alt F@ is the free 'Alternative' functor on @F@ +module Env.Free + ( Alt(..) + , liftAlt + , runAlt + , foldAlt + ) where + +import Control.Applicative (Applicative(..), Alternative(..)) +import Data.Monoid (Monoid(..)) + + +data Alt f a where + Nope :: Alt f a + Pure :: a -> Alt f a + Ap :: Alt f (a -> b) -> Alt f a -> Alt f b + Alt :: Alt f a -> Alt f a -> Alt f a + Fun :: f a -> Alt f a + +instance Functor f => Functor (Alt f) where + fmap _ Nope = Nope + fmap f (Pure a) = Pure (f a) + fmap f (Ap a v) = Ap (fmap (f .) a) v + fmap f (Alt a b) = Alt (fmap f a) (fmap f b) + fmap f (Fun a) = Fun (fmap f a) + +instance Functor f => Applicative (Alt f) where + pure = Pure + (<*>) = Ap + +instance Functor f => Alternative (Alt f) where + empty = Nope + (<|>) = Alt + + +liftAlt :: f a -> Alt f a +liftAlt = Fun + +runAlt :: forall f g a. Alternative g => (forall x. f x -> g x) -> Alt f a -> g a +runAlt u = go where + go :: Alt f b -> g b + go Nope = empty + go (Pure a) = pure a + go (Ap f x) = go f <*> go x + go (Alt s t) = go s <|> go t + go (Fun x) = u x + +foldAlt :: Monoid p => (forall a. f a -> p) -> Alt f b -> p +foldAlt f = unMon . runAlt (Mon . f) + + +-- | The 'Alternative' functor induced by the 'Monoid' +newtype Mon m a = Mon + { unMon :: m + } deriving (Show, Eq) + +instance Functor (Mon m) where + fmap _ (Mon a) = Mon a + +instance Monoid m => Applicative (Mon m) where + pure _ = Mon mempty + Mon x <*> Mon y = Mon (mappend x y) + +instance Monoid m => Alternative (Mon m) where + empty = Mon mempty + Mon x <|> Mon y = Mon (mappend x y) diff --git a/src/Env/Help.hs b/src/Env/Help.hs new file mode 100644 --- /dev/null +++ b/src/Env/Help.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE NamedFieldPuns #-} +module Env.Help + ( helpDoc + ) where + +import Data.List (intercalate) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) + +import Env.Free +import Env.Parse + + +helpDoc :: Mod Info a -> Parser a -> [Error] -> String +helpDoc (Mod f) p fs = intercalate "\n\n" . catMaybes $ + [ infoHeader + , fmap (intercalate "\n" . splitWords 50) infoDesc + , Just "Available environment variables:" + , Just (intercalate "\n" (helpParserDoc p)) + , fmap (intercalate "\n" . splitWords 50) infoFooter + ] ++ map Just (helpFailuresDoc fs) + where + Info { infoHeader, infoDesc, infoFooter } = f defaultInfo + +helpParserDoc :: Parser a -> [String] +helpParserDoc = concat . Map.elems . foldAlt (\v -> Map.singleton (varfName v) (helpVarfDoc v)) . unParser + +helpVarfDoc :: VarF a -> [String] +helpVarfDoc VarF { varfName, varfHelp, varfHelpDef } = + case varfHelp of + Nothing -> [indent 2 varfName] + Just h + | k > 15 -> indent 2 varfName : map (indent 25) (splitWords 30 t) + | otherwise -> + case zipWith indent (23 - k : repeat 25) (splitWords 30 t) of + (x : xs) -> (indent 2 varfName ++ x) : xs + [] -> [indent 2 varfName] + where k = length varfName + t = maybe h (\s -> h ++ " (default: " ++ s ++")") varfHelpDef + +helpFailuresDoc :: [Error] -> [String] +helpFailuresDoc [] = [] +helpFailuresDoc fs = ["Parsing errors:", intercalate "\n" (map helpFailureDoc fs)] + +helpFailureDoc :: Error -> String +helpFailureDoc (ParseError n e) = " " ++ n ++ " cannot be parsed: " ++ e +helpFailureDoc (ENoExistError n) = " " ++ n ++ " is missing" + +splitWords :: Int -> String -> [String] +splitWords n = go [] 0 . words + where + go acc _ [] = prep acc + go acc k (w : ws) + | k + z < n = go (w : acc) (k + z) ws + | z > n = prep acc ++ case splitAt n w of (w', w'') -> w' : go [] 0 (w'' : ws) + | otherwise = prep acc ++ go [w] z ws + where + z = length w + + prep [] = [] + prep acc = [unwords (reverse acc)] + +indent :: Int -> String -> String +indent n s = replicate n ' ' <> s diff --git a/src/Env/Parse.hs b/src/Env/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Env/Parse.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE NamedFieldPuns #-} +module Env.Parse + ( Parser(..) + , VarF(..) + , static + , Error(..) + , Mod(..) + , Info(..) + , defaultInfo + , header + , desc + , footer + , var + , Var(..) + , defaultVar + , Reader + , str + , nonempty + , auto + , def + , helpDef + , flag + , switch + , Flag + , HasHelp + , help + ) where + +import Control.Applicative +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) + +import Env.Free +import Env.Val + + +static :: Parser a -> [(String, String)] -> Either [Error] a +static (Parser p) xs = toEither (runAlt go p) + where + go v = maybe id (\d x -> x <|> pure d) (varfDef v) (fromEither (readVar v =<< lookupVar v ys)) + + ys = Map.fromList xs + +lookupVar :: VarF a -> Map String String -> Either [Error] String +lookupVar v = note [ENoExistError (varfName v)] . Map.lookup (varfName v) + +readVar :: VarF a -> String -> Either [Error] a +readVar v = mapLeft (pure . ParseError (varfName v)) . varfReader v + +note :: a -> Maybe b -> Either a b +note a = maybe (Left a) Right + +mapLeft :: (a -> b) -> Either a t -> Either b t +mapLeft f = either (Left . f) Right + + +-- | An environment parser +newtype Parser a = Parser { unParser :: Alt VarF a } + deriving (Functor) + +instance Applicative Parser where + pure = Parser . pure + Parser f <*> Parser x = Parser (f <*> x) + +instance Alternative Parser where + empty = Parser empty + Parser f <|> Parser x = Parser (f <|> x) + + +data Error + = ParseError String String + | ENoExistError String + deriving (Show, Eq) + +data VarF a = VarF + { varfName :: String + , varfReader :: Reader a + , varfHelp :: Maybe String + , varfDef :: Maybe a + , varfHelpDef :: Maybe String + } deriving (Functor) + +-- | An environment variable's value parser. Use @(<=<)@ and @(>=>)@ to combine these +type Reader a = String -> Either String a + +-- | Parse a particular variable from the environment +-- +-- @ +-- >>> var 'str' \"EDITOR\" ('def' \"vim\" <> 'helpDef' show) +-- @ +var :: Reader a -> String -> Mod Var a -> Parser a +var r n (Mod f) = Parser . liftAlt $ VarF + { varfName = n + , varfReader = r + , varfHelp = varHelp + , varfDef = varDef + , varfHelpDef = varHelpDef <*> varDef + } + where + Var { varHelp, varDef, varHelpDef } = f defaultVar + +-- | A flag that takes the active value if the environment variable +-- is set and non-empty and the default value otherwise +-- +-- /Note:/ this parser never fails. +flag + :: a -- ^ default value + -> a -- ^ active value + -> String -> Mod Flag a -> Parser a +flag f t n (Mod g) = Parser . liftAlt $ VarF + { varfName = n + , varfReader = Right . either (const f) (const t) . (nonempty :: Reader String) + , varfHelp = flagHelp + , varfDef = Just f + , varfHelpDef = Nothing + } + where + Flag { flagHelp } = g defaultFlag + +-- | A simple boolean 'flag' +-- +-- /Note:/ the same caveats apply. +switch :: String -> Mod Flag Bool -> Parser Bool +switch = flag False True + +-- | The trivial reader +str :: IsString s => Reader s +str = Right . fromString + +-- | The reader that accepts only non-empty strings +nonempty :: IsString s => Reader s +nonempty = fmap fromString . go where go [] = Left "a non-empty string is expected"; go xs = Right xs + +-- | The reader that uses the 'Read' instance of the type +auto :: Read a => Reader a +auto = \s -> case reads s of [(v, "")] -> Right v; _ -> Left (show s ++ " is an invalid value") +{-# ANN auto "HLint: ignore Redundant lambda" #-} + + +-- | This represents a modification of the properties of a particular 'Parser'. +-- Combine them using the 'Monoid' instance. +newtype Mod t a = Mod (t a -> t a) + +instance Monoid (Mod t a) where + mempty = Mod id + mappend (Mod f) (Mod g) = Mod (g . f) + + +-- | Parser's metadata +data Info a = Info + { infoHeader :: Maybe String + , infoDesc :: Maybe String + , infoFooter :: Maybe String + } + +defaultInfo :: Info a +defaultInfo = Info + { infoHeader = Nothing + , infoDesc = Nothing + , infoFooter = Nothing + } + +-- | A help text header (it usually includes an application name and version) +header :: String -> Mod Info a +header h = Mod (\i -> i { infoHeader = Just h }) + +-- | A short program description +desc :: String -> Mod Info a +desc h = Mod (\i -> i { infoDesc = Just h }) + +-- | A help text footer (it usually includes examples) +footer :: String -> Mod Info a +footer h = Mod (\i -> i { infoFooter = Just h }) + + +-- | Environment variable metadata +data Var a = Var + { varHelp :: Maybe String + , varHelpDef :: Maybe (a -> String) + , varDef :: Maybe a + } + +defaultVar :: Var a +defaultVar = Var + { varHelp = Nothing + , varDef = Nothing + , varHelpDef = Nothing + } + +-- | The default value of the variable +-- +-- /Note:/ specifying it means the parser won't ever fail. +def :: a -> Mod Var a +def d = Mod (\v -> v { varDef = Just d }) + +-- | Flag metadata +data Flag a = Flag + { flagHelp :: Maybe String + } + +defaultFlag :: Flag a +defaultFlag = Flag { flagHelp = Nothing } + +-- | Show the default value of the variable in the help text +helpDef :: (a -> String) -> Mod Var a +helpDef d = Mod (\v -> v { varHelpDef = Just d }) + + +-- | A class of things that can have a help message attached to them +class HasHelp t where + setHelp :: String -> t a -> t a + +instance HasHelp Var where + setHelp h v = v { varHelp = Just h } + +instance HasHelp Flag where + setHelp h v = v { flagHelp = Just h } + +-- | Attach help text to the variable +help :: HasHelp t => String -> Mod t a +help = Mod . setHelp diff --git a/src/Env/Val.hs b/src/Env/Val.hs new file mode 100644 --- /dev/null +++ b/src/Env/Val.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveFunctor #-} +module Env.Val + ( Val(..) + , fromEither + , toEither + ) where + +import Control.Applicative +import Data.Monoid (Monoid(..), (<>)) + + +-- | An isomorphic to 'Either' type with the accumulating 'Applicative' instance +data Val e a + = Err e + | Ok a + deriving (Functor, Show, Eq) + +instance Monoid e => Applicative (Val e) where + pure = Ok + + Err e <*> Err e' = Err (e <> e') + Err e <*> _ = Err e + _ <*> Err e' = Err e' + Ok f <*> Ok a = Ok (f a) + +instance Monoid e => Alternative (Val e) where + empty = Err mempty + + Err _ <|> Ok x = Ok x + x <|> _ = x + +fromEither :: Either e a -> Val e a +fromEither = either Err Ok + +toEither :: Val e a -> Either e a +toEither x = case x of Err e -> Left e; Ok a -> Right a diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}