module Database.Persist.Audit.Generator where
import Data.Monoid ((<>))
import Data.Char
import Data.Text (Text)
import qualified Data.Text as T
import Database.Persist.Audit.Types
data AuditGeneratorSettings = AuditGeneratorSettings {
childSpacing :: Int
, auditTag :: Text
, keepEntityDerive :: Bool
, keepComments :: Bool
, keepSpacing :: Bool
, foreignKeyType :: ForeignKeyType
} deriving (Eq,Read,Show)
data ForeignKeyType
= OriginalKey
| MongoKeyInSQL
| SQLKeyInMongo
deriving (Eq,Read,Show)
defaultSettings :: AuditGeneratorSettings
defaultSettings = AuditGeneratorSettings 2 "Audit" True False False OriginalKey
generateAuditModels :: AuditGeneratorSettings -> PersistModelFile -> Text
generateAuditModels settings = T.concat . (map $ (flip T.append "\n") . (printTopLevel settings))
printForeignKey :: ForeignKeyType -> Text -> (Text, Text)
printForeignKey OriginalKey entityName = (entityName <> " noreference", "")
printForeignKey MongoKeyInSQL entityName = ("ByteString", " -- " <> entityName)
printForeignKey SQLKeyInMongo entityName = ("Int64" , " -- " <> entityName)
printTopLevel :: AuditGeneratorSettings -> PersistModelFilePiece -> Text
printTopLevel settings (PersistModelFileEntity e) = (_getEntityName e <> auditTag settings <> jsonOption <> sqlOption <> "\n")
<> (T.concat $ map (printEntityChild settings) $ _getEntityChildren e)
<> (T.pack $ replicate (childSpacing settings) ' ') <> "originalId " <> foreignKey <> foreignKeyComment <> "\n"
<> (T.pack $ replicate (childSpacing settings) ' ') <> "auditAction AuditAction\n"
<> (T.pack $ replicate (childSpacing settings) ' ') <> "editedBy Text\n"
<> (T.pack $ replicate (childSpacing settings) ' ') <> "editedOn UTCTime\n"
where
jsonOption =
if _isEntityDeriveJson e then " " <> "json" else ""
sqlOption =
case _getEntitySqlTable e of
Just s -> " sql=" <> s
Nothing -> ""
(foreignKey,foreignKeyComment) = printForeignKey (foreignKeyType settings) (_getEntityName e <> "Id")
printTopLevel settings (PersistModelFileComment c) =
if keepComments settings then _getComment c else ""
printTopLevel settings (PersistModelFileWhiteSpace w) =
if keepSpacing settings then _getWhiteSpace w else ""
printEntityChild :: AuditGeneratorSettings -> EntityChild -> Text
printEntityChild settings (EntityChildEntityField ef) = " " <> entityFieldName <> " "
<> entityFieldType
<> entityDefault
<> sqlRow
<> sqlType
<> maxLen
<> foreignKeyComment'
<> "\n"
where
entityFieldName = _getEntityFieldName ef
eft = _getEntityFieldType ef
eftText = _getEntityFieldTypeText eft
(foreignKey,foreignKeyComment) = printForeignKey (foreignKeyType settings) eftText
entityFieldType =
case _getEntityFieldStrictness eft of
Strict -> ""
ExplicitStrict -> "!"
Lazy -> "~"
<> maybeLeftBracket
<> entityType
<> maybeRightBracket
<> if _isEntityFieldTypeMaybe eft then " Maybe" else ""
entityDefault =
case _getEntityFieldDefault ef of
Just d -> " default=" <> d
Nothing -> ""
sqlRow =
case _getEntityFieldSqlRow ef of
Just sr -> " sql=" <> sr
Nothing -> ""
sqlType =
case _getEntityFieldSqlType ef of
Just st -> " sqltype=" <> st
Nothing -> ""
maxLen =
case _getEntityFieldMaxLen ef of
Just ml -> " maxlen=" <> (T.pack . show $ ml)
Nothing -> ""
maybeLeftBracket = if _isEntityFieldTypeList eft then "[" else ""
maybeRightBracket = if _isEntityFieldTypeList eft then "]" else ""
entityType = if stringEndsInId . T.unpack $ eftText then foreignKey else eftText
foreignKeyComment' = if stringEndsInId . T.unpack $ eftText then foreignKeyComment else ""
printEntityChild _ (EntityChildEntityDerive d) = " " <> "deriving" <> " " <> (T.intercalate " " (_getEntityDeriveTypes d)) <> "\n"
printEntityChild _ (EntityChildEntityUnique _) = ""
printEntityChild _ (EntityChildEntityPrimary _) = ""
printEntityChild _ (EntityChildEntityForeign _) = ""
printEntityChild settings (EntityChildComment c) = if keepComments settings then _getComment c else ""
printEntityChild settings (EntityChildWhiteSpace w) = if keepSpacing settings then _getWhiteSpace w else ""
generateToAuditInstances :: AuditGeneratorSettings -> PersistModelFile -> Text
generateToAuditInstances settings = T.concat . (map $ printToAuditInstance settings)
printToAuditInstance :: AuditGeneratorSettings -> PersistModelFilePiece -> Text
printToAuditInstance settings (PersistModelFileEntity e) = "instance ToAudit " <> entityName <> " where\n"
<> " type AuditResult " <> entityName <> " = " <> auditEntityName <> "\n"
<> " toAudit v k auditAction editedBy editedOn = " <> auditEntityName <> "\n"
<> (T.concat $ map (printModelAccessor settings entityName) entityChildren)
<> " (" <> ifForeignKeyAlternate <> "k) auditAction editedBy editedOn\n\n"
where
entityName = _getEntityName e
auditEntityName = entityName <> (auditTag settings)
entityChildren = _getEntityChildren e
ifForeignKeyAlternate = printIfForeignKeyAlternate (foreignKeyType settings) "Id"
printToAuditInstance _ _ = ""
printModelAccessor :: AuditGeneratorSettings -> Text -> EntityChild -> Text
printModelAccessor settings entityName (EntityChildEntityField ef) = " ("
<> ifForeignKeyAlternate
<> (T.pack . firstLetterToLowerCase . T.unpack $ entityName)
<> (T.pack . firstLetterToUpperCase . T.unpack $ _getEntityFieldName ef)
<> " v)\n"
where
entityFieldType = _getEntityFieldType ef
ifForeignKeyAlternate = printIfForeignKeyAlternate2 (foreignKeyType settings) (_getEntityFieldTypeText entityFieldType) entityFieldType
printModelAccessor _ _ _ = ""
printIfForeignKeyAlternate :: ForeignKeyType -> Text -> Text
printIfForeignKeyAlternate MongoKeyInSQL entityName =
case stringEndsInId $ T.unpack entityName of
False -> ""
True -> "mongoKeyToByteString "
printIfForeignKeyAlternate SQLKeyInMongo entityName =
case stringEndsInId $ T.unpack entityName of
False -> ""
True -> "fromSqlKey "
printIfForeignKeyAlternate _ _ = ""
printIfForeignKeyAlternate2 :: ForeignKeyType -> Text -> EntityFieldType -> Text
printIfForeignKeyAlternate2 MongoKeyInSQL entityName entityFieldType =
case stringEndsInId $ T.unpack entityName of
False -> ""
True ->
case needsPrefix of
False -> "mongoKeyToByteString" <> funcInfix <> " "
True -> "fmap mongoKeyToByteString" <> funcInfix <> " "
where
(needsPrefix,funcInfix) = printEntityFieldTypeFunctionConnector entityFieldType
printIfForeignKeyAlternate2 SQLKeyInMongo entityName entityFieldType =
case stringEndsInId $ T.unpack entityName of
False -> ""
True ->
case needsPrefix of
False -> "fromSqlKey" <> funcInfix <> " "
True -> "fmap fromSqlKey" <> funcInfix <> " "
where
(needsPrefix,funcInfix) = printEntityFieldTypeFunctionConnector entityFieldType
printIfForeignKeyAlternate2 _ _ _ = ""
printEntityFieldTypeFunctionConnector :: EntityFieldType -> (Bool, Text)
printEntityFieldTypeFunctionConnector eft =
if _isEntityFieldTypeMaybe eft && _isEntityFieldTypeList eft
then (True, " <$>")
else
if _isEntityFieldTypeMaybe eft || _isEntityFieldTypeList eft
then (False, " <$>")
else (False, " $")
stringEndsInId :: String -> Bool
stringEndsInId s = if length s > 1 then hasId $ reverse s else False
where
hasId ('d':'I':_) = True
hasId _ = False
firstLetterToUpperCase :: String -> String
firstLetterToUpperCase (h:r) = toUpper h : r
firstLetterToUpperCase _ = []
firstLetterToLowerCase :: String -> String
firstLetterToLowerCase (h:r) = toLower h : r
firstLetterToLowerCase _ = []