Updated interface to be more similar to snaplet-postgresql-simple, bu…

…mped version

snaplet-riak.cabal

@@ -1,5 +1,5 @@
 name:                snaplet-riak
-version:             0.1.1.0
+version:             0.2.0.0
 synopsis:            A Snaplet for the Riak database
 -- description:         
 license:             MIT

src/Snap/Snaplet/Riak.hs

@@ -1,13 +1,15 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
--- | A Snaplet for using the Riak database (via the 'Network.Riak' package)
+-- | A Snaplet for using the Riak database (via the <http://hackage.haskell.org/package/riak riak> package)
+-- Modelled on <http://hackage.haskell.org/package/snaplet-postgresql-simple snaplet-postgresql-simple>
+
 module Snap.Snaplet.Riak
   ( RiakDB
   , withRiak
   , riakInit
   , riakCreate
-  , HasRiak(riak)
+  , HasRiak(getRiakState)
   , get
   , getMany
   , modify
@@ -44,21 +46,29 @@ import Data.Time.Clock
 import Data.Aeson.Types
 import Data.Sequence
 
--- | Riak Snaplet state
+-- | Riak Snaplet state. Stores a connection pool shared between handlers.
 data RiakDB = RiakDB
   { _pool :: Pool
   }
 
 makeLens ''RiakDB
 
+-- | A class which, when implemented, allows the wrapper functions below to
+-- be used without explicitly managing the connection and having to use liftIO.
+
+-- The wrappers are pretty mechanically defined, so Template Haskell could
+-- probably be used instead- especially since there are so many options in
+-- Network.Riak
+class MonadIO m => HasRiak m where
+  getRiakState :: m RiakDB
+
 -- | Perform an action using a Riak Connection in the Riak snaplet
 --
 -- > result <- withRiak $ \c -> get c "myBucket" "myKey" Default
-withRiak :: (MonadIO m, MonadState app m) =>
-  Lens app (Snaplet RiakDB) -> (Connection -> IO a) -> m a
-withRiak snaplet f = do
-  c <- gets $ getL (pool . snapletValue . snaplet)
-  liftIO $ withConnection c f
+withRiak :: (HasRiak m) => (Connection -> IO a) -> m a
+withRiak f = do
+  c <- getRiakState
+  liftIO $ withConnection (getL pool $ c) f
 
 -- | Utility function for creating the Riak snaplet from an Initializer
 makeRiak :: Initializer b v v -> SnapletInit b v
@@ -74,64 +84,52 @@ riakCreate c ns t nc = makeRiak $ do
   pool <- liftIO $ create c ns t nc
   return $ RiakDB pool
 
-class HasRiak a where
-  riak :: Lens a (Snaplet RiakDB)
-
--- | HasRiak wrappers around the database functions provided by Network.Riak.
--- The functions are pretty mechanically defined, so Template Haskell could
--- probably be used instead- especially since there are so many options...
-
 get ::
-  (HasRiak a, MonadIO m, MonadState a m, FromJSON c, ToJSON c, Resolvable c)
-  => Bucket -> Key -> R -> m (Maybe (c, VClock))
-get b k r = withRiak riak $ \conn -> R.get conn b k r
+  (HasRiak m, FromJSON a, ToJSON a, Resolvable a)
+  => Bucket -> Key -> R -> m (Maybe (a, VClock))
+get b k r = withRiak $ \conn -> R.get conn b k r
 
 getMany ::
-  (HasRiak a, MonadIO m, MonadState a m, FromJSON c, ToJSON c, Resolvable c)
-  => Bucket -> [Key] -> R -> m [Maybe (c, VClock)]
-getMany b ks r = withRiak riak $ \conn -> R.getMany conn b ks r
+  (HasRiak m, FromJSON a, ToJSON a, Resolvable a)
+  => Bucket -> [Key] -> R -> m [Maybe (a, VClock)]
+getMany b ks r = withRiak $ \conn -> R.getMany conn b ks r
 
 modify ::
-  (HasRiak app, MonadIO m, MonadState app m, FromJSON a, ToJSON a, Resolvable a)
+  (HasRiak m, FromJSON a, ToJSON a, Resolvable a)
   => Bucket -> Key -> R -> W -> DW -> (Maybe a -> IO (a, b))
   -> m (a, b)
-modify b k r w dw f = withRiak riak $ \conn -> R.modify conn b k r w dw f
+modify b k r w dw f = withRiak $ \conn -> R.modify conn b k r w dw f
 
 modify_ ::
-  (HasRiak app, MonadIO m, MonadState app m, FromJSON a, ToJSON a, Resolvable a)
+  (HasRiak m, FromJSON a, ToJSON a, Resolvable a)
   => Bucket -> Key -> R -> W -> DW -> (Maybe a -> IO a)
   -> m a
-modify_ b k r w dw f = withRiak riak $ \conn -> R.modify_ conn b k r w dw f
+modify_ b k r w dw f = withRiak $ \conn -> R.modify_ conn b k r w dw f
 
-delete :: (HasRiak a, MonadIO m, MonadState a m)
-  => Bucket -> Key -> RW -> m ()
-delete b k rw = withRiak riak $ \conn -> R.delete conn b k rw
+delete :: (HasRiak m) => Bucket -> Key -> RW -> m ()
+delete b k rw = withRiak $ \conn -> R.delete conn b k rw
 
 put :: 
-  (HasRiak a, MonadIO m, MonadState a m,
-  Eq c, FromJSON c, ToJSON c, Resolvable c)
-  => Bucket -> Key -> Maybe VClock -> c -> W -> DW -> m (c, VClock)
-put b k vc c w dw = withRiak riak $ \conn -> R.put conn b k vc c w dw
+  (HasRiak m, Eq a, FromJSON a, ToJSON a, Resolvable a)
+  => Bucket -> Key -> Maybe VClock -> a -> W -> DW -> m (a, VClock)
+put b k vc c w dw = withRiak $ \conn -> R.put conn b k vc c w dw
 
 putMany :: 
-  (HasRiak a, MonadIO m, MonadState a m,
-  Eq c, FromJSON c, ToJSON c, Resolvable c)
-  => Bucket -> [(Key, Maybe VClock, c)] -> W -> DW -> m [(c, VClock)]
-putMany b ks w dw = withRiak riak $ \conn -> R.putMany conn b ks w dw
+  (HasRiak m, Eq a, FromJSON a, ToJSON a, Resolvable a)
+  => Bucket -> [(Key, Maybe VClock, a)] -> W -> DW -> m [(a, VClock)]
+putMany b ks w dw = withRiak $ \conn -> R.putMany conn b ks w dw
 
-listBuckets :: (HasRiak a, MonadIO m, MonadState a m) => m (Seq Bucket)
-listBuckets = withRiak riak R.listBuckets
+listBuckets :: HasRiak m => m (Seq Bucket)
+listBuckets = withRiak R.listBuckets
 
-foldKeys :: (HasRiak a, MonadIO m, MonadState a m)
-  => Bucket -> (a -> Key -> IO a) -> a -> m a
-foldKeys b f x = withRiak riak $ \conn -> R.foldKeys conn b f x
+foldKeys :: HasRiak m => Bucket -> (a -> Key -> IO a) -> a -> m a
+foldKeys b f x = withRiak $ \conn -> R.foldKeys conn b f x
 
-getBucket :: (HasRiak a, MonadIO m, MonadState a m) => Bucket -> m BucketProps
-getBucket b = withRiak riak $ \conn -> R.getBucket conn b
+getBucket :: HasRiak m => Bucket -> m BucketProps
+getBucket b = withRiak $ \conn -> R.getBucket conn b
 
-setBucket :: (HasRiak a, MonadIO m, MonadState a m)
-  => Bucket -> BucketProps -> m ()
-setBucket b props = withRiak riak $ \conn -> R.setBucket conn b props
+setBucket :: HasRiak m  => Bucket -> BucketProps -> m ()
+setBucket b props = withRiak $ \conn -> R.setBucket conn b props
 
-mapReduce :: (HasRiak a, MonadIO m, MonadState a m) => Job -> (b -> MapReduce -> b) -> b -> m b
-mapReduce job f z0 = withRiak riak $ \conn -> R.mapReduce conn job f z0
+mapReduce :: HasRiak m => Job -> (a -> MapReduce -> a) -> a -> m a
+mapReduce job f z0 = withRiak $ \conn -> R.mapReduce conn job f z0