{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable, NamedFieldPuns #-}
module Distribution.Server.Features.TarIndexCache.State (
    TarIndexCache(..)
  , initialTarIndexCache
  , GetTarIndexCache(GetTarIndexCache)
  , ReplaceTarIndexCache(ReplaceTarIndexCache)
  , FindTarIndex(FindTarIndex)
  , SetTarIndex(SetTarIndex)
  ) where

-- TODO: use strict map? (Can we rely on containers >= 0.5?)

import Data.Typeable (Typeable)
import Control.Monad.Reader (ask, asks)
import Control.Monad.State (put, modify)
import Data.Map (Map)
import qualified Data.Map as Map

import Data.Acid (Query, Update, makeAcidic)
import Data.SafeCopy (base, deriveSafeCopy)

import Distribution.Server.Framework.BlobStorage
import Distribution.Server.Framework.MemSize

data TarIndexCache = TarIndexCache {
    tarIndexCacheMap :: Map BlobId BlobId
  }
  deriving (Eq, Show, Typeable)

$(deriveSafeCopy 0 'base ''TarIndexCache)

instance MemSize TarIndexCache where
  memSize st = 2 + memSize (tarIndexCacheMap st)

initialTarIndexCache :: TarIndexCache
initialTarIndexCache = TarIndexCache Map.empty

getTarIndexCache :: Query TarIndexCache TarIndexCache
getTarIndexCache = ask

replaceTarIndexCache :: TarIndexCache -> Update TarIndexCache ()
replaceTarIndexCache = put

getTarIndexCacheMap :: Query TarIndexCache (Map BlobId BlobId)
getTarIndexCacheMap = asks tarIndexCacheMap

modifyTarIndexCacheMap :: (Map BlobId BlobId -> Map BlobId BlobId)
                       -> Update TarIndexCache ()
modifyTarIndexCacheMap f = modify $ \st@TarIndexCache{tarIndexCacheMap} ->
                             st { tarIndexCacheMap = f tarIndexCacheMap }

findTarIndex :: BlobId -> Query TarIndexCache (Maybe BlobId)
findTarIndex blobId = Map.lookup blobId <$> getTarIndexCacheMap

setTarIndex :: BlobId -> BlobId -> Update TarIndexCache ()
setTarIndex tar index = modifyTarIndexCacheMap (Map.insert tar index)

makeAcidic ''TarIndexCache [
    'getTarIndexCache
  , 'replaceTarIndexCache
  , 'findTarIndex
  , 'setTarIndex
  ]
