{-# LANGUAGE ExplicitForAll      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}


module Docker.Client.Utils where

import qualified Codec.Archive.Tar           as Tar
import qualified Codec.Compression.GZip      as GZip
import           Control.Monad               (filterM, liftM, unless)
import           Control.Monad.IO.Class
import qualified Data.ByteString.Lazy        as BS
import           Data.Monoid                 ((<>))
import qualified Data.Text                   as T
import qualified Data.Text.IO                as TIO
import qualified Data.UUID                   as UUID
import qualified Data.UUID.V4                as UUID
import           System.Directory            (doesDirectoryExist, doesFileExist,
                                              getTemporaryDirectory)
import           System.FilePath             (isAbsolute, makeRelative, (</>))
import           System.FilePath.Find        (FilterPredicate,
                                              RecursionPredicate, always,
                                              fileName, find, (==?))
import           System.FilePath.GlobPattern ((~~))
import           System.IO.Error             (tryIOError)
-- import           System.IO.Temp              (withSystemTempDirectory)
--
import           Docker.Client.Http

type File = FilePath
data DirTree = DirTree [File] [DirTree]


newtype ExclusionPattern = ExclusionPattern T.Text deriving (ExclusionPattern -> ExclusionPattern -> Bool
(ExclusionPattern -> ExclusionPattern -> Bool)
-> (ExclusionPattern -> ExclusionPattern -> Bool)
-> Eq ExclusionPattern
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExclusionPattern -> ExclusionPattern -> Bool
$c/= :: ExclusionPattern -> ExclusionPattern -> Bool
== :: ExclusionPattern -> ExclusionPattern -> Bool
$c== :: ExclusionPattern -> ExclusionPattern -> Bool
Eq, Int -> ExclusionPattern -> ShowS
[ExclusionPattern] -> ShowS
ExclusionPattern -> String
(Int -> ExclusionPattern -> ShowS)
-> (ExclusionPattern -> String)
-> ([ExclusionPattern] -> ShowS)
-> Show ExclusionPattern
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExclusionPattern] -> ShowS
$cshowList :: [ExclusionPattern] -> ShowS
show :: ExclusionPattern -> String
$cshow :: ExclusionPattern -> String
showsPrec :: Int -> ExclusionPattern -> ShowS
$cshowsPrec :: Int -> ExclusionPattern -> ShowS
Show)
newtype InclusionPattern = InclusionPattern T.Text deriving (InclusionPattern -> InclusionPattern -> Bool
(InclusionPattern -> InclusionPattern -> Bool)
-> (InclusionPattern -> InclusionPattern -> Bool)
-> Eq InclusionPattern
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InclusionPattern -> InclusionPattern -> Bool
$c/= :: InclusionPattern -> InclusionPattern -> Bool
== :: InclusionPattern -> InclusionPattern -> Bool
$c== :: InclusionPattern -> InclusionPattern -> Bool
Eq, Int -> InclusionPattern -> ShowS
[InclusionPattern] -> ShowS
InclusionPattern -> String
(Int -> InclusionPattern -> ShowS)
-> (InclusionPattern -> String)
-> ([InclusionPattern] -> ShowS)
-> Show InclusionPattern
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InclusionPattern] -> ShowS
$cshowList :: [InclusionPattern] -> ShowS
show :: InclusionPattern -> String
$cshow :: InclusionPattern -> String
showsPrec :: Int -> InclusionPattern -> ShowS
$cshowsPrec :: Int -> InclusionPattern -> ShowS
Show)

data DockerIgnore = DockerIgnore { DockerIgnore -> [ExclusionPattern]
exclusionPatterns :: [ExclusionPattern]
                                 , DockerIgnore -> [InclusionPattern]
inclusionPatterns :: [InclusionPattern]
                                 } deriving (DockerIgnore -> DockerIgnore -> Bool
(DockerIgnore -> DockerIgnore -> Bool)
-> (DockerIgnore -> DockerIgnore -> Bool) -> Eq DockerIgnore
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DockerIgnore -> DockerIgnore -> Bool
$c/= :: DockerIgnore -> DockerIgnore -> Bool
== :: DockerIgnore -> DockerIgnore -> Bool
$c== :: DockerIgnore -> DockerIgnore -> Bool
Eq, Int -> DockerIgnore -> ShowS
[DockerIgnore] -> ShowS
DockerIgnore -> String
(Int -> DockerIgnore -> ShowS)
-> (DockerIgnore -> String)
-> ([DockerIgnore] -> ShowS)
-> Show DockerIgnore
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DockerIgnore] -> ShowS
$cshowList :: [DockerIgnore] -> ShowS
show :: DockerIgnore -> String
$cshow :: DockerIgnore -> String
showsPrec :: Int -> DockerIgnore -> ShowS
$cshowsPrec :: Int -> DockerIgnore -> ShowS
Show)

