content: {-# LANGUAGE ExistentialQuantification, Rank2Types, ImpredicativeTypes #-}
  
  module Database.Siege.DoStore where
  
  import Control.Monad
  import Control.Monad.Trans
  import Data.Word
  import Data.Char
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Lazy as L
  import qualified Control.Monad.Trans.Store as S
  -- import qualified Database.Redis.Redis as R
  import Database.Siege.Hash
  import qualified Database.Siege.DBNode as N
  import Database.Siege.DBNodeBinary
  import qualified Data.Binary as Bin
  import System.Random
  import Database.Siege.StringHelper
  
  randRef :: IO N.Ref
  randRef = do
    s <- replicateM 20 $ do
      r <- randomIO :: IO Int
      let r' = fromIntegral r :: Word8
      return $ r'
    return $ N.Ref $ B.pack s
  
  refLocation :: N.Ref -> B.ByteString
  refLocation arg = B.snoc (N.unRef arg) 0
  
  invertLocation :: N.Ref -> B.ByteString
  invertLocation arg = B.snoc (N.unRef arg) 1
  
  get :: [(forall x. (R.Redis -> IO x) -> IO x)] -> B.ByteString -> IO (Maybe B.ByteString)
  get fns k = do
    let fn = head fns
    v <- fn (\redis -> R.get redis k)
    case v of
      R.RBulk v -> return v
      _ -> return Nothing
  
  store :: [(forall x. (R.Redis -> IO x) -> IO x)] -> B.ByteString -> B.ByteString -> IO ()
  store fns k v = do
    let fn = head fns
    fn (\redis -> R.set redis k v)
    return ()
  
  withRedis :: [(forall x. (R.Redis -> IO x) -> IO x)] -> S.StoreT N.Ref (N.Node N.Ref) IO a -> IO a
  withRedis redisfns op = do
    step <- S.runStoreT op
    case step of
      S.Done a -> return a
      S.Get k c -> do
        let k' = refLocation k
        v <- get redisfns k'
        case v of
          (Just v') ->
            (withRedis redisfns . c . Bin.decode . L.fromChunks . (\i -> [i])) v'
          _ ->
            error $ show ("lookup error", k)
      S.Store v c -> do
        k <- randRef
        out <- withRedis redisfns $ c k
        store redisfns (refLocation k) ((B.concat . L.toChunks . Bin.encode) v)
        return out
  