hocker-1.0.0: src/Network/Wreq/Docker/Image/Lib.hs
{-# 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.Except
import Control.Monad.Reader
import qualified Data.ByteString.Lazy.Char8 as C8L
import Data.Coerce
import qualified Data.HashMap.Strict as HashMap
import Data.Monoid
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