Permalink
Browse files

Field applications

  • Loading branch information...
1 parent 7751398 commit f29e16de88bbae6e1a2f155783a88e66ce1dfcf0 @dzhus committed Mar 29, 2012
Showing with 146 additions and 12 deletions.
  1. +42 −0 README.org
  2. +103 −12 src/Snap/Snaplet/Redson/Snapless/Metamodel.hs
  3. +1 −0 src/Snap/Snaplet/Redson/Snapless/Metamodel/Loader.hs
View
42 README.org
@@ -58,6 +58,9 @@
List of field objects, where every field object has keys listed
below.
+**** applications
+ List of application objects which target many fields at once (see
+ below).
*** Valid field keys
**** name
@@ -276,6 +279,40 @@
- Attempt to create or update instances with unwritable fields
will be rejected with 403 Forbidden.
+*** Field applications
+ It's possible to change certain annotations for many fields in
+ model with one instruction. `application` key of form definition
+ contains a list of application objects. Every application object
+ may contain `canRead`, `canWrite` and `meta` keys with same syntax
+ as in fields. Additionally, `targets` keys must be present. If
+ `targets` is a list of field names, then new values for `canRead`,
+ `canWrite` are set for matched fields. `true` value of `targets`
+ matches every field. `meta` values from application and matched
+ field are merged, with meta keys from application having
+ precedence over field meta.
+
+ Example (set new label and foo meta, new permissions for all fields):
+ #+BEGIN_SRC javascript
+ {
+ "targets": true,
+ "meta": {
+ "label": "Renamed label",
+ "foo": "bar"
+ },
+ "canRead": ["changed_role"],
+ "canWrite": false
+ }
+ #+END_SRC
+
+ Example (change label of "foo" field):
+ #+BEGIN_SRC javascript
+ {
+ "targets": ["foo"],
+ "meta": {
+ "label": "Foo field"
+ }
+ }
+ #+END_SRC
*** Served models
Client may request stripped form description by sending this
request:
@@ -318,6 +355,11 @@
then `foo` will be *spliced into* fields named `foo_f1`, `foo_f2`
and `foo_f3`, and `groupName` for all these fields will be set to
`bar`.
+**** Applications
+ Applications are performed (in sequence following the order
+ they're listed in model definition) *after* group splicing, which
+ means applications may be used to override default field
+ annotations set for group members in `field-groups-file`.
**** Index fields list caching
Served form will also contain `indices` field which is a list of
View
115 src/Snap/Snaplet/Redson/Snapless/Metamodel.hs
@@ -13,11 +13,14 @@ import Control.Applicative
import Data.Aeson
import qualified Data.ByteString as B
+import Data.Lens.Common
import Data.Lens.Template
import Data.List
+import Data.Maybe
import qualified Data.Map as M
+
type ModelName = B.ByteString
-- | Field name.
@@ -29,6 +32,7 @@ type FieldValue = B.ByteString
-- | Name of indexed field and collation flag.
type FieldIndex = (FieldName, Bool)
+
-- | List of field key-value pairs.
--
-- Suitable for using with 'Database.Redis.hmset'.
@@ -41,31 +45,53 @@ data Permissions = Roles [B.ByteString]
| Nobody
deriving Show
+
+data FieldTargets = Fields [FieldName]
+ | AllFields
+ | NoneFields
+ deriving Show
+
+
-- | Map of field annotations which are transparently handled by
-- server without any logic.
type FieldMeta = M.Map FieldName Value
+
-- | Form field object.
data Field = Field { name :: FieldName
, fieldType :: B.ByteString
, index :: Bool
, indexCollate :: Bool
, groupName :: Maybe B.ByteString
, meta :: Maybe FieldMeta
- , canRead :: Permissions
- , canWrite :: Permissions
+ , _canRead :: Permissions
+ , _canWrite :: Permissions
}
deriving Show
+makeLenses [''Field]
+
+
+-- | A list of properties to be applied to named fields.
+data Application = Application { targets :: FieldTargets
+ , apMeta :: Maybe FieldMeta
+ , _apRead :: Maybe Permissions
+ , _apWrite :: Maybe Permissions
+ }
+ deriving Show
+
+makeLenses [''Application]
+
-- | Model describes fields and permissions.
--
-- Models are built from JSON definitions (using FromJSON instance for
--- Model) with further group splicing ('spliceGroups') and index
--- caching ('cacheIndices').
+-- Model) with further group splicing ('spliceGroups'), applications
+-- ('doApplications') and index caching ('cacheIndices').
data Model = Model { modelName :: ModelName
, title :: B.ByteString
, fields :: [Field]
+ , applications :: [Application]
, _canCreateM :: Permissions
, _canReadM :: Permissions
, _canUpdateM :: Permissions
@@ -87,6 +113,7 @@ instance FromJSON Model where
v .: "name" <*>
v .: "title" <*>
v .: "fields" <*>
+ v .:? "applications" .!= [] <*>
v .:? "canCreate" .!= Nobody <*>
v .:? "canRead" .!= Nobody <*>
v .:? "canUpdate" .!= Nobody <*>
@@ -138,14 +165,31 @@ instance ToJSON Field where
, "index" .= index f
, "indexCollate" .= indexCollate f
, "groupName" .= groupName f
- , "canRead" .= canRead f
- , "canWrite" .= canWrite f
+ , "canRead" .= _canRead f
+ , "canWrite" .= _canWrite f
, "meta" .= meta f
]
+instance FromJSON FieldTargets where
+ parseJSON (Bool True) = return AllFields
+ parseJSON (Bool False) = return NoneFields
+ parseJSON v@(Array _) = Fields <$> parseJSON v
+ parseJSON _ = error "Could not application targets"
+
+
+instance FromJSON Application where
+ parseJSON (Object v) = Application <$>
+ v .:? "targets" .!= NoneFields <*>
+ v .:? "meta" <*>
+ v .:? "canRead" <*>
+ v .:? "canWrite"
+ parseJSON _ = error "Could not parse application entry"
+
+
type Groups = M.Map B.ByteString [Field]
+
-- | Build new name `f_gK` for every field of group `g` to which field
-- `f` is spliced into.
groupFieldName :: FieldName
@@ -155,6 +199,7 @@ groupFieldName :: FieldName
-> FieldName
groupFieldName parent field = B.concat [parent, "_", field]
+
-- | Replace all model fields having `group` type with actual group
-- fields.
spliceGroups :: Groups -> Model -> Model
@@ -176,12 +221,58 @@ spliceGroups groups model =
) origFields}
+-- | Perform all applications in model.
+doApplications :: Model -> Model
+doApplications model =
+ let
+ -- Update values in old meta with those specified in
+ -- application meta
+ mergeFieldsMeta :: Maybe FieldMeta -> Field -> Field
+ mergeFieldsMeta (Just patchMeta) original =
+ let
+ oldMeta = fromMaybe M.empty (meta original)
+ -- TODO Monoid is out there
+ newMeta =
+ M.foldlWithKey' (\o k v -> M.insert k v o) oldMeta patchMeta
+ in
+ original{meta = Just newMeta}
+ mergeFieldsMeta Nothing original = original
+
+ -- Try to perform application for fields in list.
+ processField :: [Field] -> Application -> [Field]
+ processField (f:fs) ap =
+ let
+ -- List of setters to apply to field which will update
+ -- it with application values
+ patchBits :: [Field -> Field]
+ patchBits = [mergeFieldsMeta (apMeta ap)] ++
+ map (\(from, to) ->
+ maybe id (to ^=) (ap ^. from))
+ [ (apRead, canRead)
+ , (apWrite, canWrite)
+ ]
+ patch = foldl1' (.) patchBits
+ -- Meta field is merged separately
+ newF = case targets ap of
+ AllFields -> patch f
+ Fields ts -> if (elem (name f) ts)
+ then patch f
+ else f
+ _ -> f
+ in
+ newF:(processField fs ap)
+ processField [] _ = []
+ in
+ model{fields = foldl' processField (fields model) (applications model)}
+
+
-- | Set indices field of model to list of 'FieldIndex'es
cacheIndices :: Model -> Model
cacheIndices model =
- model{indices = foldl'
- (\l f -> case (index f, indexCollate f) of
- (True, c) -> (name f, c):l
- _ -> l
- )
- [] (fields model)}
+ let
+ maybeCacheIndex indexList field =
+ case (index field, indexCollate field) of
+ (True, c) -> (name field, c):indexList
+ _ -> indexList
+ in
+ model{indices = foldl' maybeCacheIndex [] (fields model)}
View
1 src/Snap/Snaplet/Redson/Snapless/Metamodel/Loader.hs
@@ -53,6 +53,7 @@ loadModel modelFile groups =
return $ case mres of
Just model -> Just $
cacheIndices $
+ doApplications $
spliceGroups groups model
Nothing -> Nothing

0 comments on commit f29e16d

Please sign in to comment.