module Hadolint.Rule.DL3026 (rule) where

import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import Data.String ( IsString(..) )
import Data.Text (Text, pack, unpack, drop, dropEnd, isSuffixOf, isPrefixOf)
import Hadolint.Rule
import Language.Docker.Syntax

rule :: Set.Set Registry -> Rule args
rule :: forall args. Set Registry -> Rule args
rule Set Registry
allowed = (Linenumber
 -> State (Set (Maybe ImageAlias))
 -> Instruction args
 -> State (Set (Maybe ImageAlias)))
-> State (Set (Maybe ImageAlias)) -> Rule args
forall a args.
(Linenumber -> State a -> Instruction args -> State a)
-> State a -> Rule args
customRule Linenumber
-> State (Set (Maybe ImageAlias))
-> Instruction args
-> State (Set (Maybe ImageAlias))
forall {args}.
Linenumber
-> State (Set (Maybe ImageAlias))
-> Instruction args
-> State (Set (Maybe ImageAlias))
check (Set (Maybe ImageAlias) -> State (Set (Maybe ImageAlias))
forall a. a -> State a
emptyState Set (Maybe ImageAlias)
forall a. Set a
Set.empty)
  where
    code :: RuleCode
code = RuleCode
"DL3026"
    severity :: DLSeverity
severity = DLSeverity
DLErrorC
    message :: Text
message = Text
"Use only an allowed registry in the FROM image"

    check :: Linenumber
-> State (Set (Maybe ImageAlias))
-> Instruction args
-> State (Set (Maybe ImageAlias))
check Linenumber
line State (Set (Maybe ImageAlias))
st (From BaseImage {Image
image :: Image
image :: BaseImage -> Image
image, Maybe ImageAlias
alias :: Maybe ImageAlias
alias :: BaseImage -> Maybe ImageAlias
alias}) =
      let newState :: State (Set (Maybe ImageAlias))
newState = State (Set (Maybe ImageAlias))
st State (Set (Maybe ImageAlias))
-> (State (Set (Maybe ImageAlias))
    -> State (Set (Maybe ImageAlias)))
-> State (Set (Maybe ImageAlias))
forall a b. a -> (a -> b) -> b
|> (Set (Maybe ImageAlias) -> Set (Maybe ImageAlias))
-> State (Set (Maybe ImageAlias)) -> State (Set (Maybe ImageAlias))
forall a. (a -> a) -> State a -> State a
modify (Maybe ImageAlias
-> Set (Maybe ImageAlias) -> Set (Maybe ImageAlias)
forall a. Ord a => a -> Set a -> Set a
Set.insert Maybe ImageAlias
alias)
       in if Set (Maybe ImageAlias) -> Image -> Bool
doCheck (State (Set (Maybe ImageAlias)) -> Set (Maybe ImageAlias)
forall a. State a -> a
state State (Set (Maybe ImageAlias))
st) Image
image
            then State (Set (Maybe ImageAlias))
newState
            else State (Set (Maybe ImageAlias))
newState State (Set (Maybe ImageAlias))
-> (State (Set (Maybe ImageAlias))
    -> State (Set (Maybe ImageAlias)))
-> State (Set (Maybe ImageAlias))
forall a b. a -> (a -> b) -> b
|> CheckFailure
-> State (Set (Maybe ImageAlias)) -> State (Set (Maybe ImageAlias))
forall a. CheckFailure -> State a -> State a
addFail CheckFailure {Linenumber
Text
RuleCode
DLSeverity
code :: RuleCode
severity :: DLSeverity
message :: Text
line :: Linenumber
line :: Linenumber
message :: Text
severity :: DLSeverity
code :: RuleCode
..}
    check Linenumber
line State (Set (Maybe ImageAlias))
st (Copy CopyArgs
_ (CopyFlags Chown
_ Chmod
_ Link
_ Parents
_ (CopySource Text
src) [Exclude]
_)) =
      let img :: Image
img = String -> Image
forall a. IsString a => String -> a
fromString ( Text -> String
Data.Text.unpack Text
src )
       in if Set (Maybe ImageAlias) -> Image -> Bool
doCheck (State (Set (Maybe ImageAlias)) -> Set (Maybe ImageAlias)
forall a. State a -> a
state State (Set (Maybe ImageAlias))
st) Image
img
            then State (Set (Maybe ImageAlias))
st
            else State (Set (Maybe ImageAlias))
st State (Set (Maybe ImageAlias))
-> (State (Set (Maybe ImageAlias))
    -> State (Set (Maybe ImageAlias)))
-> State (Set (Maybe ImageAlias))
forall a b. a -> (a -> b) -> b
|> CheckFailure
-> State (Set (Maybe ImageAlias)) -> State (Set (Maybe ImageAlias))
forall a. CheckFailure -> State a -> State a
addFail CheckFailure {Linenumber
Text
RuleCode
DLSeverity
code :: RuleCode
severity :: DLSeverity
message :: Text
line :: Linenumber
message :: Text
severity :: DLSeverity
code :: RuleCode
line :: Linenumber
..}
    check Linenumber
line State (Set (Maybe ImageAlias))
st (Run (RunArgs Arguments args
_ (RunFlags Set RunMount
m Maybe RunSecurity
_ Maybe RunNetwork
_))) =
       if Set RunMount -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set RunMount -> Bool) -> Set RunMount -> Bool
