module Hadolint.Config.Environment
  ( getConfigFromEnvironment
  )
where

import Data.Char (toLower)
import Data.Coerce (coerce)
import Data.Map (empty, fromList)
import Data.Set (Set, empty, fromList)
import Data.Text (Text, pack, unpack, drop, splitOn, breakOn)
import Hadolint.Formatter.Format (OutputFormat (..), readMaybeOutputFormat)
import Hadolint.Config.Configuration
import Hadolint.Rule
import Language.Docker.Syntax
import System.Environment


getConfigFromEnvironment :: IO PartialConfiguration
getConfigFromEnvironment :: IO PartialConfiguration
getConfigFromEnvironment =
  Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe OutputFormat
-> [RuleCode]
-> [RuleCode]
-> [RuleCode]
-> [RuleCode]
-> [RuleCode]
-> Set Registry
-> LabelSchema
-> Maybe Bool
-> Maybe Bool
-> Maybe DLSeverity
-> PartialConfiguration
PartialConfiguration
    (Maybe Bool
 -> Maybe Bool
 -> Maybe Bool
 -> Maybe OutputFormat
 -> [RuleCode]
 -> [RuleCode]
 -> [RuleCode]
 -> [RuleCode]
 -> [RuleCode]
 -> Set Registry
 -> LabelSchema
 -> Maybe Bool
 -> Maybe Bool
 -> Maybe DLSeverity
 -> PartialConfiguration)
-> IO (Maybe Bool)
-> IO
     (Maybe Bool
      -> Maybe Bool
      -> Maybe OutputFormat
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> Set Registry
      -> LabelSchema
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe DLSeverity
      -> PartialConfiguration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe Bool)
