diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,11 @@ +2014-01-18 Joseph Abrahamson + + * src/System/Environment/Parser/Internal.hs: Introduced flexible environment structure designed for multiple implementations for IO and testing. + * src/System/Environment/Parser/Internal.hs: Added dependency search + * src/System/Environment/Parser/Internal.hs: FromEnv parsers for numbers and string types + * src/System/Environment/Parser/Database.hs: Introduced DBConnection type with FromEnv instance + * src/System/Environment/Parser/Internal.hs: Introduced FromEnv for Data.Time types + * src/System/Environment/Parser/Encoded.hs: Added encoded bytestring types + * src/System/Environment/Parser/Internal.hs: Introduced Aeson Value FromEnv instances + * src/System/Environment/Parser/Encoded.hs: Added To/FromJSON instances for Encoded bytestrings + * src/System/Environment/Parser/Internal.hs: Added envParse diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2013 Joseph Abrahamson + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. 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/env-parser.cabal b/env-parser.cabal new file mode 100644 --- /dev/null +++ b/env-parser.cabal @@ -0,0 +1,70 @@ +name: env-parser +version: 0.0.1.0 +synopsis: Pull configuration information from the ENV +description: + @env-parser@ is a small library for configuring programs based on information + from the environment. + . + Command-line oriented programs tend to pull much of their runtime + configuration from command-line arguments and libraries such as @cmdargs@ are + useful for encoding this configuration in your program. For programs which + draw configuration from the environment, however, this must usually be done + manually. + . + @env-parser@ focuses on making ENV-configured programs both easy to build, + declarative, self-documenting, and easy to test. + . + A particular use case of this parser is to make it easy to build applications + which launch under Heroku-style infrastructure. We provide explicit parsers + for some of Heroku's conventions for this purpose. + +homepage: http://github.com/tel/env-parser +license: MIT +license-file: LICENSE +author: Joseph Abrahamson +maintainer: me@jspha.com +copyright: 2013 (c) Joseph Abrahamson +category: System +build-type: Simple +extra-source-files: ChangeLog +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/tel/env-parser.git + +library + exposed-modules: + System.Environment.Parser + System.Environment.Parser.Database + System.Environment.Parser.Encoded + System.Environment.Parser.FromEnv + other-modules: + System.Environment.Parser.Class + System.Environment.Parser.Miss + build-depends: base >= 4.6 && <4.7 + + -- Haskell Platform 2013.2.0.0 + + , attoparsec >= 0.10 + , bytestring >= 0.10 + , containers >= 0.4 + , mtl >= 2.1 + , network >= 2.4 + , old-locale >= 1.0 + , text >= 0.11 + , time >= 1.4 + , transformers >= 0.3 + + -- Soon to be Platformed + + , aeson >= 0.7 + + -- Others + + , base16-bytestring >= 0.1.1 + , base64-bytestring >= 1.0 + , http-types >= 0.8 + + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/System/Environment/Parser.hs b/src/System/Environment/Parser.hs new file mode 100644 --- /dev/null +++ b/src/System/Environment/Parser.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : System.Environment.Parser +-- Copyright : (c) Joseph Abrahamson 2013 +-- License : MIT +-- +-- Maintainer : me@jspha.com +-- Stability : experimental +-- Portability : non-portable +-- +-- Functions for building generic environment parsers which provide +-- automatic documentation and easy testing. +-- +module System.Environment.Parser ( + + -- * Basic interface + + run -- :: Parser a -> IO (Either Errors a) + , test -- :: Parser a -> Map.Map String String -> Either Errors a + , help -- :: Parser a -> Dep + , get -- :: FromEnv a => String -> Parser a + , getParse -- :: FE.FromEnv a => (a -> Either String b) -> String -> Parser b + , json -- :: FromJSON a => String -> Parser a + + -- * Interface types + + , Parser + , Errors (..), Err (..) + , Dep (..), references + + ) where + +import Control.Applicative +import qualified Data.Aeson as Ae +import qualified Data.Aeson.Types as Ae +import Data.Functor.Compose +import qualified Data.Map as Map +import Data.Monoid +import Data.Foldable (toList, foldMap) +import Data.Sequence ((<|), (|>)) +import qualified Data.Sequence as Seq +import qualified System.Environment.Parser.Class as Cls +import qualified System.Environment.Parser.FromEnv as FE +import System.Environment.Parser.Miss + +-- ----------------------------------------------------------------------------- +-- Error types + +data Err = Wanted String | Joined String + deriving ( Eq, Ord, Show ) + +newtype Errors = Errors { getErrors :: Seq.Seq Err } + deriving ( Eq, Ord, Show, Monoid ) + +instance Cls.Satisfiable Errors where + wants = Errors . Seq.singleton . Wanted + errors = Errors . Seq.singleton . Joined + +-- ----------------------------------------------------------------------------- +-- Analysis types + +data Dep = Succeeding + | Needing String + | Branching (Seq.Seq Dep) + | Joining Dep + | Defaulting String Dep + deriving ( Eq, Show ) + +references :: Dep -> [String] +references = toList . foldDep where + foldDep Succeeding = Seq.empty + foldDep (Needing key) = Seq.singleton key + foldDep (Branching ds) = foldMap foldDep ds + foldDep (Joining d) = foldDep d + foldDep (Defaulting _ d) = foldDep d + +data Df a = Df { runDf :: Dep } deriving Functor + +instance Applicative Df where + pure _ = Df Succeeding + Df (Branching dfs) <*> Df (Branching dxs) = Df (Branching $ dfs <> dxs) + Df (Branching dfs) <*> Df dx = Df (Branching $ dfs |> dx) + Df df <*> Df (Branching dxs) = Df (Branching $ df <| dxs) + Df df <*> Df dx = Df (Branching $ Seq.fromList [df, dx]) + +instance Cls.HasEnv Df where + getEnv key = Df (Needing key) + +instance Cls.Env Df where + joinFailure (Df dep) = Df (Joining dep) + def a sho (Df dep) = Df (Defaulting (sho a) dep) + +-- ----------------------------------------------------------------------------- +-- Parser types + +data Parser a = Parser + { run' :: Compose IO (Miss Errors) a + , test' :: Compose ((->) (Map.Map String String)) (Miss Errors) a + , help' :: Df a + } + deriving ( Functor ) + +instance Applicative Parser where + pure a = Parser (pure a) (pure a) (pure a) + Parser f1 f2 f3 <*> Parser x1 x2 x3 = + Parser (f1 <*> x1) (f2 <*> x2) (f3 <*> x3) + +instance Cls.HasEnv Parser where + getEnv key = Parser (Cls.getEnv key) (Cls.getEnv key) (Cls.getEnv key) + +instance Cls.Env Parser where + joinFailure (Parser i1 i2 i3) = + Parser (Cls.joinFailure i1) (Cls.joinFailure i2) (Cls.joinFailure i3) + def a sho (Parser i1 i2 i3) = + Parser (Cls.def a sho i1) (Cls.def a sho i2) (Cls.def a sho i3) + +run :: Parser a -> IO (Either Errors a) +run = fmap toEither . getCompose . run' + +test :: Parser a -> Map.Map String String -> Either Errors a +test = fmap toEither . getCompose . test' + +help :: Parser a -> Dep +help = runDf . help' + +get :: FE.FromEnv a => String -> Parser a +get = FE.fromEnv . Cls.getEnv + +json :: Ae.FromJSON a => String -> Parser a +json = getParse (Ae.parseEither Ae.parseJSON) + +getParse :: FE.FromEnv a => (a -> Either String b) -> String -> Parser b +getParse parse key = Cls.joinFailure $ fmap parse $ get key diff --git a/src/System/Environment/Parser/Class.hs b/src/System/Environment/Parser/Class.hs new file mode 100644 --- /dev/null +++ b/src/System/Environment/Parser/Class.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE FlexibleInstances #-} +-- | +-- Module : System.Environment.Parser.Class +-- Copyright : (c) Joseph Abrahamson 2013 +-- License : MIT +-- +-- Maintainer : me@jspha.com +-- Stability : experimental +-- Portability : non-portable +-- +module System.Environment.Parser.Class where + +import Control.Applicative +import qualified Control.Exception as E +import Data.Functor.Compose +import qualified Data.Map as Map +import Data.Monoid +import qualified System.Environment as Env +import System.Environment.Parser.Miss + +-- ----------------------------------------------------------------------------- +-- The HasEnv class + +-- | 'HasEnv' is an adapter abstracting the raw IO-based environment +-- lookup. This lets us simulate a run of our parser in a fake environment. +class HasEnv r where + getEnv :: String -> r String + +instance HasEnv IO where + getEnv = Env.getEnv + +getEnvSafe :: String -> IO (Maybe String) +getEnvSafe key = do + v <- E.try (getEnv key) + return $ case v :: Either E.SomeException String of + Left _ -> Nothing + Right a -> Just a + +instance (HasEnv f, Applicative f) => HasEnv (Compose IO f) where + getEnv key = Compose $ maybe (getEnv key) pure <$> getEnvSafe key + +instance (HasEnv f, Applicative f) + => HasEnv (Compose ((->) (Map.Map String String)) f) where + getEnv key = Compose $ maybe (getEnv key) pure . Map.lookup key + +-- ---------------------------------------------------------------------------- +-- Satisfiable class + +class Monoid a => Satisfiable a where + wants :: String -> a + errors :: String -> a + +-- ---------------------------------------------------------------------------- +-- The Env class + +class Applicative r => Env r where + -- | Express that a parse has failed + joinFailure :: r (Either String a) -> r a + + -- | Replace a result with a default if necessary + def :: a -> (a -> String) -> r a -> r a + +instance Satisfiable e => HasEnv (Miss e) where + getEnv key = Miss (wants key) + +instance Satisfiable e => Env (Miss e) where + joinFailure (Miss er) = Miss er + joinFailure (Got (Left er)) = Miss (errors er) + joinFailure (Got (Right a)) = Got a + + def a _ (Miss _) = Got a + def _ _ (Got a) = Got a + +instance (Applicative f, Env g) => Env (Compose f g) where + joinFailure = Compose . fmap joinFailure . getCompose + def a sho = Compose . fmap (def a sho) . getCompose + +-- | Default a 'Show'-able type. +defShow :: (Show a, Env r) => a -> r a -> r a +defShow a = def a show + +-- | Default a type with a constant string. +defNoShow :: Env r => a -> String -> r a -> r a +defNoShow a str = def a (const str) diff --git a/src/System/Environment/Parser/Database.hs b/src/System/Environment/Parser/Database.hs new file mode 100644 --- /dev/null +++ b/src/System/Environment/Parser/Database.hs @@ -0,0 +1,122 @@ + +-- | +-- Module : System.Environment.Parser.Database +-- Copyright : (c) Joseph Abrahamson 2013 +-- License : MIT +-- +-- Maintainer : me@jspha.com +-- Stability : experimental +-- Portability : non-portable +-- +-- Heroku-style database connection URL parsing. +module System.Environment.Parser.Database ( + + DBConnection (..), Provider (..), providerString + + ) where + +import Control.Applicative +import qualified Data.Attoparsec.Text as At +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Network.HTTP.Types as Ht +import qualified Network.URI as URI +import System.Environment.Parser.FromEnv + +---------------------------------------------------------------------------- +-- Heroku-style DB urls + +-- | Provider indicates what kind of database provider scheme this URL +-- refers to. This provides a small amount of convenience around URL +-- detection, but if detection fails use 'providerName' to extract the raw +-- string. +data Provider = Postgres S.ByteString + | MySQL S.ByteString + | AMQP S.ByteString + | HTTP S.ByteString + | Other S.ByteString + +providerString :: Provider -> S.ByteString +providerString p = case p of + Postgres s -> s + MySQL s -> s + AMQP s -> s + HTTP s -> s + Other s -> s + +-- | A type representing the information that can be parsed from +-- a URL-style database configuration. For example consider the following +-- URLs +-- +-- > postgres://user3123:passkja83kd8@ec2-117-21-174-214.compute-1.amazonaws.com:6212/db982398 +-- > mysql://adffdadf2341:adf4234@us-cdbr-east.cleardb.com/heroku_db?reconnect=true +-- > mysql2://adffdadf2341:adf4234@us-cdbr-east.cleardb.com/heroku_db?reconnect=true +-- > http://user:pass@instance.ip/resourceid +-- > amqp://user:pass@ec2.clustername.cloudamqp.com/vhost +-- +-- We assume that all the information in these URLs is provided---if +-- a username or password is unnecessary then it must be passed as an empty +-- string and not omitted. +-- +data DBConnection = DBConnection + { provider :: Provider + , host :: S.ByteString + , username :: S.ByteString + , password :: S.ByteString + , port :: Int + , location :: S.ByteString + , params :: Map.Map S.ByteString S.ByteString + } + +instance FromEnv DBConnection where + parseEnv = tryParse + +tryParse :: String -> Either String DBConnection +tryParse s = do + uri <- e "invalid URI format" $ URI.parseAbsoluteURI s + auth <- e "URI authority segment missing" $ URI.uriAuthority uri + port <- parsePort (URI.uriPort auth) + (username, password) <- parseUserPw (URI.uriUserInfo auth) + + return DBConnection + { provider = guessProvider (URI.uriScheme uri) + , host = S8.pack (URI.uriRegName auth) + , username = username + , password = password + , port = port + , location = S8.pack $ drop 1 $ URI.uriPath uri + , params = makeQueryMap (URI.uriQuery uri) + } + + where + + guessProvider :: String -> Provider + guessProvider x = case x of + "postgres:" -> Postgres bs + "mysql:" -> MySQL bs + "mysql2:" -> MySQL bs + "http:" -> HTTP bs + "amqp:" -> AMQP bs + _ -> Other bs + where bs = S8.pack s + + parsePort :: String -> Either String Int + parsePort = At.parseOnly (At.char ':' *> At.decimal) . T.pack + + parseUserPw :: String -> Either String (S.ByteString, S.ByteString) + parseUserPw = At.parseOnly ( (,) <$> (TE.encodeUtf8 <$> At.takeTill (==':') <* At.char ':') + <*> (TE.encodeUtf8 <$> At.takeTill (=='@') <* At.char '@') ) + . T.pack + + makeQueryMap :: String -> Map.Map S.ByteString S.ByteString + makeQueryMap = Map.fromList . Ht.parseSimpleQuery . S8.pack + +-- ----------------------------------------------------------------------------- +-- Utilities + +e :: String -> Maybe a -> Either String a +e s Nothing = Left s +e _ (Just a) = Right a diff --git a/src/System/Environment/Parser/Encoded.hs b/src/System/Environment/Parser/Encoded.hs new file mode 100644 --- /dev/null +++ b/src/System/Environment/Parser/Encoded.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : System.Environment.Parser.Encoded +-- Copyright : (c) Joseph Abrahamson 2013 +-- License : MIT +-- +-- Maintainer : me@jspha.com +-- Stability : experimental +-- Portability : non-portable +-- +-- Often it's useful to pass binary data through the environment as an +-- encoded string. This module provides handy types for specifying these +-- kinds of data. +-- +-- @ +-- data SecretKeys = Sk { key1 :: Base64, key2 :: Base64 } +-- @ +-- +module System.Environment.Parser.Encoded ( + + Base64 (..), Base64Url (..), Base16 (..) + + ) where + +import Control.Monad +import qualified Data.Aeson as Ae +import qualified Data.ByteString as S +import qualified Data.ByteString.Base16 as S16 +import qualified Data.ByteString.Base64 as S64 +import qualified Data.ByteString.Base64.URL as S64U +import qualified Data.Text.Encoding as Te +import System.Environment.Parser.FromEnv + +-- | Isomorphic to a 'S.ByteString', a type which prefers to be base-64 +-- encoded. +newtype Base64 = Base64 { unBase64 :: S.ByteString } + deriving ( Eq, Ord, Show ) + +-- | Isomorphic to a 'S.ByteString', a type which prefers to be base-64-url +-- encoded (see ). +newtype Base64Url = Base64Url { unBase64Url :: S.ByteString } + deriving ( Eq, Ord, Show ) + +-- | Isomorphic to a 'S.ByteString', a type which prefers to be hexadecimal +-- encoded. +newtype Base16 = Base16 { unBase16 :: S.ByteString } + deriving ( Eq, Ord, Show ) + +instance FromEnv Base64 where + parseEnv = fmap Base64 . S64.decode <=< parseEnv + +instance FromEnv Base64Url where + parseEnv = fmap Base64Url . S64U.decode <=< parseEnv + +instance FromEnv Base16 where + parseEnv = fmap Base16 . s16decode <=< parseEnv where + s16decode :: S.ByteString -> Either String S.ByteString + s16decode bs = case S16.decode bs of + (out, rest) | S.null rest -> Right out + | otherwise -> Left "failed to decode hexadecimal string" + +instance Ae.FromJSON Base64 where + parseJSON = Ae.withText "base64 encoded string" $ \t -> + case S64.decode (Te.encodeUtf8 t) of + Left err -> fail err + Right b -> return (Base64 b) + +instance Ae.ToJSON Base64 where + toJSON (Base64 bs) = Ae.String $ Te.decodeUtf8 $ S64.encode bs + +instance Ae.FromJSON Base64Url where + parseJSON = Ae.withText "base64url encoded string" $ \t -> + case S64U.decode (Te.encodeUtf8 t) of + Left err -> fail err + Right b -> return (Base64Url b) + +instance Ae.ToJSON Base64Url where + toJSON (Base64Url bs) = Ae.String $ Te.decodeUtf8 $ S64U.encode bs + +instance Ae.FromJSON Base16 where + parseJSON = Ae.withText "base64 encoded string" $ \t -> + case S16.decode (Te.encodeUtf8 t) of + (out, rest) | S.null rest -> return (Base16 out) + | otherwise -> fail "failed to decode hexadecimal string" + +instance Ae.ToJSON Base16 where + toJSON (Base16 bs) = Ae.String $ Te.decodeUtf8 $ S16.encode bs diff --git a/src/System/Environment/Parser/FromEnv.hs b/src/System/Environment/Parser/FromEnv.hs new file mode 100644 --- /dev/null +++ b/src/System/Environment/Parser/FromEnv.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-- | +-- Module : System.Environment.Parser.Internal +-- Copyright : (c) Joseph Abrahamson 2013 +-- License : MIT +-- +-- Maintainer : me@jspha.com +-- Stability : experimental +-- Portability : non-portable +-- +-- Types which can be deserialized from an environment variable. + +module System.Environment.Parser.FromEnv ( + + FromEnv (..) + + ) where + +import Control.Applicative +import Control.Monad +import qualified Data.Aeson as Ae +import qualified Data.Attoparsec.Text as At +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as SL +import qualified Data.ByteString.Lazy.Char8 as SL8 +import Data.Int +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Time +import System.Environment.Parser.Class +import System.Locale + +-- | Types instantiatiating 'FromEnv' can be deserialized from the +-- environment directly. +class FromEnv a where + parseEnv :: String -> Either String a + + -- | For this most part this should be left as default. It's useful for + -- introducing non-failing parsers, though. + fromEnv :: Env r => r String -> r a + fromEnv = joinFailure . fmap parseEnv + + +instance FromEnv String where + parseEnv = Right + fromEnv = id + +instance FromEnv S.ByteString where + parseEnv s = Right (S8.pack s) + fromEnv = fmap S8.pack + +instance FromEnv SL.ByteString where + parseEnv s = Right (SL8.pack s) + fromEnv = fmap SL8.pack + +instance FromEnv T.Text where + parseEnv s = Right (T.pack s) + fromEnv = fmap T.pack + +instance FromEnv TL.Text where + parseEnv s = Right (TL.pack s) + fromEnv = fmap TL.pack + +integralEnv :: Integral a => String -> Either String a +integralEnv s = do + txt <- parseEnv s + At.parseOnly (At.signed At.decimal) txt where + +instance FromEnv Int where parseEnv = integralEnv +instance FromEnv Integer where parseEnv = integralEnv +instance FromEnv Int8 where parseEnv = integralEnv +instance FromEnv Int64 where parseEnv = integralEnv +instance FromEnv Int32 where parseEnv = integralEnv +instance FromEnv Int16 where parseEnv = integralEnv + +instance FromEnv Double where + parseEnv s = do + txt <- parseEnv s + At.parseOnly (At.signed At.double) txt + +instance FromEnv At.Number where + parseEnv s = do + txt <- parseEnv s + At.parseOnly (At.signed At.number) txt + +-- ---------------------------------------------------------------------------- +-- Time parsers +-- +-- These may not always be the most apropriate formats for parsing time, +-- but customer parser can always be appended as needed. Instead, these +-- provide convention. + +-- | Interprets a string as a decimal number of seconds +instance FromEnv DiffTime where + parseEnv s = + realToFrac <$> (parseEnv s :: Either String At.Number) + +-- | Interprets a string as a decimal number of seconds +instance FromEnv NominalDiffTime where + parseEnv s = + realToFrac <$> (parseEnv s :: Either String At.Number) + +-- | Assumes first that the date is formatted as the W3C Profile of ISO +-- 8601 but also implements a few other formats. +-- +-- > %Y-%m-%dT%H:%M:%S%Q%z +-- > +-- > 1997-07-16T19:20:30.45+01:00 +-- > 1997-07-16T19:20:30.45Z +-- > 1997-07-16T19:20:30Z +-- +-- > %a %b %_d %H:%M:%S %z %Y +-- > +-- > Sat Jan 18 22:20:02 +0000 2014 +-- > Sat Jan 18 22:20:02 2014 +-- > Jan 18 22:20:02 2014 +-- +instance FromEnv UTCTime where + parseEnv s = + e "bad UTC time" + $ msum $ map (\format -> parseTime defaultTimeLocale format s) formats + + where + formats = + [ "%Y-%m-%dT%H:%M:%S%Q%z" + , "%Y-%m-%dT%H:%M:%S%QZ" + , "%a %b %_d %H:%M:%S %z %Y" + , "%a %b %_d %H:%M:%S %Y" + , "%b %_d %H:%M:%S %Y" + ] + +-- | Parses the Gregorian calendar format @\"%Y-%m-%d\"@. +instance FromEnv Day where + parseEnv s = + e "bad date" $ parseTime defaultTimeLocale "%Y-%m-%d" s + + +-- ---------------------------------------------------------------------------- +-- JSON Parsers +-- +-- JSON is such a convenient format that it might be conceivably jammed +-- into an environment variable. Since Aeson will soon be in the Haskell +-- platform we'll go ahead and include some obvious default instances for +-- Aeson Value types along with a nice general parser. + +instance FromEnv Ae.Value where + parseEnv s = do + bs <- parseEnv s + Ae.eitherDecodeStrict bs + +-- ---------------------------------------------------------------------------- +-- Utilities + +e :: String -> Maybe a -> Either String a +e s Nothing = Left s +e _ (Just a) = Right a diff --git a/src/System/Environment/Parser/Miss.hs b/src/System/Environment/Parser/Miss.hs new file mode 100644 --- /dev/null +++ b/src/System/Environment/Parser/Miss.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DeriveFunctor #-} + +-- | +-- Module : System.Environment.Parser.Miss +-- Copyright : (c) Joseph Abrahamson 2013 +-- License : MIT +-- +-- Maintainer : me@jspha.com +-- Stability : experimental +-- Portability : non-portable +-- +-- A purely Applicative Either. + +module System.Environment.Parser.Miss where + +import Control.Applicative +import Data.Monoid + +data Miss e a + = Got a + | Miss e + deriving ( Eq, Ord, Show, Read, Functor ) + +instance Monoid e => Applicative (Miss e) where + pure = Got + Miss e1 <*> Miss e2 = Miss (e1 <> e2) + Miss e1 <*> _ = Miss e1 + _ <*> Miss e2 = Miss e2 + Got f <*> Got x = Got (f x) + +toEither :: Miss e a -> Either e a +toEither (Miss e) = Left e +toEither (Got a) = Right a + +missMap :: (e -> f) -> Miss e a -> Miss f a +missMap f (Miss e) = Miss (f e) +missMap _ (Got a) = Got a + +gotMap :: (a -> b) -> Miss e a -> Miss e b +gotMap _ (Miss e) = Miss e +gotMap f (Got a) = Got (f a)