haskell · gbaz · May 14, 2022 · Jan 12, 2022
diff --git a/datafiles/templates/Html/analytics-pixels-page.html.st b/datafiles/templates/Html/analytics-pixels-page.html.st
@@ -0,0 +1,45 @@
+<!DOCTYPE html>
+<html>
+<head>
+$hackageCssTheme()$
+<title>Analytics pixels for $pkgname$ | Hackage</title>
+</head>
+
+<body>
+$hackagePageHeader()$
+
+<div id="content">
+
+<h2>Adding a analytics pixel to <a href="/package/$pkgname$">$pkgname$</a></h2>
+
+<p> 
+  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.
+</p>
+
+<form method="POST" class="box" action="/package/$pkgname$/analytics-pixels">
+    <label for="analytics-pixel">Analytics Image URL</label>
+    <input name="analytics-pixel" type="text" />
+    <input type="submit" />
+</form>
+
+<h2>Existing analytics pixels for <a href="/package/$pkgname$">$pkgname$</a></h2>
+
+<ul>
+  $analyticsPixels:{analyticsPixel|
+    <li>
+        <form method="POST" action="/package/$pkgname$/analytics-pixels">
+            <label for="analytics-pixel">$analyticsPixel$</label>
+            <input type="hidden" name="analytics-pixel" value="$analyticsPixel$"/>
+            <input type="hidden" name="_method" value="DELETE" />
+            <input type="submit" value="Delete" />
+        </form>
+    </li>
+  }; separator=""$
+</ul>
+
+</div>
+</body>
+</html>
diff --git a/datafiles/templates/Html/package-page.html.st b/datafiles/templates/Html/package-page.html.st
@@ -95,6 +95,11 @@
                 edit package information
               </a>
             </li>
+            <li>
+              <a href="$baseurl$/package/$package.name$/analytics-pixels">
+                edit package analytics pixels
+              </a>
+            </li>
           </ul>
           <p>Candidates</p>
           <ul>
@@ -272,5 +277,10 @@
   <script src="$doc.baseUrl$/quick-jump.min.js" type="text/javascript"></script>
   <script type="text/javascript"> quickNav.init("$doc.baseUrl$", function(toggle) {var t = document.getElementById('quickjump-trigger');if (t) {t.onclick = function(e) { e.preventDefault(); toggle(); };}}); </script>
   $endif$
+
+  $analyticsPixels:{analyticsPixelUrl|
+  <img referrerpolicy="no-referrer-when-downgrade" src="$analyticsPixelUrl$" />
+  }; separator=""$
+
 </body>
 </html>
diff --git a/datafiles/templates/Html/user-analytics-pixels-page.html.st b/datafiles/templates/Html/user-analytics-pixels-page.html.st
@@ -0,0 +1,59 @@
+<!DOCTYPE html>
+<html>
+<head>
+$hackageCssTheme()$
+<title>Analytics pixels for all of $username$'s packages | Hackage</title>
+</head>
+
+<body>
+$hackagePageHeader()$
+
+<div id="content">
+
+<h2>Create a analytics pixel</h2>
+
+<p> 
+  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.
+</p>
+
+<form method="POST" class="box" action="/user/$username$/analytics-pixels">
+    <p>    
+        <label for="package">Package</label>
+        <select name="package">
+        $pkgs:{pkg|
+            <option value="$pkg$">$pkg$</option>      
+        }; separator=""$
+        </select>
+    </p>
+    <p>
+        <label for="analytics-pixel">Analytics pixel URL</label>
+        <input name="analytics-pixel" type="text" />
+    </p>
+    <input type="submit" />
+</form>
+
+<h2>Existing analytics pixels</h2>
+
+$pkgpixels:{pkgpixel|
+<h3><a href="/package/$pkgpixel.0$">$pkgpixel.0$</a></h3>
+<ul>
+  $pkgpixel.1:{analyticsPixel|
+    <li>
+        <form method="POST" action="/user/$username$/analytics-pixels">
+            <label for="analytics-pixel">$analyticsPixel$</label>
+            <input type="hidden" name="package" value="$pkgpixel.0$" />
+            <input type="hidden" name="analytics-pixel" value="$analyticsPixel$"/>
+            <input type="hidden" name="_method" value="DELETE" />
+            <input type="submit" value="Delete" />
+        <form>
+    </li>
+  }; separator=""$
+</ul>
+}; separator=""$
+
+</div>
+</body>
+</html>
diff --git a/datafiles/templates/Users/manage.html.st b/datafiles/templates/Users/manage.html.st
@@ -64,6 +64,9 @@ $tokens:{token|
   <li>
     <a href="/user/$username$/password">Change your password</a>
   </li>
+  <li>
+    <a href="/user/$username$/analytics-pixels">Analytics pixels</a>
+  </li>
 </ul>
 
 </div>

diff --git 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
@@ -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
@@ -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)
-Original file line number
+Diff line change
@@ Expand Up / @@ -64,6 +64,9 @@ $tokens:{token| @@
       <li>
         <a href="/user/$username$/password">Change your password</a>
       </li>
+      <li>
+        <a href="/user/$username$/analytics-pixels">Analytics pixels</a>
+      </li>
     </ul>
     </div>
@@ Expand Down @@