{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module Hadolint.Config (applyConfig, ConfigFile (..)) where

import Control.Monad (filterM)
import qualified Data.ByteString as Bytes
import Data.Coerce (coerce)
import Data.Maybe (fromMaybe, listToMaybe)
import qualified Data.Set as Set
import Data.YAML ((.:?))
import qualified Data.YAML as Yaml
import GHC.Generics (Generic)
import qualified Hadolint.Lint as Lint
import qualified Hadolint.Rules as Rules
import qualified Language.Docker as Docker
import System.Directory
  ( XdgDirectory (..),
    doesFileExist,
    getCurrentDirectory,
    getXdgDirectory,
  )
import System.FilePath ((</>))

data ConfigFile = ConfigFile
  { ConfigFile -> Maybe [IgnoreRule]
ignoredRules :: Maybe [Lint.IgnoreRule],
    ConfigFile -> Maybe [IgnoreRule]
trustedRegistries :: Maybe [Lint.TrustedRegistry]
  }
  deriving (Int -> ConfigFile -> ShowS
[ConfigFile] -> ShowS
ConfigFile -> String
(Int -> ConfigFile -> ShowS)
-> (ConfigFile -> String)
-> ([ConfigFile] -> ShowS)
-> Show ConfigFile
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConfigFile] -> ShowS
$cshowList :: [ConfigFile] -> ShowS
show :: ConfigFile -> String
$cshow :: ConfigFile -> String
showsPrec :: Int -> ConfigFile -> ShowS
$cshowsPrec :: Int -> ConfigFile -> ShowS
Show, ConfigFile -> ConfigFile -> Bool
(ConfigFile -> ConfigFile -> Bool)
-> (ConfigFile -> ConfigFile -> Bool) -> Eq ConfigFile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConfigFile -> ConfigFile -> Bool
$c/= :: ConfigFile -> ConfigFile -> Bool
== :: ConfigFile -> ConfigFile -> Bool
$c== :: ConfigFile -> ConfigFile -> Bool
Eq, (forall x. ConfigFile -> Rep ConfigFile x)
-> (forall x. Rep ConfigFile x -> ConfigFile) -> Generic ConfigFile
forall x. Rep ConfigFile x -> ConfigFile
forall x. ConfigFile -> Rep ConfigFile x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConfigFile x -> ConfigFile
$cfrom :: forall x. ConfigFile -> Rep ConfigFile x
Generic)

instance Yaml.FromYAML ConfigFile where
  parseYAML :: Node Pos -> Parser ConfigFile
parseYAML = String
-> (Mapping Pos -> Parser ConfigFile)
-> Node Pos
-> Parser ConfigFile
forall a.
String -> (Mapping Pos -> Parser a) -> Node Pos -> Parser a
Yaml.withMap "ConfigFile" ((Mapping Pos -> Parser ConfigFile)
 -> Node Pos -> Parser ConfigFile)
-> (Mapping Pos -> Parser ConfigFile)
-> Node Pos
-> Parser ConfigFile
forall a b. (a -> b) -> a -> b
$ \m :: Mapping Pos
m ->
    Maybe [IgnoreRule] -> Maybe [IgnoreRule] -> ConfigFile
ConfigFile
      (Maybe [IgnoreRule] -> Maybe [IgnoreRule] -> ConfigFile)
-> Parser (Maybe [IgnoreRule])
-> Parser (Maybe [IgnoreRule] -> ConfigFile)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mapping Pos
m Mapping Pos -> IgnoreRule -> Parser (Maybe [IgnoreRule])
forall a.
FromYAML a =>
Mapping Pos -> IgnoreRule -> Parser (Maybe a)
.:? "ignored"
      Parser (Maybe [IgnoreRule] -> ConfigFile)
-> Parser (Maybe [IgnoreRule]) -> Parser ConfigFile
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mapping Pos
m Mapping Pos -> IgnoreRule -> Parser (Maybe [IgnoreRule])
forall a.
FromYAML a =>
Mapping Pos -> IgnoreRule -> Parser (Maybe a)
.:? "trustedRegistries"

-- | If both the ignoreRules and rulesConfig properties of Lint options are empty
-- then this function will fill them with the default found in the passed config
-- file. If there is an error parsing the default config file, this function will
-- return the error string.
applyConfig :: Maybe FilePath -> Lint.LintOptions -> IO (Either String Lint.LintOptions)
applyConfig :: Maybe String -> LintOptions -> IO (Either String LintOptions)
applyConfig maybeConfig :: Maybe String
maybeConfig o :: LintOptions
o
  | Bool -> Bool
