module Snap.Snaplet.Redson.Snapless.Metamodel
where
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
type FieldName = B.ByteString
type FieldValue = B.ByteString
type FieldIndex = (FieldName, Bool)
type Commit = M.Map FieldName FieldValue
data Permissions = Roles [B.ByteString]
| Everyone
| Nobody
deriving Show
data FieldTargets = Fields [FieldName]
| AllFields
| NoneFields
deriving Show
type FieldMeta = M.Map FieldName Value
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]
data Application = Application { targets :: FieldTargets
, apMeta :: Maybe FieldMeta
, _apRead :: Maybe Permissions
, _apWrite :: Maybe Permissions
}
deriving Show
makeLenses [''Application]
data Model = Model { modelName :: ModelName
, title :: B.ByteString
, fields :: [Field]
, applications :: [Application]
, _canCreateM :: Permissions
, _canReadM :: Permissions
, _canUpdateM :: Permissions
, _canDeleteM :: Permissions
, indices :: [FieldIndex]
}
deriving Show
makeLenses [''Model]
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"
type Groups = M.Map B.ByteString [Field]
groupFieldName :: FieldName
-> FieldName
-> FieldName
groupFieldName parent field = B.concat [parent, "_", field]
spliceGroups :: Groups -> Model -> Model
spliceGroups groups model =
let
origFields = fields model
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}
doApplications :: Model -> Model
doApplications model =
let
mergeFieldsMeta :: Maybe FieldMeta -> Field -> Field
mergeFieldsMeta (Just patchMeta) original =
let
oldMeta = fromMaybe M.empty (meta original)
newMeta =
M.foldlWithKey' (\o k v -> M.insert k v o) oldMeta patchMeta
in
original{meta = Just newMeta}
mergeFieldsMeta Nothing original = original
processField :: [Field] -> Application -> [Field]
processField (f:fs) ap =
let
patchBits :: [Field -> Field]
patchBits = [mergeFieldsMeta (apMeta ap)] ++
map (\(from, to) ->
maybe id (to ^=) (ap ^. from))
[ (apRead, canRead)
, (apWrite, canWrite)
]
patch = foldl1' (.) patchBits
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)}
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)}