newtype BuildContextRootDir = BuildContextRootDir FilePath deriving (BuildContextRootDir -> BuildContextRootDir -> Bool
(BuildContextRootDir -> BuildContextRootDir -> Bool)
-> (BuildContextRootDir -> BuildContextRootDir -> Bool)
-> Eq BuildContextRootDir
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildContextRootDir -> BuildContextRootDir -> Bool
$c/= :: BuildContextRootDir -> BuildContextRootDir -> Bool
== :: BuildContextRootDir -> BuildContextRootDir -> Bool
$c== :: BuildContextRootDir -> BuildContextRootDir -> Bool
Eq, Int -> BuildContextRootDir -> ShowS
[BuildContextRootDir] -> ShowS
BuildContextRootDir -> String
(Int -> BuildContextRootDir -> ShowS)
-> (BuildContextRootDir -> String)
-> ([BuildContextRootDir] -> ShowS)
-> Show BuildContextRootDir
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BuildContextRootDir] -> ShowS
$cshowList :: [BuildContextRootDir] -> ShowS
show :: BuildContextRootDir -> String
$cshow :: BuildContextRootDir -> String
showsPrec :: Int -> BuildContextRootDir -> ShowS
$cshowsPrec :: Int -> BuildContextRootDir -> ShowS
Show)

makeBuildContext :: forall m. MonadIO m => BuildContextRootDir -> m (Either DockerError FilePath)
makeBuildContext :: BuildContextRootDir -> m (Either DockerError String)
makeBuildContext BuildContextRootDir
base = IO (Either DockerError String) -> m (Either DockerError String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either DockerError String) -> m (Either DockerError String))
-> IO (Either DockerError String) -> m (Either DockerError String)
forall a b. (a -> b) -> a -> b
$ IO String -> IO (Either IOError String)
forall a. IO a -> IO (Either IOError a)
tryIOError (BuildContextRootDir -> IO String
forall (m :: * -> *). MonadIO m => BuildContextRootDir -> m String
makeBuildContext' BuildContextRootDir
base) IO (Either IOError String)
-> (Either IOError String -> IO (Either DockerError String))
-> IO (Either DockerError String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either IOError String
res -> case Either IOError String
res of
    Left IOError
e -> Either DockerError String -> IO (Either DockerError String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DockerError String -> IO (Either DockerError String))
-> Either DockerError String -> IO (Either DockerError String)
forall a b. (a -> b) -> a -> b
$ DockerError -> Either DockerError String
forall a b. a -> Either a b
Left (DockerError -> Either DockerError String)
-> DockerError -> Either DockerError String
forall a b. (a -> b) -> a -> b
$ Text -> DockerError
DockerClientError (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOError -> String
forall a. Show a => a -> String
show IOError
e)
    Right String
c -> Either DockerError String -> IO (Either DockerError String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either DockerError String -> IO (Either DockerError String))
-> Either DockerError String -> IO (Either DockerError String)
forall a b. (a -> b) -> a -> b
$ String -> Either DockerError String
forall a b. b -> Either a b
Right String
c

makeBuildContext' :: forall m. MonadIO m => BuildContextRootDir -> m FilePath
makeBuildContext' :: BuildContextRootDir -> m String
makeBuildContext' (BuildContextRootDir String
base) = do
    UUID
uuid <- IO UUID -> m UUID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUID.nextRandom
    [String]
fs <- IO [String] -> m [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> m [String]) -> IO [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ BuildContextRootDir -> IO [String]
getBuildContext (BuildContextRootDir -> IO [String])
-> BuildContextRootDir -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> BuildContextRootDir
BuildContextRootDir String
base
    let relFs :: [String]
relFs = ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
makeRelative String
base) [String]
fs
    String
