module Network.Riak.Resolvable.Internal
(
Resolvable(..)
, ResolvableMonoid(..)
, get
, getMany
, put
, put_
, putMany
, putMany_
) where
import Control.Arrow (first)
import Control.Monad (unless)
import Data.Aeson.Types (FromJSON, ToJSON)
import Data.Data (Data)
import Data.Either (partitionEithers)
import Data.Function (on)
import Data.List (foldl', sortBy)
import Data.Monoid (Monoid(mappend))
import Data.Typeable (Typeable)
import Network.Riak.Debug (debugValues)
import Network.Riak.Types.Internal hiding (MessageTag(..))
class (Eq a, Show a) => Resolvable a where
resolve :: a -> a -> a
newtype ResolvableMonoid a = RM { unRM :: a }
deriving (Eq, Ord, Read, Show, Typeable, Data, Monoid, FromJSON, ToJSON)
instance (Eq a, Show a, Monoid a) => Resolvable (ResolvableMonoid a) where
resolve = mappend
instance (Resolvable a) => Resolvable (Maybe a) where
resolve (Just a) (Just b) = Just (resolve a b)
resolve a@(Just _) _ = a
resolve _ b = b
get :: (Resolvable a) =>
(Connection -> Bucket -> Key -> R -> IO (Maybe ([a], VClock)))
-> (Connection -> Bucket -> Key -> R -> IO (Maybe (a, VClock)))
get doGet conn bucket key r =
fmap (first resolveMany) `fmap` doGet conn bucket key r
getMany :: (Resolvable a) =>
(Connection -> Bucket -> [Key] -> R -> IO [Maybe ([a], VClock)])
-> Connection -> Bucket -> [Key] -> R -> IO [Maybe (a, VClock)]
getMany doGet conn b ks r =
map (fmap (first resolveMany)) `fmap` doGet conn b ks r
put :: (Resolvable a) =>
(Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
-> IO ([a], VClock))
-> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
-> IO (a, VClock)
put doPut conn bucket key mvclock0 val0 w dw = do
let go val mvclock1 = do
(xs, vclock) <- doPut conn bucket key mvclock1 val w dw
case xs of
[] -> return (val, vclock)
[v] | v == val -> return (val, vclock)
ys -> do debugValues "put" "conflict" ys
go (resolveMany' val ys) (Just vclock)
go val0 mvclock0
put_ :: (Resolvable a) =>
(Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
-> IO ([a], VClock))
-> Connection -> Bucket -> Key -> Maybe VClock -> a -> W -> DW
-> IO ()
put_ doPut conn bucket key mvclock0 val0 w dw =
put doPut conn bucket key mvclock0 val0 w dw >> return ()
putMany :: (Resolvable a) =>
(Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW
-> IO [([a], VClock)])
-> Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW
-> IO [(a, VClock)]
putMany doPut conn bucket puts0 w dw = go [] . zip [(0::Int)..] $ puts0 where
go acc [] = return . map snd . sortBy (compare `on` fst) $ acc
go acc puts = do
rs <- doPut conn bucket (map snd puts) w dw
let (conflicts, ok) = partitionEithers $ zipWith mush puts rs
unless (null conflicts) $
debugValues "putMany" "conflicts" conflicts
go (ok++acc) conflicts
mush (i,(k,_,c)) (cs,v) =
case cs of
[] -> Right (i,(c,v))
[x] | x == c -> Right (i,(c,v))
_ -> Left (i,(k,Just v, resolveMany' c cs))
putMany_ :: (Resolvable a) =>
(Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW
-> IO [([a], VClock)])
-> Connection -> Bucket -> [(Key, Maybe VClock, a)] -> W -> DW -> IO ()
putMany_ doPut conn bucket puts0 w dw =
putMany doPut conn bucket puts0 w dw >> return ()
resolveMany' :: (Resolvable a) => a -> [a] -> a
resolveMany' = foldl' resolve
resolveMany :: (Resolvable a) => [a] -> a
resolveMany (a:as) = resolveMany' a as
resolveMany _ = error "resolveMany: empty list"