From 9b39e787448ea3da839c8985eeb1f205478704cf Mon Sep 17 00:00:00 2001 From: Parnell Springmeyer Date: Thu, 20 Oct 2016 15:47:41 -0500 Subject: [PATCH] Initial public release of hocker --- .gitignore | 20 ++ LICENSE | 201 +++++++++++++++++ README.md | 96 +++++++++ Setup.hs | 2 + config.nix | 46 ++++ default.nix | 39 ++++ docker2nix/Main.hs | 77 +++++++ docker2nix/README.md | 62 ++++++ hocker-config/Main.hs | 41 ++++ hocker-config/README.md | 107 ++++++++++ hocker-image/Main.hs | 44 ++++ hocker-image/README.md | 31 +++ hocker-layer/Main.hs | 72 +++++++ hocker-layer/README.md | 27 +++ hocker-manifest/Main.hs | 41 ++++ hocker-manifest/README.md | 52 +++++ hocker.cabal | 220 +++++++++++++++++++ nix/http-client-tls.nix | 19 ++ nix/http-client.nix | 27 +++ nix/optparse-applicative.nix | 15 ++ nix/optparse-generic.nix | 14 ++ nix/shell.nix | 11 + nix/turtle.nix | 20 ++ nix/wreq.nix | 34 +++ release.nix | 13 ++ src/Data/Docker/Image/AesonHelpers.hs | 18 ++ src/Data/Docker/Image/Types.hs | 52 +++++ 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 | 22 ++ src/Data/Docker/Nix/FetchDocker.hs | 224 +++++++++++++++++++ src/Data/Docker/Nix/Lib.hs | 57 +++++ src/Lib.hs | 190 +++++++++++++++++ src/Network/Wreq/Docker/Image/Lib.hs | 150 +++++++++++++ src/Network/Wreq/Docker/Image/V1_2.hs | 158 ++++++++++++++ src/Network/Wreq/Docker/Registry/V2.hs | 231 ++++++++++++++++++++ src/Network/Wreq/ErrorHandling.hs | 60 ++++++ src/Types.hs | 189 ++++++++++++++++ src/Types/Exceptions.hs | 39 ++++ src/Types/Hash.hs | 43 ++++ src/Types/ImageName.hs | 38 ++++ src/Types/ImageTag.hs | 38 ++++ src/Types/URI.hs | 44 ++++ stack.yaml | 10 + test/Main.hs | 19 ++ test/Tests/Data/Docker/Image/V1.hs | 86 ++++++++ test/Tests/Data/Docker/Image/V1_2.hs | 74 +++++++ test/Tests/Data/Docker/Nix/FetchDocker.hs | 73 +++++++ test/data/golden-debian:jessie.nix | 20 ++ test/data/manifest-debian:jessie.json | 16 ++ 51 files changed, 3647 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 config.nix create mode 100644 default.nix create mode 100644 docker2nix/Main.hs create mode 100644 docker2nix/README.md create mode 100644 hocker-config/Main.hs create mode 100644 hocker-config/README.md create mode 100644 hocker-image/Main.hs create mode 100644 hocker-image/README.md create mode 100644 hocker-layer/Main.hs create mode 100644 hocker-layer/README.md create mode 100644 hocker-manifest/Main.hs create mode 100644 hocker-manifest/README.md create mode 100644 hocker.cabal create mode 100644 nix/http-client-tls.nix create mode 100644 nix/http-client.nix create mode 100644 nix/optparse-applicative.nix create mode 100644 nix/optparse-generic.nix create mode 100644 nix/shell.nix create mode 100644 nix/turtle.nix create mode 100644 nix/wreq.nix create mode 100644 release.nix create mode 100644 src/Data/Docker/Image/AesonHelpers.hs create mode 100644 src/Data/Docker/Image/Types.hs create mode 100644 src/Data/Docker/Image/V1/Layer.hs create mode 100644 src/Data/Docker/Image/V1/Types.hs create mode 100644 src/Data/Docker/Image/V1_2/Types.hs create mode 100644 src/Data/Docker/Nix.hs create mode 100644 src/Data/Docker/Nix/FetchDocker.hs create mode 100644 src/Data/Docker/Nix/Lib.hs create mode 100644 src/Lib.hs create mode 100644 src/Network/Wreq/Docker/Image/Lib.hs create mode 100644 src/Network/Wreq/Docker/Image/V1_2.hs create mode 100644 src/Network/Wreq/Docker/Registry/V2.hs create mode 100644 src/Network/Wreq/ErrorHandling.hs create mode 100644 src/Types.hs create mode 100644 src/Types/Exceptions.hs create mode 100644 src/Types/Hash.hs create mode 100644 src/Types/ImageName.hs create mode 100644 src/Types/ImageTag.hs create mode 100644 src/Types/URI.hs create mode 100644 stack.yaml create mode 100644 test/Main.hs create mode 100644 test/Tests/Data/Docker/Image/V1.hs create mode 100644 test/Tests/Data/Docker/Image/V1_2.hs create mode 100644 test/Tests/Data/Docker/Nix/FetchDocker.hs create mode 100644 test/data/golden-debian:jessie.nix create mode 100644 test/data/manifest-debian:jessie.json diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..5680003 --- /dev/null +++ b/.gitignore @@ -0,0 +1,20 @@ +dist +dist-* +cabal-dev +*.o +*.hi +*.chi +*.chs.h +*.dyn_o +*.dyn_hi +.hpc +.hsenv +.cabal-sandbox/ +cabal.sandbox.config +*.prof +*.aux +*.hp +*.eventlog +.stack-work/ +cabal.project.local +throwaway/* diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..9963ffd --- /dev/null +++ b/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "{}" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2016 Awake Networks + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..33c2974 --- /dev/null +++ b/README.md @@ -0,0 +1,96 @@ +# Welcome! +The `hocker` package provides a small set of utilities to fetch docker image +artifacts from docker registries and produce Nix derivations marrying docker and +Nix elegantly: + +- [`hocker-image`](./hocker-image/README.md) for fetching a docker image +- [`hocker-layer`](./hocker-layer/README.md) for fetching a docker image's layers +- [`hocker-config`](./hocker-config/README.md) for fetching a docker image's configuration JSON +- [`hocker-manifest`](./hocker-manifest/README.md) for fetching docker registry image manifest +- [`docker2nix`](./docker2nix/README.md) for generating Nix expressions calling the `fetchdocker` + derivations, given a docker registry image manifest + +These tools _only_ work with version 2 of the **docker registry** and **docker +(>=) v1.10**. + +The motivation for this tool came from a need to fetch docker image artifacts +from a docker registry without the stock docker tooling designed to only work +with the docker daemon. + +Our use-case (and the reason why this package exposes a `docker2nix` tool) was +the need to pull our docker images into a [NixOS system's store](https://nixos.org/nix/manual/#ch-about-nix) and load +those images from the store into the docker daemon running on that same system. + +We desired this for two critical reasons: +1. The docker daemon no longer required an internet connection in order to pull + the docker images it needed +2. By virtue of fetching the docker images at build-time as opposed to run-time, + failures resulting in non-existent images or image tags we caught earlier + +We strived to make this tool useful outside of the context of Nix and NixOS, +therefore all of these tools are usable without Nix in the workflow. + +For high-level documentation of each utility, please refer to the README's in +each project's respective directory (links are in the above list). + +## Quickstart +Let's first retrieve a docker registry image manifest for the `debian:jessie` +docker image (note that we need the `library/` repository prefix because we are +pulling from the official debian repository!): + +```shell +$ hocker-manifest library/debian jessie +{ + "schemaVersion": 2, + "mediaType": "application/vnd.docker.distribution.manifest.v2+json", + "config": { + "mediaType": "application/vnd.docker.container.image.v1+json", + "size": 1528, + "digest": "sha256:054abe38b1e6f863befa4258cbfaf127b1cc9440d2e2e349b15d22e676b591e7" + }, + "layers": [ + { + "mediaType": "application/vnd.docker.image.rootfs.diff.tar.gzip", + "size": 52550276, + "digest": "sha256:cd0a524342efac6edff500c17e625735bbe479c926439b263bbe3c8518a0849c" + } + ] +} +``` + +## Private Registries +We developed these tools with private registries in-mind and they currently +support three modes of authentication: + +1. Nothing at all (simply do not supply `--token` or `--username` and + `--password`) +2. Bearer token-based authentication, you should retrieve a token and then give + it via the `--token` flag +3. Basic authentication with `--username` and `--password` (most common with + nginx proxied registries providing basic auth protection; you should be + careful to ensure you're only sending requests to registries exposed via TLS + or SSL!) + +A caveat to #1 if you do not supply any authentication credential flags and you +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/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/config.nix b/config.nix new file mode 100644 index 0000000..557328f --- /dev/null +++ b/config.nix @@ -0,0 +1,46 @@ +{ allowUnfree = true; + packageOverrides = pkgs: { + haskellPackages = pkgs.haskellPackages.override { + overrides = haskellPackagesNew: haskellPackagesOld: { + optparse-applicative = + pkgs.haskell.lib.dontCheck + (haskellPackagesNew.callPackage ./nix/optparse-applicative.nix { }); + + optparse-generic = + haskellPackagesNew.callPackage ./nix/optparse-generic.nix { }; + + turtle = + haskellPackagesNew.callPackage ./nix/turtle.nix { }; + + wreq = + haskellPackagesNew.callPackage ./nix/wreq.nix { }; + + http-client = + haskellPackagesNew.callPackage ./nix/http-client.nix { }; + + http-client-tls = + haskellPackagesNew.callPackage ./nix/http-client-tls.nix { }; + + hocker = + pkgs.haskell.lib.overrideCabal + ( haskellPackagesNew.callPackage ./default.nix { } ) + ( oldDerivation: { + testToolDepends = + (oldDerivation.testToolDepends or []) ++[ pkgs.nix ]; + buildDepends = + (oldDerivation.buildDepends or []) ++ [ pkgs.makeWrapper ]; + + postInstall = + (oldDerivation.postInstall or "") + '' + wrapProgram $out/bin/hocker-* \ + --suffix PATH : ${pkgs.nix}/bin + + wrapProgram $out/bin/docker2nix \ + --suffix PATH : ${pkgs.nix}/bin + ''; + } + ); + }; + }; + }; +} diff --git a/default.nix b/default.nix new file mode 100644 index 0000000..d3c0b22 --- /dev/null +++ b/default.nix @@ -0,0 +1,39 @@ +{ mkDerivation, aeson, aeson-pretty, ansi-wl-pprint, async, base +, bytestring, concurrentoutput, containers, cryptonite, data-fix +, deepseq, directory, exceptions, filepath, foldl, hnix +, http-client, http-types, lens, lens-aeson, lifted-base, memory +, mtl, neat-interpolation, network, network-uri, optional-args +, optparse-applicative, optparse-generic, pooled-io, pureMD5 +, scientific, stdenv, tar, tasty, tasty-golden, tasty-hunit +, tasty-quickcheck, tasty-smallcheck, temporary, text, time +, transformers, turtle, unordered-containers, uri-bytestring +, vector, wreq, zlib +}: +mkDerivation { + pname = "hocker"; + version = "0.1.0.0"; + src = ./.; + isLibrary = true; + isExecutable = true; + libraryHaskellDepends = [ + aeson aeson-pretty ansi-wl-pprint async base bytestring + concurrentoutput containers cryptonite data-fix deepseq directory + exceptions filepath foldl hnix http-client http-types lens + lens-aeson lifted-base memory mtl neat-interpolation network + network-uri optional-args optparse-applicative optparse-generic + pooled-io pureMD5 scientific tar temporary text time transformers + turtle unordered-containers uri-bytestring vector wreq zlib + ]; + executableHaskellDepends = [ + base bytestring cryptonite data-fix filepath hnix lens mtl network + optional-args optparse-applicative optparse-generic temporary text + ]; + testHaskellDepends = [ + aeson ansi-wl-pprint base bytestring containers cryptonite mtl + network network-uri tasty tasty-golden tasty-hunit tasty-quickcheck + tasty-smallcheck text unordered-containers + ]; + homepage = "https://github.com/awakenetworks/hocker#readme"; + description = "CLI tools and library to interact with a V2 Docker Registry"; + license = stdenv.lib.licenses.asl20; +} diff --git a/docker2nix/Main.hs b/docker2nix/Main.hs new file mode 100644 index 0000000..8faf448 --- /dev/null +++ b/docker2nix/Main.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : docker2nix/Main +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Main where + +import Data.ByteString.Lazy.Char8 as C8L +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Options.Generic +import System.IO (hWaitForInput, stdin) + +import Data.Docker.Image.Types +import Data.Docker.Nix.FetchDocker as Nix.FetchDocker +import Lib +import Network.Wreq.Docker.Registry.V2 as Docker.Registry +import Types +import Types.ImageName +import Types.ImageTag + +-- | Top-level optparse-generic CLI args data type and specification. +data ProgArgs w = ProgArgs + { -- | URI for the registry, optional + registry :: w ::: Maybe RegistryURI + "URI of registry, defaults to the Docker Hub registry" + -- | Filepath to a file containing the manifest JSON + , manifest :: w ::: Maybe FilePath + "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 + "Alternate image name provided in the `fetcdocker` derivation" + -- | Docker image name (includes the reponame, e.g: library/debian) + , name :: ImageName + -- | Docker image tag + , imageTag :: ImageTag + } deriving (Generic) + + +instance ParseRecord (ProgArgs Wrapped) +deriving instance Show (ProgArgs Unwrapped) + +progSummary :: T.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 + dockerRegistry = fromMaybe defaultRegistry registry + + manifestJSON <- + case manifest of + Just f -> C8L.readFile f + Nothing -> do + let h = stdin + hWaitForInput h (-1) + C8L.hGetContents h + + exprs <- Nix.FetchDocker.generate HockerImageMeta{..} + either (Lib.exitProgFail . show) Lib.pprintNixExpr exprs diff --git a/docker2nix/README.md b/docker2nix/README.md new file mode 100644 index 0000000..532ccb3 --- /dev/null +++ b/docker2nix/README.md @@ -0,0 +1,62 @@ +# Generate nix expression to fetch a docker image +This tool takes a docker registry V2 image manifest JSON on stdin or as a file +to read from and generates a Nix expression that uses the fetchdocker machinery +to pull all individual layers and generate an image compositor that can stream +to `docker load`. + +## Quickstart + +```shell +$ docker2nix --help +Produce a Nix expression given a manifest for a docker image via stdin or via a +filepath + +Usage: docker2nix [--registry URI] [--manifest STRING] [--altName TEXT] + IMAGE-NAME IMAGE-TAG + +Available options: + -h,--help Show this help text + --registry URI URI of registry, defaults to the Docker Hub registry + --manifest STRING Fetch image manifest from a path on the filesystem + --altName TEXT Alternate image name provided in the `fetcdocker` + derivation + IMAGE-NAME Docker image name, e.g: 'debian' in debian:jessie + IMAGE-TAG Docker image tag identifier, e.g: 'jessie' in + debian:jessie +``` + +Generating a fetchdocker Nix expression from a docker registry V2 image manifest +JSON retrieved by `hocker-manifest`: + +```shell +$ hocker-manifest library/debian jessie | docker2nix library/debian jessie +{ + config.docker.images.debian = pkgs.fetchdocker { + name = "debian"; + registry = "https://registry-1.docker.io/v2/"; + repository = "library"; + imageName = "debian"; + tag = "jessie"; + imageConfig = pkgs.fetchDockerConfig { + inherit registry repository imageName tag; + sha256 = "1rwinmvfc8jxn54y7qnj82acrc97y7xcnn22zaz67y76n4wbwjh5"; + }; + imageLayers = let + layer0 = pkgs.fetchDockerLayer { + inherit registry repository imageName tag; + layerDigest = "cd0a524342efac6edff500c17e625735bbe479c926439b263bbe3c8518a0849c"; + sha256 = "1744l0c8ag5y7ck9nhr6r5wy9frmaxi7xh80ypgnxb7g891m42nd"; + }; + in [ layer0 ]; + }; +} +``` + +And to load a fetched docker image into a running docker daemon on a NixOS +system (NB the preferred method to do the below might be in a systemd unit with +the `config.docker.images.debian` attribute parametrizing the path to +`compositeImage.sh`): + +```shell +$ /nix/store/6qn5i7p6x3c3qylvzqf76fqgd0gl47cv-debian/compositeImage.sh | docker load +``` diff --git a/hocker-config/Main.hs b/hocker-config/Main.hs new file mode 100644 index 0000000..3678602 --- /dev/null +++ b/hocker-config/Main.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : hocker-config/Main +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Main where + +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 Types + +progSummary :: Data.Text.Text +progSummary = "Fetch a docker image config JSON from the registry" + +main :: IO () +main = unwrapRecord progSummary >>= \OptArgs{..} -> do + let dockerRegistry = fromMaybe defaultRegistry registry + + auth <- mkAuth dockerRegistry imageName credentials + config <- Docker.Image.fetchConfig $ + HockerMeta + { outDir = Nothing + , imageLayer = Nothing + , .. + } + either (Lib.exitProgFail . show) (Lib.writeOrPrint out) config diff --git a/hocker-config/README.md b/hocker-config/README.md new file mode 100644 index 0000000..99cc442 --- /dev/null +++ b/hocker-config/README.md @@ -0,0 +1,107 @@ +# Retrieve a docker image configuration JSON +This tool fetches the specified docker image's configuration JSON from the +docker registry. + +## Quickstart +```shell +Fetch a docker image config JSON from the registry + +Usage: hocker-config [--registry URI] ([-u|--username BASIC USERNAME] + [-p|--password BASIC PASSWORD] | [-t|--token BEARER TOKEN]) + [--out STRING] IMAGE-NAME IMAGE-TAG + +Available options: + -h,--help Show this help text + --registry URI URI of registry, defaults to the Docker Hub registry + -u,--username BASIC USERNAME + Username part of a basic auth credential + -p,--password BASIC PASSWORD + Password part of a basic auth credential + -t,--token BEARER TOKEN Bearer token retrieved from a call to `docker login` + (mutually exclusive to --username and --password) + --out STRING Write content to location + IMAGE-NAME Docker image name, e.g: 'debian' in debian:jessie + IMAGE-TAG Docker image tag identifier, e.g: 'jessie' in + debian:jessie +``` + +```shell +$ hocker-config library/debian jessie | jq +{ + "architecture": "amd64", + "config": { + "Hostname": "200591939db7", + "Domainname": "", + "User": "", + "AttachStdin": false, + "AttachStdout": false, + "AttachStderr": false, + "Tty": false, + "OpenStdin": false, + "StdinOnce": false, + "Env": [ + "PATH=/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" + ], + "Cmd": [ + "/bin/bash" + ], + "ArgsEscaped": true, + "Image": "sha256:9e77974e778cc6730c21889f33f2dcb141f9f632745ba2c3914dd62250ea93c9", + "Volumes": null, + "WorkingDir": "", + "Entrypoint": null, + "OnBuild": null, + "Labels": {} + }, + "container": "9a3fb25551fee47cea1203cbc2a6022dc3ffea8bc2010733e1286c4702cdf778", + "container_config": { + "Hostname": "200591939db7", + "Domainname": "", + "User": "", + "AttachStdin": false, + "AttachStdout": false, + "AttachStderr": false, + "Tty": false, + "OpenStdin": false, + "StdinOnce": false, + "Env": [ + "PATH=/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin" + ], + "Cmd": [ + "/bin/sh", + "-c", + "#(nop) ", + "CMD [\"/bin/bash\"]" + ], + "ArgsEscaped": true, + "Image": "sha256:9e77974e778cc6730c21889f33f2dcb141f9f632745ba2c3914dd62250ea93c9", + "Volumes": null, + "WorkingDir": "", + "Entrypoint": null, + "OnBuild": null, + "Labels": {} + }, + "created": "2017-05-08T23:28:15.327579341Z", + "docker_version": "17.04.0-ce", + "history": [ + { + "created": "2017-05-08T23:28:14.437236885Z", + "created_by": "/bin/sh -c #(nop) ADD file:f4e6551ac34ab446a297849489a5693d67a7e76c9cb9ed9346d82392c9d9a5fe in / " + }, + { + "created": "2017-05-08T23:28:15.327579341Z", + "created_by": "/bin/sh -c #(nop) CMD [\"/bin/bash\"]", + "empty_layer": true + } + ], + "os": "linux", + "rootfs": { + "type": "layers", + "diff_ids": [ + "sha256:8d4d1ab5ff74fc361fb74212fff3b6dc1e6c16d1e1f0e8b44f9a9112b00b564f" + ] + } +} +``` + + diff --git a/hocker-image/Main.hs b/hocker-image/Main.hs new file mode 100644 index 0000000..8a3374f --- /dev/null +++ b/hocker-image/Main.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : hocker-fetch/Main +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Main where + +import Data.Maybe (fromMaybe) +import qualified Data.Text +import Data.Text.IO as TIO +import Options.Generic +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 Types + +progSummary :: Data.Text.Text +progSummary = "Fetch a docker image from a docker registry without using docker" + +main :: IO () +main = unwrapRecord progSummary >>= \OptArgs{..} -> do + let dockerRegistry = fromMaybe defaultRegistry registry + + auth <- mkAuth dockerRegistry imageName credentials + img <- withSystemTempDirectory "hocker-image-XXXXXX" $ \d -> + Docker.Image.fetchAndAssemble $ + HockerMeta + { outDir = Just d + , imageLayer = Nothing + , .. + } + either (Lib.exitProgFail . show) TIO.putStrLn img diff --git a/hocker-image/README.md b/hocker-image/README.md new file mode 100644 index 0000000..2a4c3b9 --- /dev/null +++ b/hocker-image/README.md @@ -0,0 +1,31 @@ +# Fetch a docker image + +## Quickstart + +```shell +Fetch a docker image from a docker registry without using docker + +Usage: hocker-image [--registry URI] ([-u|--username BASIC USERNAME] + [-p|--password BASIC PASSWORD] | [-t|--token BEARER TOKEN]) + [--out STRING] IMAGE-NAME IMAGE-TAG + +Available options: + -h,--help Show this help text + --registry URI URI of registry, defaults to the Docker Hub registry + -u,--username BASIC USERNAME + Username part of a basic auth credential + -p,--password BASIC PASSWORD + Password part of a basic auth credential + -t,--token BEARER TOKEN Bearer token retrieved from a call to `docker login` + (mutually exclusive to --username and --password) + --out STRING Write content to location + IMAGE-NAME Docker image name, e.g: 'debian' in debian:jessie + IMAGE-TAG Docker image tag identifier, e.g: 'jessie' in + debian:jessie +``` + +```shell +$ hocker-image --out=./debian-latest.tar.gz library/debian latest +Downloading layer: 22def84 => decompressed => wrote 159fbd8 +./debian-latest.tar.gz +``` diff --git a/hocker-layer/Main.hs b/hocker-layer/Main.hs new file mode 100644 index 0000000..07fca9a --- /dev/null +++ b/hocker-layer/Main.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} + +----------------------------------------------------------------------------- +-- | +-- Module : hocker-layer/Main +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Main where + +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 Types +import Types.Hash () +import Types.ImageName +import Types.ImageTag +import Types.URI () + +data ProgArgs w = ProgArgs + { -- | URI for the registry, optional + registry :: w ::: Maybe RegistryURI + "URI of registry, defaults to the Docker Hub registry" + , credentials :: Maybe Credentials + -- | Filesystem path to write output to + , out :: w ::: Maybe FilePath + "Write content to location" + -- | Layer sha256 hash digest to fetch from registry + , imageLayer :: w ::: Hash.Digest Hash.SHA256 + "Layer to fetch, by hash digest (unprefixed by the hash algorithm identifier)" + -- | Docker image name (includes the repository, e.g: library/debian) + , imageName :: ImageName + -- | Docker image tag + , imageTag :: ImageTag + } deriving (Generic) + +instance ParseRecord (ProgArgs Wrapped) +deriving instance Show (ProgArgs Unwrapped) + +progSummary :: Data.Text.Text +progSummary = "Fetch a docker image layer from a docker registry without using docker" + +main :: IO () +main = unwrapRecord progSummary >>= \ProgArgs{..} -> do + let dockerRegistry = fromMaybe defaultRegistry registry + + auth <- mkAuth dockerRegistry imageName credentials + layerPath <- Docker.Image.fetchLayer $ + HockerMeta + { outDir = Nothing + , imageLayer = Just imageLayer + , .. + } + either (Lib.exitProgFail . show) Prelude.putStrLn layerPath diff --git a/hocker-layer/README.md b/hocker-layer/README.md new file mode 100644 index 0000000..d1cb740 --- /dev/null +++ b/hocker-layer/README.md @@ -0,0 +1,27 @@ +# Retrieve an individual docker image layer + +## Quickstart + +```shell +Fetch a docker image layer from a docker registry without using docker + +Usage: hocker-layer [--registry URI] ([-u|--username BASIC USERNAME] + [-p|--password BASIC PASSWORD] | [-t|--token BEARER TOKEN]) + [--out STRING] (-l|--layer SHA256) IMAGE-NAME IMAGE-TAG + +Available options: + -h,--help Show this help text + --registry URI URI of registry, defaults to the Docker Hub registry + -u,--username BASIC USERNAME + Username part of a basic auth credential + -p,--password BASIC PASSWORD + Password part of a basic auth credential + -t,--token BEARER TOKEN Bearer token retrieved from a call to `docker login` + (mutually exclusive to --username and --password) + --out STRING Write content to location + -l,--layer SHA256 Layer to fetch, by hash digest (unprefixed by the + hash algorithm identifier) + IMAGE-NAME Docker image name, e.g: 'debian' in debian:jessie + IMAGE-TAG Docker image tag identifier, e.g: 'jessie' in + debian:jessie +``` diff --git a/hocker-manifest/Main.hs b/hocker-manifest/Main.hs new file mode 100644 index 0000000..253c354 --- /dev/null +++ b/hocker-manifest/Main.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : hocker-manifest/Main +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Main where + +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 Types + +progSummary :: Data.Text.Text +progSummary = "Pull a docker image manifest from the registry" + +main :: IO () +main = unwrapRecord progSummary >>= \OptArgs{..} -> do + let dockerRegistry = fromMaybe defaultRegistry registry + + auth <- mkAuth dockerRegistry imageName credentials + manifest <- Docker.Image.fetchImageManifest $ + HockerMeta + { outDir = Nothing + , imageLayer = Nothing + , .. + } + either (Lib.exitProgFail . show) (Lib.writeOrPrint out) manifest diff --git a/hocker-manifest/README.md b/hocker-manifest/README.md new file mode 100644 index 0000000..c3fc266 --- /dev/null +++ b/hocker-manifest/README.md @@ -0,0 +1,52 @@ +# Retrieve a docker registry V2 image manifest +This utility retrieves a V2 docker image manifest from the docker registry. + +NB: the V2 docker image manifest retrieved from the docker registry is a +manifest of the configuration JSON and layer blobs stored by the registry, this +is _not_ the same manifest JSON file of the docker image V1.2 _image_ +specification. + +## Quickstart + +```shell +Pull a docker image manifest from the registry + +Usage: hocker-manifest [--registry URI] ([-u|--username BASIC USERNAME] + [-p|--password BASIC PASSWORD] | + [-t|--token BEARER TOKEN]) [--out STRING] IMAGE-NAME + IMAGE-TAG + +Available options: + -h,--help Show this help text + --registry URI URI of registry, defaults to the Docker Hub registry + -u,--username BASIC USERNAME + Username part of a basic auth credential + -p,--password BASIC PASSWORD + Password part of a basic auth credential + -t,--token BEARER TOKEN Bearer token retrieved from a call to `docker login` + (mutually exclusive to --username and --password) + --out STRING Write content to location + IMAGE-NAME Docker image name, e.g: 'debian' in debian:jessie + IMAGE-TAG Docker image tag identifier, e.g: 'jessie' in + debian:jessie +``` + +```shell +hocker-manifest library/debian jessie +{ + "schemaVersion": 2, + "mediaType": "application/vnd.docker.distribution.manifest.v2+json", + "config": { + "mediaType": "application/vnd.docker.container.image.v1+json", + "size": 1528, + "digest": "sha256:3e83c23dba6a16cd936a3dc044df71b26706c5a4c28181bc3ca4a4af9f5f38ee" + }, + "layers": [ + { + "mediaType": "application/vnd.docker.image.rootfs.diff.tar.gzip", + "size": 52584016, + "digest": "sha256:10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9" + } + ] +} +``` diff --git a/hocker.cabal b/hocker.cabal new file mode 100644 index 0000000..d664e46 --- /dev/null +++ b/hocker.cabal @@ -0,0 +1,220 @@ +name: hocker +version: 0.1.0.0 +synopsis: CLI tools and library to interact with a V2 Docker Registry +description: Please see README.md +homepage: https://github.com/awakenetworks/hocker#readme +license: Apache-2.0 +license-file: LICENSE +author: Awake networks +maintainer: opensource@awakenetworks.com +copyright: 2016 Awake Networks +category: Web +build-type: Simple +extra-source-files: LICENSE +cabal-version: >=1.10 + +library + ghc-options: -Wall + hs-source-dirs: src + exposed-modules: + Lib, + Types, + Types.URI, + Types.Hash, + Types.ImageName, + Types.ImageTag, + Types.Exceptions, + Data.Docker.Nix, + Data.Docker.Nix.Lib, + 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.Image.Lib + build-depends: + base >= 4.9 && < 5, + aeson >= 0.9.0.1, + ansi-wl-pprint >= 0.6.7.3, + lens-aeson >= 1.0, + async >= 2.0.0.0 && < 2.2, + exceptions >= 0.8, + text >= 1.2, + directory >= 1.2.2.0, + temporary >= 1.2, + pureMD5 >= 2.1, + vector >= 0.11, + optparse-generic >= 1.1.5, + optparse-applicative >= 0.13, + aeson-pretty >= 0.8, + filepath >= 1.4, + deepseq >= 1.4, + lens >= 4.0, + mtl >= 2.2, + transformers >= 0.4, + lifted-base >= 0.2.3.8, + zlib >= 0.6, + http-types >= 0.9.1, + http-client >= 0.4, + tar >= 0.5, + network >= 2.6, + scientific >= 0.3, + pooled-io >= 0.0.2, + concurrentoutput >= 0.2, + bytestring >= 0.10, + uri-bytestring >= 0.2, + unordered-containers >= 0.2, + containers >= 0.5, + memory >= 0.11, + turtle >= 1.3, + cryptonite >= 0.13, + foldl >= 1.0, + time >= 1.4, + network-uri >= 2.6, + wreq >= 0.4, + data-fix >= 0.0.3, + hnix >= 0.3.4, + neat-interpolation >= 0.3.2, + optional-args + + default-language: Haskell2010 + +executable hocker-image + hs-source-dirs: hocker-image + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >= 4.9 && < 5, + text >= 1.2, + lens >= 4.0, + optparse-generic >= 1.1.5, + temporary >= 1.2, + optparse-applicative >= 0.13, + filepath >= 1.4, + mtl >= 2.2, + network >= 2.6, + bytestring >= 0.10, + optional-args, + hocker + + default-language: Haskell2010 + +executable hocker-layer + hs-source-dirs: hocker-layer + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >= 4.9 && < 5, + text >= 1.2, + lens >= 4.0, + optparse-generic >= 1.1.5, + temporary >= 1.2, + optparse-applicative >= 0.13, + filepath >= 1.4, + mtl >= 2.2, + network >= 2.6, + bytestring >= 0.10, + cryptonite >= 0.13, + optional-args, + hocker + + default-language: Haskell2010 + +executable hocker-config + hs-source-dirs: hocker-config + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >= 4.9 && < 5, + text >= 1.2, + lens >= 4.0, + optparse-generic >= 1.1.5, + temporary >= 1.2, + optparse-applicative >= 0.13, + filepath >= 1.4, + mtl >= 2.2, + network >= 2.6, + bytestring >= 0.10, + optional-args, + hocker + + default-language: Haskell2010 + +executable hocker-manifest + hs-source-dirs: hocker-manifest + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >= 4.9 && < 5, + text >= 1.2, + lens >= 4.0, + optparse-generic >= 1.1.5, + temporary >= 1.2, + optparse-applicative >= 0.13, + filepath >= 1.4, + mtl >= 2.2, + network >= 2.6, + bytestring >= 0.10, + optional-args, + hocker + + default-language: Haskell2010 + +executable docker2nix + hs-source-dirs: docker2nix + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >= 4.9 && < 5, + text >= 1.2, + lens >= 4.0, + optparse-generic >= 1.1.5, + temporary >= 1.2, + optparse-applicative >= 0.13, + filepath >= 1.4, + mtl >= 2.2, + network >= 2.6, + bytestring >= 0.10, + hnix >= 0.3.4, + data-fix >= 0.0.3, + optional-args, + hocker + +test-suite hocker-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Tests.Data.Docker.Image.V1, + Tests.Data.Docker.Image.V1_2, + Tests.Data.Docker.Nix.FetchDocker + build-depends: + base >= 4.9 && < 5, + aeson >= 0.9.0.1, + tasty >= 0.11, + tasty-hunit >= 0.9, + text >= 1.2, + network >= 2.6, + network-uri >= 2.6, + ansi-wl-pprint >= 0.6.7.3, + unordered-containers >= 0.2, + tasty-quickcheck >= 0.8, + tasty-smallcheck >= 0.8, + tasty-golden >= 2.3, + mtl >= 2.2, + bytestring >= 0.10, + cryptonite >= 0.13, + containers >= 0.5, + hocker + + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/awakenetworks/hocker diff --git a/nix/http-client-tls.nix b/nix/http-client-tls.nix new file mode 100644 index 0000000..1a95faf --- /dev/null +++ b/nix/http-client-tls.nix @@ -0,0 +1,19 @@ +{ mkDerivation, base, bytestring, case-insensitive, connection +, cryptonite, data-default-class, exceptions, hspec, http-client +, http-types, memory, network, stdenv, tls, transformers +}: +mkDerivation { + pname = "http-client-tls"; + version = "0.3.3"; + sha256 = "0r50h7lhrwmxcmiq5nw1rxnpda3k6mhz4jsd86m56ymai5lnf77c"; + libraryHaskellDepends = [ + base bytestring case-insensitive connection cryptonite + data-default-class exceptions http-client http-types memory network + tls transformers + ]; + testHaskellDepends = [ base hspec http-client http-types ]; + doCheck = false; + homepage = "https://github.com/snoyberg/http-client"; + description = "http-client backend using the connection package and tls library"; + license = stdenv.lib.licenses.mit; +} diff --git a/nix/http-client.nix b/nix/http-client.nix new file mode 100644 index 0000000..533186a --- /dev/null +++ b/nix/http-client.nix @@ -0,0 +1,27 @@ +{ mkDerivation, array, async, base, base64-bytestring +, blaze-builder, bytestring, case-insensitive, containers, cookie +, deepseq, directory, exceptions, filepath, ghc-prim, hspec +, http-types, mime-types, monad-control, network, network-uri +, random, stdenv, streaming-commons, text, time, transformers, zlib +}: +mkDerivation { + pname = "http-client"; + version = "0.5.6.1"; + sha256 = "1v9bdb8dkhb5g6jl9azk86ig7ia8xh9arr64n7s8r94fp0vl6c1c"; + libraryHaskellDepends = [ + array base base64-bytestring blaze-builder bytestring + case-insensitive containers cookie deepseq exceptions filepath + ghc-prim http-types mime-types network network-uri random + streaming-commons text time transformers + ]; + testHaskellDepends = [ + async base base64-bytestring blaze-builder bytestring + case-insensitive containers deepseq directory hspec http-types + monad-control network network-uri streaming-commons text time + transformers zlib + ]; + doCheck = false; + homepage = "https://github.com/snoyberg/http-client"; + description = "An HTTP client engine"; + license = stdenv.lib.licenses.mit; +} diff --git a/nix/optparse-applicative.nix b/nix/optparse-applicative.nix new file mode 100644 index 0000000..fe6b2b1 --- /dev/null +++ b/nix/optparse-applicative.nix @@ -0,0 +1,15 @@ +{ mkDerivation, ansi-wl-pprint, base, process, QuickCheck, stdenv +, transformers, transformers-compat +}: +mkDerivation { + pname = "optparse-applicative"; + version = "0.13.0.0"; + sha256 = "1b0c5fdq8bd070g24vrjrwlq979r8dk8mys6aji9hy1l9pcv3inf"; + libraryHaskellDepends = [ + ansi-wl-pprint base process transformers transformers-compat + ]; + testHaskellDepends = [ base QuickCheck ]; + homepage = "https://github.com/pcapriotti/optparse-applicative"; + description = "Utilities and combinators for parsing command line options"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/nix/optparse-generic.nix b/nix/optparse-generic.nix new file mode 100644 index 0000000..06f4f64 --- /dev/null +++ b/nix/optparse-generic.nix @@ -0,0 +1,14 @@ +{ mkDerivation, base, bytestring, optparse-applicative, semigroups +, stdenv, system-filepath, text, time, transformers, void +}: +mkDerivation { + pname = "optparse-generic"; + version = "1.1.5"; + sha256 = "1xg6c7h6h8q64gwskh7l4h7qn7w4y0ixf88grgk23xdficgmsyms"; + libraryHaskellDepends = [ + base bytestring optparse-applicative semigroups system-filepath + text time transformers void + ]; + description = "Auto-generate a command-line parser for your datatype"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/nix/shell.nix b/nix/shell.nix new file mode 100644 index 0000000..4d9614e --- /dev/null +++ b/nix/shell.nix @@ -0,0 +1,11 @@ +{ ghc }: +let + config = import ../config.nix; + pkgs = import { inherit config; }; +in with pkgs; pkgs.haskell.lib.buildStackProject { + inherit ghc; + name = "hocker-stack-shell"; + buildInputs = [ + zlib cabal-install + ]; +} diff --git a/nix/turtle.nix b/nix/turtle.nix new file mode 100644 index 0000000..aafa7b3 --- /dev/null +++ b/nix/turtle.nix @@ -0,0 +1,20 @@ +{ mkDerivation, ansi-wl-pprint, async, base, bytestring, clock +, directory, doctest, foldl, hostname, managed, optional-args +, optparse-applicative, process, stdenv, stm, system-fileio +, system-filepath, temporary, text, time, transformers, unix +, unix-compat +}: +mkDerivation { + pname = "turtle"; + version = "1.3.1"; + sha256 = "0pnxislwq6vzllrlva9la9wisvz54gb74n3nprw145rxszw0ag93"; + libraryHaskellDepends = [ + ansi-wl-pprint async base bytestring clock directory foldl hostname + managed optional-args optparse-applicative process stm + system-fileio system-filepath temporary text time transformers unix + unix-compat + ]; + testHaskellDepends = [ base doctest ]; + description = "Shell programming, Haskell-style"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/nix/wreq.nix b/nix/wreq.nix new file mode 100644 index 0000000..5c99ba0 --- /dev/null +++ b/nix/wreq.nix @@ -0,0 +1,34 @@ +{ mkDerivation, aeson, aeson-pretty, attoparsec, authenticate-oauth +, base, base16-bytestring, base64-bytestring, byteable, bytestring +, case-insensitive, containers, cryptohash, directory, doctest +, exceptions, filepath, ghc-prim, hashable, http-client +, http-client-tls, http-types, HUnit, lens, lens-aeson, mime-types +, network-info, psqueues, QuickCheck, snap-core, snap-server +, stdenv, template-haskell, temporary, test-framework +, test-framework-hunit, test-framework-quickcheck2, text, time +, time-locale-compat, transformers, unix-compat +, unordered-containers, uuid, vector +}: +mkDerivation { + pname = "wreq"; + version = "0.5.0.1"; + sha256 = "138n138rczs5xb7pr25b5a2ajhhxph7vfrh02x71w2alh2xr4akc"; + libraryHaskellDepends = [ + aeson attoparsec authenticate-oauth base base16-bytestring byteable + bytestring case-insensitive containers cryptohash exceptions + ghc-prim hashable http-client http-client-tls http-types lens + lens-aeson mime-types psqueues template-haskell text time + time-locale-compat unordered-containers + ]; + testHaskellDepends = [ + aeson aeson-pretty base base64-bytestring bytestring + case-insensitive containers directory doctest filepath hashable + http-client http-types HUnit lens lens-aeson network-info + QuickCheck snap-core snap-server temporary test-framework + test-framework-hunit test-framework-quickcheck2 text time + transformers unix-compat unordered-containers uuid vector + ]; + homepage = "http://www.serpentine.com/wreq"; + description = "An easy-to-use HTTP client library"; + license = stdenv.lib.licenses.bsd3; +} diff --git a/release.nix b/release.nix new file mode 100644 index 0000000..2eb1729 --- /dev/null +++ b/release.nix @@ -0,0 +1,13 @@ +let config = import ./config.nix; +in +{ pkgs ? import { inherit config; } }: +let + darwinPkgs = import { inherit config; system = "x86_64-darwin"; }; + linuxPkgs = import { inherit config; system = "x86_64-linux" ; }; + pkgs = import { inherit config; }; + +in + { hocker-linux = linuxPkgs.haskellPackages.hocker; + hocker-darwin = darwinPkgs.haskellPackages.hocker; + hocker = pkgs.haskellPackages.hocker; + } diff --git a/src/Data/Docker/Image/AesonHelpers.hs b/src/Data/Docker/Image/AesonHelpers.hs new file mode 100644 index 0000000..073ee8d --- /dev/null +++ b/src/Data/Docker/Image/AesonHelpers.hs @@ -0,0 +1,18 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Docker.Image.AesonHelpers +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Data.Docker.Image.AesonHelpers where + +import Data.Aeson +import Data.Aeson.TH + +-- | Produce a default option record with @omitNothingFields@ set to +-- True by default. +stdOpts :: Options +stdOpts = defaultOptions{ omitNothingFields = True } diff --git a/src/Data/Docker/Image/Types.hs b/src/Data/Docker/Image/Types.hs new file mode 100644 index 0000000..a82fa7c --- /dev/null +++ b/src/Data/Docker/Image/Types.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Docker.Image.Types +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Data.Docker.Image.Types where + +import Data.ByteString.Lazy.Char8 as C8L +import qualified Data.Text as T + +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). +data HockerImageMeta = HockerImageMeta + { -- | Docker image repo, the first part of a repository+name + -- separated by a "/"; e.g: library/debian. + imageRepo :: RepoNamePart + -- | Docker image name, the second part of a repository+name + -- separated by a "/"; e.g: library/debian. + , 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 + } deriving (Show) diff --git a/src/Data/Docker/Image/V1/Layer.hs b/src/Data/Docker/Image/V1/Layer.hs new file mode 100644 index 0000000..449c6e2 --- /dev/null +++ b/src/Data/Docker/Image/V1/Layer.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Docker.Image.V1.Layer +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- 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 new file mode 100644 index 0000000..503e7ef --- /dev/null +++ b/src/Data/Docker/Image/V1/Types.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Docker.Image.V1.Types +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- 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 new file mode 100644 index 0000000..8901628 --- /dev/null +++ b/src/Data/Docker/Image/V1_2/Types.hs @@ -0,0 +1,108 @@ +{-# 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 : AllRightsReserved +-- 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 new file mode 100644 index 0000000..7a5bd4b --- /dev/null +++ b/src/Data/Docker/Nix.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Docker.Nix +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +-- +-- This module only re-exports Nix modules providing Docker-specific +-- functionality as it pertains to Nix. +---------------------------------------------------------------------------- + +module Data.Docker.Nix +( -- * Generating `fetchdocker` Nix Derivation Expressions + module Data.Docker.Nix.FetchDocker +) where + +import Data.Docker.Nix.FetchDocker diff --git a/src/Data/Docker/Nix/FetchDocker.hs b/src/Data/Docker/Nix/FetchDocker.hs new file mode 100644 index 0000000..c53d9ef --- /dev/null +++ b/src/Data/Docker/Nix/FetchDocker.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Docker.Nix.FetchDocker +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Data.Docker.Nix.FetchDocker where + +import Control.Lens +import Control.Monad +import Control.Monad.Except as Except +import Data.Aeson.Lens +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.Encoding.Error +import Nix.Expr +import URI.ByteString + +import Data.Docker.Image.Types +import Data.Docker.Nix.Lib as Nix.Lib +import Lib +import Network.Wreq.Docker.Registry.V2 (pluckLayersFrom) +import Types +import Types.Exceptions +import Types.ImageTag + +{- Example output of the pretty-printed, generated Nix expression AST. +{ + config.docker.images.debian = pkgs.fetchdocker { + name = "debian"; + registry = "https://registry-1.docker.io/v2/"; + repository = "library"; + imageName = "debian"; + tag = "latest"; + imageConfig = pkgs.fetchDockerConfig { + inherit registry repository imageName tag; + sha256 = "1viqbygsz9547jy830f2lk2hcrxjf7gl9h1xda9ws5kap8yw50ry"; + }; + imageLayers = let + layer0 = pkgs.fetchDockerLayer { + inherit registry repository imageName tag; + layerDigest = "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9"; + sha256 = "1fcmx3aklbr24qsjhm6cvmhqhmrxr6xlpq75mzrk0dj2gz36g8hh"; + }; + in [ layer0 ]; + }; +} +-} + +-- | @fetchdocker@ derivation name. +constFetchdocker :: T.Text +constFetchdocker = "fetchdocker" + +-- | @fetchDockerConfig@ derivation name. +constFetchDockerConfig :: T.Text +constFetchDockerConfig = "fetchDockerConfig" + +-- | @fetchDockerLayer@ derivation name. +constFetchDockerLayer :: T.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. +generate :: HockerImageMeta -> IO (Either HockerException NExpr) +generate dim@HockerImageMeta{..} = runExceptT $ + case (manifestJSON ^? key "schemaVersion" . _Integer) of + Just 2 -> do + nixhash <- Lib.findExec "nix-hash" + configDigest <- Nix.Lib.toBase32Nix nixhash . Base16Digest $ pluckedConfigDigest + layerDigests <- forM pluckedLayerDigests $ \d16 -> + (Base16Digest d16,) <$> (Nix.Lib.toBase32Nix nixhash $ Base16Digest d16) + + ExceptT (pure $ generateFetchDockerExpr dim configDigest layerDigests) + Just v -> + throwError $ HockerException ("Expected: 2 but got: " <> (show v)) Nothing Nothing + Nothing -> + throwError $ HockerException "No key 'schemaVersion' in JSON object" Nothing Nothing + + where + -- 'stripHashId' is necessary because digests in the manifest are + -- prefixed by the hash algorithm used to generate them + pluckedConfigDigest = Lib.stripHashId $ manifestJSON ^. key "config" . key "digest" . _String + pluckedLayerDigests = Lib.stripHashId <$> pluckLayersFrom manifestJSON + + + +{-| 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: +@ +{ + config.docker.images.debian = pkgs.fetchdocker { + name = "debian"; + registry = "https://registry-1.docker.io/v2/"; + repository = "library"; + imageName = "debian"; + tag = "latest"; + imageConfig = pkgs.fetchDockerConfig { + inherit registry repository imageName tag; + sha256 = "1viqbygsz9547jy830f2lk2hcrxjf7gl9h1xda9ws5kap8yw50ry"; + }; + imageLayers = let + layer0 = pkgs.fetchDockerLayer { + inherit registry repository imageName tag; + layerDigest = "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9"; + sha256 = "1fcmx3aklbr24qsjhm6cvmhqhmrxr6xlpq75mzrk0dj2gz36g8hh"; + }; + in [ layer0 ]; + }; +} +@ +-} +generateFetchDockerExpr :: HockerImageMeta -> ConfigDigest -> [(Base16Digest, Base32Digest)] -> Either HockerException NExpr +generateFetchDockerExpr dim@HockerImageMeta{..} configDigest layerDigests = do + let fetchconfig = mkFetchDockerConfig commonInherits configDigest + fetchlayers = + mkLets + (mkFetchDockerLayers commonInherits layerDigests) + (mkList $ fmap genLayerId [0..(Prelude.length layerDigests)-1]) + + fetchDockerExpr <- mkFetchDocker dim fetchconfig fetchlayers + + pure (Fix $ NSet [ dockerImgExpr fetchDockerExpr ]) + + where + dockerImgExpr fDockerExpr = NamedVar imgSelector fDockerExpr + genLayerId i = mkSym . T.pack $ "layer" <> show i + imgSelector = + [ StaticKey "config" + , StaticKey "docker" + , StaticKey "images" + , StaticKey imageName + ] + commonInherits = inherit + [ StaticKey "registry" + , StaticKey "repository" + , StaticKey "imageName" + , StaticKey "tag" + ] + +-- | Generate a @pkgs.fetchdocker { ... }@ function call and argument +-- attribute set. Please see 'generateNixExprs' documentation for an +-- example of full output. +mkFetchDocker :: HockerImageMeta -> NExpr -> NExpr -> Either HockerException NExpr +mkFetchDocker HockerImageMeta{..} fetchconfig fetchlayers = do + registry <- Bifunctor.first mkHockerException serializedRegistry + pure + (mkApp (mkPkgsAttrSelector constFetchdocker) + (attrsE + [ ("name", mkStr $ fromMaybe imageName altImageName) + , ("registry", mkStr registry) + , ("repository", mkStr imageRepo) + , ("imageName", mkStr imageName) + , ("tag", mkStr (T.pack $ coerce imageTag)) + , ("imageConfig", fetchconfig) + , ("imageLayers", fetchlayers) + ])) + where + serializedRegistry = decodeUtf8' (serializeURIRef' dockerRegistry) + mkHockerException (DecodeError err char) = + HockerException (err <> " " <> (show char)) Nothing Nothing + mkHockerException err = + HockerException (show err) Nothing Nothing + + +-- | Generate a @pkgs.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. +mkFetchDockerConfig :: Binding NExpr -> Base32Digest -> NExpr +mkFetchDockerConfig inherits (Base32Digest digest) = + mkApp (mkPkgsAttrSelector constFetchDockerConfig) + (Fix $ NSet [ inherits, "sha256" $= (mkStr digest) ]) + +-- | Generate a list of Nix expression ASTs representing +-- @pkgs.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 +-- @nix-hash@ base32 encoded copy. +-- +-- This is necessary because fixed output derivations require a +-- pre-computed hash (which we have, thanks to the manifest) and the +-- hash must be base32 encoded using @nix-hash@'s own base32 +-- encoding. The base16 encoded hash digest is needed intact in order +-- for the @pkgs.fetchDockerLayer@ builder script (which calls the +-- @hocker-layer@ utility) to download the layer from a docker +-- registry. +mkFetchDockerLayers :: Binding NExpr -> [(Base16Digest, Base32Digest)] -> [Binding NExpr] +mkFetchDockerLayers inherits layerDigests = + fmap mkFetchLayer $ Prelude.zip [0..(Prelude.length layerDigests)] layerDigests + where + mkLayerId i = T.pack $ "layer" <> show i + mkFetchLayer (i, ((Base16Digest d16), (Base32Digest d32))) = + (mkLayerId i) $= mkApp (mkPkgsAttrSelector constFetchDockerLayer) + (Fix $ NSet + [ inherits + , "layerDigest" $= (mkStr d16) -- Required in order to perform a registry request + , "sha256" $= (mkStr d32) -- Required by Nix for fixed output derivations + ]) + +-- | Generate a selector for an attribute within the @pkgs@ set; i.e +-- @pkgs.fetchDockerLayer@. +mkPkgsAttrSelector :: T.Text -> NExpr +mkPkgsAttrSelector k = Fix $ NSelect (mkSym "pkgs") [StaticKey k] Nothing diff --git a/src/Data/Docker/Nix/Lib.hs b/src/Data/Docker/Nix/Lib.hs new file mode 100644 index 0000000..e356ce0 --- /dev/null +++ b/src/Data/Docker/Nix/Lib.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Docker.Nix.Lib +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Data.Docker.Nix.Lib where + +import Control.Foldl as Foldl +import Turtle +import Control.Monad.Except as Except +import qualified Data.Text as T + +import Types +import Types.Exceptions + +-- | Convert a @Base16Digest@ to a @Base32Digest@ using the supplied +-- `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. +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. + -> m Base32Digest +toBase32Nix nixhash (Base16Digest d16) = + Turtle.fold convertDigest Foldl.head >>= \case + Nothing -> throwError $ HockerException "nothing was returned by `nix-hash', not even an error" Nothing Nothing + Just result -> + either + (throwError . hockerExc . T.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 new file mode 100644 index 0000000..1586e32 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Lib +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Lib where + +import Control.Exception (throwIO) +import Control.Lens +import qualified Control.Monad.Except as Except +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Crypto.Hash as Hash +import qualified Data.Aeson +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.Encoding (encodeUtf8) +import Network.Wreq +import Nix.Expr (NExpr) +import Nix.Pretty +import System.Directory (findExecutable) +import System.Environment (getProgName) +import System.Exit as Exit +import System.FilePath.Posix as File +import System.IO (stdout) +import Text.PrettyPrint.ANSI.Leijen as Text.PrettyPrint (SimpleDoc, + displayIO, + renderPretty) +import URI.ByteString + +import Data.Docker.Image.V1.Types + +import Types +import Types.Exceptions +import Types.ImageName +import Types.ImageTag + +-- | Throw a @userError@, exiting the program with the supplied +-- message. +die :: MonadIO io => T.Text -> io a +die = liftIO . throwIO . userError . T.unpack + +-- | Print an error message to stderr and return a non-zero exit code, +-- the message is prefixed with the name of the program. +exitProgFail :: String -> IO a +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. +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 + +-- | Make a path given a base path and a docker container name. +mkOutImage :: ImageName -> FilePath -> 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 +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 +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 +joinURIPath pts uri@URI{..} = uri { uriPath = joinedParts } + where + joinedParts = C8.pack $ File.joinPath ("/":"v2":(C8.unpack uriPath):pts) + +-- | Produce an @Options@ using @Network.Wreq.defaults@ and an @Auth@. +opts :: Maybe Auth -> Options +opts bAuth = Network.Wreq.defaults & Network.Wreq.auth .~ bAuth + +-- | Hash a @Data.ByteString.Lazy.Char8@ using the 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 ":" + +-- | Encode, following Docker's canonical JSON rules, any @ToJSON@ +-- data type. +-- +-- The canonicalization rules enable consistent hashing of encoded +-- JSON, a process relied upon heavily by docker for content +-- addressability and unique identification of resources within a +-- docker registry. Notably, an image's config JSON file and layers. +-- +-- NB: +-- intentionally *does not* follow the 's +-- Canonical JSON format even though it was inspired by it. +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) + => Maybe FilePath + -> m (FilePath) +requireOutPath = maybe outPathError return + where + outPathError = 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 +-- registry image manifest. Attempting to parse and return the digest +-- value as a `Digest SHA256`, otherwise throwing an error. +getConfigDigest :: (Except.MonadError HockerException m) + => C8L.ByteString + -> m (Hash.Digest Hash.SHA256) +getConfigDigest (view (key "config" . key "digest" . _String) -> digest) = + maybe badDigest return parsedDigest + where + 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 + +-- | 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@. +renderNixExpr :: NExpr -> Text.PrettyPrint.SimpleDoc +renderNixExpr = renderPretty 0.4 120 . prettyNix + +-- | Pretty print a Nix expression AST and print to stdout. +pprintNixExpr :: NExpr -> IO () +pprintNixExpr = displayIO stdout . renderNixExpr + +-- | Given an executable's name, try to find it in the current +-- process's PATH context. +findExec :: (MonadIO m, Except.MonadError HockerException m) + => String + -> m Prelude.FilePath +findExec execname = (liftIO $ findExecutable execname) >>= \case + Just v -> return v + Nothing -> Except.throwError $ + HockerException + ("cannot find executable `" <> execname <> "'") + Nothing + Nothing diff --git a/src/Network/Wreq/Docker/Image/Lib.hs b/src/Network/Wreq/Docker/Image/Lib.hs new file mode 100644 index 0000000..2d8b08d --- /dev/null +++ b/src/Network/Wreq/Docker/Image/Lib.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Network.Wreq.Docker.Image.Lib +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- 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.V1_2.Types +import Lib +import Network.Wreq.Docker.Registry.V2 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*. +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 the 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 <- Lib.requireOutPath 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 <- Lib.requireOutPath 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 +-- 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 <- Lib.requireOutPath outDir + liftIO $ C8L.writeFile + (imageOutDir "repositories") + (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 <- Lib.requireOutPath outDir + archivePath <- Lib.requireOutPath 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 diff --git a/src/Network/Wreq/Docker/Image/V1_2.hs b/src/Network/Wreq/Docker/Image/V1_2.hs new file mode 100644 index 0000000..976ee26 --- /dev/null +++ b/src/Network/Wreq/Docker/Image/V1_2.hs @@ -0,0 +1,158 @@ +{-# 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 : AllRightsReserved +-- 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/V2.hs new file mode 100644 index 0000000..52e3caf --- /dev/null +++ b/src/Network/Wreq/Docker/Registry/V2.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Network.Wreq.Docker.Registry.V2 +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +-- +-- Convenience functions for interacting with an instance of Docker +-- Distribution (Docker Registry V2). I've kept the module naming +-- consistent with the docker registry terms since that appears to be +-- what everyone uses colloquially even though the formal name for the +-- software is "docker distribution". +---------------------------------------------------------------------------- + +module Network.Wreq.Docker.Registry.V2 where + +import Control.Lens +import qualified Control.Monad.Except as Except +import Control.Monad.Reader +import Data.Monoid +import qualified Crypto.Hash as Hash +import Data.Aeson.Lens +import Data.ByteString.Lazy.Char8 as C8L +import qualified Data.ByteString.Char8 as C8 +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import URI.ByteString +import NeatInterpolation +import qualified Data.Text as Text +import qualified Network.Wreq as Wreq +import System.Directory + +import Data.Docker.Image.V1.Types +import Lib +import Types +import Types.Exceptions +import Types.ImageName +import Types.ImageTag + +-- | Default docker hub registry. +defaultRegistry :: URIRef Absolute +defaultRegistry = URI + { uriScheme = Scheme "https" + , uriAuthority = Just $ Authority + { authorityUserInfo = Nothing + , authorityHost = Host "registry-1.docker.io" + , authorityPort = Nothing + } + , uriPath = "/v2/" + , uriQuery = Query [] + , uriFragment = Nothing + } + +mkAuth :: RegistryURI + -> ImageName + -> Maybe Credentials + -> IO (Maybe Wreq.Auth) +mkAuth reg (ImageName img) credentials = + case credentials of + Just (BearerToken token) + -> pure (Just $ Wreq.oauth2Bearer (encodeUtf8 token)) + Just (Basic username password) + -> pure (Just $ Wreq.basicAuth (encodeUtf8 username) (encodeUtf8 password)) + Nothing | reg /= defaultRegistry + -> pure Nothing + | otherwise + -> getHubToken >>= pure . mkHubBearer + where + 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. +-- +-- 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. +-- +-- 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. +pluckRefLayersFrom :: ImageConfigJSON -> [Layer] +pluckRefLayersFrom = toListOf (key "rootfs" . key "diff_ids" . values . _String) + +----------------------------------------------------------------------------- +-- Top-level docker-registry V2 REST interface functions + +-- | Request a V2 registry manifest for the specified docker image. +fetchManifest :: Hocker RspBS +fetchManifest = ask >>= \HockerMeta{..} -> + liftIO $ Wreq.getWith (opts auth & accept) (mkURL imageName imageTag dockerRegistry) + where + mkURL (ImageName n) (ImageTag t) r = C8.unpack (serializeURIRef' $ Lib.joinURIPath [n, "manifests", t] r) + accept = Wreq.header "Accept" .~ + [ "application/vnd.docker.distribution.manifest.v2+json" + , "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). +fetchImageConfig :: (Hash.Digest Hash.SHA256) -> Hocker RspBS +fetchImageConfig (showSHA -> digest) = ask >>= \HockerMeta{..} -> + liftIO $ Wreq.getWith (opts auth) (mkURL imageName dockerRegistry) + where + mkURL (ImageName n) r = C8.unpack (serializeURIRef' $ Lib.joinURIPath [n, "blobs", digest] r) + +-- | Retrieve a compressed layer blob by its hash digest. +-- +-- TODO: take advantage of registry's support for the Range header so +-- we can stream downloads. +fetchLayer :: Layer -> Hocker RspBS +fetchLayer layer = ask >>= \HockerMeta{..} -> + liftIO $ Wreq.getWith (opts auth) (mkURL layer imageName dockerRegistry) + where + mkURL + (Text.unpack -> digest) + (ImageName name) + 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. +-- +-- The second argument, the @StrippedDigest@, must be a hash digest +-- stripped of the "sha256:" hash 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 + -> 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 + 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 +-- 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 +-- between the time you issue a request with a digest and when you +-- receive a response back! +writeRespBody' :: FilePath -- ^ Filesystem path to write the content to + -> RspBS -- ^ Wreq lazy bytestring response object + -> Hocker FilePath +writeRespBody' out r = writeRespBody out etagHash r + where + etagHash = decodeUtf8 $ r ^. Wreq.responseHeader "ETag" + +-- | Compute a sha256 hash digest of the response body and compare it +-- against the supplied hash digest. +checkResponseIntegrity :: (Except.MonadError HockerException m) + => RspBS -- ^ Wreq lazy bytestring response object + -> StrippedDigest -- ^ Hash digest, stripped of its hash algorithm identifier prefix + -> m RspBS +checkResponseIntegrity r d = do + let contentHash = show . Lib.sha256 $ r ^. Wreq.responseBody + digestHash = Text.unpack d + if | contentHash == digestHash -> pure r + | otherwise -> + let chTxt = Text.pack contentHash + dgTxt = Text.pack digestHash + in Except.throwError + (hockerException + (Text.unpack [text| + Response content hash is $chTxt + and it does not match the addressable content hash + $dgTxt + |])) + +-- | Compute a sha256 hash digest of the response body and compare it +-- against the @Docker-Content-Digest@ header from the response. +-- +-- The Docker docs do *not* recommended this method for verification +-- because the Docker-Content-Digest header may change between the +-- time you issue a request with a digest and when you receive a +-- response back! +-- +-- NB: some registries do not send a @Docker-Content-Digest@ header, +-- I'm not sure yet what the cause for this is but this function's +-- behavior lacking that information is to ignore the hash check. +checkResponseIntegrity' :: (Except.MonadError HockerException m) + => RspBS -- ^ Wreq lazy bytestring response object + -> m RspBS +checkResponseIntegrity' rsp = + case decodeUtf8 (rsp ^. Wreq.responseHeader "Docker-Content-Digest") of + -- Since some registries may send back no Docker-Content-Digest + -- header, or an empty one, if it is empty then ignore it + "" -> pure rsp + digest -> checkResponseIntegrity rsp (Lib.stripHashId digest) + +-- | Compute a sha256 hash digest for a file and compare that hash to +-- the supplied hash digest. +checkFileIntegrity :: FilePath -- ^ Filesystem path of file to verify + -> StrippedDigest -- ^ Hash digest, stripped of its hash algorithm identifier prefix + -> IO (Either String FilePath) +checkFileIntegrity fp digest = + Except.runExceptT $ do + exists <- liftIO (doesFileExist fp) + when (not exists) $ + fail (fp <> " does not exist") + + fileHash <- liftIO (return . show . Lib.sha256 =<< C8L.readFile fp) + + when (Text.unpack digest /= fileHash) $ + let fhTxt = Text.pack fileHash + fpTxt = Text.pack fp + in fail $ Text.unpack + ([text| + The sha256 hash for $fpTxt: $fhTxt + Does not match the expected digest: $digest + |]) + + return fp diff --git a/src/Network/Wreq/ErrorHandling.hs b/src/Network/Wreq/ErrorHandling.hs new file mode 100644 index 0000000..cc098e5 --- /dev/null +++ b/src/Network/Wreq/ErrorHandling.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Network.Wreq.ErrorHandling +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Network.Wreq.ErrorHandling where + +import Control.Exception.Lifted as Lifted +import Control.Lens +import Control.Monad.Except +import Data.ByteString.Char8 as C8 +import Data.Monoid +import Network.HTTP.Client +import Network.HTTP.Types.Status + +#if !MIN_VERSION_http_client(0,5,0) +import Data.HashMap.Lazy as H +#endif + +import Types.Exceptions + +interceptHttpExc :: ExceptT HockerException IO a + -> ExceptT HockerException IO a +interceptHttpExc a = Lifted.try a >>= except . over _Left prettify + where + except (Left e) = throwError e + except (Right v) = return v + +prettify :: HttpException -> HockerException +#if MIN_VERSION_http_client(0,5,0) +prettify + (HttpExceptionRequest _ + (StatusCodeException + (responseStatus -> (Status code msg)) body)) + = HockerException + (show code <> " " <> C8.unpack msg) + (Just $ C8.unpack body) + Nothing +#else +prettify + (StatusCodeException (Status code msg) (H.fromList -> e) _) + = HockerException + ((show code) <> " " <> C8.unpack msg) + (C8.unpack <$> H.lookup "X-Response-Body-Start" e) + Nothing +#endif + +prettify e = HockerException (show e) Nothing Nothing diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 0000000..9143b17 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Types +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Types where + +import Control.Applicative +import Control.Monad.Error.Class +import qualified Control.Monad.Except as Except +import Control.Monad.IO.Class +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.Monoid +import Data.Text (Text) +import qualified Data.Text as Text +import Network.Wreq +import qualified Network.Wreq as Wreq +import Network.Wreq.ErrorHandling +import qualified Options.Applicative as Options +import Options.Generic +import URI.ByteString + +import Types.Exceptions +import Types.Hash () +import Types.ImageName +import Types.ImageTag +import Types.URI () + +-- | Docker registry URI. +type RegistryURI = (URIRef Absolute) + +-- | Docker registry username. +type Username = Text + +-- | Docker registry user password. +type Password = Text + +-- | Docker image layer sha256 hash digest. +type Layer = Text + +-- | SHA256 hash digest with the hash algorithm identifier prefix, +-- stripped +type StrippedDigest = Text + +-- | Docker image manifest JSON. +type Manifest = Data.ByteString.Lazy.ByteString + +-- | Docker image config JSON. +type ImageConfigJSON = Data.ByteString.Lazy.ByteString + +-- | Wreq response type parameterized by the lazy bytestring type. +type RspBS = Network.Wreq.Response Data.ByteString.Lazy.ByteString + +-- | A file extension. +type Extension = String + +-- | RepoName is the part before the forward slash in a docker image +-- name, e.g: @library@ in @library/debian@ +type RepoNamePart = Text + +-- | ImageName is the part after the forward slash in a docker image +-- name, e.g: @library@ in @library/debian@ +type ImageNamePart = Text + +-- | Docker image config JSON file's sha256 hash digest in Nix's +-- base32 encoding. +-- +-- NB: it's very important to realize there's a significant difference +-- between Nix's base32 encoding and the standard base32 encoding! +-- (i.e, they're not compatible). +type ConfigDigest = Base32Digest + +-- | Generic top-level optparse-generic CLI args data type and +-- specification. +-- +-- NOTE: `hocker-layer` does not use this data type because it +-- requires an additional layer sha256 hash digest argument. +data OptArgs w = OptArgs + { -- | URI for the registry, optional + registry :: w ::: Maybe RegistryURI + "URI of registry, defaults to the Docker Hub registry" + , credentials :: Maybe Credentials + -- | Filesystem path to write output to + , out :: w ::: Maybe FilePath + "Write content to location" + -- | Docker image name (includes the reponame, e.g: library/debian) + , imageName :: ImageName + -- | Docker image tag + , imageTag :: ImageTag + } deriving (Generic) + +instance ParseRecord (OptArgs Wrapped) +deriving instance Show (OptArgs Unwrapped) + +-- | Hocker 'ExceptT' and 'ReaderT' transformer stack threading a +-- 'HockerMeta' data type. +newtype Hocker a = Hocker { unHocker :: Reader.ReaderT HockerMeta (Except.ExceptT HockerException IO) a } + deriving + ( Functor + , Applicative + , Monad + , MonadIO + , MonadReader HockerMeta + , MonadError HockerException + ) + +runHocker :: Hocker a -> HockerMeta -> IO (Either HockerException a) +runHocker (unHocker -> d) = Except.runExceptT . interceptHttpExc . Reader.runReaderT d + +-- | Red wagon record carrying around the environment as we fetch, +-- transform, and assemble docker image artifacts. +data HockerMeta = HockerMeta + { dockerRegistry :: RegistryURI + , auth :: Maybe Wreq.Auth + , imageName :: ImageName + , imageTag :: ImageTag + , out :: Maybe FilePath + , outDir :: Maybe FilePath + , imageLayer :: Maybe (Hash.Digest Hash.SHA256) + } deriving (Show) + +-- | Newtype base32 encoding of a hash digest. +-- +-- Please note, this base32 encoding is unique to Nix and not +-- compatible with other base32 encodings. +newtype Base32Digest = Base32Digest Text + deriving (Show, Read, Eq) + +-- | Newtype base16 encoding of a hash digest. +-- +-- This encoding has no known idiosyncracies specific to Nix, it +-- should be compatible with other tools and library's expectations. +newtype Base16Digest = Base16Digest Text + deriving (Show, Read, Eq) + +data Credentials = Basic Username Password | BearerToken Text + deriving (Show) + +instance ParseField Credentials where + parseField _ _ = (Basic <$> parseUsername <*> parsePassword) <|> (BearerToken <$> parseToken) + where + parseUsername = Text.pack <$> + (Options.option Options.str $ + ( Options.metavar "BASIC USERNAME" + <> Options.long "username" + <> Options.short 'u' + <> Options.help "Username part of a basic auth credential" + ) + ) + parsePassword = Text.pack <$> + (Options.option Options.str $ + ( Options.metavar "BASIC PASSWORD" + <> Options.long "password" + <> Options.short 'p' + <> Options.help "Password part of a basic auth credential" + ) + ) + parseToken = Text.pack <$> + (Options.option Options.str $ + ( Options.metavar "BEARER TOKEN" + <> Options.long "token" + <> Options.short 't' + <> Options.help "Bearer token retrieved from a call to `docker login` (mutually exclusive to --username and --password)" + ) + ) + +instance ParseFields Credentials +instance ParseRecord Credentials where + parseRecord = fmap Options.Generic.getOnly parseRecord diff --git a/src/Types/Exceptions.hs b/src/Types/Exceptions.hs new file mode 100644 index 0000000..5c83e2d --- /dev/null +++ b/src/Types/Exceptions.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Types.Exceptions +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Types.Exceptions where + +import Control.DeepSeq +import Control.Exception +import Data.Monoid +import GHC.Generics + +data HockerException = HockerException + { baseMsg :: String + , expected :: Maybe String + , received :: Maybe String + } deriving (Read, Generic, NFData) + +instance Exception HockerException +instance Show HockerException where + show (HockerException m e r) = m <> (ext $ e <> r) + where + ext (Just v) = "; " <> v + ext Nothing = mempty + +hockerException :: String -> HockerException +hockerException m = HockerException m Nothing Nothing diff --git a/src/Types/Hash.hs b/src/Types/Hash.hs new file mode 100644 index 0000000..d202ca0 --- /dev/null +++ b/src/Types/Hash.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Types.Hash +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Types.Hash where + +import qualified Crypto.Hash as Hash +import qualified Data.ByteArray as BA +import qualified Data.ByteArray.Encoding as BA +import qualified Data.ByteString.Char8 as C8 +import Data.Monoid +import qualified Data.Text +import qualified Options.Applicative as Options +import Options.Generic + +toBytes :: C8.ByteString -> Either String BA.Bytes +toBytes = BA.convertFromBase BA.Base16 + +readSHA256 :: C8.ByteString -> Maybe (Hash.Digest Hash.SHA256) +readSHA256 = either (const Nothing) Hash.digestFromByteString . toBytes + +instance ParseField (Hash.Digest Hash.SHA256) where + parseField h _ = + (Options.option (Options.maybeReader (readSHA256 . C8.pack)) $ + ( Options.metavar "SHA256" + <> Options.short 'l' + <> Options.long "layer" + <> maybe mempty (Options.help . Data.Text.unpack) h + ) + ) + +instance ParseFields (Hash.Digest Hash.SHA256) where +instance ParseRecord (Hash.Digest Hash.SHA256) where + parseRecord = fmap getOnly parseRecord diff --git a/src/Types/ImageName.hs b/src/Types/ImageName.hs new file mode 100644 index 0000000..4d8a3fa --- /dev/null +++ b/src/Types/ImageName.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Types.ImageName +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Types.ImageName where + +import Control.DeepSeq +import Data.Monoid +import qualified Options.Applicative as Options +import Options.Generic + +newtype ImageName = ImageName { unImageName :: String } + deriving (Generic, Show) + +instance ParseField ImageName where + parseField _ _ = + ImageName <$> + (Options.argument Options.str $ + ( Options.metavar "IMAGE-NAME" + <> Options.help "Docker image name, e.g: 'debian' in debian:jessie" + ) + ) + +instance ParseFields ImageName where +instance ParseRecord ImageName where + parseRecord = fmap getOnly parseRecord + +instance NFData ImageName diff --git a/src/Types/ImageTag.hs b/src/Types/ImageTag.hs new file mode 100644 index 0000000..3af0198 --- /dev/null +++ b/src/Types/ImageTag.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Types.ImageTag +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Types.ImageTag where + +import Control.DeepSeq +import Data.Monoid +import qualified Options.Applicative as Options +import Options.Generic + +newtype ImageTag = ImageTag { unImageTag :: String } + deriving (Generic, Show) + +instance ParseField ImageTag where + parseField _ _ = + ImageTag <$> + (Options.argument Options.str $ + ( Options.metavar "IMAGE-TAG" + <> Options.help "Docker image tag identifier, e.g: 'jessie' in debian:jessie" + ) + ) + +instance ParseFields ImageTag where +instance ParseRecord ImageTag where + parseRecord = fmap getOnly parseRecord + +instance NFData ImageTag diff --git a/src/Types/URI.hs b/src/Types/URI.hs new file mode 100644 index 0000000..1a98b84 --- /dev/null +++ b/src/Types/URI.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS -fno-warn-orphans #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Types.URI +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Types.URI where + +import Control.Lens +import qualified Data.ByteString.Char8 as C8 +import Data.Monoid +import qualified Data.Text as Text +import qualified Options.Applicative as Options +import Options.Applicative.Builder +import Options.Generic +import URI.ByteString + +-- | Parse a URI value. +uriReader :: ReadM (URIRef Absolute) +uriReader = Options.eitherReader parseURIArg + where + parseURIArg (parseURI strictURIParserOptions . C8.pack -> parsedURI) = + over _Left show parsedURI + +instance ParseField (URIRef Absolute) where + parseField h n = + (Options.option uriReader $ + ( Options.metavar "URI" + <> foldMap (Options.long . Text.unpack) n + <> foldMap (Options.help . Text.unpack) h + ) + ) + +instance ParseFields (URIRef Absolute) where +instance ParseRecord (URIRef Absolute) where + parseRecord = fmap getOnly parseRecord diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..ef450c6 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,10 @@ +flags: {} +nix: + shell-file: nix/shell.nix +extra-package-dbs: [] +packages: +- '.' +extra-deps: +- concurrentoutput-0.2.0.2 +- hnix-0.3.4 +resolver: lts-8.12 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..240f883 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,19 @@ + +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.Nix.FetchDocker as FetchDockerTests + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" + [ ImageV1Tests.unitTests + , ImageV1_2Tests.unitTests + , FetchDockerTests.tests + ] diff --git a/test/Tests/Data/Docker/Image/V1.hs b/test/Tests/Data/Docker/Image/V1.hs new file mode 100644 index 0000000..c7af17a --- /dev/null +++ b/test/Tests/Data/Docker/Image/V1.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Docker.Image.V1 +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- 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/Image/V1_2.hs b/test/Tests/Data/Docker/Image/V1_2.hs new file mode 100644 index 0000000..5249150 --- /dev/null +++ b/test/Tests/Data/Docker/Image/V1_2.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Docker.Image.V1_2 +-- Copyright : (C) 2016 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +module Tests.Data.Docker.Image.V1_2 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 Test.Tasty +import Test.Tasty.HUnit + +import Lib + +----------------------------------------------------------------------------- +-- +unitTests = testGroup "V1.2 Image Tests" + [ testCase "ImageManifest golden encoding" testImageManifestGoldenEncoding + , testCase "ImageManifest two-way encoding" testImageManifestTwoWayEncoding + , testCase "ImageRepositories golden encoding" testImageRepositoriesGoldenEncoding + , testCase "ImageRepositories two-way encoding" testImageRepositoriesTwoWayEncoding + ] + +----------------------------------------------------------------------------- +-- TESTS + +testImageManifestGoldenEncoding = + let goldenStr = "[{\"Config\":\"3e83c23dba6a16cd936a3dc044df71b26706c5a4c28181bc3ca4a4af9f5f38ee.json\",\"Layers\":[\"10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9/layer.tar\"],\"RepoTags\":[\"library/debian:jessie\"]}]" + imgManifest = [ImageManifest + "3e83c23dba6a16cd936a3dc044df71b26706c5a4c28181bc3ca4a4af9f5f38ee.json" + [ "library/debian:jessie" ] + [ "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9/layer.tar" ] + ] + in (Lib.encodeCanonical imgManifest) @?= (C8L.pack goldenStr) + +testImageManifestTwoWayEncoding = + let imgManifest = [ImageManifest + "3e83c23dba6a16cd936a3dc044df71b26706c5a4c28181bc3ca4a4af9f5f38ee.json" + [ "library/debian:jessie" ] + [ "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9/layer.tar" ] + ] + encoded = Lib.encodeCanonical imgManifest + in decode encoded @?= (Just imgManifest) + +testImageRepositoriesGoldenEncoding = + let goldenStr = "{\"library/debian\":{\"jessie\":\"10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9\"}}" + imgRepos = ImageRepositories + [ImageRepo + "library/debian" + (H.singleton + "jessie" + "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9")] + + in (Lib.encodeCanonical imgRepos) @?= (C8L.pack goldenStr) + +testImageRepositoriesTwoWayEncoding = + let imgRepos = ImageRepositories + [ImageRepo + "library/debian" + (H.singleton + "jessie" + "10a267c67f423630f3afe5e04bbbc93d578861ddcc54283526222f3ad5e895b9")] + encoded = Lib.encodeCanonical imgRepos + in decode encoded @?= (Just imgRepos) diff --git a/test/Tests/Data/Docker/Nix/FetchDocker.hs b/test/Tests/Data/Docker/Nix/FetchDocker.hs new file mode 100644 index 0000000..304939e --- /dev/null +++ b/test/Tests/Data/Docker/Nix/FetchDocker.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Docker.Nix.FetchDocker +-- Copyright : (C) 2017 Awake Networks +-- License : AllRightsReserved +-- Maintainer : Awake Networks +-- Stability : stable +---------------------------------------------------------------------------- + +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 Network.URI +import Test.Tasty +import Test.Tasty.Golden +import Test.Tasty.HUnit +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 Lib +import Network.Wreq.Docker.Registry.V2 as Docker.Registry +import Types +import Types.ImageTag + +tests = testGroup "FetchDocker Nix Generation Tests" + [ goldenVsString + "Golden vs. Generated `fetchDocker' Nix Expression" + "test/data/golden-debian:jessie.nix" + generateFetchDockerNix + , testCase "Base16 Digest to Base32 Digest" testBase16toBase32 + ] + +testBase16toBase32 :: Assertion +testBase16toBase32 = do + let b16 = Base16Digest "5c90d4a2d1a8dfffd05ff2dd659923f0ca2d843b5e45d030e17abbcd06a11b5b" + b32 = Base32Digest "0nqvl43cvfvsw4qd0iay7f22vjph4fcnbpgjbz8gzpx8s6id942w" + + res <- Except.runExceptT $ do + nixhash <- Lib.findExec "nix-hash" + Nix.Lib.toBase32Nix nixhash b16 + + either + (assertFailure . show) + (assertEqual "" b32) + res + +generateFetchDockerNix :: IO C8L.ByteString +generateFetchDockerNix = do + manifest <- C8L.readFile "test/data/manifest-debian:jessie.json" + nixExpression <- Nix.FetchDocker.generate + HockerImageMeta + { imageRepo = "library" + , imageName = "debian" + , imageTag = ImageTag "jessie" + , manifestJSON = manifest + , dockerRegistry = defaultRegistry + , altImageName = Nothing + } + + either + (Lib.die . T.pack . show) + (return . C8L.pack . (flip displayS "") . Lib.renderNixExpr) + nixExpression diff --git a/test/data/golden-debian:jessie.nix b/test/data/golden-debian:jessie.nix new file mode 100644 index 0000000..3ce46a3 --- /dev/null +++ b/test/data/golden-debian:jessie.nix @@ -0,0 +1,20 @@ +{ + config.docker.images.debian = pkgs.fetchdocker { + name = "debian"; + registry = "https://registry-1.docker.io/v2/"; + repository = "library"; + imageName = "debian"; + tag = "jessie"; + imageConfig = pkgs.fetchDockerConfig { + inherit registry repository imageName tag; + sha256 = "1rwinmvfc8jxn54y7qnj82acrc97y7xcnn22zaz67y76n4wbwjh5"; + }; + imageLayers = let + layer0 = pkgs.fetchDockerLayer { + inherit registry repository imageName tag; + layerDigest = "cd0a524342efac6edff500c17e625735bbe479c926439b263bbe3c8518a0849c"; + sha256 = "1744l0c8ag5y7ck9nhr6r5wy9frmaxi7xh80ypgnxb7g891m42nd"; + }; + in [ layer0 ]; + }; +} \ No newline at end of file diff --git a/test/data/manifest-debian:jessie.json b/test/data/manifest-debian:jessie.json new file mode 100644 index 0000000..3a804d5 --- /dev/null +++ b/test/data/manifest-debian:jessie.json @@ -0,0 +1,16 @@ +{ + "schemaVersion": 2, + "mediaType": "application/vnd.docker.distribution.manifest.v2+json", + "config": { + "mediaType": "application/vnd.docker.container.image.v1+json", + "size": 1528, + "digest": "sha256:054abe38b1e6f863befa4258cbfaf127b1cc9440d2e2e349b15d22e676b591e7" + }, + "layers": [ + { + "mediaType": "application/vnd.docker.image.rootfs.diff.tar.gzip", + "size": 52550276, + "digest": "sha256:cd0a524342efac6edff500c17e625735bbe479c926439b263bbe3c8518a0849c" + } + ] +}