hackage-server-0.5.0: Distribution/Server/Framework/Auth.hs
-- | Server methods to do user authentication.
--
-- We authenticate clients using HTTP Basic or Digest authentication and we
-- authorise users based on membership of particular user groups.
--
{-# LANGUAGE PatternGuards #-}
module Distribution.Server.Framework.Auth (
-- * Checking authorisation
guardAuthorised,
-- ** Realms
RealmName,
hackageRealm,
adminRealm,
-- ** Creating password hashes
newPasswdHash,
UserName,
PasswdPlain,
PasswdHash,
-- ** Special cases
guardAuthenticated, checkAuthenticated,
guardPriviledged, checkPriviledged,
PrivilegeCondition(..),
-- ** Errors
AuthError(..),
authErrorResponse,
) where
import Distribution.Server.Users.Types (UserId, UserName(..), UserAuth(..), UserInfo)
import qualified Distribution.Server.Users.Types as Users
import qualified Distribution.Server.Users.Users as Users
import qualified Distribution.Server.Users.Group as Group
import Distribution.Server.Framework.AuthCrypt
import Distribution.Server.Framework.AuthTypes
import Distribution.Server.Framework.Error
import Distribution.Server.Framework.HtmlFormWrapper (rqRealMethod)
import Happstack.Server
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Data.ByteString.Char8 as BS -- Only used for Digest headers
import Control.Monad
import qualified Data.ByteString.Base64 as Base64
import Data.Char (intToDigit, isAsciiLower)
import System.Random (randomRs, newStdGen)
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Text.ParserCombinators.ReadP as Parse
import Data.Maybe (listToMaybe)
import Data.List (intercalate)
------------------------------------------------------------------------
-- Main auth methods
--
hackageRealm, adminRealm :: RealmName
hackageRealm = RealmName "Hackage"
adminRealm = RealmName "Hackage admin"
-- | Check that the client is authenticated and is authorised to perform some
-- priviledged action.
--
-- We check that:
--
-- * the client has supplied appropriate authentication credentials for a
-- known enabled user account;
-- * is a member of a given group of users who are permitted to perform
-- certain priviledged actions.
--
guardAuthorised :: RealmName -> Users.Users -> [PrivilegeCondition]
-> ServerPartE UserId
guardAuthorised realm users privconds = do
(uid, _) <- guardAuthenticated realm users
guardPriviledged users uid privconds
return uid
-- | Check that the client is authenticated. Returns the information about the
-- user account that the client authenticates as.
--
-- This checks the client has supplied appropriate authentication credentials
-- for a known enabled user account.
--
-- 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 -> ServerPartE (UserId, UserInfo)
guardAuthenticated realm users = do
authres <- checkAuthenticated realm users
case authres of
Left autherr -> throwError =<< authErrorResponse realm autherr
Right info -> return info
checkAuthenticated :: ServerMonad m => RealmName -> Users.Users -> m (Either AuthError (UserId, UserInfo))
checkAuthenticated realm users = do
req <- askRq
return $ case getHeaderAuth req of
Just (BasicAuth, ahdr) -> checkBasicAuth users realm ahdr
Just (DigestAuth, ahdr) -> checkDigestAuth users ahdr req
Nothing -> Left NoAuthError
where
getHeaderAuth :: Request -> Maybe (AuthType, BS.ByteString)
getHeaderAuth req =
case getHeader "authorization" req of
Just hdr
| BS.isPrefixOf (BS.pack "Digest ") hdr
-> Just (DigestAuth, BS.drop 7 hdr)
| BS.isPrefixOf (BS.pack "Basic ") hdr
-> Just (BasicAuth, BS.drop 6 hdr)
_ -> Nothing
data AuthType = BasicAuth | DigestAuth
data PrivilegeCondition = InGroup Group.UserGroup
| IsUserId UserId
| AnyKnownUser
-- | Check that a given user is permitted to perform certain priviledged
-- actions.
--
-- This is based on whether the user is a mamber of a particular group of
-- priviledged users.
--
-- It only checks if the user is in the priviledged user group, it does not
-- imply that the current client has been authenticated, see 'guardAuthorised'.
--
guardPriviledged :: Users.Users -> UserId -> [PrivilegeCondition] -> ServerPartE ()
guardPriviledged users uid privconds = do
allok <- checkPriviledged users uid privconds
when (not allok) $
errForbidden "Forbidden" [MText "No access for this resource."]
checkPriviledged :: MonadIO m => Users.Users -> UserId -> [PrivilegeCondition] -> m Bool
checkPriviledged _users _uid [] = return False
checkPriviledged users uid (InGroup ugroup:others) = do
uset <- liftIO $ Group.queryUserList ugroup
if Group.member uid uset
then return True
else checkPriviledged users uid others
checkPriviledged users uid (IsUserId uid':others) =
if uid == uid'
then return True
else checkPriviledged users uid others
checkPriviledged _ _ (AnyKnownUser:_) = return True
------------------------------------------------------------------------
-- Basic auth method
--
-- | Use HTTP Basic auth to authenticate the client as an active enabled user.
--
checkBasicAuth :: Users.Users -> RealmName -> BS.ByteString
-> Either AuthError (UserId, UserInfo)
checkBasicAuth users realm ahdr = do
authInfo <- getBasicAuthInfo realm ahdr ?! UnrecognizedAuthError
let uname = basicUsername authInfo
(uid, uinfo) <- Users.lookupUserName uname users ?! NoSuchUserError uname
uauth <- getUserAuth uinfo ?! UserStatusError uid uinfo
let passwdhash = getPasswdHash uauth
guard (checkBasicAuthInfo passwdhash authInfo) ?! PasswordMismatchError uid uinfo
return (uid, uinfo)
getBasicAuthInfo :: RealmName -> BS.ByteString -> Maybe BasicAuthInfo
getBasicAuthInfo realm authHeader
| Just (username, pass) <- splitHeader authHeader
= Just BasicAuthInfo {
basicRealm = realm,
basicUsername = UserName username,
basicPasswd = PasswdPlain pass
}
| otherwise = Nothing
where
splitHeader h = case Base64.decode h of
Left _ -> Nothing
Right xs ->
case break (':' ==) $ BS.unpack xs of
(username, ':' : pass) -> Just (username, pass)
_ -> Nothing
{-
We don't actually want to offer basic auth. It's not something we want to
encourage and some browsers (like firefox) end up prompting the user for
failing auth once for each auth method that the server offers. So if we offer
both digest and auth then the user gets prompted twice when they try to cancel
the auth.
Note that we still accept basic auth if the client offers it pre-emptively.
headerBasicAuthChallenge :: RealmName -> (String, String)
headerBasicAuthChallenge (RealmName realmName) =
(headerName, headerValue)
where
headerName = "WWW-Authenticate"
headerValue = "Basic realm=\"" ++ realmName ++ "\""
-}
------------------------------------------------------------------------
-- Digest auth method
--
-- See RFC 2617 http://www.ietf.org/rfc/rfc2617
-- Digest auth TODO:
-- * support domain for the protection space (otherwise defaults to whole server)
-- * nonce generation is not ideal: consists just of a random number
-- * nonce is not checked
-- * opaque is not used
-- | Use HTTP Digest auth to authenticate the client as an active enabled user.
--
checkDigestAuth :: Users.Users -> BS.ByteString -> Request
-> Either AuthError (UserId, UserInfo)
checkDigestAuth users ahdr req = do
authInfo <- getDigestAuthInfo ahdr req ?! UnrecognizedAuthError
let uname = digestUsername authInfo
(uid, uinfo) <- Users.lookupUserName uname users ?! NoSuchUserError uname
uauth <- getUserAuth uinfo ?! UserStatusError uid uinfo
let passwdhash = getPasswdHash uauth
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)
-- | retrieve the Digest auth info from the headers
--
getDigestAuthInfo :: BS.ByteString -> Request -> Maybe DigestAuthInfo
getDigestAuthInfo authHeader req = do
authMap <- parseDigestHeader authHeader
username <- Map.lookup "username" authMap
nonce <- Map.lookup "nonce" authMap
response <- Map.lookup "response" authMap
uri <- Map.lookup "uri" authMap
let mb_qop = Map.lookup "qop" authMap
qopInfo <- case mb_qop of
Just "auth" -> do
nc <- Map.lookup "nc" authMap
cnonce <- Map.lookup "cnonce" authMap
return (QopAuth nc cnonce)
`mplus`
return QopNone
Nothing -> return QopNone
_ -> mzero
return DigestAuthInfo {
digestUsername = UserName username,
digestNonce = nonce,
digestResponse = response,
digestURI = uri,
digestRqMethod = show (rqRealMethod req),
digestQoP = qopInfo
}
where
-- Parser derived from RFCs 2616 and 2617
parseDigestHeader :: BS.ByteString -> Maybe (Map String String)
parseDigestHeader =
fmap Map.fromList . parse . BS.unpack
where
parse :: String -> Maybe [(String, String)]
parse s = listToMaybe [ x | (x, "") <- Parse.readP_to_S parser s ]
parser :: Parse.ReadP [(String, String)]
parser = Parse.skipSpaces
>> Parse.sepBy1 nameValuePair
(Parse.skipSpaces >> Parse.char ',' >> Parse.skipSpaces)
nameValuePair = do
theName <- Parse.munch1 isAsciiLower
void $ Parse.char '='
theValue <- quotedString
return (theName, theValue)
quotedString :: Parse.ReadP String
quotedString =
join Parse.between
(Parse.char '"')
(Parse.many $ (Parse.char '\\' >> Parse.get) Parse.<++ Parse.satisfy (/='"'))
Parse.<++ (liftM2 (:) (Parse.satisfy (/='"')) (Parse.munch (/=',')))
headerDigestAuthChallenge :: RealmName -> IO (String, String)
headerDigestAuthChallenge (RealmName realmName) = do
nonce <- liftIO generateNonce
return (headerName, headerValue nonce)
where
headerName = "WWW-Authenticate"
-- Note that offering both qop=\"auth,auth-int\" can confuse some browsers
-- e.g. see http://code.google.com/p/chromium/issues/detail?id=45194
headerValue nonce =
"Digest " ++
intercalate ", "
[ "realm=" ++ inQuotes realmName
, "qop=" ++ inQuotes "auth"
, "nonce=" ++ inQuotes nonce
, "opaque=" ++ inQuotes ""
]
generateNonce = fmap (take 32 . map intToDigit . randomRs (0, 15)) newStdGen
inQuotes s = '"' : s ++ ['"']
------------------------------------------------------------------------
-- Common
--
getUserAuth :: UserInfo -> Maybe UserAuth
getUserAuth userInfo =
case Users.userStatus userInfo of
Users.AccountEnabled auth -> Just auth
_ -> Nothing
getPasswdHash :: UserAuth -> PasswdHash
getPasswdHash (UserAuth hash) = hash
------------------------------------------------------------------------
-- Errors
--
data AuthError = NoAuthError
| UnrecognizedAuthError
| NoSuchUserError UserName
| UserStatusError UserId UserInfo
| PasswordMismatchError UserId UserInfo
deriving Show
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" []
-- we don't want to leak info for the other cases, so same message for them all:
toErrorResponse _ =
ErrorResponse 401 [] "Username or password incorrect" []