Extend voting interface to allow score

Soorya Narayan · hvr · commit de47daf8ec6a · 2017-08-21T23:33:35.000+02:00
This extends the package voting mechanism from boolean "stars" to integral "lambdas", and using the statistical method outlined in http://www.evanmiller.org/how-not-to-sort-by-average-rating.html to compute an overall score. This has been factored out of the HSoC work haskell#514 by @sooryan The code has been refactored & cleaned up by Duncan, Gershom and myself. NOTE: Detecting non-anonymous users to display the user's current vote doesn't work yet. This will be fixed at some later point.
diff --git a/Distribution/Server/Features.hs b/Distribution/Server/Features.hs
@@ -257,6 +257,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
                          coreFeature
                          -- [reverse index disabled] reverseFeature
                          downloadFeature
+                         votesFeature
                          tagsFeature
                          versionsFeature
 
diff --git a/Distribution/Server/Features/Html.hs b/Distribution/Server/Features/Html.hs
@@ -463,7 +463,7 @@ mkHtmlCore :: ServerEnv
            -> HtmlCore
 mkHtmlCore ServerEnv{serverBaseURI}
            utilities@HtmlUtilities{..}
-           UserFeature{queryGetUserDb}
+           UserFeature{queryGetUserDb, checkAuthenticated}
            CoreFeature{coreResource}
            VersionsFeature{ versionsResource
                           , queryGetDeprecatedFor
@@ -544,7 +544,10 @@ mkHtmlCore ServerEnv{serverBaseURI}
         distributions <- queryPackageStatus pkgname
         totalDown     <- cmFind pkgname `liftM` totalPackageDownloads
         recentDown    <- cmFind pkgname `liftM` recentPackageDownloads
-        pkgVotesHtml  <- renderVotesHtml pkgname
+        pkgVotes      <- pkgNumVotes pkgname
+        pkgScore      <- fmap (/2) $ pkgNumScore pkgname
+        auth          <- checkAuthenticated
+        userRating    <- case auth of Just (uid,_) -> pkgUserVote pkgname uid; _ -> return Nothing
         mdoctarblob   <- queryDocumentation realpkg
         tags          <- queryTagsForPackage pkgname
         deprs         <- queryGetDeprecatedFor pkgname
@@ -571,7 +574,9 @@ mkHtmlCore ServerEnv{serverBaseURI}
               (classifyVersions prefInfo $ map packageVersion pkgs) infoUrl)
           , "totalDownloads"    $= totalDown
           , "recentDownloads"   $= recentDown
-          , "votesSection"      $= pkgVotesHtml
+          , "votes"             $= pkgVotes
+          , "userRating"        $= userRating
+          , "score"             $= pkgScore
           , "buildStatus"       $= buildStatus
           ] ++
           -- Items not related to IO (mostly pure functions)
diff --git a/Distribution/Server/Features/PackageList.hs b/Distribution/Server/Features/PackageList.hs
@@ -10,6 +10,7 @@ import Distribution.Server.Framework
 
 import Distribution.Server.Features.Core
 -- [reverse index disabled] import Distribution.Server.Features.ReverseDependencies
+import Distribution.Server.Features.Votes
 import Distribution.Server.Features.DownloadCount
 import Distribution.Server.Features.Tags
 import Distribution.Server.Features.PreferredVersions
@@ -89,6 +90,7 @@ initListFeature :: ServerEnv
                 -> IO (CoreFeature
                     -- [reverse index disabled] -> ReverseFeature
                     -> DownloadFeature
+                    -> VotesFeature
                     -> TagsFeature
                     -> VersionsFeature
                     -> IO ListFeature)
@@ -99,17 +101,19 @@ initListFeature _env = do
     return $ \core@CoreFeature{..}
               -- [reverse index disabled] revs
               download
+              votesf@VotesFeature{..}
               tagsf@TagsFeature{..}
               versions@VersionsFeature{..} -> do
 
       let (feature, modifyItem, updateDesc) =
-            listFeature core download tagsf versions
+            listFeature core download votesf tagsf versions
                         itemCache itemUpdate
 
       registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, _) ->
         updateDesc (packageName pkgid)
 
       {- [reverse index disabled]
+              votesf@VotesFeature{..}
       registerHook (reverseUpdateHook revs) $ \mrev -> do
           let pkgs = Map.keys mrev
           forM_ pkgs $ \pkgname -> do
@@ -131,6 +135,7 @@ initListFeature _env = do
 
 listFeature :: CoreFeature
             -> DownloadFeature
+            -> VotesFeature
             -> TagsFeature
             -> VersionsFeature
             -> MemState (Map PackageName PackageItem)
@@ -140,7 +145,10 @@ listFeature :: CoreFeature
                 PackageName -> IO ())
 
 listFeature CoreFeature{..}