forall a b. (a -> b) -> a -> b
$ (RunMount -> Bool) -> Set RunMount -> Set RunMount
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (RunMount -> Bool) -> RunMount -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State (Set (Maybe ImageAlias)) -> RunMount -> Bool
checkMount State (Set (Maybe ImageAlias))
st) Set RunMount
m
         then State (Set (Maybe ImageAlias))
st
         else State (Set (Maybe ImageAlias))
st State (Set (Maybe ImageAlias))
-> (State (Set (Maybe ImageAlias))
    -> State (Set (Maybe ImageAlias)))
-> State (Set (Maybe ImageAlias))
forall a b. a -> (a -> b) -> b
|> CheckFailure
-> State (Set (Maybe ImageAlias)) -> State (Set (Maybe ImageAlias))
forall a. CheckFailure -> State a -> State a
addFail CheckFailure {Linenumber
Text
RuleCode
DLSeverity
code :: RuleCode
severity :: DLSeverity
message :: Text
line :: Linenumber
message :: Text
severity :: DLSeverity
code :: RuleCode
line :: Linenumber
..}
    check Linenumber
_ State (Set (Maybe ImageAlias))
st Instruction args
_ = State (Set (Maybe ImageAlias))
st

    checkMount :: State (Set (Maybe ImageAlias)) -> RunMount -> Bool
checkMount State (Set (Maybe ImageAlias))
st (CacheMount (CacheOpts TargetPath
_ Maybe CacheSharing
_ Maybe Text
_ Maybe Bool
_ Maybe Text
fi Maybe SourcePath
_ Maybe Text
_ Maybe Text
_ Maybe Text
_)) =
      let img :: Image
img = String -> Image
forall a. IsString a => String -> a
fromString (String -> Image) -> String -> Image
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Maybe.fromMaybe Text
"scratch" Maybe Text
fi
       in Set (Maybe ImageAlias) -> Image -> Bool
doCheck (State (Set (Maybe ImageAlias)) -> Set (Maybe ImageAlias)
forall a. State a -> a
state State (Set (Maybe ImageAlias))
st) Image
img
    checkMount State (Set (Maybe ImageAlias))
st (BindMount (BindOpts TargetPath
_ Maybe SourcePath
_ Maybe Text
fi Maybe Bool
_ Maybe Relabel
_)) =
      let img :: Image
img = String -> Image
forall a. IsString a => String -> a
fromString (String -> Image) -> String -> Image
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Maybe.fromMaybe Text
"scratch" Maybe Text
fi
       in Set (Maybe ImageAlias) -> Image -> Bool
doCheck (State (Set (Maybe ImageAlias)) -> Set (Maybe ImageAlias)
forall a. State a -> a
state State (Set (Maybe ImageAlias))
st) Image
img
    checkMount State (Set (Maybe ImageAlias))
_ RunMount
_ = Bool
True

    doCheck :: Set (Maybe ImageAlias) -> Image -> Bool
doCheck Set (Maybe ImageAlias)
st Image
img = Maybe ImageAlias -> Set (Maybe ImageAlias) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Image -> Maybe ImageAlias
toImageAlias Image
img) Set (Maybe ImageAlias)
st Bool -> Bool -> Bool
|| Set Registry -> Bool
forall a. Set a -> Bool
Set.null Set Registry
allowed Bool -> Bool -> Bool
|| Image -> Bool
isAllowed Image
img

    toImageAlias :: Image -> Maybe ImageAlias
toImageAlias = ImageAlias -> Maybe ImageAlias
forall a. a -> Maybe a
Just (ImageAlias -> Maybe ImageAlias)
-> (Image -> ImageAlias) -> Image -> Maybe ImageAlias
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ImageAlias
ImageAlias (Text -> ImageAlias) -> (Image -> Text) -> Image -> ImageAlias
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Image -> Text
imageName
    isAllowed :: Image -> Bool
isAllowed Image {registryName :: Image -> Maybe Registry
registryName = Just Registry
registry} = Text -> Bool
isRegistryAllowed (Registry -> Text
unRegistry Registry
registry)
    isAllowed Image {registryName :: Image -> Maybe Registry
registryName = Maybe Registry
Nothing, Text
imageName :: Image -> Text
imageName :: Text
imageName} =
      Text
imageName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"scratch"
        Bool -> Bool -> Bool
|| Text -> Bool
isRegistryAllowed Text
"docker.io"
        Bool -> Bool -> Bool
|| Text -> Bool
isRegistryAllowed Text
"hub.docker.com"

    isRegistryAllowed :: Text -> Bool
isRegistryAllowed Text
registry = (Registry -> Bool) -> Set Registry -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Registry
p -> Text -> Text -> Bool
matchRegistry (Registry -> Text
unRegistry Registry
p) Text
registry) Set Registry
allowed
{-# INLINEABLE rule #-}

matchRegistry :: Text -> Text -> Bool
matchRegistry :: Text -> Text -> Bool
matchRegistry Text
allow Text
registry
  | Text
allow Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
star = Bool
True
  | Text
star Text -> Text -> Bool
`isPrefixOf` Text
allow = Linenumber -> Text -> Text
Data.Text.drop Linenumber
1 Text
allow Text -> Text -> Bool
`isSuffixOf` Text
registry
  | Text
star Text -> Text -> Bool
`isSuffixOf` Text
allow = Linenumber -> Text -> Text
Data.Text.dropEnd Linenumber
1 Text
allow Text -> Text -> Bool
`isPrefixOf` Text
registry
  | Bool
otherwise = Text
registry Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
allow
  where
      star :: Text
star = String -> Text
pack String
"*"