diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2010, Roman Smrž +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT +OWNER 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.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Disk/Swapper.hs b/src/Data/Disk/Swapper.hs new file mode 100644 --- /dev/null +++ b/src/Data/Disk/Swapper.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} + +-- | +-- Maintainer : Roman Smrž +-- Stability : experimental +-- +-- This module provides the actual wrapper around functors, which allows them +-- to swap their values to disk. Before any use, original structure have to by +-- turned into appropriate 'Swapper' using function 'mkSwapper'; this has to be +-- done in IO monad. The created object can then be used in normal pure way, +-- when internal side effects concern only database files determined by the +-- first parameter passed to 'mkSwapper'; those should not be altered +-- externally during the program run. +-- +-- Because the Swapper is different type than the original functor, lifting +-- functions are provided to allow manipulation with it. Those are 'adding' for +-- functions, which add new elements like ':' or 'Data.Map.insert', 'getting' +-- for function retrieving elements like 'head' or 'Data.Map.lookup', +-- 'changing' for functions changing the structure itself like 'tail'. Concrete +-- examples are provided it the description of the aforementioned functions. +-- +-- When creating snapshot using 'putToSnapshot', all items present it structure +-- are saved into the current database file (its name is then recorded to the +-- snapshot itself in order to be able to load in future) and new one is +-- created for items added thereafter. When the snapshot is loaded using +-- 'getFromSnapshot', only indices and auxiliary data are loaded into the +-- memory at that time; values are read on demand from their database file. + + + +-- IMPLEMENTATION +-- +-- Swapper is implemented using the functor given as its first type argument, +-- containing a certain "placeholders" (encapsulated in internal Swappable +-- type) instead of (or possibly along with) actual data. When some value is +-- added to the Swapper object, it is assigned unique numeric key (each Swapper +-- contains counter for generating these keys) to be used later for indexing in +-- database and the Swappable object is created for it. It contains the key and +-- weak pointer to the data; when those are garbage collected and about to be +-- freed, they are written to the database file of the containing Swapper. +-- +-- Because loading and deserializing values form database even if such value is +-- frequently used, is undesirable, a cache mechanism is provided using the +-- ClockCache data type. (Originally, it was meant to accept any type belonging +-- to the Cache class, but as we need to recreate some cache when loading +-- snapshot, we need to know its type, hence type parameter in the Swapper +-- would need to carry that information and Swappers differing only in cache +-- type would not constitute the same type; anyway, this may be changed in the +-- future.) Cache only keeps references to certain set of values (and is +-- informed when some value is requested), so keep even weak pointers in +-- appropriate Swappables alive; when the value drop out of cache (and no +-- longer referenced from any other place in the program), it is finalized (id +-- est, saved to the database) and freed. +-- +-- When all the references to some Swappable (the per-value structure) are lost +-- and it is about to be garbage collected, it also (in its finalizer) deletes +-- accompanying entry in the current database. +-- +-- +-- Snapshots +-- +-- Because creating snapshot involves writing to external file (and creating +-- new one), it is not (directly) implement the Serialize class, but Snapshot +-- instead, which allows running IO actions. When snapshot is about to be +-- created, all present values are saved to the current database (even those +-- not currently in memory, because they may be saved in some older database; +-- for this, the Traversable instance is needed), then we wait for all possibly +-- running writes to terminate and close then current DB (and reopen it for +-- further reading), and create new one, with filename determined by given +-- prefix and current counter. +-- +-- Loading snapshot is rather straightforward: Accounting data and database +-- filename are extracted from snapshot, then that database is opened for +-- reading, actual data are then retrieved, when they are needed. New database +-- is created, with filename again given by prefix and counter, which is also +-- loaded from snapshot. Due to this, snapshot of Swapper should be created in +-- single-threaded manner. Databases assigned to some snapshot always contain +-- all values of the Swapper on which the putToSnapshot was call; it may +-- contain also some other values, if there were other Swappers "descended" +-- from the same mkSwapper call. + + +module Data.Disk.Swapper ( + Swapper, + mkSwapper, + setCache, setCacheRef, + adding, + getting, + changing, + swapperDBPrefix, +) where + + +import Control.Concurrent.MVar +import Control.Concurrent.QSemN +import Control.DeepSeq +import Control.Parallel + +import Data.ByteString.Lazy as BS hiding (map) +import Data.IORef +import Data.Traversable +import Data.Typeable + +import Happstack.Data.Serialize + +import System.Mem.Weak +import System.IO.Unsafe + +#ifdef TRACE_SAVING +import qualified System.IO as IO +#endif + +import Data.Disk.Swapper.Cache +import Data.Disk.Swapper.Snapshot +import qualified Data.Disk.Swapper.TokyoCabinet as TC + + +type Key = ByteString + + +-- Datatype containing information for single value – its key, weak pointer to +-- actual data and finalization lock (which is emptied when data is created or +-- loaded and filled when they are saved to disk). +data Swappable a = Swappable + { saKey :: !Key + , saValue :: !(MVar (Weak (a, IO ()))) + , saFinalized :: !(MVar ()) + } + +-- The Swapper type; contains database information, counter for generating keys +-- of newly added items, cache and actual content (consisting of Swappables). +data Swapper f a = Swapper + { spDB :: !SwapDB + , spCounter :: !(MVar Integer) + , spCache :: !(IORef (SomeCache a)) + , spContent :: !(f (Swappable a)) + } + +-- Data needed to manage access to database +data SwapDB = SwapDB + { sdDB :: !(MVar [TC.Database]) + -- List of open databases, the first one is for writing, the rest are + -- read-only databases, created when loading snapshot (the database + -- accompanying the snapshot), or when creating snapshot (the old + -- database, which was formerly used for writing). + + , sdPrefix :: !FilePath + , sdCounter :: !(IORef Integer) + -- These are to components of database filename, the first is prefix, + -- after which is appended current value of the counter (which is then + -- incremented) and finely there goes the extension. + + , sdSem :: QSemN + -- Semaphore to force synchronization when changing databases. + } + + + +-- Auxiliary functions for accessing the DB + +-- They take into account that data can be read from multiple databases and +-- some locking needed for synchronization when snapshots are created + +dbOpen :: FilePath -> IO SwapDB +dbOpen prefix = do + cdb <- TC.open (prefix ++ "0.tcb") + tdb <- newMVar [cdb] + counter <- newIORef 0 + sem <- newQSemN 1000 + return $ SwapDB { sdDB = tdb, sdPrefix = prefix, sdCounter = counter, sdSem = sem } + +withDB :: SwapDB -> ([TC.Database] -> IO a) -> IO a +withDB db f = do + dbs <- readMVar (sdDB db) + waitQSemN (sdSem db) 1 + res <- f dbs + signalQSemN (sdSem db) 1 + return res + +dbPut :: SwapDB -> ByteString -> ByteString -> IO Bool +dbPut db key value = withDB db $ \(cdb:_) -> TC.put cdb key value + +dbGet :: SwapDB -> ByteString -> IO (Maybe ByteString) +dbGet db key = withDB db get + where get [] = return Nothing + get (cdb:rest) = do value <- TC.get cdb key + case value of + res@(Just _) -> return res + Nothing -> get rest + +dbOut :: SwapDB -> ByteString -> IO Bool +dbOut db key = withDB db $ \(cdb:_) -> TC.out cdb key + + +-- Instances of Typeable and Snapshot classes + +instance (Typeable a) => Typeable (Swappable a) where + typeOf _ = mkTyConApp (mkTyCon "Data.Disk.Swapper.Swappable") + [ typeOf (undefined :: a) ] + +instance (Typeable1 f, Typeable a) => Typeable (Swapper f a) where + typeOf _ = mkTyConApp (mkTyCon "Data.Disk.Swapper.Swapper") + [ typeOf1 (undefined :: f a), typeOf (undefined :: a) ] + + + +instance Version a => Version (Swapper f a) where mode = Primitive + + +instance ( + Typeable a, Version a, Serialize a, + Typeable1 f, Traversable f, Snapshot (f ByteString) + ) => Snapshot (Swapper f a) where + + getFromSnapshot = do + prefix <- safeGet + spCnt <- safeGet + cnt <- safeGet + mkKeys <- getFromSnapshot + + return $ do + mcounter <- newMVar spCnt + cache <- newIORef nullCache + + keys <- mkKeys + emptyWeak <- mkWeakPtr undefined Nothing + finalize emptyWeak + data_ <- forM keys $ \key -> do + mval <- newMVar emptyWeak + mfin <- newMVar () + return $ Swappable { saKey = key, saValue = mval, saFinalized = mfin } + + dbcounter <- newIORef (cnt+1) + odb <- TC.open $ prefix ++ show cnt ++ ".tcb#mode=r" + ndb <- TC.open $ prefix ++ show (cnt+1) ++ ".tcb" + dbs <- newMVar [ndb,odb] + sem <- newQSemN 1000 + + return $ Swapper + { spDB = SwapDB { sdDB = dbs, sdPrefix = prefix, sdCounter = dbcounter, sdSem = sem } + , spCounter = mcounter + , spCache = cache + , spContent = data_ + } + + + putToSnapshot sp = do +#ifdef TRACE_SAVING + IO.putStrLn "Beginning snapshot" +#endif + spCnt <- readMVar (spCounter sp) + putData <- putToSnapshot $ fmap saKey $ spContent sp + + forM (spContent sp) $ \sa -> do + wx <- takeMVar $ saValue sa + mx <- deRefWeak wx + case mx of + Just (x, _) -> dbPut (spDB sp) (saKey sa) (serialize x) + Nothing -> do + readMVar (saFinalized sa) + + -- TODO: this copying is necessary only when the data + -- were finalized to some older DB: + mbx <- dbGet (spDB sp) (saKey sa) + case mbx of + Just x -> dbPut (spDB sp) (saKey sa) x + Nothing -> error "Data not found in DB (snapshot)!" + + putMVar (saValue sa) wx + + (cdb:rest) <- takeMVar (sdDB $ spDB sp) + waitQSemN (sdSem $ spDB sp) 1000 + + cnt <- readIORef (sdCounter $ spDB sp) + TC.close cdb + cdb' <- TC.open $ (sdPrefix $ spDB sp) ++ show cnt ++ ".tcb#mode=r" + ndb <- TC.open $ (sdPrefix $ spDB sp) ++ show (cnt+1) ++ ".tcb" + writeIORef (sdCounter $ spDB sp) (cnt+1) + + signalQSemN (sdSem $ spDB sp) 1000 + putMVar (sdDB $ spDB sp) (ndb:cdb':rest) + + return $ do + safePut (sdPrefix $ spDB sp) + safePut spCnt + safePut cnt + putData + + +return' :: (Monad m) => a -> m a +return' x = x `pseq` return x + + +swPutNewWeak :: (Serialize a) => Swappable a -> (a, IO ()) -> SwapDB -> IO () +swPutNewWeak sa (x, refresh) db = do + value <- mkWeak x (x, refresh) $ Just $ do +#ifdef TRACE_SAVING + IO.putStrLn $ "Saving " ++ show (fst (deserialize $ saKey sa) :: Integer) +#endif + dbPut db (saKey sa) (serialize x) + putMVar (saFinalized sa) () +#ifdef TRACE_SAVING + IO.putStrLn $ "Saved " ++ show (fst (deserialize $ saKey sa) :: Integer) +#endif + + takeMVar (saFinalized sa) + putMVar (saValue sa) value + + +-- Actual loading of data from database +swLoader :: (Serialize a) => Swapper f a -> Key -> IO (a, IO ()) +swLoader sp key = do +#ifdef TRACE_SAVING + IO.putStrLn $ "Loading " ++ show (fst (deserialize key) :: Integer) +#endif + + value <- dbGet (spDB sp) key + case value of + Just serialized -> do + let x = fst $ deserialize serialized + refresh <- addValueRef (spCache sp) x + return (x, refresh) + Nothing -> error "Data not found in DB!" + + +-- Takes care about creating Swappables from items newly added to the +-- structure; their initialization and assigning of finalizers. +putSwappable :: (Serialize a, NFData a) => Swapper f a -> a -> Swappable a +putSwappable sp x = deepseq x `pseq` unsafePerformIO $ do + c <- takeMVar (spCounter sp) + putMVar (spCounter sp) (c+1) + let key = serialize c + +#ifdef TRACE_SAVING + IO.putStrLn $ "Creating " ++ show c +#endif + + refresh <- addValueRef (spCache sp) x + mvalue <- newEmptyMVar + mfin <- newMVar () + + let swappable = Swappable key mvalue mfin + addFinalizer swappable $ do +#ifdef TRACE_SAVING + IO.putStrLn ("Deleting "++show c) +#endif + dbOut (spDB sp) key + return () + + swPutNewWeak swappable (x,refresh) (spDB sp) + return' swappable + + +-- Retrievs data from swapper, possibly loading it from the database using +-- swLoader, and calls refresh function on appropriate object in cache. +getSwappable :: (Serialize a) => Swapper f a -> Swappable a -> a +getSwappable sp sa = unsafePerformIO $ do + wx <- takeMVar $ saValue sa + mx <- deRefWeak wx + case mx of + Just (x, refresh) -> + -- TODO: possibly refreshing now-replaced value + refresh >> putMVar (saValue sa) wx >> return x + + Nothing -> do + finalize wx + readMVar (saFinalized sa) + + pair@(x, _) <- swLoader sp $ saKey sa + swPutNewWeak sa pair (spDB sp) + return x + + +mkSwapper :: (Serialize a, NFData a, Functor f) + => FilePath -- ^ Prefix of database files + -> f a -- ^ Initial data + -> IO (Swapper f a) + +-- ^ +-- Creates 'Swapper' from given functor object. The first parameter is prefix +-- from which the name of database files are derived (by appending their index +-- number and database extension), those files should not be altered by +-- external files when the program is running or between saving and loading +-- snapshots. +-- +-- The 'Swapper' initially uses the 'NullCache', which does not keep any data +-- in memory, apart from those referenced from other places. + +mkSwapper filename v = do + db <- dbOpen filename + counter <- newMVar (0 :: Integer) + cache <- newIORef nullCache + + let swapper = Swapper db counter cache $ fmap (putSwappable swapper) v + in return swapper + + +-- | +-- Sets cache for given 'Swapper' object; it determines, which items are to be +-- swapped onto disk, when available slots are used up (and also how many of +-- such slots actually exists in the first place); can be shared among several +-- 'Swappable' objects. + +setCache :: Cache c a => Swapper f a -> c -> IO () +setCache swapper = writeIORef (spCache swapper) . SomeCache + + +-- | +-- Analogous to the 'setCache', but works with 'Swapper' encosed in an 'IORef'. + +setCacheRef :: Cache c a => IORef (Swapper f a) -> c -> IO () +setCacheRef ref cache = flip setCache cache =<< readIORef ref + + +-- | +-- Lifting function used for adding new elements to the 'Swapper' object. Needs +-- to be applied to functions like ':' or 'Data.Map.insert' for them to act on +-- Swapper instead of the original structure. Requires the function in its +-- first argument to work for functor containing arbitrary type. +-- +-- > a :: Swapper [] Int +-- > let a' = adding (:) 6 a +-- > +-- > b :: Swapper (Map String) Int +-- > let b' = adding (insert "new") 42 b + +adding :: (Serialize a, NFData a) => + (forall b. b -> f b -> f b) -> + (a -> Swapper f a -> Swapper f a) +adding f x sp = let sx = putSwappable sp x + in sx `pseq` sp { spContent = f sx (spContent sp) } + + +-- | +-- Function used to lift functions getting elements from inner structure, +-- like 'head' or 'Data.Map.lookup', to functions getting elements from 'Swapper' +-- object. Functions in the first argument needs to work on 'f' containing +-- elements of arbitrary type. +-- +-- > a :: Swapper [] Int +-- > let x = getting head a +-- > +-- > b :: Swapper (Map String) Int +-- > let y = getting (lookup "some") b + +getting :: (Serialize a) => (forall b. f b -> b) -> (Swapper f a -> a) +getting f sp = getSwappable sp $ f $ spContent sp + + +-- | +-- +-- This function is needed to make functions changing the structure somehow +-- (like 'tail' or 'Data.Map.delete'), to change the 'Swapper' instead. Like +-- the previous lifting functions, its first argument needs to work for any +-- values of any type. +-- +-- > a :: Swapper [] Int +-- > let a' = changing tail a +-- > +-- > b :: Swapper (Map String) Int +-- > let b' = changing (delete "some") b + +changing :: (Serialize a) => (forall b. f b -> f b) -> (Swapper f a -> Swapper f a) +changing f sp = sp { spContent = f (spContent sp) } + + + +swapperDBPrefix :: Swapper f a -> FilePath +swapperDBPrefix = sdPrefix . spDB diff --git a/src/Data/Disk/Swapper/Cache.hs b/src/Data/Disk/Swapper/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Data/Disk/Swapper/Cache.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | +-- Maintainer : Roman Smrž +-- Stability : experimental +-- +-- Here is provided a 'Cache' type class designed to generalize notion of cache +-- currently used in Swapper. + + +module Data.Disk.Swapper.Cache where + +import Control.Concurrent.MVar +import Control.Monad + +import Data.IORef +import Data.Typeable + + +-- | +-- First parameter of this class is actual cache type, the second is type of +-- cached values. The cache should just hold an reference to those values that +-- are meant to be kept in memory. + +class Cache a v | a -> v where + -- | + -- This function is called when new value is about to be added to the + -- structure using the cache. It returns another 'IO' action used for + -- \"refreshing\"; i.e. which should be called whenever associated value + -- is accessed, so the cache can adapt. + + addValue :: a -> v -> IO (IO ()) + + +-- | +-- Version of 'addValue', which works with a cache in 'IORef'. +addValueRef :: Cache a v => IORef a -> v -> IO (IO ()) +addValueRef r x = flip addValue x =<< readIORef r + + +data SomeCache v = forall c. (Cache c v) => SomeCache !c + +instance Cache (SomeCache v) v where + addValue (SomeCache c) = addValue c + + + +-- | Provides standard clock cache with second chance mechanism. +data ClockCache a = ClockCache { ccSize :: Int, ccData :: MVar [(IORef a, IORef Bool)] } + deriving (Typeable) + +mkClockCache :: Int -> IO (ClockCache a) +mkClockCache size = return . ClockCache size =<< newMVar . cycle =<< + mapM (const $ liftM2 (,) (newIORef undefined) (newIORef False)) [1..size] + + +instance Cache (ClockCache a) a where + addValue cache x = do + add =<< takeMVar (ccData cache) + where add ((ix, ikeep):rest) = do + keep <- readIORef ikeep + modifyIORef ikeep not + + if keep then add rest + else do writeIORef ix x + putMVar (ccData cache) rest + return (writeIORef ikeep True) + + add [] = error "ClockCache: we got to the end of infinite list" + + + + +-- | 'NullCache' does not cache any values +data NullCache a = NullCache + +nullCache :: SomeCache a +nullCache = SomeCache NullCache + +instance Cache (NullCache a) a where + addValue _ _ = return (return ()) diff --git a/src/Data/Disk/Swapper/HappstackCompat.hs b/src/Data/Disk/Swapper/HappstackCompat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Disk/Swapper/HappstackCompat.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE FlexibleContexts, UndecidableInstances, ExistentialQuantification #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Disk.Swapper.HappstackCompat ( + createSwapperCheckpoint, +) where + + +import Control.Concurrent.MVar + +import Data.Binary +import Data.Binary.Get + +import Happstack.Data +import Happstack.State + +import System.IO.Unsafe + +import Unsafe.Coerce + + +import Data.Disk.Swapper +import Data.Disk.Swapper.Snapshot + + +data X = forall a. X a + +{-# NOINLINE checkGet #-} +checkGet :: MVar [(FilePath, X)] +checkGet = unsafePerformIO $ newMVar [] + +{-# NOINLINE checkPut #-} +checkPut :: MVar [(FilePath, Put)] +checkPut = unsafePerformIO newEmptyMVar + + +instance Snapshot (Swapper f a) => Serialize (Swapper f a) where + + getCopy = contain . check $ getFromSnapshot + where check getIO = do + prefix <- lookAhead safeGet + load <- getIO + return . unsafePerformIO $ do + c <- takeMVar checkGet + case lookup prefix c of + Just (X x) -> putMVar checkGet c >> return (unsafeCoerce x) + Nothing -> do x <- load + putMVar checkGet ((prefix, X x) : c) + return x + + + + putCopy sw = contain . check . putToSnapshot $ sw + where check ioPut = unsafePerformIO $ do + c <- takeMVar checkPut + let prefix = swapperDBPrefix sw + case lookup prefix c of + Just p -> putMVar checkPut c >> return p + Nothing -> do p <- ioPut + putMVar checkPut ((prefix, p) : c) + return p + + + +createSwapperCheckpoint :: MVar TxControl -> IO () +createSwapperCheckpoint txc = do +#ifdef TRACE_SAVING + putStrLn "createSwapperCheckpoint" +#endif + putMVar checkPut [] + createCheckpoint txc + takeMVar checkPut + return () diff --git a/src/Data/Disk/Swapper/Snapshot.hs b/src/Data/Disk/Swapper/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/Data/Disk/Swapper/Snapshot.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-} + +-- | +-- Maintainer : Roman Smrž +-- Stability : experimental +-- +-- 'Snapshot' is a type class generalizing 'Serialize', as it, apart from +-- writing values in the 'Put' monad (or reading in 'Get'), allows to perform +-- arbitrary 'IO' actions, like saving data to (or loading from) some external +-- database files. Any instance of 'Serialize' is also trivially an instance of +-- 'Snapshot'. + +module Data.Disk.Swapper.Snapshot where + +import Control.Monad + +import Data.Binary +import Data.Typeable + +import Happstack.Data.Serialize + + +class (Typeable a, Version a) => Snapshot a where + getFromSnapshot :: Get (IO a) + putToSnapshot :: a -> IO Put + +instance Serialize a => Snapshot a where + getFromSnapshot = liftM return safeGet + putToSnapshot = return . (return <=< safePut) diff --git a/src/Data/Disk/Swapper/TokyoCabinet.hs b/src/Data/Disk/Swapper/TokyoCabinet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Disk/Swapper/TokyoCabinet.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Data.Disk.Swapper.TokyoCabinet ( + Database, + open, close, + put, get, out, + copy, +) where + +import Control.Monad + +import Data.IORef + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Unsafe as BSU + +import Data.Typeable + +import Foreign.C +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable + +data TCADB deriving Typeable +type Database = Ptr TCADB + + +foreign import ccall "tcadb.h tcadbnew" tcadbnew :: IO Database +foreign import ccall "tcadb.h tcadbdel" tcadbdel :: Database -> IO () +foreign import ccall "tcadb.h tcadbopen" tcadbopen :: Database -> CString -> IO Bool +foreign import ccall "tcadb.h tcadbclose" tcadbclose :: Database -> IO Bool +foreign import ccall "tcadb.h tcadbput" tcadbput :: Database -> Ptr () -> CInt -> Ptr () -> CInt -> IO Bool +foreign import ccall "tcadb.h tcadbget" tcadbget :: Database -> Ptr () -> CInt -> Ptr CInt -> IO (Ptr ()) +foreign import ccall "tcadb.h tcadbout" tcadbout :: Database -> Ptr () -> CInt -> IO Bool +foreign import ccall "tcadb.h tcadbcopy" tcadbcopy :: Database -> CString -> IO Bool + + +open :: FilePath -> IO Database +open str = withCAString str $ \filename -> + do db <- tcadbnew + tcadbopen db filename + return db + +close :: Database -> IO () +close db = tcadbclose db >> tcadbdel db + + +useLBSAsCString :: LBS.ByteString -> (CString -> IO a) -> IO a +useLBSAsCString str action = do + --allocaBytes (fromIntegral $ LBS.length str) $ \ptr -> do + ptr <- mallocBytes (fromIntegral $ LBS.length str) + cur <- newIORef ptr + forM_ (LBS.toChunks str) $ \ch -> do + BSU.unsafeUseAsCString ch $ \cstr -> do + dest <- readIORef cur + copyBytes dest cstr $ BS.length ch + modifyIORef cur (`plusPtr` (BS.length ch)) + result <- action ptr + free ptr + return result + + + +put :: Database -> LBS.ByteString -> LBS.ByteString -> IO Bool +put db key value = useLBSAsCString key $ \ckey -> useLBSAsCString value $ \cvalue -> + tcadbput db (castPtr ckey) (fromIntegral $ LBS.length key) (castPtr cvalue) (fromIntegral $ LBS.length value) + + +get :: Database -> LBS.ByteString -> IO (Maybe LBS.ByteString) +get db key = useLBSAsCString key $ \ckey -> alloca $ \psize -> do + value <- tcadbget db (castPtr ckey) (fromIntegral $ LBS.length key) psize + if value == nullPtr + then return Nothing + else do size <- peek psize + strict <- BSU.unsafePackCStringFinalizer (castPtr value) (fromIntegral size) (free value) + return $ Just $ LBS.fromChunks [strict] + + +out :: Database -> LBS.ByteString -> IO Bool +out db key = useLBSAsCString key $ \ckey -> tcadbout db (castPtr ckey) (fromIntegral $ LBS.length key) + + +copy :: Database -> FilePath -> IO Bool +copy db filename = withCAString filename $ tcadbcopy db diff --git a/swapper.cabal b/swapper.cabal new file mode 100644 --- /dev/null +++ b/swapper.cabal @@ -0,0 +1,62 @@ +name: swapper +version: 0.1 +synopsis: Transparently swapping data from in-memory structures to disk +description: + This package provides a wrapper for functors, which allows their data to be + automatically swapped to disk and loaded back when necessary. Although + interaction with filesystem is required, whole interface (with exception of + initialization) is pure and safe as long as no external manipulation with + used database files happens while the program is running. + + Because only actual data, not indices (in Data.Map.Map, for example), are + swapped and some accounting information are remembered for each item, this + system is suitable mainly for situations where values are considerably + larger then indices. Furthermore, creating complete snapshots to a file of + this structure is supported; such snapshot can be then loaded, with + individual values being read as they are requested. + + This package uses the Tokyo Cabinet + database, which needs to be installed on the system. + + A prototype of another data structure, SwapMap, is available in the git + repository. It is similar to the Data.Map.Map and like Swapper allows + transparent swapping of data to disk, but without requiring any accessory + function and with the ability to swap both elements and indices. This one + is, however, not complete and thus not provided here. + +author: Roman Smrž +maintainer: Roman Smrž +stability: experimental +category: Data Structures +homepage: http://github.com/roman-smrz/swapper/ +copyright: Copyright (C) 2010-2011, Roman Smrž +license: BSD3 +license-file: LICENSE + +build-type: Simple +cabal-version: >=1.6 + +extra-source-files: + test/test.hs + test/test-load.hs + test/happstack.hs + test/Makefile + +source-repository head + type: git + location: git://github.com/roman-smrz/swapper.git + +library + build-depends: base >= 3 && < 5, bytestring, happstack-data, happstack-state, binary, parallel, deepseq + hs-source-dirs: src + + exposed-modules: + Data.Disk.Swapper + Data.Disk.Swapper.HappstackCompat + Data.Disk.Swapper.Cache + Data.Disk.Swapper.Snapshot + other-modules: + Data.Disk.Swapper.TokyoCabinet + + ghc-options: -Wall -fno-warn-unused-do-bind + extra-libraries: tokyocabinet diff --git a/test/Makefile b/test/Makefile new file mode 100644 --- /dev/null +++ b/test/Makefile @@ -0,0 +1,19 @@ +all: test test-load happstack in + +GHCOPTS+=-ltokyocabinet -i../src +GHCOPTS+=-DTRACE_SAVING # prints info about saving/loading individual values + +test: *.hs + ghc --make test.hs $(GHCOPTS) + +test-load: *.hs + ghc --make test-load.hs $(GHCOPTS) + +happstack: *.hs + ghc --make happstack.hs $(GHCOPTS) + +in: + dd if=/dev/zero of=in bs=1024 count=1024 + +clean: + rm -f *.hi *.o test test-load data* snapshot* diff --git a/test/happstack.hs b/test/happstack.hs new file mode 100644 --- /dev/null +++ b/test/happstack.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, MultiParamTypeClasses, + TypeFamilies, FlexibleContexts, FlexibleInstances, TypeOperators #-} + +module Main where + +import Prelude hiding (lookup) + +import Control.DeepSeq +import Control.Monad +import Control.Monad.State + +import qualified Data.ByteString as BS +import Data.Typeable + +import Happstack.State + +import System.IO.Unsafe +import System.Mem + +import Data.Disk.Swapper +import Data.Disk.Swapper.Cache +import Data.Disk.Swapper.HappstackCompat + + +data AppState = AppState (Swapper [] BS.ByteString) + deriving Typeable + +rootState :: Proxy AppState +rootState = Proxy + +instance Version AppState + + +-- initial swapper to be used when none was loaded from snapshot +{-# NOINLINE initialSwapper #-} +initialSwapper :: Swapper [] BS.ByteString +initialSwapper = unsafePerformIO $ mkSwapper "_local/happstack_state/data" [] + +instance Component AppState where + type Dependencies AppState = End + initialValue = AppState initialSwapper + +instance Serialize AppState where + getCopy = contain $ fmap AppState safeGet + putCopy (AppState s) = contain $ safePut s + + +-- instance needed for Swapper +instance NFData BS.ByteString where + rnf x = x `seq` () + + + +-- this need to be call at the startup to initialize the cache +initCache :: Update AppState () +initCache = do + -- we need to force evaluation of the IO computation, hence the () <- + () <- gets $ \(AppState s) -> unsafePerformIO $ do + putStrLn "initCache" + setCache s =<< mkClockCache 5 + return () + + +-- adds entry to the swapper in global state +addState :: BS.ByteString -> Update AppState () +addState x = do + AppState s <- get + let s' = adding (:) x s + put $ AppState s' + + -- evaluate the Swapper object to HNF in order to allow the data to be + -- swapped-out (instead of being held by unevaluated thunks) + s' `seq` return () + + +$(mkMethods ''AppState ['addState, 'initCache]) + + + +main :: IO () +main = do + control <- startSystemState rootState + update $ InitCache + + forM_ [1..10] $ \_ -> do + d <- BS.readFile "in" + update $ AddState d + performGC + + -- we need to call this wrapper around createCheckpoint + createSwapperCheckpoint control + + shutdownSystem control diff --git a/test/test-load.hs b/test/test-load.hs new file mode 100644 --- /dev/null +++ b/test/test-load.hs @@ -0,0 +1,34 @@ +module Main where + +import Control.DeepSeq +import Control.Monad + +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL + +import System.Mem + +import Data.Disk.Swapper +import Data.Disk.Swapper.Cache +import Data.Disk.Swapper.Snapshot + +instance NFData BS.ByteString where + rnf x = x `seq` () + +main :: IO () +main = do + x <- runGet getFromSnapshot =<< BSL.readFile "snapshot2" + setCache x =<< mkClockCache 5 + print . BS.length . getting last $ x + + let y = adding (:) (BS.pack "aaa") $ + adding (:) (BS.pack "bbb") $ + x + + forM_ [2..12] $ \i -> do + BS.writeFile "out" (getting (!!i) y) + performGC + + BSL.writeFile "snapshot3" . runPut =<< putToSnapshot y diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,72 @@ +module Main where + +import Prelude hiding (lookup) + +import Control.DeepSeq +import Control.Monad + +import Data.Binary.Put +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.IORef + +import System.Mem + +import Data.Disk.Swapper +import Data.Disk.Swapper.Cache +import Data.Disk.Swapper.Snapshot + + +instance NFData BS.ByteString where + rnf x = x `seq` () + + + +main :: IO () +main = do + x <- newIORef =<< mkSwapper "data" [] + setCacheRef x =<< mkClockCache 5 + + forM_ [1..7] $ \_ -> do + d <- BS.readFile "in" + x' <- readIORef x + writeIORef x $! adding (:) d x' + performGC + + forM_ [3..4] $ \i -> do + BS.writeFile "out" . getting (!!i) =<< readIORef x + performGC + + forM_ [8..10] $ \_ -> do + d <- BS.readFile "in" + x' <- readIORef x + writeIORef x $! adding (:) d x' + performGC + + forM_ [2..6] $ \i -> do + x' <- return . getting (!!i) =<< readIORef x + BS.writeFile "out" x' + performGC + + forM_ [2..6] $ \_ -> do + modifyIORef x $ changing tail + performGC + + forM_ [8..10] $ \_ -> do + d <- BS.readFile "in" + x' <- readIORef x + writeIORef x $! adding (:) d x' + performGC + + BSL.writeFile "snapshot0" . runPut =<< putToSnapshot =<< readIORef x + + forM_ [1..7] $ \_ -> do + d <- BS.readFile "in" + x' <- readIORef x + writeIORef x $! adding (:) d x' + performGC + + BSL.writeFile "snapshot1" . runPut =<< putToSnapshot =<< readIORef x + BSL.writeFile "snapshot2" . runPut =<< putToSnapshot =<< readIORef x + + print . BS.length . getting last =<< readIORef x