hackage-server-0.4: Distribution/Server/Features/RecentPackages.hs

{-# LANGUAGE DoRec, RankNTypes, NamedFieldPuns, RecordWildCards #-}
module Distribution.Server.Features.RecentPackages (
    RecentPackagesFeature(..),
    RecentPackagesResource(..),
    initRecentPackagesFeature,
  ) where

import Distribution.Server.Framework

import Distribution.Server.Features.Core
import Distribution.Server.Features.Users
import Distribution.Server.Features.PackageContents (PackageContentsFeature(..))

import Distribution.Server.Packages.Types
import Distribution.Server.Packages.Render

import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
import qualified Distribution.Server.Framework.ResponseContentTypes as Resource

import Data.Time.Clock (getCurrentTime)
import Data.List (sortBy)
import Data.Ord (comparing)


-- the goal is to have the HTML modules import /this/ one, not the other way around
import qualified Distribution.Server.Pages.Recent as Pages

data RecentPackagesFeature = RecentPackagesFeature {
    recentPackagesFeatureInterface :: HackageFeature,
    recentPackagesResource :: RecentPackagesResource,

    -- necessary information for the representation of a package resource
    packageRender :: PkgInfo -> IO PackageRender
    -- other informational hooks: perhaps a simplified CondTree so a browser script can dynamically change the package page based on flags
}

instance IsHackageFeature RecentPackagesFeature where
    getFeatureInterface = recentPackagesFeatureInterface

data RecentPackagesResource = RecentPackagesResource {
    -- replace with log resource
    recentPackages :: Resource
}

initRecentPackagesFeature :: ServerEnv
                          -> UserFeature
                          -> CoreFeature
                          -> PackageContentsFeature
                          -> IO RecentPackagesFeature
initRecentPackagesFeature env@ServerEnv{serverCacheDelay, serverVerbosity = verbosity}
                          user
                          core@CoreFeature{packageChangeHook}
                          packageContents = do
    loginfo verbosity "Initialising recentPackages feature, start"

    -- recent caches. in lieu of an ActionLog
    -- TODO: perhaps a hook, recentUpdated :: HookList ([PkgInfo] -> IO ())
    rec let (feature, updateRecentCache) =
              recentPackagesFeature env user core packageContents
                                    cacheRecent

        cacheRecent <- newAsyncCacheNF updateRecentCache
                         defaultAsyncCachePolicy {
                           asyncCacheName = "recent uploads (html,rss)",
                           asyncCacheUpdateDelay  = serverCacheDelay,
                           asyncCacheSyncInit     = False,
                           asyncCacheLogVerbosity = verbosity
                         }

    registerHookJust packageChangeHook isPackageChangeAny $ \_ ->
      prodAsyncCache cacheRecent

    loginfo verbosity "Initialising recentPackages feature, end"
    return feature


recentPackagesFeature :: ServerEnv
                      -> UserFeature
                      -> CoreFeature
                      -> PackageContentsFeature
                      -> AsyncCache (Response, Response)
                      -> (RecentPackagesFeature, IO (Response, Response))

recentPackagesFeature env
                      UserFeature{..}
                      CoreFeature{..}
                      PackageContentsFeature{packageChangeLog}
                      cacheRecent
  = (RecentPackagesFeature{..}, updateRecentCache)
  where
    recentPackagesFeatureInterface = (emptyHackageFeature "recentPackages") {
        featureResources = map ($recentPackagesResource) [recentPackages]
      , featureState     = []
      , featureCaches    = [
            CacheComponent {
              cacheDesc       = "recents packages page (html, rss)",
              getCacheMemSize = memSize <$> readAsyncCache cacheRecent
            }
          ]
      , featurePostInit = syncAsyncCache cacheRecent
      }

    recentPackagesResource = RecentPackagesResource {
        recentPackages = (resourceAt "/recent.:format") {
            resourceGet = [
                ("html", const $ liftM fst $ readAsyncCache cacheRecent)
              , ("rss",  const $ liftM snd $ readAsyncCache cacheRecent)
              ]
          }
      }

    packageRender pkg = do
      users <- queryGetUserDb
      changeLog <- packageChangeLog pkg
      let showChangeLogLink = case changeLog of Right _ -> True ; _ -> False
      doPackageRender users pkg showChangeLogLink

    updateRecentCache = do
        -- TODO: move the html version to the HTML feature
        pkgIndex <- queryGetPackageIndex
        users <- queryGetUserDb
        now   <- getCurrentTime
        let recentChanges = reverse $ sortBy (comparing pkgUploadTime) (PackageIndex.allPackages pkgIndex)
            xmlRepresentation = toResponse $ Resource.XHtml $ Pages.recentPage users recentChanges
            rssRepresentation = toResponse $ Pages.recentFeed users (serverBaseURI env) now recentChanges
        return (xmlRepresentation, rssRepresentation)

{-
data SimpleCondTree = SimpleCondNode [Dependency] [(Condition ConfVar, SimpleCondTree, SimpleCondTree)]
                    | SimpleCondLeaf
    deriving (Show, Eq)

doMakeCondTree :: GenericPackageDescription -> [(String, SimpleCondTree)]
doMakeCondTree desc = map (\lib -> ("library", makeCondTree lib)) (maybeToList $ condLibrary desc)
                   ++ map (\(exec, tree) -> (exec, makeCondTree tree)) (condExecutables desc)
  where
    makeCondTree (CondNode _ deps comps) = case deps of
        [] -> SimpleCondLeaf
        _  -> SimpleCondNode deps $ map makeCondComponents comps
    makeCondComponents (cond, tree, mtree) = (cond, makeCondTree tree, maybe SimpleCondLeaf makeCondTree mtree)
-}