|
| 1 | +{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards #-} |
| 2 | + |
| 3 | +-- | Implements a system to allow users to upvote packages. |
| 4 | +-- |
| 5 | +module Distribution.Server.Features.AnalyticsPixels |
| 6 | + ( AnalyticsPixelsFeature(..) |
| 7 | + , AnalyticsPixel(..) |
| 8 | + , initAnalyticsPixelsFeature |
| 9 | + ) where |
| 10 | + |
| 11 | +import Data.Set (Set) |
| 12 | + |
| 13 | +import Distribution.Server.Features.AnalyticsPixels.State |
| 14 | + |
| 15 | +import Distribution.Server.Framework |
| 16 | +import Distribution.Server.Framework.BackupRestore |
| 17 | + |
| 18 | +import Distribution.Server.Features.Core |
| 19 | +import Distribution.Server.Features.Upload |
| 20 | +import Distribution.Server.Features.Users |
| 21 | + |
| 22 | +import Distribution.Package |
| 23 | + |
| 24 | +-- | Define the prototype for this feature |
| 25 | +data AnalyticsPixelsFeature = AnalyticsPixelsFeature { |
| 26 | + analyticsPixelsFeatureInterface :: HackageFeature, |
| 27 | + analyticsPixelsResource :: Resource, |
| 28 | + userAnalyticsPixelsResource :: Resource, |
| 29 | + |
| 30 | + analyticsPixelAdded :: Hook (PackageName, AnalyticsPixel) (), |
| 31 | + analyticsPixelRemoved :: Hook (PackageName, AnalyticsPixel) (), |
| 32 | + |
| 33 | + -- | Returns all 'AnalyticsPixel's associated with a 'Package'. |
| 34 | + getPackageAnalyticsPixels :: forall m. MonadIO m => PackageName -> m (Set AnalyticsPixel), |
| 35 | + |
| 36 | + -- | Adds a new 'AnalyticsPixel' to a 'Package'. Returns True in case it was added. False in case |
| 37 | + -- it's already existing. |
| 38 | + addPackageAnalyticsPixel :: forall m. MonadIO m => PackageName -> AnalyticsPixel -> m Bool, |
| 39 | + |
| 40 | + -- | Remove a 'AnalyticsPixel' from a 'Package'. |
| 41 | + removePackageAnalyticsPixel :: forall m. MonadIO m => PackageName -> AnalyticsPixel -> m () |
| 42 | +} |
| 43 | + |
| 44 | +-- | Implement the isHackageFeature 'interface' |
| 45 | +instance IsHackageFeature AnalyticsPixelsFeature where |
| 46 | + getFeatureInterface = analyticsPixelsFeatureInterface |
| 47 | + |
| 48 | +-- | Called from Features.hs to initialize this feature |
| 49 | +initAnalyticsPixelsFeature :: ServerEnv |
| 50 | + -> IO ( CoreFeature |
| 51 | + -> UserFeature |
| 52 | + -> UploadFeature |
| 53 | + -> IO AnalyticsPixelsFeature) |
| 54 | +initAnalyticsPixelsFeature env@ServerEnv{serverStateDir} = do |
| 55 | + dbAnalyticsPixelsState <- analyticsPixelsStateComponent serverStateDir |
| 56 | + analyticsPixelAdded <- newHook |
| 57 | + analyticsPixelRemoved <- newHook |
| 58 | + |
| 59 | + return $ \coref@CoreFeature{..} userf@UserFeature{..} uploadf -> do |
| 60 | + let feature = analyticsPixelsFeature env |
| 61 | + dbAnalyticsPixelsState |
| 62 | + coref userf uploadf analyticsPixelAdded analyticsPixelRemoved |
| 63 | + |
| 64 | + return feature |
| 65 | + |
| 66 | +-- | Define the backing store (i.e. database component) |
| 67 | +analyticsPixelsStateComponent :: FilePath -> IO (StateComponent AcidState AnalyticsPixelsState) |
| 68 | +analyticsPixelsStateComponent stateDir = do |
| 69 | + st <- openLocalStateFrom (stateDir </> "db" </> "AnalyticsPixels") initialAnalyticsPixelsState |
| 70 | + return StateComponent { |
| 71 | + stateDesc = "Backing store for AnalyticsPixels feature" |
| 72 | + , stateHandle = st |
| 73 | + , getState = query st GetAnalyticsPixelsState |
| 74 | + , putState = update st . ReplaceAnalyticsPixelsState |
| 75 | + , resetState = analyticsPixelsStateComponent |
| 76 | + , backupState = \_ _ -> [] |
| 77 | + , restoreState = RestoreBackup { |
| 78 | + restoreEntry = error "Unexpected backup entry" |
| 79 | + , restoreFinalize = return initialAnalyticsPixelsState |
| 80 | + } |
| 81 | + } |
| 82 | + |
| 83 | + |
| 84 | +-- | Default constructor for building this feature. |
| 85 | +analyticsPixelsFeature :: ServerEnv |
| 86 | + -> StateComponent AcidState AnalyticsPixelsState |
| 87 | + -> CoreFeature -- To get site package list |
| 88 | + -> UserFeature -- To authenticate users |
| 89 | + -> UploadFeature -- For accessing package maintainers and trustees |
| 90 | + -> Hook (PackageName, AnalyticsPixel) () -- Signals addition of a new AnalyticsPixel |
| 91 | + -> Hook (PackageName, AnalyticsPixel) () -- Signals removeal of a AnalyticsPixel |
| 92 | + -> AnalyticsPixelsFeature |
| 93 | + |
| 94 | +analyticsPixelsFeature ServerEnv{..} |
| 95 | + analyticsPixelsState |
| 96 | + CoreFeature { coreResource = CoreResource{..} } |
| 97 | + UserFeature{..} |
| 98 | + UploadFeature{..} |
| 99 | + analyticsPixelAdded |
| 100 | + analyticsPixelRemoved |
| 101 | + = AnalyticsPixelsFeature {..} |
| 102 | + where |
| 103 | + analyticsPixelsFeatureInterface = (emptyHackageFeature "AnalyticsPixels") { |
| 104 | + featureDesc = "Allow users to attach analytics pixels to their packages", |
| 105 | + featureResources = [analyticsPixelsResource, userAnalyticsPixelsResource] |
| 106 | + , featureState = [abstractAcidStateComponent analyticsPixelsState] |
| 107 | + } |
| 108 | + |
| 109 | + analyticsPixelsResource :: Resource |
| 110 | + analyticsPixelsResource = resourceAt "/package/:package/analytics-pixels.:format" |
| 111 | + |
| 112 | + userAnalyticsPixelsResource :: Resource |
| 113 | + userAnalyticsPixelsResource = resourceAt "/user/:username/analytics-pixels.:format" |
| 114 | + |
| 115 | + getPackageAnalyticsPixels :: MonadIO m => PackageName -> m (Set AnalyticsPixel) |
| 116 | + getPackageAnalyticsPixels name = |
| 117 | + queryState analyticsPixelsState (AnalyticsPixelsForPackage name) |
| 118 | + |
| 119 | + addPackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m Bool |
| 120 | + addPackageAnalyticsPixel name pixel = do |
| 121 | + added <- updateState analyticsPixelsState (AddPackageAnalyticsPixel name pixel) |
| 122 | + when added $ runHook_ analyticsPixelAdded (name, pixel) |
| 123 | + pure added |
| 124 | + |
| 125 | + removePackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m () |
| 126 | + removePackageAnalyticsPixel name pixel = do |
| 127 | + updateState analyticsPixelsState (RemovePackageAnalyticsPixel name pixel) |
| 128 | + runHook_ analyticsPixelRemoved (name, pixel) |
0 commit comments