Implement API Key authorization

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

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
-

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

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" []
-

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 ]