Skip to content

Commit

Permalink
Factor out unsafeLookupEnv
Browse files Browse the repository at this point in the history
- Added System.Environment.Lookup and System.Environment.LookupSpec to
core

- Removed common parts from
    - Cardano.Environment.HttpBridge
    - Cardano.Environment.HttpBridgeSpec
    - Cardano.Environment.Jormungandr
    - Cardano.Environment.JormungandrSpec (added)
  • Loading branch information
Anviking committed May 9, 2019
1 parent 4922d52 commit fba0951
Show file tree
Hide file tree
Showing 9 changed files with 246 additions and 240 deletions.
2 changes: 2 additions & 0 deletions lib/core/cardano-wallet-core.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -63,6 +63,7 @@ library
Cardano.Wallet.Api.Types
Cardano.Wallet.DB
Cardano.Wallet.DB.MVar
Cardano.Environment
Cardano.Wallet.Network
Cardano.Wallet.Primitive.AddressDerivation
Cardano.Wallet.Primitive.AddressDiscovery
Expand Down Expand Up @@ -130,6 +131,7 @@ test-suite unit
Cardano.Wallet.ApiSpec
Cardano.Wallet.DB.MVarSpec
Cardano.Wallet.DBSpec
Cardano.EnvironmentSpec
Cardano.Wallet.NetworkSpec
Cardano.Wallet.Primitive.AddressDerivationSpec
Cardano.Wallet.Primitive.AddressDiscoverySpec
Expand Down
106 changes: 106 additions & 0 deletions lib/core/src/Cardano/Environment.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,106 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

-- | Helpers for reading ENV vars using 'unsafePerformIO' with readable error
-- messages.
--
-- Copyright: © 2018-2019 IOHK
-- License: MIT
--
module Cardano.Environment
(
ErrMissingOrInvalidEnvVar(..)
, unsafeLookupEnv
) where

import Prelude

import Control.Exception
( Exception (..), throwIO )
import Data.Text
( Text )
import Data.Text.Class
( FromText (..), TextDecodingError (..) )
import Fmt
( Buildable (..), nameF, padLeftF, pretty )
import System.Environment
( getProgName, lookupEnv )
import System.IO.Unsafe
( unsafePerformIO )

import qualified Data.Text as T


-- | Fatal exception thrown when a required ENV var is missing upon start-up.
data ErrMissingOrInvalidEnvVar = ErrMissingOrInvalidEnvVar
{ name :: String
, command :: String
, additionalContext :: Maybe (String, TextDecodingError)
}

instance Show ErrMissingOrInvalidEnvVar where
show = displayException

-- | Produces a nice terminal output so that the error is very readable.
--
-- @
-- $ NETWORK=patate cardano-wallet-launcher
-- Starting...
-- cardano-wallet-launcher: Missing or invalid ENV var:
--
-- ENV[NETWORK] = patate
-- |
-- |
-- *--> patate is neither "mainnet", "testnet" nor "staging"
--
-- @
--
-- @
-- $ cardano-wallet-launcher
-- Starting...
-- cardano-wallet-launcher: Missing or invalid ENV var:
--
-- ENV[NETWORK] = ?
--
-- What about trying to provide a valid ENV var `NETWORK=value cardano-wallet-launcher` ?
-- @
instance Exception ErrMissingOrInvalidEnvVar where
displayException (ErrMissingOrInvalidEnvVar n cmd ctx) = pretty $ mempty
<> nameF "Missing or invalid ENV var"
( "\n ENV[" <> build n <> "] = " <> ctxF )
where
ctxF = case ctx of
Nothing -> "?"
<> "\n\nWhat about trying to provide a valid ENV var "
<> "`" <> build n <> "=value " <> build cmd <> "` ?"
Just (v, err) ->
let
pad = length n + (length v `div` 2) + 11
in
build v
<> "\n " <> padLeftF @Text pad ' ' "| "
<> "\n " <> padLeftF @Text pad ' ' "| "
<> "\n " <> padLeftF @Text pad ' ' "*--> "
<> build err

-- | Lookup the environment for a given variable
unsafeLookupEnv
:: FromText a
=> String
-> a
unsafeLookupEnv k = unsafePerformIO $ do
cmd <- getProgName
v <- lookupEnv k >>= \case
Just v -> return v
Nothing -> throwIO $ ErrMissingOrInvalidEnvVar
{ name = k
, command = cmd
, additionalContext = Nothing
}
case fromText (T.pack v) of
Right a -> return a
Left err -> throwIO $ ErrMissingOrInvalidEnvVar
{ name = k
, command = cmd
, additionalContext = Just (v, err)
}
98 changes: 98 additions & 0 deletions lib/core/test/unit/Cardano/EnvironmentSpec.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,98 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Cardano.EnvironmentSpec
( spec
) where

import Prelude

import Cardano.Environment
( ErrMissingOrInvalidEnvVar (..), unsafeLookupEnv )
import Data.Maybe
( isNothing )
import Data.Text.Class
( FromText (..), TextDecodingError (..), ToText (..) )
import GHC.Generics
( Generic )
import System.Environment
( setEnv, unsetEnv )
import Test.Hspec
( Spec, describe, it, shouldThrow )
import Test.QuickCheck
( Arbitrary (..) )
import Test.QuickCheck.Arbitrary.Generic
( genericArbitrary, genericShrink )

import qualified Data.Text as T

