Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge pull request #5 from f-me/master

pull plox
  • Loading branch information...
commit a60a615c5456d8c5b15c0dce932fa93717816ea1 2 parents 97235fe + 59a91c2
Dmitry Dzhus authored
13 README.org
View
@@ -2,14 +2,17 @@
* Overview
This snaplet provides create-read-update-delete operations for any
- JSON objects with Redis storage. Role-based permissions system is
- supported.
+ JSON objects with Redis storage. JSON objects are mapped to Redis
+ hashes. Role-based permissions system is supported.
Primary notion of Redson is a model, or form, which is a named
collection of fields with certain extra annotations. Every filled
form («instance of model») has unique ID when stored in Redis.
- Models must be defined prior to usage with special syntax.
+ Models must be defined prior to usage with special syntax, which may
+ also be requested by client code to build interface for models
+ (using JavaScript templating, for example).
+
Transparent mode is supported in which model definitions are not
checked, but permissions engine is unavailable as well. Certain
transformations may be applied to model definition by server and
@@ -65,7 +68,7 @@
**** name
Field object must include `name` key which is the internal name of
- the field.
+ the field. Name is alphanumeric string.
`class` cannot be used as a field name.
@@ -323,7 +326,7 @@
**** Permissions processing
Response will contain original description but without fields
- unreadable by current user. canEdit field property will be set to
+ unreadable by current user. canWrite field property will be set to
boolean value for every form field, indicating whether the current
user can write to this field. Whole-form permissions will be set to
booleans as well, indicating whether the current user has specific
36 snaplet-redson.cabal
View
@@ -1,13 +1,42 @@
name: snaplet-redson
version: 0.1.0.0
synopsis: CRUD for JSON data with Redis storage
+
+description: This snaplet provides HTTP API to /c/reate, /r/ead,
+ /u/pdate and /d/elete JSON objects sent by client
+ and stored in Redis key-value cache. CRUD methods
+ are mapped to HTTP `POST`, `GET`, `PUT` and
+ `DELETE`. Valid objects are described using model
+ definition syntax, which includes information on
+ fields and permissions. The snaplet supports
+ role-based user permissions system as implemented
+ by Snap authentication. Model definitions may
+ also be used by browser JavaScript to provide
+ interface to create or edit objects.
+
+ There is a permission-less transparent mode,
+ WebSocket create/delete notifications and
+ timeline method to serve information about
+ recently added objects. Ad-hoc search is
+ implemented in Redis and provided via snaplet
+ route.
+
+ There's a "snapless" part of the package, which
+ implements Snap-agnostic Redis CRUD operations
+ for key-value pair collections and may be used
+ for tools which operate with storage directly
+ without using web framework.
+
+ More of usage documentation is contained in
+ <https://github.com/dzhus/snaplet-redson/blob/master/README.org>
+
homepage: https://github.com/dzhus/snaplet-redson/
bug-reports: https://github.com/dzhus/snaplet-redson/issues/
license: BSD3
license-file: LICENSE
author: Dmitry Dzhus
-maintainer: <dima@dzhus.org>
-category: Snap, Web
+maintainer: dima@dzhus.org
+category: Web, Snap
build-type: Simple
cabal-version: >=1.8
tested-with: GHC == 7.4.1
@@ -34,7 +63,7 @@ library
base == 4.*,
bytestring == 0.9.*,
configurator == 0.2.*,
- containers == 0.4.*,
+ containers >= 0.4.1 && < 0.5,
data-lens >= 2.0.1 && < 2.1,
data-lens-template == 2.1.*,
easy-file == 0.1.*,
@@ -44,6 +73,5 @@ library
snap-core == 0.8.*,
snaplet-redis == 0.1.*,
text == 0.11.*,
- utf8-string == 0.3.*,
websockets == 0.6.*,
websockets-snap == 0.6.*
128 src/Snap/Snaplet/Redson.hs
View
@@ -17,18 +17,16 @@ module Snap.Snaplet.Redson
where
-import Prelude hiding (concat, FilePath, id)
+import qualified Prelude (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
-import Data.Char (isDigit)
-
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB (ByteString)
-import qualified Data.ByteString.UTF8 as BU (toString)
import Data.Configurator
@@ -84,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.
@@ -106,9 +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
- return =<< withTop am action
+withAuth = (gets auth >>=) . flip withTop
------------------------------------------------------------------------------
@@ -175,29 +171,7 @@ deletionMessage = modelMessage "delete"
------------------------------------------------------------------------------
-- | Encode Redis HGETALL reply to B.ByteString with JSON.
commitToJson :: Commit -> LB.ByteString
-commitToJson r = A.encode r
-
-
-------------------------------------------------------------------------------
--- | Decode B.ByteString with JSON to map of hash keys & values for
--- Redis HMSET (still to be `toList`-ed).
---
--- Return Nothing if parsing failed.
---
--- Note that if JSON object contains `null` values, conversion will
--- fail.
-jsonToCommit :: LB.ByteString -> Maybe Commit
-jsonToCommit s =
- let
- j = A.decode s
- in
- case j of
- Nothing -> Nothing
- Just m ->
- -- Omit fields with null values and "id" key
- Just (M.filterWithKey
- (\k _ -> k /= "id")
- m)
+commitToJson = A.encode
------------------------------------------------------------------------------
@@ -227,28 +201,25 @@ post = ifTop $ do
-- the response SHOULD be 201 (Created) and contain an entity which
-- describes the status of the request and refers to the new
-- resource
- modifyResponse $ (setContentType "application/json" . setResponseCode 201)
+ modifyResponse $ setContentType "application/json" . setResponseCode 201
-- Tell client new instance id in response JSON.
writeLBS $ A.encode $ M.insert "id" newId commit
- return ()
------------------------------------------------------------------------------
-- | 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))
- return ()
+ writeLBS $ commitToJson $ filterUnreadable au mdl r
------------------------------------------------------------------------------
@@ -267,12 +238,11 @@ 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)
modifyResponse $ setResponseCode 204
- return ()
------------------------------------------------------------------------------
@@ -280,9 +250,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
@@ -370,8 +341,8 @@ listModels = ifTop $ do
Nothing -> handleError unauthorized >> return []
-- Leave only readable models.
Just user ->
- gets (filter (\(_, m) -> elem GET $
- getModelPermissions (Right user) m)
+ gets (filter (elem GET
+ . getModelPermissions (Right user) . snd)
. M.toList . models)
modifyResponse $ setContentType "application/json"
writeLBS (A.encode $
@@ -411,42 +382,29 @@ search =
-- TODO: Mark these field names as reserved
mType <- getParam "_matchType"
sType <- getParam "_searchType"
- iLimit <- getParam "_limit"
- outFields <- (\p -> maybe [] (B.split comma) p) <$>
+ outFields <- maybe [] (B.split comma) <$>
getParam "_fields"
- patFunction <- return $ case mType of
+ let patFunction = case mType of
Just "p" -> prefixMatch
Just "s" -> substringMatch
_ -> prefixMatch
- searchType <- return $ case sType of
+ let searchType = case sType of
Just "and" -> intersectAll
Just "or" -> unionAll
_ -> intersectAll
- itemLimit <- return $ case iLimit of
- Just b -> let
- s = BU.toString b
- in
- if (all isDigit s) then (read s)
- else defaultSearchLimit
- _ -> defaultSearchLimit
+ itemLimit <- fromIntParam "_limit" defaultSearchLimit
+ query <- fromMaybe "" <$> getParam "q"
-- Produce Just SearchTerm
- indexValues <- mapM (\(i, c) -> do
- p <- getParam i
- case p of
- Nothing -> return Nothing
- Just s -> if c then return $
- Just (i, CRUD.collate s)
- else return $
- Just (i, s))
- (indices m)
+ let collate c = if c then CRUD.collate else Prelude.id
+ let indexValues = map (mapSnd (`collate` query)) $ indices m
-- For every term, get list of ids which match it
termIds <- runRedisDB database $
- redisSearch m (catMaybes indexValues) patFunction
+ redisSearch m indexValues patFunction
modifyResponse $ setContentType "application/json"
case (filter (not . null) termIds) of
@@ -463,8 +421,11 @@ search =
case outFields of
[] -> writeLBS $ A.encode instances
_ -> writeLBS $ A.encode $
- map (flip CRUD.onlyFields outFields) instances
- return ()
+ map (`CRUD.onlyFields` outFields) instances
+
+
+mapSnd :: (b -> c) -> (a, b) -> (a, c)
+mapSnd f (a, b) = (a, f b)
-----------------------------------------------------------------------------
@@ -475,7 +436,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)
@@ -483,7 +444,18 @@ routes = [ (":model/timeline", method GET timeline)
------------------------------------------------------------------------------
--- | Connect to Redis and set routes.
+-- | Initialize Redson. AuthManager from parent snaplet is required.
+--
+-- Connect to Redis, read configuration and set routes.
+--
+-- > appInit :: SnapletInit MyApp MyApp
+-- > appInit = makeSnaplet "app" "App with Redson" Nothing $
+-- > do
+-- > r <- nestSnaplet "_" redson $ redsonInit auth
+-- > s <- nestSnaplet "session" session $ initCookieSessionManager
+-- > sesKey "_session" sessionTimeout
+-- > a <- nestSnaplet "auth" auth $ initJsonFileAuthManager defAuthSettings
+-- > return $ MyApp r s a
redsonInit :: Lens b (Snaplet (AuthManager b))
-> SnapletInit b (Redson b)
redsonInit topAuth = makeSnaplet
3  src/Snap/Snaplet/Redson/Search.hs
View
@@ -74,5 +74,4 @@ redisSearch model searchTerms patFunction =
return ids
in
-- Try to get search results for every index field
- mapM (\s -> getTermIds (patFunction mname s))
- searchTerms
+ mapM (getTermIds . (patFunction mname)) searchTerms
37 src/Snap/Snaplet/Redson/Snapless/CRUD.hs
View
@@ -2,7 +2,8 @@
{-|
-Snap-agnostic low-level CRUD operations.
+Snap-agnostic low-level CRUD operations. No model definitions are used
+on this level. Instead, objects must be
This module may be used for batch uploading of database data.
@@ -10,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
@@ -23,17 +25,16 @@ module Snap.Snaplet.Redson.Snapless.CRUD
where
-import Prelude hiding (id)
+import Prelude hiding (id, read)
import Control.Monad.State
import Data.Functor
import Data.Maybe
import Data.Char
-import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
-import qualified Data.ByteString.UTF8 as BU (fromString)
import qualified Data.Map as M
import Database.Redis
@@ -45,28 +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]
------------------------------------------------------------------------------
--- | Cut instance model and id from Redis key
---
--- >>> keyToId "case:32198"
--- 32198
-keyToId :: B.ByteString -> InstanceId
-keyToId key = B.tail $ B.dropWhile (/= 0x3a) key
-
-
-------------------------------------------------------------------------------
--- | 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"]
@@ -163,7 +155,7 @@ create :: ModelName -- ^ Model name
create mname commit findices = do
-- Take id from global:model:id
Right n <- incr $ modelIdKey mname
- newId <- return $ (BU.fromString . show) n
+ newId <- return $ (B.pack . show) n
-- Save new instance
_ <- hmset (instanceKey mname newId) (M.toList commit)
@@ -174,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
44 src/Snap/Snaplet/Redson/Snapless/Metamodel.hs
View
@@ -11,6 +11,7 @@ import Control.Applicative
import Data.Aeson
import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
import Data.Lens.Common
import Data.Lens.Template
@@ -30,7 +31,7 @@ type FieldValue = B.ByteString
type FieldIndex = (FieldName, Bool)
--- | List of field key-value pairs.
+-- | List of field key-value pairs, or contents of model isntance.
--
-- Suitable for using with 'Database.Redis.hmset'.
type Commit = M.Map FieldName FieldValue
@@ -184,6 +185,7 @@ instance FromJSON Application where
parseJSON _ = error "Could not parse application entry"
+-- | A named group of fields.
type Groups = M.Map B.ByteString [Field]
@@ -197,25 +199,19 @@ groupFieldName :: FieldName
groupFieldName parent field = B.concat [parent, "_", field]
--- | Replace all model fields having `group` type with actual group
--- fields.
+-- | Replace all model fields having `groupName` annotation with
+-- actual group fields.
spliceGroups :: Groups -> Model -> Model
spliceGroups groups model =
let
- origFields = fields model
+ updateNames f = fromMaybe [f] $ do
+ n <- groupName f
+ grp <- M.lookup n groups
+ return $ map (\gf -> gf{ groupName = Just n
+ , name = groupFieldName (name f) (name gf)
+ }) grp
in
- model{fields = concat $
- map (\f ->
- case groupName f of
- Just n ->
- case (M.lookup n groups) of
- Just grp ->
- map (\gf -> gf{ groupName = Just n
- , name = groupFieldName (name f) (name gf)
- }) grp
- Nothing -> [f]
- _ -> [f]
- ) origFields}
+ model{fields = concatMap updateNames $ fields model}
-- | Perform all applications in model.
@@ -273,3 +269,19 @@ cacheIndices model =
_ -> indexList
in
model{indices = foldl' maybeCacheIndex [] (fields model)}
+
+
+------------------------------------------------------------------------------
+-- | Decode B.ByteString with JSON containing hash of commit keys and
+-- values to actual 'Commit'.
+--
+-- Return Nothing if parsing failed.
+--
+-- @id@ key is omitted from result.
+--
+-- Note that if JSON object contains `null` values, conversion will
+-- fail.
+jsonToCommit :: LB.ByteString -> Maybe Commit
+jsonToCommit s =
+ M.filterWithKey (const (/= "id"))
+ <$> decode s
22 src/Snap/Snaplet/Redson/Snapless/Metamodel/Loader.hs
View
@@ -20,7 +20,7 @@ import Data.Aeson as A
import Data.Functor
-import qualified Data.ByteString.UTF8 as BU (fromString)
+import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB (readFile)
import qualified Data.Map as M
@@ -47,20 +47,16 @@ loadModel :: FilePath
-> Groups
-- ^ Group definitions
-> IO (Maybe Model)
-loadModel modelFile groups =
- do
- mres <- parseFile modelFile
- return $ case mres of
- Just model -> Just $
- cacheIndices $
- doApplications $
- spliceGroups groups model
- Nothing -> Nothing
+loadModel modelFile groups
+ = (fmap $ cacheIndices
+ . doApplications
+ . spliceGroups groups)
+ <$> parseFile modelFile
-- | Build metamodel name from its file path.
pathToModelName :: FilePath -> ModelName
-pathToModelName filepath = BU.fromString $ takeBaseName filepath
+pathToModelName filepath = B.pack $ takeBaseName filepath
-- | Read all models from directory to a map.
@@ -75,13 +71,13 @@ loadModels directory groupsFile =
dirEntries <- getDirectoryContents directory
-- Leave out non-files
mdlFiles <- filterM doesFileExist
- (map (\f -> directory ++ "/" ++ f) dirEntries)
+ (map (directory </>) dirEntries)
gs <- loadGroups groupsFile
case gs of
Just groups -> do
mdls <- mapM (\m -> do
mres <- loadModel m groups
- return $ case mres of
+ return $! case mres of
Just mdl -> mdl
Nothing -> error $ "Could not parse " ++ m
) mdlFiles
14 src/Snap/Snaplet/Redson/Util.hs
View
@@ -10,7 +10,11 @@ module Snap.Snaplet.Redson.Util where
import Control.Applicative
+import Data.Char (isDigit)
+
import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B8 (readInt)
+
import Data.Maybe
import Snap.Core
@@ -21,6 +25,16 @@ fromParam :: MonadSnap m => ByteString -> m ByteString
fromParam p = fromMaybe "" <$> getParam p
+------------------------------------------------------------------------------
+-- | Get integer parameter value from Request or return default value.
+fromIntParam :: MonadSnap m => ByteString -> Int -> m Int
+fromIntParam p def = do
+ i <- getParam p
+ return $ case i >>= B8.readInt of
+ Just (j, "") -> j
+ _ -> def
+
+
data Error = Error { code :: Int
-- ^ Error response code
}
Please sign in to comment.
Something went wrong with that request. Please try again.