Skip to content

Commit d2d6af0

Browse files
gbazgbaz
authored
Merge pull request #1480 from haskell/distro-permissions
Distros: Harden security
2 parents ba656c7 + 28671e1 commit d2d6af0

File tree

2 files changed

+51
-34
lines changed

2 files changed

+51
-34
lines changed

‎src/Distribution/Server/Features/Distro.hs‎

Lines changed: 46 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-}
1+
{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, RecursiveDo #-}
22
module Distribution.Server.Features.Distro (
33
DistroFeature(..),
44
DistroResource(..),
@@ -20,6 +20,7 @@ import Distribution.Text (display, simpleParse)
2020
import Distribution.Package
2121

2222
import Data.List (intercalate)
23+
import qualified Data.Text as T
2324
import Text.CSV (parseCSV)
2425

2526
-- TODO:
@@ -29,7 +30,6 @@ import Text.CSV (parseCSV)
2930
data DistroFeature = DistroFeature {
3031
distroFeatureInterface :: HackageFeature,
3132
distroResource :: DistroResource,
32-
maintainersGroup :: DynamicPath -> IO (Maybe UserGroup),
3333
queryPackageStatus :: forall m. MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)]
3434
}
3535

@@ -48,8 +48,28 @@ initDistroFeature :: ServerEnv
4848
initDistroFeature ServerEnv{serverStateDir} = do
4949
distrosState <- distrosStateComponent serverStateDir
5050

51-
return $ \user core -> do
52-
let feature = distroFeature user core distrosState
51+
return $ \user@UserFeature{adminGroup, groupResourcesAt} core@CoreFeature{coreResource} -> do
52+
rec
53+
let
54+
maintainersUserGroup :: DistroName -> UserGroup
55+
maintainersUserGroup name =
56+
UserGroup {
57+
groupDesc = maintainerGroupDescription name,
58+
queryUserGroup = queryState distrosState $ GetDistroMaintainers name,
59+
addUserToGroup = updateState distrosState . AddDistroMaintainer name,
60+
removeUserFromGroup = updateState distrosState . RemoveDistroMaintainer name,
61+
groupsAllowedToAdd = [adminGroup],
62+
groupsAllowedToDelete = [adminGroup]
63+
}
64+
feature = distroFeature user core distrosState maintainersGroupResource maintainersUserGroup
65+
distroNames <- queryState distrosState EnumerateDistros
66+
(_maintainersGroup, maintainersGroupResource) <-
67+
groupResourcesAt "/distro/:package/maintainers"
68+
maintainersUserGroup
69+
(\distroName -> [("package", display distroName)])
70+
(packageInPath coreResource)
71+
distroNames
72+
5373
return feature
5474

5575
distrosStateComponent :: FilePath -> IO (StateComponent AcidState Distros)
@@ -68,15 +88,21 @@ distrosStateComponent stateDir = do
6888
distroFeature :: UserFeature
6989
-> CoreFeature
7090
-> StateComponent AcidState Distros
91+
-> GroupResource
92+
-> (DistroName -> UserGroup)
7193
-> DistroFeature
7294
distroFeature UserFeature{..}
7395
CoreFeature{coreResource=CoreResource{packageInPath}}
7496
distrosState
97+
maintainersGroupResource
98+
distroGroup
7599
= DistroFeature{..}
76100
where
77101
distroFeatureInterface = (emptyHackageFeature "distro") {
78102
featureResources =
79-
map ($ distroResource) [
103+
groupResource maintainersGroupResource
104+
: groupUserResource maintainersGroupResource
105+
: map ($ distroResource) [
80106
distroIndexPage
81107
, distroAllPage
82108
, distroPackages
@@ -109,10 +135,6 @@ distroFeature UserFeature{..}
109135
}
110136
}
111137

112-
maintainersGroup = \dpath -> case simpleParse =<< lookup "distro" dpath of
113-
Nothing -> return Nothing
114-
Just dname -> getMaintainersGroup adminGroup dname
115-
116138
textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState EnumerateDistros)
117139
textDistroPkgs dpath = withDistroPath dpath $ \dname pkgs -> do
118140
let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) pkgs
@@ -124,15 +146,15 @@ distroFeature UserFeature{..}
124146
-- result: see-other uri, or an error: not authenticated or not found (todo)
125147
distroDelete dpath =
126148
withDistroNamePath dpath $ \distro -> do
127-
guardAuthorised_ [InGroup adminGroup] --TODO: use the per-distro maintainer groups
149+
guardAuthorised_ [InGroup adminGroup]
128150
-- should also check for existence here of distro here
129151
void $ updateState distrosState $ RemoveDistro distro
130152
seeOther "/distros/" (toResponse ())
131153

132154
-- result: ok response or not-found error
133155
distroPackageDelete dpath =
134156
withDistroPackagePath dpath $ \dname pkgname info -> do
135-
guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups
157+
guardAuthorised_ [InGroup $ distroGroup dname]
136158
case info of
137159
Nothing -> notFound . toResponse $ "Package not found for " ++ display pkgname
138160
Just {} -> do
@@ -142,30 +164,30 @@ distroFeature UserFeature{..}
142164
-- result: see-other response, or an error: not authenticated or not found (todo)
143165
distroPackagePut dpath =
144166
withDistroPackagePath dpath $ \dname pkgname _ -> lookPackageInfo $ \newPkgInfo -> do
145-
guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups
167+
guardAuthorised_ [InGroup $ distroGroup dname]
146168
void $ updateState distrosState $ AddPackage dname pkgname newPkgInfo
147169
seeOther ("/distro/" ++ display dname ++ "/" ++ display pkgname) $ toResponse "Ok!"
148170

