Commits

Bryan O'Sullivan  committed 00bfe58

Add support for type-safe and auto-resolved gets and puts.

  • Participants
  • Parent commits 805ac46

Comments (0)

Files changed (3)

     Network.Riak.Connection
     Network.Riak.Content
     Network.Riak.Debug
+    Network.Riak.Monoid
     Network.Riak.Request
     Network.Riak.Response
     Network.Riak.Basic
     Network.Riak.Types
+    Network.Riak.Value
     Network.Riak.Protocol.ServerInfo
     Network.Riak.Protocol.BucketProps
     Network.Riak.Protocol.Content
   
   build-depends:       
     aeson,
+    attoparsec >= 0.8.4.0,
     base == 4.*,
     binary,
     bytestring,

File src/Network/Riak/Monoid.hs

+{-# LANGUAGE RecordWildCards #-}
+
+module Network.Riak.Monoid
+    (
+      V.IsContent(..)
+    , V.JSON(plain)
+    , V.json
+    , get
+    , getMany
+    , put
+    ) where
+
+import Control.Arrow (first)
+import Data.Monoid (Monoid(..))
+import Network.Riak.Types.Internal hiding (MessageTag(..))
+import qualified Network.Riak.Value as V
+
+get :: (Monoid c, V.IsContent c) =>
+       Connection -> Bucket -> Key -> R -> IO (Maybe (c, VClock))
+get conn bucket key r = fmap (first mconcat) `fmap` V.get conn bucket key r
+
+getMany :: (Monoid c, V.IsContent c) => Connection -> [(Bucket, Key)] -> R
+        -> IO [Maybe (c, VClock)]
+getMany conn bks r = map (fmap (first mconcat)) `fmap` V.getMany conn bks r
+
+put :: (Monoid c, V.IsContent c) =>
+       Connection -> Bucket -> Key -> Maybe VClock -> c -> W -> DW
+    -> IO (c, VClock)
+put conn bucket key mvclock0 val0 w dw = do
+  let go val mvclock1 = do
+        (xs, vclock) <- V.put conn bucket key mvclock1 val w dw
+        case xs of
+          [c] -> return (c, vclock)
+          _   -> go (mconcat xs) (Just vclock)
+  go val0 mvclock0

File src/Network/Riak/Value.hs

+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+
+module Network.Riak.Value
+    (
+      IsContent(..)
+    , JSON(plain)
+    , json
+    , get
+    , getMany
+    , put
+    , put_
+    , putMany
+    , putMany_
+    ) where
+
+import Data.Attoparsec.Lazy (maybeResult, parse)
+import Data.Foldable (toList)
+import Network.Riak.Connection.Internal
+import Network.Riak.Protocol.Content (Content(..))
+import Network.Riak.Protocol.GetResponse (GetResponse(..))
+import Network.Riak.Protocol.PutResponse (PutResponse(..))
+import Network.Riak.Types.Internal hiding (MessageTag(..))
+import qualified Data.Aeson.Parser as Aeson
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Sequence as Seq
+import qualified Network.Riak.Content as C
+import qualified Network.Riak.Request as Req
+
+class IsContent c where
+    fromContent :: Content -> Maybe c
+    toContent :: c -> Content
+
+instance IsContent Content where
+    fromContent = Just
+    {-# INLINE fromContent #-}
+
+    toContent v = v
+    {-# INLINE toContent #-}
+
+instance IsContent () where
+    fromContent c | c == C.empty = Just ()
+                  | otherwise    = Nothing
+    {-# INLINE fromContent #-}
+
+    toContent _ = C.empty
+    {-# INLINE toContent #-}
+
+instance IsContent Aeson.Value where
+    fromContent c | content_type c == Just "application/json" =
+                      maybeResult (parse Aeson.json (value c))
+                  | otherwise = Nothing
+
+    toContent = C.json
+    {-# INLINE toContent #-}
+
+newtype JSON a = J {
+      plain :: a
+    } deriving (Eq, Ord, Show, Read, Bounded)
+
+json :: (Aeson.FromJSON a, Aeson.ToJSON a) => a -> JSON a
+json = J
+{-# INLINE json #-}
+
+instance (Aeson.FromJSON a, Aeson.ToJSON a) => IsContent (JSON a) where
+    fromContent c = J `fmap` (fromContent c >>= Aeson.fromJSON)
+
+    toContent (J a) = toContent (Aeson.toJSON a)
+
+put :: (IsContent c) => Connection -> Bucket -> Key -> Maybe VClock -> c
+    -> W -> DW -> IO ([c], VClock)
+put conn bucket key mvclock val w dw =
+  putResp =<< exchange conn
+              (Req.put bucket key mvclock (toContent val) w dw True)
+
+putMany :: (IsContent c) => Connection -> [(Bucket, Key, Maybe VClock, c)]
+        -> W -> DW -> IO [([c], VClock)]
+putMany conn puts w dw =
+  mapM putResp =<< pipeline conn (map (\(b,k,v,c) -> Req.put b k v (toContent c) w dw True) puts)
+
+putResp :: (IsContent c) => PutResponse -> IO ([c], VClock)
+putResp PutResponse{..} = do
+  case vclock of
+    Nothing -> return ([], VClock L.empty)
+    Just s  -> do
+      c <- convert content
+      return (c, VClock s)
+
+put_ :: (IsContent c) => Connection -> Bucket -> Key -> Maybe VClock -> c
+    -> W -> DW -> IO ()
+put_ conn bucket key mvclock val w dw =
+  exchange_ conn (Req.put bucket key mvclock (toContent val) w dw False)
+
+putMany_ :: (IsContent c) => Connection -> [(Bucket, Key, Maybe VClock, c)]
+         -> W -> DW -> IO ()
+putMany_ conn puts w dw =
+  pipeline_ conn . map (\(b,k,v,c) -> Req.put b k v (toContent c) w dw False) $ puts
+
+get :: (IsContent c) => Connection -> Bucket -> Key -> R
+    -> IO (Maybe ([c], VClock))
+get conn bucket key r = getResp =<< exchangeMaybe conn (Req.get bucket key r)
+
+getMany :: (IsContent c) => Connection -> [(Bucket, Key)] -> R
+        -> IO [Maybe ([c], VClock)]
+getMany conn bks r =
+    mapM getResp =<< pipelineMaybe conn (map (\(b,k) -> Req.get b k r) bks)
+
+getResp :: (IsContent c) => Maybe GetResponse -> IO (Maybe ([c], VClock))
+getResp resp =
+  case resp of
+    Just (GetResponse content (Just s)) -> do
+      c <- convert content
+      return $ Just (c, VClock s)
+    _   -> return Nothing
+
+convert :: IsContent v => Seq.Seq Content -> IO [v]
+convert = go [] [] . toList
+    where go cs vs (x:xs) = case fromContent x of
+                              Just v -> go cs (v:vs) xs
+                              _      -> go (x:cs) vs xs
+          go [] vs _      = return (reverse vs)
+          go cs _  _      = typeError "Network.Riak.Value" "convert" $
+                            show (length cs) ++ " values failed conversion: " ++
+                            show cs