Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add CRUD.read and use it in HTTP interface, rewrite getInstanceKey

helper, cleanups
  • Loading branch information...
commit 86334be29c469e49e310fd71919060f38741977a 1 parent c9e9d75
@dzhus authored
Showing with 35 additions and 29 deletions.
  1. +20 −24 src/Snap/Snaplet/Redson.hs
  2. +15 −5 src/Snap/Snaplet/Redson/Snapless/CRUD.hs
View
44 src/Snap/Snaplet/Redson.hs
@@ -18,10 +18,10 @@ module Snap.Snaplet.Redson
where
import qualified Prelude (id)
-import Prelude hiding (concat, FilePath, id)
+import Prelude hiding (concat, FilePath, id, read)
+import Control.Applicative
import Control.Monad.State hiding (put)
-import Data.Functor
import Data.Aeson as A
@@ -82,15 +82,15 @@ getModelName = fromParam "model"
------------------------------------------------------------------------------
-- | Extract model instance id from request parameter.
-getModelId:: MonadSnap m => m CRUD.InstanceId
-getModelId = fromParam "id"
-
+getInstanceId:: MonadSnap m => m CRUD.InstanceId
+getInstanceId = fromParam "id"
------------------------------------------------------------------------------
-- | Extract model instance Redis key from request parameters.
-getInstanceKey :: MonadSnap m => m B.ByteString
-getInstanceKey = liftM2 CRUD.instanceKey getModelName getModelId
+getInstanceKey :: MonadSnap m => m (ModelName, CRUD.InstanceId)
+getInstanceKey = (,) <$> getModelName <*> getInstanceId
+
------------------------------------------------------------------------------
-- | Try to get Model for current request.
@@ -104,11 +104,7 @@ getModel = liftM2 M.lookup getModelName (gets models)
-- | Perform action with AuthManager.
withAuth :: (MonadState (Redson b1) (m b1 v), MonadSnaplet m) =>
m b1 (AuthManager b1) b -> m b1 v b
-withAuth action = do
- am <- gets auth
- withTop am action
--- Pointfree is more concise but less readable
--- withAuth = (gets auth >>=) . flip withTop
+withAuth = (gets auth >>=) . flip withTop
------------------------------------------------------------------------------
@@ -227,19 +223,18 @@ post = ifTop $ do
------------------------------------------------------------------------------
-- | Read instance from Redis.
-read' :: Handler b (Redson b) ()
-read' = ifTop $ do
+get' :: Handler b (Redson b) ()
+get' = ifTop $ do
withCheckSecurity $ \au mdl -> do
- key <- getInstanceKey
- r <- runRedisDB database $ do
- Right r <- hgetall key
- return r
+ (mname, id) <- getInstanceKey
+
+ Right r <- runRedisDB database $ CRUD.read mname id
- when (null r) $
+ when (M.null r) $
handleError notFound
modifyResponse $ setContentType "application/json"
- writeLBS $ commitToJson $ filterUnreadable au mdl (M.fromList r)
+ writeLBS $ commitToJson $ filterUnreadable au mdl r
------------------------------------------------------------------------------
@@ -258,7 +253,7 @@ put = ifTop $ do
when (not $ checkWrite au mdl j) $
handleError forbidden
- id <- getModelId
+ id <- getInstanceId
mname <- getModelName
Right _ <- runRedisDB database $
CRUD.update mname id j (maybe [] indices mdl)
@@ -270,9 +265,10 @@ put = ifTop $ do
delete :: Handler b (Redson b) ()
delete = ifTop $ do
withCheckSecurity $ \_ mdl -> do
- id <- getModelId
mname <- getModelName
- key <- getInstanceKey
+ id <- getInstanceId
+
+ let key = CRUD.instanceKey mname id
r <- runRedisDB database $ do
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec9.html#sec9.7
@@ -454,7 +450,7 @@ routes = [ (":model/timeline", method GET timeline)
, (":model/model", method GET metamodel)
, ("_models", method GET listModels)
, (":model", method POST post)
- , (":model/:id", method GET read')
+ , (":model/:id", method GET get')
, (":model/:id", method PUT put)
, (":model/:id", method DELETE delete)
, (":model/search/", method GET search)
View
20 src/Snap/Snaplet/Redson/Snapless/CRUD.hs
@@ -11,6 +11,7 @@ This module may be used for batch uploading of database data.
module Snap.Snaplet.Redson.Snapless.CRUD
( -- * CRUD operations
create
+ , read
, update
, delete
-- * Redis helpers
@@ -24,7 +25,7 @@ module Snap.Snaplet.Redson.Snapless.CRUD
where
-import Prelude hiding (id)
+import Prelude hiding (id, read)
import Control.Monad.State
import Data.Functor
@@ -45,19 +46,19 @@ type InstanceId = B.ByteString
------------------------------------------------------------------------------
--- | Build Redis key given model name and instance id
+-- | Build Redis key given model name and instance id.
instanceKey :: ModelName -> InstanceId -> B.ByteString
instanceKey model id = B.concat [model, ":", id]
------------------------------------------------------------------------------
--- | Get Redis key which stores id counter for model
+-- | Get Redis key which stores id counter for model.
modelIdKey :: ModelName -> B.ByteString
modelIdKey model = B.concat ["global:", model, ":id"]
------------------------------------------------------------------------------
--- | Get Redis key which stores timeline for model
+-- | Get Redis key which stores timeline for model.
modelTimeline :: ModelName -> B.ByteString
modelTimeline model = B.concat ["global:", model, ":timeline"]
@@ -165,7 +166,16 @@ create mname commit findices = do
------------------------------------------------------------------------------
--- | Modify existing instance in Redis, updating indices
+-- | Read existing instance from Redis.
+read :: ModelName
+ -> InstanceId
+ -> Redis (Either Reply Commit)
+read mname id = (fmap M.fromList) <$> hgetall key
+ where
+ key = instanceKey mname id
+
+------------------------------------------------------------------------------
+-- | Modify existing instance in Redis, updating indices.
--
-- TODO: Handle non-existing instance as error here?
update :: ModelName
Please sign in to comment.
Something went wrong with that request. Please try again.