tmpDir <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getTemporaryDirectory
    let tmpF :: String
tmpF = String
tmpDir String -> ShowS
</> String
"docker.context-" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UUID -> String
UUID.toString UUID
uuid  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".tar.gz"
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
tmpF (ByteString -> IO ())
-> ([Entry] -> ByteString) -> [Entry] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
GZip.compress (ByteString -> ByteString)
-> ([Entry] -> ByteString) -> [Entry] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entry] -> ByteString
Tar.write ([Entry] -> IO ()) -> IO [Entry] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> [String] -> IO [Entry]
Tar.pack String
base [String]
relFs
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
tmpF

parseDockerIgnoreFile :: T.Text -> DockerIgnore
parseDockerIgnoreFile :: Text -> DockerIgnore
parseDockerIgnoreFile Text
c = DockerIgnore :: [ExclusionPattern] -> [InclusionPattern] -> DockerIgnore
DockerIgnore{ exclusionPatterns :: [ExclusionPattern]
exclusionPatterns=[ExclusionPattern]
parseExclusions
                                      , inclusionPatterns :: [InclusionPattern]
inclusionPatterns=[InclusionPattern]
parseInclusions}
    where lines :: [Text]
lines = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Bool
T.isPrefixOf Text
"#") (Text -> [Text]
T.lines Text
c) -- Ignore comments
          parseExclusions :: [ExclusionPattern]
parseExclusions = (Text -> ExclusionPattern) -> [Text] -> [ExclusionPattern]
forall a b. (a -> b) -> [a] -> [b]
map Text -> ExclusionPattern
ExclusionPattern ([Text] -> [ExclusionPattern]) -> [Text] -> [ExclusionPattern]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
l -> Bool -> Bool
not (Text -> Text -> Bool
T.isPrefixOf Text
"!" Text
l) Bool -> Bool -> Bool
&& (Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"")) [Text]
lines
          parseInclusions :: [InclusionPattern]
parseInclusions = (Text -> InclusionPattern) -> [Text] -> [InclusionPattern]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> InclusionPattern
InclusionPattern (Text -> InclusionPattern)
-> (Text -> Text) -> Text -> InclusionPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
1) ([Text] -> [InclusionPattern]) -> [Text] -> [InclusionPattern]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
l -> Text -> Text -> Bool
T.isPrefixOf Text
"!" Text
l Bool -> Bool -> Bool
&& (Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"")) [Text]
lines

getBuildContext :: BuildContextRootDir -> IO [FilePath]
getBuildContext :: BuildContextRootDir -> IO [String]
getBuildContext (BuildContextRootDir String
base) = do
    -- The base dir needs to be a path to a directory and not a path to
    -- a file
    Bool
exists <- String -> IO Bool
doesDirectoryExist String
base
    let abs :: Bool
abs = String -> Bool
isAbsolute String
base
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
exists Bool -> Bool -> Bool
&& Bool
abs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Path to context needs to be a directory that: exists, is readable, and is an absolute path."
    [String]
di <- RecursionPredicate -> RecursionPredicate -> String -> IO [String]
find RecursionPredicate
always (FindClause String
fileName FindClause String -> String -> RecursionPredicate
forall a. Eq a => FindClause a -> a -> RecursionPredicate
==? String
".dockerignore") String
base
    DockerIgnore
dockerignore <- case [String]
di of
        [] -> DockerIgnore -> IO DockerIgnore
forall (m :: * -> *) a. Monad m => a -> m a
return (DockerIgnore -> IO DockerIgnore)
-> DockerIgnore -> IO DockerIgnore
forall a b. (a -> b) -> a -> b
$ [ExclusionPattern] -> [InclusionPattern] -> DockerIgnore
DockerIgnore [] []
        -- This should not return more than one result though
        (String
x:[String]
_) -> do
            Text
c <- String -> IO Text
TIO.readFile String
x
            DockerIgnore -> IO DockerIgnore
forall (m :: * -> *) a. Monad m => a -> m a
return (DockerIgnore -> IO DockerIgnore)
-> DockerIgnore -> IO DockerIgnore
forall a b. (a -> b) -> a -> b
$ Text -> DockerIgnore
parseDockerIgnoreFile Text
c
    -- This will traverse the directory recursively
    [String]
