Add support for manifest lists

hocker-config/Main.hs

@@ -30,6 +30,7 @@ progSummary = "Fetch a docker image config JSON from the registry"
 main :: IO ()
 main = unwrapRecord progSummary >>= \Options{..} -> do
   let dockerRegistry = fromMaybe defaultRegistry registry
+      imageArch      = fromMaybe systemArch arch
 
   auth   <- mkAuth dockerRegistry imageName credentials
   config <- Docker.Image.fetchConfig $

hocker-image/Main.hs

@@ -32,6 +32,7 @@ progSummary = "Fetch a docker image from a docker registry without using docker"
 main :: IO ()
 main = unwrapRecord progSummary >>= \Options{..} -> do
   let dockerRegistry = fromMaybe defaultRegistry registry
+      imageArch      = fromMaybe systemArch arch
 
   auth <- mkAuth dockerRegistry imageName credentials
   img  <- withSystemTempDirectory "hocker-image-XXXXXX" $ \d ->

hocker-layer/Main.hs

@@ -67,6 +67,7 @@ main = unwrapRecord progSummary >>= \ProgArgs{..} -> do
     HockerMeta
       { outDir     = Nothing
       , imageLayer = Just imageLayer
+      , imageArch  = systemArch
       , ..
       }
   either (Hocker.Lib.exitProgFail . show) Prelude.putStrLn layerPath

hocker-manifest/Main.hs

@@ -30,6 +30,7 @@ progSummary = "Pull a docker image manifest from the registry"
 main :: IO ()
 main = unwrapRecord progSummary >>= \Options{..} -> do
   let dockerRegistry =  fromMaybe defaultRegistry registry
+      imageArch      =  fromMaybe systemArch arch
 
   auth     <- mkAuth dockerRegistry imageName credentials
   manifest <- Docker.Image.fetchImageManifest $

hocker.cabal

@@ -81,6 +81,7 @@ library
                 foldl                >= 1.0,
                 hnix                 >= 0.9.0,
                 http-client          >= 0.4,
+                http-client-tls      >= 0.3 && < 0.4,
                 http-types           >= 0.9.1,
                 lens                 >= 4.0,
                 lens-aeson           >= 1.0,

src/Hocker/Lib.hs