maybeTruthy String
"HADOLINT_NOFAIL"
    IO
  (Maybe Bool
   -> Maybe Bool
   -> Maybe OutputFormat
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> Set Registry
   -> LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO (Maybe Bool)
-> IO
     (Maybe Bool
      -> Maybe OutputFormat
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> Set Registry
      -> LabelSchema
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe DLSeverity
      -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Maybe Bool)
isSet String
"NO_COLOR"
    IO
  (Maybe Bool
   -> Maybe OutputFormat
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> Set Registry
   -> LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO (Maybe Bool)
-> IO
     (Maybe OutputFormat
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> Set Registry
      -> LabelSchema
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe DLSeverity
      -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Maybe Bool)
maybeTruthy String
"HADOLINT_VERBOSE"
    IO
  (Maybe OutputFormat
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> Set Registry
   -> LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO (Maybe OutputFormat)
-> IO
     ([RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> Set Registry
      -> LabelSchema
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe DLSeverity
      -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Maybe OutputFormat)
getFormat
    IO
  ([RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> Set Registry
   -> LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO [RuleCode]
-> IO
     ([RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> Set Registry
      -> LabelSchema
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe DLSeverity
      -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO [RuleCode]
getOverrideList String
"HADOLINT_OVERRIDE_ERROR"
    IO
  ([RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> Set Registry
   -> LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO [RuleCode]
-> IO
     ([RuleCode]
      -> [RuleCode]
      -> [RuleCode]
      -> Set Registry
      -> LabelSchema
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe DLSeverity
      -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO [RuleCode]
getOverrideList String
"HADOLINT_OVERRIDE_WARNING"
    IO
  ([RuleCode]
   -> [RuleCode]
   -> [RuleCode]
   -> Set Registry
   -> LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO [RuleCode]
-> IO
     ([RuleCode]
      -> [RuleCode]
      -> Set Registry
      -> LabelSchema
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe DLSeverity
      -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO [RuleCode]
getOverrideList String
"HADOLINT_OVERRIDE_INFO"
    IO
  ([RuleCode]
   -> [RuleCode]
   -> Set Registry
   -> LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO [RuleCode]
-> IO
     ([RuleCode]
      -> Set Registry
      -> LabelSchema
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe DLSeverity
      -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO [RuleCode]
getOverrideList String
"HADOLINT_OVERRIDE_STYLE"
    IO
  ([RuleCode]
   -> Set Registry
   -> LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO [RuleCode]
-> IO
     (Set Registry
      -> LabelSchema
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe DLSeverity
      -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO [RuleCode]
getOverrideList String
"HADOLINT_IGNORE"
    IO
  (Set Registry
   -> LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO (Set Registry)
-> IO
     (LabelSchema
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe DLSeverity
      -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Set Registry)
getAllowedSet String
"HADOLINT_TRUSTED_REGISTRIES"
    IO
  (LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO LabelSchema
-> IO
     (Maybe Bool
      -> Maybe Bool -> Maybe DLSeverity -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO LabelSchema
getLabelSchema String
"HADOLINT_REQUIRE_LABELS"
    IO
  (Maybe Bool
   -> Maybe Bool -> Maybe DLSeverity -> PartialConfiguration)
-> IO (Maybe Bool)
-> IO (Maybe Bool -> Maybe DLSeverity -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Maybe Bool)
maybeTruthy String
"HADOLINT_STRICT_LABELS"
    IO (Maybe Bool -> Maybe DLSeverity -> PartialConfiguration)
-> IO (Maybe Bool) -> IO (Maybe DLSeverity -> PartialConfiguration)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO (Maybe Bool)
maybeTruthy String
"HADOLINT_DISABLE_IGNORE_PRAGMA"
    IO (Maybe DLSeverity -> PartialConfiguration)
-> IO (Maybe DLSeverity) -> IO PartialConfiguration
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Maybe DLSeverity)
getFailureThreshold


isSet :: String -> IO (Maybe Bool)
isSet :: String -> IO (Maybe Bool)
isSet String
name = do
  Maybe String
e <- String -> IO (Maybe String)
lookupEnv String
name
  case Maybe String
e of
    Just String
_ -> Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    Maybe String
Nothing -> Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing

maybeTruthy :: String -> IO (Maybe Bool)
maybeTruthy :: String -> IO (Maybe Bool)
maybeTruthy String
name = do
  Maybe String
e <- String -> IO (Maybe String)
lookupEnv String
name
  case Maybe String
e of
    Just String
v ->
      if String -> Bool
truthy String
v
      then Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
      else Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Bool -> IO (Maybe Bool)) -> Maybe Bool -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    Maybe String
Nothing -> Maybe Bool -> IO (Maybe Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing

truthy :: String -> Bool
truthy :: String -> Bool
truthy String
s = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"1", String
"y", String
"on", String
"true", String
"yes"]

getFormat :: IO (Maybe OutputFormat)
getFormat :: IO (Maybe OutputFormat)
getFormat = do
  Maybe String
fmt <- String -> IO (Maybe String)
lookupEnv String
"HADOLINT_FORMAT"
  Maybe OutputFormat -> IO (Maybe OutputFormat)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe OutputFormat -> IO (Maybe OutputFormat))
-> Maybe OutputFormat -> IO (Maybe OutputFormat)
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe OutputFormat
readMaybeOutputFormat (Text -> Maybe OutputFormat)
-> (String -> Text) -> String -> Maybe OutputFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) (String -> Maybe OutputFormat)
-> Maybe String -> Maybe OutputFormat
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
fmt

getOverrideList :: String -> IO [RuleCode]
getOverrideList :: String -> IO [RuleCode]
getOverrideList String
env = do
  Maybe String
maybeString <- String -> IO (Maybe String)
lookupEnv String
env
  case Maybe String
maybeString of
    Just String
s -> [RuleCode] -> IO [RuleCode]
forall (m :: * -> *) a. Monad m => a -> m a
return ([RuleCode] -> IO [RuleCode]) -> [RuleCode] -> IO [RuleCode]
forall a b. (a -> b) -> a -> b
$ Text -> [RuleCode]
getRulecodes (String -> Text
pack String
s)
    Maybe String
Nothing -> [RuleCode] -> IO [RuleCode]
forall (m :: * -> *) a. Monad m => a -> m a
return []

getRulecodes :: Text -> [RuleCode]
getRulecodes :: Text -> [RuleCode]
getRulecodes Text
s = do
  Text
list <- Text -> Text -> [Text]
splitOn Text
"," Text
s
  let rules :: RuleCode
rules = Text -> RuleCode
coerce (Text
list :: Text)
  RuleCode -> [RuleCode]
forall (m :: * -> *) a. Monad m => a -> m a
return RuleCode
rules

getAllowedSet :: String -> IO (Set Registry)
getAllowedSet :: String -> IO (Set Registry)
getAllowedSet String
env = do
  Maybe String
maybeString <- String -> IO (Maybe String)
lookupEnv String
env
  case Maybe String
maybeString of
    Just String
s -> Set Registry -> IO (Set Registry)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set Registry -> IO (Set Registry))
-> Set Registry -> IO (Set Registry)
forall a b. (a -> b) -> a -> b
$ [Registry] -> Set Registry
forall a. Ord a => [a] -> Set a
Data.Set.fromList (Text -> [Registry]
getAllowed (String -> Text
pack String
s))
    Maybe String
Nothing -> Set Registry -> IO (Set Registry)
forall (m :: * -> *) a. Monad m => a -> m a
return Set Registry
forall a. Set a
Data.Set.empty

getAllowed :: Text -> [Registry]
getAllowed :: Text -> [Registry]
getAllowed Text
s = do
  Text
list <- Text -> Text -> [Text]
splitOn Text
"," Text
s
  let regs :: Registry
regs = Text -> Registry
coerce (Text
list :: Text)
  Registry -> [Registry]
forall (m :: * -> *) a. Monad m => a -> m a
return Registry
regs

getLabelSchema :: String -> IO LabelSchema
getLabelSchema :: String -> IO LabelSchema
getLabelSchema String
env = do
  Maybe String
maybeString <- String -> IO (Maybe String)
lookupEnv String
env
  case Maybe String
maybeString of
    Just String
s -> LabelSchema -> IO LabelSchema
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelSchema -> IO LabelSchema) -> LabelSchema -> IO LabelSchema
forall a b. (a -> b) -> a -> b
$ [(Text, LabelType)] -> LabelSchema
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList (Text -> [(Text, LabelType)]
labelSchemaFromText (String -> Text
pack String
s))
    Maybe String
Nothing -> LabelSchema -> IO LabelSchema
forall (m :: * -> *) a. Monad m => a -> m a
return LabelSchema
forall k a. Map k a
Data.Map.empty

labelSchemaFromText :: Text -> [(LabelName, LabelType)]
labelSchemaFromText :: Text -> [(Text, LabelType)]
labelSchemaFromText Text
txt =
  [ (Text
ln, LabelType
lt) | Right (Text
ln, LabelType
lt) <- ((Text, Text) -> Either String (Text, LabelType))
-> [(Text, Text)] -> [Either String (Text, LabelType)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Either String (Text, LabelType)
convertToLabelSchema (Text -> [(Text, Text)]
convertToPairs Text
txt) ]

convertToPairs :: Text -> [(Text, Text)]
convertToPairs :: Text -> [(Text, Text)]
convertToPairs Text
txt = (Text -> (Text, Text)) -> [Text] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> (Text, Text)
breakOn Text
":") (Text -> Text -> [Text]
splitOn Text
"," Text
txt)

convertToLabelSchema :: (Text, Text) -> Either String (LabelName, LabelType)
convertToLabelSchema :: (Text, Text) -> Either String (Text, LabelType)
convertToLabelSchema (Text
tln, Text
tlt) =
  case (Text -> Either Text LabelType
readEitherLabelType (Text -> Either Text LabelType)
-> (Text -> Text) -> Text -> Either Text LabelType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Data.Text.drop Int
1) Text
tlt of
    Right LabelType
lt -> (Text, LabelType) -> Either String (Text, LabelType)
forall a b. b -> Either a b
Right (Text -> Text
coerce Text
tln :: Text, LabelType
lt)
    Left Text
e -> String -> Either String (Text, LabelType)
forall a b. a -> Either a b
Left (Text -> String
unpack Text
e)

getFailureThreshold :: IO (Maybe DLSeverity)
getFailureThreshold :: IO (Maybe DLSeverity)
getFailureThreshold = do
  Maybe String
ft <- String -> IO (Maybe String)
lookupEnv String
"HADOLINT_FAILURE_THRESHOLD"
  Maybe DLSeverity -> IO (Maybe DLSeverity)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe DLSeverity -> IO (Maybe DLSeverity))
-> Maybe DLSeverity -> IO (Maybe DLSeverity)
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe DLSeverity
readMaybeSeverity (Text -> Maybe DLSeverity)
-> (String -> Text) -> String -> Maybe DLSeverity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) (String -> Maybe DLSeverity) -> Maybe String -> Maybe DLSeverity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
ft