-            DownloadFeature{..} TagsFeature{..} VersionsFeature{..}
+            DownloadFeature{..}
+            VotesFeature{..}
+            TagsFeature{..}
+            VersionsFeature{..}
             itemCache itemUpdate
   = (ListFeature{..}, modifyItem, updateDesc)
   where
diff --git a/Distribution/Server/Features/Users.hs b/Distribution/Server/Features/Users.hs
@@ -61,8 +61,11 @@ data UserFeature = UserFeature {
     guardAuthorised_   :: [PrivilegeCondition] -> ServerPartE (),
     -- | Require any of a set of privileges, giving the id of the current user.
     guardAuthorised    :: [PrivilegeCondition] -> ServerPartE UserId,
+    guardAuthorised'    :: [PrivilegeCondition] -> ServerPartE Bool,
     -- | Require being logged in, giving the id of the current user.
     guardAuthenticated :: ServerPartE UserId,
+    -- | Gets the authentication if it exists.
+    checkAuthenticated :: ServerPartE (Maybe (UserId, UserInfo)),
     -- | A hook to override the default authentication error in particular
     -- circumstances.
     authFailHook       :: Hook Auth.AuthError (Maybe ErrorResponse),
@@ -389,6 +392,13 @@ userFeature templates usersState adminsState
         Auth.guardPriviledged users uid privconds
         return uid
 
+    guardAuthorised' :: [PrivilegeCondition] -> ServerPartE Bool
+    guardAuthorised' privconds = do
+        users <- queryGetUserDb
+        uid   <- guardAuthenticatedWithErrHook users
+        valid <- Auth.checkPriviledged users uid privconds
+        return valid
+
     -- Simply check if the user is authenticated as some user, without any
     -- check that they have any particular priveledges. Only useful as a
     -- building block.
@@ -412,6 +422,11 @@ userFeature templates usersState adminsState
           overrideResponse <- msum <$> runHook authFailHook err
           throwError (fromMaybe defaultResponse overrideResponse)
 
+    -- Check if there is an authenticated userid, and return info, if so.
+    checkAuthenticated :: ServerPartE (Maybe (UserId, UserInfo))
+    checkAuthenticated = do
+        users <- queryGetUserDb
+        either (const Nothing) Just `fmap` Auth.checkAuthenticated Auth.hackageRealm users
 
     -- | Resources representing the collection of known users.
     --
diff --git a/Distribution/Server/Features/Votes.hs b/Distribution/Server/Features/Votes.hs
@@ -16,7 +16,6 @@ import Distribution.Server.Framework.BackupRestore
 import Distribution.Server.Features.Core
 import Distribution.Server.Features.Users
 import Distribution.Server.Users.Types (UserId(..))
-import Distribution.Server.Users.UserIdSet as UserIdSet
 
 import Distribution.Package
 import Distribution.Text
@@ -26,6 +25,7 @@ import qualified Data.Map as Map
 import qualified Data.Text as T
 import qualified Data.HashMap.Strict as HashMap
 
+import Control.Monad (when)
 import Control.Arrow (first)
 import qualified Text.XHtml.Strict as X
 
@@ -35,6 +35,9 @@ data VotesFeature = VotesFeature {
     votesFeatureInterface :: HackageFeature
   , didUserVote             :: forall m. MonadIO m => PackageName -> UserId -> m Bool
   , pkgNumVotes             :: forall m. MonadIO m => PackageName -> m Int
+  , pkgNumScore             :: forall m. MonadIO m => PackageName -> m Float
+  , pkgUserVote             :: forall m. MonadIO m => PackageName -> UserId -> m (Maybe Score)
+  , votesUpdated            :: Hook (PackageName, Float) ()
   , renderVotesHtml         :: PackageName -> ServerPartE X.Html
 }
 
@@ -49,11 +52,13 @@ initVotesFeature :: ServerEnv
                       -> IO VotesFeature)
 initVotesFeature env@ServerEnv{serverStateDir} = do
   dbVotesState      <- votesStateComponent serverStateDir
+  updateVotes       <- newHook
 
   return $ \coref@CoreFeature{..} userf@UserFeature{..} -> do
     let feature = votesFeature env
                   dbVotesState
-                  coref userf
+                  coref userf updateVotes
+
     return feature
 
 -- | Define the backing store (i.e. database component)
@@ -79,12 +84,14 @@ votesFeature ::  ServerEnv
              -> StateComponent AcidState VotesState
              -> CoreFeature                    -- To get site package list
              -> UserFeature                    -- To authenticate users
+             -> Hook (PackageName, Float) ()
              -> VotesFeature
 
 votesFeature  ServerEnv{..}
               votesState
               CoreFeature { coreResource = CoreResource{..} }
               UserFeature{..}
