Persistence.hs

module Data.HMemDb.Persistence (fillTable, putTable) where
import Control.Applicative (Applicative(pure, (<*>)), (<$>))
import Control.Concurrent.STM (STM, TVar, readTVar, writeTVar)
import Control.Monad.Trans.Cont (Cont, runCont, cont)
import Control.Monad.Trans.Maybe (MaybeT(runMaybeT))
import Data.Binary (Binary(get, put))
import Data.Foldable (for_)
import qualified Data.Map as M (toAscList)
import Data.HMemDb.Bin (Bin (binGet, binPut))
import Data.HMemDb.Binary (GS, SP)
import Data.HMemDb.Tables
    (PreTable(tabContent, tabCount, tabRefs), Table(Table), insertRefIntoTable)
import Data.HMemDb.Utils
    (bindO, enumElem, fixArray, oBind, liftPure, pureO, replicateO)
-- serialization
putTVar :: TVar a -> Cont SP a
putTVar tv = cont $ bindO $ readTVar tv
readValue :: (a, TVar (Maybe b)) -> STM (Maybe (a, b))
readValue (n, tv) = fmap ((,) n) <$> readTVar tv
putPreTable :: Bin r -> PreTable r a -> Cont SP ()
putPreTable b pt =
    do tC <- putTVar $ tabCount pt
       liftPure $ put tC
       mp <- putTVar $ tabContent pt
       pairs <- fixArray (M.toAscList mp) readValue
       liftPure $ put $ length pairs
       ~(n, r) <- enumElem pairs
       liftPure $ put n >> binPut b r
putTable :: Table a -> SP
-- ^ This function saves the table to the ByteString.
-- Note that it doesn't really matter if the type of values in the table
-- are serializable.
--
-- NB: if any index used to access the values in this table depended on any foreign keys,
-- and targets of these keys have changed,
-- the index could be different after storing and restoring the table.
putTable (Table b pt) = runCont (putPreTable b pt) pure
-- deserialization
fillTable :: Table a -> GS ()
-- ^ This function reads the table from the ByteString.
fillTable (Table b pt) = genPairs `oBind` insPairs where
    genPair = (,) <$> pureO get <*> binGet b (tabRefs pt)
    genPairs = (,) <$> pureO get <*> (get `bindO` replicateO genPair)
    insPairs ~(counter, pairs) =
        do writeTVar (tabCount pt) counter
           for_ pairs $ runMaybeT . insertRefIntoTable pt