diff --git a/Distribution/Server/Features/Html.hs b/Distribution/Server/Features/Html.hs index 468fd09a4..211f12ebc 100644 --- a/Distribution/Server/Features/Html.hs +++ b/Distribution/Server/Features/Html.hs @@ -723,6 +723,9 @@ mkHtmlUsers UserFeature{..} UserDetailsFeature{..} = HtmlUsers{..} [ toHtml $ display uname ++ " is part of the following groups:" , unordList uriPairs ] + , hr + , anchor ! [href $ manageUserUri users "" uname] << + "Click here to manage this account" ] addUserForm :: DynamicPath -> ServerPartE Response diff --git a/Distribution/Server/Features/UserSignup.hs b/Distribution/Server/Features/UserSignup.hs index b5eb0e595..fa53509f9 100644 --- a/Distribution/Server/Features/UserSignup.hs +++ b/Distribution/Server/Features/UserSignup.hs @@ -5,7 +5,7 @@ module Distribution.Server.Features.UserSignup ( initUserSignupFeature, UserSignupFeature(..), SignupResetInfo(..), - + accountSuitableForPasswordReset ) where @@ -20,6 +20,7 @@ import Distribution.Server.Features.UserDetails import Distribution.Server.Users.Group import Distribution.Server.Users.Types +import Distribution.Server.Util.Nonce import qualified Distribution.Server.Users.Users as Users import Data.Map (Map) @@ -101,9 +102,6 @@ data SignupResetInfo = SignupInfo { newtype SignupResetTable = SignupResetTable (Map Nonce SignupResetInfo) deriving (Eq, Show, Typeable, MemSize) -newtype Nonce = Nonce ByteString - deriving (Eq, Ord, Show, Typeable, MemSize) - emptySignupResetTable :: SignupResetTable emptySignupResetTable = SignupResetTable Map.empty @@ -113,20 +111,6 @@ instance MemSize SignupResetInfo where $(deriveSafeCopy 0 'base ''SignupResetInfo) $(deriveSafeCopy 0 'base ''SignupResetTable) -$(deriveSafeCopy 0 'base ''Nonce) - ------------------------------- --- Nonces --- - -newRandomNonce :: IO Nonce -newRandomNonce = do - raw <- withFile "/dev/urandom" ReadMode $ \h -> - BS.hGet h 10 - return $! Nonce (Base16.encode raw) - -renderNonce :: Nonce -> String -renderNonce (Nonce nonce) = BS.unpack nonce ------------------------------ -- State queries and updates @@ -226,8 +210,8 @@ importSignupInfo = sequence . map fromRecord . drop 2 fromRecord :: Record -> Restore (Nonce, SignupResetInfo) fromRecord [nonceStr, usernameStr, realnameStr, emailStr, timestampStr] = do timestamp <- parseUTCTime "timestamp" timestampStr - let nonce = Nonce (BS.pack nonceStr) - signupinfo = SignupInfo { + nonce <- parseNonceM nonceStr + let signupinfo = SignupInfo { signupUserName = T.pack usernameStr, signupRealName = T.pack realnameStr, signupContactEmail = T.pack emailStr, @@ -259,8 +243,8 @@ importResetInfo = sequence . map fromRecord . drop 2 fromRecord [nonceStr, useridStr, timestampStr] = do userid <- parseText "userid" useridStr timestamp <- parseUTCTime "timestamp" timestampStr - let nonce = Nonce (BS.pack nonceStr) - signupinfo = ResetInfo { + nonce <- parseNonceM nonceStr + let signupinfo = ResetInfo { resetUserId = userid, nonceTimestamp = timestamp } @@ -289,7 +273,7 @@ initUserSignupFeature :: ServerEnv -> UserDetailsFeature -> UploadFeature -> IO UserSignupFeature) -initUserSignupFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, +initUserSignupFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, serverTemplatesMode } = do -- Canonical state signupResetState <- signupResetStateComponent serverStateDir @@ -419,7 +403,8 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} -- nonceInPath :: MonadPlus m => DynamicPath -> m Nonce - nonceInPath dpath = maybe mzero return (Nonce . BS.pack <$> lookup "nonce" dpath) + nonceInPath dpath = + maybe mzero return (lookup "nonce" dpath >>= parseNonceM) lookupSignupInfo :: Nonce -> ServerPartE SignupResetInfo lookupSignupInfo nonce = querySignupInfo nonce @@ -445,7 +430,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} (username, realname, useremail) <- lookUserNameEmail - nonce <- liftIO newRandomNonce + nonce <- liftIO (newRandomNonce 10) timestamp <- liftIO getCurrentTime let signupInfo = SignupInfo { signupUserName = username, @@ -591,7 +576,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} guardEmailMatches mudetails supplied_useremail AccountDetails{..} <- guardSuitableAccountType uinfo mudetails - nonce <- liftIO newRandomNonce + nonce <- liftIO (newRandomNonce 10) timestamp <- liftIO getCurrentTime let resetInfo = ResetInfo { resetUserId = uid, @@ -701,4 +686,3 @@ accountSuitableForPasswordReset (AccountDetails { accountKind = Just AccountKindRealUser }) = True accountSuitableForPasswordReset _ _ = False - diff --git a/Distribution/Server/Features/Users.hs b/Distribution/Server/Features/Users.hs index 3b38b9eb3..5d17d817c 100644 --- a/Distribution/Server/Features/Users.hs +++ b/Distribution/Server/Features/Users.hs @@ -11,6 +11,7 @@ module Distribution.Server.Features.Users ( import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump +import Distribution.Server.Framework.Templating import qualified Distribution.Server.Framework.Auth as Auth import Distribution.Server.Users.Types @@ -154,6 +155,8 @@ data UserResource = UserResource { enabledResource :: Resource, -- | The admin group. adminResource :: GroupResource, + -- | Manage a user + manageUserResource :: Resource, -- | URI for `userList` given a format. userListUri :: String -> String, @@ -164,7 +167,9 @@ data UserResource = UserResource { -- | URI for `enabledResource` given a format and name. userEnabledUri :: String -> UserName -> String, -- | URI for `adminResource` given a format. - adminPageUri :: String -> String + adminPageUri :: String -> String, + -- | URI for `manageUserResource` give a format and name + manageUserUri :: String -> UserName -> String } instance FromReqURI UserName where @@ -195,7 +200,7 @@ instance MemSize GroupIndex where -- TODO: add renaming initUserFeature :: ServerEnv -> IO (IO UserFeature) -initUserFeature ServerEnv{serverStateDir} = do +initUserFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do -- Canonical state usersState <- usersStateComponent serverStateDir adminsState <- adminsStateComponent serverStateDir @@ -208,6 +213,13 @@ initUserFeature ServerEnv{serverStateDir} = do authFailHook <- newHook groupChangedHook <- newHook + -- Load templates + templates <- + loadTemplates serverTemplatesMode + [serverTemplatesDir, serverTemplatesDir "Users"] + [ "manage.html", "token-created.html", "token-revoked.html" + ] + return $ do -- Slightly tricky: we have an almost recursive knot between the group -- resource management functions, and creating the admin group @@ -216,7 +228,8 @@ initUserFeature ServerEnv{serverStateDir} = do -- Instead of trying to pull it apart, we just use a 'do rec' -- rec let (feature@UserFeature{groupResourceAt}, adminGroupDesc) - = userFeature usersState + = userFeature templates + usersState adminsState groupIndex userAdded authFailHook groupChangedHook @@ -253,7 +266,8 @@ adminsStateComponent stateDir = do , resetState = adminsStateComponent } -userFeature :: StateComponent AcidState Users.Users +userFeature :: Templates + -> StateComponent AcidState Users.Users -> StateComponent AcidState HackageAdmins -> MemState GroupIndex -> Hook () () @@ -262,7 +276,7 @@ userFeature :: StateComponent AcidState Users.Users -> UserGroup -> GroupResource -> (UserFeature, UserGroup) -userFeature usersState adminsState +userFeature templates usersState adminsState groupIndex userAdded authFailHook groupChangedHook adminGroup adminResource = (UserFeature {..}, adminGroupDesc) @@ -275,6 +289,7 @@ userFeature usersState adminsState , userPage , passwordResource , enabledResource + , manageUserResource ] ++ [ groupResource adminResource @@ -306,6 +321,14 @@ userFeature usersState adminsState , resourcePut = [ ("", serveUserPut) ] , resourceDelete = [ ("", serveUserDelete) ] } + , manageUserResource = + (resourceAt "/user/:username/manage.:format") + { resourceDesc = + [ (GET, "user management page") + ] + , resourceGet = [ ("", serveUserManagement) ] + , resourcePost = [ ("", runUserManagementAction)] + } , passwordResource = resourceAt "/user/:username/password.:format" --TODO: PUT , enabledResource = (resourceAt "/user/:username/enabled.:format") { @@ -328,6 +351,8 @@ userFeature usersState adminsState renderResource (enabledResource r) [display uname, format] , adminPageUri = \format -> renderResource (groupResource adminResource) [format] + , manageUserUri = \format uname -> + renderResource (manageUserResource r) [display uname, format] } -- Queries and updates @@ -468,6 +493,68 @@ userFeature usersState adminsState errBadRequest "User deleted" [MText "Cannot disable account, it has already been deleted"] + serveUserManagement :: DynamicPath -> ServerPartE Response + serveUserManagement dpath = do + (UserName username) <- userNameInPath dpath + uid <- lookupUserName (UserName username) + guardAuthorised_ [IsUserId uid, InGroup adminGroup] + userInfo <- lookupUserInfo uid + let (UserTokenMap knownTokens) = userTokens userInfo + template <- getTemplate templates "manage.html" + let mkTok (t, desc) = + templateDict + [ templateVal "hash" (display t) + , templateVal "description" desc + ] + ok $ toResponse $ template + [ "username" $= username + , "tokens" $= map mkTok (Map.toList knownTokens) + ] + + runUserManagementAction :: DynamicPath -> ServerPartE Response + runUserManagementAction dpath = do + (UserName username) <- userNameInPath dpath + uid <- lookupUserName (UserName username) + guardAuthorised_ [IsUserId uid, InGroup adminGroup] + action <- look "action" + case action of + "new-auth-token" -> do + origTok <- liftIO generateOriginalToken + let storeTok = convertToken origTok + desc <- T.pack <$> look "description" + res <- updateState usersState (AddAuthToken uid storeTok desc) + template <- getTemplate templates "token-created.html" + case res of + Nothing -> + ok $ toResponse $ template + [ "username" $= username + , "token" $= viewOriginalToken origTok + ] + Just Users.ErrNoSuchUserId -> + errInternalError [MText "uid does not exist"] + "revoke-auth-token" -> do + authToken <- parseAuthToken . T.pack <$> look "auth-token" + case authToken of + Left err -> + errBadRequest "Bad auth token" + [MText "The token you have provided is malformed"] + Right at -> do + res <- updateState usersState (RevokeAuthToken uid at) + template <- getTemplate templates "token-revoked.html" + case res of + Nothing -> + ok $ toResponse $ template + [ "username" $= username + ] + Just (Left Users.ErrNoSuchUserId) -> + errInternalError [MText "uid does not exist"] + Just (Right Users.ErrTokenNotOwned) -> + errBadRequest "Token not owned" + [MText "Cannot revoke this token, wrong owner!"] + _ -> + errBadRequest "Missing or wrong action" + [MText "The action you have provided does not exist"] + -- -- Exported utils for looking up user names in URLs\/paths -- diff --git a/Distribution/Server/Framework/Auth.hs b/Distribution/Server/Framework/Auth.hs index 6934093c5..35c91fc46 100644 --- a/Distribution/Server/Framework/Auth.hs +++ b/Distribution/Server/Framework/Auth.hs @@ -53,6 +53,7 @@ import qualified Data.Map as Map import qualified Text.ParserCombinators.ReadP as Parse import Data.Maybe (listToMaybe) import Data.List (intercalate) +import qualified Data.Text.Encoding as T ------------------------------------------------------------------------ @@ -104,6 +105,7 @@ checkAuthenticated realm users = do return $ case getHeaderAuth req of Just (BasicAuth, ahdr) -> checkBasicAuth users realm ahdr Just (DigestAuth, ahdr) -> checkDigestAuth users ahdr req + Just (KeyAuth, ahdr) -> checkAccessTokenAuth users ahdr Nothing -> Left NoAuthError where getHeaderAuth :: Request -> Maybe (AuthType, BS.ByteString) @@ -112,12 +114,13 @@ checkAuthenticated realm users = do Just hdr | BS.isPrefixOf (BS.pack "Digest ") hdr -> Just (DigestAuth, BS.drop 7 hdr) - + | BS.isPrefixOf (BS.pack "ApiKey ") hdr + -> Just (KeyAuth, BS.drop 7 hdr) | BS.isPrefixOf (BS.pack "Basic ") hdr -> Just (BasicAuth, BS.drop 6 hdr) _ -> Nothing -data AuthType = BasicAuth | DigestAuth +data AuthType = BasicAuth | DigestAuth | KeyAuth data PrivilegeCondition = InGroup Group.UserGroup @@ -155,6 +158,21 @@ checkPriviledged users uid (IsUserId uid':others) = checkPriviledged _ _ (AnyKnownUser:_) = return True +------------------------------------------------------------------------ +-- Access token method +-- + +-- | Handle a auth request using an access token +checkAccessTokenAuth :: + Users.Users -> BS.ByteString -> Either AuthError (UserId, UserInfo) +checkAccessTokenAuth users ahdr = + do parsedToken <- + case Users.parseOriginalToken (T.decodeUtf8 ahdr) of + Left _ -> Left BadApiKeyError -- TODO: should we display more infos? + Right ok -> Right (Users.convertToken ok) + (uid, uinfo) <- Users.lookupAuthToken parsedToken users ?! BadApiKeyError + _ <- getUserAuth uinfo ?! UserStatusError uid uinfo + return (uid, uinfo) ------------------------------------------------------------------------ -- Basic auth method @@ -331,6 +349,7 @@ data AuthError = NoAuthError | NoSuchUserError UserName | UserStatusError UserId UserInfo | PasswordMismatchError UserId UserInfo + | BadApiKeyError deriving Show authErrorResponse :: MonadIO m => RealmName -> AuthError -> m ErrorResponse @@ -345,7 +364,9 @@ authErrorResponse realm autherr = do toErrorResponse UnrecognizedAuthError = ErrorResponse 400 [] "Authorization scheme not recognized" [] + 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" [] - diff --git a/Distribution/Server/Framework/MemSize.hs b/Distribution/Server/Framework/MemSize.hs index fca3c0c85..4e5b5f687 100644 --- a/Distribution/Server/Framework/MemSize.hs +++ b/Distribution/Server/Framework/MemSize.hs @@ -20,6 +20,7 @@ import Data.Sequence (Seq) import qualified Data.Foldable as Foldable import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as BSS import qualified Data.Text as T import Data.Time (UTCTime, Day) import Data.Ix @@ -160,6 +161,11 @@ instance MemSize BS.ByteString where memSize s = let (w,t) = divMod (BS.length s) wordSize in 5 + w + signum t +instance MemSize BSS.ShortByteString where + memSize s = + let (w,t) = divMod (BSS.length s) wordSize + in 5 + w + signum t + instance MemSize LBS.ByteString where memSize s = sum [ 1 + memSize c | c <- LBS.toChunks s ] diff --git a/Distribution/Server/Users/AuthToken.hs b/Distribution/Server/Users/AuthToken.hs new file mode 100644 index 000000000..7a77246b1 --- /dev/null +++ b/Distribution/Server/Users/AuthToken.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Distribution.Server.Users.AuthToken + ( AuthToken + , parseAuthToken, parseAuthTokenM, renderAuthToken + , OriginalToken + , convertToken, viewOriginalToken, generateOriginalToken + , parseOriginalToken + ) +where + +import Distribution.Server.Framework.MemSize +import Distribution.Server.Util.Nonce + +import Distribution.Text + ( Text(..) ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Data.Char as Char +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V +import qualified Data.ByteString as BS +import qualified Data.ByteString.Short as BSS +import qualified Data.ByteString.Base16 as BS16 +import qualified Crypto.Hash.SHA256 as SHA256 + +import Control.Applicative ((<$>)) +import Data.Aeson (ToJSON, FromJSON) +import Data.SafeCopy +import Data.Typeable (Typeable) + +-- | Contains the original token which will be shown to the user +-- once and is NOT stored on the server. The user is expected +-- to provide this token on each request that should be +-- authed by it +newtype OriginalToken = OriginalToken Nonce + deriving (Eq, Ord, Show, Typeable) + +-- | Contains a hash of the original token +newtype AuthToken = AuthToken BSS.ShortByteString + deriving (Eq, Ord, Read, Show, Typeable, MemSize) + +convertToken :: OriginalToken -> AuthToken +convertToken (OriginalToken bs) = + AuthToken $ BSS.toShort $ SHA256.hash $ getRawNonceBytes bs + +viewOriginalToken :: OriginalToken -> T.Text +viewOriginalToken (OriginalToken ot) = T.pack $ renderNonce ot + +-- | Generate a random 32 byte auth token. The token is represented as +-- in textual base16 way so it can easily be printed and parsed. +-- Note that this operation is not very efficient because it +-- calls 'withSystemRandom' for each token, but for the current +-- use case we only generate tokens infrequently so this should be fine. +generateOriginalToken :: IO OriginalToken +generateOriginalToken = OriginalToken <$> newRandomNonce 32 + +parseOriginalToken :: T.Text -> Either String OriginalToken +parseOriginalToken t = OriginalToken <$> parseNonce (T.unpack t) + +parseAuthTokenM :: Monad m => T.Text -> m AuthToken +parseAuthTokenM t = + case parseAuthToken t of + Left err -> fail err + Right ok -> return ok + +parseAuthToken :: T.Text -> Either String AuthToken +parseAuthToken t + | T.length t /= 64 = Left "auth token must be 64 charaters long" + | not (T.all Char.isHexDigit t) = Left "only hex digits are allowed in tokens" + | otherwise = + Right $ AuthToken $ BSS.toShort $ fst $ BS16.decode $ T.encodeUtf8 t + +renderAuthToken :: AuthToken -> T.Text +renderAuthToken (AuthToken bss) = T.decodeUtf8 $ BS16.encode $ BSS.fromShort bss + +instance Text AuthToken where + disp tok = Disp.text . T.unpack . renderAuthToken $ tok + parse = + Parse.munch1 Char.isHexDigit >>= \x -> + case parseAuthToken (T.pack x) of + Left err -> fail err + Right ok -> return ok + +instance SafeCopy AuthToken where + putCopy (AuthToken bs) = contain $ safePut (BSS.fromShort bs) + getCopy = + contain $ AuthToken . BSS.toShort <$> safeGet diff --git a/Distribution/Server/Users/Backup.hs b/Distribution/Server/Users/Backup.hs index 8884c5fd3..2a76feb6c 100644 --- a/Distribution/Server/Users/Backup.hs +++ b/Distribution/Server/Users/Backup.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} module Distribution.Server.Users.Backup ( -- Importing user data userBackup, @@ -20,7 +21,12 @@ import Distribution.Server.Framework.BackupDump (BackupType(..)) import Distribution.Server.Framework.BackupRestore import Distribution.Text (display) import Data.Version +import Data.Monoid import Text.CSV (CSV, Record) +import qualified Data.Map as M +import qualified Data.ByteString.Base64 as B64 +import qualified Data.Text as T +import qualified Data.Text.Encoding as T -- Import for the user database @@ -43,24 +49,48 @@ updateUserBackup users = RestoreBackup { importAuth :: CSV -> Users -> Restore Users importAuth = concatM . map fromRecord . drop 2 where + decodeTokenPair tokenPair = + case T.splitOn "|" tokenPair of + [k, v] -> + do tok <- parseText "token" (T.unpack k) + desc <- + case B64.decode (T.encodeUtf8 v) of + Left errMsg -> fail errMsg + Right ok -> + return (T.decodeUtf8 ok) + return (tok, desc) + _ -> fail $ "Bad token pair: " ++ show tokenPair fromRecord :: Record -> Users -> Restore Users - fromRecord [idStr, nameStr, "enabled", auth] users = do - uid <- parseText "user id" idStr - uname <- parseText "user name" nameStr - let uauth = UserAuth (PasswdHash auth) - insertUser users uid $ UserInfo uname (AccountEnabled uauth) - fromRecord [idStr, nameStr, "disabled", auth] users = do - uid <- parseText "user id" idStr - uname <- parseText "user name" nameStr - let uauth | null auth = Nothing - | otherwise = Just (UserAuth (PasswdHash auth)) - insertUser users uid $ UserInfo uname (AccountDisabled uauth) - fromRecord [idStr, nameStr, "deleted", ""] users = do - uid <- parseText "user id" idStr - uname <- parseText "user name" nameStr - insertUser users uid $ UserInfo uname AccountDeleted - - fromRecord x _ = fail $ "Error processing auth record: " ++ show x + fromRecord record users = + case record of + (idStr : nameStr : authStatus : auth : more) -> + do uid <- parseText "user id" idStr + uname <- parseText "user name" nameStr + authState <- + case authStatus of + "enabled" -> + return . AccountEnabled . UserAuth . PasswdHash $ auth + "disabled" -> + let mayAuth = + if null auth then Nothing + else Just . UserAuth . PasswdHash $ auth + in return $ AccountDisabled mayAuth + "deleted" -> + return AccountDeleted + badAuthStatus -> + fail $ + "Error processing record " ++ show record + ++ ". Bad auth status: " ++ show badAuthStatus + tokenSet <- + case more of + [tokenList] -> + do let toks = words tokenList + parsedTokens <- mapM (decodeTokenPair . T.pack) toks + return (UserTokenMap $ M.fromList parsedTokens) + _ -> + return (UserTokenMap M.empty) + insertUser users uid $ UserInfo uname authState tokenSet + x -> fail $ "Error processing auth record: " ++ show x insertUser :: Users -> UserId -> UserInfo -> Restore Users insertUser users uid uinfo = @@ -107,7 +137,7 @@ groupToCSV uidset = [map show (UserIdSet.toList uidset)] . Format: . - User Id,User name,(enabled|disabled|deleted),pwd-hash + User Id,User name,(enabled|disabled|deleted),pwd-hash,token1|descB64-1 token2|descB64-2 ... tokenN|descB64-N -} -- have a "safe" argument to this function that doesn't export password hashes? usersToCSV :: BackupType -> Users -> CSV @@ -122,14 +152,22 @@ usersToCSV backuptype users , if backuptype == FullBackup then infoToAuth uinfo else scrubbedAuth uinfo + , let (UserTokenMap ts) = userTokens uinfo + in unwords $ map encodeTokenPair (M.toList ts) ] where + encodeTokenPair (token, desc) = + display token + <> "|" + <> T.unpack (T.decodeUtf8 $ B64.encode $ T.encodeUtf8 desc) + usersCSVKey = [ "uid" , "name" , "status" , "auth-info" + , "tokens" ] userCSVVer = Version [0,2] [] @@ -157,4 +195,3 @@ usersToCSV backuptype users AccountEnabled (UserAuth (PasswdHash hash)) -> hash AccountDisabled (Just (UserAuth (PasswdHash hash))) -> hash _ -> "" - diff --git a/Distribution/Server/Users/State.hs b/Distribution/Server/Users/State.hs index 7c108ae0f..bb2e0bae9 100644 --- a/Distribution/Server/Users/State.hs +++ b/Distribution/Server/Users/State.hs @@ -18,6 +18,7 @@ import Data.Typeable (Typeable) import Control.Monad.Reader import qualified Control.Monad.State as State +import qualified Data.Text as T initialUsers :: Users.Users initialUsers = Users.emptyUsers @@ -53,6 +54,18 @@ setUserName :: UserId -> UserName -> Update Users.Users (Maybe (Either Users.Err setUserName uid uname = updateUsers_ $ Users.setUserName uid uname +addAuthToken :: + UserId -> AuthToken -> T.Text + -> Update Users.Users (Maybe Users.ErrNoSuchUserId) +addAuthToken uid authToken description = + updateUsers_ $ Users.addAuthToken uid authToken description + +revokeAuthToken :: + UserId -> AuthToken + -> Update Users.Users (Maybe (Either Users.ErrNoSuchUserId Users.ErrTokenNotOwned)) +revokeAuthToken uid authToken = + updateUsers_ $ Users.revokeAuthToken uid authToken + -- updates the user db with a simpler function updateUsers_ :: (Users.Users -> Either err Users.Users) -> Update Users.Users (Maybe err) updateUsers_ upd = do @@ -85,6 +98,8 @@ $(makeAcidic ''Users.Users [ 'addUserEnabled , 'deleteUser , 'getUserDb , 'replaceUserDb + , 'addAuthToken + , 'revokeAuthToken ]) ----------------------------------------------------- @@ -163,4 +178,3 @@ $(makeAcidic ''MirrorClients ,'addMirrorClient ,'removeMirrorClient ,'replaceMirrorClients]) - diff --git a/Distribution/Server/Users/Types.hs b/Distribution/Server/Users/Types.hs index df2fc7650..e661e2b05 100644 --- a/Distribution/Server/Users/Types.hs +++ b/Distribution/Server/Users/Types.hs @@ -1,11 +1,14 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Distribution.Server.Users.Types ( module Distribution.Server.Users.Types, + module Distribution.Server.Users.AuthToken, module Distribution.Server.Framework.AuthTypes ) where import Distribution.Server.Framework.AuthTypes import Distribution.Server.Framework.MemSize +import Distribution.Server.Users.AuthToken import Distribution.Text ( Text(..) ) @@ -13,10 +16,12 @@ import qualified Distribution.Server.Util.Parse as Parse import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char +import qualified Data.Text as T +import qualified Data.Map as M import Control.Applicative ((<$>)) import Data.Aeson (ToJSON, FromJSON) -import Data.SafeCopy (base, deriveSafeCopy) +import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..)) import Data.Typeable (Typeable) @@ -28,7 +33,8 @@ newtype UserName = UserName String data UserInfo = UserInfo { userName :: !UserName, - userStatus :: !UserStatus + userStatus :: !UserStatus, + userTokens :: !UserTokenMap } deriving (Eq, Show, Typeable) data UserStatus = AccountEnabled UserAuth @@ -36,6 +42,10 @@ data UserStatus = AccountEnabled UserAuth | AccountDeleted deriving (Eq, Show, Typeable) +newtype UserTokenMap + = UserTokenMap { unUserTokenMap :: M.Map AuthToken T.Text } + deriving (Show, Eq, Typeable, MemSize) + newtype UserAuth = UserAuth PasswdHash deriving (Show, Eq, Typeable) @@ -45,7 +55,7 @@ isActiveAccount (AccountDisabled _) = True isActiveAccount AccountDeleted = False instance MemSize UserInfo where - memSize (UserInfo a b) = memSize2 a b + memSize (UserInfo a b c) = memSize3 a b c instance MemSize UserStatus where memSize (AccountEnabled a) = memSize1 a @@ -55,7 +65,6 @@ instance MemSize UserStatus where instance MemSize UserAuth where memSize (UserAuth a) = memSize1 a - instance Text UserId where disp (UserId uid) = Disp.int uid parse = UserId <$> Parse.int @@ -67,8 +76,24 @@ instance Text UserName where isValidUserNameChar :: Char -> Bool isValidUserNameChar c = (c < '\127' && Char.isAlphaNum c) || (c == '_') +data UserInfo_v0 = UserInfo_v0 { + userName_v0 :: !UserName, + userStatus_v0 :: !UserStatus + } deriving (Eq, Show, Typeable) + +instance Migrate UserInfo where + type MigrateFrom UserInfo = UserInfo_v0 + migrate v0 = + UserInfo + { userName = userName_v0 v0 + , userStatus = userStatus_v0 v0 + , userTokens = UserTokenMap M.empty + } + $(deriveSafeCopy 0 'base ''UserId) $(deriveSafeCopy 0 'base ''UserName) $(deriveSafeCopy 1 'base ''UserAuth) $(deriveSafeCopy 0 'base ''UserStatus) -$(deriveSafeCopy 0 'base ''UserInfo) +$(deriveSafeCopy 0 'base ''UserTokenMap) +$(deriveSafeCopy 0 'base ''UserInfo_v0) +$(deriveSafeCopy 1 'extension ''UserInfo) diff --git a/Distribution/Server/Users/Users.hs b/Distribution/Server/Users/Users.hs index 6b6eccfc1..ec420e085 100644 --- a/Distribution/Server/Users/Users.hs +++ b/Distribution/Server/Users/Users.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell, NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} module Distribution.Server.Users.Users ( -- * Users type Users, @@ -15,10 +16,13 @@ module Distribution.Server.Users.Users ( setUserEnabledStatus, setUserAuth, setUserName, + addAuthToken, + revokeAuthToken, -- * Lookup lookupUserId, lookupUserName, + lookupAuthToken, -- ** Lookup utils userIdToName, @@ -32,6 +36,7 @@ module Distribution.Server.Users.Users ( ErrUserIdClash(..), ErrNoSuchUserId(..), ErrDeletedUser(..), + ErrTokenNotOwned(..) ) where import Distribution.Server.Users.Types @@ -41,12 +46,13 @@ import Distribution.Server.Framework.MemSize import Control.Monad (guard) import Data.Maybe (fromMaybe) -import Data.List (sort, group) +import Data.List (sort, group, foldl') import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import Data.SafeCopy (base, deriveSafeCopy) +import Data.SafeCopy (base, deriveSafeCopy, extension, Migrate(..)) import Data.Typeable (Typeable) import Control.Exception (assert) +import qualified Data.Text as T -- | The entire collection of users. Manages the mapping between 'UserName' @@ -58,24 +64,25 @@ data Users = Users { -- | A map from active UserNames to the UserId for that name userNameMap :: !(Map.Map UserName UserId), -- | The next available UserId - nextId :: !UserId + nextId :: !UserId, + -- | A map from 'AuthToken' to 'UserId' for quick token based auth + authTokenMap :: !(Map.Map AuthToken UserId) } deriving (Eq, Typeable, Show) instance MemSize Users where - memSize (Users a b c) = memSize3 a b c - -$(deriveSafeCopy 0 'base ''Users) + memSize (Users a b c d) = memSize4 a b c d checkinvariant :: Users -> Users checkinvariant users = assert (invariant users) users invariant :: Users -> Bool -invariant Users{userIdMap, userNameMap, nextId} = +invariant Users{userIdMap, userNameMap, nextId, authTokenMap} = nextIdIsRight && noUserNameOverlap && userNameMapComplete && userNameMapConsistent + && authTokenMapConsistent where nextIdIsRight = -- 1) the next id should be 0 if the userIdMap is empty @@ -107,19 +114,39 @@ invariant Users{userIdMap, userNameMap, nextId} = Nothing -> False Just uinfo -> userName uinfo == uname | (uname, UserId uid) <- Map.toList userNameMap ] - -- the point is, user names can be recycled but user ids never are -- this simplifies things because other user groups in the system do not -- need to be adjusted when an account is enabled/disabled/deleted -- it also allows us to track historical info, like name of uploader -- even if that user name has been recycled, the user ids will be distinct. + -- every registered token must map to a users token set + -- and vice versa + authTokenMapConsistent = + and + [ and + [ case IntMap.lookup uid userIdMap of + Nothing -> False + Just uinfo -> + let (UserTokenMap userToks) = userTokens uinfo + in Map.member token userToks + | (token, UserId uid) <- Map.toList authTokenMap + ] + , and + [ Map.lookup token authTokenMap == Just uid + | (token, uid) <- concatMap getUserTokList (IntMap.toList userIdMap) + ] + ] + getUserTokList (uid, uinfo) = + let (UserTokenMap userToks) = userTokens uinfo + in map (\t -> (t, UserId uid)) $ map fst $ Map.toList userToks emptyUsers :: Users emptyUsers = Users { userIdMap = IntMap.empty, userNameMap = Map.empty, - nextId = UserId 0 + nextId = UserId 0, + authTokenMap = Map.empty } -- error codes @@ -127,11 +154,13 @@ data ErrUserNameClash = ErrUserNameClash deriving Typeable data ErrUserIdClash = ErrUserIdClash deriving Typeable data ErrNoSuchUserId = ErrNoSuchUserId deriving Typeable data ErrDeletedUser = ErrDeletedUser deriving Typeable +data ErrTokenNotOwned = ErrTokenNotOwned deriving Typeable $(deriveSafeCopy 0 'base ''ErrUserNameClash) $(deriveSafeCopy 0 'base ''ErrUserIdClash) $(deriveSafeCopy 0 'base ''ErrNoSuchUserId) $(deriveSafeCopy 0 'base ''ErrDeletedUser) +$(deriveSafeCopy 0 'base ''ErrTokenNotOwned) (?!) :: Maybe a -> e -> Either e a ma ?! e = maybe (Left e) Right ma @@ -149,6 +178,12 @@ lookupUserName uname users = do where impossible = error "lookupUserName: invariant violation" +lookupAuthToken :: AuthToken -> Users -> Maybe (UserId, UserInfo) +lookupAuthToken authTok users = + do uid <- Map.lookup authTok (authTokenMap users) + uinfo <- lookupUserId uid users + return (uid, uinfo) + -- | Convert a 'UserId' to a 'UserName'. If the user id doesn't exist, -- an ugly placeholder is used instead. -- @@ -182,7 +217,8 @@ addUser name status users = userid@(UserId uid) = nextId users uinfo = UserInfo { userName = name, - userStatus = status + userStatus = status, + userTokens = UserTokenMap Map.empty } users' = checkinvariant users { userIdMap = IntMap.insert uid uinfo (userIdMap users), @@ -200,6 +236,9 @@ insertUserAccount userId@(UserId uid) uinfo users = do guard (not userNameInUse || isUserDeleted) ?! Right ErrUserNameClash return $! checkinvariant users { userIdMap = IntMap.insert uid uinfo (userIdMap users), + authTokenMap = + foldl' (\om (tok, _) -> Map.insert tok userId om) + (authTokenMap users) usertoks, userNameMap = if isUserDeleted then userNameMap users else Map.insert (userName uinfo) userId (userNameMap users), @@ -207,6 +246,7 @@ insertUserAccount userId@(UserId uid) uinfo users = do in UserId (max nextid (uid + 1)) } where + usertoks = Map.toList $ unUserTokenMap $ userTokens uinfo userIdInUse = IntMap.member uid (userIdMap users) userNameInUse = Map.member (userName uinfo) (userNameMap users) isUserDeleted = case userStatus uinfo of @@ -294,6 +334,45 @@ setUserName (UserId uid) newname users = do where userNameInUse uname = Map.member uname (userNameMap users) +-- | Register a new auth token for a user account +addAuthToken :: + UserId -> AuthToken -> T.Text -> Users + -> Either ErrNoSuchUserId Users +addAuthToken (UserId uid) token description users = + do userinfo <- lookupUserId (UserId uid) users ?! ErrNoSuchUserId + let (UserTokenMap tokenMap) = userTokens userinfo + userinfo' = + userinfo + { userTokens = + UserTokenMap (Map.insert token description tokenMap) + } + users' = + users + { userIdMap = IntMap.insert uid userinfo' (userIdMap users) + , authTokenMap = Map.insert token (UserId uid) (authTokenMap users) + } + return $! checkinvariant users' + +-- | Revoke an auth token from a user account +revokeAuthToken :: + UserId -> AuthToken -> Users + -> Either (Either ErrNoSuchUserId ErrTokenNotOwned) Users +revokeAuthToken (UserId uid) token users = + do userinfo <- lookupUserId (UserId uid) users ?! Left ErrNoSuchUserId + let (UserTokenMap tokenMap) = userTokens userinfo + () <- + if Map.member token tokenMap + then Right () + else Left (Right ErrTokenNotOwned) + let userinfo' = + userinfo { userTokens = UserTokenMap (Map.delete token tokenMap) } + users' = + users + { userIdMap = IntMap.insert uid userinfo' (userIdMap users) + , authTokenMap = Map.delete token (authTokenMap users) + } + return $! checkinvariant users' + enumerateAllUsers :: Users -> [(UserId, UserInfo)] enumerateAllUsers users = [ (UserId uid, uinfo) | (uid, uinfo) <- IntMap.assocs (userIdMap users) ] @@ -302,3 +381,26 @@ enumerateActiveUsers :: Users -> [(UserId, UserInfo)] enumerateActiveUsers users = [ (UserId uid, uinfo) | (uid, uinfo) <- IntMap.assocs (userIdMap users) , isActiveAccount (userStatus uinfo) ] + +data Users_v0 = Users_v0 { + -- | A map from UserId to UserInfo + userIdMap_v0 :: !(IntMap.IntMap UserInfo), + -- | A map from active UserNames to the UserId for that name + userNameMap_v0 :: !(Map.Map UserName UserId), + -- | The next available UserId + nextId_v0 :: !UserId + } + deriving (Eq, Typeable, Show) + +instance Migrate Users where + type MigrateFrom Users = Users_v0 + migrate v0 = + Users + { userIdMap = userIdMap_v0 v0 + , userNameMap = userNameMap_v0 v0 + , nextId = nextId_v0 v0 + , authTokenMap = Map.empty + } + +$(deriveSafeCopy 0 'base ''Users_v0) +$(deriveSafeCopy 1 'extension ''Users) diff --git a/Distribution/Server/Util/Nonce.hs b/Distribution/Server/Util/Nonce.hs new file mode 100644 index 000000000..e6026ae8b --- /dev/null +++ b/Distribution/Server/Util/Nonce.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Distribution.Server.Util.Nonce + ( newRandomNonce + , renderNonce, parseNonce, parseNonceM + , getRawNonceBytes + , Nonce + ) +where + +import Distribution.Server.Framework.MemSize + +import Data.ByteString (ByteString) +import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..)) +import Data.Typeable +import System.IO +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS -- Only used for ASCII data +import qualified Data.Char as Char + +newtype Nonce = Nonce ByteString + deriving (Eq, Ord, Show, Typeable, MemSize) + +newRandomNonce :: Int -> IO Nonce +newRandomNonce len = do + raw <- + withFile "/dev/urandom" ReadMode $ \h -> + BS.hGet h len + return $! Nonce raw + +getRawNonceBytes :: Nonce -> ByteString +getRawNonceBytes (Nonce b) = b + +renderNonce :: Nonce -> String +renderNonce (Nonce nonce) = BS.unpack (Base16.encode nonce) + +parseNonce :: String -> Either String Nonce +parseNonce t + | not (all Char.isHexDigit t) = Left "only hex digits are allowed in tokens" + | otherwise = Right (Nonce $ fst $ Base16.decode $ BS.pack t) + +parseNonceM :: Monad m => String -> m Nonce +parseNonceM t = + case parseNonce t of + Left err -> fail err + Right ok -> return ok + +-- Nonce and Nonce_v0 have the same type, but the "new" nonce is +-- internally NOT base16 encoded +newtype Nonce_v0 = Nonce_v0 ByteString + deriving (Eq, Ord, Show, Typeable, MemSize) + +instance Migrate Nonce where + type MigrateFrom Nonce = Nonce_v0 + migrate (Nonce_v0 x) = Nonce $ fst $ Base16.decode x + +$(deriveSafeCopy 0 'base ''Nonce_v0) +$(deriveSafeCopy 1 'extension ''Nonce) diff --git a/datafiles/templates/Users/manage.html.st b/datafiles/templates/Users/manage.html.st new file mode 100644 index 000000000..db1006b8d --- /dev/null +++ b/datafiles/templates/Users/manage.html.st @@ -0,0 +1,56 @@ + + + +$hackageCssTheme()$ +Manage your user account | Hackage + + + +$hackagePageHeader()$ + +
+

Manage user account $username$

+

This site collects operations you can do to manage your user account

+ +

Authentication Tokens

+

+ You can register API authentication token to use them to for example have services like continouos integration upload packages on your behalf without providing them your username and/or password. +

+ +

Active tokens

+ +

Register new token

+

+ To register a new token please provide a description for it. After registering + the token it will be shown to you once and you can not recover it after from + the site. Please be sure to store it in a safe place as it currently has + the same privileges as your username and password. +

+
+ Description:
+ + +
+ + +

Other options

+ + + +
+ diff --git a/datafiles/templates/Users/token-created.html.st b/datafiles/templates/Users/token-created.html.st new file mode 100644 index 000000000..c61152f53 --- /dev/null +++ b/datafiles/templates/Users/token-created.html.st @@ -0,0 +1,29 @@ + + + +$hackageCssTheme()$ +Auth token generated | Hackage + + + +$hackagePageHeader()$ + +
+

New auth token for $username$

+

+ A new token was successfully generated. Please keep it in a safe place and do + not loose it. You can revoke it from the user management page. +

+ +

Auth token: $token$

+ + + +
+ diff --git a/datafiles/templates/Users/token-revoked.html.st b/datafiles/templates/Users/token-revoked.html.st new file mode 100644 index 000000000..51a9eac6f --- /dev/null +++ b/datafiles/templates/Users/token-revoked.html.st @@ -0,0 +1,26 @@ + + + +$hackageCssTheme()$ +Auth token revoked | Hackage + + + +$hackagePageHeader()$ + +
+

Revoked auth token for $username$

+

+ Your auth token was revoked and it can no longer be used for authentication. +

+ + + +
+ diff --git a/hackage-server.cabal b/hackage-server.cabal index 79bf541da..e0dd68518 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -40,6 +40,7 @@ data-files: templates/UserSignupReset/*.html.st templates/UserSignupReset/*.email.st templates/AdminFrontend/*.html.st + templates/Users/*.html.st static/*.css static/*.ico @@ -161,6 +162,7 @@ executable hackage-server Distribution.Server.Users.Types Distribution.Server.Users.Backup Distribution.Server.Users.Users + Distribution.Server.Users.AuthToken Distribution.Server.Users.UserIdSet Distribution.Server.Util.Histogram @@ -173,6 +175,7 @@ executable hackage-server Distribution.Server.Util.ContentType Distribution.Server.Util.SigTerm Distribution.Server.Util.ReadDigest + Distribution.Server.Util.Nonce Distribution.Server.Features Distribution.Server.Features.Core @@ -322,7 +325,8 @@ executable hackage-server ed25519, cryptohash-md5 == 0.11.*, cryptohash-sha256 == 0.11.*, - binary + binary, + base16-bytestring >= 0.1 && < 0.2 if ! flag(minimal) build-depends: @@ -384,6 +388,7 @@ executable hackage-mirror cryptohash-sha256, parsec, process >= 1.2.0, + base16-bytestring >= 0.1 && < 0.2, hackage-security >= 0.5.1 && < 0.6, hackage-security-HTTP default-language: Haskell2010 @@ -427,6 +432,7 @@ executable hackage-build random, unix, cryptohash-sha256, + base16-bytestring >= 0.1 && < 0.2, -- Runtime dependency only: hscolour >= 1.8 default-language: Haskell2010