+              votesUpdated
   = VotesFeature{..}
   where
     votesFeatureInterface   = (emptyHackageFeature "votes") {
@@ -111,7 +118,7 @@ votesFeature  ServerEnv{..}
                         , (DELETE,  "Remove a user's vote from this package")
                         ]
     , resourceGet     = [("json", servePackageNumVotesGet)]
-    , resourcePut     = [("",     servePackageVotePut)]
+    , resourcePost    = [("",     servePackageVotePut)]
     , resourceDelete  = [("",     servePackageVoteDelete)]
     }
 
@@ -123,8 +130,8 @@ votesFeature  ServerEnv{..}
       cacheControlWithoutETag [Public, maxAgeMinutes 10]
       votesMap <- queryState votesState GetAllPackageVoteSets
       ok . toResponse $ objectL
-        [ (display pkgname, toJSON (UserIdSet.size voterset))
-        | (pkgname, voterset) <- Map.toList votesMap ]
+        [ (display pkgname, toJSON (votesScore pkgMap))
+        | (pkgname, pkgMap) <- Map.toList votesMap ]
 
     -- Get the number of votes a package has. If the package
     -- has never been voted for, returns 0.
@@ -133,7 +140,7 @@ votesFeature  ServerEnv{..}
       pkgname <- packageInPath dpath
       guardValidPackageName pkgname
       cacheControlWithoutETag [Public, maxAgeMinutes 10]
-      voteCount <- queryState votesState (GetPackageVoteCount pkgname)
+      voteCount <- pkgNumVotes pkgname
       let obj = objectL
                   [ ("packageName", string $ display pkgname)
                   , ("numVotes",    toJSON voteCount)
@@ -146,12 +153,17 @@ votesFeature  ServerEnv{..}
       uid     <- guardAuthorised [AnyKnownUser]
       pkgname <- packageInPath dpath
       guardValidPackageName pkgname
-
-      success <- updateState votesState (AddVote pkgname uid)
-      if success
-        then ok . toResponse $ Render.voteConfirmationPage pkgname
-                                 "Package voted for successfully"
-        else ok . toResponse $ Render.alreadyVotedPage pkgname
+      scoreStr <- look "score"
+      -- very simple input validation; we accept only three literals
+      score <- case scoreStr of
+        "1" -> pure 1
+        "2" -> pure 2
+        "3" -> pure 3
+        _   -> fail "invalid score value received"
+      _ <- updateState votesState (AddVote pkgname uid score)
+      pkgScore <- pkgNumScore pkgname
+      runHook_ votesUpdated (pkgname, pkgScore)
+      ok . toResponse $ "Package voted for successfully"
 
     -- Removes a user's vote from a package. If the user has not voted
     -- for this package, does nothing.
@@ -162,11 +174,12 @@ votesFeature  ServerEnv{..}
       guardValidPackageName pkgname
 
       success <- updateState votesState (RemoveVote pkgname uid)
+      pkgScore <- pkgNumScore pkgname
+      when success $ runHook_ votesUpdated (pkgname, pkgScore)
 
       let responseMsg | success   = "Package vote removed successfully."
                       | otherwise = "User has not voted for this package."
-      ok . toResponse $ Render.voteConfirmationPage
-        pkgname responseMsg
+      ok . toResponse $ responseMsg
 
     -- Helper Functions (Used outside of responses, e.g. by other features.)
 
@@ -181,6 +194,14 @@ votesFeature  ServerEnv{..}
     pkgNumVotes pkgname =
       queryState votesState (GetPackageVoteCount pkgname)
 
+    pkgNumScore :: MonadIO m => PackageName -> m Float
+    pkgNumScore pkgname =
+      queryState votesState (GetPackageVoteScore pkgname)
+
+    pkgUserVote :: MonadIO m => PackageName -> UserId -> m (Maybe Score)
+    pkgUserVote pkgname uid =
+      queryState votesState (GetPackageUserVote pkgname uid)
+
     -- Renders the HTML for the "Votes:" section on package pages.
     renderVotesHtml :: PackageName -> ServerPartE X.Html
     renderVotesHtml pkgname = do
diff --git a/Distribution/Server/Features/Votes/State.hs b/Distribution/Server/Features/Votes/State.hs
@@ -15,47 +15,70 @@ import Distribution.Server.Users.State ()
 import Data.Typeable
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.List
 import Data.Maybe (fromMaybe)
-
+import Control.Arrow ((&&&))
 import Data.Acid     (Query, Update, makeAcidic)
-import Data.SafeCopy (base, deriveSafeCopy)
+import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..))
 
 import qualified Control.Monad.State as State
 import Control.Monad.Reader.Class (ask)
 
+type Score = Int
+
+newtype VotesState_v0 = VotesState_v0 { votesMap :: Map PackageName UserIdSet }
 
