Feature.hs

-- | This module defines a plugin interface for hackage features.
--
{-# LANGUAGE ExistentialQuantification, RankNTypes, NoMonomorphismRestriction, RecordWildCards #-}
module Distribution.Server.Framework.Feature
  ( -- * Main datatypes
    HackageFeature(..)
  , IsHackageFeature(..)
  , emptyHackageFeature
    -- * State components
  , StateComponent(..)
  , OnDiskState(..)
  , AbstractStateComponent(..)
  , abstractAcidStateComponent
  , abstractAcidStateComponent'
  , abstractOnDiskStateComponent
  , queryState
  , updateState
  , compareState
    -- * Cache components
  , CacheComponent(..)
    -- * Re-exports
  , BlobStorage
  ) where

import Distribution.Server.Framework.BackupRestore (RestoreBackup(..), AbstractRestoreBackup(..), BackupEntry, abstractRestoreBackup)
import Distribution.Server.Framework.Resource      (Resource, ServerErrorResponse)
import Distribution.Server.Framework.BlobStorage   (BlobStorage)
import Distribution.Server.Framework.MemSize

import Data.Monoid
import Control.Monad (liftM, liftM2)
import Control.Monad.Trans (MonadIO)
import Data.Acid
import Data.Acid.Advanced

-- | We compose the overall hackage server featureset from a bunch of these
-- features. The intention is to make the hackage server reasonably modular
-- by allowing distinct features to be designed independently.
--
-- Features can hold their own canonical state and caches, and can provide a
-- set of resources.
--
data HackageFeature = HackageFeature {
    featureName        :: String
  , featureDesc        :: String
  , featureResources   :: [Resource]
  , featureErrHandlers :: [(String, ServerErrorResponse)]

  , featurePostInit    :: IO ()

  , featureState       :: [AbstractStateComponent]
  , featureCaches      :: [CacheComponent]
  }

-- | A feature with no state and no resources, just a name.
--
-- Define your new feature by extending this one, e.g.
--
-- > myHackageFeature = emptyHackageFeature "wizzo" {
-- >     featureResources = [wizzo]
-- >   }
--
emptyHackageFeature :: String -> HackageFeature
emptyHackageFeature name = HackageFeature {
    featureName      = name,
    featureDesc      = "",
    featureResources = [],
    featureErrHandlers= [],

    featurePostInit  = return (),

    featureState     = error $ "'featureState' not defined for feature '" ++ name ++ "'",
    featureCaches    = []
  }

class IsHackageFeature feature where
  getFeatureInterface :: feature -> HackageFeature

--------------------------------------------------------------------------------
-- State components                                                           --
--------------------------------------------------------------------------------

-- | A state component encapsulates (part of) a feature's state
data StateComponent f st = StateComponent {
    -- | Human readable description of the state component
    stateDesc    :: String
    -- | Handle required to access the state
  , stateHandle  :: f st
    -- | Return the entire state
  , getState     :: IO st
    -- | Overwrite the state
  , putState     :: st -> IO ()
    -- | (Pure) backup function
  , backupState  :: st -> [BackupEntry]
    -- | (Pure) backup restore
  , restoreState :: RestoreBackup st
    -- | Clone the state component in the given state directory
  , resetState   :: FilePath -> IO (StateComponent f st)
  }

data OnDiskState a = OnDiskState

-- | 'AbstractStateComponent' abstracts away from a particular type of
-- 'StateComponent'
data AbstractStateComponent = AbstractStateComponent {
    abstractStateDesc       :: String
  , abstractStateCheckpoint :: IO ()
  , abstractStateClose      :: IO ()
  , abstractStateBackup     :: IO [BackupEntry]
  , abstractStateRestore    :: AbstractRestoreBackup
  , abstractStateNewEmpty   :: FilePath -> IO (AbstractStateComponent, IO [String])
  , abstractStateSize       :: IO Int
  }

compareState :: (Eq st, Show st) => st -> st -> [String]
compareState old new =
    if old /= new
     then ["Internal state mismatch:\n" ++ difference (show old) (show new)]
     else []
  where
    difference old_str new_str
        -- = indent 2 old_str ++ "Versus:\n" ++ indent 2 new_str
        = "After " ++ show (length common)   ++ " chars, in context:\n" ++
            indent 2 (trunc_last 80 common)  ++ "\nOld data was:\n" ++
            indent 2 (trunc 80 old_str_tail) ++ "\nVersus new data:\n" ++
            indent 2 (trunc 80 new_str_tail)
      where (common, old_str_tail, new_str_tail) = dropCommonPrefix [] old_str new_str

    indent n = unlines . map (replicate n ' ' ++) . lines

    trunc n xs | null zs   = ys
               | otherwise = ys ++ "..."
      where (ys, zs) = splitAt n xs

    trunc_last n xs | null ys_rev = reverse zs_rev
                    | otherwise   = "..." ++ reverse zs_rev
      where (zs_rev, ys_rev) = splitAt n (reverse xs)

    dropCommonPrefix common (x:xs) (y:ys) | x == y = dropCommonPrefix (x:common) xs ys
    dropCommonPrefix common xs ys = (reverse common, xs, ys)

abstractAcidStateComponent :: (Eq st, Show st, MemSize st)
                           => StateComponent AcidState st -> AbstractStateComponent
abstractAcidStateComponent = abstractAcidStateComponent' compareState

abstractAcidStateComponent' :: MemSize st
                            => (st -> st -> [String])
                            -> StateComponent AcidState st -> AbstractStateComponent
abstractAcidStateComponent' cmp st = AbstractStateComponent {
    abstractStateDesc       = stateDesc st
  , abstractStateCheckpoint = createCheckpoint (stateHandle st)
  , abstractStateClose      = closeAcidState (stateHandle st)
  , abstractStateBackup     = liftM (backupState st) (getState st)
  , abstractStateRestore    = abstractRestoreBackup (putState st) (restoreState st)
  , abstractStateNewEmpty   = \stateDir -> do
                                st' <- resetState st stateDir
                                let cmpSt = liftM2 cmp (getState st) (getState st')
                                return (abstractAcidStateComponent' cmp st', cmpSt)
  , abstractStateSize       = liftM memSize (getState st)
  }

abstractOnDiskStateComponent :: (Eq st, Show st) => StateComponent OnDiskState st -> AbstractStateComponent
abstractOnDiskStateComponent st = AbstractStateComponent {
    abstractStateDesc       = stateDesc st
  , abstractStateCheckpoint = return ()
  , abstractStateClose      = return ()
  , abstractStateBackup     = liftM (backupState st) (getState st)
  , abstractStateRestore    = abstractRestoreBackup (putState st) (restoreState st)
  , abstractStateNewEmpty   = \stateDir -> do
                                st' <- resetState st stateDir
                                let cmpSt = liftM2 compareState (getState st) (getState st')
                                return (abstractOnDiskStateComponent st', cmpSt)
  , abstractStateSize       = return 0
  }

instance Monoid AbstractStateComponent where
  mempty = AbstractStateComponent {
      abstractStateDesc       = ""
    , abstractStateCheckpoint = return ()
    , abstractStateClose      = return ()
    , abstractStateBackup     = return []
    , abstractStateRestore    = mempty
    , abstractStateNewEmpty   = \_stateDir -> return (mempty, return [])
    , abstractStateSize       = return 0
    }
  a `mappend` b = AbstractStateComponent {
      abstractStateDesc       = abstractStateDesc a ++ "\n" ++ abstractStateDesc b
    , abstractStateCheckpoint = abstractStateCheckpoint a >> abstractStateCheckpoint b
    , abstractStateClose      = abstractStateClose a >> abstractStateClose b
    , abstractStateBackup     = liftM2 (++) (abstractStateBackup a) (abstractStateBackup b)
    , abstractStateRestore    = abstractStateRestore a `mappend` abstractStateRestore b
    , abstractStateNewEmpty   = \stateDir -> do
                                 (a', cmpA) <- abstractStateNewEmpty a stateDir
                                 (b', cmpB) <- abstractStateNewEmpty b stateDir
                                 return (a' `mappend` b', liftM2 (++) cmpA cmpB)
    , abstractStateSize       = liftM2 (+) (abstractStateSize a)
                                           (abstractStateSize b)
    }

queryState :: (MonadIO m, QueryEvent event)
           => StateComponent AcidState (EventState event)
           -> event
           -> m (EventResult event)
queryState = query' . stateHandle

updateState :: (MonadIO m, UpdateEvent event)
            => StateComponent AcidState (EventState event)
            -> event
            -> m (EventResult event)
updateState = update' . stateHandle


--------------------------------------------------------------------------------
-- Cache components                                                           --
--------------------------------------------------------------------------------

-- | A cache component encapsulates a cache, managed by a feature
data CacheComponent = CacheComponent {
    -- | Human readable description of the state component
    cacheDesc :: String

    -- | Get the current memory residency of the cache
  , getCacheMemSize :: IO Int
  }