Permalink
Browse files

Merge pull request #2 from f-me/master

merge plox
  • Loading branch information...
2 parents 1b0cec1 + 14ba665 commit 97235feb9b9aad6cdfa27c68b8974b121a56b0cb @dzhus committed Mar 29, 2012
View

Large diffs are not rendered by default.

Oops, something went wrong.
View
@@ -48,3 +48,30 @@ Archived entries from file /home/sphinx/projects/snaplet-redson/README.org
`/_/<formname>/` requests to emptyPage handler by checking `id`
parameter value in read handler.
+
+* DONE Allow any meta flags for fields
+ CLOSED: [2012-03-22 Чтв 02:41]
+ :PROPERTIES:
+ :ARCHIVE_TIME: 2012-03-22 Чтв 15:41
+ :ARCHIVE_FILE: ~/projects/snaplet-redson/README.org
+ :ARCHIVE_OLPATH: To do
+ :ARCHIVE_CATEGORY: README
+ :ARCHIVE_TODO: DONE
+ :END:
+ Field options which are not used by the server should be stored in
+ separate group and served back to client transparently. This way
+ we'll be able to modify models and client without fiddling with
+ Metamodel.hs.
+
+* DONE [#A] Faster search
+ CLOSED: [2012-03-22 Чтв 20:54]
+ :PROPERTIES:
+ :ARCHIVE_TIME: 2012-03-22 Чтв 20:54
+ :ARCHIVE_FILE: ~/projects/snaplet-redson/README.org
+ :ARCHIVE_OLPATH: To do
+ :ARCHIVE_CATEGORY: README
+ :ARCHIVE_TODO: DONE
+ :END:
+ We should support serving of results as a table (array of arrays)
+ to avoid redundant field names served with every matched instance.
+ Client should be able to set fields to be served in output.
View
@@ -11,6 +11,7 @@ category: Snap, Web
build-type: Simple
cabal-version: >=1.8
tested-with: GHC == 7.4.1
+stability: provisional
source-repository head
type: git
@@ -23,6 +24,7 @@ library
exposed-modules: Snap.Snaplet.Redson,
Snap.Snaplet.Redson.Snapless.CRUD,
Snap.Snaplet.Redson.Snapless.Metamodel,
+ Snap.Snaplet.Redson.Snapless.Metamodel.Loader,
Snap.Snaplet.Redson.Util
other-modules: Snap.Snaplet.Redson.Permissions,
Snap.Snaplet.Redson.Search
View
@@ -12,7 +12,8 @@ Can be used as Backbone.sync backend.
module Snap.Snaplet.Redson
( Redson
- , redsonInit)
+ , redsonInit
+ )
where
@@ -26,8 +27,8 @@ import Data.Aeson as A
import Data.Char (isDigit)
import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as LB (ByteString, readFile)
-import qualified Data.ByteString.UTF8 as BU (fromString, toString)
+import qualified Data.ByteString.Lazy as LB (ByteString)
+import qualified Data.ByteString.UTF8 as BU (toString)
import Data.Configurator
@@ -50,18 +51,17 @@ import qualified Network.WebSockets.Util.PubSub as PS
import Database.Redis hiding (auth)
-import System.EasyFile
import qualified Snap.Snaplet.Redson.Snapless.CRUD as CRUD
import Snap.Snaplet.Redson.Snapless.Metamodel
+import Snap.Snaplet.Redson.Snapless.Metamodel.Loader (loadModels)
import Snap.Snaplet.Redson.Permissions
import Snap.Snaplet.Redson.Search
import Snap.Snaplet.Redson.Util
+
------------------------------------------------------------------------------
-- | Redson snaplet state type.
---
--- *TODO*: Use HashMap to store models?
data Redson b = Redson
{ _database :: Snaplet RedisDB
, auth :: Lens b (Snaplet (AuthManager b))
@@ -157,12 +157,14 @@ modelMessage event = \model id ->
in
DataMessage $ Text $ A.encode $ M.fromList response
+
-- | Model instance creation message.
creationMessage :: ModelName
-> CRUD.InstanceId
-> Network.WebSockets.Message p
creationMessage = modelMessage "create"
+
-- | Model instance deletion message.
deletionMessage :: ModelName
-> CRUD.InstanceId
@@ -334,6 +336,7 @@ modelEvents = ifTop $ do
acceptRequest r
PS.subscribe ps)
+
------------------------------------------------------------------------------
-- | Serve JSON metamodel with respect to current user and field
-- permissions.
@@ -348,6 +351,7 @@ metamodel = ifTop $ do
modifyResponse $ setContentType "application/json"
writeLBS (A.encode $ stripModel au m)
+
------------------------------------------------------------------------------
-- | Serve JSON array of readable models to user. Every array element
-- is an object with fields "name" and "title". In transparent mode,
@@ -385,7 +389,7 @@ defaultSearchLimit = 100
-- | Serve model instances which have index values containing supplied
-- search parameters.
--
--- TODO Allow to request only subset of fields and serve them in array.
+-- Currently not available in transparent mode.
search :: Handler b (Redson b) ()
search =
let
@@ -395,6 +399,7 @@ search =
fetchInstance id key = runRedisDB database $ do
Right r <- hgetall key
return $ (M.fromList $ ("id", id):r)
+ comma = 0x2c
in
ifTop $ withCheckSecurity $ \_ mdl -> do
case mdl of
@@ -407,6 +412,8 @@ search =
mType <- getParam "_matchType"
sType <- getParam "_searchType"
iLimit <- getParam "_limit"
+ outFields <- (\p -> maybe [] (B.split comma) p) <$>
+ getParam "_fields"
patFunction <- return $ case mType of
Just "p" -> prefixMatch
@@ -437,6 +444,7 @@ search =
Just (i, s))
(indices m)
+ -- For every term, get list of ids which match it
termIds <- runRedisDB database $
redisSearch m (catMaybes indexValues) patFunction
@@ -445,14 +453,20 @@ search =
[] -> writeLBS $ A.encode ([] :: [Value])
tids -> do
-- Finally, list of matched instances
- instances <- mapM (\id -> fetchInstance id $
- CRUD.instanceKey mname id)
- (searchType tids)
- writeLBS $ A.encode (take itemLimit instances)
+ instances <- take itemLimit <$>
+ mapM (\id -> fetchInstance id $
+ CRUD.instanceKey mname id)
+ (searchType tids)
+ -- If _fields provided, leave only requested
+ -- fields and serve array of arrays. Otherwise,
+ -- serve array of objects.
+ case outFields of
+ [] -> writeLBS $ A.encode instances
+ _ -> writeLBS $ A.encode $
+ map (flip CRUD.onlyFields outFields) instances
return ()
-
-----------------------------------------------------------------------------
-- | CRUD routes for models.
routes :: [(B.ByteString, Handler b (Redson b) ())]
@@ -468,40 +482,6 @@ routes = [ (":model/timeline", method GET timeline)
]
--- | Build metamodel name from its file path.
-pathToModelName :: FilePath -> ModelName
-pathToModelName filepath = BU.fromString $ takeBaseName filepath
-
-
--- | Read all models from directory to a map, splicing group fields.
---
--- TODO: Perhaps rely on special directory file which explicitly lists
--- all models.
-loadModels :: FilePath -- ^ Models directory
- -> FilePath -- ^ Group definitions file
- -> IO (M.Map ModelName Model)
-loadModels directory groupsFile =
- let
- parseFile :: FromJSON a => FilePath -> IO a
- parseFile filename = do
- j <- LB.readFile filename
- case (A.decode j) of
- Just obj -> return obj
- Nothing -> error $ "Could not parse " ++ filename
- in
- do
- dirEntries <- getDirectoryContents directory
- -- Leave out non-files
- mdlFiles <- filterM doesFileExist
- (map (\f -> directory ++ "/" ++ f) dirEntries)
- groups <- parseFile groupsFile
- mdls <- mapM parseFile mdlFiles
- -- Splice groups & cache indices for served models
- return $ M.fromList $
- zip (map pathToModelName mdlFiles)
- (map (cacheIndices . spliceGroups groups) mdls)
-
-
------------------------------------------------------------------------------
-- | Connect to Redis and set routes.
redsonInit :: Lens b (Snaplet (AuthManager b))
@@ -21,14 +21,17 @@ import qualified Data.Map as M
import Snap.Core (Method(..))
import Snap.Snaplet.Auth
-import Snap.Snaplet.Redson.Snapless.Metamodel hiding (required)
+
+import Snap.Snaplet.Redson.Snapless.Metamodel
+
-- | User who has all permissions (used in security-disabled mode).
data SuperUser = SuperUser
-- | Either superuser or logged in user.
type User = Either SuperUser AuthUser
+
-- | Map between CRUD methods and form permission lenses.
methodMap :: [(Method, Lens Model Permissions)]
methodMap = [ (POST, canCreateM)
@@ -37,6 +40,7 @@ methodMap = [ (POST, canCreateM)
, (DELETE, canDeleteM)
]
+
-- | Check if provided roles meet the permission requirements.
--
-- Always succeed in case Everyone is required, always fail in case
@@ -78,7 +82,7 @@ getFieldPermissions (Right user) model =
(userRoles user))
(fields model)
in
- (union (getFields canRead) (getFields canWrite), getFields canWrite)
+ (union (getFields _canRead) (getFields _canWrite), getFields _canWrite)
-- | Get list of CRUD/HTTP methods accessible by user for model.
@@ -147,7 +151,7 @@ stripModel user model =
(\f -> elem (name f) readables)
(fields model)
-- Fields with boolean canWrite's
- strippedFields = map (\f -> f{canWrite = stripMapper $
+ strippedFields = map (\f -> f{_canWrite = stripMapper $
elem (name f) writables})
readableFields
formPerms = getModelPermissions user model
@@ -156,4 +160,4 @@ stripModel user model =
p ^= (stripMapper $ elem m formPerms))
methodMap
in
- foldl' (\m f -> f m) model{ fields = strippedFields } boolFormPerms
+ foldl' (\m f -> f m) model{fields = strippedFields} boolFormPerms
@@ -49,8 +49,8 @@ substringMatch model (field, value) =
------------------------------------------------------------------------------
--- | Redis action which returns list of instance id's matching given
--- search terms.
+-- | Redis action which returns list of matching instance id's for
+-- every search term.
redisSearch :: Model
-- ^ Model instances of which are being searched
-> [SearchTerm]
@@ -4,8 +4,6 @@
Snap-agnostic low-level CRUD operations.
-(This module may be refactored to a separate package.)
-
This module may be used for batch uploading of database data.
-}
@@ -20,6 +18,7 @@ module Snap.Snaplet.Redson.Snapless.CRUD
, modelIndex
, modelTimeline
, collate
+ , onlyFields
)
where
@@ -134,6 +133,7 @@ deleteIndices mname id commit =
mapM_ (\(i, v) -> srem (modelIndex mname i v) [id])
commit
+
------------------------------------------------------------------------------
-- | Get old values of index fields stored under key.
getOldIndices :: B.ByteString -> [FieldName] -> Redis [Maybe B.ByteString]
@@ -143,6 +143,13 @@ getOldIndices key findices = do
Left _ -> []
Right l -> l
+
+------------------------------------------------------------------------------
+-- | Extract values of named fields from commit.
+onlyFields :: Commit -> [FieldName] -> [Maybe FieldValue]
+onlyFields commit names = map (flip M.lookup commit) names
+
+
------------------------------------------------------------------------------
-- | Create new instance in Redis and indices for it.
--
Oops, something went wrong.

0 comments on commit 97235fe

Please sign in to comment.