spec :: Spec
spec = do
describe "ErrMissingOrInvalidEnvVar (Show / displayException)" $ do
let errNoAdditionalContext = ErrMissingOrInvalidEnvVar
{ name = "PATATE"
, command = "my-command"
, additionalContext = Nothing
}
let errWithAdditionalContext = ErrMissingOrInvalidEnvVar
{ name = "PATATE"
, command = "my-command"
, additionalContext = Just
("💩"
, TextDecodingError
{ getTextDecodingError = "not a valid value" }
)
}
it (show errNoAdditionalContext) True
it (show errWithAdditionalContext) True

describe "unsafeLookupEnv" $ do
it "throws with no context when variable isn't present" $ do
unsetEnv "PATATE" -- Just in case
let io =
unsafeLookupEnv @Network "PATATE" `seq` (return ())
let selector (ErrMissingOrInvalidEnvVar n _ c) =
n == "PATATE" && isNothing c
io `shouldThrow` selector

it "throws with extra context when variable is present but invalid" $ do
setEnv "PATATE" "not-a-network"
let ctx =
( "not-a-network"
, TextDecodingError "not-a-network is neither \"mainnet\",\
\ \"testnet\" nor \"staging\"."
)
let selector (ErrMissingOrInvalidEnvVar n _ c) =
n == "PATATE" && c == Just ctx
let io =
unsafeLookupEnv @Network "PATATE" `seq` (return ())
io `shouldThrow` selector

{-------------------------------------------------------------------------------
Types
-------------------------------------------------------------------------------}

data Network = Mainnet | Testnet | Staging
deriving Generic

instance Arbitrary Network where
arbitrary = genericArbitrary
shrink = genericShrink

instance FromText Network where
fromText = \case
"mainnet" -> Right Mainnet
"testnet" -> Right Testnet
"staging" -> Right Staging
s -> Left $ TextDecodingError $ T.unpack s
<> " is neither \"mainnet\", \"testnet\" nor \"staging\"."

instance ToText Network where
toText = \case
Mainnet -> "mainnet"
Testnet -> "testnet"
Staging -> "staging"
1 change: 0 additions & 1 deletion lib/http-bridge/cardano-wallet-http-bridge.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -42,7 +42,6 @@ library
, cryptonite
, digest
, exceptions
, fmt
, http-api-data
, http-client
, http-media
Expand Down
96 changes: 2 additions & 94 deletions lib/http-bridge/src/Cardano/Environment/HttpBridge.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,5 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Copyright: © 2018-2019 IOHK
Expand All @@ -23,112 +22,21 @@ module Cardano.Environment.HttpBridge
, network
, ProtocolMagic(..)
, protocolMagic

-- * Internals
, ErrMissingOrInvalidEnvVar(..)
, unsafeLookupEnv
) where

import Prelude

import Control.Exception
( Exception (..), throwIO )
import Cardano.Environment
( unsafeLookupEnv )
import Data.Int
( Int32 )
import Data.Text
( Text )
import Data.Text.Class
( FromText (..), TextDecodingError (..), ToText (..) )
import Fmt
( Buildable (..), nameF, padLeftF, pretty )
import GHC.Generics
( Generic )
import System.Environment
( getProgName, lookupEnv )
import System.IO.Unsafe
( unsafePerformIO )

import qualified Data.Text as T


-- | Fatal exception thrown when a required ENV var is missing upon start-up.
data ErrMissingOrInvalidEnvVar = ErrMissingOrInvalidEnvVar
{ name :: String
, command :: String
, additionalContext :: Maybe (String, TextDecodingError)
}

instance Show ErrMissingOrInvalidEnvVar where
show = displayException

-- | Produces a nice terminal output so that the error is very readable.
--
-- @
-- $ NETWORK=patate cardano-wallet-launcher
-- Starting...
-- cardano-wallet-launcher: Missing or invalid ENV var:
--
-- ENV[NETWORK] = patate
-- |
-- |
-- *--> patate is neither "mainnet", "testnet" nor "staging"
--
-- @
--
-- @
-- $ cardano-wallet-launcher
-- Starting...
-- cardano-wallet-launcher: Missing or invalid ENV var:
--
-- ENV[NETWORK] = ?
--
-- What about trying to provide a valid ENV var `NETWORK=value cardano-wallet-launcher` ?
-- @
instance Exception ErrMissingOrInvalidEnvVar where
displayException (ErrMissingOrInvalidEnvVar n cmd ctx) = pretty $ mempty
<> nameF "Missing or invalid ENV var"
( "\n ENV[" <> build n <> "] = " <> ctxF )
where
ctxF = case ctx of
Nothing -> "?"
<> "\n\nWhat about trying to provide a valid ENV var "
<> "`" <> build n <> "=value " <> build cmd <> "` ?"
Just (v, err) ->
let
pad = length n + (length v `div` 2) + 11
in
build v
<> "\n " <> padLeftF @Text pad ' ' "| "
<> "\n " <> padLeftF @Text pad ' ' "| "
<> "\n " <> padLeftF @Text pad ' ' "*--> "
<> build err

-- | Lookup the environment for a given variable
unsafeLookupEnv
:: FromText a
=> String
-> a
unsafeLookupEnv k = unsafePerformIO $ do
cmd <- getProgName
v <- lookupEnv k >>= \case
Just v -> return v
Nothing -> throwIO $ ErrMissingOrInvalidEnvVar
{ name = k
, command = cmd
, additionalContext = Nothing
}
case fromText (T.pack v) of
Right a -> return a
Left err -> throwIO $ ErrMissingOrInvalidEnvVar
{ name = k
, command = cmd
, additionalContext = Just (v, err)
}

{-------------------------------------------------------------------------------
Environment
-------------------------------------------------------------------------------}

-- | Available network options.
data Network = Mainnet | Testnet | Staging
deriving (Generic, Show, Eq, Enum)
Expand Down
Loading

0 comments on commit fba0951

Please sign in to comment.