diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020 IIJ Innovation Institute, Inc. + +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 IIJ Innovation Institute, Inc. 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,4 @@ +# envy-extensible + +Provides [`FromEnv`](http://hackage.haskell.org/package/envy/docs/System-Envy.html#t:FromEnv) instance for [`Record`](https://hackage.haskell.org/package/extensible/docs/Data-Extensible-Field.html#t:Record) and functions to create `Record` from environment variable using [Parser](http://hackage.haskell.org/package/envy/docs/System-Envy.html#t:Parser). +See [the spec file](https://github.com/igrep/envy-extensible/blob/master/test/Data/Extensible/EnvySpec.hs) for examples. 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/envy-extensible.cabal b/envy-extensible.cabal new file mode 100644 --- /dev/null +++ b/envy-extensible.cabal @@ -0,0 +1,51 @@ +cabal-version: 2.2 +name: envy-extensible +version: 0.1.0.0 +synopsis: Provides FromEnv in envy instance for Record of extensible. +-- description: +homepage: https://github.com/igrep/envy-extensible#readme +license: BSD-3-Clause +license-file: LICENSE +author: IIJ Innovation Institute, Inc. +maintainer: yuji-yamamoto@iij.ad.jp +copyright: 2020 IIJ Innovation Institute, Inc. +category: Data, Record +build-type: Simple +extra-source-files: README.md + +common shared + default-language: Haskell2010 + build-depends: , base >= 4.7 && < 5 + , extensible >= 0.6 + , envy >= 2.0 + +library + import: shared + hs-source-dirs: src + exposed-modules: Data.Extensible.Envy + +test-suite envy-extensible-test + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Data.Extensible.EnvySpec + build-depends: , envy-extensible + , hspec + , main-tester + , QuickCheck + build-tool-depends: hspec-discover:hspec-discover + ghc-options: -rtsopts + +test-suite envy-extensible-doctest + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: doctest.hs + build-depends: , envy-extensible + , doctest + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + +source-repository head + type: git + location: https://github.com/igrep/envy-extensible diff --git a/src/Data/Extensible/Envy.hs b/src/Data/Extensible/Envy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Extensible/Envy.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Data.Extensible.Envy +-- Copyright : (c) 2020 IIJ Innovation Institute, Inc. +-- License : BSD3 +-- Maintainer: YAMAMOTO Yuji +-- Stability : Experimental +-- +-- Provides 'Env.FromEnv' instance for 'Ex.Record' and functions to +-- create 'Ex.Record' from environment variable using 'Env.Parser'. +-------------------------------------------------------------------------------- +module Data.Extensible.Envy + ( recordFromEnvWith + , recordFromEnv + , FieldLabelToEnvName + , defaultFieldLabelToEnvName + , camelToUpperSnakeCase + ) where + + +import qualified Data.Char as C +import Data.Extensible (Forall, Instance1) +import qualified Data.Extensible as Ex +import Data.Functor.Identity (Identity (Identity), runIdentity) +import Data.Kind (Type) +import Data.Proxy (Proxy (Proxy)) +import GHC.TypeLits (KnownSymbol, Symbol) +import qualified System.Envy as Env + + +-- | Function to convert field labels of 'Ex.Record' into the +-- name of environment variable. +-- Applied to each field label before passing it to 'Env.env' +type FieldLabelToEnvName = String -> String + + +-- | The default of 'FieldLabelToEnvName'. +-- +-- If the first argument is empty, just convert the field label +-- (second argument) into @UPPER_SNAKE_CASE@. +-- +-- >>> defaultFieldLabelToEnvName "" "thisIsATest" +-- "THIS_IS_A_TEST" +-- +-- Otherwise, convert the field label into @UPPER_SNAKE_CASE@, +-- then prepend the first argument with an underscore @_@. +-- +-- >>> defaultFieldLabelToEnvName "PREFIXED" "thisIsATest" +-- "PREFIXED_THIS_IS_A_TEST" +defaultFieldLabelToEnvName :: String -> FieldLabelToEnvName +defaultFieldLabelToEnvName "" s = camelToUpperSnakeCase s +defaultFieldLabelToEnvName prefix s = prefix ++ "_" ++ camelToUpperSnakeCase s +{-# INLINE defaultFieldLabelToEnvName #-} + + +-- | Used internally in 'defaultFieldLabelToEnvName'. +-- Published for your convenience. +camelToUpperSnakeCase :: FieldLabelToEnvName +camelToUpperSnakeCase = + foldMap (\c -> if C.isUpper c then '_' : [c] else [C.toUpper c]) +{-# INLINE camelToUpperSnakeCase #-} + + +-- | +-- @ +-- recordFromEnv = recordFromEnvWith $ defaultFieldLabelToEnvName "" +-- @ +recordFromEnv + :: forall (xs :: [Ex.Assoc Symbol Type]) h + . Forall (Ex.KeyTargetAre KnownSymbol (Instance1 Env.Var h)) xs + => Env.Parser (Ex.RecordOf h xs) +recordFromEnv = recordFromEnvWith $ defaultFieldLabelToEnvName "" +{-# INLINE recordFromEnv #-} + + +-- | 'Env.Parser' for 'Ex.Record' +recordFromEnvWith + :: forall (xs :: [Ex.Assoc Symbol Type]) h + . Forall (Ex.KeyTargetAre KnownSymbol (Instance1 Env.Var h)) xs + => FieldLabelToEnvName + -> Env.Parser (Ex.RecordOf h xs) +recordFromEnvWith fl2en = + Ex.hgenerateFor + (Proxy :: Proxy (Ex.KeyTargetAre KnownSymbol (Instance1 Env.Var h))) f + where + f membership = Ex.Field <$> Env.env (fl2en $ Ex.stringKeyOf membership) +{-# INLINE recordFromEnvWith #-} + + +-- | Returns 'recordFromEnv' when the first argument of 'Env.fromEnv' is @Nothing@. +instance Forall (Ex.KeyTargetAre KnownSymbol (Instance1 Env.Var h)) xs + => Env.FromEnv (Ex.RecordOf (h :: Type -> Type) xs) + where + fromEnv (Just r) = pure r + fromEnv Nothing = recordFromEnv + {-# INLINE fromEnv #-} + + +-- | Necessary to make 'Ex.Record' an instance of 'Env.FromEnv' +instance Env.Var a => Env.Var (Identity a) where + toVar = Env.toVar . runIdentity + {-# INLINE toVar #-} + fromVar = fmap Identity . Env.fromVar + {-# INLINE fromVar #-} diff --git a/test/Data/Extensible/EnvySpec.hs b/test/Data/Extensible/EnvySpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Extensible/EnvySpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Extensible.EnvySpec + ( main + , spec + ) where + +import Data.Either (isLeft) +import Data.Extensible (type (>:), (<:), (@=)) +import qualified Data.Extensible as Ex +import qualified System.Envy as Env +import Test.Hspec +import Test.Main (withEnv) + +import Data.Extensible.Envy + + +type SomeRecord = Ex.Record + '[ "fooField" >: String + , "bar" >: Bool + , "baz" >: Int + ] + + +main :: IO () +main = hspec spec + + +spec :: Spec +spec = describe "recordFromEnvWith" $ do + let fl2en = defaultFieldLabelToEnvName "EXAMPLE_RECORD" + context "When all of the required environment variables are created" $ + it "can be created by System.Envy.runEnv" $ do + let env = + [ ("EXAMPLE_RECORD_FOO_FIELD", Just "string") + , ("EXAMPLE_RECORD_BAR", Just "True") + , ("EXAMPLE_RECORD_BAZ", Just "1230") + ] + expected :: SomeRecord + expected = + #fooField @= "string" + <: #bar @= True + <: #baz @= 1230 + <: Ex.nil + withEnv env $ + Env.runEnv (recordFromEnvWith fl2en) `shouldReturn` Right expected + context "When some of the required environment variables are not created" $ + it "can't be created by System.Envy.runEnv" $ do + let env = + [ ("EXAMPLE_RECORD_FOO_FIELD", Just "string") + , ("EXAMPLE_RECORD_BAR", Just "True") + , ("EXAMPLE_RECORD_BAZ", Nothing) + ] + withEnv env $ do + result <- Env.runEnv (recordFromEnvWith fl2en) :: IO (Either String SomeRecord) + result `shouldSatisfy` isLeft 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 #-} diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,4 @@ +import Test.DocTest + +main :: IO () +main = doctest ["src/Data/Extensible/Envy.hs"]