Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 59a91c216d
Fetching contributors…

Cannot retrieve contributors at this time

288 lines (231 sloc) 9.302 kB
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Model definition parser, served model routines.
module Snap.Snaplet.Redson.Snapless.Metamodel
where
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
import Data.List
import Data.Maybe
import qualified Data.Map as M
type ModelName = B.ByteString
type FieldName = B.ByteString
type FieldValue = B.ByteString
-- | Name of indexed field and collation flag.
type FieldIndex = (FieldName, Bool)
-- | List of field key-value pairs, or contents of model isntance.
--
-- Suitable for using with 'Database.Redis.hmset'.
type Commit = M.Map FieldName FieldValue
-- | Field permissions property.
data Permissions = Roles [B.ByteString]
| Everyone
| 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
}
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'), applications
-- ('doApplications') and index caching ('cacheIndices').
data Model = Model { modelName :: ModelName
, title :: B.ByteString
, fields :: [Field]
, applications :: [Application]
, _canCreateM :: Permissions
, _canReadM :: Permissions
, _canUpdateM :: Permissions
, _canDeleteM :: Permissions
, indices :: [FieldIndex]
-- ^ Cached list of index fields.
}
deriving Show
makeLenses [''Model]
-- | Used when field type is not specified in model description.
defaultFieldType :: B.ByteString
defaultFieldType = "text"
instance FromJSON Model where
parseJSON (Object v) = Model <$>
v .: "name" <*>
v .: "title" <*>
v .: "fields" <*>
v .:? "applications" .!= [] <*>
v .:? "canCreate" .!= Nobody <*>
v .:? "canRead" .!= Nobody <*>
v .:? "canUpdate" .!= Nobody <*>
v .:? "canDelete" .!= Nobody <*>
pure []
parseJSON _ = error "Could not parse model description"
instance ToJSON Model where
toJSON mdl = object
[ "name" .= modelName mdl
, "title" .= title mdl
, "fields" .= fields mdl
, "indices" .= indices mdl
, "canCreate" .= _canCreateM mdl
, "canRead" .= _canReadM mdl
, "canUpdate" .= _canUpdateM mdl
, "canDelete" .= _canDeleteM mdl
]
instance FromJSON Permissions where
parseJSON (Bool True) = return Everyone
parseJSON (Bool False) = return Nobody
parseJSON v@(Array _) = Roles <$> parseJSON v
parseJSON _ = error "Could not permissions"
instance ToJSON Permissions where
toJSON Everyone = Bool True
toJSON Nobody = Bool False
toJSON (Roles r) = toJSON r
instance FromJSON Field where
parseJSON (Object v) = Field <$>
v .: "name" <*>
v .:? "type" .!= defaultFieldType <*>
v .:? "index" .!= False <*>
v .:? "indexCollate" .!= False <*>
v .:? "groupName" <*>
v .:? "meta" <*>
v .:? "canRead" .!= Nobody <*>
v .:? "canWrite" .!= Nobody
parseJSON _ = error "Could not parse field properties"
instance ToJSON Field where
toJSON f = object
[ "name" .= name f
, "type" .= fieldType f
, "index" .= index f
, "indexCollate" .= indexCollate f
, "groupName" .= groupName 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"
-- | A named group of fields.
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
-- ^ Name of field which is spliced into group
-> FieldName
-- ^ Name of group field
-> FieldName
groupFieldName parent field = B.concat [parent, "_", field]
-- | Replace all model fields having `groupName` annotation with
-- actual group fields.
spliceGroups :: Groups -> Model -> Model
spliceGroups groups model =
let
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 = concatMap updateNames $ fields model}
-- | 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 =
let
maybeCacheIndex indexList field =
case (index field, indexCollate field) of
(True, c) -> (name field, c):indexList
_ -> 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
Jump to Line
Something went wrong with that request. Please try again.