Redis.hs

{-# LANGUAGE OverloadedStrings, RankNTypes, ScopedTypeVariables #-}
module Linden.Store.Redis (
   rStore
 ) where

import Control.Monad
import Control.Monad.Trans
import qualified Data.UUID as UUID
import qualified Data.Aeson as JS
import qualified Control.Monad.Catch as E
import qualified Control.Exception.Base as BE
import qualified Data.ByteString.Lazy as BSL
import Data.Random
import Control.Time
import Data.Time
import Database.Redis
import Codec.Compression.Zlib (compress, decompress)

import Linden.Types

backOff :: forall a. IO (Maybe a) -> IO (Maybe a)
backOff act =
    go 0
  where
    go :: Int -> IO (Maybe a)
    go 5 = return Nothing
    go e = E.handle (\(ex::E.SomeException) -> print ex >> delay (secondsToDiffTime $ 2^e) >> act) act

rStore :: Bool -> ConnectInfo -> IO GardenStore
rStore debug cinfo = do
    conn <- connect cinfo
    return $ GardenStore (rSave conn) (rCAS conn) undefined
  where
    rSave :: Connection -> GardenSave
    rSave conn lcs = runRedis conn $ do
      let ubs = UUID.toASCIIBytes . lsGarden $ lcs
      let bdy = BSL.toStrict . compress . JS.encode $ lcs
      void $ set ubs bdy

    rCAS :: Connection -> GardenCAS
    rCAS conn = \u mut -> backOff . runRedis conn $ do
      when debug . liftIO . putStrLn $ "CASing "++show u
      let ubs = UUID.toASCIIBytes u
      watch [ubs]
      eo <- get ubs
      case fmap (join . fmap (JS.decode' . decompress . BSL.fromStrict)) eo of
        Left err -> do
          liftIO . putStrLn $ " - "++show u ++ " got error: "++show err
          return Nothing
        Right Nothing -> do
          liftIO . putStrLn $ " - "++show u ++ " was not pressent or didn't decode!"
          return Nothing
        Right (Just g) -> do
          when debug . liftIO . putStrLn $ " - "++show u ++ " downloaded"          
          (mg', a) <- liftIO $ runRVar (mut g) StdRandom
          case mg' of
            Nothing -> do
              when debug . liftIO . putStrLn $ " - "++show u ++ " no action."
              return $ Just a
            Just g' | g' == g -> do
              when debug . liftIO . putStrLn $ " - "++show u ++ " updated but same"
              return $ Just a
            Just g' -> do
              when debug . liftIO . putStrLn $ " - "++show u ++ " updated"
              let bdy = BSL.toStrict . compress . JS.encode $ g'
              txRes <- multiExec $ do
                (fmap (const ())) <$> set ubs bdy
              case txRes of
                TxSuccess _ -> do
                  when debug . liftIO . putStrLn $ " - "++show u ++ " CAS"
                  return $ Just a
                TxAborted -> liftIO . E.throwM . BE.AssertionFailed $ "Raced"
                TxError err ->
                  -- liftIO . putStrLn $ " - Error on multi: "++err
                  liftIO . E.throwM . BE.AssertionFailed $ "retry"