diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs
index bea91542..8a187cbd 100644
--- a/src/Distribution/Server/Features/Html.hs
+++ b/src/Distribution/Server/Features/Html.hs
@@ -650,7 +650,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore}
pkgVotes <- pkgNumVotes pkgname
pkgScore <- pkgNumScore pkgname
auth <- checkAuthenticated
- userRating <- case auth of Just (uid,_) -> pkgUserVote pkgname uid; _ -> return Nothing
+ userRating <- case auth of Just uid -> pkgUserVote pkgname uid; _ -> return Nothing
mdoctarblob <- queryDocumentation realpkg
tags <- queryTagsForPackage pkgname
rdeps <- queryReverseDeps pkgname
diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs
index 69b215b3..d74e0185 100644
--- a/src/Distribution/Server/Features/Users.hs
+++ b/src/Distribution/Server/Features/Users.hs
@@ -68,7 +68,7 @@ data UserFeature = UserFeature {
-- | Require being logged in, giving the id of the current user.
guardAuthenticated :: ServerPartE UserId,
-- | Gets the authentication if it exists.
- checkAuthenticated :: ServerPartE (Maybe (UserId, UserInfo)),
+ checkAuthenticated :: ServerPartE (Maybe UserId),
-- | A hook to override the default authentication error in particular
-- circumstances.
authFailHook :: Hook Auth.AuthError (Maybe ErrorResponse),
@@ -487,7 +487,7 @@ userFeature templates usersState adminsState
-- See note about "authn" cookie above
guardAuthenticatedWithErrHook :: Users.Users -> ServerPartE UserId
guardAuthenticatedWithErrHook users = do
- (uid,_) <- Auth.checkAuthenticated realm users userFeatureServerEnv
+ uid <- Auth.checkAuthenticated realm users userFeatureServerEnv
>>= either handleAuthError return
addCookie Session (mkCookie "authn" "1")
-- Set-Cookie:authn="1";Path=/;Version="1"
@@ -510,7 +510,7 @@ userFeature templates usersState adminsState
-- Check if there is an authenticated userid, and return info, if so.
-- See note about "authn" cookie above
- checkAuthenticated :: ServerPartE (Maybe (UserId, UserInfo))
+ checkAuthenticated :: ServerPartE (Maybe UserId)
checkAuthenticated = do
authn <- optional (lookCookieValue "authn")
case authn of
diff --git a/src/Distribution/Server/Framework/Auth.hs b/src/Distribution/Server/Framework/Auth.hs
index 2d2ae175..87be4924 100644
--- a/src/Distribution/Server/Framework/Auth.hs
+++ b/src/Distribution/Server/Framework/Auth.hs
@@ -82,7 +82,7 @@ guardAuthorised :: RealmName -> Users.Users -> [PrivilegeCondition]
-> ServerEnv
-> ServerPartE UserId
guardAuthorised realm users privconds env = do
- (uid, _) <- guardAuthenticated realm users env
+ uid <- guardAuthenticated realm users env
guardPriviledged users uid privconds
return uid
@@ -96,14 +96,14 @@ guardAuthorised realm users privconds env = do
-- It only checks the user is known, it does not imply that the user is
-- authorised to do anything in particular, see 'guardAuthorised'.
--
-guardAuthenticated :: RealmName -> Users.Users -> ServerEnv -> ServerPartE (UserId, UserInfo)
+guardAuthenticated :: RealmName -> Users.Users -> ServerEnv -> ServerPartE UserId
guardAuthenticated realm users env = do
authres <- checkAuthenticated realm users env
case authres of
Left autherr -> throwError =<< authErrorResponse realm autherr
Right info -> return info
-checkAuthenticated :: ServerMonad m => RealmName -> Users.Users -> ServerEnv -> m (Either AuthError (UserId, UserInfo))
+checkAuthenticated :: ServerMonad m => RealmName -> Users.Users -> ServerEnv -> m (Either AuthError UserId)
checkAuthenticated realm users ServerEnv { serverRequiredBaseHostHeader } = do
mbHost <- getHost
case mbHost of
@@ -251,7 +251,7 @@ plainHttp req
-- | Handle a auth request using an access token
checkTokenAuth :: Users.Users -> BS.ByteString
- -> Either AuthError (UserId, UserInfo)
+ -> Either AuthError UserId
checkTokenAuth users ahdr = do
parsedToken <-
case Users.parseOriginalToken (T.decodeUtf8 ahdr) of
@@ -259,7 +259,7 @@ checkTokenAuth users ahdr = do
Right tok -> Right (Users.convertToken tok)
(uid, uinfo) <- Users.lookupAuthToken parsedToken users ?! BadApiKeyError
_ <- getUserAuth uinfo ?! UserStatusError uid uinfo
- return (uid, uinfo)
+ return uid
------------------------------------------------------------------------
-- Basic auth method
@@ -268,7 +268,7 @@ checkTokenAuth users ahdr = do
-- | Use HTTP Basic auth to authenticate the client as an active enabled user.
--
checkBasicAuth :: Users.Users -> RealmName -> BS.ByteString
- -> Either AuthError (UserId, UserInfo)
+ -> Either AuthError UserId
checkBasicAuth users realm ahdr = do
authInfo <- getBasicAuthInfo realm ahdr ?! UnrecognizedAuthError
let uname = basicUsername authInfo
@@ -276,7 +276,7 @@ checkBasicAuth users realm ahdr = do
uauth <- getUserAuth uinfo ?! UserStatusError uid uinfo
let passwdhash = getPasswdHash uauth
guard (checkBasicAuthInfo passwdhash authInfo) ?! PasswordMismatchError uid uinfo
- return (uid, uinfo)
+ return uid
getBasicAuthInfo :: RealmName -> BS.ByteString -> Maybe BasicAuthInfo
getBasicAuthInfo realm authHeader
@@ -327,7 +327,7 @@ headerBasicAuthChallenge (RealmName realmName) =
-- | Use HTTP Digest auth to authenticate the client as an active enabled user.
--
checkDigestAuth :: Users.Users -> BS.ByteString -> Request
- -> Either AuthError (UserId, UserInfo)
+ -> Either AuthError UserId
checkDigestAuth users ahdr req = do
authInfo <- getDigestAuthInfo ahdr req ?! UnrecognizedAuthError
let uname = digestUsername authInfo
@@ -337,7 +337,7 @@ checkDigestAuth users ahdr req = do
guard (checkDigestAuthInfo passwdhash authInfo) ?! PasswordMismatchError uid uinfo
-- TODO: if we want to prevent replay attacks, then we must check the
-- nonce and nonce count and issue stale=true replies.
- return (uid, uinfo)
+ return uid
-- | retrieve the Digest auth info from the headers
--