diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs index 267184633..a525f4cd3 100644 --- a/src/Distribution/Server/Features/Users.hs +++ b/src/Distribution/Server/Features/Users.hs @@ -495,7 +495,9 @@ userFeature templates usersState adminsState overrideResponse <- msum <$> runHook authFailHook err let resp' = fromMaybe defaultResponse overrideResponse -- reset authn to "0" on auth failures - resp'' = resp' { errorHeaders = ("Set-Cookie","authn=\"0\";Path=/;Version=\"1\""):errorHeaders resp' } + resp'' = case resp' of + r@ErrorResponse{} -> r { errorHeaders = ("Set-Cookie","authn=\"0\";Path=/;Version=\"1\""):errorHeaders r } + GenericErrorResponse -> GenericErrorResponse throwError resp'' -- Check if there is an authenticated userid, and return info, if so. diff --git a/src/Distribution/Server/Framework/Auth.hs b/src/Distribution/Server/Framework/Auth.hs index 90d81907e..3f429adc4 100644 --- a/src/Distribution/Server/Framework/Auth.hs +++ b/src/Distribution/Server/Framework/Auth.hs @@ -3,7 +3,7 @@ -- We authenticate clients using HTTP Basic or Digest authentication and we -- authorise users based on membership of particular user groups. -- -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE LambdaCase, PatternGuards #-} module Distribution.Server.Framework.Auth ( -- * Checking authorisation guardAuthorised, @@ -428,26 +428,29 @@ data AuthError = NoAuthError authErrorResponse :: MonadIO m => RealmName -> AuthError -> m ErrorResponse authErrorResponse realm autherr = do - digestHeader <- liftIO (headerDigestAuthChallenge realm) - return $! (toErrorResponse autherr) { errorHeaders = [digestHeader] } - where - toErrorResponse :: AuthError -> ErrorResponse - toErrorResponse NoAuthError = - ErrorResponse 401 [] "No authorization provided" [] - - toErrorResponse UnrecognizedAuthError = - ErrorResponse 400 [] "Authorization scheme not recognized" [] - - toErrorResponse InsecureAuthError = - ErrorResponse 400 [] "Authorization scheme not allowed over plain http" - [ MText $ "HTTP Basic and X-ApiKey authorization methods leak " - ++ "information when used over plain HTTP. Either use HTTPS " - ++ "or if you must use plain HTTP for authorised requests then " - ++ "use HTTP Digest authentication." ] - - toErrorResponse BadApiKeyError = - ErrorResponse 401 [] "Bad auth token" [] - - -- we don't want to leak info for the other cases, so same message for them all: - toErrorResponse _ = - ErrorResponse 401 [] "Username or password incorrect" [] + digestHeader <- liftIO (headerDigestAuthChallenge realm) + + let + toErrorResponse :: AuthError -> ErrorResponse + toErrorResponse = \case + NoAuthError -> + ErrorResponse 401 [digestHeader] "No authorization provided" [] + + UnrecognizedAuthError -> + ErrorResponse 400 [digestHeader] "Authorization scheme not recognized" [] + + InsecureAuthError -> + ErrorResponse 400 [digestHeader] "Authorization scheme not allowed over plain http" + [ MText $ "HTTP Basic and X-ApiKey authorization methods leak " + ++ "information when used over plain HTTP. Either use HTTPS " + ++ "or if you must use plain HTTP for authorised requests then " + ++ "use HTTP Digest authentication." ] + + BadApiKeyError -> + ErrorResponse 401 [digestHeader] "Bad auth token" [] + + -- we don't want to leak info for the other cases, so same message for them all: + _ -> + ErrorResponse 401 [digestHeader] "Username or password incorrect" [] + + return $! toErrorResponse autherr diff --git a/src/Distribution/Server/Framework/HappstackUtils.hs b/src/Distribution/Server/Framework/HappstackUtils.hs index 0646e63f5..41bce1b74 100644 --- a/src/Distribution/Server/Framework/HappstackUtils.hs +++ b/src/Distribution/Server/Framework/HappstackUtils.hs @@ -215,7 +215,8 @@ enableRange = do -- awkward; we'd have to parse the original Content-Length header to find -- out the original length. rangeFilter :: (Int64, Int64) -> Response -> Response - rangeFilter (fr, to) r = + rangeFilter _ r@SendFile{} = r + rangeFilter (fr, to) r@Response{} = setHeader "Content-Length" (show rangeLen) . setHeaderBS (BS.C8.pack "Content-Range") (contentRange fr to fullLen) . removeResponseHeader "Content-MD5"