packages feed

swapper (empty) → 0.1

raw patch · 12 files changed

+1054/−0 lines, 12 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, deepseq, happstack-data, happstack-state, parallel

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/Disk/Swapper.hs view
@@ -0,0 +1,472 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}++-- |+-- Maintainer  : Roman Smrž <roman.smrz@seznam.cz>+-- 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
+ src/Data/Disk/Swapper/Cache.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Maintainer  : Roman Smrž <roman.smrz@seznam.cz>+-- 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 ())
+ src/Data/Disk/Swapper/HappstackCompat.hs view
@@ -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 ()
+ src/Data/Disk/Swapper/Snapshot.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances #-}++-- |+-- Maintainer  : Roman Smrž <roman.smrz@seznam.cz>+-- 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)
+ src/Data/Disk/Swapper/TokyoCabinet.hs view
@@ -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
+ swapper.cabal view
@@ -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 <http://fallabs.com/tokyocabinet/>+    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ž <roman.smrz@seznam.cz>+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
+ test/Makefile view
@@ -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*
+ test/happstack.hs view
@@ -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
+ test/test-load.hs view
@@ -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
+ test/test.hs view
@@ -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