module Bitcoin.BlockChain.Cache where
import Control.Concurrent
import System.IO.Unsafe as Unsafe
import Data.IntMap (IntMap) ; import qualified Data.IntMap as IntMap
import Bitcoin.Misc.BiMap (BiMap ) ; import qualified Bitcoin.Misc.BiMap as BiMap
import Bitcoin.BlockChain.Base
import Bitcoin.BlockChain.Tx
import Bitcoin.BlockChain.Load
import Bitcoin.Script.Base
data BlockCache script = BlockCache
{ _blkMap :: !(IntMap (Block (Tx script script)))
, _locMap :: !(BiMap BlockLocation Int)
}
theBlockCacheSize :: Int
theBlockCacheSize = 128
theBlockCacheCompactLimit :: Int
theBlockCacheCompactLimit = 1024
theBlockCache :: MVar (BlockCache RawScript)
theBlockCache = Unsafe.unsafePerformIO $ newMVar (BlockCache IntMap.empty BiMap.empty)
compactTheBlockCache :: IO ()
compactTheBlockCache = do
BlockCache blks locs <- takeMVar theBlockCache
let oldlocs = BiMap.toList locs
let locs' = BiMap.fromList $ zipWith (\(loc,j) i -> (loc,i)) oldlocs [1..]
translate = IntMap.fromList $ zipWith (\(loc,j) i -> (j ,i)) oldlocs [1..]
f (!j,blk) = case IntMap.lookup j translate of
Just !i -> (i,blk)
Nothing -> error "compactTheBlockCache: fatal error, shouldn't happen"
blks' = IntMap.fromList $ map f $ IntMap.toList blks
putMVar theBlockCache $! (BlockCache blks' locs')
loadBlockCached :: BlockLocation -> IO (Block (Tx RawScript RawScript))
loadBlockCached location = do
orig@(BlockCache blks locs) <- takeMVar theBlockCache
let n = IntMap.size blks
lmax = if n==0 then 0 else fst (IntMap.findMax blks)
l' = lmax+1
if n >= theBlockCacheCompactLimit
then do
putMVar theBlockCache $! orig
compactTheBlockCache
loadBlockCached location
else case BiMap.lookup location locs of
Just i -> case IntMap.lookup i blks of
Just block -> do
putStrLn $ "block at " ++ show location ++ " was in the cache at pos " ++ show i ++ " (max = " ++ show lmax ++ " ; size = " ++ show n ++ ")"
let blks' = IntMap.insert l' block $ IntMap.delete i $ blks
locs' = BiMap.insert location l' locs
putMVar theBlockCache $! (BlockCache blks' locs')
return block
Nothing -> do
let locs' = BiMap.delete location locs
putMVar theBlockCache $! (BlockCache blks locs')
loadBlockCached location
Nothing -> do
putStrLn $ "block at " ++ show location ++ " was not in the cache"
block <- loadBlockAt location
if n < theBlockCacheSize
then do
let blks' = IntMap.insert l' block blks
locs' = BiMap.insert location l' locs
putMVar theBlockCache $! BlockCache blks' locs'
return block
else
case IntMap.minViewWithKey blks of
Nothing -> error "loadBlockCached: fatal error, shouldn't happen; #1"
Just ((i,_),rest) -> do
let blks' = IntMap.insert l' block rest
locs' = BiMap.insert location l' $ BiMap.deleteRev i $ locs
putMVar theBlockCache $! (BlockCache blks' locs')
return block