Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

pull plox #5

Merged
merged 14 commits into from

3 participants

@dzhus
Owner

No description provided.

@dzhus
Owner

Что там починили в 0.4.1?

попытка собрать с 0.4.0 показала, что не хватает foldlWithKey'

@dzhus
Owner

Всё супер

@dzhus
Owner

Тут не очень понятно, зачем эти изменения?

@dzhus
Owner

Это чтобы система не запускалась сразу, если есть покоцаные модели.

@dzhus dzhus merged commit a60a615 into from
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Apr 1, 2012
Commits on Apr 5, 2012
  1. Note on hashes

    authored
  2. More notes

    authored
  3. Web, Snap

    authored
Commits on Apr 6, 2012
  1. @tymmym

    Fixed containers version

    tymmym authored
Commits on Apr 13, 2012
  1. @jorpic

    one query string for all fields

    jorpic authored
  2. @jorpic

    peephole refactoring

    jorpic authored
Commits on Apr 21, 2012
  1. Minor clarifications

    authored
  2. Documentation fix

    authored
Commits on Apr 22, 2012
Commits on Apr 23, 2012
Commits on Apr 24, 2012
This page is out of date. Refresh to see the latest.
View
13 README.org
@@ -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
View
36 snaplet-redson.cabal
@@ -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.*
View
128 src/Snap/Snaplet/Redson.hs
@@ -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
View
3  src/Snap/Snaplet/Redson/Search.hs
@@ -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
View
37 src/Snap/Snaplet/Redson/Snapless/CRUD.hs
@@ -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
View
44 src/Snap/Snaplet/Redson/Snapless/Metamodel.hs
@@ -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
View
22 src/Snap/Snaplet/Redson/Snapless/Metamodel/Loader.hs
@@ -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
View
14 src/Snap/Snaplet/Redson/Util.hs
@@ -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
}
Something went wrong with that request. Please try again.