content: {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE NamedFieldPuns #-}
  
  module Docker.Cacher.Inspect where
  
  import qualified Control.Foldl                 as Fold
  import qualified Data.Aeson                    as Aeson
  import           Data.Aeson                     ( (.:) )
  import qualified Data.Coerce
  import           Data.Either                    ( rights )
  import           Data.List.NonEmpty             ( toList )
  import           Data.Maybe                     ( fromMaybe
                                                  , isJust
                                                  , mapMaybe
                                                  )
  import qualified Data.Map                      as Map
  import qualified Data.Text                     as Text
  import           Data.Text                      ( Text )
  import qualified Data.Text.Encoding
  import           Language.Docker         hiding ( workdir )
  import           Language.Docker.Syntax         ( Tag(..) )
  import           Prelude                 hiding ( FilePath )
  import           Turtle
  
  import           Docker.Cacher.Internal
  
  -- | This represents the image config as stored on disk by the docker daemon. We only care here
  -- about the .Config.WorkingDir and .Config.OnBuild properties
  data ImageConfig = ImageConfig
      { workingDir :: !Text
      , onBuildInstructions :: ![Text]
      , storedLabels :: !(Map.Map Text Text)
      } deriving (Show, Eq)
  
  data StageCache
      = NotCached (Stage SourceImage) -- When the image has not yet been built separetely
      | FallbackCache (Stage SourceImage) -- When the cache was not present but we looked at a falback key
                      StageCache -- The fallback cache
      | Cached { stage :: Stage CachedImage -- When the image was built and tagged as a separate image
               , cacheBusters :: [(SourcePath, TargetPath)] -- List of files that are able to bust the cache
               }
      | CacheInvalidated (Stage SourceImage) (Stage CachedImage)
      deriving (Show)
  
  instance Aeson.FromJSON ImageConfig where
      parseJSON =
          Aeson.withObject "ImageConfig" $ \ic -> do
              workingDir <- ic .: "WorkingDir"
              onBuildInstructions <- fromMaybe [] <$> ic .: "OnBuild"
              storedLabels <- fromMaybe Map.empty <$> ic .: "Labels"
              return $ ImageConfig {..}
  
  
  -- | Calls docker inspect for the given image name and returns the config
  imageConfig :: ImageName a -> Shell ImageConfig
  imageConfig (ImageName name) = do
    printLn ("----> Inspecting the config for the docker image: " % s) name
    out <- fmap lineToText <$> fold fetchConfig Fold.list -- Buffer all the output in the out variable
  
    case decodeJSON out of
      Left decodeErr -> do
        error
          $  "----> Could not decode the response of docker inspect: "
          ++ decodeErr
        return (ImageConfig "" [] Map.empty)
  
      Right ic -> return ic
   where
    fetchConfig =
      inproc "docker" ["inspect", "--format", "{{.Config | json}}", name] empty
    decodeJSON =
      Aeson.eitherDecodeStrict . Data.Text.Encoding.encodeUtf8 . Text.unlines
  
  
  -- | Check whether or not the imageName exists for each of the passed stages
  --   and return only those that already exist.
  getAlreadyCached :: [Stage SourceImage] -> Shell (Stage SourceImage, StageCache)
  getAlreadyCached stages = do
    echo
      "--> I'm checking whether or not the stage exists as a docker image already"
  
    stage@Stage { buildImageName, stageFallbackImage } <- select stages -- foreach stages as stage
    exists <- cacheKeyExists stage buildImageName
  
    if exists
      then do
        echo
          "------> It already exists, so I will then check if the cache files changed"
        inspected <- inspectCache stage
        return (stage, inspected)
      else do
        echo "------> It does not exist, so I will need to build it myself later"
        maybe (return (stage, NotCached stage))
              (getFallbackCache stage)
              stageFallbackImage
   where
    cacheKeyExists stage (ImageName imageName) = do
      printLn ("----> Looking for image " % s) imageName
  
      existent <- fold
        (inproc "docker"
                ["image", "ls", imageName, "--format", "{{.Repository}}"]
                empty
        )
        Fold.list -- Get the output of the command as a list of lines
  
      if existent == mempty
        then return False
              -- For the cache to be valid, we need to make sure that the stored image is based on the same
              -- base image and tag. Otherwise we will need to rebuild the cache anyway
        else imageAndTagMatches (ImageName (stageName stage))
                                (Tag (stageTag stage))
                                imageName
    --
    --
    getFallbackCache stage fallbackName = do
      exists <- cacheKeyExists stage fallbackName
  
      if exists
        then do
          echo
            "------> The fallback image exists, using it to build the initial cache"
          cachedStage <- inspectCache
            (stage { stageImageName = fallbackName
                   , buildImageName = fallbackName
                   }
            )
          return (stage, FallbackCache stage cachedStage)
        else do
          echo "------> There is not fallback cache image"
          return (stage, NotCached stage)
  
  
  -- | Here check each of the cache buster from the image and compare them with those we have locally,
  --   if the files do not match, then we return the stage back as a result, otherwise return Nothing.
  shouldBustCache :: Stage SourceImage -> StageCache -> Shell StageCache
  shouldBustCache sourceStage cached@Cached {..} = do
    printLn ("----> Checking cache buster files for stage " % s) (stageName stage)
    result <- withContainer (buildImageName stage) checkFiles -- Create a container to inspect the files
    case result of
      Left _ -> do
        err
          "----> Could not create the container, impossible to inspect the cache"
        return $ NotCached sourceStage
      Right stCache -> return stCache
   where
    checkFiles containerId = do
      hasChanged <- fold
        (mfilter isJust (checkFileChanged containerId cacheBusters))
        Fold.head
      -- ^ Get the cache buster files that have changed since last time
  
      -- The following is executed for each of the files found
      if isJust hasChanged
        then do
          printLn ("----> The stage " % s % " changed") (stageName stage)
          return (CacheInvalidated sourceStage stage)
        else do
          printLn ("----> The stage " % s % " did not change") (stageName stage)
          return cached
  
    -- |
    checkFileChanged containerId files = do
      (SourcePath src, TargetPath dest) <- select files
      let file = fromText src
      exists <- testpath file
      if not exists
      then
        return (Just file)
      else do
        isDir <- testdir file
  
        if isDir
          then do
            printLn
              ( "------>'"
              % fp
              % "' is a directory, assuming files inside it changed"
              )
              file
            return $ Just file
          else do
            let targetDir = fromText dest
            printLn ("------> Checking file '" % fp % "' in directory " % fp)
                    file
                    targetDir
            currentDirectory <- pwd
            tempFile         <- mktempfile currentDirectory "comp"
            let targetFile = targetDir </> file
            status <- proc
              "docker"
              [ "cp"
              , format (s % ":" % fp) containerId targetFile
              , format fp tempFile
              ]
              empty
  
            guard (status == ExitSuccess)
  
            local  <- liftIO (readTextFile file)
            remote <- liftIO (readTextFile tempFile)
            if local == remote then return Nothing else return (Just file)
  
  -- In any other case return the same inspected stage
  shouldBustCache _ c@NotCached{}        = return c
  shouldBustCache _ c@CacheInvalidated{} = return c
  shouldBustCache _ c@FallbackCache{}    = return c
  
  
  -- | This will inspect how an image was build and extrack the ONBUILD directives. If any of those
  --   instructions are copying or adding files to the build, they are considered "cache busters".
  inspectCache :: Stage SourceImage -> Shell StageCache
  inspectCache sourceStage@Stage {..} = do
    ImageConfig workdir onBuildLines foundLabels <- imageConfig buildImageName
    let parsedDirectivesWithErrors = fmap parseText onBuildLines -- Parse each of the lines
        parsedDirectives = (getFirst . rights) parsedDirectivesWithErrors -- We only keep the good lines
        workPath = fromText workdir
        onBuildBusters = extractCachePaths workPath parsedDirectives
        cacheBusters = onBuildBusters ++ bustersFromLabels workPath foundLabels
    return $ Cached (toCachedStage sourceStage) cacheBusters
   where
    extractCachePaths workdir dir =
      let filePairs = concat (mapMaybe doExtract dir) -- Get the (source, target) pairs of files copied
      in  fmap (prependWorkdir workdir) filePairs -- Some target paths need to have the WORKDIR prepended
  
    --
    -- | Prepend a given target dir to the target path
    prependWorkdir workdir (source, TargetPath target) =
      let dest          = fromText target
          prependedDest = format fp (collapse (workdir </> dest))
      in  if relative dest -- If the target path is relative, we need to prepend the workdir
            then (source, TargetPath prependedDest) -- Remove the ./ prefix and prepend workdir
            else (source, TargetPath target)
  
    --
    -- | COPY allows multiple paths in the same line, we need to convert each to a separate path
    doExtract (InstructionPos (Copy CopyArgs { sourcePaths, targetPath }) _ _) =
      Just (zip (toList sourcePaths) (repeat targetPath))
    --
    -- | This case is simpler, we only need to convert the source and target from ADD
    doExtract (InstructionPos (Add AddArgs { sourcePaths, targetPath }) _ _) =
      Just (zip (toList sourcePaths) (repeat targetPath))
    doExtract _ = Nothing
  
    getFirst (first : _) = first
    getFirst []          = []
  
    bustersFromLabels workdir labelList =
      case Map.lookup "cached_files" labelList of
        Nothing -> []
        Just fs ->
          case
              Aeson.decodeStrict . Data.Text.Encoding.encodeUtf8 $ fs :: Maybe
                [(Text, Text)]
            of
              Nothing -> []
              Just busters ->
                fmap (prependWorkdir workdir) (Data.Coerce.coerce busters)
  
  
  toCachedStage :: Stage SourceImage -> Stage CachedImage
  toCachedStage Stage {..} =
    let stage                = Stage {..}
        ImageName sImageName = stageImageName
        ImageName bImageName = buildImageName
    in  stage { stageImageName     = ImageName sImageName
              , stageFallbackImage = Nothing
              , buildImageName     = ImageName bImageName
              }
  
  
  -- | Extracts the label from the cached image passed in the last argument and checks
  -- if it matches the passeed image name and tag name. This is used to avoid using a
  -- cached image tht was built using a different base iamge
  imageAndTagMatches :: ImageName Text -> Tag -> Text -> Shell Bool
  imageAndTagMatches (ImageName imageName) (Tag tagName) cachedImage = do
    printLn ("------> Checking the stored cached key in a label for " % s)
            cachedImage
    value <- fold getCacheLabel Fold.head -- Get the only line
    let expected = unsafeTextToLine (imageName <> ":" <> tagName)
    return (Just expected == value)
   where
    getCacheLabel = inproc
      "docker"
      [ "inspect"
      , "--format"
      , "{{ index .Config.Labels \"cached_image\"}}"
      , cachedImage
      ]
      empty
  
  
  alreadyCached :: StageCache -> Maybe (Stage CachedImage)
  -- We want to replace stages where the cache
  -- was invalidated by any file changes.
  alreadyCached (CacheInvalidated _ stage) = Just stage
  
  -- Likewise, once we have a cached stage, we need to keep using it
  -- in succesive builds, so the cache is not invalidated again.
  alreadyCached (Cached stage _) = Just stage
  
  -- Finally, if we are using a fallback, we apply
  -- the same rules as above for the fallback key
  alreadyCached (FallbackCache _ (CacheInvalidated _ stage)) = Just stage
  
  alreadyCached (FallbackCache _ (Cached stage _)) = Just stage
  
  alreadyCached _ = Nothing
  
  
  -- | Creates a container from a stage and passes the container id to the
  --   given shell as an argument
  withContainer :: ImageName a -> (Text -> Shell b) -> Shell (Either Line b)
  withContainer (ImageName imageName) action = do
    result <- inprocWithErr "docker" ["create", imageName, "sh"] empty
    case result of
      Left  errorMsg    -> return (Left errorMsg)
      Right containerId -> do
        res <- fold (action (format l containerId)) Fold.list
        _   <- removeContainer containerId -- Ignore the return code of this command
        select (map Right res) -- yield each result as a separate line
   where
    removeContainer containerId =
      proc "docker" ["rm", format l containerId] empty
  