diff --git a/src/Distribution/Server/Features/Distro.hs b/src/Distribution/Server/Features/Distro.hs index 785bb5f6..82042d11 100644 --- a/src/Distribution/Server/Features/Distro.hs +++ b/src/Distribution/Server/Features/Distro.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, RecursiveDo #-} module Distribution.Server.Features.Distro ( DistroFeature(..), DistroResource(..), @@ -20,6 +20,7 @@ import Distribution.Text (display, simpleParse) import Distribution.Package import Data.List (intercalate) +import qualified Data.Text as T import Text.CSV (parseCSV) -- TODO: @@ -29,7 +30,6 @@ import Text.CSV (parseCSV) data DistroFeature = DistroFeature { distroFeatureInterface :: HackageFeature, distroResource :: DistroResource, - maintainersGroup :: DynamicPath -> IO (Maybe UserGroup), queryPackageStatus :: forall m. MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)] } @@ -48,8 +48,28 @@ initDistroFeature :: ServerEnv initDistroFeature ServerEnv{serverStateDir} = do distrosState <- distrosStateComponent serverStateDir - return $ \user core -> do - let feature = distroFeature user core distrosState + return $ \user@UserFeature{adminGroup, groupResourcesAt} core@CoreFeature{coreResource} -> do + rec + let + maintainersUserGroup :: DistroName -> UserGroup + maintainersUserGroup name = + UserGroup { + groupDesc = maintainerGroupDescription name, + queryUserGroup = queryState distrosState $ GetDistroMaintainers name, + addUserToGroup = updateState distrosState . AddDistroMaintainer name, + removeUserFromGroup = updateState distrosState . RemoveDistroMaintainer name, + groupsAllowedToAdd = [adminGroup], + groupsAllowedToDelete = [adminGroup] + } + feature = distroFeature user core distrosState maintainersGroupResource maintainersUserGroup + distroNames <- queryState distrosState EnumerateDistros + (_maintainersGroup, maintainersGroupResource) <- + groupResourcesAt "/distro/:package/maintainers" + maintainersUserGroup + (\distroName -> [("package", display distroName)]) + (packageInPath coreResource) + distroNames + return feature distrosStateComponent :: FilePath -> IO (StateComponent AcidState Distros) @@ -68,15 +88,21 @@ distrosStateComponent stateDir = do distroFeature :: UserFeature -> CoreFeature -> StateComponent AcidState Distros + -> GroupResource + -> (DistroName -> UserGroup) -> DistroFeature distroFeature UserFeature{..} CoreFeature{coreResource=CoreResource{packageInPath}} distrosState + maintainersGroupResource + distroGroup = DistroFeature{..} where distroFeatureInterface = (emptyHackageFeature "distro") { featureResources = - map ($ distroResource) [ + groupResource maintainersGroupResource + : groupUserResource maintainersGroupResource + : map ($ distroResource) [ distroIndexPage , distroAllPage , distroPackages @@ -109,10 +135,6 @@ distroFeature UserFeature{..} } } - maintainersGroup = \dpath -> case simpleParse =<< lookup "distro" dpath of - Nothing -> return Nothing - Just dname -> getMaintainersGroup adminGroup dname - textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState EnumerateDistros) textDistroPkgs dpath = withDistroPath dpath $ \dname pkgs -> do let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) pkgs @@ -124,7 +146,7 @@ distroFeature UserFeature{..} -- result: see-other uri, or an error: not authenticated or not found (todo) distroDelete dpath = withDistroNamePath dpath $ \distro -> do - guardAuthorised_ [InGroup adminGroup] --TODO: use the per-distro maintainer groups + guardAuthorised_ [InGroup adminGroup] -- should also check for existence here of distro here void $ updateState distrosState $ RemoveDistro distro seeOther "/distros/" (toResponse ()) @@ -132,7 +154,7 @@ distroFeature UserFeature{..} -- result: ok response or not-found error distroPackageDelete dpath = withDistroPackagePath dpath $ \dname pkgname info -> do - guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups + guardAuthorised_ [InGroup $ distroGroup dname] case info of Nothing -> notFound . toResponse $ "Package not found for " ++ display pkgname Just {} -> do @@ -142,14 +164,14 @@ distroFeature UserFeature{..} -- result: see-other response, or an error: not authenticated or not found (todo) distroPackagePut dpath = withDistroPackagePath dpath $ \dname pkgname _ -> lookPackageInfo $ \newPkgInfo -> do - guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups + guardAuthorised_ [InGroup $ distroGroup dname] void $ updateState distrosState $ AddPackage dname pkgname newPkgInfo seeOther ("/distro/" ++ display dname ++ "/" ++ display pkgname) $ toResponse "Ok!" -- result: see-other response, or an error: not authentcated or bad request distroPostNew _ = lookDistroName $ \dname -> do - guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups + guardAuthorised_ [InGroup adminGroup] success <- updateState distrosState $ AddDistro dname if success then seeOther ("/distro/" ++ display dname) $ toResponse "Ok!" @@ -157,7 +179,7 @@ distroFeature UserFeature{..} distroPutNew dpath = withDistroNamePath dpath $ \dname -> do - guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups + guardAuthorised_ [InGroup adminGroup] _success <- updateState distrosState $ AddDistro dname -- it doesn't matter if it exists already or not ok $ toResponse "Ok!" @@ -165,7 +187,7 @@ distroFeature UserFeature{..} -- result: ok repsonse or not-found error distroPackageListPut dpath = withDistroPath dpath $ \dname _pkgs -> do - guardAuthorised_ [AnyKnownUser] --TODO: use the per-distro maintainer groups + guardAuthorised_ [InGroup $ distroGroup dname] lookCSVFile $ \csv -> case csvToPackageList csv of Left msg -> @@ -205,8 +227,8 @@ distroFeature UserFeature{..} pVerStr <- look "version" pUriStr <- look "uri" case simpleParse pVerStr of - Nothing -> mzero - Just pVer -> return $ DistroPackageInfo pVer pUriStr + Just pVer | isValidDistroURI pUriStr -> return $ DistroPackageInfo pVer pUriStr + _ -> mzero case mInfo of (Left errs) -> ok $ toResponse $ unlines $ "Sorry, something went wrong there." : errs (Right pInfo) -> func pInfo @@ -216,21 +238,6 @@ distroFeature UserFeature{..} Just distro -> func distro _ -> badRequest $ toResponse "Not a valid distro name" - getMaintainersGroup :: UserGroup -> DistroName -> IO (Maybe UserGroup) - getMaintainersGroup admins dname = do - isDist <- queryState distrosState (IsDistribution dname) - case isDist of - False -> return Nothing - True -> return . Just $ UserGroup - { groupDesc = maintainerGroupDescription dname - , queryUserGroup = queryState distrosState $ GetDistroMaintainers dname - , addUserToGroup = updateState distrosState . AddDistroMaintainer dname - , removeUserFromGroup = updateState distrosState . RemoveDistroMaintainer dname - , groupsAllowedToAdd = [admins] - , groupsAllowedToDelete = [admins] - } - - maintainerGroupDescription :: DistroName -> GroupDescription maintainerGroupDescription dname = nullDescription { groupTitle = "Maintainers" @@ -253,6 +260,10 @@ packageListToCSV :: [(PackageName, DistroPackageInfo)] -> CSVFile packageListToCSV entries = CSVFile $ map (\(pn,DistroPackageInfo version url) -> [display pn, display version, url]) entries +isValidDistroURI :: String -> Bool +isValidDistroURI uri = + T.pack "https:" `T.isPrefixOf` T.pack uri + csvToPackageList :: CSVFile -> Either String [(PackageName, DistroPackageInfo)] csvToPackageList (CSVFile records) = mapM fromRecord records @@ -260,6 +271,7 @@ csvToPackageList (CSVFile records) fromRecord [packageStr, versionStr, uri] | Just package <- simpleParse packageStr , Just version <- simpleParse versionStr + , isValidDistroURI uri = return (package, DistroPackageInfo version uri) - fromRecord rec - = Left $ "Invalid distro package entry: " ++ show rec + fromRecord record + = Left $ "Invalid distro package entry: " ++ show record diff --git a/src/Distribution/Server/Features/Distro/Types.hs b/src/Distribution/Server/Features/Distro/Types.hs index 92225f54..5f632836 100644 --- a/src/Distribution/Server/Features/Distro/Types.hs +++ b/src/Distribution/Server/Features/Distro/Types.hs @@ -8,6 +8,7 @@ module Distribution.Server.Features.Distro.Types where +import Distribution.Server.Framework (FromReqURI(..)) import Distribution.Server.Framework.Instances () import Distribution.Server.Framework.MemSize import Distribution.Server.Users.State() @@ -22,6 +23,7 @@ import Distribution.Package import Distribution.Pretty (Pretty(..)) import Distribution.Parsec (Parsec(..)) import qualified Distribution.Compat.CharParsing as P +import Distribution.Text (simpleParse) import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char @@ -39,6 +41,9 @@ instance Pretty DistroName where instance Parsec DistroName where parsec = DistroName <$> P.munch1 (\c -> Char.isAlphaNum c || c `elem` "-_()[]{}=$,;") +instance FromReqURI DistroName where + fromReqURI = simpleParse + -- | Listing of known distributions and their maintainers data Distributions = Distributions { nameMap :: !(Map.Map DistroName UserIdSet)