Fix anonymous access for other registries

hocker-config/Main.hs

@@ -31,7 +31,7 @@ main :: IO ()
 main = unwrapRecord progSummary >>= \Options{..} -> do
   let dockerRegistry = fromMaybe defaultRegistry registry
 
-  auth   <- mkAuth dockerRegistry imageName credentials
+  auth   <- mkAuth dockerRegistry imageName imageTag credentials
   config <- Docker.Image.fetchConfig $
     HockerMeta
       { outDir     = Nothing

hocker-image/Main.hs

@@ -33,7 +33,7 @@ main :: IO ()
 main = unwrapRecord progSummary >>= \Options{..} -> do
   let dockerRegistry = fromMaybe defaultRegistry registry
 
-  auth <- mkAuth dockerRegistry imageName credentials
+  auth <- mkAuth dockerRegistry imageName imageTag credentials
   img  <- withSystemTempDirectory "hocker-image-XXXXXX" $ \d ->
     Docker.Image.fetchImage $
       HockerMeta

hocker-layer/Main.hs

@@ -62,7 +62,7 @@ main :: IO ()
 main = unwrapRecord progSummary >>= \ProgArgs{..} -> do
   let dockerRegistry = fromMaybe defaultRegistry registry
 
-  auth      <- mkAuth dockerRegistry imageName credentials
+  auth      <- mkAuth dockerRegistry imageName imageTag credentials
   layerPath <- Docker.Image.fetchLayer $
     HockerMeta
       { outDir     = Nothing

hocker-manifest/Main.hs

@@ -31,7 +31,7 @@ main :: IO ()
 main = unwrapRecord progSummary >>= \Options{..} -> do
   let dockerRegistry =  fromMaybe defaultRegistry registry
 
-  auth     <- mkAuth dockerRegistry imageName credentials
+  auth     <- mkAuth dockerRegistry imageName imageTag credentials
   manifest <- Docker.Image.fetchImageManifest $
     HockerMeta
       { outDir     = Nothing

hocker.cabal

@@ -59,6 +59,7 @@ library
                   Data.Docker.Nix.Lib,
                   Hocker.Lib,
                   Hocker.Types,
+                  Hocker.Types.AuthInfo,
                   Hocker.Types.Exceptions,
                   Hocker.Types.Hash,
                   Hocker.Types.ImageName,
@@ -73,6 +74,7 @@ library
                 aeson                >= 2.0.1.0,
                 aeson-pretty         >= 0.8,
                 bytestring           >= 0.10,
+                case-insensitive     >= 1.2.1.0,
                 concurrentoutput     >= 0.2,
                 crypton              >= 0.32,
                 data-fix             >= 0.0.3,
@@ -174,7 +176,8 @@ test-suite hocker-tests
   main-is:             Main.hs
   other-modules:
                 Tests.Data.Docker.Image,
-                Tests.Data.Docker.Nix.FetchDocker
+                Tests.Data.Docker.Nix.FetchDocker,
+                Tests.Hocker.Types.AuthInfo
   build-depends:
                 base                 >= 4.9 && < 5,
                 aeson                >= 0.9.0.1,
@@ -188,6 +191,7 @@ test-suite hocker-tests
                 tasty-hunit          >= 0.9,
                 text                 >= 1.2,
                 unordered-containers >= 0.2,
+                uri-bytestring       >= 0.2,
                 word8                >= 0.1.0
 
 

src/Hocker/Types/AuthInfo.hs

@@ -0,0 +1,191 @@
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE OverloadedStrings   #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Hocker.Types.AuthInfo
+-- Copyright   :  (C) 2026 Awake Networks
+-- License     :  Apache-2.0
+-- Maintainer  :  Awake Networks <opensource@awakenetworks.com>
+-- Stability   :  stable
+----------------------------------------------------------------------------
+
+module Hocker.Types.AuthInfo (
+  AuthInfo(..),
+  parseWWWAuthHeader
+) where
+
+import           Control.Applicative          ((<|>))
+import           Data.Bifunctor               (first)
+import qualified Data.ByteString.Char8        as C8
+import qualified Data.CaseInsensitive         as CI
+import           Data.Char                    (isAlphaNum, ord)
+import           Data.Either                  (partitionEithers)
+import           Data.List                    (intercalate)
+import           Data.List.NonEmpty           (NonEmpty)
+import qualified Data.List.NonEmpty           as NonEmpty
+import           URI.ByteString               (Absolute, URIRef, parseURI, strictURIParserOptions)
+import           Text.Read                    (readEither)
+import           Text.ParserCombinators.ReadP
+
+import           Hocker.Types.Exceptions
+
+
+data AuthInfo = AuthInfo
+  { realm   :: URIRef Absolute
+  , service :: C8.ByteString
+  , scope   :: C8.ByteString
+  }
+  deriving (Show, Eq)
+
+newtype AuthScheme = AuthScheme (CI.CI String)
+  deriving (Show, Eq)
+
+data AuthParams = AuthParamsB64 String | AuthParamsArr [(CI.CI String, String)]
+  deriving (Show, Eq)
+
+data Challenge = Challenge
+  { scheme :: AuthScheme
+  , params :: AuthParams
+  } deriving (Show, Eq)
+
+isWhitespace :: Char -> Bool
+isWhitespace ' '  = True
+isWhitespace '\t' = True
+isWhitespace _    = False
+
+-- OWS            = *( SP / HTAB )
+--                ; optional whitespace
+-- BWS            = OWS
+--                ; "bad" whitespace
+ows :: ReadP String
+ows = munch isWhitespace
+
+-- tchar          = "!" / "#" / "$" / "%" / "&" / "'" / "*"
+--                / "+" / "-" / "." / "^" / "_" / "`" / "|" / "~"
+--                / DIGIT / ALPHA
+--                ; any VCHAR, except delimiters
+tchar :: ReadP Char
+tchar = satisfy isTchar
+  where
+    isTchar c = isAlphaNum c || c `elem` ("!#$%&'*+-.^_`|~" :: String)
+
+-- token          = 1*tchar
+token :: ReadP String
+token = many1 tchar
+
+-- token68        = 1*( ALPHA / DIGIT / "-" / "." / "_" / "~" / "+" / "/" ) *"="
+token68 :: ReadP String
+token68 = do
+  let validChar c = isAlphaNum c || c `elem` ("-._~+/" :: String)
+  part1 <- many1 $ satisfy validChar
+  part2 <- many $ satisfy (== '=')
+  return (part1 <> part2)
+
+-- quoted-string  = DQUOTE *( qdtext / quoted-pair ) DQUOTE
+quotedString :: ReadP String
+quotedString = do
+  _      <- char '"'
+  str    <- many (qdtext <|> quotedPair)
+  _      <- char '"'
+  return str
+
+-- obs-text       = %x80-FF
+-- qdtext         = HTAB / SP / %x21 / %x23-5B / %x5D-7E / obs-text
+qdtext :: ReadP Char
+qdtext = satisfy isQdtext
+  where
+    isQdtext c = 
+      let code = ord c 
+      in isWhitespace c || code == 0x21 
+         || (code >= 0x23 && code <= 0x5B) 
+         || (code >= 0x5D && code <= 0x7E) 
+         || (code >= 0x80 && code <= 0xFF)
+
+-- quoted-pair    = "\" ( HTAB / SP / VCHAR / obs-text )
+quotedPair :: ReadP Char
+quotedPair = do
+  _ <- char '\\'
+  satisfy (\c -> let code = ord c in isWhitespace c || (code >= 0x21 && code <= 0x7E) || (code >= 0x80 && code <= 0xFF))
+
+authScheme :: ReadP AuthScheme
+authScheme = (AuthScheme . CI.mk) <$> token
+
+-- auth-param = token BWS "=" BWS ( token / quoted-string )
+authParam :: ReadP (CI.CI String, String)
+authParam = do
+  key <- token
+  _   <- ows
+  _   <- char '='
+  _   <- ows
+  val <- token <|> quotedString
+  return (CI.mk key, val)
+
+-- Not part of RFC, extracted for readability
+-- 1*SP ( token68 / [ ( "," / auth-param ) *( OWS "," [ OWS auth-param ] ) ] )
+--
+-- Note: We don't want to consume commas at the end to avoid accidentally consuming comma between two challenges.
+--       The possible extra commas are being treated as "empty challenges" in `challenges` parser
+authParams :: ReadP AuthParams
+authParams = do
+  _ <- munch1 (== ' ')
+
+  let authToken = AuthParamsB64 <$> token68
+  let authParams' = do
+        _   <- munch (\c -> isWhitespace c || c == ',')
+        res <- sepBy authParam (ows >> char ',' >> (munch (\c -> isWhitespace c || c == ',')))
+        pure $ AuthParamsArr res
+
+  authToken <|> authParams'
+
+-- challenge = auth-scheme [ 1*SP ( token68 / [ ( "," / auth-param ) *( OWS "," [ OWS auth-param ] ) ] ) ]
+challenge :: ReadP Challenge
+challenge = do
+  s <- authScheme
+  ps <- authParams <|> (pure $ AuthParamsArr [])
+  return $ Challenge s ps
+
+-- WWW-Authenticate = *( "," OWS ) challenge *( OWS "," [ OWS challenge ] )
+challenges :: ReadP (NonEmpty Challenge)
+challenges = do
+  -- The header can start with an "empty" challenge
+  _ <- munch (\c -> isWhitespace c || c == ',')
+  let sepByAtLeastComma = (ows >> char ',' >> (munch (\c -> isWhitespace c || c == ',')))
+  cs <- sepBy1 challenge sepByAtLeastComma
+  -- It can also end with "empty" challenges
+  _ <- munch (\c -> isWhitespace c || c == ',')
+  return (NonEmpty.fromList cs)
+
+newtype WWWAuthHeader = WWWAuthHeader (NonEmpty Challenge)
+
+instance Read WWWAuthHeader where
+  readsPrec _ = readP_to_S $ WWWAuthHeader <$> (challenges <* eof)
+
+challengeToAuthInfo :: Challenge -> Either String AuthInfo
+challengeToAuthInfo c
+  | scheme c /= AuthScheme (CI.mk "bearer") = Left "Only Bearer challenges are supported"
+  | otherwise = case params c of
+      AuthParamsArr ps -> do
+        let lookupKey key = case lookup (CI.mk key) ps of
+              Just value -> Right $ C8.pack value
+              Nothing    -> Left $ "Key '" <> key <> "' is missing"
+
+        rawRealm <- lookupKey "realm"
+        service  <- lookupKey "service"
+        scope    <- lookupKey "scope"
+
+        realm <- first (\e -> "Failed to parse realm as an absolute URL: " <> show e) $ parseURI strictURIParserOptions rawRealm
+        Right AuthInfo{ realm, service, scope }
+
+      AuthParamsB64 _ -> Left "Base64 auth params are not supported"
+
+parseWWWAuthHeader :: C8.ByteString -> Either HockerException AuthInfo
+parseWWWAuthHeader headerValue = do
+  WWWAuthHeader parsedChallenges <- first hockerException $ readEither $ C8.unpack headerValue
+
+  -- We take the first parsed AuthInfo we find. In case of multiple valid Bearer challenges we ignore the later ones.
+  let collectErrors xs = case partitionEithers $ NonEmpty.toList xs of
+          (_, authInfo:_) -> Right authInfo
+          (errors, _)     -> Left $ hockerException ("Unable to extract AuthInfo from WWW-Authentication header:\n\t" <> intercalate "\n\t" errors)
+
+  collectErrors $ NonEmpty.map challengeToAuthInfo parsedChallenges

src/Hocker/Types/Exceptions.hs

@@ -25,7 +25,7 @@ data HockerException = HockerException
   { baseMsg  :: String
   , expected :: Maybe String
   , received :: Maybe String
-  } deriving (Read, Generic, NFData)
+  } deriving (Eq, Read, Generic, NFData)
 
 instance Exception HockerException
 instance Show HockerException where

src/Network/Wreq/Docker/Registry.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE MultiWayIf          #-}
 {-# LANGUAGE TupleSections       #-}
 {-# LANGUAGE ViewPatterns        #-}
@@ -40,14 +41,18 @@ import           NeatInterpolation
 import           Data.Bifunctor
 import qualified Data.Text                  as Text
 import qualified Data.Text.IO               as Text
+import           Network.HTTP.Client        (throwErrorStatusCodes)
+import qualified Network.HTTP.Types.Header  as HttpHeader
 import qualified Network.Wreq               as Wreq
+import qualified Network.Wreq.Types         as Wreq.Types
 import qualified Turtle
 import           System.Directory
 import qualified System.IO
 
 import           Data.Docker.Image.Types
 import           Hocker.Lib
 import           Hocker.Types
+import           Hocker.Types.AuthInfo
 import           Hocker.Types.Exceptions
 import           Hocker.Types.ImageName
 import           Hocker.Types.ImageTag
@@ -81,23 +86,18 @@ defaultRegistry = URI
 -- be made.
 mkAuth :: RegistryURI       -- ^ Docker registry
        -> ImageName         -- ^ Docker image name
+       -> ImageTag          -- ^ Docker image tag
        -> Maybe Credentials -- ^ Docker registry authentication credentials
        -> IO (Maybe Wreq.Auth)
-mkAuth reg iname@(ImageName img) credentials =
+mkAuth reg imageName imageTag 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))
     Just (CredentialsFile path)
-      -> parseCredentialsFile path >>= mkAuth reg iname . Just
-    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)
+      -> parseCredentialsFile path >>= mkAuth reg imageName imageTag . Just
+    Nothing -> anonymousAuth reg imageName imageTag
 
 parseCredentialsFile :: FilePath -> IO Credentials
 parseCredentialsFile path = do
@@ -119,6 +119,32 @@ parseCredentialsFile path = do
       System.IO.hPutStrLn System.IO.stderr "error: could not parse credentials file"
       Turtle.exit (Turtle.ExitFailure 1)
 
+getAnonymousToken :: AuthInfo -> IO Wreq.Auth
+getAnonymousToken AuthInfo{realm, service, scope} = do
+  let url = over (queryL . queryPairsL) (++ [("service", service), ("scope", scope)]) realm
+  rsp <- Wreq.get $ C8.unpack $ serializeURIRef' url
+  let token = rsp ^. Wreq.responseBody . key "token" . _String
+  pure $ Wreq.oauth2Bearer $ encodeUtf8 token
+
+anonymousAuth :: RegistryURI -> ImageName -> ImageTag -> IO (Maybe Wreq.Auth)
+anonymousAuth reg imageName imageTag = do
+  -- Don't throw on 401
+  let customRc :: Wreq.Types.ResponseChecker
+      customRc _ resp
+        | resp ^. Wreq.responseStatus . Wreq.statusCode == 401 = return ()
+      customRc req resp = throwErrorStatusCodes req resp
+
+  let noThrowOpts = Wreq.defaults & Wreq.checkResponse .~ Just customRc
+  rsp <- Wreq.headWith noThrowOpts $ mkManifestURL reg imageName imageTag
+
+  case rsp ^. Wreq.responseStatus ^. Wreq.statusCode of
+    401 -> do           -- Need to get anonymous token from endpoint in WWW-Authenticate
+      let wwwAuthHeader = rsp ^. Wreq.responseHeader HttpHeader.hWWWAuthenticate
+      authInfo <- either Exception.throwIO pure (parseWWWAuthHeader wwwAuthHeader)
+      token <- getAnonymousToken authInfo
+      pure $ Just token
+    _   -> pure Nothing -- No token needed, should be only 2xx based on customRc above
+
 
 -- | Retrieve a list of layer hash digests from a docker registry
 -- image manifest JSON.
@@ -142,12 +168,14 @@ pluckRefLayersFrom = toListOf (key "rootfs" . key "diff_ids" . values . _String)
 -----------------------------------------------------------------------------
 -- Top-level docker-registry V2 REST interface functions
 
+mkManifestURL :: RegistryURI -> ImageName -> ImageTag -> String
+mkManifestURL r (ImageName n) (ImageTag t) = C8.unpack (serializeURIRef' $ Hocker.Lib.joinURIPath [n, "manifests", t] r)
+
 -- | 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)
+  liftIO $ Wreq.getWith (opts auth & accept) (mkManifestURL dockerRegistry imageName imageTag)
   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" ]
 

test/Main.hs

@@ -6,6 +6,7 @@ import           Test.Tasty.HUnit
 
 import qualified Tests.Data.Docker.Image           as Docker.Image
 import qualified Tests.Data.Docker.Nix.FetchDocker as FetchDockerTests
+import qualified Tests.Hocker.Types.AuthInfo       as AuthInfoTests
 
 main :: IO ()
 main = defaultMain tests
@@ -14,4 +15,5 @@ tests :: TestTree
 tests = testGroup "Tests"
   [ Docker.Image.unitTests
   , FetchDockerTests.tests
+  , AuthInfoTests.tests
   ]