From aab52668e5d69c76055b8e41b47e4d0e3dad24ea Mon Sep 17 00:00:00 2001 From: Parnell Springmeyer Date: Wed, 28 Jun 2017 13:20:56 -0500 Subject: [PATCH] Refactoring polish and haddocks documentation refactor (#7) * Refactoring polish and haddocks documentation refactor * Remove tested with 7.10.2 until we actually test it * Remove the TODO header as most of that is done now --- README.md | 18 -- docker2nix/Main.hs | 18 +- hocker-config/Main.hs | 6 +- hocker-image/Main.hs | 12 +- hocker-layer/Main.hs | 12 +- hocker-manifest/Main.hs | 6 +- hocker.cabal | 44 ++-- src/Data/Docker/Image/Types.hs | 128 +++++++-- src/Data/Docker/Image/V1/Layer.hs | 249 ------------------ src/Data/Docker/Image/V1/Types.hs | 108 -------- src/Data/Docker/Image/V1_2/Types.hs | 108 -------- src/Data/Docker/Nix.hs | 4 +- src/Data/Docker/Nix/FetchDocker.hs | 104 ++++---- src/Data/Docker/Nix/Lib.hs | 53 ++-- src/Lib.hs | 111 ++++---- src/Network/Wreq/Docker/Image.hs | 137 ++++++++++ src/Network/Wreq/Docker/Image/Lib.hs | 24 +- src/Network/Wreq/Docker/Image/V1_2.hs | 158 ----------- .../Docker/{Registry/V2.hs => Registry.hs} | 82 +++--- src/Types.hs | 6 + test/Main.hs | 6 +- .../Data/Docker/{Image/V1_2.hs => Image.hs} | 10 +- test/Tests/Data/Docker/Image/V1.hs | 86 ------ test/Tests/Data/Docker/Nix/FetchDocker.hs | 20 +- 24 files changed, 529 insertions(+), 981 deletions(-) delete mode 100644 src/Data/Docker/Image/V1/Layer.hs delete mode 100644 src/Data/Docker/Image/V1/Types.hs delete mode 100644 src/Data/Docker/Image/V1_2/Types.hs create mode 100644 src/Network/Wreq/Docker/Image.hs delete mode 100644 src/Network/Wreq/Docker/Image/V1_2.hs rename src/Network/Wreq/Docker/{Registry/V2.hs => Registry.hs} (78%) rename test/Tests/Data/Docker/{Image/V1_2.hs => Image.hs} (92%) delete mode 100644 test/Tests/Data/Docker/Image/V1.hs diff --git a/README.md b/README.md index 29507af..a8e55ae 100644 --- a/README.md +++ b/README.md @@ -101,21 +101,3 @@ also do not supply a `--registry` flag then the tools assume you wish to make a request to the public docker hub registry, in which case they ask for a short-lived authentication token from the registry auth server and then make the request to the public docker hub registry. - -# TODO -- [X] ~Get a nix-build workflow working for hocker~ -- [ ] Work on a nix-shell based dev workflow -- [ ] Document types in `Exceptions`, `ErrorHandling`, etc. -- [x] ~Rename the `Types/Extra.hs` module, that's poorly named~ (I got rid of it) -- [x] ~Write an updated and accurate README introduction~ -- [X] Rename `ContainerName` and `ContainerTag` to `ImageName` and `ImageTag` to - be more consistent with the correct docker terminology -- [x] ~Remove the run prefix from most of the `V1_2.hs` module functions~ (replaced with a `do` prefix) -- [X] ~Use HockerException in docker2nix's lib functions~ -- [x] ~Better document the types and function signatures in `Nix/FetchDocker.hs`~ -- [X] L258 fix docker-layer to hocker-layer -- [ ] Proofread comments -- [ ] `Data/Docker/Image/Types.hs` can probably move to a more general location - I think -- [ ] Use friendly module prefixing more consistently and cleanup usage -- [ ] Strip out the unused docker image V1 code diff --git a/docker2nix/Main.hs b/docker2nix/Main.hs index 78630ca..655da71 100644 --- a/docker2nix/Main.hs +++ b/docker2nix/Main.hs @@ -21,16 +21,16 @@ module Main where -import Data.ByteString.Lazy.Char8 as C8L -import Data.Maybe (fromMaybe) -import qualified Data.Text as T +import Data.ByteString.Lazy.Char8 as C8L +import Data.Maybe (fromMaybe) +import Data.Text (Text) import Options.Generic -import System.IO (hWaitForInput, stdin) +import System.IO (hWaitForInput, stdin) import Data.Docker.Image.Types -import Data.Docker.Nix.FetchDocker as Nix.FetchDocker +import Data.Docker.Nix.FetchDocker as Nix.FetchDocker import Lib -import Network.Wreq.Docker.Registry.V2 as Docker.Registry +import Network.Wreq.Docker.Registry as Docker.Registry import Types import Types.ImageName import Types.ImageTag @@ -45,7 +45,7 @@ data ProgArgs w = ProgArgs "Fetch image manifest from a path on the filesystem" -- | Alternative docker image name made available in the Nix -- expression fetchdocker derivation - , altImageName :: w ::: Maybe T.Text + , altImageName :: w ::: Maybe Text "Alternate image name provided in the `fetcdocker` derivation" -- | Docker image name (includes the reponame, e.g: library/debian) , name :: ImageName @@ -57,12 +57,12 @@ data ProgArgs w = ProgArgs instance ParseRecord (ProgArgs Wrapped) deriving instance Show (ProgArgs Unwrapped) -progSummary :: T.Text +progSummary :: Text progSummary = "Produce a Nix expression given a manifest for a docker image via stdin or via a filepath" main :: IO () main = unwrapRecord progSummary >>= \ProgArgs{..} -> do - let (imageRepo, imageName) = Lib.splitImgName name + let (imageRepo, imageName) = Lib.splitRepository name dockerRegistry = fromMaybe defaultRegistry registry manifestJSON <- diff --git a/hocker-config/Main.hs b/hocker-config/Main.hs index cd1aa7f..911f00b 100644 --- a/hocker-config/Main.hs +++ b/hocker-config/Main.hs @@ -15,13 +15,13 @@ module Main where -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Text import Options.Generic import Lib -import Network.Wreq.Docker.Image.V1_2 as Docker.Image -import Network.Wreq.Docker.Registry.V2 +import Network.Wreq.Docker.Image as Docker.Image +import Network.Wreq.Docker.Registry import Types progSummary :: Data.Text.Text diff --git a/hocker-image/Main.hs b/hocker-image/Main.hs index d895d70..507c828 100644 --- a/hocker-image/Main.hs +++ b/hocker-image/Main.hs @@ -15,15 +15,15 @@ module Main where -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Text -import Data.Text.IO as TIO +import Data.Text.IO as TIO import Options.Generic -import System.IO.Temp as Tmp +import System.IO.Temp as Tmp import Lib -import Network.Wreq.Docker.Image.V1_2 as Docker.Image -import Network.Wreq.Docker.Registry.V2 +import Network.Wreq.Docker.Image as Docker.Image +import Network.Wreq.Docker.Registry import Types progSummary :: Data.Text.Text @@ -35,7 +35,7 @@ main = unwrapRecord progSummary >>= \Options{..} -> do auth <- mkAuth dockerRegistry imageName credentials img <- withSystemTempDirectory "hocker-image-XXXXXX" $ \d -> - Docker.Image.fetchAndAssemble $ + Docker.Image.fetchImage $ HockerMeta { outDir = Just d , imageLayer = Nothing diff --git a/hocker-layer/Main.hs b/hocker-layer/Main.hs index 0b54d7a..399e6cc 100644 --- a/hocker-layer/Main.hs +++ b/hocker-layer/Main.hs @@ -21,19 +21,19 @@ module Main where -import qualified Crypto.Hash as Hash -import Data.Maybe (fromMaybe) +import qualified Crypto.Hash as Hash +import Data.Maybe (fromMaybe) import qualified Data.Text import Options.Generic import Lib -import Network.Wreq.Docker.Image.V1_2 as Docker.Image -import Network.Wreq.Docker.Registry.V2 +import Network.Wreq.Docker.Image as Docker.Image +import Network.Wreq.Docker.Registry import Types -import Types.Hash () +import Types.Hash () import Types.ImageName import Types.ImageTag -import Types.URI () +import Types.URI () data ProgArgs w = ProgArgs { -- | URI for the registry, optional diff --git a/hocker-manifest/Main.hs b/hocker-manifest/Main.hs index 52667ab..8101d7a 100644 --- a/hocker-manifest/Main.hs +++ b/hocker-manifest/Main.hs @@ -15,13 +15,13 @@ module Main where -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import qualified Data.Text import Options.Generic import Lib -import Network.Wreq.Docker.Image.V1_2 as Docker.Image -import Network.Wreq.Docker.Registry.V2 +import Network.Wreq.Docker.Image as Docker.Image +import Network.Wreq.Docker.Registry import Types progSummary :: Data.Text.Text diff --git a/hocker.cabal b/hocker.cabal index a5f56bd..631600a 100644 --- a/hocker.cabal +++ b/hocker.cabal @@ -1,17 +1,39 @@ name: hocker -version: 0.1.0.0 -synopsis: CLI tools and library to interact with a V2 Docker Registry -description: Please see README.md +version: 1.0.0 +synopsis: Utilities for interacting with the docker registry and generating nix build instructions homepage: https://github.com/awakenetworks/hocker#readme +Bug-Reports: https://github.com/awakenetworks/hocker/issues license: Apache-2.0 license-file: LICENSE author: Awake networks maintainer: opensource@awakenetworks.com copyright: 2016 Awake Networks -category: Web +category: Utilities build-type: Simple extra-source-files: LICENSE cabal-version: >=1.10 +Tested-With: GHC == 8.0.1 +Description: + @hocker@ is a suite of command line utilities and a library for: + . + * fetching a docker image + * fetching a layer of an image + * fetching an image's configuration + * fetching a docker registry image manifest + * generating nix build instructions from a registry image manifest + . + The motivation for this tool came from a need to fetch docker + image artifacts from a docker registry without the stock docker + tooling that is designed to only work with the docker daemon. + . + These tools /only/ work with version 2 of the docker registry and + docker version (>=) 1.10. + . + For a complete set of usage examples please see the project's . + +source-repository head + type: git + location: https://github.com/awakenetworks/hocker library ghc-options: -Wall @@ -29,12 +51,9 @@ library Data.Docker.Nix.FetchDocker, Data.Docker.Image.Types, Data.Docker.Image.AesonHelpers, - Data.Docker.Image.V1.Layer, - Data.Docker.Image.V1.Types, - Data.Docker.Image.V1_2.Types, Network.Wreq.ErrorHandling, - Network.Wreq.Docker.Registry.V2, - Network.Wreq.Docker.Image.V1_2, + Network.Wreq.Docker.Registry, + Network.Wreq.Docker.Image, Network.Wreq.Docker.Image.Lib build-depends: base >= 4.9 && < 5, @@ -189,8 +208,7 @@ test-suite hocker-tests hs-source-dirs: test main-is: Main.hs other-modules: - Tests.Data.Docker.Image.V1, - Tests.Data.Docker.Image.V1_2, + Tests.Data.Docker.Image, Tests.Data.Docker.Nix.FetchDocker build-depends: base >= 4.9 && < 5, @@ -214,7 +232,3 @@ test-suite hocker-tests ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 - -source-repository head - type: git - location: https://github.com/awakenetworks/hocker diff --git a/src/Data/Docker/Image/Types.hs b/src/Data/Docker/Image/Types.hs index a05d5dc..9adb541 100644 --- a/src/Data/Docker/Image/Types.hs +++ b/src/Data/Docker/Image/Types.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- @@ -14,18 +15,22 @@ module Data.Docker.Image.Types where -import Data.ByteString.Lazy.Char8 as C8L -import qualified Data.Text as T +import qualified Crypto.Hash as Hash +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Types +import qualified Data.ByteArray as BA +import qualified Data.ByteArray.Encoding as BA +import qualified Data.ByteString.Char8 as C8 +import Data.ByteString.Lazy.Char8 as C8L +import Data.HashMap.Strict as H +import Data.Text (Text) +import Data.Docker.Image.AesonHelpers import Types import Types.ImageTag --- | Record of all the metadata we need for a docker image; this --- includes the basics like registry location, image repository name, --- image name, image tag, a possible alternative image name, and --- finally the full manifest JSON for the docker image from which a --- complete image can be constructed (supplying the config JSON and --- references to all of the layers). +-- | Metadata needed for constructing a docker image. data HockerImageMeta = HockerImageMeta { -- | Docker image repo, the first part of a repository+name -- separated by a "/"; e.g: library/debian. @@ -35,18 +40,109 @@ data HockerImageMeta = HockerImageMeta , imageName :: ImageNamePart -- | Docker image tag , imageTag :: ImageTag - -- | A docker image manifest JSON blob as usually fetched from a -- docker registry. - -- - -- TODO: switch this to the JSON AST type? , manifestJSON :: C8L.ByteString -- | The URI (even if the default public registry) of the docker -- registry. , dockerRegistry :: RegistryURI - -- | An alternative name for the docker image provided in the - -- output Nix `fetchdocker` derivation expressions. Not replacing - -- @imageName@ but providing a method for declaring up-front a - -- possibly cleaner or more intuitive name for use within Nix. - , altImageName :: Maybe T.Text + -- | An alternative name for the docker image in the generated nix + -- build instructions. + , altImageName :: Maybe Text } deriving (Show) + +-- | Parse a 'C8.ByteString' into a 'Hash.SHA256'. +-- +-- A digest value, as seen in the docker registry manifest, is the +-- hexadecimal encoding of a hashing function's digest with the +-- hashing function identifier prefixed onto the string. At this time +-- the only prefix used is @sha256:@. +toDigest :: C8.ByteString -> Maybe (Hash.Digest Hash.SHA256) +toDigest = from . C8.break (== ':') + where + from ("sha256", r) = either (const Nothing) Hash.digestFromByteString . toBytes $ C8.tail r + from (_, _) = Nothing + + toBytes :: C8.ByteString -> Either String BA.Bytes + toBytes = BA.convertFromBase BA.Base16 + +-- | Show a hexadecimal encoded 'SHA256' hash digest and prefix +-- @sha256:@ to it. +showSHA :: Hash.Digest Hash.SHA256 -> String +showSHA = ("sha256:" ++) . show + +-- Pretty-printed example of the `manifest.json` file. +{- + [ + { + "Config": "3e83c23dba6a16cd936a3dc044df71b26706c5a4c28181bc3ca4a4af9f5f38ee.json", + "Layers": [ + "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9.tar" + ], + "RepoTags": [ + "library/debian:jessie" + ] + } +] +-} + +-- Pretty-printed example of the `repositories` json file. +{- + { + "library/debian": { + "jessie": "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9" + } + } +-} + +-- | A layer hash digest from a docker image's config JSON. This hash +-- is different from those found in the image's manifest JSON. +type RefLayer = Text + +-- | A 'String' representing the full repository tag, e.g: @library/debian@. +type RepoTag = String + +-- | A v1.2 docker image manifest. +data ImageManifest = ImageManifest + { -- | 'FilePath' within the image archive of the image's config + -- JSON + config :: FilePath + -- | List of image repository tags + , repoTags :: [Text] + -- | List of layers within the image archive named by their hash + -- digest and with a @.tar@ extension + , layers :: [FilePath] + } deriving (Show, Eq) + +-- | A map of 'ImageRepo's. The repository names are the top-level +-- keys and their value is a map who's keys are the tags of the +-- repository with the hash-value of the layer that tag references. +data ImageRepositories = ImageRepositories [ImageRepo] + deriving (Show, Eq) + +data ImageRepo = ImageRepo + { -- | Repository tag + repo :: Text + -- | 'HashMap' of tags to the top-most layer associated with that tag + , tags :: H.HashMap Text Text + } deriving (Show, Eq) + +$(deriveJSON stdOpts{ fieldLabelModifier = upperFirst } ''ImageManifest) + + + +instance ToJSON ImageRepositories where + toJSON (ImageRepositories r) = + Object . H.unions $ [i | o@(Object i) <- (fmap toJSON r), isObject o] + where + isObject (Object _) = True + isObject _ = False + +instance ToJSON ImageRepo where + toJSON (ImageRepo r t) = object [ r .= toJSON t ] + +instance FromJSON ImageRepositories where + parseJSON (Object v) = ImageRepositories <$> (mapM buildRepo $ H.toList v) + where + buildRepo (k,v') = ImageRepo k <$> parseJSON v' + parseJSON v = typeMismatch "ImageRepositories" v diff --git a/src/Data/Docker/Image/V1/Layer.hs b/src/Data/Docker/Image/V1/Layer.hs deleted file mode 100644 index 51dedd2..0000000 --- a/src/Data/Docker/Image/V1/Layer.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Docker.Image.V1.Layer --- Copyright : (C) 2016 Awake Networks --- License : Apache-2.0 --- Maintainer : Awake Networks --- Stability : stable --- --- Many of these functions are named after their equivalent functions --- in the docker Golang source code. --- --- ----------------------------------------------------------------------------- - -module Data.Docker.Image.V1.Layer where - -import Control.Monad -import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as CL8 -import Data.Coerce -import Data.Docker.Image.V1.Types -import Data.Foldable -import qualified Data.HashMap.Strict as H -import Data.Monoid -import Data.Sequence as Seq -import Data.Sequence.Lens -import qualified Data.Text as T - -import Lib - -type Parent = ChainID -type TopLayerJSON = Data.Aeson.Object - --- | Produce a @ChainID@ using a sequence of layer @DiffIDs@. --- --- -createChainID :: Seq DiffID -- ^ A sequence of layer @DiffID@s, (usually) fetched from the image's config JSON. - -> Maybe ChainID -createChainID = createChainIDFromParent Nothing - --- | Produce a @ChainID@ given the @ChainID@ of a parent layer and a --- sequence of layer @DiffIDs@. --- --- -createChainIDFromParent :: Maybe Parent -- ^ Previous (parent) @ChainID@ in the sequence used to produce the next @ChainID@. - -> Seq DiffID -- ^ A sequence of layer @DiffID@s, (usually) fetched from the image's config JSON. - -> Maybe ChainID -createChainIDFromParent parent (Seq.viewl -> EmptyL) = parent -createChainIDFromParent parent (Seq.viewl -> h :< rest) = - createChainIDFromParent (maybe root layer parent) rest - where - root = Just $ coerce h - layer = Just . flip chainDigest h - -createChainIDFromParent parent _ = parent - --- | Produce a @ChainID@ given a parent @ChainID@ and a layer --- @DiffID@. -chainDigest :: Parent -- ^ Parent @ChainID@ used to produce a child @ChainID@. - -> DiffID -- ^ Layer @DiffID@. - -> ChainID -chainDigest (show -> c) (show -> d) = ChainID . - Lib.sha256 . CL8.pack $ concat [c, " ", d] - --- | Produce a sequence of @ChainID@s from a sequence of layer --- @DiffID@s. --- --- -chainIDSequence :: Seq DiffID - -> Seq (Maybe ChainID) -chainIDSequence diffIDSeq = mapWithIndex chainIDSlice diffIDSeq - where - chainIDSlice (succ -> i) _ = - createChainID $ seqOf (slicedTo i) diffIDSeq - --- | Produce a sequence of unwrapped Just's from a sequence of --- Maybe's. -squishMaybe :: MonadPlus m => m (Maybe a) -> m a -squishMaybe = join . fmap adapt - where - adapt Nothing = mzero - adapt (Just x) = return x - --- | Produce layer content ID hashes given an empty JSON config with --- the layer's @ChainID@ injected as the value of the `layer_id` key --- and, if not the base layer, the previous @ContentID@ injected as --- the value of the `parent` key. --- --- The JSON that is encoded *must* be in the canonical format --- specified by Docker, please see @Lib.encodeCanonical@ for a --- convenience function to encode an @Aeson.Value@ satisfying those --- rules. -contentIDSequence :: Seq ChainID -- ^ A sequence of @ChainID@s, please see @chainIDSequence@. - -> TopLayerJSON -- ^ Config JSON paired with the top-most layer of the image. - -> Seq ContentID -contentIDSequence cids fj = foldl' (contentIDFold fj $ Seq.length cids) Seq.empty cids - --- | A folding function given to @foldl'@. This function computes the --- @ContentID@'s for each layer using the last computed @ContentID@ as --- the parent @ContentID@ for each iteration. --- --- The first two arguments are closed over before being fed to --- @foldl'@ producing a partial function that satisfies @foldl'@'s --- first argument type signature. -contentIDFold :: TopLayerJSON -- ^ Config JSON to be hashed with the top-most layer of the image. - -> Int -- ^ Length of the @ChainID@ sequence being folded over. - -> Seq ContentID -- ^ The sequence of @ContentID@s accumulated. - -> ChainID -- ^ The @ChainID@ for producing a @ContentID@. - -> Seq ContentID -contentIDFold _ _ acc@(Seq.viewr -> EmptyR) chainid = - acc |> hashContent Nothing chainid emptyLayerJSON -contentIDFold topLayerJSON ln acc@(Seq.viewr -> _ :> parent) chainid = - acc |> hashedContentID - where - -- Check to see if we're at the end of the sequence we're folding - -- over, if so then hash the content using the top-layer config - -- JSON instead of the empty JSON - hashedContentID = - if ln == (succ $ Seq.length acc) - then hashContent (Just parent) chainid topLayerJSON - else hashContent (Just parent) chainid emptyLayerJSON - -contentIDFold _ _ acc chainid = - acc |> hashContent Nothing chainid emptyLayerJSON - --- | Produce a @ContentID@, given a parent and a @ChainID@, builds the --- empty JSON object with those two values and encodes it following --- the canonical JSON rules. -hashContent :: Maybe ContentID -- ^ Parent @ContentID@ for injection into the hashing JSON. - -> ChainID -- ^ @ChainID@ to be hashed with the hashing JSON. - -> Data.Aeson.Object -- ^ Aeson AST to be canonically encoded; this can be either the ephemeral JSON or the config JSON. - -> ContentID -hashContent p c jsn = mk $ ephemeralHashableLayerJSON p c jsn - where - mk = ContentID . Lib.sha256 . Lib.encodeCanonical - --- | @emptyLayerJSON@ produces "empty" JSON for use in layer content --- hashing. --- --- The Aeson instances for @ContentID@, @DiffID@, and @ChainID@ will --- correctly output a hex serialization of the SHA256 digest and --- prefix it with "sha256:", which is necessary to correctly hash the --- layer config in the same way that Docker's Golang code does it. --- --- NB: I've manually assembled this in the "canonical order" it needs --- to be in, in order to correctly hash the JSON string. There is also --- a custom Aeson pretty printing function that serializes ADTs into --- the canonical form and should make this function moot once an --- appropriate ADT is in place. --- --- TODO: codify this as an ADT to get rid of this manual construction --- and make things clearer. For now, the manually constructed one is --- fine (to get things working). -emptyLayerJSON :: Data.Aeson.Object -emptyLayerJSON = H.fromList - [ "container_config" .= object - [ "Hostname" .= ("" :: String) - , "Domainname" .= ("" :: String) -- NB: this one isn't cased like the others :( - , "User" .= ("" :: String) - , "AttachStdin" .= False - , "AttachStdout" .= False - , "AttachStderr" .= False - , "Tty" .= False - , "OpenStdin" .= False - , "StdinOnce" .= False - , "Env" .= (Nothing :: Maybe String) - , "Cmd" .= (Nothing :: Maybe String) - , "Image" .= ("" :: String) - - -- This is a object with significant keys and empty values - -- (don't ask me why) - , "Volumes" .= (Nothing :: Maybe Data.Aeson.Value) - , "WorkingDir" .= ("" :: String) - , "Entrypoint" .= (Nothing :: Maybe String) - , "OnBuild" .= (Nothing :: Maybe String) - , "Labels" .= (Nothing :: Maybe [String]) - ] - - -- This is the "canonical" empty timestamp - , "created" .= emptyTimeStamp - ] - --- | Produce an "empty" JSON object given a parent and a --- @ChainID@. This is used internally to produce the @ContentID@ hash --- for a given layer. -ephemeralHashableLayerJSON :: Maybe ContentID -- ^ Parent @ContentID@, if Nothing, will not be included in the Aeson AST. - -> ChainID -- ^ @ChainID@ of the layer we're producing the @ContentID@ for. - -> Data.Aeson.Object -- ^ Aeson AST we want to inject the parent @ContentID@ and layer @ChainID@ into. - -> Data.Aeson.Value -ephemeralHashableLayerJSON parent layerid layerJSON = - Object $ layerJSON `H.union` H.fromList - ([ "layer_id" .= layerid ] <> (maybeSingletonParent parent)) - --- | Produce a layer JSON object given a parent, a @ContentID@, and an --- Aeson Value Object. This function is different from --- @ephemeralHashableLayerJSON@ in that its output is (later on) --- written to the filesystem alongside the `layer.tar` file within the --- directory named after the @ContentID@ hash. -permanentLayerJSON :: Maybe ContentID - -> ContentID - -> Data.Aeson.Object - -> Data.Aeson.Value -permanentLayerJSON parent layerContentId layerJSON = - Object $ layerJSON `H.union` H.fromList - ([ "id" .= (mkPermHash layerContentId) ] <> maybeSingletonParent (mkPermHash <$> parent)) - where - mkPermHash = Lib.stripHashId . T.pack . show - --- TODO: this should be parsed into an ADT, transformed algebraically --- into what it should be, then re-encoded; instead of performing --- Map-based operations on the AST. This was the quicker option though --- for now; need to get something working first. -imageConfig2LayerConfig :: Data.Aeson.Object - -> Data.Aeson.Object -imageConfig2LayerConfig = H.filterWithKey keyWhitelist - where - keyWhitelist k _ = k `elem` - [ "container" - , "container_config" - , "docker_version" - , "config" - , "architecture" - , "os" - ] - --- | Produce mempty if the parent is Nothing; if the parent is @Just --- ContentID@ then it returns a singleton list with the expected --- @Data.Aeson.Pair@ construction for the empty layer JSON. --- --- The input argument is parameterized because the permanent JSON --- config objects store hashes with the "sha256:" prefix stripped, but --- the ephemeral JSON objects used to produce the Content ID hashes --- want the "sha256:" prefix to be present! -maybeSingletonParent :: ToJSON a - => Maybe a - -> [(T.Text, Data.Aeson.Value)] -maybeSingletonParent = maybe mempty (singletonList . ("parent" .=)) - where - -- Alternatively - singleton v = [v] - singletonList = (: []) - --- | Produce the string "0001-01-01T00:00:00Z". -emptyTimeStamp :: String -emptyTimeStamp = "0001-01-01T00:00:00Z" diff --git a/src/Data/Docker/Image/V1/Types.hs b/src/Data/Docker/Image/V1/Types.hs deleted file mode 100644 index 3b6122c..0000000 --- a/src/Data/Docker/Image/V1/Types.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Docker.Image.V1.Types --- Copyright : (C) 2016 Awake Networks --- License : Apache-2.0 --- Maintainer : Awake Networks --- Stability : stable ----------------------------------------------------------------------------- - -module Data.Docker.Image.V1.Types where - -import qualified Crypto.Hash as Hash -import Data.Aeson -import Data.Aeson.Types -import qualified Data.ByteArray as BA -import qualified Data.ByteArray.Encoding as BA -import qualified Data.ByteString.Char8 as C8 -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) - --- | Attempt to parse a @C8.ByteString@ into a @Hash.Digest --- Hash.SHA256@. --- --- A @Digest@ in Docker Golang-code parlance is the string hexadecimal --- representation of a hashing function's digest with the hashing --- function identifier prefixed onto the string. Right now they only --- use SHA256 everywhere and also don't really do anything to --- parameterize it. --- --- There is a custom Show instance for this newtype to output a string --- representation of the digest prefixed by its hashing function --- identifier. -toDigest :: C8.ByteString -> Maybe (Hash.Digest Hash.SHA256) -toDigest = from . C8.break (== ':') - where - from ("sha256", r) = either (const Nothing) Hash.digestFromByteString . toBytes $ C8.tail r - from (_, _) = Nothing - - toBytes :: C8.ByteString -> Either String BA.Bytes - toBytes = BA.convertFromBase BA.Base16 - --- | A special kind of SHA256 hash digest identifying a layer by its --- *content*. This value is a hash of an empty, canonicalized JSON --- string with a "layer_id" (which is actually the layer's @ChainID@) --- and possibly a parent ID (which is the previous-layer-in-sequence --- @ContentID@). -newtype ContentID = ContentID (Hash.Digest Hash.SHA256) - deriving (Eq) - --- | A special kind of SHA256 digest identifying a specific sequence --- of layers. --- --- -newtype ChainID = ChainID (Hash.Digest Hash.SHA256) - deriving (Eq) - --- | A special kind of a SHA256 digest identifying a layer by the --- sha256 sum of the uncompressed layer tarball. "Diff" in this --- context refers to the root filesystem contents of the tarball --- identified by @DiffID@ representing the difference from the --- previous layer. --- --- -newtype DiffID = DiffID (Hash.Digest Hash.SHA256) - deriving (Eq) - --- | Show a hexadecimal encoded SHA256 hash digest and prefix --- "sha256:" to it. -showSHA :: Hash.Digest Hash.SHA256 -> String -showSHA = ("sha256:" ++) . show - -instance Show ContentID where - show (ContentID d) = showSHA d -instance Show ChainID where - show (ChainID d) = showSHA d -instance Show DiffID where - show (DiffID d) = showSHA d - -instance ToJSON ContentID where - toJSON v = String . T.pack $ show v -instance ToJSON ChainID where - toJSON v = String . T.pack $ show v -instance ToJSON DiffID where - toJSON v = String . T.pack $ show v - -instance FromJSON ContentID where - parseJSON o@(String v) = - case toDigest $ encodeUtf8 v of - Just v' -> return $ ContentID v' - Nothing -> typeMismatch "SHA256 Digest" o - parseJSON inv = typeMismatch "SHA256 Digest" inv -instance FromJSON ChainID where - parseJSON o@(String v) = - case toDigest $ encodeUtf8 v of - Just v' -> return $ ChainID v' - Nothing -> typeMismatch "SHA256 Digest" o - parseJSON inv = typeMismatch "SHA256 Digest" inv -instance FromJSON DiffID where - parseJSON o@(String v) = - case toDigest $ encodeUtf8 v of - Just v' -> return $ DiffID v' - Nothing -> typeMismatch "SHA256 Digest" o - parseJSON inv = typeMismatch "SHA256 Digest" inv diff --git a/src/Data/Docker/Image/V1_2/Types.hs b/src/Data/Docker/Image/V1_2/Types.hs deleted file mode 100644 index 471c0b1..0000000 --- a/src/Data/Docker/Image/V1_2/Types.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Docker.Image.V1_2.Types --- Copyright : (C) 2016 Awake Networks --- License : Apache-2.0 --- Maintainer : Awake Networks --- Stability : stable --- --- The types in this module are used to describe two specific pieces --- of JSON within the v1.2 Docker Image spec: @manifest.json@ and --- @repositories@. ----------------------------------------------------------------------------- - -module Data.Docker.Image.V1_2.Types where - -import Data.Aeson -import Data.Aeson.TH -import Data.Aeson.Types -import Data.HashMap.Strict as H -import qualified Data.Text as T - -import Data.Docker.Image.AesonHelpers -import Lib - ----------------------------------------------------------------------------- --- - --- Pretty-printed example of the `manifest.json` file. -{- - [ - { - "Config": "3e83c23dba6a16cd936a3dc044df71b26706c5a4c28181bc3ca4a4af9f5f38ee.json", - "Layers": [ - "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9.tar" - ], - "RepoTags": [ - "library/debian:jessie" - ] - } -] --} - --- Pretty-printed example of the `repositories` json file. -{- - { - "library/debian": { - "jessie": "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9" - } - } --} - --- | A 'Text' representing a layer hash digest sourced from a docker --- image's config JSON (different from the image's manifest JSON). -type RefLayer = T.Text - --- | A 'String' representing the full repository tag, e.g: @library/debian@. -type RepoTag = String - --- | Represents a v1.2 Docker Image manifest. -data ImageManifest = ImageManifest - { -- | 'FilePath' within the image archive of the image's config - -- JSON - config :: FilePath - -- | List of image repository tags - , repoTags :: [T.Text] - -- | List of layers within the image archive named by their hash - -- digest and with the tar extension appended - , layers :: [FilePath] - } deriving (Show, Eq) - --- | Represents an object of 'ImageRepo's. The repository names are the --- top-level keys and their value is an object who's keys are the tags --- of the repository with the hash-value of the layer that tag --- references. -data ImageRepositories = ImageRepositories [ImageRepo] - deriving (Show, Eq) - -data ImageRepo = ImageRepo - { -- | Repository tag - repo :: T.Text - -- | 'HashMap' of tags to the top-most layer associated with that tag - , tags :: H.HashMap T.Text T.Text - } deriving (Show, Eq) - -$(deriveJSON stdOpts{ fieldLabelModifier = upperFirst } ''ImageManifest) - -instance ToJSON ImageRepositories where - toJSON (ImageRepositories r) = - Object . H.unions $ [i | o@(Object i) <- (fmap toJSON r), isObject o] - where - isObject (Object _) = True - isObject _ = False - -instance ToJSON ImageRepo where - toJSON (ImageRepo r t) = object [ r .= toJSON t ] - -instance FromJSON ImageRepositories where - parseJSON (Object v) = ImageRepositories <$> (mapM buildRepo $ H.toList v) - where - buildRepo (k,v') = ImageRepo k <$> parseJSON v' - parseJSON v = typeMismatch "ImageRepositories" v diff --git a/src/Data/Docker/Nix.hs b/src/Data/Docker/Nix.hs index fe4c607..206bf4c 100644 --- a/src/Data/Docker/Nix.hs +++ b/src/Data/Docker/Nix.hs @@ -11,11 +11,11 @@ -- Stability : stable -- -- This module only re-exports Nix modules providing Docker-specific --- functionality as it pertains to Nix. +-- functionality as it pertains to generation of Nix expression. ---------------------------------------------------------------------------- module Data.Docker.Nix -( -- * Generating `fetchdocker` Nix Derivation Expressions +( -- * Generate nix build instructions for a docker image module Data.Docker.Nix.FetchDocker ) where diff --git a/src/Data/Docker/Nix/FetchDocker.hs b/src/Data/Docker/Nix/FetchDocker.hs index b6e165b..e9788ee 100644 --- a/src/Data/Docker/Nix/FetchDocker.hs +++ b/src/Data/Docker/Nix/FetchDocker.hs @@ -17,23 +17,24 @@ module Data.Docker.Nix.FetchDocker where import Control.Lens import Control.Monad -import Control.Monad.Except as Except +import Control.Monad.Except as Except import Data.Aeson.Lens -import qualified Data.Bifunctor as Bifunctor +import qualified Data.Bifunctor as Bifunctor import Data.Coerce import Data.Fix import Data.Maybe import Data.Monoid -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8') +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (decodeUtf8') import Data.Text.Encoding.Error import Nix.Expr import URI.ByteString import Data.Docker.Image.Types -import Data.Docker.Nix.Lib as Nix.Lib +import Data.Docker.Nix.Lib as Nix.Lib import Lib -import Network.Wreq.Docker.Registry.V2 (pluckLayersFrom) +import Network.Wreq.Docker.Registry (pluckLayersFrom) import Types import Types.Exceptions import Types.ImageTag @@ -60,22 +61,24 @@ fetchdocker rec { } -} --- | @fetchdocker@ derivation name. -constFetchdocker :: T.Text +-- | @fetchdocker@ function name. +constFetchdocker :: Text constFetchdocker = "fetchdocker" --- | @fetchDockerConfig@ derivation name. -constFetchDockerConfig :: T.Text +-- | @fetchDockerConfig@ function name. +constFetchDockerConfig :: Text constFetchDockerConfig = "fetchDockerConfig" --- | @fetchDockerLayer@ derivation name. -constFetchDockerLayer :: T.Text +-- | @fetchDockerLayer@ function name. +constFetchDockerLayer :: Text constFetchDockerLayer = "fetchDockerLayer" -- | Generate a Nix expression AST from a @HockerImageMeta@ --- record. This function crucially checks that the supplied manifest --- JSON contains a key in the top-level object describing what version --- of the manifest we have. +-- record. +-- +-- This function checks that the supplied manifest JSON contains a key +-- in the top-level object describing what version of the manifest we +-- have. generate :: HockerImageMeta -> IO (Either HockerException NExpr) generate dim@HockerImageMeta{..} = runExceptT $ case (manifestJSON ^? key "schemaVersion" . _Integer) of @@ -87,7 +90,7 @@ generate dim@HockerImageMeta{..} = runExceptT $ ExceptT (pure $ generateFetchDockerExpr dim configDigest layerDigests) Just v -> - throwError $ HockerException ("Expected: 2 but got: " <> (show v)) Nothing Nothing + throwError $ HockerException ("Expected a version 2 manifest but got version " <> (show v)) Nothing Nothing Nothing -> throwError $ HockerException "No key 'schemaVersion' in JSON object" Nothing Nothing @@ -102,28 +105,27 @@ generate dim@HockerImageMeta{..} = runExceptT $ {-| Generate a top-level Nix Expression AST from a 'HockerImageMeta' record, a config digest, and a list of layer digests. -The generated AST, pretty-printed, may look similar to the following: -@ -{ fetchdocker, fetchDockerConfig, fetchDockerLayer }: -fetchdocker rec { - name = "debian"; - registry = "https://registry-1.docker.io/v2/"; - repository = "library"; - imageName = "debian"; - tag = "latest"; - imageConfig = fetchDockerConfig { - inherit registry repository imageName tag; - sha256 = "1viqbygsz9547jy830f2lk2hcrxjf7gl9h1xda9ws5kap8yw50ry"; - }; - imageLayers = let - layer0 = fetchDockerLayer { - inherit registry repository imageName; - layerDigest = "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9"; - sha256 = "1fcmx3aklbr24qsjhm6cvmhqhmrxr6xlpq75mzrk0dj2gz36g8hh"; - }; - in [ layer0 ]; -} -@ +The generated AST, pretty printed, may look similar to the following: + +> { fetchdocker, fetchDockerConfig, fetchDockerLayer }: +> fetchdocker rec { +> name = "debian"; +> registry = "https://registry-1.docker.io/v2/"; +> repository = "library"; +> imageName = "debian"; +> tag = "latest"; +> imageConfig = fetchDockerConfig { +> inherit registry repository imageName tag; +> sha256 = "1viqbygsz9547jy830f2lk2hcrxjf7gl9h1xda9ws5kap8yw50ry"; +> }; +> imageLayers = let +> layer0 = fetchDockerLayer { +> inherit registry repository imageName; +> layerDigest = "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9"; +> sha256 = "1fcmx3aklbr24qsjhm6cvmhqhmrxr6xlpq75mzrk0dj2gz36g8hh"; +> }; +> in [ layer0 ]; +> } -} generateFetchDockerExpr :: HockerImageMeta -> ConfigDigest -> [(Base16Digest, Base32Digest)] -> Either HockerException NExpr generateFetchDockerExpr dim@HockerImageMeta{..} configDigest layerDigests = do @@ -132,7 +134,7 @@ generateFetchDockerExpr dim@HockerImageMeta{..} configDigest layerDigests = do , StaticKey "repository" , StaticKey "imageName" ] - let genLayerId i = mkSym . T.pack $ "layer" <> show i + let genLayerId i = mkSym . Text.pack $ "layer" <> show i let fetchconfig = mkFetchDockerConfig (inherit $ ((StaticKey "tag"):commonInherits)) configDigest fetchlayers = mkLets @@ -148,8 +150,8 @@ generateFetchDockerExpr dim@HockerImageMeta{..} configDigest layerDigests = do ]) fetchDockerExpr) -- | Generate a @fetchdocker { ... }@ function call and argument --- attribute set. Please see 'generateNixExprs' documentation for an --- example of full output. +-- attribute set. Please see 'generateFetchDockerExpr' documentation +-- for an example of full output. mkFetchDocker :: HockerImageMeta -> NExpr -> NExpr -> Either HockerException NExpr mkFetchDocker HockerImageMeta{..} fetchconfig fetchlayers = do registry <- Bifunctor.first mkHockerException serializedRegistry @@ -160,7 +162,7 @@ mkFetchDocker HockerImageMeta{..} fetchconfig fetchlayers = do , ("registry", mkStr registry) , ("repository", mkStr imageRepo) , ("imageName", mkStr imageName) - , ("tag", mkStr (T.pack $ coerce imageTag)) + , ("tag", mkStr (Text.pack $ coerce imageTag)) , ("imageConfig", fetchconfig) , ("imageLayers", fetchlayers) ])) @@ -173,18 +175,22 @@ mkFetchDocker HockerImageMeta{..} fetchconfig fetchlayers = do -- | Generate a @fetchDockerConfig { ... }@ function call and --- argument attrset. This function takes an argument for a list of --- static keys to inherit from the parent attribute set; it helps --- reduce the noise in the output expression. +-- argument attrset. +-- +-- This function takes an argument for a list of static keys to +-- inherit from the parent attribute set; it helps reduce the noise in +-- the output expression. mkFetchDockerConfig :: Binding NExpr -> Base32Digest -> NExpr mkFetchDockerConfig inherits (Base32Digest digest) = mkApp (mkSym constFetchDockerConfig) (Fix $ NSet [ inherits, "sha256" $= (mkStr digest) ]) -- | Generate a list of Nix expression ASTs representing --- @fetchDockerLayer { ... }@ function calls. This function takes --- an argument for a list of static keys to inherit from the parent --- attribute set; it helps reduce the noise in the output expression. +-- @fetchDockerLayer { ... }@ function calls. +-- +-- This function takes an argument for a list of static keys to +-- inherit from the parent attribute set; it helps reduce the noise in +-- the output expression. -- -- NB: the hash digest tuple in the second argument is the base16 -- encoded hash digest plucked from the image's manifest JSON and a @@ -201,7 +207,7 @@ mkFetchDockerLayers :: Binding NExpr -> [(Base16Digest, Base32Digest)] -> [Bindi mkFetchDockerLayers inherits layerDigests = fmap mkFetchLayer $ Prelude.zip [0..(Prelude.length layerDigests)] layerDigests where - mkLayerId i = T.pack $ "layer" <> show i + mkLayerId i = Text.pack $ "layer" <> show i mkFetchLayer (i, ((Base16Digest d16), (Base32Digest d32))) = (mkLayerId i) $= mkApp (mkSym constFetchDockerLayer) (Fix $ NSet diff --git a/src/Data/Docker/Nix/Lib.hs b/src/Data/Docker/Nix/Lib.hs index 96ff9dc..08f3274 100644 --- a/src/Data/Docker/Nix/Lib.hs +++ b/src/Data/Docker/Nix/Lib.hs @@ -15,43 +15,48 @@ module Data.Docker.Nix.Lib where -import Control.Foldl as Foldl +import Control.Foldl as Foldl import Turtle import Control.Monad.Except as Except -import qualified Data.Text as T +import qualified Data.Text as Text import Types import Types.Exceptions --- | Convert a @Base16Digest@ to a @Base32Digest@ using the supplied --- `nix-hash` utility. +-- | Convert a 'Base16Digest' to a 'Base32Digest' using the @nix-hash@ +-- utility. -- -- NB: Nix implements its own custom base32 encoding function for -- hashes that is not compatible with other more standard and native --- implementations in Haskell. I opted to call out to `nix-hash` --- instead of re-implementing their algorithm here in Haskell because --- it's non-standard and may change, creating a maintenance headache --- and "surprise" behavior for users. +-- implementations in Haskell. I opted to call out to @nix-hash@ +-- instead of re-implementing their algorithm because it's +-- non-standard and may change, creating a maintenance headache and +-- surprise behavior. toBase32Nix :: (MonadIO m, Except.MonadError HockerException m) - => Prelude.FilePath -- ^ Path to the `nix-hash` executable, see @Lib.findExec@. - -> Base16Digest -- ^ @Base16@ hash digest to @Base32@ encode. + => Prelude.FilePath -- ^ Path to the @nix-hash@ executable, see 'Lib.findExec' + -> Base16Digest -- ^ 'Base16Digest' to @base32@ encode -> m Base32Digest -toBase32Nix nixhash (Base16Digest d16) = +toBase32Nix nixhash (Base16Digest d16) = do + let hockerExc m = HockerException m Nothing Nothing + let convertDigest = + inprocWithErr + (Text.pack nixhash) + [ "--type" + , "sha256" + , "--to-base32" + , d16 + ] + Turtle.empty + Turtle.fold convertDigest Foldl.head >>= \case - Nothing -> throwError $ HockerException "nothing was returned by `nix-hash', not even an error" Nothing Nothing + Nothing -> + throwError + (HockerException + "nothing was returned by `nix-hash', not even an error" + Nothing + Nothing) Just result -> either - (throwError . hockerExc . T.unpack . lineToText) + (throwError . hockerExc . Text.unpack . lineToText) (return . Base32Digest . lineToText) result - where - hockerExc m = HockerException m Nothing Nothing - convertDigest = - inprocWithErr - (T.pack nixhash) - [ "--type" - , "sha256" - , "--to-base32" - , d16 - ] - Turtle.empty diff --git a/src/Lib.hs b/src/Lib.hs index c61da98..31e9ce4 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -27,10 +27,10 @@ import qualified Data.Aeson.Encode.Pretty as AP import Data.Aeson.Lens import qualified Data.ByteString.Char8 as C8 import Data.ByteString.Lazy.Char8 as C8L -import Data.Char import Data.Coerce import Data.Monoid -import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) import qualified Network.Wreq as Wreq import Nix.Expr (NExpr) @@ -44,17 +44,16 @@ import Text.PrettyPrint.ANSI.Leijen as Text.PrettyPrint (SimpleDoc, renderPretty) import URI.ByteString -import Data.Docker.Image.V1.Types - +import Data.Docker.Image.Types import Types import Types.Exceptions import Types.ImageName import Types.ImageTag --- | Throw a @userError@, exiting the program with the supplied +-- | Throw a 'userError', exiting the program with the supplied -- message. -die :: MonadIO io => T.Text -> io a -die = liftIO . throwIO . userError . T.unpack +die :: MonadIO io => Text -> io a +die = liftIO . throwIO . userError . Text.unpack -- | Print an error message to stderr and return a non-zero exit code, -- the message is prefixed with the name of the program. @@ -63,57 +62,67 @@ exitProgFail msg = do name <- getProgName Exit.die $ name ++ ": " ++ msg --- | Writes a bytestring to the provided filesystem path if it --- @isJust@ and prints the path it wrote to the screen, otherwise --- print the entire contents to the screen. +-- | Print the bytestring to stdout if the first argument is +-- @Nothing@, otherwise write the bytestring to the provided +-- filesystem path and print the path to stdout. writeOrPrint :: Maybe FilePath -> C8L.ByteString -> IO () -writeOrPrint o r = case o of - Just p' -> C8L.writeFile p' r >> Prelude.putStrLn p' - Nothing -> C8L.putStrLn r +writeOrPrint filepath content = maybe (C8L.putStrLn content) writeContent filepath + where + writeContent p = C8L.writeFile p content >> Prelude.putStrLn p --- | Make a path given a base path and a docker container name. -mkOutImage :: ImageName -> FilePath -> FilePath +-- | Combine an image name and a base path producing an output path. +mkOutImage :: ImageName -- ^ Docker image name + -> FilePath -- ^ Base path to write to + -> FilePath mkOutImage n o = o (takeBaseName $ coerce n) --- | Make a path given a base path, a docker container name, and a --- docker container tag appending "-config.json" to the basename. -mkOutConfig :: ImageName -> ImageTag -> FilePath -> FilePath +-- | Combine an image name, an image tag, and a base path producing an +-- output path with a @-config.json@ suffix. +mkOutConfig :: ImageName -- ^ Docker image name + -> ImageTag -- ^ Docker image tag + -> FilePath -- ^ Base path to write to + -> FilePath mkOutConfig n t o = o Prelude.concat [ (takeBaseName $ coerce n) , "_", coerce t , "-config.json" ] --- | Make a path given a base path, a docker container name, and a --- docker container tag appending "-manifest.json" to the basename. -mkOutManifest :: ImageName -> ImageTag -> FilePath -> FilePath +-- | Combine an image name, an image tag, and a base path producing an +-- output path with a @-manifest.json@ suffix. +mkOutManifest :: ImageName -- ^ Docker image name + -> ImageTag -- ^ Docker image tag + -> FilePath -- ^ Base path to write to + -> FilePath mkOutManifest n t o = o Prelude.concat [ (takeBaseName $ coerce n) , "_", coerce t , "-manifest.json" ] --- | Safely join a list of strings and a Network.URI record together --- using @joinPath@. -joinURIPath :: [String] -> RegistryURI -> RegistryURI +-- | Join a list of strings and the path part of a 'RegistryURI' to +-- produce a new 'RegistryURI' with a path root of @/v2@. +joinURIPath :: [String] -- ^ Extra path segments to add + -> RegistryURI -- ^ Base URI to add path segments to + -> RegistryURI joinURIPath pts uri@URI{..} = uri { uriPath = joinedParts } where joinedParts = C8.pack $ File.joinPath ("/":"v2":(C8.unpack uriPath):pts) --- | Produce an @Wreq.Options@ using @Network.Wreq.defaults@ and an @Auth@. +-- | Given a 'Wreq.Auth' produce a 'Wreq.Options'. opts :: Maybe Wreq.Auth -> Wreq.Options opts bAuth = Wreq.defaults & Wreq.auth .~ bAuth --- | Hash a @Data.ByteString.Lazy.Char8@ using the SHA256 algorithm. +-- | Hash a 'Data.ByteString.Lazy.Char8' using the 'Hash.SHA256' +-- algorithm. sha256 :: C8L.ByteString -> Hash.Digest Hash.SHA256 sha256 = Hash.hashlazy --- | Strip the hash algorithm identifier prefix from the beginning of --- a hash digest string; e.g: "sha256:" becomes "". -stripHashId :: T.Text -> T.Text -stripHashId = snd . T.breakOnEnd ":" +-- | Strip the @sha256:@ identifier prefix from a hash digest. +stripHashId :: Text -> Text +stripHashId = snd . Text.breakOnEnd ":" --- | Encode, following Docker's canonical JSON rules, any @ToJSON@ +-- | Encode, following Docker's canonical JSON rules, any 'ToJSON' -- data type. -- -- The canonicalization rules enable consistent hashing of encoded @@ -127,24 +136,22 @@ stripHashId = snd . T.breakOnEnd ":" encodeCanonical :: Data.Aeson.ToJSON a => a -> C8L.ByteString encodeCanonical = AP.encodePretty' conf where - -- NB: the spec requires keys to be in lexically sorted order and - -- it appears that the Ord instance of @Text@ behaves the same way - -- the Ord instance for @String@ does: it sorts lexically. conf = AP.defConfig { AP.confIndent = AP.Spaces 0, AP.confCompare = compare } --- | Throw an error if `Maybe FilePath` is `Nothing`, otherwise return --- the @FilePath@ unwrapped. -requireOutPath :: (Except.MonadError HockerException m) +-- | Throw an error if the first argument is @Nothing@, otherwise +-- return the @FilePath@ unwrapped. +requirePath :: (Except.MonadError HockerException m) => Maybe FilePath -> m (FilePath) -requireOutPath = maybe outPathError return +requirePath = maybe pathError pure where - outPathError = Except.throwError $ - hockerException "To fetch and assemble a docker image, `--out=` must be supplied" + pathError = + Except.throwError + (hockerException "To fetch and assemble a docker image, '--out=' must be supplied") --- | Pluck the digest value for the config JSON given a docker +-- | Pluck out the digest value for the config JSON given a docker -- registry image manifest. Attempting to parse and return the digest --- value as a `Digest SHA256`, otherwise throwing an error. +-- value as a 'Hash.SHA256', otherwise throw an error. getConfigDigest :: (Except.MonadError HockerException m) => C8L.ByteString -> m (Hash.Digest Hash.SHA256) @@ -154,29 +161,23 @@ getConfigDigest (view (key "config" . key "digest" . _String) -> digest) = parsedDigest = toDigest $ encodeUtf8 digest badDigest = Except.throwError $ hockerException "Failed parsing the config hash digest" --- | @upperFirst@ uppercases the first letter of the string. -upperFirst :: String -> String -upperFirst [] = [] -upperFirst (h:t) = toUpper h : t + -- | Split a docker image's name on the forward slash separator so we -- get the distinct repo name and image name. -splitImgName :: ImageName -> (RepoNamePart, ImageNamePart) -splitImgName (ImageName (T.pack -> n)) = over _2 T.tail $ T.break (=='/') n +splitRepository :: ImageName -> (RepoNamePart, ImageNamePart) +splitRepository (ImageName (Text.pack -> n)) = over _2 Text.tail $ Text.break (=='/') n --- | Pretty print a Nix expression and return a --- @Text.PrettyPrint.SimpleDoc@, this can in turn be displayed to the --- screen using @Text.PrettyPrint.displayIO@ or transformed into a --- string using @Text.PrettyPrint.displayS@. +-- | Given a nix expression AST, produce a pretty printer document. renderNixExpr :: NExpr -> Text.PrettyPrint.SimpleDoc renderNixExpr = renderPretty 0.4 120 . prettyNix --- | Pretty print a Nix expression AST and print to stdout. +-- | Print a nix expression AST using the 'renderNixExpr' pretty +-- printing renderer. pprintNixExpr :: NExpr -> IO () pprintNixExpr expr = Prelude.putStrLn (displayS (renderNixExpr expr) "") --- | Given an executable's name, try to find it in the current --- process's PATH context. +-- | Given an executable's name, try to find it in the PATH. findExec :: (MonadIO m, Except.MonadError HockerException m) => String -> m Prelude.FilePath diff --git a/src/Network/Wreq/Docker/Image.hs b/src/Network/Wreq/Docker/Image.hs new file mode 100644 index 0000000..d599f23 --- /dev/null +++ b/src/Network/Wreq/Docker/Image.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Network.Wreq.Docker.Image +-- Copyright : (C) 2016 Awake Networks +-- License : Apache-2.0 +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Network.Wreq.Docker.Image where + + +import Control.Lens +import Control.Monad +import Control.Monad.Except +import Control.Monad.Reader +import Data.ByteString.Lazy.Char8 as C8L +import Data.Coerce +import Data.Either +import Data.HashSet as Set +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as Text +import NeatInterpolation +import qualified Network.Wreq as Wreq +import System.FilePath.Posix as File +import System.Terminal.Concurrent + +import Data.Docker.Image.Types +import Lib + +import Network.Wreq.Docker.Image.Lib as Docker.Image +import Network.Wreq.Docker.Registry as Docker.Registry +import Types +import Types.Exceptions +import Types.ImageName + +-- | Fetch an image from the docker registery, assembling the +-- artifacts into a Docker V1.2 Image. +fetchImage :: HockerMeta -> IO (Either HockerException Text) +fetchImage = + runHocker $ ask >>= \HockerMeta{..} -> do + imageOutDir <- Lib.requirePath outDir + manifest <- fetchManifest >>= checkResponseIntegrity' + configDigest <- getConfigDigest $ manifest ^. Wreq.responseBody + + -- TODO: use Managed + + -- Fetch and write the configuration json file for the image + let configFileHash = Lib.stripHashId . Text.pack $ showSHA configDigest + imageConfig <- fetchImageConfig configDigest + imageConfigFile <- writeRespBody + (File.joinPath [imageOutDir, Text.unpack configFileHash] `addExtension` "json") + configFileHash + imageConfig + + let refLayers = pluckRefLayersFrom $ imageConfig ^. Wreq.responseBody + refLayers' = fmap Lib.stripHashId refLayers + refLayerSet = Set.fromList refLayers' + manifestLayers = pluckLayersFrom $ manifest ^. Wreq.responseBody + (_, strippedReg) = Text.breakOnEnd "//" . Text.pack . show $ dockerRegistry + repoTags = (Text.unpack strippedReg) (coerce imageName) + + -- Concurrently fetch layers and write to disk with a limit of three + -- threads + layers <- mapPool 3 Docker.Image.fetchLayer $ Prelude.zip refLayers' manifestLayers + + let writtenLayerSet = Set.fromList . fmap (Text.pack . takeBaseName) $ rights layers + refLayerSetTxt = Text.pack (show refLayerSet) + wrtLayerSetTxt = Text.pack (show writtenLayerSet) + dffLayerSetTxt = Text.pack (show $ Set.difference refLayerSet writtenLayerSet) + + when (writtenLayerSet /= refLayerSet) $ + throwError . hockerException $ Text.unpack + ([text| +Written layers do not match the reference layers! + +Reference layers: ${refLayerSetTxt} +Written layers: ${wrtLayerSetTxt} + +Difference: ${dffLayerSetTxt} +|]) + + createImageRepository repoTags refLayers' + createImageManifest repoTags imageConfigFile refLayers' + + archivePath <- createImageTar + + return (Text.pack archivePath) + +-- | Fetch a layer using its digest key from the docker registery. +fetchLayer :: HockerMeta -> IO (Either HockerException FilePath) +fetchLayer = + runHocker $ ask >>= \HockerMeta{..} -> do + layerOut <- Lib.requirePath out + layerDigest <- Text.pack . show <$> maybe + (throwError $ hockerException + "a layer digest is expected!") + return + imageLayer + + let shortRef = Text.take 7 layerDigest + + writeC <- liftIO $ getConcurrentOutputter + liftIO . writeC . Text.unpack $ "Downloading layer: " <> shortRef + + fetchedImageLayer <- checkResponseIntegrity' =<< Docker.Registry.fetchLayer ("sha256:" <> layerDigest) + layerPath <- writeRespBody layerOut layerDigest fetchedImageLayer + + liftIO . writeC $ Text.unpack ("=> wrote " <> shortRef) + + return layerPath + +-- | Fetch the configuration JSON file of the specified image from the +-- docker registry. +fetchConfig :: HockerMeta -> IO (Either HockerException C8L.ByteString) +fetchConfig = + runHocker $ ask >>= \HockerMeta{..} -> do + configDigest <- + fetchManifest + >>= checkResponseIntegrity' + >>= getConfigDigest . view Wreq.responseBody + + fetchImageConfig configDigest + >>= return . view Wreq.responseBody + +-- | Fetch the docker registry manifest JSON file for the specified +-- image from the docker registry.. +fetchImageManifest :: HockerMeta -> IO (Either HockerException C8L.ByteString) +fetchImageManifest = runHocker (fetchManifest >>= return . view Wreq.responseBody) diff --git a/src/Network/Wreq/Docker/Image/Lib.hs b/src/Network/Wreq/Docker/Image/Lib.hs index bd0b0d6..04f1559 100644 --- a/src/Network/Wreq/Docker/Image/Lib.hs +++ b/src/Network/Wreq/Docker/Image/Lib.hs @@ -31,16 +31,16 @@ import qualified System.Directory as Directory import System.FilePath.Posix as File import System.Terminal.Concurrent -import Data.Docker.Image.V1_2.Types +import Data.Docker.Image.Types import Lib -import Network.Wreq.Docker.Registry.V2 as Docker.Registry +import Network.Wreq.Docker.Registry as Docker.Registry import Types import Types.Exceptions import Types.ImageTag --- | Like @mapM@ but concurrently applies a function to the elements --- of the @Traversable@, limiting the maximum number of worker threads --- by *n*. +-- | 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 @@ -69,7 +69,7 @@ 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 the hash digest from the image's manifest JSON + -> (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') @@ -79,7 +79,7 @@ fetchLayer writeC layer@(refl, (stripHashId -> layer')) = ask >>= \HockerMeta{.. let decompressed = fetchedImageLayer & Wreq.responseBody %~ GZip.decompress shortRef = Text.take 7 refl - imageOutDir <- Lib.requireOutPath outDir + imageOutDir <- Lib.requirePath outDir liftIO $ writeC " => decompressed " @@ -101,14 +101,14 @@ createImageManifest repoTag imageConfigFile refls = ask >>= \HockerMeta{..} -> d (takeBaseName imageConfigFile `addExtension` "json") [Text.pack (repoTag ++ ":" ++ coerce imageTag)] (fmap ((`addExtension` "tar") . Text.unpack) refls) ] - imageOutDir <- Lib.requireOutPath outDir + imageOutDir <- Lib.requirePath outDir liftIO $ C8L.writeFile (imageOutDir "manifest" `addExtension` "json") (Lib.encodeCanonical imageManifest) -- | Generate a @repositories@ json file. -- --- NB: it is JSON but Docker doesn't want it with a JSON extension +-- 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 @@ -125,7 +125,7 @@ createImageRepository repoTag refls = ask >>= \HockerMeta{..} -> do (HashMap.singleton (Text.pack $ coerce imageTag) ((Prelude.last refls) <> ".tar")) - imageOutDir <- Lib.requireOutPath outDir + imageOutDir <- Lib.requirePath outDir liftIO $ C8L.writeFile (imageOutDir "repositories") (Lib.encodeCanonical repositories) @@ -134,8 +134,8 @@ createImageRepository repoTag refls = ask >>= \HockerMeta{..} -> do -- and remove the output dir. createImageTar :: Hocker FilePath createImageTar = ask >>= \HockerMeta{..} -> do - imageOutDir <- Lib.requireOutPath outDir - archivePath <- Lib.requireOutPath out + imageOutDir <- Lib.requirePath outDir + archivePath <- Lib.requirePath out entries <- liftIO $ Directory.getDirectoryContents imageOutDir diff --git a/src/Network/Wreq/Docker/Image/V1_2.hs b/src/Network/Wreq/Docker/Image/V1_2.hs deleted file mode 100644 index c6ca1de..0000000 --- a/src/Network/Wreq/Docker/Image/V1_2.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- | --- Module : Network.Wreq.Docker.Image.V1_2 --- Copyright : (C) 2016 Awake Networks --- License : Apache-2.0 --- Maintainer : Awake Networks --- Stability : stable ----------------------------------------------------------------------------- - -module Network.Wreq.Docker.Image.V1_2 where - - -import Control.Lens -import Control.Monad -import Control.Monad.Except -import Control.Monad.Reader -import Data.ByteString.Lazy.Char8 as C8L -import Data.Coerce -import Data.Either -import Data.HashSet as Set -import Data.Monoid -import qualified Data.Text as T -import NeatInterpolation -import qualified Network.Wreq as Wreq -import System.FilePath.Posix as File -import System.Terminal.Concurrent - -import Data.Docker.Image.V1.Types -import Lib - -import Network.Wreq.Docker.Image.Lib as Docker.Image -import Network.Wreq.Docker.Registry.V2 as Docker.Registry -import Types -import Types.Exceptions -import Types.ImageName - --- | Fetches an image from the specified (or default) V2 Docker --- Registery and assembles the artifacts into a compatible Docker V1.2 --- Image. -fetchAndAssemble :: HockerMeta -> IO (Either HockerException T.Text) -fetchAndAssemble = runHocker doFetchImage - --- | Fetches a layer by its digest key from the specified (or default) --- V2 Docker Registery. -fetchLayer :: HockerMeta -> IO (Either HockerException FilePath) -fetchLayer = runHocker doFetchLayer - --- | Fetches the config file of the specified image from the specified --- (or default) V2 Docker Registry and returns it. -fetchConfig :: HockerMeta -> IO (Either HockerException C8L.ByteString) -fetchConfig = runHocker doFetchConfig - --- | Fetches the manifest file of the specified image from the --- specified (or default) V2 Docker Registry and returns it. -fetchImageManifest :: HockerMeta -> IO (Either HockerException C8L.ByteString) -fetchImageManifest = runHocker doFetch - where - doFetch = fetchManifest >>= return . view Wreq.responseBody - --- | Executes the monadic logic for fetching the docker image config --- JSON within the ReaderT monad. -doFetchConfig :: Hocker C8L.ByteString -doFetchConfig = ask >>= \HockerMeta{..} -> do - configDigest <- - fetchManifest - >>= checkResponseIntegrity' - >>= getConfigDigest . view Wreq.responseBody - - fetchImageConfig configDigest - >>= return . view Wreq.responseBody - --- | Executes the monadic logic for fetching and saving a layer tar --- archive. -doFetchLayer :: Hocker FilePath -doFetchLayer = ask >>= \HockerMeta{..} -> do - layerOut <- Lib.requireOutPath out - - layerDigest <- T.pack . show <$> maybe - (throwError $ hockerException - "a layer digest is expected!") - return - imageLayer - - let shortRef = T.take 7 layerDigest - - writeC <- liftIO $ getConcurrentOutputter - liftIO . writeC . T.unpack $ "Downloading layer: " <> shortRef - - fetchedImageLayer <- checkResponseIntegrity' =<< Docker.Registry.fetchLayer ("sha256:" <> layerDigest) - layerPath <- writeRespBody layerOut layerDigest fetchedImageLayer - - liftIO . writeC $ T.unpack ("=> wrote " <> shortRef) - - return layerPath - --- | Executes the monadic logic for fetching, transforming, and --- assembling a docker container image. -doFetchImage :: Hocker T.Text -doFetchImage = ask >>= \HockerMeta{..} -> do - imageOutDir <- Lib.requireOutPath outDir - - manifest <- fetchManifest >>= checkResponseIntegrity' - configDigest <- getConfigDigest $ manifest ^. Wreq.responseBody - - -- TODO: ALL of the below steps that handle saving things to the - -- disk should probably be wrapped in a bracket function responsible - -- for cleaning up any partially written data if there's a - -- failure... Or perhaps instad of bracketing in here, we bracket - -- around the @runExceptT@? - - -- Fetch and write the configuration json file for the image - let configFileHash = Lib.stripHashId . T.pack $ showSHA configDigest - imageConfig <- fetchImageConfig configDigest - imageConfigFile <- writeRespBody - (File.joinPath [imageOutDir, T.unpack configFileHash] `addExtension` "json") - configFileHash - imageConfig - - let refLayers = pluckRefLayersFrom $ imageConfig ^. Wreq.responseBody - refLayers' = fmap Lib.stripHashId refLayers - refLayerSet = Set.fromList refLayers' - manifestLayers = pluckLayersFrom $ manifest ^. Wreq.responseBody - (_, strippedReg) = T.breakOnEnd "//" . T.pack . show $ dockerRegistry - repoTags = (T.unpack strippedReg) (coerce imageName) - - -- Concurrently fetch layers and write to disk with a limit of three - -- threads - layers <- mapPool 3 Docker.Image.fetchLayer $ Prelude.zip refLayers' manifestLayers - - let writtenLayerSet = Set.fromList . fmap (T.pack . takeBaseName) $ rights layers - refLayerSetTxt = T.pack (show refLayerSet) - wrtLayerSetTxt = T.pack (show writtenLayerSet) - dffLayerSetTxt = T.pack (show $ Set.difference refLayerSet writtenLayerSet) - - when (writtenLayerSet /= refLayerSet) $ - throwError . hockerException $ T.unpack - ([text| - Written layers do not match the reference layers! - - Reference layers: ${refLayerSetTxt} - Written layers: ${wrtLayerSetTxt} - - Difference: ${dffLayerSetTxt} - |]) - - createImageRepository repoTags refLayers' - createImageManifest repoTags imageConfigFile refLayers' - - archivePath <- createImageTar - - return $ T.pack archivePath diff --git a/src/Network/Wreq/Docker/Registry/V2.hs b/src/Network/Wreq/Docker/Registry.hs similarity index 78% rename from src/Network/Wreq/Docker/Registry/V2.hs rename to src/Network/Wreq/Docker/Registry.hs index 227d495..23437f3 100644 --- a/src/Network/Wreq/Docker/Registry/V2.hs +++ b/src/Network/Wreq/Docker/Registry.hs @@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | --- Module : Network.Wreq.Docker.Registry.V2 +-- Module : Network.Wreq.Docker.Registry -- Copyright : (C) 2016 Awake Networks -- License : Apache-2.0 -- Maintainer : Awake Networks @@ -22,7 +22,7 @@ -- software is "docker distribution". ---------------------------------------------------------------------------- -module Network.Wreq.Docker.Registry.V2 where +module Network.Wreq.Docker.Registry where import Control.Lens import qualified Control.Monad.Except as Except @@ -39,14 +39,14 @@ import qualified Data.Text as Text import qualified Network.Wreq as Wreq import System.Directory -import Data.Docker.Image.V1.Types +import Data.Docker.Image.Types import Lib import Types import Types.Exceptions import Types.ImageName import Types.ImageTag --- | Default docker hub registry. +-- | Default docker hub registry (@https://registry-1.docker.io/v2/@). defaultRegistry :: URIRef Absolute defaultRegistry = URI { uriScheme = Scheme "https" @@ -60,9 +60,22 @@ defaultRegistry = URI , uriFragment = Nothing } -mkAuth :: RegistryURI - -> ImageName - -> Maybe Credentials +-- | Given 'Credentials', produce a 'Wreq.Auth'. +-- +-- If 'Credentials' is either 'BearerToken' or 'Basic' then produce a +-- 'Wreq.Auth' value for that type of credential. +-- +-- If @Nothing@ is provided _and_ the provided 'RegistryURI' matches +-- the default registry, make a request to +-- @https://auth.docker.io/token@ for a temporary pull-only bearer +-- token, assuming the request we want to make is to the public docker +-- hub and without any other credentials. +-- +-- Otherwise, return 'Nothing' so that an unauthenticated request can +-- be made. +mkAuth :: RegistryURI -- ^ Docker registry + -> ImageName -- ^ Docker image name + -> Maybe Credentials -- ^ Docker registry authentication credentials -> IO (Maybe Wreq.Auth) mkAuth reg (ImageName img) credentials = case credentials of @@ -78,21 +91,22 @@ mkAuth reg (ImageName img) credentials = getHubToken = Wreq.get ("https://auth.docker.io/token?service=registry.docker.io&scope=repository:"<>img<>":pull") mkHubBearer rsp = (Wreq.oauth2Bearer . encodeUtf8) <$> (rsp ^? Wreq.responseBody . key "token" . _String) --- | Retrieve a list of layer hash digests from an image's manifest --- JSON. +-- | Retrieve a list of layer hash digests from a docker registry +-- image manifest JSON. -- -- TODO: pluck out the layer's size and digest into a tuple. pluckLayersFrom :: Manifest -> [Layer] pluckLayersFrom = toListOf (key "layers" . values . key "digest" . _String) --- | Retrieve a list of layer hash digests from an image's config --- JSON. +-- | Retrieve a list of layer hash digests from an image's +-- configuration JSON. -- --- This is subtly different from @pluckLayersFrom@ because both list +-- This is subtly different from 'pluckLayersFrom' because both list -- hash digests for the image's layers but the manifest's layer hash --- digests are keys into the registry's blob storage referencing the --- *compressed* layer archive. The config JSON's layer hash digests --- reference the uncompressed layer tar archives within the image. +-- digests are keys into the registry's blob storage referencing +-- _compressed_ layer archives. The configuration JSON's layer hash +-- digests reference the uncompressed layer tar archives within the +-- image. pluckRefLayersFrom :: ImageConfigJSON -> [Layer] pluckRefLayersFrom = toListOf (key "rootfs" . key "diff_ids" . values . _String) @@ -110,8 +124,8 @@ fetchManifest = ask >>= \HockerMeta{..} -> , "application/vnd.docker.distribution.manifest.list.v2+json" ] --- | Retrieve the config json of an image by its hash digest (found in --- the V2 manifest for an image given by a name and tag). +-- | Retrieve the configuratino JSON of an image by its hash digest +-- (found in the V2 manifest for an image given by a name and a tag). fetchImageConfig :: (Hash.Digest Hash.SHA256) -> Hocker RspBS fetchImageConfig (showSHA -> digest) = ask >>= \HockerMeta{..} -> liftIO $ Wreq.getWith (opts auth) (mkURL imageName dockerRegistry) @@ -132,33 +146,32 @@ fetchLayer layer = ask >>= \HockerMeta{..} -> registry = C8.unpack (serializeURIRef' $ joinURIPath [name, "blobs", digest] registry) --- | Write a @Wreq@ response body to the specified @FilePath@, --- checking the integrity of the file with its sha256 hash digest. +-- | Write a 'Wreq.responseBody' to the specified 'FilePath', checking +-- the integrity of the file with its sha256 hash digest. -- --- The second argument, the @StrippedDigest@, must be a hash digest --- stripped of the "sha256:" hash algorithm identifier prefix. +-- The second argument, the 'StrippedDigest', must be a hash digest +-- stripped of the @sha256:@ algorithm identifier prefix. writeRespBody :: FilePath -- ^ Filesystem path to write the content to - -> StrippedDigest -- ^ Hash digest, stripped of its hash algorithm identifier prefix - -> RspBS -- ^ Wreq lazy bytestring response object + -> StrippedDigest -- ^ Hash digest, stripped of its algorithm identifier prefix + -> RspBS -- ^ Wreq lazy bytestring response object -> Hocker FilePath writeRespBody out digest resp = do liftIO . C8L.writeFile out $ resp ^. Wreq.responseBody - - -- Now, verify the file; we assume the sha256 function since that is - -- used everywhere - verified <- liftIO $ checkFileIntegrity out digest + verified <- liftIO (checkFileIntegrity out digest) either (Except.throwError . hockerException) return verified -- | Write a response to the filesystem without a request hash --- digest. Attempt to fetch the value of the `ETag` header to verify +-- digest. Attempt to fetch the value of the @ETag@ header to verify -- the integrity of the content received. -- --- The Docker docs do *not* recommended this method for verification --- because the ETag and Docker-Content-Digest headers may change +-- The Docker docs do _not_ recommended this method for verification +-- because the @ETag@ and @Docker-Content-Digest@ headers may change -- between the time you issue a request with a digest and when you -- receive a response back! +-- +-- We do it anyway and leave this warning. writeRespBody' :: FilePath -- ^ Filesystem path to write the content to - -> RspBS -- ^ Wreq lazy bytestring response object + -> RspBS -- ^ Wreq lazy bytestring response object -> Hocker FilePath writeRespBody' out r = writeRespBody out etagHash r where @@ -224,8 +237,7 @@ checkFileIntegrity fp digest = fpTxt = Text.pack fp in fail $ Text.unpack ([text| - The sha256 hash for $fpTxt: $fhTxt - Does not match the expected digest: $digest - |]) - +The sha256 hash for $fpTxt: $fhTxt +Does not match the expected digest: $digest +|]) return fp diff --git a/src/Types.hs b/src/Types.hs index c046c41..2f4acc4 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -30,6 +30,7 @@ import qualified Control.Monad.Reader as Reader import Control.Monad.Reader.Class import qualified Crypto.Hash as Hash import qualified Data.ByteString.Lazy +import Data.Char (toUpper) import Data.Monoid import Data.Text (Text) import qualified Data.Text as Text @@ -186,3 +187,8 @@ instance ParseField Credentials where instance ParseFields Credentials instance ParseRecord Credentials where parseRecord = fmap Options.Generic.getOnly parseRecord + +-- | @upperFirst@ uppercases the first letter of the string. +upperFirst :: String -> String +upperFirst [] = [] +upperFirst (h:t) = toUpper h : t diff --git a/test/Main.hs b/test/Main.hs index 240f883..1f5c78c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -4,8 +4,7 @@ module Main where import Test.Tasty import Test.Tasty.HUnit -import qualified Tests.Data.Docker.Image.V1 as ImageV1Tests -import qualified Tests.Data.Docker.Image.V1_2 as ImageV1_2Tests +import qualified Tests.Data.Docker.Image as Docker.Image import qualified Tests.Data.Docker.Nix.FetchDocker as FetchDockerTests main :: IO () @@ -13,7 +12,6 @@ main = defaultMain tests tests :: TestTree tests = testGroup "Tests" - [ ImageV1Tests.unitTests - , ImageV1_2Tests.unitTests + [ Docker.Image.unitTests , FetchDockerTests.tests ] diff --git a/test/Tests/Data/Docker/Image/V1_2.hs b/test/Tests/Data/Docker/Image.hs similarity index 92% rename from test/Tests/Data/Docker/Image/V1_2.hs rename to test/Tests/Data/Docker/Image.hs index 72a22f2..1605392 100644 --- a/test/Tests/Data/Docker/Image/V1_2.hs +++ b/test/Tests/Data/Docker/Image.hs @@ -4,19 +4,19 @@ ----------------------------------------------------------------------------- -- | --- Module : Data.Docker.Image.V1_2 +-- Module : Data.Docker.Image -- Copyright : (C) 2016 Awake Networks -- License : Apache-2.0 -- Maintainer : Awake Networks -- Stability : stable ---------------------------------------------------------------------------- -module Tests.Data.Docker.Image.V1_2 where +module Tests.Data.Docker.Image where import Data.Aeson -import qualified Data.ByteString.Lazy.Char8 as C8L -import Data.Docker.Image.V1_2.Types -import Data.HashMap.Strict as H +import qualified Data.ByteString.Lazy.Char8 as C8L +import Data.Docker.Image.Types +import Data.HashMap.Strict as H import Test.Tasty import Test.Tasty.HUnit diff --git a/test/Tests/Data/Docker/Image/V1.hs b/test/Tests/Data/Docker/Image/V1.hs deleted file mode 100644 index d6ea8f3..0000000 --- a/test/Tests/Data/Docker/Image/V1.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Docker.Image.V1 --- Copyright : (C) 2016 Awake Networks --- License : Apache-2.0 --- Maintainer : Awake Networks --- Stability : stable ----------------------------------------------------------------------------- - -module Tests.Data.Docker.Image.V1 where - -import qualified Crypto.Hash as Hash -import qualified Data.ByteString.Char8 as C8 -import Data.Docker.Image.V1.Layer -import Data.Docker.Image.V1.Types -import Data.Maybe -import Data.Sequence as Seq - -import Test.Tasty -import Test.Tasty.HUnit - -import Lib - -unitTests = testGroup "V1 Image Tests" - [ testCase "Digest (De)Serialization" testDigest - , testCase "Handle bad digest" testBadDigest1 - , testCase "Handle bad digest" testBadDigest2 - , testCase "Digest == ChainID" testChainID - , testCase "Digest == DiffID" testDiffID - , testCase "ChainID sequence generation" testChainIDGeneration - ] - -mkHash = Lib.sha256 "somestring" - --- DiffID sequence from a real Docker Image. -diffIds :: Seq DiffID -diffIds = fromList $ fmap (DiffID . fromJust . toDigest) - [ "sha256:f96222d75c5563900bc4dd852179b720a0885de8f7a0619ba0ac76e92542bbc8" - , "sha256:149636c850120e59e6bb79f2fc23ed423030afc73841c221906a147d61da11a9" - , "sha256:33c3a104206aed2ae947e03c48cc011af0a3e5b87e7ba8e7cbc298273a638921" - , "sha256:2681a05b8f8288a384dbddf0b899ec9d2bea3ee265f1678230d0bdac6dc13da1" - , "sha256:dcfda398b984bb5a55e1932079b6cc4823e433bd6c962f9667eaf28b0f1fe7e0" - , "sha256:2a182bf72d68b9c7cb76be0f9dcadd047088ae6f8cb85e7ac9661f68537acccd" - , "sha256:647af69f55fd5fdc27db7b6aa51945aec53b0b03d17095e79b4c69c6432195c7" - , "sha256:c7ef4827bb9592e9788c1cc49e3db4e265c12f49c9b1f6c9bb99551eb5189020" - , "sha256:f9361c1f9b1eb2d93709546fe6ad48786cea55c03c4e52d3f1cdb341e0d398da" - ] - --- Pre-computed golden result produced by a valid Python --- implementation of the ChainID sequence generation logic. -preComputedChainIds :: Seq ChainID -preComputedChainIds = fromList $ fmap (ChainID . fromJust . toDigest) - [ "sha256:f96222d75c5563900bc4dd852179b720a0885de8f7a0619ba0ac76e92542bbc8" - , "sha256:5e6f832cd2df18460af48ed117c5b63bc2189971c9346e6d952376b5a8ba74ff" - , "sha256:19947c09eddb9dab0d1b938660cd72ea4bb8f0f24c604cf9e1d9b14772d7bd6d" - , "sha256:b0fbea1a99ec834d59e524733f1be81f1dce325dbe9df58bba5dec7014b386c8" - , "sha256:262faf2cc4db81d3bcb526099b7dc33069b24f4028a9a23d46edca2493077ce0" - , "sha256:ac07dba5e07787c2a10edc3f8d8052f38cb5bec6767520bbab4289cb55b3a3f4" - , "sha256:c781557b490e1e8ff2132af386abe2a9c2d3cb66df06ee2cbd489d869432328a" - , "sha256:ff275e52e374819094e8035459820bf8e5fc42f287f603b445a8aee7aba2b689" - , "sha256:ffd859ffb35598eeec1283f3ccb3633f2798c042343425f635d616633cf63c2b" - ] - -testDigest = - let digest = mkHash - digestStr = showSHA digest - in toDigest (C8.pack digestStr) @?= (Just digest) - -testBadDigest1 = toDigest "ffd859ffb35598eeec1283f3ccb3633f2798c042343425f635d616633cf63c2b" @?= Nothing -testBadDigest2 = toDigest "ffd859ffb35598eeec1283f3corrupt?" @?= Nothing - -testChainID = - let digest = mkHash - in (show $ ChainID digest) @?= showSHA digest - -testDiffID = - let digest = mkHash - in (show $ DiffID digest) @?= showSHA digest - -testChainIDGeneration = - let chainIDs = squishMaybe $ chainIDSequence diffIds - in chainIDs @?= preComputedChainIds diff --git a/test/Tests/Data/Docker/Nix/FetchDocker.hs b/test/Tests/Data/Docker/Nix/FetchDocker.hs index 02d2e02..0ce0307 100644 --- a/test/Tests/Data/Docker/Nix/FetchDocker.hs +++ b/test/Tests/Data/Docker/Nix/FetchDocker.hs @@ -13,22 +13,22 @@ module Tests.Data.Docker.Nix.FetchDocker where -import Control.Exception as CE -import Control.Monad.Except as Except -import Data.ByteString.Lazy.Char8 as C8L -import Data.Either (either) -import qualified Data.Text as T +import Control.Exception as CE +import Control.Monad.Except as Except +import Data.ByteString.Lazy.Char8 as C8L +import Data.Either (either) +import qualified Data.Text as Text import Network.URI import Test.Tasty import Test.Tasty.Golden import Test.Tasty.HUnit -import Text.PrettyPrint.ANSI.Leijen as Text.PrettyPrint (displayS) +import Text.PrettyPrint.ANSI.Leijen as Text.PrettyPrint (displayS) import Data.Docker.Image.Types -import Data.Docker.Nix.FetchDocker as Nix.FetchDocker -import Data.Docker.Nix.Lib as Nix.Lib +import Data.Docker.Nix.FetchDocker as Nix.FetchDocker +import Data.Docker.Nix.Lib as Nix.Lib import Lib -import Network.Wreq.Docker.Registry.V2 as Docker.Registry +import Network.Wreq.Docker.Registry as Docker.Registry import Types import Types.ImageTag @@ -68,6 +68,6 @@ generateFetchDockerNix = do } either - (Lib.die . T.pack . show) + (Lib.die . Text.pack . show) (return . C8L.pack . (flip displayS "") . Lib.renderNixExpr) nixExpression