@@ -35,6 +35,9 @@ import           Prettyprinter                (LayoutOptions(..),
 import qualified Prettyprinter
 import qualified Prettyprinter.Render.Text
 import           Data.Text.Encoding           (encodeUtf8)
+import           Network.HTTP.Client          (ManagerSettings(managerModifyRequest),
+                                               Request(shouldStripHeaderOnRedirect))
+import           Network.HTTP.Client.TLS      (tlsManagerSettings)
 import qualified Network.Wreq                 as Wreq
 import           Nix.Expr                     (NExpr)
 import           Nix.Pretty
@@ -112,7 +115,14 @@ joinURIPath pts uri@URI{..} = uri { uriPath = joinedParts }
 
 -- | Given a 'Wreq.Auth' produce a 'Wreq.Options'.
 opts :: Maybe Wreq.Auth -> Wreq.Options
-opts bAuth = Wreq.defaults & Wreq.auth .~ bAuth
+opts bAuth = Wreq.defaults
+               & Wreq.auth .~ bAuth
+               & Wreq.manager .~
+                   (Left tlsManagerSettings{managerModifyRequest =
+                                              pure . stripAuthHeader})
+  where
+    stripAuthHeader request =
+      request{shouldStripHeaderOnRedirect = (== "Authorization")}
 
 -- | Hash a 'Data.ByteString.Lazy.Char8' using the 'Hash.SHA256'
 -- algorithm.

src/Hocker/Types.hs

@@ -37,6 +37,7 @@ import qualified Network.Wreq               as Wreq
 import           Network.Wreq.ErrorHandling
 import qualified Options.Applicative        as Options
 import           Options.Generic
+import qualified System.Info                as Info (arch)
 import           URI.ByteString
 
 import           Hocker.Types.Exceptions
@@ -89,6 +90,10 @@ type ImageNamePart   = Text
 -- (i.e, they're not compatible).
 type ConfigDigest    = Base32Digest
 
+-- |Architecture of docker image. This is required when manifests api returns
+-- a V2 Schema 2 list of manifests for different architecture
+type Arch            = Text
+
 -- | Generic top-level optparse-generic CLI args data type and
 -- specification.
 --
@@ -103,6 +108,9 @@ data Options w = Options
     , out         :: w ::: Maybe FilePath
       <?> "Write content to location"
       -- | Docker image name (includes the reponame, e.g: library/debian)
+    , arch        :: w ::: Maybe Arch
+    <?> "Image architecture to pick, defaults to current architecture"
+    -- | Docker image architecture, amd64, arm64, etc.,
     , imageName   :: ImageName
       -- | Docker image tag
     , imageTag    :: ImageTag
@@ -136,6 +144,7 @@ data HockerMeta = HockerMeta
     , out            :: Maybe FilePath
     , outDir         :: Maybe FilePath
     , imageLayer     :: Maybe (Hash.Digest Hash.SHA256)
+    , imageArch      :: Arch
     } deriving (Show)
 
 -- | Newtype base32 encoding of a hash digest.
@@ -216,3 +225,19 @@ instance ParseRecord Credentials where
 upperFirst :: String -> String
 upperFirst []    = []
 upperFirst (h:t) = toUpper h : t
+
+-- |Converts 'arch' from System.Info to the arch string expected by Docker
+-- See valid values fro "$GOARCH" in https://go.dev/doc/install/source#environment
+systemArch :: Arch
+systemArch =
+  case Info.arch of
+    "aarch64" -> "amd64"
+    "arm"     -> "arm"
+    "i386"    -> "386"
+    "mips"    -> "mips"
+    "mipseb"  -> "mipsle"
+    "mipsel"  -> "mipsle"
+    "powerpc64" -> "ppc64"
+    "powerpc64le" -> "ppc64le"
+    "x86_64"      -> "amd64"
+    unknownArch   -> error ("Unknown architecture: " <> unknownArch)

src/Network/Wreq/Docker/Registry.hs

@@ -27,6 +27,7 @@ module Network.Wreq.Docker.Registry where
 
 import qualified Control.Exception          as Exception
 import           Control.Lens
+import           Control.Monad              (when)
 import qualified Control.Monad.Except       as Except
 import           Control.Monad.Reader
 import qualified Crypto.Hash                as Hash
@@ -143,17 +144,27 @@ pluckRefLayersFrom = toListOf (key "rootfs" . key "diff_ids" . values . _String)
 
 -- | 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)
+fetchManifest = ask >>= \HockerMeta{..} -> do
+  resp <- liftIO $ Wreq.getWith (opts auth & accept) (mkURL imageName imageTag dockerRegistry)
+  case resp ^. Wreq.responseHeader "Content-Type" of
+    "application/vnd.docker.distribution.manifest.list.v2+json" ->
+      case findOf
+             folded
+             (\m -> m ^. key "platform" . key "architecture" . _String == imageArch)
+             (resp ^. Wreq.responseBody . key "manifests" . _Array) of
+        Just m -> local (\_ -> HockerMeta {imageTag = ImageTag (m ^. key "digest" . _String . to Text.unpack), ..}) fetchManifest
+        Nothing -> error "No manifest found for required architecture"
+    _ -> pure resp
   where
     mkURL (ImageName n) (ImageTag t) r = C8.unpack (serializeURIRef' $ Hocker.Lib.joinURIPath [n, "manifests", t] r)
     accept = Wreq.header "Accept" .~
-      [ "application/vnd.docker.distribution.manifest.v2+json" ]
+      [ "application/vnd.docker.distribution.manifest.v2+json"
+      , "application/vnd.docker.distribution.manifest.list.v2+json" ]
 
 -- | Retrieve the configuratino JSON of an image by its hash digest
 -- (found in the V2 manifest for an image given by a name and a tag).
 fetchImageConfig :: (Hash.Digest Hash.SHA256) -> Hocker RspBS
-fetchImageConfig (showSHA -> digest) = ask >>= \HockerMeta{..} ->
+fetchImageConfig (showSHA -> digest) = ask >>= \HockerMeta{..} -> do
   liftIO $ Wreq.getWith (opts auth) (mkURL imageName dockerRegistry)
   where
     mkURL (ImageName n) r = C8.unpack (serializeURIRef' $ Hocker.Lib.joinURIPath [n, "blobs", digest] r)