content: {-# LANGUAGE FlexibleContexts  #-}
  {-# LANGUAGE LambdaCase        #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards   #-}
  {-# LANGUAGE ViewPatterns      #-}
  
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Network.Wreq.Docker.Image.Lib
  -- Copyright   :  (C) 2016 Awake Networks
  -- License     :  Apache-2.0
  -- Maintainer  :  Awake Networks <opensource@awakenetworks.com>
  -- Stability   :  stable
  ----------------------------------------------------------------------------
  
  module Network.Wreq.Docker.Image.Lib where
  
  import qualified Codec.Archive.Tar                 as Tar
  import qualified Codec.Compression.GZip            as GZip
  import qualified Control.Concurrent.PooledIO.Final as Pool
  import           Control.Lens
  import           Control.Monad.Reader
  import qualified Data.ByteString.Lazy.Char8        as C8L
  import           Data.Coerce
  import qualified Data.HashMap.Strict               as HashMap
  import qualified Data.Text                         as Text
  import qualified Network.Wreq                      as Wreq
  import qualified System.Directory                  as Directory
  import           System.FilePath.Posix             as File
  import           System.Terminal.Concurrent
  
  import           Data.Docker.Image.Types
  import           Hocker.Lib
  import           Network.Wreq.Docker.Registry      as Docker.Registry
  import           Hocker.Types
  import           Hocker.Types.Exceptions
  import           Hocker.Types.ImageTag
  
  -- | Like @mapM@ but concurrently apply a function to the elements of
  -- the @Traversable@, limiting the maximum number of worker threads by
  -- _n_.
  mapPool :: Traversable t
          => Int                                         -- ^ Number of pooled worker threads
          -> ((String -> IO ()) -> a -> Hocker FilePath) -- ^ Processing function
          -> t a                                         -- ^ A Traversable container
          -> Hocker (t (Either HockerException FilePath))
  mapPool n f l = do
    env    <- ask
    writeC <- liftIO getConcurrentOutputter
    let f' v = (runHocker (f writeC v) env)
  
    -- TODO: because I'm re-wrapping the function traversing the
    -- traversable, I need to extract the Left's from the result and
    -- propagate an error up with @throwError@ from this function.
    --
    -- TODO: refactor this such that the previous TODO is unnecessary.
    liftIO . Pool.runLimited n $ traverse (Pool.fork . f') l
  
  -- | Like @mapPool@ but with the arguments flipped.
  forPool :: Traversable t
          => Int                                         -- ^ Number of pooled worker threads
          -> t a                                         -- ^ A Traversable container
          -> ((String -> IO ()) -> a -> Hocker FilePath) -- ^ Processing function
          -> Hocker (t (Either HockerException FilePath))
  forPool n = flip $ mapPool n
  
  -- | Download, verify, decompress, and write a docker container image
  -- layer to the filesystem.
  fetchLayer :: (String -> IO ()) -- ^ Concurrent terminal output function
             -> (RefLayer, Layer) -- ^ A tuple of the reference layer hash digest from the image's config JSON and hash digest from the image's manifest JSON
             -> Hocker FilePath
  fetchLayer writeC layer@(refl, (stripHashId -> layer')) = ask >>= \HockerMeta{..} -> do
    liftIO . writeC . Text.unpack $ "Downloading layer: " <> (Text.take 7 layer')
  
    fetchedImageLayer <- checkResponseIntegrity' =<< (Docker.Registry.fetchLayer $ snd layer)
  
    let decompressed = fetchedImageLayer & Wreq.responseBody %~ GZip.decompress
        shortRef     = Text.take 7 refl
  
    imageOutDir <- Hocker.Lib.requirePath outDir
  
    liftIO $ writeC " => decompressed "
  
    let layerOutPath = File.joinPath [imageOutDir, Text.unpack refl] `addExtension` "tar"
    layerPath <- writeRespBody layerOutPath refl decompressed
  
    liftIO . writeC $ Text.unpack ("=> wrote " <> shortRef)
  
    return layerPath
  
  -- | Generate a @manifest.json@ file.
  createImageManifest :: RepoTag    -- ^ e.g: registry.mydomain.net:5001/reponame/imagename
                      -> FilePath   -- ^ Path of image config file for manifest
                      -> [RefLayer] -- ^ Layer hash digests sourced from the image's config JSON
                      -> Hocker ()
  createImageManifest repoTag imageConfigFile refls = ask >>= \HockerMeta{..} -> do
    let imageManifest = [
          ImageManifest
            (takeBaseName imageConfigFile `addExtension` "json")
            [Text.pack (repoTag ++ ":" ++ coerce imageTag)]
            (fmap ((`addExtension` "tar") . Text.unpack) refls) ]
    imageOutDir <- Hocker.Lib.requirePath outDir
    liftIO $ C8L.writeFile
      (imageOutDir </> "manifest" `addExtension` "json")
      (Hocker.Lib.encodeCanonical imageManifest)
  
  -- | Generate a @repositories@ json file.
  --
  -- NB: it is JSON but Docker doesn't want it a @.json@ extension
  -- unlike its sibling the @manifest.json@ file.
  createImageRepository :: RepoTag    -- ^ e.g: registry.mydomain.net:5001/reponame/imagename
                        -> [RefLayer] -- ^ Layer hash digests sourced from the image's configuration JSON
                        -> Hocker ()
  createImageRepository repoTag refls = ask >>= \HockerMeta{..} -> do
    let repositories  =
          ImageRepo
            (Text.pack repoTag)
  
            -- Create a singleton map from a tag and the "latest" layer;
            -- Aeson will correctly encode this as an object with a key
            -- (the tag) and value (the layer within the archive named
            -- by its hash digest)
            (HashMap.singleton
             (Text.pack $ coerce imageTag)
             ((Prelude.last refls) <> ".tar"))
    imageOutDir <- Hocker.Lib.requirePath outDir
    liftIO $ C8L.writeFile
      (imageOutDir </> "repositories")
      (Hocker.Lib.encodeCanonical repositories)
  
  -- | Tar and gzip the output dir into the final docker image archive
  -- and remove the output dir.
  createImageTar :: Hocker FilePath
  createImageTar = ask >>= \HockerMeta{..} -> do
    imageOutDir <- Hocker.Lib.requirePath outDir
    archivePath <- Hocker.Lib.requirePath out
  
    entries <- liftIO $ Directory.getDirectoryContents imageOutDir
  
    -- TODO: remove once we have a newer `directory`
    let entriesToPack = [e | e <- entries, e /= ".", e /= ".."]
  
    liftIO $ Tar.create archivePath imageOutDir entriesToPack
  
    -- Cleanup after ourselves
    liftIO $ Directory.removeDirectoryRecursive imageOutDir
  
    return $ archivePath
  