149171
-- result: see-other response, or an error: not authentcated or bad request
150172
distroPostNew _ =
151173
lookDistroName $ \dname -> do
152-
guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups
174+
guardAuthorised_ [InGroup adminGroup]
153175
success <- updateState distrosState $ AddDistro dname
154176
if success
155177
then seeOther ("/distro/" ++ display dname) $ toResponse "Ok!"
156178
else badRequest $ toResponse "Selected distribution name is already in use"
157179

158180
distroPutNew dpath =
159181
withDistroNamePath dpath $ \dname -> do
160-
guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups
182+
guardAuthorised_ [InGroup adminGroup]
161183
_success <- updateState distrosState $ AddDistro dname
162184
-- it doesn't matter if it exists already or not
163185
ok $ toResponse "Ok!"
164186

165187
-- result: ok repsonse or not-found error
166188
distroPackageListPut dpath =
167189
withDistroPath dpath $ \dname _pkgs -> do
168-
guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups
190+
guardAuthorised_ [InGroup $ distroGroup dname]
169191
lookCSVFile $ \csv ->
170192
case csvToPackageList csv of
171193
Left msg ->
@@ -205,8 +227,8 @@ distroFeature UserFeature{..}
205227
pVerStr <- look "version"
206228
pUriStr <- look "uri"
207229
case simpleParse pVerStr of
208-
Nothing -> mzero
209-
Just pVer -> return $ DistroPackageInfo pVer pUriStr
230+
Just pVer | isValidDistroURI pUriStr -> return $ DistroPackageInfo pVer pUriStr
231+
_ -> mzero
210232
case mInfo of
211233
(Left errs) -> ok $ toResponse $ unlines $ "Sorry, something went wrong there." : errs
212234
(Right pInfo) -> func pInfo
@@ -216,21 +238,6 @@ distroFeature UserFeature{..}
216238
Just distro -> func distro
217239
_ -> badRequest $ toResponse "Not a valid distro name"
218240

219-
getMaintainersGroup :: UserGroup -> DistroName -> IO (Maybe UserGroup)
220-
getMaintainersGroup admins dname = do
221-
isDist <- queryState distrosState (IsDistribution dname)
222-
case isDist of
223-
False -> return Nothing
224-
True -> return . Just $ UserGroup
225-
{ groupDesc = maintainerGroupDescription dname
226-
, queryUserGroup = queryState distrosState $ GetDistroMaintainers dname
227-
, addUserToGroup = updateState distrosState . AddDistroMaintainer dname
228-
, removeUserFromGroup = updateState distrosState . RemoveDistroMaintainer dname
229-
, groupsAllowedToAdd = [admins]
230-
, groupsAllowedToDelete = [admins]
231-
}
232-
233-
234241
maintainerGroupDescription :: DistroName -> GroupDescription
235242
maintainerGroupDescription dname = nullDescription
236243
{ groupTitle = "Maintainers"
@@ -253,13 +260,18 @@ packageListToCSV :: [(PackageName, DistroPackageInfo)] -> CSVFile
253260
packageListToCSV entries
254261
= CSVFile $ map (\(pn,DistroPackageInfo version url) -> [display pn, display version, url]) entries
255262

263+
isValidDistroURI :: String -> Bool
264+
isValidDistroURI uri =
265+
T.pack "https:" `T.isPrefixOf` T.pack uri
266+
256267
csvToPackageList :: CSVFile -> Either String [(PackageName, DistroPackageInfo)]
257268
csvToPackageList (CSVFile records)
258269
= mapM fromRecord records
259270
where
260271
fromRecord [packageStr, versionStr, uri]
261272
| Just package <- simpleParse packageStr
262273
, Just version <- simpleParse versionStr
274+
, isValidDistroURI uri
263275
= return (package, DistroPackageInfo version uri)
264-
fromRecord rec
265-
= Left $ "Invalid distro package entry: " ++ show rec
276+
fromRecord record
277+
= Left $ "Invalid distro package entry: " ++ show record

‎src/Distribution/Server/Features/Distro/Types.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88

99
module Distribution.Server.Features.Distro.Types where
1010

11+
import Distribution.Server.Framework (FromReqURI(..))
1112
import Distribution.Server.Framework.Instances ()
1213
import Distribution.Server.Framework.MemSize
1314
import Distribution.Server.Users.State()
@@ -22,6 +23,7 @@ import Distribution.Package
2223
import Distribution.Pretty (Pretty(..))
2324
import Distribution.Parsec (Parsec(..))
2425
import qualified Distribution.Compat.CharParsing as P
26+
import Distribution.Text (simpleParse)
2527

2628
import qualified Text.PrettyPrint as Disp
2729
import qualified Data.Char as Char
@@ -39,6 +41,9 @@ instance Pretty DistroName where
3941
instance Parsec DistroName where
4042
parsec = DistroName <$> P.munch1 (\c -> Char.isAlphaNum c || c `elem` "-_()[]{}=$,;")
4143

44+
instance FromReqURI DistroName where
45+
fromReqURI = simpleParse
46+
4247
-- | Listing of known distributions and their maintainers
4348
data Distributions = Distributions {
4449
nameMap :: !(Map.Map DistroName UserIdSet)

0 commit comments

Comments
 (0)