diff --git a/Data/TCache.hs b/Data/TCache.hs new file mode 100644 --- /dev/null +++ b/Data/TCache.hs @@ -0,0 +1,404 @@ +{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-} + + +------------------------------------------------- +-- A Transactional data cache with configurable persitence +-- (Something like a little Java Hybernate or Rails for Rubi) +-- Author: Alberto Gómez Corona Nov 2006 +-- Language: Haskell +-- Version: 0.5 +-- Terms of use: See LICENSE +-- 2008: +-- some bugs fixed +-- 10/15/2007 : changes +-- Default writeResource and delResource for persistence in files +-- (only keyResource must be defined by the user if use defaults) +-- Coherent Inserts and deletes +-- Reduced the number of accesses to the hashtable +-- hashtable access put outside of the transaction block (takeBlocks) +-- faster re-executions in case of roll-back + +------------------------------------------------ + + +module Data.TCache ( + + IResource(..) -- class interface to be implemented for the object by the user + +,Operation (Insert,Delete) -- data definition used to communicate object Inserts and Deletes to the cache + +,Cache -- :: IORef (Ht a,Int, Integer) --The cache definition + +,getTVars -- :: (IResource a)=> [a] -- the list of resources to be retrieved + -- -> IO [Maybe (TVar a)] -- The Transactional variables (See Data.TVar documentation) + +,withResourcesID -- :: (IResource a)=> [a]-> --list of resources to be extracted for the user function + -- ([Maybe a]->[Operation a]) --user function that get the retrieved resources + -- ->IO () --and return a list of objects to be inserted/modified or deleted + +,withResources -- :: (IResource a)=> [a] --list of resources to be retrieve + -- ->([Maybe a]->[a]) ----function that get the retrieved resources + -- ->IO () --and return a list of objects to be inserted/modified + +,withResource -- :: (IResource a)=> a --same as withResources , but for one only object + -- ->([Maybe a]->a) -- + -- ->IO () -- + +,getResources -- :: (IResource a)=>[a] --resources [a] are read from cache and returned + -- -> IO [Maybe a] + +,getResource -- :: :: (IResource a)=>a --to retrieve one object instead of a list + -- -> IO [Maybe a] + +,deleteResources -- :: (IResource a)=>[a]-> IO() -- delete the list of resources from cache and from persistent storage +,deleteResource -- :: (IResource a)=>a-> IO() -- delete the resource from cache and from persistent storage +--cache handling + +,refcache -- :: Cache a --the reference to the cache (see data definition below) + +,syncCache -- :: (IResource a) =>Cache a -> IO() --force the atomic write of all the cache objects into permanent storage + --useful for termination + +--start the thread that clean and writes on the persistent storage trough syncCache +,clearSyncCacheProc -- :: (IResource a) =>Cache a --The cache reference + -- -> Int --number of seconds betwen checks + -- -> (Integer->Integer-> Bool) --The user-defined check-for-cleanup-from-cache for each object + --(when True, the object is removed from cache) + -- -> Int --The max number of objects in the cache, if more, the cleanup start + -- -> >IO ThreadId --Identifier of the thread created + +-- the default check procedure +,defaultCheck -- :: Integer --last access time for a given object + -- ->Integer --last cache syncronization (with the persisten storage) + -- ->Bool --return true for all the elems not accesed since + --half the time between now and the last sync + +-- auxiliary +,readFileStrict -- :: String -> IO String -- Strict file read, needed for the default file persistence + + +) +where + +import GHC.Conc +import Control.Exception as Exception +import Control.Concurrent +import Data.HashTable as H +import Data.IORef +import System.IO +import System.IO.Unsafe +import System.IO.Error +import System.Time +import Data.Maybe(catMaybes,mapMaybe) +import Debug.Trace +import System.Directory + + + +debug1 a b= trace b a + + +type Key= String + + + +-- Interface that must be defined for every object being cached +-- readResource and writeResource implemented by default as read/write files with its key as filename +-- serialize and deserialize are specified just to allow these defaults + + + +class IResource a where + serialize :: a -> String + deserialize :: String -> a + keyResource :: a -> String + + defPath :: a-> String --additional extension for default file paths or key prefixes + defPath _ = "" + + -- get object content from the file + -- (NOTE: reads and writes can't collide, so they-- Not really needed since no write is done while read + -- must be strict, not lazy ) + readResource :: a->IO (Maybe a) + readResource x=handleJust ioErrors (handle x) $ do + s::String <- readFileStrict filename --`debug` ("read "++filename) + return $ Just $ deserialize s + where + filename= defPath x++ keyResource x + handle :: a -> IOError -> IO (Maybe a) + handle x e + |isAlreadyInUseError e = readResource x -- maybe is being written. try again. + -- Not really needed since no write is done while read + | isDoesNotExistError e = return Nothing + | isPermissionError e = error $ "no permissions for opening file: "++filename + | otherwise= error $ "unspecified error: " ++ show e + + writeResource:: a->IO() + writeResource x= handleJust ioErrors (handle x) $ writeFile filename (serialize x) --`debug` ("write "++filename) + where + filename= (defPath x ++ keyResource x) + handle :: a -> IOError -> IO () + handle x e + | isDoesNotExistError e=do + createDirectory $ defPath x --maybe the path does not exist + writeResource x + | isAlreadyInUseError e= writeResource x -- maybe is being read. try again + -- Not really needed since no write is done while read + | isPermissionError e = error $ "no permissions for writing file: "++ filename + + delResource:: a->IO() + delResource x= handleJust ioErrors (handle x) $ removeFile $ defPath x ++ keyResource x + where + handle :: a -> IOError -> IO () + handle x e + | isDoesNotExistError e= return () + | otherwise = error (show e) + +-- to allow not only inserts but also deletes +data Operation b= Insert b | Delete b + + +type AccessTime= Integer +type ModifTime = Integer + +type Block a= (TVar a,AccessTime,ModifTime) +type Ht a= HashTable String (Block a) +-- contains the hastable, number of items, last sync time +type Cache a= IORef (Ht a,Int, Integer) +data CheckBlockFlags= AddToHash | NoAddToHash | MaxTime +-- the cache holder + +refcache :: Cache a +refcache =unsafePerformIO $ do c <- H.new (==) hashString + newIORef (c,0,nowTime 1) + + +getTVars :: (IResource a)=> [a] -> IO [Maybe (TVar a)] +getTVars rs= do + (cache,_,_) <- readIORef refcache + takeBlocks rs cache MaxTime + +withResourcesID:: (IResource a)=> [a]->([Maybe a]->[Operation a])->IO () +withResourcesID rs f= do + (cache,_,_) <- readIORef refcache + mtrs <- takeBlocks rs cache NoAddToHash + idrs <- atomically $ do + mrs <- mapM mreadTVar mtrs + let idrs= f mrs + let ladd= map selectAdd idrs + releaseBlocks (catMaybes ladd) cache + return idrs + + let ldel= map selectDelete idrs + let ldel1= catMaybes ldel + mapM delResource ldel1 + delListFromHash cache $ map keyResource ldel1 + + return () + + where + + selectDelete (Insert a)= Nothing + selectDelete (Delete a)= Just a + + selectAdd (Insert a)= Just a + selectAdd (Delete a)= Nothing + +mreadTVar (Just tvar)= do r <-readTVar tvar + return $ Just r +mreadTVar Nothing = return Nothing + + + + +withResource:: (IResource a)=> a->(Maybe a->a)->IO () +withResource r f= withResources [r] (\[mr]-> [f mr]) + + + + +withResources:: (IResource a)=> [a]->([Maybe a]->[a])->IO () +withResources rs f= do + (cache,size,time) <- readIORef refcache + mtrs <- takeBlocks rs cache NoAddToHash + + + atomically $ do + + mrs <- mapM mreadTVar mtrs + let rs'= f mrs + releaseBlocks rs' cache + + return () + +takeBlocks :: (IResource a)=> [a] -> Ht a -> CheckBlockFlags ->IO [Maybe (TVar a)] +takeBlocks rs cache addToHash= mapM (checkBlock cache addToHash) rs + where + checkBlock :: IResource a => Ht a -> CheckBlockFlags -> a-> IO(Maybe (TVar a)) + checkBlock cache flags r =do + c <- H.lookup cache keyr + case c of + Nothing -> do + mr <- readResource r -- `debug1` ("read "++keyr++ " hash= "++ (show $ H.hashString keyr)) + case mr of + Nothing -> return Nothing + Just r2 -> do + tvr <- atomically $ newTVar r2 + case flags of + NoAddToHash -> return $ Just tvr + AddToHash -> do + H.update cache keyr (tvr, ti, 0) -- accesed, not modified + return $ Just tvr + MaxTime -> do + H.update cache keyr (tvr, maxtime, maxtime) -- accesed, not modified + return $ Just tvr + where + maxtime= ti + 10000000 + + Just(tvr,_,_) -> return $ Just tvr + + where keyr= keyResource r + ti= t where TOD t _=unsafePerformIO getClockTime + +releaseTVars :: (IResource a)=> [a]-> IO() +releaseTVars rs=do + (cache,_,_) <- readIORef refcache + atomically $ releaseBlocks rs cache + +releaseBlocks :: (IResource a)=> [a] -> Ht a ->STM () +releaseBlocks rs cache = mapM_ checkBlock rs + + where + checkBlock r =do + c <- unsafeIOToSTM $ H.lookup cache keyr + case c of + Nothing -> do tvr <- newTVar r + unsafeIOToSTM $ H.update cache keyr (tvr, ti, ti ) -- accesed and modified XXX + + + Just(tvr,_,tm) ->do writeTVar tvr r + unsafeIOToSTM $ H.update cache keyr (tvr ,ti,ti) + + + + where keyr= keyResource r + ti= t where TOD t _=unsafePerformIO getClockTime + +getResource r= do{mr<-getResources [r];return $! head mr} + +getResources:: (IResource a)=>[a]-> IO [Maybe a] +getResources rs= do + (cache,_,_) <- readIORef refcache + mtrs <- takeBlocks rs cache AddToHash + atomically $ mapM mreadTVar mtrs + + +deleteResource r= deleteResources [r] +deleteResources rs=do + (cache,_,time) <- readIORef refcache + atomically $! do + unsafeIOToSTM $ mapM delResource rs + unsafeIOToSTM $ delListFromHash cache $ map keyResource rs + + where + ntime= nowTime 1 + +delListFromHash hash l= do{mapM (delete hash) l; return()} + +updateListToHash hash kv= do{mapM (update1 hash) kv; return()}where + update1 h (k,v)= update h k v + +-----------------------clear, sync cache------------- +clearSyncCacheProc ::(IResource a)=> Cache a->Int->(Integer->Integer->Bool)->Int->IO ThreadId +clearSyncCacheProc refcache time check sizeObjects= + forkIO $ clear refcache time check sizeObjects + + where + clear :: (IResource a) => Cache a->Int->(Integer->Integer->Bool)->Int->IO () + clear refcache time check sizeObjects= do + threadDelay $ (fromIntegral$ time * 1000000) + clearSyncCache refcache time check sizeObjects + clear refcache time check sizeObjects + + +syncCache refcache = do + (cache,_,_) <- readIORef refcache + list <- toList cache + atomically $ save list 0 + --print $ "write to persistent storage finised: "++ show (length list)++ " objects" + +-- - saves the unsaved elems of the cache +-- - delete some elems of the cache when the number of elems > sizeObjects +-- - The deletion depends on the check criteria. defaultCheck is the one implemented +clearSyncCache ::(IResource a) => Cache a-> Int -> (Integer->Integer-> Bool)-> Int -> IO () +clearSyncCache refcache time check sizeObjects=do + (cache,size,last) <- readIORef refcache + handle (\e->do{print e;return ()})$ do + (nsize,ntime) <- atomically $ clearCache cache size last check sizeObjects + writeIORef refcache (cache,size, ntime) + +save:: (IResource a) => [(String, Block a)]-> Integer-> STM () +save list lastSave= mapM_ save1 list + where + save1 :: IResource a =>(String, Block a) -> STM() + save1(_, (tvr,_,modTime))= do + if modTime > lastSave + then do + r<- readTVar tvr + unsafeIOToSTM $! writeResource r --`debug1` ("saved " ++ keyResource r) + else return() + +nowTime x = t where TOD t _=unsafePerformIO getClockTime + + + +clearCache:: (IResource a) =>Ht a->Int->Integer-> + (Integer->Integer-> Bool)->Int -> STM (Int,Integer) + +clearCache cache size lastSync check sizeObjects= do + elems <- unsafeIOToSTM $ toList cache + let size=length elems + save elems lastSync + if size > sizeObjects then filtercache lastSync elems else return (size,lastSync) + + + where + -- delete elems from the cache according with the check criteria + filtercache lastSync elems= do + n <- unsafeIOToSTM $ mapM filter elems + return(size - sum n,nowTime 1) + where + check1 (_,lastAccess,_)=check lastAccess lastSync + + filter ::(String,Block a)->IO Int + filter (k,e)= if check1 e then do{H.delete cache k;return 1} else return 0 + +--to drop from the cache all the elems not accesed since half the time between now and the last sync +defaultCheck:: Integer->Integer->Bool +defaultCheck lastAccess lastSync + | lastAccess > halftime = False + | otherwise = True + + where + halftime= now- (now-lastSync) `div` 2 + now= nowTime 1 + + + +readFileStrict f = do + h <- openFile f ReadMode + s <- hFileSize h + let n= fromIntegral s + str <- readn h n + hClose h + return str + + where + -- read n bytes from handle h + readn h 0= return "" + readn h n=do + str <- hGetContents h + -- force to read n elements + if (str !! (n-1))== '\x00' then return str else return str + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Alberto Gómez Corona 2008 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#! /usr/bin/runghc + +> import Distribution.Simple +> +> main = defaultMain diff --git a/TCache.cabal b/TCache.cabal new file mode 100644 --- /dev/null +++ b/TCache.cabal @@ -0,0 +1,36 @@ +name: TCache +version: 0.5 +synopsis: A Transactional cache with configurable persitence +description: ------------------------------------------------- +-- A Transactional data cache with configurable persitence +-- The exported methods are documented in the TCache.hs header +-- See also http://haskellandweb.blogspot.com +-- (Something like a little Java Hybernate or Rails for Rubi) +-- Author: Alberto Gómez Corona Nov 2006-2008 agocorona at gmail.com +-- Language: Haskell +-- Version: 0.5 +-- Terms of use: you can do whatever you want +-- with this code as long as you keep this notice + +-- 10/15/2007 : changes +-- Default writeResource and delResource for persistence in files +-- (only keyResource must be defined by the user if use defaults) +-- Coherent Inserts and deletes +-- Reduced the number of accesses to the hashtable +-- hashtable access put outside of the transaction block (takeBlocks) +-- faster re-executions in case of rollback + + + +category: Middleware +license: BSD3 +license-file: LICENSE +author: Alberto Gómez Corona +maintainer: agocorona@gmail.com +Tested-With: GHC == 6.8.2 +Build-Type: Simple +build-Depends: base,directory >= 1.0, old-time >=1.0 +Cabal-Version: >= 1.2 + +exposed-modules: Data.TCache +ghc-options: