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 Docker.Client.Http
type File = FilePath
data DirTree = DirTree [File] [DirTree]
newtype ExclusionPattern = ExclusionPattern T.Text deriving (Eq, Show)
newtype InclusionPattern = InclusionPattern T.Text deriving (Eq, Show)
data DockerIgnore = DockerIgnore { exclusionPatterns :: [ExclusionPattern]
, inclusionPatterns :: [InclusionPattern]
} deriving (Eq, Show)
newtype BuildContextRootDir = BuildContextRootDir FilePath deriving (Eq, Show)
makeBuildContext :: forall m. MonadIO m => BuildContextRootDir -> m (Either DockerError FilePath)
makeBuildContext base = liftIO $ tryIOError (makeBuildContext' base) >>= \res -> case res of
Left e -> return $ Left $ DockerClientError (T.pack $ show e)
Right c -> return $ Right c
makeBuildContext' :: forall m. MonadIO m => BuildContextRootDir -> m FilePath
makeBuildContext' (BuildContextRootDir base) = do
uuid <- liftIO UUID.nextRandom
fs <- liftIO $ getBuildContext $ BuildContextRootDir base
let relFs = map (makeRelative base) fs
tmpDir <- liftIO getTemporaryDirectory
let tmpF = tmpDir </> "docker.context-" <> UUID.toString uuid <> ".tar.gz"
liftIO $ BS.writeFile tmpF . GZip.compress . Tar.write =<< Tar.pack base relFs
return tmpF
parseDockerIgnoreFile :: T.Text -> DockerIgnore
parseDockerIgnoreFile c = DockerIgnore{ exclusionPatterns=parseExclusions
, inclusionPatterns=parseInclusions}
where lines = filter (not . T.isPrefixOf "#") (T.lines c)
parseExclusions = map ExclusionPattern $ filter (\l -> not (T.isPrefixOf "!" l) && (l /= "")) lines
parseInclusions = map (InclusionPattern . T.drop 1) $ filter (\l -> T.isPrefixOf "!" l && (l /= "")) lines
getBuildContext :: BuildContextRootDir -> IO [FilePath]
getBuildContext (BuildContextRootDir base) = do
exists <- doesDirectoryExist base
let abs = isAbsolute base
unless (exists && abs) $ fail "Path to context needs to be a directory that: exists, is readable, and is an absolute path."
di <- find always (fileName ==? ".dockerignore") base
dockerignore <- case di of
[] -> return $ DockerIgnore [] []
(x:_) -> do
c <- TIO.readFile x
return $ parseDockerIgnoreFile c
fs <- find (shouldRecurse dockerignore) (shouldInclude dockerignore) base
fs' <- filterM doesFileExist fs
return $ filter (not . (==) base) fs'
shouldInclude :: DockerIgnore -> FilterPredicate
shouldInclude d = check `liftM` fileName
where check f = dockerIgnoreDecision (exclusionCheck f (exclusionPatterns d), inclusionCheck f (inclusionPatterns d))
shouldRecurse :: DockerIgnore -> RecursionPredicate
shouldRecurse d = check `liftM` fileName
where check f = dockerIgnoreDecision (exclusionCheck f (exclusionPatterns d), inclusionCheck f (inclusionPatterns d))
dockerIgnoreDecision :: (Bool, Bool) -> Bool
dockerIgnoreDecision p = case p of
(True, True) -> True
(True, False) -> False
(False, True) -> True
(False, False) -> True
exclusionCheck :: FilePath -> [ExclusionPattern] -> Bool
exclusionCheck f ps = any id (map (\(ExclusionPattern p) -> f ~~ T.unpack p) ps)
inclusionCheck :: FilePath -> [InclusionPattern] -> Bool
inclusionCheck f ps = any id (map (\(InclusionPattern p) -> f ~~ T.unpack p) ps)