diff --git a/hocker-config/Main.hs b/hocker-config/Main.hs index 902c4c4..cb46525 100644 --- a/hocker-config/Main.hs +++ b/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 diff --git a/hocker-image/Main.hs b/hocker-image/Main.hs index 2e52260..38cd084 100644 --- a/hocker-image/Main.hs +++ b/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 diff --git a/hocker-layer/Main.hs b/hocker-layer/Main.hs index bc8c13f..ebc9ec9 100644 --- a/hocker-layer/Main.hs +++ b/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 diff --git a/hocker-manifest/Main.hs b/hocker-manifest/Main.hs index 71576e2..4f52dfd 100644 --- a/hocker-manifest/Main.hs +++ b/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 diff --git a/hocker.cabal b/hocker.cabal index 01298c9..578f4e2 100644 --- a/hocker.cabal +++ b/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 diff --git a/src/Hocker/Types/AuthInfo.hs b/src/Hocker/Types/AuthInfo.hs new file mode 100644 index 0000000..0bb2e2b --- /dev/null +++ b/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 +-- 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 diff --git a/src/Hocker/Types/Exceptions.hs b/src/Hocker/Types/Exceptions.hs index 90fbd34..984c64d 100644 --- a/src/Hocker/Types/Exceptions.hs +++ b/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 diff --git a/src/Network/Wreq/Docker/Registry.hs b/src/Network/Wreq/Docker/Registry.hs index 2639311..8402f33 100644 --- a/src/Network/Wreq/Docker/Registry.hs +++ b/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,7 +41,10 @@ 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 @@ -48,6 +52,7 @@ 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" ] diff --git a/test/Main.hs b/test/Main.hs index 1f5c78c..e23b485 100644 --- a/test/Main.hs +++ b/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 ] diff --git a/test/Tests/Hocker/Types/AuthInfo.hs b/test/Tests/Hocker/Types/AuthInfo.hs new file mode 100644 index 0000000..65d9d35 --- /dev/null +++ b/test/Tests/Hocker/Types/AuthInfo.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Hocker.Types.AuthInfo (tests) where + +import Test.Tasty +import Test.Tasty.HUnit +import qualified Data.ByteString.Char8 as C8 +import Data.Either (isLeft) +import URI.ByteString (Absolute, URIRef, parseURI, strictURIParserOptions) +import Hocker.Types.AuthInfo (AuthInfo(..), parseWWWAuthHeader) + +mkURI :: C8.ByteString -> URIRef Absolute +mkURI bs = case parseURI strictURIParserOptions bs of + Right u -> u + Left e -> error $ "Test configuration error, invalid URI: " ++ show e + +tests :: TestTree +tests = testGroup "Hocker.Types.AuthInfo Parsing" + [ testGroup "Valid Headers" + [ testCase "Internal Corporate Header" $ do + let h = "Bearer realm=\"https://auth.internal.example.com/v2/token\",service=\"auth.internal.example.com\",scope=\"repository:project/image:pull,push\"" + let expected = AuthInfo + { realm = mkURI "https://auth.internal.example.com/v2/token" + , service = "auth.internal.example.com" + , scope = "repository:project/image:pull,push" + } + parseWWWAuthHeader h @?= Right expected + + , testCase "Docker Hub Header" $ do + let h = "Bearer realm=\"https://auth.docker.io/token\",service=\"registry.docker.io\",scope=\"repository:library/node:pull\"" + let expected = AuthInfo + { realm = mkURI "https://auth.docker.io/token" + , service = "registry.docker.io" + , scope = "repository:library/node:pull" + } + parseWWWAuthHeader h @?= Right expected + + , testCase "Parameter Permutation & Whitespace" $ do + -- RFC 7235: Order of params shouldn't matter; OWS (Optional White Space) allowed + let h = "Bearer scope=\"read\", service=my-svc, realm=\"https://example.com/\"" + let expected = AuthInfo + { realm = mkURI "https://example.com/" + , service = "my-svc" + , scope = "read" + } + parseWWWAuthHeader h @?= Right expected + + , testCase "Ignore extra args" $ do + let h = "Bearer scope=\"read\", foo=baz, service=my-svc, realm=\"https://example.com/\", " + let expected = AuthInfo + { realm = mkURI "https://example.com/" + , service = "my-svc" + , scope = "read" + } + parseWWWAuthHeader h @?= Right expected + + , testCase "Ignore extra challenges" $ do + let h = "Bearer scope=\"read\", foo=baz, service=my-svc, realm=\"https://example.com/\",,,,,,,,,, Bearer scope=\"read\", foo=baz, service=other-svc, realm=\"https://example.com/\", " + let expected = AuthInfo + { realm = mkURI "https://example.com/" + , service = "my-svc" + , scope = "read" + } + parseWWWAuthHeader h @?= Right expected + + , testCase "Ignore extra non-bearer challenges" $ do + let h = "Newauth realm=\"apps\", type=1, title=\"Login to \\\"apps\\\"\", Basic realm=\"simple\",Bearer scope=\"read\", foo=baz, service=my-svc, realm=\"https://example.com/\",Basic realm=\"foo\", charset=\"UTF-8\"" + let expected = AuthInfo + { realm = mkURI "https://example.com/" + , service = "my-svc" + , scope = "read" + } + parseWWWAuthHeader h @?= Right expected + ] + + , testGroup "Invalid Headers (missing required fields)" + [ testCase "Missing Scope" $ do + let h = "Bearer realm=\"https://example.com/\", service=\"svc\"" + assertBool "Should fail: missing scope" (isLeft $ parseWWWAuthHeader h) + + , testCase "Missing Realm" $ do + let h = "Bearer service=\"s\", scope=\"*\"" + assertBool "Should fail: missing realm" (isLeft $ parseWWWAuthHeader h) + + , testCase "Non-Absolute URI in Realm" $ do + let h = "Bearer realm=\"/v2/token\", service=\"s\", scope=\"*\"" + assertBool "Should fail: relative realm" (isLeft $ parseWWWAuthHeader h) + + , testCase "Malformed Quoted String" $ do + let h = "Bearer realm=\"https://example.com/\", service=\"svc, scope=\"unclosed\"" + assertBool "Should fail: unclosed quotes" (isLeft $ parseWWWAuthHeader h) + ] + + , testGroup "Invalid Headers (garbage data)" + [ testCase "Missing Scope" $ do + let h = "Basic realm=\"WallyWorld\"" + assertBool "Should fail: only Bearer challenge is supported" (isLeft $ parseWWWAuthHeader h) + + , testCase "Missing Realm" $ do + let h = "Bearer service=\"s\", scope=\"*\"" + assertBool "Should fail: relative realm" (isLeft $ parseWWWAuthHeader h) + + , testCase "Non-Absolute URI in Realm" $ do + let h = "Bearer realm=\"/v2/token\", service=\"s\", scope=\"*\"" + assertBool "Should fail: relative realm" (isLeft $ parseWWWAuthHeader h) + + , testCase "Malformed Quoted String" $ do + let h = "Bearer realm=\"https://example.com/\", service=\"svc, scope=\"unclosed\"" + assertBool "Should fail: unclosed quotes" (isLeft $ parseWWWAuthHeader h) + ] + ]