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
<$> [Char] -> IO (Maybe Bool)
maybeTruthy [Char]
"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 a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO (Maybe Bool)
isSet [Char]
"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 a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO (Maybe Bool)
maybeTruthy [Char]
"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 a b. IO (a -> b) -> IO a -> IO b
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 a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO [RuleCode]
getOverrideList [Char]
"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 a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO [RuleCode]
getOverrideList [Char]
"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 a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO [RuleCode]
getOverrideList [Char]
"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 a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO [RuleCode]
getOverrideList [Char]
"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 a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO [RuleCode]
getOverrideList [Char]
"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 a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO (Set Registry)
getAllowedSet [Char]
"HADOLINT_TRUSTED_REGISTRIES"
    IO
  (LabelSchema
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe DLSeverity
   -> PartialConfiguration)
-> IO LabelSchema
-> IO
     (Maybe Bool
      -> Maybe Bool -> Maybe DLSeverity -> PartialConfiguration)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO LabelSchema
getLabelSchema [Char]
"HADOLINT_REQUIRE_LABELS"
    IO
  (Maybe Bool
   -> Maybe Bool -> Maybe DLSeverity -> PartialConfiguration)
-> IO (Maybe Bool)
-> IO (Maybe Bool -> Maybe DLSeverity -> PartialConfiguration)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO (Maybe Bool)
maybeTruthy [Char]
"HADOLINT_STRICT_LABELS"
    IO (Maybe Bool -> Maybe DLSeverity -> PartialConfiguration)
-> IO (Maybe Bool) -> IO (Maybe DLSeverity -> PartialConfiguration)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Char] -> IO (Maybe Bool)
maybeTruthy [Char]
"HADOLINT_DISABLE_IGNORE_PRAGMA"
    IO (Maybe DLSeverity -> PartialConfiguration)
-> IO (Maybe DLSeverity) -> IO PartialConfiguration
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (Maybe DLSeverity)
getFailureThreshold


isSet :: String -> IO (Maybe Bool)
isSet :: [Char] -> IO (Maybe Bool)
isSet [Char]
name = do
  e <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
name
  case e of
    Just [Char]
_ -> Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
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 [Char]
Nothing -> Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing

maybeTruthy :: String -> IO (Maybe Bool)
maybeTruthy :: [Char] -> IO (Maybe Bool)
maybeTruthy [Char]
name = do
  e <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
name
  case e of
    Just [Char]
v ->
      if [Char] -> Bool
truthy [Char]
v
      then Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
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 a. a -> IO a
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 [Char]
Nothing -> Maybe Bool -> IO (Maybe Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing

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

getFormat :: IO (Maybe OutputFormat)
getFormat :: IO (Maybe OutputFormat)
getFormat = do
  fmt <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"HADOLINT_FORMAT"
  return $ (readMaybeOutputFormat . pack) =<< fmt

getOverrideList :: String -> IO [RuleCode]
getOverrideList :: [Char] -> IO [RuleCode]
getOverrideList [Char]
env = do
  maybeString <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
env
  case maybeString of
    Just [Char]
s -> [RuleCode] -> IO [RuleCode]
forall a. a -> IO a
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 ([Char] -> Text
pack [Char]
s)
    Maybe [Char]
Nothing -> [RuleCode] -> IO [RuleCode]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

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

getAllowedSet :: String -> IO (Set Registry)
getAllowedSet :: [Char] -> IO (Set Registry)
getAllowedSet [Char]
env = do
  maybeString <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
env
  case maybeString of
    Just [Char]
s -> Set Registry -> IO (Set Registry)
forall a. a -> IO a
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 ([Char] -> Text
pack [Char]
s))
    Maybe [Char]
Nothing -> Set Registry -> IO (Set Registry)
forall a. a -> IO a
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
  list <- HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn Text
"," Text
s
  let regs = Text -> Registry
forall a b. Coercible a b => a -> b
coerce (Text
list :: Text)
  return regs

getLabelSchema :: String -> IO LabelSchema
getLabelSchema :: [Char] -> IO LabelSchema
getLabelSchema [Char]
env = do
  maybeString <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
env
  case maybeString of
    Just [Char]
s -> LabelSchema -> IO LabelSchema
forall a. a -> IO a
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 ([Char] -> Text
pack [Char]
s))
    Maybe [Char]
Nothing -> LabelSchema -> IO LabelSchema
forall a. a -> IO a
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 [Char] (Text, LabelType))
-> [(Text, Text)] -> [Either [Char] (Text, LabelType)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> Either [Char] (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 (HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
breakOn Text
":") (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
splitOn Text
"," Text
txt)

convertToLabelSchema :: (Text, Text) -> Either String (LabelName, LabelType)
convertToLabelSchema :: (Text, Text) -> Either [Char] (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 [Char] (Text, LabelType)
forall a b. b -> Either a b
Right (Text -> Text
forall a b. Coercible a b => a -> b
coerce Text
tln :: Text, LabelType
lt)
    Left Text
e -> [Char] -> Either [Char] (Text, LabelType)
forall a b. a -> Either a b
Left (Text -> [Char]
unpack Text
e)

getFailureThreshold :: IO (Maybe DLSeverity)
getFailureThreshold :: IO (Maybe DLSeverity)
getFailureThreshold = do
  ft <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"HADOLINT_FAILURE_THRESHOLD"
  return $ (readMaybeSeverity . pack) =<< ft