-newtype VotesState = VotesState { votesMap :: Map PackageName UserIdSet }
+newtype VotesState = VotesState (Map PackageName (Map UserId Score))
   deriving (Show, Eq, Typeable, MemSize)
 
-$(deriveSafeCopy 0 'base ''VotesState)
+-- SafeCopy instances
+deriveSafeCopy 1 'extension ''VotesState
+
+deriveSafeCopy 0 'base      ''VotesState_v0
+
+instance Migrate VotesState where
+    type MigrateFrom VotesState = VotesState_v0
+
+    migrate (VotesState_v0 m) = VotesState (Map.map go m)
+      where
+        go :: UserIdSet -> Map UserId Score
+        go = Map.fromList . map (\x->(x,3)) . UserIdSet.toList
+
+--
 
 initialVotesState :: VotesState
 initialVotesState = VotesState Map.empty
 
 -- helper function
-userVotedForPackage :: PackageName -> UserId -> Map PackageName UserIdSet -> Bool
+userVotedForPackage :: PackageName -> UserId -> Map PackageName (Map UserId Score) -> Bool
 userVotedForPackage pkgname uid votes =
     case Map.lookup pkgname votes of
       Nothing     -> False
-      Just uidset -> UserIdSet.member uid uidset
+      Just m -> case Map.lookup uid m of
+                  Nothing -> False
+                  Just _ -> True
+
+-- Using La Placian rule of succession to calculate scoring
+votesScore :: Map UserId Score -> Float
+votesScore m =
+    let grouping = map (head &&& length) . group . sort . Map.elems $ m
+        score =  fromIntegral (sum $ map (uncurry (*)) grouping) / fromIntegral (4 + foldr (\(_,b) -> (+b) ) 0 grouping)
+    in score*10
 
 -- All the acid state transactions
 
-addVote :: PackageName -> UserId -> Update VotesState Bool
-addVote pkgname uid = do
+addVote :: PackageName -> UserId -> Score -> Update VotesState Float
+addVote pkgname uid score = do
     VotesState votes <- State.get
-    if userVotedForPackage pkgname uid votes
-      then return False
-      else do let votes' = Map.alter insert pkgname votes
-                  insert = Just . UserIdSet.insert uid . fromMaybe UserIdSet.empty
-              State.put $! VotesState votes'
-              return True
+    let votes' = Map.insertWith Map.union pkgname (Map.singleton uid score) votes
+    State.put $! VotesState votes'
+    return $ votesScore $ fromMaybe Map.empty $ Map.lookup pkgname votes'
 
 removeVote :: PackageName -> UserId -> Update VotesState Bool
 removeVote pkgname uid = do
     VotesState votes <- State.get
     if userVotedForPackage pkgname uid votes
-       then do let votes' = Map.adjust (UserIdSet.delete uid) pkgname votes
+       then do let votes' = Map.adjust (Map.delete uid) pkgname votes
                State.put $! VotesState votes'
                return True
        else return False
@@ -65,14 +88,26 @@ getPackageVoteCount pkgname = do
     VotesState votes <- ask
     case Map.lookup pkgname votes of
       Nothing     -> return 0
-      Just uidset -> return $! UserIdSet.size uidset
+      Just m      -> return $! Map.size m
+
+getPackageVoteScore :: PackageName -> Query VotesState Float
+getPackageVoteScore pkgname = do
+    VotesState votes <- ask
+    case Map.lookup pkgname votes of
+      Nothing     -> return 0
+      Just m      -> return $! votesScore m
 
 getPackageUserVoted :: PackageName -> UserId -> Query VotesState Bool
 getPackageUserVoted pkgname uid = do
     VotesState votes <- ask
     return $! userVotedForPackage pkgname uid votes
 
-getAllPackageVoteSets :: Query VotesState (Map PackageName UserIdSet)
+getPackageUserVote :: PackageName -> UserId -> Query VotesState (Maybe Score)
+getPackageUserVote pkgname uid = do
+    VotesState votes <- ask
+    return $! Map.lookup uid =<< Map.lookup pkgname votes
+
+getAllPackageVoteSets :: Query VotesState (Map PackageName (Map UserId Score))
 getAllPackageVoteSets = do
     VotesState votes <- ask
     return votes
@@ -91,7 +126,9 @@ makeAcidic
   [ 'addVote
   , 'removeVote
   , 'getPackageVoteCount
+  , 'getPackageVoteScore
   , 'getPackageUserVoted
+  , 'getPackageUserVote
   , 'getAllPackageVoteSets
   , 'getVotesState
   , 'replaceVotesState
diff --git a/datafiles/templates/Html/package-page.html.st b/datafiles/templates/Html/package-page.html.st
diff --git a/datafiles/templates/packagePageAssets.st b/datafiles/templates/packagePageAssets.st
