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 --