not ([IgnoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (LintOptions -> [IgnoreRule]
Lint.ignoreRules LintOptions
o)) Bool -> Bool -> Bool
&& LintOptions -> RulesConfig
Lint.rulesConfig LintOptions
o RulesConfig -> RulesConfig -> Bool
forall a. Eq a => a -> a -> Bool
/= RulesConfig
forall a. Monoid a => a
mempty = Either String LintOptions -> IO (Either String LintOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (LintOptions -> Either String LintOptions
forall a b. b -> Either a b
Right LintOptions
o)
  | Bool
otherwise = do
    Maybe String
theConfig <-
      case Maybe String
maybeConfig of
        Nothing -> IO (Maybe String)
findConfig
        c :: Maybe String
c -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
c
    case Maybe String
theConfig of
      Nothing -> Either String LintOptions -> IO (Either String LintOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (LintOptions -> Either String LintOptions
forall a b. b -> Either a b
Right LintOptions
o)
      Just config :: String
config -> String -> IO (Either String LintOptions)
parseAndApply String
config
  where
    findConfig :: IO (Maybe String)
findConfig = do
      String
localConfigFile <- (String -> ShowS
</> ".hadolint.yaml") ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getCurrentDirectory
      String
configFile <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig "hadolint.yaml"
      [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> IO [String] -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String
localConfigFile, String
configFile]

    parseAndApply :: FilePath -> IO (Either String Lint.LintOptions)
    parseAndApply :: String -> IO (Either String LintOptions)
parseAndApply configFile :: String
configFile = do
      ByteString
contents <- String -> IO ByteString
Bytes.readFile String
configFile
      case ByteString -> Either (Pos, String) ConfigFile
forall v. FromYAML v => ByteString -> Either (Pos, String) v
Yaml.decode1Strict ByteString
contents of
        Left (_, err :: String
err) -> Either String LintOptions -> IO (Either String LintOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String LintOptions -> IO (Either String LintOptions))
-> Either String LintOptions -> IO (Either String LintOptions)
forall a b. (a -> b) -> a -> b
$ String -> Either String LintOptions
forall a b. a -> Either a b
Left (String -> ShowS
formatError String
err String
configFile)
        Right (ConfigFile ignore :: Maybe [IgnoreRule]
ignore trusted :: Maybe [IgnoreRule]
trusted) -> Either String LintOptions -> IO (Either String LintOptions)
forall (m :: * -> *) a. Monad m => a -> m a
return (LintOptions -> Either String LintOptions
forall a b. b -> Either a b
Right (Maybe [IgnoreRule] -> Maybe [IgnoreRule] -> LintOptions
forall a.
Coercible a [Registry] =>
Maybe [IgnoreRule] -> Maybe a -> LintOptions
override Maybe [IgnoreRule]
ignore Maybe [IgnoreRule]
trusted))

    override :: Maybe [IgnoreRule] -> Maybe a -> LintOptions
override ignore :: Maybe [IgnoreRule]
ignore trusted :: Maybe a
trusted = Maybe a -> LintOptions -> LintOptions
forall a.
Coercible a [Registry] =>
Maybe a -> LintOptions -> LintOptions
applyTrusted Maybe a
trusted (LintOptions -> LintOptions)
-> (LintOptions -> LintOptions) -> LintOptions -> LintOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [IgnoreRule] -> LintOptions -> LintOptions
applyIgnore Maybe [IgnoreRule]
ignore (LintOptions -> LintOptions) -> LintOptions -> LintOptions
forall a b. (a -> b) -> a -> b
$ LintOptions
o
    applyIgnore :: Maybe [IgnoreRule] -> LintOptions -> LintOptions
applyIgnore ignore :: Maybe [IgnoreRule]
ignore opts :: LintOptions
opts =
      case LintOptions -> [IgnoreRule]
Lint.ignoreRules LintOptions
opts of
        [] -> LintOptions
opts {ignoreRules :: [IgnoreRule]
Lint.ignoreRules = [IgnoreRule] -> Maybe [IgnoreRule] -> [IgnoreRule]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [IgnoreRule]
ignore}
        _ -> LintOptions
opts

    applyTrusted :: Maybe a -> LintOptions -> LintOptions
applyTrusted trusted :: Maybe a
trusted opts :: LintOptions
opts
      | Set Registry -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RulesConfig -> Set Registry
Rules.allowedRegistries (LintOptions -> RulesConfig
Lint.rulesConfig LintOptions
opts)) =
        LintOptions
opts {rulesConfig :: RulesConfig
Lint.rulesConfig = Maybe a -> RulesConfig
forall a. Coercible a [Registry] => Maybe a -> RulesConfig
toRules Maybe a
trusted RulesConfig -> RulesConfig -> RulesConfig
forall a. Semigroup a => a -> a -> a
<> LintOptions -> RulesConfig
Lint.rulesConfig LintOptions
opts}
      | Bool
otherwise = LintOptions
opts

    toRules :: Maybe a -> RulesConfig
toRules (Just trusted :: a
trusted) = Set Registry -> RulesConfig
Rules.RulesConfig ([Registry] -> Set Registry
forall a. Ord a => [a] -> Set a
Set.fromList ([Registry] -> Set Registry)
-> (a -> [Registry]) -> a -> Set Registry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Registry]
forall a b. Coercible a b => a -> b
coerce (a -> Set Registry) -> a -> Set Registry
forall a b. (a -> b) -> a -> b
$ a
trusted)
    toRules _ = RulesConfig
forall a. Monoid a => a
mempty

    formatError :: String -> ShowS
formatError err :: String
err config :: String
config =
      [String] -> String
unlines
        [ "Error parsing your config file in  '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
config String -> ShowS
forall a. [a] -> [a] -> [a]
++ "':",
          "It should contain one of the keys 'ignored' or 'trustedRegistries'. For example:\n",
          "ignored:",
          "\t- DL3000",
          "\t- SC1099\n\n",
          "The key 'trustedRegistries' should contain the names of the allowed docker registries:\n",
          "allowedRegistries:",
          "\t- docker.io",
          "\t- my-company.com",
          "",
          String
err
        ]