packages feed

persistent-audit (empty) → 0.1.0.0

raw patch · 13 files changed

+1207/−0 lines, 13 filesdep +attoparsecdep +basedep +bytestringsetup-changed

Dependencies added: attoparsec, base, bytestring, getopt-generics, hspec, mongoDB, persistent, persistent-mongoDB, persistent-sqlite, persistent-template, text, time, transformers

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for persistent-audit-script++## 0.0.0.0  -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2016, James M.C. Haver II++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of persistent-audit nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ persistent-audit.cabal view
@@ -0,0 +1,76 @@+name:                persistent-audit+version:             0.1.0.0+synopsis:            Parses a Persist Model file and produces Audit Models+description:         Simplify database audits+license:             BSD3+license-file:        LICENSE+author:              James M.C. Haver II+maintainer:          mchaver@gmail.com+category:            Database, Yesod, Persistent+stability:           Beta+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10++executable persistent-audit+  main-is:             Main.hs+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=4.8 && < 5+                     , attoparsec+                     , bytestring+                     , getopt-generics+                     , mongoDB+                     , persistent  >= 2.2+                     , persistent-mongoDB+                     , persistent-template+                     , text+                     , time+                      +  hs-source-dirs:      src+  default-language:    Haskell2010++library +  exposed-modules:     Database.Persist.Audit.Class+                       Database.Persist.Audit.Generator+                       Database.Persist.Audit.MongoDB.Util+                       Database.Persist.Audit.Parser+                       Database.Persist.Audit.Parser.Types+                       Database.Persist.Audit.Types+                       Database.Persist.Audit.Queries+  -- other-modules:+  build-depends:       base >=4.8 && < 5+                     , attoparsec+                     , bytestring+                     , mongoDB+                     , persistent >= 2.2+                     , persistent-mongoDB+                     , persistent-template+                     , text+                     , time+                     , transformers++  hs-source-dirs:      src+  default-language:    Haskell2010+++test-suite test+  type:              exitcode-stdio-1.0+  main-is:           Spec.hs+  default-language:  Haskell2010+  hs-source-dirs:     src+                     ,tests++  ghc-options:       -threaded -O0 -Wall+  build-depends:     base >=4.8 && < 5+                   , attoparsec+                   , bytestring+                   , hspec+                   , mongoDB+                   , persistent >= 2.2+                   , persistent-sqlite+                   , persistent-mongoDB+                   , persistent-template+                   , text  +                   , time  +                   , transformers
+ src/Database/Persist/Audit/Class.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE TypeFamilies #-}+module Database.Persist.Audit.Class where++import           Data.Text              (Text)+import           Data.Time              (UTCTime)+import           Database.Persist.Types+import           Database.Persist.Audit.Types+++-- | Persistent Model types that have a corresponding Audit type as produced by 'Database.Persist.Audit.Generator.generateAuditModels'+-- need to implement 'ToAudit' in order to use the queries+-- from 'Database.Persist.Audit.Queries'. Given the following two Persistent models:+-- +-- @+-- Person+--   name String+--   age Int Maybe+--+-- PersonAudit+--   name String+--   age Int Maybe+--   originalId PersonId noreference+--   auditAction AuditAction+--   editedBy Text+--   editedOn UTCTime+-- +-- @+--+-- The 'ToAudit' instance should look like this:+-- +-- @+-- instance ToAudit Person where+--  type AuditResult Person = PersonAudit+--  toAudit v k auditAction editedBy editedOn = PersonAudit (personName v)+--                                                          (personAge v)+--                                                          k auditAction editedBy editedOn +-- @+-- +-- 'Database.Persist.Audit.Generator.generateAuditModels' can help automate these instances.+class ToAudit a where+  type AuditResult a :: *+  toAudit :: a -> Key a -> AuditAction -> Text -> UTCTime -> AuditResult a
+ src/Database/Persist/Audit/Generator.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts  #-}+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++++-- | Five options for generating Audit Models and ToAudit Instances.+data AuditGeneratorSettings = AuditGeneratorSettings {+  childSpacing     :: Int   -- ^ The number of spaces to add for all items that appear under an EntityName. +, auditTag         :: Text  -- ^ The tag that will be added to the original model name in the generated audit models. If 'auditTag' is "History" then "User" will become "UserHistory".+, keepEntityDerive :: Bool  -- ^ If 'True', the generated Audit Models will maintain the same derived Type Classes as the original file.+, keepComments     :: Bool  -- ^ If 'True', the generated Audit Models will maintain the same comments as the original file.+, keepSpacing      :: Bool  -- ^ If 'True', the generated Audit Models will maintain the same spacing as the original file.+, foreignKeyType   :: ForeignKeyType -- ^ Foreign Keys can be the original type, ByteString or Int64.+} deriving (Eq,Read,Show)+++-- | All foreign keys are kept in the audit models but derefenced so the original models+-- | can be deleted without affecting the audit models. This is a work around in case the +-- | original models and the audit models are stored in different databases.+-- | Persist cannot handle keys across SQL and Mongo.+data ForeignKeyType = OriginalKey   -- | Default setting. Link the ids as the original type with a "noreference" tag.+                    | MongoKeyInSQL -- | Store Mongo Key as a ByteString in SQL.+                    | SQLKeyInMongo -- | Store SQL Key as an Int64 in Mongo.+  deriving (Eq,Read,Show)++-- | Settings that the author assumed would be most common.+defaultSettings :: AuditGeneratorSettings+defaultSettings =  AuditGeneratorSettings 2 "Audit" True False False OriginalKey+++-- | Convert a list of 'TopLevel' to a list of Audit Models in 'Text'.+generateAuditModels :: AuditGeneratorSettings -> PersistModelFile -> Text+generateAuditModels settings = T.concat . (map $ (flip T.append "\n") . (printTopLevel settings))++-- | Select the correct type from Audit Model to original Model. Used for cross database.+-- | 'fst' is the type and 'snd' is the original type in comment for if using cross database.+printForeignKey :: ForeignKeyType -> Text -> (Text, Text)+printForeignKey OriginalKey   entityName = (entityName <> " noreference", "")+printForeignKey MongoKeyInSQL entityName = ("ByteString", " -- " <> entityName)+printForeignKey SQLKeyInMongo entityName = ("Int64"     , " -- " <> entityName)+++-- | Convert a 'TopLevel' to an Audit Model, white space or comment in 'Text'.+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 ""+++-- | Convert an 'EntityChild' to a piece of an Audit Model in 'Text'.+-- | It does not generate anything for EntityUnique, EntityPrimary or EntityForeign+-- | because Audits do not need to be unique, they will have an automatically produced Key+-- | and should not have any foreign keys connecting back to the original model.+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 ""+++-- | Convert a list of 'TopLevel' to a to a list of 'ToAudit' in 'Text'.+generateToAuditInstances ::  AuditGeneratorSettings -> PersistModelFile -> Text+generateToAuditInstances settings = T.concat . (map $ printToAuditInstance settings)++-- | Convert 'TopLevel' to an instance of 'ToAudit' in 'Text'.+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 _ _ = ""++-- encodeUtf8++-- | Convert 'EntityChild' to a Model accessor.+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 _ _ _ = ""+++-- | Select the correct function for handling foreign keys.+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 _ _ _ = ""++-- | If 'fst' True then prefix the function with 'fmap'+printEntityFieldTypeFunctionConnector :: EntityFieldType -> (Bool, Text)+printEntityFieldTypeFunctionConnector eft = +  if _isEntityFieldTypeMaybe eft && _isEntityFieldTypeList eft +    then (True, " <$>") +    else +      if _isEntityFieldTypeMaybe eft || _isEntityFieldTypeList eft +        then (False, " <$>")+        else (False, " $")++-- | Return true if the last two characters are "Id".+stringEndsInId :: String -> Bool+stringEndsInId s = if length s > 1 then hasId $ reverse s else False+  where+    hasId ('d':'I':_) = True+    hasId _ = False++-- | Convert the first letter of a 'String' to the corresponding uppercase letter.+firstLetterToUpperCase :: String -> String+firstLetterToUpperCase (h:r) = toUpper h : r+firstLetterToUpperCase _     = []++-- | Convert the first letter of a 'String' to the corresponsing lowercase letter.+firstLetterToLowerCase :: String -> String+firstLetterToLowerCase (h:r) = toLower h : r+firstLetterToLowerCase _     = []
+ src/Database/Persist/Audit/MongoDB/Util.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts  #-}++module Database.Persist.Audit.MongoDB.Util where++import           Data.ByteString (ByteString)+import           Data.Text       (Text)+import           Data.Text.Encoding (encodeUtf8,decodeUtf8')++import           Database.MongoDB as DB+import           Database.Persist.MongoDB (keyToText,readMayMongoKey)+import           Database.Persist +++-- | Used for creating instances of ToAudit when the original model database is Mongo+--   and the audit model database is SQL.+-- ==== __Example__ +-- User+--     ident Text+--     password Text Maybe+--     UniqueUser ident+-- UserAudit+--     ident Text+--     password Text Maybe+--     originalId ByteString+--     auditAction AuditAction+--     editedBy Text+--     editedOn UTCTime+--  instance ToAudit User where+--    type AuditResult User = UserAudit+--    toAudit v k auditAction editedBy editedOn = UserAudit (userIdent v)+--      (userPassword v)+--      (mongoKeyToByteString k) auditAction editedBy editedOn ++mongoKeyToByteString :: (ToBackendKey DB.MongoContext record) => Key record -> ByteString+mongoKeyToByteString = encodeUtf8 . keyToText . toBackendKey++-- | Used for when Mongo stored in SQL needs to be converted to a Key to query the original +--   MongoDB. +byteStringToMongoKey :: (ToBackendKey DB.MongoContext record) => ByteString -> Maybe (Key record)+byteStringToMongoKey bs = case decodeUtf8' bs of+                            Left _ -> Nothing+                            Right text -> fromBackendKey <$> readMayMongoKey text ++-- | To handle SQL keys to and from MongoDB, use 'toSqlKey' and 'fromSqlKey' from Database.Persist.Sql+
+ src/Database/Persist/Audit/Parser.hs view
@@ -0,0 +1,413 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE ScopedTypeVariables #-}+++module Database.Persist.Audit.Parser where++import           Control.Applicative ++import           Data.Attoparsec.ByteString.Char8 (isSpace)+import           Data.Attoparsec.Combinator+import           Data.Attoparsec.Text++import           Data.List  (delete,elem,nub)+import           Data.Maybe+import           Data.Monoid ((<>))+import           Data.Text (Text)+import qualified Data.Text as T++import           Database.Persist.Audit.Types+import           Database.Persist.Audit.Parser.Types++import           Prelude hiding (takeWhile)++import           Text.Read (readMaybe)+++-- handling indented text appropriately++parseQuasiQuoterFile :: Text -> Either String PersistModelFile+parseQuasiQuoterFile = parseOnly parseEntities++parseModelsFile :: Text -> Either String PersistModelFile+parseModelsFile = parseOnly parseEntities++-- | Parse Persist Models that are in quasi-quoters. The source could be a haskell file.+parsePersistQuasiQuoters :: Parser PersistModelFile+parsePersistQuasiQuoters = do+  _ <- manyTill' anyChar (string "[persistLowerCase|" <|> string "[persistUpperCase|")+  manyTill' ( PersistModelFileEntity     <$> parseEntity +      <|> PersistModelFileWhiteSpace <$> collectWhiteSpace+      <|> PersistModelFileComment    <$> singleLineComment) (string "|]")++-- | Parse a Persist Model file.+parseEntities :: Parser PersistModelFile+parseEntities = do+  many' ( PersistModelFileEntity     <$> parseEntity +      <|> PersistModelFileWhiteSpace <$> collectWhiteSpace+      <|> PersistModelFileComment    <$> singleLineComment)++-- | Parse a single Persist Entity+parseEntity :: Parser Entity+parseEntity = do++  entityName <- haskellTypeNameWithoutPrefix+  _ <- many' spaceNoNewLine+  derivesJson <- (string "json" *> pure True) <|> pure False+  _ <- many' spaceNoNewLine+  mSqlTable <- (Just <$> parseEntitySqlTable) <|> pure Nothing+  _ <- takeTill isEndOfLine+  endOfLine <|> endOfInput++  entityChildren <- many' ( EntityChildEntityField   <$> parseEntityField +                        <|> EntityChildEntityDerive  <$> parseEntityDerive +                        <|> EntityChildEntityPrimary <$> parseEntityPrimary+                        <|> EntityChildEntityForeign <$> parseEntityForeign+                        <|> EntityChildEntityUnique  <$> parseEntityUnique +                        <|> EntityChildWhiteSpace    <$> collectWhiteSpace+                        <|> EntityChildComment       <$> singleLineComment)+  +  return $ Entity entityName derivesJson mSqlTable entityChildren+++parseEntitySqlTable :: Parser Text+parseEntitySqlTable = do+  _ <- string "sql" +  _ <- many' spaceNoNewLine+  _ <- char '='+  _ <- many' spaceNoNewLine+  -- take while not space+  text <- many' (digit <|> letter <|> underline) +  return $ T.pack text+  +-- helper functions++-- | Wrap a Parser in 'Maybe' because it might fail. Useful for making choices.+maybeOption :: Parser a -> Parser (Maybe a)+maybeOption p = option Nothing (Just <$> p)++-- | Parse a lowercase 'Char'.+lowerCase :: Parser Char+lowerCase = satisfy (\c -> c >= 'a' && c <= 'z')++-- | Parse an uppercase 'Char'.+upperCase :: Parser Char+upperCase = satisfy (\c -> c >= 'A' && c <= 'Z')++-- | Parse an underline.+underline :: Parser Char +underline = satisfy (== '_')++-- | Parse strict marker "!" for haskellTypeName.+exclamationMark :: Parser Char +exclamationMark = satisfy (== '!')++-- | Parse lazy marker "~" for haskellTypeName.+tilde :: Parser Char +tilde = satisfy (== '~')+++-- | Parse any space 'Char' excluding "\n".+spaceNoNewLine :: Parser Char+spaceNoNewLine = satisfy (\x -> isSpace x && not (isEndOfLine x)) <?> "spaceNoNewLine"++-- | Parse a Haskell function name. It starts with underscore or lowercase letter then +-- is followed by a combination of underscores, single quotes, letters and digits.+-- E.g., "get", "_get", "get_1", etc.+haskellFunctionName :: Parser Text+haskellFunctionName = do+  first <- lowerCase <|> underline+  rest  <- many' (digit <|> letter <|> underline) +  lookAhead ((space *> pure ()) <|> (char ']' *> pure ()) <|> endOfInput)+  return $ T.pack ([first] ++ rest)++-- | Parse a Haskell type name. It starts with an uppercase letter then +-- is followed by a combination of underscores, single quotes, letters and digits.+-- E.g., "Person", "Address", "PhoneNumber", etc.+haskellTypeName :: Parser Text+haskellTypeName = do+  prefix <- (Just <$> exclamationMark) <|> (Just <$> tilde) <|> pure Nothing+  haskellTypeNameWithoutPrefix++haskellTypeNameWithoutPrefix :: Parser Text+haskellTypeNameWithoutPrefix = do+  first <- upperCase+  rest  <- many' (digit <|> letter <|> underline) +  -- check for ']' because it could be in a list+  lookAhead ((space *> pure ()) <|> (char ']' *> pure ())  <|> endOfInput)+  return $ T.pack ([first] ++ rest)++++-- | Parse a comment that starts with "--".+singleLineComment :: Parser Comment+singleLineComment = do+  _ <- string "--"+  comment <- takeTill isEndOfLine+  endOfLine+  return $ Comment ("--" <> comment <> "\n")+++collectWhiteSpace :: Parser WhiteSpace+collectWhiteSpace = do+  whiteSpace <- takeWhile (\x -> isSpace x && not (isEndOfLine x))+  endOfLine -- <|> endOfInput+  return $ WhiteSpace (whiteSpace <> "\n")++++-- EntityName++parseEntityName :: Parser Text+parseEntityName = do+  name <- haskellTypeName+  rest <- takeTill isEndOfLine+  endOfLine <|> endOfInput+  return name++-- EntityField++parseEntityField :: Parser EntityField+parseEntityField = do+  efn <- parseEntityFieldName+  eft <- parseEntityFieldType++  ms <- parseMigrationOnlyAndSafeToRemove [] <|> pure []+  rs <- parseEntityFieldLastItem [] <|> pure []+  +  rest <- takeTill isEndOfLine+  endOfLine <|> endOfInput+  +  return $ EntityField efn +                       eft +                       (elem MigrationOnly ms) +                       (elem SafeToRemove ms)+                       (getFieldDefault rs)+                       (getFieldSqlRow  rs)+                       (getFieldSqlType rs)+                       (getFieldMaxLen  rs)+  ++deleteItems :: (Eq a) => [a] -> [a] -> [a]+deleteItems (x:xs) ys = deleteItems xs $ delete x ys +deleteItems _ ys = nub ys++parseMigrationOnly :: Parser MigrationOnlyAndSafeToRemoveOption+parseMigrationOnly = string "MigrationOnly" *> pure MigrationOnly++parseSafeToRemove :: Parser MigrationOnlyAndSafeToRemoveOption+parseSafeToRemove  = string "SafeToRemove" *> pure SafeToRemove ++getMigrationOnlyAndSafeToRemoveOption :: MigrationOnlyAndSafeToRemoveOption -> Parser MigrationOnlyAndSafeToRemoveOption+getMigrationOnlyAndSafeToRemoveOption MigrationOnly = parseMigrationOnly+getMigrationOnlyAndSafeToRemoveOption SafeToRemove  = parseSafeToRemove++parseMigrationOnlyAndSafeToRemove :: [MigrationOnlyAndSafeToRemoveOption] -> Parser [MigrationOnlyAndSafeToRemoveOption]+parseMigrationOnlyAndSafeToRemove parserOps = do+  _ <- many1 spaceNoNewLine+  -- let parsers = [MigrationOnly,SafeToRemove] \\ parserOps+  let parsers = deleteItems parserOps [MigrationOnly,SafeToRemove]+  mResult <- (Just <$> choice (map getMigrationOnlyAndSafeToRemoveOption parsers)) <|> pure Nothing+  case mResult of+    Nothing -> return parserOps+    Just result -> parseMigrationOnlyAndSafeToRemove (parserOps ++ [result]) <|> pure (parserOps ++ [result])++getFieldDefault :: [EntityFieldLastItem] -> Maybe Text+getFieldDefault (x:xs) = +  case x of+    (FieldDefault y) -> Just y+    _ -> getFieldDefault xs+getFieldDefault _ = Nothing++getFieldSqlRow  :: [EntityFieldLastItem] -> Maybe Text+getFieldSqlRow (x:xs) = +  case x of+    (FieldSqlRow y) -> Just y+    _ -> getFieldSqlRow xs+getFieldSqlRow _ = Nothing++getFieldSqlType :: [EntityFieldLastItem] -> Maybe Text+getFieldSqlType (x:xs) = +  case x of+    (FieldSqlType y) -> Just y+    _ -> getFieldSqlType xs+getFieldSqlType _ = Nothing++getFieldMaxLen  :: [EntityFieldLastItem] -> Maybe Int+getFieldMaxLen (x:xs) = +  case x of+    (FieldMaxLen y) -> Just y+    _ -> getFieldMaxLen xs+getFieldMaxLen _ = Nothing+++getEntityFieldLastItemParser :: EntityFieldLastItem -> Parser EntityFieldLastItem+getEntityFieldLastItemParser (FieldDefault  _) = parseFieldDefault+getEntityFieldLastItemParser (FieldSqlRow   _) = parseFieldSqlRow+getEntityFieldLastItemParser (FieldSqlType  _) = parseFieldSqlType+getEntityFieldLastItemParser (FieldMaxLen   _) = parseFieldMaxLen+++parseFieldDefault :: Parser EntityFieldLastItem+parseFieldDefault = do+  _ <- string "default"+  _ <- many' spaceNoNewLine+  _ <- char '='+  _ <- many' spaceNoNewLine+  -- take while not space+  text <- many' (digit <|> letter <|> underline)+  return $ FieldDefault $ T.pack text++  +parseFieldSqlRow :: Parser EntityFieldLastItem+parseFieldSqlRow = do+  _ <- string "sql" +  _ <- many' spaceNoNewLine+  _ <- char '='+  _ <- many' spaceNoNewLine+  -- take while not space+  text <- many' (digit <|> letter <|> underline) +  return $ FieldSqlRow $ T.pack text++parseFieldSqlType :: Parser EntityFieldLastItem+parseFieldSqlType = do+  _ <- string "sqltype" +  _ <- many' spaceNoNewLine+  _ <- char '='+  _ <- many' spaceNoNewLine+  -- take while not space+  text <- many' (digit <|> letter <|> underline) +  return $ FieldSqlType $ T.pack text++parseFieldMaxLen :: Parser EntityFieldLastItem+parseFieldMaxLen = do+  _ <- string "maxlen" +  _ <- many' spaceNoNewLine+  _ <- char '='+  _ <- many' spaceNoNewLine+  -- take while not space+  intString <- many1 digit+  +  case readMaybe intString :: Maybe Int of +    Nothing -> fail "fieldMaxLen"+    Just int -> return $ FieldMaxLen int++parseEntityFieldLastItem :: [EntityFieldLastItem] -> Parser [EntityFieldLastItem]+parseEntityFieldLastItem parserOps = do+  _ <- many1 spaceNoNewLine+  let parsers = deleteItems parserOps [FieldDefault "", FieldSqlType "", FieldSqlRow "", FieldMaxLen 0]+  mResult <- (Just <$> choice (map getEntityFieldLastItemParser parsers)) <|> pure Nothing+  +  case mResult of+    Nothing -> return parserOps+    Just result -> parseEntityFieldLastItem (parserOps ++ [result]) <|> pure (parserOps ++ [result])+++parseEntityFieldName :: Parser Text+parseEntityFieldName = do+  _ <- many1 spaceNoNewLine+  name <- haskellFunctionName+  +  case name == "deriving" of+    True -> fail "deriving"+    False -> return name++parseStrictness :: Parser Strictness+parseStrictness = do+  (string "!" *> pure ExplicitStrict) <|> (string "~" *> pure Lazy) <|> pure Strict++parseEntityFieldType :: Parser EntityFieldType+parseEntityFieldType = do+  _ <- many1 spaceNoNewLine+  mLeftBracket <- maybeOption (char '[')+  strictness <- parseStrictness+  name <- haskellTypeName++  case mLeftBracket of+    Nothing -> do+      -- _ <- many' spaceNoNewLine+      -- mMaybe <- maybeOption (string "Maybe")+      mybe <- (parseMaybe *> pure True) <|> pure False+      return $ EntityFieldType name strictness False mybe+    Just _  -> do+      _ <- char ']'+      -- _ <- many' spaceNoNewLine+      -- mMaybe <- maybeOption (string "Maybe")+      mybe <- (parseMaybe *> pure True) <|> pure False+      return $ EntityFieldType name strictness True mybe+++parseMaybe :: Parser ()+parseMaybe = do+  _ <- many1 spaceNoNewLine+  _ <- string "Maybe"+  return ()++-- EntityUnique++parseEntityUnique :: Parser EntityUnique+parseEntityUnique = do+  eun <- parseEntityUniqueName+  euefn <- parseEntityUniqueEntityFieldName+  _ <- takeTill isEndOfLine+  endOfLine <|> endOfInput++  return $ EntityUnique eun euefn++parseEntityUniqueName :: Parser Text+parseEntityUniqueName = do+  _ <- many1 spaceNoNewLine+  haskellTypeName++parseEntityUniqueEntityFieldName :: Parser [Text]+parseEntityUniqueEntityFieldName = do+  _ <- many1 spaceNoNewLine+  many1 haskellFunctionName+  ++-- EntityDerive++parseEntityDerive :: Parser EntityDerive+parseEntityDerive = do+  _ <- many1 spaceNoNewLine+  _ <- string "deriving"+  -- _ <- many1 spaceNoNewLine+  names <- many1 (many1 spaceNoNewLine *> haskellTypeName)+  +  _ <- takeTill isEndOfLine+  endOfLine <|> endOfInput++  return $ EntityDerive names++parseEntityPrimary :: Parser EntityPrimary+parseEntityPrimary = do+  _ <- many1 spaceNoNewLine+  _ <- string "Primary"+  -- _ <- many1 spaceNoNewLine+  names <- many1 (many1 spaceNoNewLine *> haskellFunctionName)+  +  _ <- takeTill isEndOfLine+  endOfLine <|> endOfInput++  return $ EntityPrimary names++parseEntityForeign :: Parser EntityForeign+parseEntityForeign = do+  _ <- many1 spaceNoNewLine+  _ <- string "Foreign"+  _ <- many1 spaceNoNewLine+  foreignTable <- haskellTypeName+  names <- many1 (many1 spaceNoNewLine *> haskellFunctionName)+  +  _ <- takeTill isEndOfLine+  endOfLine <|> endOfInput++  return $ EntityForeign foreignTable names+++parseForeignKeyType :: Parser () -- Text+parseForeignKeyType = do+  _ <- manyTill anyChar (string "Id" *> endOfInput)+  return ()+
+ src/Database/Persist/Audit/Parser/Types.hs view
@@ -0,0 +1,21 @@++{-# LANGUAGE OverloadedStrings   #-}++module Database.Persist.Audit.Parser.Types where++import Data.Text (Text)++data MigrationOnlyAndSafeToRemoveOption = MigrationOnly | SafeToRemove deriving (Eq,Read,Show)++data EntityFieldLastItem = FieldDefault Text+                         | FieldSqlRow  Text +                         | FieldSqlType Text+                         | FieldMaxLen  Int+  deriving (Read,Show)++instance Eq EntityFieldLastItem where+  (FieldDefault  _) == (FieldDefault  _) = True+  (FieldSqlRow   _) == (FieldSqlRow   _) = True+  (FieldSqlType  _) == (FieldSqlType  _) = True+  (FieldMaxLen   _) == (FieldMaxLen   _) = True+  _ == _ = False
+ src/Database/Persist/Audit/Queries.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE TypeFamilies           #-}++module Database.Persist.Audit.Queries where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader  ++import Data.Text (Text)+import Data.Time++import Database.Persist+import Database.Persist.Audit.Class+import Database.Persist.Audit.Types++-- PersistStore++insertAndAudit :: ( MonadIO m+#if MIN_VERSION_persistent(2,5,0)+                  , backend ~ BaseBackend backend    +#endif+                  , backend ~ PersistEntityBackend val+                  , backend ~ PersistEntityBackend (AuditResult val)+                  , PersistEntity val+                  , PersistEntity (AuditResult val)+                  , PersistStore backend+                  , ToAudit val) => +                  val -> +                  Text -> +                  ReaderT backend m (Key val) +insertAndAudit val userName = do+  key <- insert val+  now <- liftIO $ getCurrentTime+  _ <- insert (toAudit val key Database.Persist.Audit.Types.Create userName now)+  return key++-- delete based on id+deleteAndAudit :: ( MonadIO m+#if MIN_VERSION_persistent(2,5,0)+                  , backend ~ BaseBackend backend    +#endif+                  , backend ~ PersistEntityBackend val+                  , backend ~ PersistEntityBackend (AuditResult val)+                  , PersistEntity val+                  , PersistEntity (AuditResult val)+                  , PersistStore backend+                  , ToAudit val) =>+                  Key val ->  +                  Text -> +                  ReaderT backend m ()+deleteAndAudit key userName = do+  mVal <- get key+  case mVal of+    Nothing -> return ()+    Just val -> do+      now <- liftIO $ getCurrentTime+      _ <- insert (toAudit val key Database.Persist.Audit.Types.Delete userName now)+      delete key+      return ()+++updateAndAudit :: ( MonadIO m+#if MIN_VERSION_persistent(2,5,0)+                  , backend ~ BaseBackend backend    +#endif+                  , backend ~ PersistEntityBackend val+                  , backend ~ PersistEntityBackend (AuditResult val)+                  , PersistEntity val+                  , PersistEntity (AuditResult val)+                  , PersistStore backend+                  , ToAudit val) =>+                   Key val -> +                   [Update val] ->+                   Text -> +                   ReaderT backend m ()+updateAndAudit key updateVals userName = do+  update key updateVals+  mVal <- get key+  case mVal of+    Nothing -> return ()+    Just val -> do+      now <- liftIO $ getCurrentTime+      _ <- insert (toAudit val key Database.Persist.Audit.Types.Update userName now)+      return ()+++-- PersistQuery+++deleteWhereAndAudit :: ( MonadIO m+#if MIN_VERSION_persistent(2,5,0)+                       , backend ~ BaseBackend backend+                       , PersistQueryWrite backend+#else +                       , PersistQuery backend+#endif+                       , backend ~ PersistEntityBackend val+                       , backend ~ PersistEntityBackend (AuditResult val)+                       , PersistEntity val+                       , PersistEntity (AuditResult val)+                       , PersistStore backend+                       , ToAudit val) =>+{-+                       ( MonadIO m+                       , PersistStore backend+                       , PersistQueryWrite backend+                       , backend ~ BaseBackend backend+                       , backend ~ PersistEntityBackend val+                       , backend ~ PersistEntityBackend (AuditResult val)+                       , PersistEntity val+                       , PersistEntity (AuditResult val)+                       , ToAudit val) =>+-} +                       [Filter val] ->  +                       Text -> +                       ReaderT backend m ()+deleteWhereAndAudit filters userName = do+  toBeDeleted <- selectList filters []+  now <- liftIO $ getCurrentTime+  forM_ toBeDeleted $ \e -> do+    _ <- insert (toAudit (entityVal e) (entityKey e) Database.Persist.Audit.Types.Delete userName now)+    return ()++  deleteWhere filters+  return ()+++updateWhereAndAudit :: ( MonadIO m+#if MIN_VERSION_persistent(2,5,0)+                       , backend ~ BaseBackend backend+                       , PersistQueryWrite backend+#else +                       , PersistQuery backend+#endif+                       , backend ~ PersistEntityBackend val+                       , backend ~ PersistEntityBackend (AuditResult val)+                       , PersistEntity val+                       , PersistEntity (AuditResult val)+                       , PersistStore backend+                       , ToAudit val) =>+                       [Filter val] ->+                       [Update val] ->+                       Text -> +                       ReaderT backend m ()+updateWhereAndAudit filters updates userName = do+  toBeUpdated <- selectList filters []+  now <- liftIO $ getCurrentTime+  forM_ toBeUpdated $ \e -> do+    _ <- insert (toAudit (entityVal e) (entityKey e) Database.Persist.Audit.Types.Update userName now)+    return ()++  updateWhere filters updates+  return ()
+ src/Database/Persist/Audit/Types.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}++module Database.Persist.Audit.Types where++import           Data.Text (Text)++import           Database.Persist.TH++import           GHC.Generics++-- | A collection of data types with which you can recontruct a Persist Model file+-- | or create an altered version.+type PersistModelFile = [PersistModelFilePiece]++-- | Top level pieces of a Persist Model file.+data PersistModelFilePiece = PersistModelFileEntity     Entity     |+                             PersistModelFileComment    Comment    |+                             PersistModelFileWhiteSpace WhiteSpace  +  deriving (Eq,Show,Read)++-- | A single Persist Model Entity.+data Entity = Entity {+  _getEntityName      :: Text+, _isEntityDeriveJson :: Bool          -- | Person json+, _getEntitySqlTable  :: Maybe Text    -- | Person sql=peoples+, _getEntityChildren  :: [EntityChild]+} deriving (Eq,Show,Read)+++-- | All of the child elements of a Persist Model Entity.+-- | They are all indented in the Model File.+data EntityChild = EntityChildEntityField   EntityField   |+                   EntityChildEntityUnique  EntityUnique  |+                   EntityChildEntityDerive  EntityDerive  |+                   EntityChildEntityPrimary EntityPrimary |+                   EntityChildEntityForeign EntityForeign |+                   EntityChildComment       Comment       |+                   EntityChildWhiteSpace    WhiteSpace    +  deriving (Eq,Show,Read)++-- | A data row from an Entity.+data EntityField = EntityField {+  _getEntityFieldName         :: Text+, _getEntityFieldType         :: EntityFieldType+, _isEntityFieldMigrationOnly :: Bool  -- | MigrationOnly+, _isEntityFieldSafeToRemove  :: Bool  -- | SafeToRemove+, _getEntityFieldDefault      :: Maybe Text -- | default=Nothing, default=now(), default=CURRENT_DATE+, _getEntityFieldSqlRow       :: Maybe Text -- | sql=my_id_name+, _getEntityFieldSqlType      :: Maybe Text -- | sqltype=varchar(255)+, _getEntityFieldMaxLen       :: Maybe Int+} deriving (Eq,Show,Read)+++-- | Table rows can be strict or lazy+data Strictness = Strict -- | Persist Model types are strict without any notation +  | ExplicitStrict       -- | "!" can be used to reemphasize that a type is strict+  | Lazy                 -- | "~" means that a type is Laxy+  deriving (Eq,Show,Read)+++-- | An entity data row's type. If '_isEntityFieldTypeList' is 'True' than this type is a list.+data EntityFieldType = EntityFieldType {+  _getEntityFieldTypeText   :: Text+, _getEntityFieldStrictness :: Strictness+, _isEntityFieldTypeList    :: Bool+, _isEntityFieldTypeMaybe   :: Bool+} deriving (Eq,Show,Read)+++-- | A unique idenfitier for an Entity.+data EntityUnique = EntityUnique {+  _getEntityUniqueName            ::  Text+, _getEntityUniqueEntityFieldName ::  [Text]+} deriving (Eq,Show,Read)+++-- | 'deriving Eq', 'deriving Show', etc.+data EntityDerive = EntityDerive {+  _getEntityDeriveTypes :: [Text]+} deriving (Eq,Show,Read)++-- | 'Primary name'+data EntityPrimary = EntityPrimary {+  _getEntityPrimeType :: [Text]+} deriving (Eq,Show,Read)++-- | 'Foreign Tree fkparent parent'+data EntityForeign = EntityForeign {+  _getEntityForeignTable :: Text+, _getEntityForeignTypes :: [Text]+} deriving (Eq,Show,Read)+++-- | Any white spaces that the user might want to maintain when generating Audit Models.+data WhiteSpace = WhiteSpace {+  _getWhiteSpace :: Text+} deriving (Eq,Show,Read)++-- | Haskell style comments that start with "-- "+data Comment = Comment {+  _getComment :: Text +} deriving (Eq,Show,Read)+++-- | Annotations for each Audit Model to keep track of why it was inserted. +data AuditAction = Create | Delete | Update +  deriving (Show, Read, Eq, Ord, Generic)++derivePersistField "AuditAction"
+ src/Main.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import           Data.Text (Text)+import qualified Data.Text as T+import           Data.Text.IO++import           Database.Persist.Audit.Generator+import           Database.Persist.Audit.Parser++import           WithCli++{-+principles+  no foreign keys between audit table and original table, they store the same data but no dependency+  database independence, original models and audit models can be stored in separate dbs++  makes a best attempt, no guarantees++  assumptions made: +    types ending in Id are foreign pointers+-}++-- data CrossDB = SQLtoMongoDB | MongoDBtoSQL deriving (Eq,Generic,Read,Show, HasArguments)++data CmdOptions = CmdOptions {+  model         :: FilePath -- | Input: Model file to parse+, audit         :: FilePath -- | Ouput: Audit Model file+, auditInstance :: Maybe FilePath -- | Optional Output: ToAudit Instances for models in model file to models in Audit Model File+, crossDB       :: Maybe String -- | Nothing if original models and audit models are in the same database type+                              --   'sqlToMongoDB'+                              --   'mongoDbToSql'+} deriving (Generic, Show, Eq, Read)++instance HasArguments CmdOptions++main :: IO ()+main = withCliModified mods $ \ (ops :: CmdOptions) -> do+  m <- Data.Text.IO.readFile $ model ops+  settings <- case crossDB ops of+      Nothing -> return defaultSettings+      Just c  -> case c of+        "mongoDbToSql" -> return $ defaultSettings {foreignKeyType = MongoKeyInSQL}+        "sqlToMongoDB" -> return $ defaultSettings {foreignKeyType = SQLKeyInMongo}+        _              -> return defaultSettings++  case parseModelsFile m of +    Left _ -> print $ "Failed to parse the models file with parseEntities function."+    Right models -> do+      Data.Text.IO.writeFile (audit ops) (generateAuditModels settings models)+      case auditInstance ops of+        Nothing -> return ()+        Just auditInstanceFile -> do+          Data.Text.IO.writeFile auditInstanceFile (generateToAuditInstances settings models)+          return ()++  where+    mods =+      AddShortOption "model" 'm' :+      AddShortOption "audit" 'a' :+      AddShortOption "auditInstance" 'i' :+      AddShortOption "crossDB" 'c' :+      []
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}