Helpful error message on missing group membership (#1054)

Author: ysangkok

src/Distribution/Client/Mirror/Session.hs

@@ -455,7 +455,9 @@ requestPUT uri mimetype body = do
       _       -> return (Just (mkErrorResponse uri rsp))
   where
     headers = [ Header HdrContentLength (show (BS.length body))
-              , Header HdrContentType mimetype ]
+              , Header HdrContentType mimetype
+              , Header HdrAccept "text/plain"
+              ]
 
 {-------------------------------------------------------------------------------
   Auxiliary functions used by HttpSession actions

src/Distribution/Server/Features/Mirror.hs

@@ -159,6 +159,8 @@ mirrorFeature ServerEnv{serverBlobStore = store}
         groupsAllowedToAdd    = [adminGroup]
     }
 
+    guardMirrorGroup = guardAuthorisedWhenInAnyGroup [mirrorGroup]
+    guardMirrorGroup_ = void guardMirrorGroup
 
     -- result: error from unpacking, bad request error, or warning lines
     --
@@ -169,7 +171,7 @@ mirrorFeature ServerEnv{serverBlobStore = store}
     --      http://localhost:8080/package/$PACKAGENAME/$PACKAGEID.tar.gz
     tarballPut :: DynamicPath -> ServerPartE Response
     tarballPut dpath = do
-        uid         <- guardAuthorised [InGroup mirrorGroup]
+        uid         <- guardMirrorGroup
         pkgid       <- packageTarballInPath dpath
         fileContent <- expectCompressedTarball
         time        <- liftIO getCurrentTime
@@ -202,7 +204,7 @@ mirrorFeature ServerEnv{serverBlobStore = store}
 
     uploaderPut :: DynamicPath -> ServerPartE Response
     uploaderPut dpath = do
-        guardAuthorised_ [InGroup mirrorGroup]
+        guardMirrorGroup_
         pkgid <- packageInPath dpath
         nameContent <- expectTextPlain
         let uname = UserName (unpackUTF8 nameContent)
@@ -225,7 +227,7 @@ mirrorFeature ServerEnv{serverBlobStore = store}
                 parseTimeMaybe "%c" timeStr
                 <|>  parseTimeMaybe "%Y-%m-%dT%H:%M:%SZ" timeStr
                 )
-        guardAuthorised_ [InGroup mirrorGroup]
+        guardMirrorGroup_
         pkgid <- packageInPath dpath
         timeContent <- expectTextPlain
         case altParseTimeMaybe (unpackUTF8 timeContent) of
@@ -239,7 +241,7 @@ mirrorFeature ServerEnv{serverBlobStore = store}
     -- return: error from parsing, bad request error, or warning lines
     cabalPut :: DynamicPath -> ServerPartE Response
     cabalPut dpath = do
-        uid <- guardAuthorised [InGroup mirrorGroup]
+        uid <- guardMirrorGroup
         pkgid :: PackageId <- packageInPath dpath
         fileContent <- expectTextPlain
         time <- liftIO getCurrentTime

src/Distribution/Server/Features/Users.hs

@@ -58,6 +58,8 @@ data UserFeature = UserFeature {
     groupChangedHook :: Hook (GroupDescription, Bool, UserId, UserId, String) (),
 
     -- Authorisation
+    -- | Require any of a set of groups, with a friendly error message
+    guardAuthorisedWhenInAnyGroup :: [Group.UserGroup] -> ServerPartE UserId,
     -- | Require any of a set of privileges.
     guardAuthorised_   :: [PrivilegeCondition] -> ServerPartE (),
     -- | Require any of a set of privileges, giving the id of the current user.
@@ -406,6 +408,15 @@ userFeature templates usersState adminsState
     -- Authorisation: authentication checks and privilege checks
     --
 
+    guardAuthorisedWhenInAnyGroup :: [Group.UserGroup] -> ServerPartE UserId
+    guardAuthorisedWhenInAnyGroup [] =
+        fail "Group list is empty, this is not meant to happen"
+    guardAuthorisedWhenInAnyGroup groups = do
+        users <- queryGetUserDb
+        uid   <- guardAuthenticatedWithErrHook users
+        Auth.guardInAnyGroup users uid groups
+        return uid
+
     -- High level, all in one check that the client is authenticated as a
     -- particular user and has an appropriate privilege, but then ignore the
     -- identity of the user.

src/Distribution/Server/Framework/Auth.hs

@@ -22,6 +22,7 @@ module Distribution.Server.Framework.Auth (
     -- ** Special cases
     guardAuthenticated, checkAuthenticated,
     guardPriviledged,   checkPriviledged,
+    guardInAnyGroup,
     PrivilegeCondition(..),
 
     -- ** Errors
@@ -128,6 +129,17 @@ data PrivilegeCondition = InGroup    Group.UserGroup
                         | IsUserId   UserId
                         | AnyKnownUser
 
+guardInAnyGroup :: Users.Users -> UserId -> [Group.UserGroup] -> ServerPartE ()
+guardInAnyGroup _ _ [] =
+  fail "Group list is empty, this is not meant to happen"
+guardInAnyGroup users uid groups = do
+  allok <- checkPriviledged users uid (map InGroup groups)
+  let groupTitles = map (Group.groupTitle . Group.groupDesc) groups
+      errMsg = "Access denied, you must be member of either of the following groups: "
+               <> show groupTitles
+  when (not allok) $
+    errForbidden "Missing group membership" [MText errMsg]
+
 -- | Check that a given user is permitted to perform certain privileged
 -- actions.
 --