diff --git a/datafiles/templates/Html/analytics-pixels-page.html.st b/datafiles/templates/Html/analytics-pixels-page.html.st new file mode 100644 index 000000000..6419eacbf --- /dev/null +++ b/datafiles/templates/Html/analytics-pixels-page.html.st @@ -0,0 +1,45 @@ + + + +$hackageCssTheme()$ +Analytics pixels for $pkgname$ | Hackage + + + +$hackagePageHeader()$ + +
+ +

Adding a analytics pixel to $pkgname$

+ +

+ Configure an analytics pixel to be automatically loaded on your package’s page on Hackage. + You’ll need an image URL from any external analytics provider, which is provided + for free and can surface information about web traffic to your package including geographic + distribution, version distribution, and companies. +

+ +
+ + + +
+ +

Existing analytics pixels for $pkgname$

+ + + +
+ + diff --git a/datafiles/templates/Html/package-page.html.st b/datafiles/templates/Html/package-page.html.st index 0c0271e64..a0453627e 100644 --- a/datafiles/templates/Html/package-page.html.st +++ b/datafiles/templates/Html/package-page.html.st @@ -95,6 +95,11 @@ edit package information +
  • + + edit package analytics pixels + +

    • Candidates

    diff --git a/hackage-server.cabal b/hackage-server.cabal index df72f0a14..10b657160 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -347,6 +347,8 @@ library lib-server Distribution.Server.Features.Tags Distribution.Server.Features.Tags.Backup Distribution.Server.Features.Tags.State + Distribution.Server.Features.AnalyticsPixels + Distribution.Server.Features.AnalyticsPixels.State Distribution.Server.Features.UserDetails Distribution.Server.Features.UserSignup Distribution.Server.Features.StaticFiles diff --git a/src/Distribution/Server/Features.hs b/src/Distribution/Server/Features.hs index 39679d9ca..fc2a152a5 100644 --- a/src/Distribution/Server/Features.hs +++ b/src/Distribution/Server/Features.hs @@ -36,6 +36,7 @@ import Distribution.Server.Features.PreferredVersions (initVersionsFeature) -- [reverse index disabled] import Distribution.Server.Features.ReverseDependencies (initReverseFeature) import Distribution.Server.Features.DownloadCount (initDownloadFeature) import Distribution.Server.Features.Tags (initTagsFeature) +import Distribution.Server.Features.AnalyticsPixels (initAnalyticsPixelsFeature) import Distribution.Server.Features.Search (initSearchFeature) import Distribution.Server.Features.PackageList (initListFeature) import Distribution.Server.Features.HaskellPlatform (initPlatformFeature) @@ -127,6 +128,8 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do initDownloadFeature env mkTagsFeature <- logStartup "tags" $ initTagsFeature env + mkAnalyticsPixelsFeature <- logStartup "analytics pixels" $ + initAnalyticsPixelsFeature env mkVersionsFeature <- logStartup "versions" $ initVersionsFeature env -- mkReverseFeature <- logStartup "reverse deps" $ @@ -255,6 +258,11 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do uploadFeature usersFeature + analyticsPixelsFeature <- mkAnalyticsPixelsFeature + coreFeature + usersFeature + uploadFeature + versionsFeature <- mkVersionsFeature coreFeature uploadFeature @@ -292,6 +300,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do versionsFeature -- [reverse index disabled] reverseFeature tagsFeature + analyticsPixelsFeature downloadFeature votesFeature listFeature @@ -372,6 +381,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do , getFeatureInterface documentationCandidatesFeature , getFeatureInterface downloadFeature , getFeatureInterface tagsFeature + , getFeatureInterface analyticsPixelsFeature , getFeatureInterface versionsFeature -- [reverse index disabled] , getFeatureInterface reverseFeature , getFeatureInterface searchFeature diff --git a/src/Distribution/Server/Features/AnalyticsPixels.hs b/src/Distribution/Server/Features/AnalyticsPixels.hs new file mode 100644 index 000000000..f8b71be75 --- /dev/null +++ b/src/Distribution/Server/Features/AnalyticsPixels.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-} + +-- | Implements a system to allow users to upvote packages. +-- +module Distribution.Server.Features.AnalyticsPixels + ( AnalyticsPixelsFeature(..) + , AnalyticsPixel(..) + , initAnalyticsPixelsFeature + ) where + +import Data.Set (Set) + +import Distribution.Server.Features.AnalyticsPixels.State + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore + +import Distribution.Server.Features.Core +import Distribution.Server.Features.Upload +import Distribution.Server.Features.Users + +import Distribution.Package + +-- | Define the prototype for this feature +data AnalyticsPixelsFeature = AnalyticsPixelsFeature { + analyticsPixelsFeatureInterface :: HackageFeature, + analyticsPixelsResource :: Resource, + userAnalyticsPixelsResource :: Resource, + + analyticsPixelAdded :: Hook (PackageName, AnalyticsPixel) (), + analyticsPixelRemoved :: Hook (PackageName, AnalyticsPixel) (), + + -- | Returns all 'AnalyticsPixel's associated with a 'Package'. + getPackageAnalyticsPixels :: forall m. MonadIO m => PackageName -> m (Set AnalyticsPixel), + + -- | Adds a new 'AnalyticsPixel' to a 'Package'. Returns True in case it was added. False in case + -- it's already existing. + addPackageAnalyticsPixel :: forall m. MonadIO m => PackageName -> AnalyticsPixel -> m Bool, + + -- | Remove a 'AnalyticsPixel' from a 'Package'. + removePackageAnalyticsPixel :: forall m. MonadIO m => PackageName -> AnalyticsPixel -> m () +} + +-- | Implement the isHackageFeature 'interface' +instance IsHackageFeature AnalyticsPixelsFeature where + getFeatureInterface = analyticsPixelsFeatureInterface + +-- | Called from Features.hs to initialize this feature +initAnalyticsPixelsFeature :: ServerEnv + -> IO ( CoreFeature + -> UserFeature + -> UploadFeature + -> IO AnalyticsPixelsFeature) +initAnalyticsPixelsFeature env@ServerEnv{serverStateDir} = do + dbAnalyticsPixelsState <- analyticsPixelsStateComponent serverStateDir + analyticsPixelAdded <- newHook + analyticsPixelRemoved <- newHook + + return $ \coref@CoreFeature{..} userf@UserFeature{..} uploadf -> do + let feature = analyticsPixelsFeature env + dbAnalyticsPixelsState + coref userf uploadf analyticsPixelAdded analyticsPixelRemoved + + return feature + +-- | Define the backing store (i.e. database component) +analyticsPixelsStateComponent :: FilePath -> IO (StateComponent AcidState AnalyticsPixelsState) +analyticsPixelsStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "AnalyticsPixels") initialAnalyticsPixelsState + return StateComponent { + stateDesc = "Backing store for AnalyticsPixels feature" + , stateHandle = st + , getState = query st GetAnalyticsPixelsState + , putState = update st . ReplaceAnalyticsPixelsState + , resetState = analyticsPixelsStateComponent + , backupState = \_ _ -> [] + , restoreState = RestoreBackup { + restoreEntry = error "Unexpected backup entry" + , restoreFinalize = return initialAnalyticsPixelsState + } + } + + +-- | Default constructor for building this feature. +analyticsPixelsFeature :: ServerEnv + -> StateComponent AcidState AnalyticsPixelsState + -> CoreFeature -- To get site package list + -> UserFeature -- To authenticate users + -> UploadFeature -- For accessing package maintainers and trustees + -> Hook (PackageName, AnalyticsPixel) () -- Signals addition of a new AnalyticsPixel + -> Hook (PackageName, AnalyticsPixel) () -- Signals removeal of a AnalyticsPixel + -> AnalyticsPixelsFeature + +analyticsPixelsFeature ServerEnv{..} + analyticsPixelsState + CoreFeature { coreResource = CoreResource{..} } + UserFeature{..} + UploadFeature{..} + analyticsPixelAdded + analyticsPixelRemoved + = AnalyticsPixelsFeature {..} + where + analyticsPixelsFeatureInterface = (emptyHackageFeature "AnalyticsPixels") { + featureDesc = "Allow users to attach analytics pixels to their packages", + featureResources = [analyticsPixelsResource, userAnalyticsPixelsResource] + , featureState = [abstractAcidStateComponent analyticsPixelsState] + } + + analyticsPixelsResource :: Resource + analyticsPixelsResource = resourceAt "/package/:package/analytics-pixels.:format" + + userAnalyticsPixelsResource :: Resource + userAnalyticsPixelsResource = resourceAt "/user/:username/analytics-pixels.:format" + + getPackageAnalyticsPixels :: MonadIO m => PackageName -> m (Set AnalyticsPixel) + getPackageAnalyticsPixels name = + queryState analyticsPixelsState (AnalyticsPixelsForPackage name) + + addPackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m Bool + addPackageAnalyticsPixel name pixel = do + added <- updateState analyticsPixelsState (AddPackageAnalyticsPixel name pixel) + when added $ runHook_ analyticsPixelAdded (name, pixel) + pure added + + removePackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m () + removePackageAnalyticsPixel name pixel = do + updateState analyticsPixelsState (RemovePackageAnalyticsPixel name pixel) + runHook_ analyticsPixelRemoved (name, pixel) diff --git a/src/Distribution/Server/Features/AnalyticsPixels/State.hs b/src/Distribution/Server/Features/AnalyticsPixels/State.hs new file mode 100644 index 000000000..d31b91642 --- /dev/null +++ b/src/Distribution/Server/Features/AnalyticsPixels/State.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, + TypeFamilies, TemplateHaskell #-} + +module Distribution.Server.Features.AnalyticsPixels.State + ( AnalyticsPixel(..) + , AnalyticsPixelsState(..) + , initialAnalyticsPixelsState + + -- * State queries and updates + , AnalyticsPixelsForPackage(..) + , AddPackageAnalyticsPixel(..) + , RemovePackageAnalyticsPixel(..) + , GetAnalyticsPixelsState(..) + , ReplaceAnalyticsPixelsState(..) + ) where + +import Distribution.Package (PackageName) + +import Distribution.Server.Framework.MemSize (MemSize) +import Distribution.Server.Users.State () + +import Data.Text (Text) +import Data.Typeable (Typeable) +import Data.Map (Map) +import qualified Data.Map.Strict as Map +import Data.Acid (Query, Update, makeAcidic) +import Data.SafeCopy (base, deriveSafeCopy) +import Data.Set (Set) +import qualified Data.Set as Set + +import Control.DeepSeq (NFData) +import qualified Control.Monad.State as State +import Control.Monad.Reader.Class (ask, asks) + +newtype AnalyticsPixel = AnalyticsPixel + { + analyticsPixelUrl :: Text + } + deriving (Show, Eq, Ord, NFData, Typeable, MemSize) + +newtype AnalyticsPixelsState = AnalyticsPixelsState + { + analyticsPixels :: Map PackageName (Set AnalyticsPixel) + } + deriving (Show, Eq, NFData, Typeable, MemSize) + +-- SafeCopy instances +$(deriveSafeCopy 0 'base ''AnalyticsPixel) +$(deriveSafeCopy 0 'base ''AnalyticsPixelsState) + +-- + +initialAnalyticsPixelsState :: AnalyticsPixelsState +initialAnalyticsPixelsState = AnalyticsPixelsState + { + analyticsPixels = Map.empty + } + +analyticsPixelsForPackage :: PackageName -> Query AnalyticsPixelsState (Set AnalyticsPixel) +analyticsPixelsForPackage name = asks $ Map.findWithDefault Set.empty name . analyticsPixels + +-- | Adds a 'AnalyticsPixel' to a 'Package'. Returns 'True' if the pixel was inserted, and 'False' if +-- the 'AnalyticsPixel' was already present. +addPackageAnalyticsPixel :: PackageName -> AnalyticsPixel -> Update AnalyticsPixelsState Bool +addPackageAnalyticsPixel name analyticsPixel = do + state <- State.get + let (successfullyInserted, pixels) = Map.alterF insertAnalyticsPixel name (analyticsPixels state) + State.put (state { analyticsPixels = pixels }) + pure successfullyInserted + where + insertAnalyticsPixel :: Maybe (Set AnalyticsPixel) -> (Bool, Maybe (Set AnalyticsPixel)) + insertAnalyticsPixel Nothing = + (True, Just (Set.singleton analyticsPixel)) + insertAnalyticsPixel existingPixels@(Just pixels) + | analyticsPixel `Set.member` pixels = + (False, existingPixels) + | otherwise = + (True, Just (Set.insert analyticsPixel pixels)) + +-- | Removes a 'AnalyticsPixel' from a 'Package'. +removePackageAnalyticsPixel :: PackageName -> AnalyticsPixel -> Update AnalyticsPixelsState () +removePackageAnalyticsPixel name analyticsPixel = do + state <- State.get + let pixels = Map.alter removeAnalyticsPixel name (analyticsPixels state) + State.put (state { analyticsPixels = pixels }) + pure () + where + removeAnalyticsPixel Nothing = + Nothing + removeAnalyticsPixel (Just pixels) = + let pixels' = analyticsPixel `Set.delete` pixels in + if Set.null pixels' then Nothing else Just pixels' + +-- get and replace the entire state, for backups + +getAnalyticsPixelsState :: Query AnalyticsPixelsState AnalyticsPixelsState +getAnalyticsPixelsState = ask + +replaceAnalyticsPixelsState :: AnalyticsPixelsState -> Update AnalyticsPixelsState () +replaceAnalyticsPixelsState = State.put + +makeAcidic + ''AnalyticsPixelsState + [ 'getAnalyticsPixelsState + , 'analyticsPixelsForPackage + , 'replaceAnalyticsPixelsState + , 'addPackageAnalyticsPixel + , 'removePackageAnalyticsPixel + ] diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 91d309831..7155f62e4 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -27,6 +27,7 @@ import Distribution.Server.Features.PreferredVersions import Distribution.Server.Features.PackageContents (PackageContentsFeature(..)) import Distribution.Server.Features.PackageList import Distribution.Server.Features.Tags +import Distribution.Server.Features.AnalyticsPixels import Distribution.Server.Features.Mirror import Distribution.Server.Features.Distro import Distribution.Server.Features.Documentation @@ -102,7 +103,9 @@ initHtmlFeature :: ServerEnv -> UploadFeature -> PackageCandidatesFeature -> VersionsFeature -- [reverse index disabled] -> ReverseFeature - -> TagsFeature -> DownloadFeature + -> TagsFeature + -> AnalyticsPixelsFeature + -> DownloadFeature -> VotesFeature -> ListFeature -> SearchFeature -> MirrorFeature -> DistroFeature @@ -131,6 +134,8 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode, , "candidate-index.html" , "browse.html" , "noscript-search-form.html" + , "analytics-pixels-page.html" + , "user-analytics-pixels-page.html" ] @@ -138,7 +143,7 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode, packages upload candidates versions -- [reverse index disabled] reverse - tags download + tags analyticsPixels download rank list@ListFeature{itemUpdate} names mirror @@ -152,7 +157,7 @@ initHtmlFeature env@ServerEnv{serverTemplatesDir, serverTemplatesMode, htmlFeature env user core packages upload candidates versions - tags download + tags analyticsPixels download rank list names mirror distros @@ -197,6 +202,7 @@ htmlFeature :: ServerEnv -> PackageCandidatesFeature -> VersionsFeature -> TagsFeature + -> AnalyticsPixelsFeature -> DownloadFeature -> VotesFeature -> ListFeature @@ -220,7 +226,7 @@ htmlFeature env@ServerEnv{..} packages upload candidates versions -- [reverse index disabled] ReverseFeature{..} - tags download + tags analyticsPixels download rank list@ListFeature{getAllLists} names @@ -258,6 +264,7 @@ htmlFeature env@ServerEnv{..} versions upload tags + analyticsPixels docsCore tarIndexCache reportsCore @@ -283,6 +290,8 @@ htmlFeature env@ServerEnv{..} htmlPreferred = mkHtmlPreferred utilities core versions htmlTags = mkHtmlTags utilities core upload user list tags templates + htmlAnalyticsPixels = mkHtmlAnalyticsPixels utilities core user upload analyticsPixels templates + htmlResources = concat [ htmlCoreResources htmlCore , htmlUsersResources htmlUsers @@ -293,6 +302,7 @@ htmlFeature env@ServerEnv{..} , htmlPreferredResources htmlPreferred , htmlDownloadsResources htmlDownloads , htmlTagsResources htmlTags + , htmlAnalyticsPixelsResources htmlAnalyticsPixels -- and user groups. package maintainers, trustees, admins , htmlGroupResource user (maintainersGroupResource . uploadResource $ upload) , htmlGroupResource user (trusteesGroupResource . uploadResource $ upload) @@ -449,6 +459,7 @@ mkHtmlCore :: ServerEnv -> VersionsFeature -> UploadFeature -> TagsFeature + -> AnalyticsPixelsFeature -> DocumentationFeature -> TarIndexCacheFeature -> ReportsFeature @@ -475,6 +486,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} } UploadFeature{..} TagsFeature{queryTagsForPackage} + AnalyticsPixelsFeature{getPackageAnalyticsPixels} documentationFeature@DocumentationFeature{documentationResource, queryDocumentation} TarIndexCacheFeature{cachedTarIndex} reportsFeature @@ -598,6 +610,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} documentationFeature reportsFeature realpkg mdocIndex <- maybe (return Nothing) (liftM Just . liftIO . cachedTarIndex) mdoctarblob + analyticsPixels <- getPackageAnalyticsPixels pkgname let idAndReport = fmap (\(rptId, rpt, _) -> (rptId, rpt)) rptStats install = getInstall $ fmap (fst &&& BR.installOutcome . snd) idAndReport @@ -628,6 +641,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} , "sbaseurl" $= show (serverBaseURI { URI.uriScheme = "https:" }) , "cabalVersion" $= display cabalVersion , "tags" $= (renderTags tags) + , "analyticsPixels" $= map analyticsPixelUrl (Set.toList analyticsPixels) , "versions" $= (PagesNew.renderVersion realpkg (classifyVersions prefInfo $ map packageVersion pkgs) infoUrl) , "totalDownloads" $= totalDown @@ -1803,6 +1817,134 @@ mkHtmlTags HtmlUtilities{..} tagInPath :: forall m a. (MonadPlus m, FromReqURI a) => DynamicPath -> m a tagInPath dpath = maybe mzero return (lookup "tag" dpath >>= fromReqURI) +{------------------------------------------------------------------------------- + Tracking pixels +-------------------------------------------------------------------------------} + +newtype HtmlAnalyticsPixels = HtmlAnalyticsPixels { + htmlAnalyticsPixelsResources :: [Resource] + } + +mkHtmlAnalyticsPixels :: HtmlUtilities -> CoreFeature -> UserFeature -> UploadFeature -> AnalyticsPixelsFeature -> Templates -> HtmlAnalyticsPixels +mkHtmlAnalyticsPixels HtmlUtilities{..} CoreFeature{..} UserFeature{..} UploadFeature{..} AnalyticsPixelsFeature{..} templates = HtmlAnalyticsPixels{..} + where + CoreResource{..} = coreResource + + htmlAnalyticsPixelsResources = [ + (extendResource analyticsPixelsResource) { + resourceGet = [("html", servePackageAnalyticsPixels)] + , resourcePost = [("html", serveAddPackageAnalyticsPixel)] + , resourceDelete = [("html", serveRemovePackageAnalyticsPixel)] + }, + (extendResource userAnalyticsPixelsResource) { + resourceGet = [("html", serveUserPackageAnalyticsPixels)] + , resourcePost = [("html", serveAddUserPackageAnalyticsPixel)] + , resourceDelete = [("html", serveRemoveUserPackageAnalyticsPixel)] + } + ] + + serveUserPackageAnalyticsPixels :: DynamicPath -> ServerPartE Response + serveUserPackageAnalyticsPixels dpath = do + uname <- userNameInPath dpath + userPackagesAnalyticsPixelsHtml uname + + serveAddUserPackageAnalyticsPixel :: DynamicPath -> ServerPartE Response + serveAddUserPackageAnalyticsPixel = + serveModifyUserPackageAnalyticsPixel $ \pkgname pixel -> do + _ <- addPackageAnalyticsPixel pkgname pixel + pure () + + serveRemoveUserPackageAnalyticsPixel :: DynamicPath -> ServerPartE Response + serveRemoveUserPackageAnalyticsPixel = + serveModifyUserPackageAnalyticsPixel removePackageAnalyticsPixel + + serveModifyUserPackageAnalyticsPixel + :: (PackageName -> AnalyticsPixel -> ServerPartE ()) + -> DynamicPath + -> ServerPartE Response + serveModifyUserPackageAnalyticsPixel modifyPixel dpath = do + uname <- userNameInPath dpath + request <- + getDataFn $ (,) + <$> look "package" + <*> look "analytics-pixel" + case request of + Left errs -> + errBadRequest "Error adding new tracking pixel" + ((MText "Tracking pixel url missing.") : map MText errs) + Right (pkgnameStr, analyticsPixel) -> do + let pkgname = mkPackageName pkgnameStr + pixel = AnalyticsPixel (T.pack analyticsPixel) + guardAuthorisedAsMaintainerOrTrustee pkgname + modifyPixel pkgname pixel + userPackagesAnalyticsPixelsHtml uname + + servePackageAnalyticsPixels :: DynamicPath -> ServerPartE Response + servePackageAnalyticsPixels dpath = do + pkgname <- packageInPath dpath + packageAnalyticsPixelsHtml pkgname + + serveAddPackageAnalyticsPixel :: DynamicPath -> ServerPartE Response + serveAddPackageAnalyticsPixel = do + serveModifyPackageAnalyticsPixel $ \pkgname pixel -> do + _ <- addPackageAnalyticsPixel pkgname pixel + pure () + + serveRemovePackageAnalyticsPixel :: DynamicPath -> ServerPartE Response + serveRemovePackageAnalyticsPixel = + serveModifyPackageAnalyticsPixel removePackageAnalyticsPixel + + serveModifyPackageAnalyticsPixel + :: (PackageName -> AnalyticsPixel -> ServerPartE ()) + -> DynamicPath + -> ServerPartE Response + serveModifyPackageAnalyticsPixel modifyPixel dpath = do + pkgname <- packageInPath dpath + guardValidPackageName pkgname + guardAuthorisedAsMaintainerOrTrustee pkgname + request <- getDataFn (look "analytics-pixel") + case request of + Left errs -> + errBadRequest "Error adding new tracking pixel" + ((MText "Tracking pixel url missing.") : map MText errs) + Right analyticsPixel -> do + let pixel = AnalyticsPixel (T.pack analyticsPixel) + modifyPixel pkgname pixel + packageAnalyticsPixelsHtml pkgname + + packageAnalyticsPixelsHtml :: PackageName -> ServerPartE Response + packageAnalyticsPixelsHtml pkgname = do + analyticsPixels <- getPackageAnalyticsPixels pkgname + template <- getTemplate templates "analytics-pixels-page.html" + return $ toResponse $ template + [ "pkgname" $= pkgname, + "AnalyticsPixels" $= map analyticsPixelUrl (Set.toList analyticsPixels) + ] + + userPackagesAnalyticsPixelsHtml :: UserName -> ServerPartE Response + userPackagesAnalyticsPixelsHtml uname = do + uid <- lookupUserName uname + -- Get all the packages the user has access to + uris <- getGroupIndex uid + pkgs <- foldMap (\uri -> do + groupDesc <- getIndexDesc uri + let mpackageName = fmap fst (Group.groupEntity groupDesc) + pure $ maybeToList (fmap mkPackageName mpackageName) + ) + uris + pkgpixels <- forM pkgs $ \pkgname -> do + pixels <- getPackageAnalyticsPixels pkgname + pure (pkgname, map analyticsPixelUrl (Set.toList pixels)) + template <- getTemplate templates "user-analytics-pixels-page.html" + return $ toResponse $ template + [ "username" $= uname, + "pkgs" $= pkgs, + "pkgpixels" $= filter (not . null . snd) pkgpixels + ] + + guardAuthorisedAsMaintainerOrTrustee pkgname = + guardAuthorised_ [InGroup (maintainersGroup pkgname), InGroup trusteesGroup] + {------------------------------------------------------------------------------- Groups -------------------------------------------------------------------------------} diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs index a525f4cd3..78b95aa3a 100644 --- a/src/Distribution/Server/Features/Users.hs +++ b/src/Distribution/Server/Features/Users.hs @@ -157,6 +157,8 @@ data UserResource = UserResource { userPage :: Resource, -- | A user's password. passwordResource :: Resource, + -- | A user's package tracking pixels. + analyticsPixelsResource :: Resource, -- | A user's enabled status. enabledResource :: Resource, -- | The admin group. @@ -362,6 +364,7 @@ userFeature templates usersState adminsState , resourceGet = [ ("", const (redirectUserManagement r)) ] } , passwordResource = resourceAt "/user/:username/password.:format" + , analyticsPixelsResource = resourceAt "/user/:username/analytics-pixels.:format" --TODO: PUT , enabledResource = (resourceAt "/user/:username/enabled.:format") { resourceDesc = [ (GET, "return if the user is enabled") diff --git a/src/Distribution/Server/Framework/Templating.hs b/src/Distribution/Server/Framework/Templating.hs index cbbcfcc2e..6ef9eeea7 100644 --- a/src/Distribution/Server/Framework/Templating.hs +++ b/src/Distribution/Server/Framework/Templating.hs @@ -52,6 +52,7 @@ import qualified Data.Aeson as JSON import Distribution.Package (PackageName, PackageIdentifier) import Distribution.Version (Version) +import Distribution.Server.Users.Types (UserName) import Distribution.Text (display) import Control.Monad (when) @@ -120,6 +121,7 @@ instance ToSElem XHtml.Html where instance ToSElem URI where toSElem = toSElem . show instance ToSElem PackageName where toSElem = toSElem . display +instance ToSElem UserName where toSElem = toSElem . display instance ToSElem Version where toSElem = toSElem . display instance ToSElem PackageIdentifier where toSElem = toSElem . display