fs <- RecursionPredicate -> RecursionPredicate -> String -> IO [String]
find (DockerIgnore -> RecursionPredicate
shouldRecurse DockerIgnore
dockerignore) (DockerIgnore -> RecursionPredicate
shouldInclude DockerIgnore
dockerignore) String
base
    -- fs is a list of directories *and* files in those directories. So
    -- an example result would look like ["/tmp/project/files",
    -- "/tmp/project/files/file1.txt"] and we want just the individual
    -- files otherwise tar duplicates them when making the archive.
    [String]
fs' <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [String]
fs
    -- For some reason base is in there as well and we don't need that
    [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) String
base) [String]
fs'

shouldInclude :: DockerIgnore -> FilterPredicate
shouldInclude :: DockerIgnore -> RecursionPredicate
shouldInclude DockerIgnore
d = String -> Bool
check (String -> Bool) -> FindClause String -> RecursionPredicate
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` FindClause String
fileName
    where check :: String -> Bool
check String
f = (Bool, Bool) -> Bool
dockerIgnoreDecision (String -> [ExclusionPattern] -> Bool
exclusionCheck String
f (DockerIgnore -> [ExclusionPattern]
exclusionPatterns DockerIgnore
d), String -> [InclusionPattern] -> Bool
inclusionCheck String
f (DockerIgnore -> [InclusionPattern]
inclusionPatterns DockerIgnore
d))

shouldRecurse :: DockerIgnore -> RecursionPredicate
shouldRecurse :: DockerIgnore -> RecursionPredicate
shouldRecurse DockerIgnore
d = String -> Bool
check (String -> Bool) -> FindClause String -> RecursionPredicate
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` FindClause String
fileName
    where check :: String -> Bool
check String
f = (Bool, Bool) -> Bool
dockerIgnoreDecision (String -> [ExclusionPattern] -> Bool
exclusionCheck String
f (DockerIgnore -> [ExclusionPattern]
exclusionPatterns DockerIgnore
d), String -> [InclusionPattern] -> Bool
inclusionCheck String
f (DockerIgnore -> [InclusionPattern]
inclusionPatterns DockerIgnore
d))

-- TODO: We don't handle precedence rules. For instance a dockerignore file
-- like this:
--
-- *.md
-- !README*.md
-- README-secret.md
--
-- Should result in no markdown files being included in the context except README files other
-- than README-secret.md. FIXME: OUR implementation would in fact include
-- README-secret.md as well!!!
--
-- Whereas this:
--
-- *.md
-- README-secret.md
-- !README*.md
--
-- Should result in all of the README files being included. The middle line has no effect
-- because !README*.md matches README-secret.md and comes last. Our
-- implementation will result in the same thing.
dockerIgnoreDecision :: (Bool, Bool) -> Bool
dockerIgnoreDecision :: (Bool, Bool) -> Bool
dockerIgnoreDecision (Bool, Bool)
p = case (Bool, Bool)
p of
         -- If it's in any of the exclusion patterns but also
         -- in any of the inclusion patterns then laeave it
         (Bool
True, Bool
True)   -> Bool
True
         (Bool
True, Bool
False)  -> Bool
False
         (Bool
False, Bool
True)  -> Bool
True
         (Bool
False, Bool
False) -> Bool
True

exclusionCheck :: FilePath -> [ExclusionPattern] -> Bool
exclusionCheck :: String -> [ExclusionPattern] -> Bool
exclusionCheck String
f [ExclusionPattern]
ps = (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Bool -> Bool
forall a. a -> a
id ((ExclusionPattern -> Bool) -> [ExclusionPattern] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\(ExclusionPattern Text
p) -> String
f String -> String -> Bool
~~ Text -> String
T.unpack Text
p) [ExclusionPattern]
ps)

inclusionCheck :: FilePath -> [InclusionPattern] -> Bool
inclusionCheck :: String -> [InclusionPattern] -> Bool
inclusionCheck String
f [InclusionPattern]
ps = (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Bool -> Bool
forall a. a -> a
id ((InclusionPattern -> Bool) -> [InclusionPattern] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (\(InclusionPattern Text
p) -> String
f String -> String -> Bool
~~ Text -> String
T.unpack Text
p) [InclusionPattern]
ps)