persistent-audit 0.1.0.1 → 0.1.0.2
raw patch · 10 files changed
+690/−87 lines, 10 filesdep +aesondep +hashabledep +unordered-containers
Dependencies added: aeson, hashable, unordered-containers
Files
- ChangeLog.md +5/−0
- README.md +1/−1
- persistent-audit.cabal +29/−9
- src/Database/Persist/Audit/MongoDB/Util.hs +8/−10
- src/Database/Persist/Audit/Parser.hs +49/−50
- src/Database/Persist/Audit/Types.hs +36/−12
- src/Main.hs +3/−5
- tests/Database/Persist/Audit/GeneratorSpec.hs +189/−0
- tests/Database/Persist/Audit/ParserSpec.hs +250/−0
- tests/Database/Persist/Audit/QueriesSpec.hs +120/−0
ChangeLog.md view
@@ -1,5 +1,10 @@ # Revision history for persistent-audit-script +## 0.1.0.2 -- 2016-08-11++* Add ToJSON, FromJSON and Hashable instances for AuditAction.+* Clean up some compiler warnings.+ ## 0.1.0.1 -- 2016-05-03 * Fix Haddock documentation.
README.md view
@@ -32,7 +32,7 @@ * To parse Persistent model files * To generate Audit Models from other Models * To generate `ToAudit` instances - * Use query functions from `Database.Persist.Audit.Queries`:`insertAndAudit`, `insertWhereAndAudit`,`deleteAndAudit`,`deleteWhereAndAudit`,`updateAndAudit`,`updateWhereAndAudit`+ * Use query functions from `Database.Persist.Audit.Queries`:`insertAndAudit`,`deleteAndAudit`,`deleteWhereAndAudit`,`updateAndAudit`,`updateWhereAndAudit` This package is originally based on this article [Maintaining a Log of Database Changes](http://www.4guysfromrolla.com/webtech/041807-1.shtml). Specifically, the first example: 'A Separate "History" Table for Each Table Being Audited'.
persistent-audit.cabal view
@@ -1,5 +1,5 @@ name: persistent-audit-version: 0.1.0.1+version: 0.1.0.2 synopsis: Parses a Persist Model file and produces Audit Models description: Simplify database audits license: BSD3@@ -14,23 +14,29 @@ executable persistent-audit main-is: Main.hs- -- other-modules: - -- other-extensions: + other-modules: Database.Persist.Audit.Generator+ Database.Persist.Audit.Parser+ Database.Persist.Audit.Parser.Types+ Database.Persist.Audit.Types+ build-depends: base >=4.8 && < 5 , attoparsec+ , aeson , bytestring , getopt-generics+ , hashable , mongoDB , persistent >= 2.2 , persistent-mongoDB , persistent-template , text , time- + , unordered-containers+ hs-source-dirs: src default-language: Haskell2010 -library +library exposed-modules: Database.Persist.Audit.Class Database.Persist.Audit.Generator Database.Persist.Audit.MongoDB.Util@@ -38,10 +44,12 @@ Database.Persist.Audit.Parser.Types Database.Persist.Audit.Types Database.Persist.Audit.Queries- -- other-modules:+ build-depends: base >=4.8 && < 5+ , aeson , attoparsec , bytestring+ , hashable , mongoDB , persistent >= 2.2 , persistent-mongoDB@@ -49,6 +57,7 @@ , text , time , transformers+ , unordered-containers hs-source-dirs: src default-language: Haskell2010@@ -57,24 +66,35 @@ test-suite test type: exitcode-stdio-1.0 main-is: Spec.hs+ other-modules: Database.Persist.Audit.Class+ Database.Persist.Audit.Generator+ Database.Persist.Audit.GeneratorSpec+ Database.Persist.Audit.Parser+ Database.Persist.Audit.Parser.Types+ Database.Persist.Audit.ParserSpec+ Database.Persist.Audit.Queries+ Database.Persist.Audit.QueriesSpec+ Database.Persist.Audit.Types default-language: Haskell2010 hs-source-dirs: src ,tests ghc-options: -threaded -O0 -Wall build-depends: base >=4.8 && < 5+ , aeson , attoparsec , bytestring+ , hashable , hspec , mongoDB , persistent >= 2.2 , persistent-sqlite , persistent-mongoDB , persistent-template- , text - , time + , text+ , time , transformers-+ , unordered-containers source-repository head type: git
src/Database/Persist/Audit/MongoDB/Util.hs view
@@ -3,18 +3,17 @@ module Database.Persist.Audit.MongoDB.Util where -import Data.ByteString (ByteString)-import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8,decodeUtf8')+import Data.ByteString (ByteString)+import Data.Text.Encoding (decodeUtf8',encodeUtf8) import Database.MongoDB as DB import Database.Persist.MongoDB (keyToText,readMayMongoKey)-import Database.Persist +import Database.Persist -- | Used for creating instances of ToAudit when the original model database is Mongo -- and the audit model database is SQL.--- ==== __Example__ +-- ==== __Example__ -- User -- ident Text -- password Text Maybe@@ -30,17 +29,16 @@ -- type AuditResult User = UserAudit -- toAudit v k auditAction editedBy editedOn = UserAudit (userIdent v) -- (userPassword v)--- (mongoKeyToByteString k) auditAction editedBy editedOn +-- (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. +-- | 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 + 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
@@ -5,16 +5,16 @@ module Database.Persist.Audit.Parser where -import Control.Applicative +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.List (delete,nub) import Data.Maybe-import Data.Monoid ((<>))-import Data.Text (Text)+import Data.Monoid ((<>))+import Data.Text (Text) import qualified Data.Text as T import Database.Persist.Audit.Types@@ -37,14 +37,14 @@ parsePersistQuasiQuoters :: Parser PersistModelFile parsePersistQuasiQuoters = do _ <- manyTill' anyChar (string "[persistLowerCase|" <|> string "[persistUpperCase|")- manyTill' ( PersistModelFileEntity <$> parseEntity + manyTill' ( PersistModelFileEntity <$> parseEntity <|> PersistModelFileWhiteSpace <$> collectWhiteSpace <|> PersistModelFileComment <$> singleLineComment) (string "|]") -- | Parse a Persist Model file. parseEntities :: Parser PersistModelFile parseEntities = do- many' ( PersistModelFileEntity <$> parseEntity + many' ( PersistModelFileEntity <$> parseEntity <|> PersistModelFileWhiteSpace <$> collectWhiteSpace <|> PersistModelFileComment <$> singleLineComment) @@ -60,27 +60,27 @@ _ <- takeTill isEndOfLine endOfLine <|> endOfInput - entityChildren <- many' ( EntityChildEntityField <$> parseEntityField - <|> EntityChildEntityDerive <$> parseEntityDerive + entityChildren <- many' ( EntityChildEntityField <$> parseEntityField+ <|> EntityChildEntityDerive <$> parseEntityDerive <|> EntityChildEntityPrimary <$> parseEntityPrimary <|> EntityChildEntityForeign <$> parseEntityForeign- <|> EntityChildEntityUnique <$> parseEntityUnique + <|> EntityChildEntityUnique <$> parseEntityUnique <|> EntityChildWhiteSpace <$> collectWhiteSpace <|> EntityChildComment <$> singleLineComment)- + return $ Entity entityName derivesJson mSqlTable entityChildren parseEntitySqlTable :: Parser Text parseEntitySqlTable = do- _ <- string "sql" + _ <- string "sql" _ <- many' spaceNoNewLine _ <- char '=' _ <- many' spaceNoNewLine -- take while not space- text <- many' (digit <|> letter <|> underline) + text <- many' (digit <|> letter <|> underline) return $ T.pack text- + -- helper functions -- | Wrap a Parser in 'Maybe' because it might fail. Useful for making choices.@@ -96,15 +96,15 @@ upperCase = satisfy (\c -> c >= 'A' && c <= 'Z') -- | Parse an underline.-underline :: Parser Char +underline :: Parser Char underline = satisfy (== '_') -- | Parse strict marker "!" for haskellTypeName.-exclamationMark :: Parser Char +exclamationMark :: Parser Char exclamationMark = satisfy (== '!') -- | Parse lazy marker "~" for haskellTypeName.-tilde :: Parser Char +tilde :: Parser Char tilde = satisfy (== '~') @@ -112,28 +112,28 @@ 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 +-- | 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) + 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 +-- | 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+ _ <- (Just <$> exclamationMark) <|> (Just <$> tilde) <|> pure Nothing haskellTypeNameWithoutPrefix haskellTypeNameWithoutPrefix :: Parser Text haskellTypeNameWithoutPrefix = do first <- upperCase- rest <- many' (digit <|> letter <|> underline) + 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)@@ -162,7 +162,7 @@ parseEntityName :: Parser Text parseEntityName = do name <- haskellTypeName- rest <- takeTill isEndOfLine+ _ <- takeTill isEndOfLine endOfLine <|> endOfInput return name @@ -175,29 +175,29 @@ ms <- parseMigrationOnlyAndSafeToRemove [] <|> pure [] rs <- parseEntityFieldLastItem [] <|> pure []- - rest <- takeTill isEndOfLine++ _ <- takeTill isEndOfLine endOfLine <|> endOfInput- - return $ EntityField efn - eft - (elem MigrationOnly ms) ++ 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 (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 +parseSafeToRemove = string "SafeToRemove" *> pure SafeToRemove getMigrationOnlyAndSafeToRemoveOption :: MigrationOnlyAndSafeToRemoveOption -> Parser MigrationOnlyAndSafeToRemoveOption getMigrationOnlyAndSafeToRemoveOption MigrationOnly = parseMigrationOnly@@ -214,28 +214,28 @@ Just result -> parseMigrationOnlyAndSafeToRemove (parserOps ++ [result]) <|> pure (parserOps ++ [result]) getFieldDefault :: [EntityFieldLastItem] -> Maybe Text-getFieldDefault (x:xs) = +getFieldDefault (x:xs) = case x of (FieldDefault y) -> Just y _ -> getFieldDefault xs getFieldDefault _ = Nothing getFieldSqlRow :: [EntityFieldLastItem] -> Maybe Text-getFieldSqlRow (x:xs) = +getFieldSqlRow (x:xs) = case x of (FieldSqlRow y) -> Just y _ -> getFieldSqlRow xs getFieldSqlRow _ = Nothing getFieldSqlType :: [EntityFieldLastItem] -> Maybe Text-getFieldSqlType (x:xs) = +getFieldSqlType (x:xs) = case x of (FieldSqlType y) -> Just y _ -> getFieldSqlType xs getFieldSqlType _ = Nothing getFieldMaxLen :: [EntityFieldLastItem] -> Maybe Int-getFieldMaxLen (x:xs) = +getFieldMaxLen (x:xs) = case x of (FieldMaxLen y) -> Just y _ -> getFieldMaxLen xs@@ -259,37 +259,37 @@ text <- many' (digit <|> letter <|> underline) return $ FieldDefault $ T.pack text - + parseFieldSqlRow :: Parser EntityFieldLastItem parseFieldSqlRow = do- _ <- string "sql" + _ <- string "sql" _ <- many' spaceNoNewLine _ <- char '=' _ <- many' spaceNoNewLine -- take while not space- text <- many' (digit <|> letter <|> underline) + text <- many' (digit <|> letter <|> underline) return $ FieldSqlRow $ T.pack text parseFieldSqlType :: Parser EntityFieldLastItem parseFieldSqlType = do- _ <- string "sqltype" + _ <- string "sqltype" _ <- many' spaceNoNewLine _ <- char '=' _ <- many' spaceNoNewLine -- take while not space- text <- many' (digit <|> letter <|> underline) + text <- many' (digit <|> letter <|> underline) return $ FieldSqlType $ T.pack text parseFieldMaxLen :: Parser EntityFieldLastItem parseFieldMaxLen = do- _ <- string "maxlen" + _ <- string "maxlen" _ <- many' spaceNoNewLine _ <- char '=' _ <- many' spaceNoNewLine -- take while not space intString <- many1 digit- - case readMaybe intString :: Maybe Int of ++ case readMaybe intString :: Maybe Int of Nothing -> fail "fieldMaxLen" Just int -> return $ FieldMaxLen int @@ -298,7 +298,7 @@ _ <- 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])@@ -308,7 +308,7 @@ parseEntityFieldName = do _ <- many1 spaceNoNewLine name <- haskellFunctionName- + case name == "deriving" of True -> fail "deriving" False -> return name@@ -364,8 +364,8 @@ parseEntityUniqueEntityFieldName = do _ <- many1 spaceNoNewLine many1 haskellFunctionName- + -- EntityDerive parseEntityDerive :: Parser EntityDerive@@ -374,7 +374,7 @@ _ <- string "deriving" -- _ <- many1 spaceNoNewLine names <- many1 (many1 spaceNoNewLine *> haskellTypeName)- + _ <- takeTill isEndOfLine endOfLine <|> endOfInput @@ -386,7 +386,7 @@ _ <- string "Primary" -- _ <- many1 spaceNoNewLine names <- many1 (many1 spaceNoNewLine *> haskellFunctionName)- + _ <- takeTill isEndOfLine endOfLine <|> endOfInput @@ -399,7 +399,7 @@ _ <- many1 spaceNoNewLine foreignTable <- haskellTypeName names <- many1 (many1 spaceNoNewLine *> haskellFunctionName)- + _ <- takeTill isEndOfLine endOfLine <|> endOfInput @@ -410,4 +410,3 @@ parseForeignKeyType = do _ <- manyTill anyChar (string "Id" *> endOfInput) return ()-
src/Database/Persist/Audit/Types.hs view
@@ -1,10 +1,17 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-} module Database.Persist.Audit.Types where -import Data.Text (Text)+import Control.Applicative (empty)+import Control.Monad (mzero) +import Data.Aeson+import Data.Hashable+import qualified Data.HashMap.Lazy as HML+import Data.Text (Text)+ import Database.Persist.TH import GHC.Generics@@ -16,7 +23,7 @@ -- | Top level pieces of a Persist Model file. data PersistModelFilePiece = PersistModelFileEntity Entity | PersistModelFileComment Comment |- PersistModelFileWhiteSpace WhiteSpace + PersistModelFileWhiteSpace WhiteSpace deriving (Eq,Show,Read) -- | A single Persist Model Entity.@@ -36,7 +43,7 @@ EntityChildEntityPrimary EntityPrimary | EntityChildEntityForeign EntityForeign | EntityChildComment Comment |- EntityChildWhiteSpace WhiteSpace + EntityChildWhiteSpace WhiteSpace deriving (Eq,Show,Read) -- | A data row from an Entity.@@ -55,11 +62,11 @@ -- | Table rows can be strict or lazy data Strictness -- | Persist Model types are strict without any notation- = Strict - -- | "!" can be used to reemphasize that a type is strict - | ExplicitStrict + = Strict+ -- | "!" can be used to reemphasize that a type is strict+ | ExplicitStrict -- | "~" means that a type is Lazy- | Lazy + | Lazy deriving (Eq,Show,Read) -- | An entity data row's type. If '_isEntityFieldTypeList' is 'True' than this type is a list. data EntityFieldType = EntityFieldType {@@ -101,12 +108,29 @@ -- | Haskell style comments that start with "-- " data Comment = Comment {- _getComment :: Text + _getComment :: Text } deriving (Eq,Show,Read) --- | Annotations for each Audit Model to keep track of why it was inserted. -data AuditAction = Create | Delete | Update +-- | 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"++instance Hashable AuditAction+instance FromJSON AuditAction where+ parseJSON (Object o) = getAuditAction+ where+ getAuditAction+ | HML.member "Create" o = pure Database.Persist.Audit.Types.Create+ | HML.member "Delete" o = pure Database.Persist.Audit.Types.Delete+ | HML.member "Update" o = pure Database.Persist.Audit.Types.Update+ | True = empty++ parseJSON _ = mzero++instance ToJSON AuditAction where+ toJSON (Database.Persist.Audit.Types.Create) = object ["Create" .= ([] :: [Int])]+ toJSON (Database.Persist.Audit.Types.Delete) = object ["Delete" .= ([] :: [Int])]+ toJSON (Database.Persist.Audit.Types.Update) = object ["Update" .= ([] :: [Int])]
src/Main.hs view
@@ -4,8 +4,6 @@ module Main where -import Data.Text (Text)-import qualified Data.Text as T import Data.Text.IO import Database.Persist.Audit.Generator@@ -20,7 +18,7 @@ makes a best attempt, no guarantees - assumptions made: + assumptions made: types ending in Id are foreign pointers -} @@ -47,8 +45,8 @@ "sqlToMongoDB" -> return $ defaultSettings {foreignKeyType = SQLKeyInMongo} _ -> return defaultSettings - case parseModelsFile m of - Left _ -> print $ "Failed to parse the models file with parseEntities function."+ case parseModelsFile m of+ Left _ -> print ("Failed to parse the models file with parseEntities function." :: String) Right models -> do Data.Text.IO.writeFile (audit ops) (generateAuditModels settings models) case auditInstance ops of
+ tests/Database/Persist/Audit/GeneratorSpec.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.Persist.Audit.GeneratorSpec (main, spec) where++import Control.Monad.IO.Class (liftIO)+import Data.Attoparsec.Text++import Data.Text (Text)++import Database.Persist.Audit.Generator+import Database.Persist.Audit.Parser++import Test.Hspec+++{- The following data is used below+User+ ident Text+ password Text Maybe+ UniqueUser ident+ deriving Typeable+ deriving Generic+ deriving Eq+ deriving Show+ deriving Ord++Phone+ number Int+ user UserId++instance ToAudit User where+ type AuditResult User = UserAudit+ toAudit v k auditAction editedBy editedOn = UserAudit (userIdent v)+ (userPassword v)+ k auditAction editedBy editedOn++instance ToAudit Person where+ type AuditResult Person = PersonAudit+ toAudit v k auditAction editedBy editedOn = PersonAudit (personName v)+ (personAge v)+ k auditAction editedBy editedOn++-}++emptyModel :: Text+emptyModel = "Test json sql=testing\n"++emptyAuditModel :: Text+emptyAuditModel = "TestAudit json sql=testing\n originalId TestId noreference\n auditAction AuditAction\n editedBy Text\n editedOn UTCTime\n\n"++userModel :: Text+userModel = "User\n ident Text\n password Text Maybe\n UniqueUser ident\n deriving Typeable\n deriving Generic\n deriving Eq\n deriving Show\n deriving Ord"++userAuditModel :: Text+userAuditModel = "UserAudit\n ident Text\n password Text Maybe\n deriving Typeable\n deriving Generic\n deriving Eq\n deriving Show\n deriving Ord\n originalId UserId noreference\n auditAction AuditAction\n editedBy Text\n editedOn UTCTime\n\n"++userToAuditInstance :: Text+userToAuditInstance = "instance ToAudit User where\n type AuditResult User = UserAudit\n toAudit v k auditAction editedBy editedOn = UserAudit\n (userIdent v)\n (userPassword v)\n (k) auditAction editedBy editedOn\n\n"++userToAuditInstanceInt64 :: Text+userToAuditInstanceInt64 = "instance ToAudit User where\n type AuditResult User = UserAudit\n toAudit v k auditAction editedBy editedOn = UserAudit\n (userIdent v)\n (userPassword v)\n (fromSqlKey k) auditAction editedBy editedOn\n\n"++++phoneModel :: Text+phoneModel = "Phone\n number Int\n user UserId"++phoneAuditModel :: Text+phoneAuditModel = "PhoneAudit\n number Int\n user UserId noreference\n originalId PhoneId noreference\n auditAction AuditAction\n editedBy Text\n editedOn UTCTime\n\n"++phoneToAuditInstanceByteString :: Text+phoneToAuditInstanceByteString = "instance ToAudit Phone where\n type AuditResult Phone = PhoneAudit\n toAudit v k auditAction editedBy editedOn = PhoneAudit\n (phoneNumber v)\n (mongoKeyToByteString $ phoneUser v)\n (mongoKeyToByteString k) auditAction editedBy editedOn\n\n"++++phoneWithMaybeModel :: Text+phoneWithMaybeModel = "Phone\n number Int\n user UserId Maybe"++phoneWithMaybeToAuditInstanceByteString :: Text+phoneWithMaybeToAuditInstanceByteString = "instance ToAudit Phone where\n type AuditResult Phone = PhoneAudit\n toAudit v k auditAction editedBy editedOn = PhoneAudit\n (phoneNumber v)\n (mongoKeyToByteString <$> phoneUser v)\n (mongoKeyToByteString k) auditAction editedBy editedOn\n\n"++-- userToAuditInstanceInt64 :: Text+-- userToAuditInstanceInt64 = "instance ToAudit User where\n type AuditResult User = UserAudit\n toAudit v k auditAction editedBy editedOn = UserAudit\n (userIdent v)\n (userPassword v)\n (fromSqlKey k) auditAction editedBy editedOn\n\n"++phoneAuditByteStringModel :: Text+phoneAuditByteStringModel = "PhoneAudit\n number Int\n user ByteString -- UserId\n originalId ByteString -- PhoneId\n auditAction AuditAction\n editedBy Text\n editedOn UTCTime\n\n"++phoneAuditInt64Model :: Text+phoneAuditInt64Model = "PhoneAudit\n number Int\n user Int64 -- UserId\n originalId Int64 -- PhoneId\n auditAction AuditAction\n editedBy Text\n editedOn UTCTime\n\n"+++addressModel :: Text+addressModel = "Address\n address Text\n phoneNumbers [Phone]"++addressAuditModel :: Text+addressAuditModel = "AddressAudit\n address Text\n phoneNumbers [Phone]\n originalId AddressId noreference\n auditAction AuditAction\n editedBy Text\n editedOn UTCTime\n\n"+++spec :: Spec+spec = do+ describe "Audit Model generator" $ do+ it "should generate an audit model from a model" $ do+ let parseResult = parseOnly parseEntities emptyModel+ case parseResult of+ Left _ -> False `shouldBe` True+ Right es -> do+ let generatedAuditModels = generateAuditModels defaultSettings es+ generatedAuditModels `shouldBe` emptyAuditModel++ it "should generate an audit model for another model" $ do+ let parseResult = parseOnly parseEntities userModel+ case parseResult of+ Left _ -> False `shouldBe` True+ Right es -> do+ let generatedAuditModels = generateAuditModels defaultSettings es+ generatedAuditModels `shouldBe` userAuditModel++ it "should add noreference tag to foreign refereces" $ do+ let parseResult = parseOnly parseEntities phoneModel+ case parseResult of+ Left _ -> False `shouldBe` True+ Right es -> do+ let generatedAuditModels = generateAuditModels defaultSettings es+ generatedAuditModels `shouldBe` phoneAuditModel++ it "should generate fields that are list types" $ do+ let parseResult = parseOnly parseEntities addressModel+ case parseResult of+ Left _ -> False `shouldBe` True+ Right es -> do+ liftIO $ print es+ let generatedAuditModels = generateAuditModels defaultSettings es+ generatedAuditModels `shouldBe` addressAuditModel++ it "should generate foreign references as ByteString if the MongoKeyInSQL setting is used" $ do+ let parseResult = parseOnly parseEntities phoneModel+ case parseResult of+ Left _ -> False `shouldBe` True+ Right es -> do+ let generatedAuditModels = generateAuditModels (defaultSettings {foreignKeyType = MongoKeyInSQL}) es+ generatedAuditModels `shouldBe` phoneAuditByteStringModel++ it "should generate foreign references as Int64 if the SQLKeyInMongo setting is used" $ do+ let parseResult = parseOnly parseEntities phoneModel+ case parseResult of+ Left _ -> False `shouldBe` True+ Right es -> do+ let generatedAuditModels = generateAuditModels (defaultSettings {foreignKeyType = SQLKeyInMongo}) es+ generatedAuditModels `shouldBe` phoneAuditInt64Model++++ describe "ToAudit instance generator" $ do+ it "should generate an instance from a model" $ do+ let parseResult = parseOnly parseEntities userModel+ case parseResult of+ Left _ -> False `shouldBe` True+ Right es -> do+ let generatedAuditInstances = generateToAuditInstances defaultSettings es+ generatedAuditInstances `shouldBe` userToAuditInstance++ it "should generate an instance from a model foreign references as ByteString when the MongoKeyInSQL setting is used" $ do+ let parseResult = parseOnly parseEntities phoneModel+ case parseResult of+ Left _ -> False `shouldBe` True+ Right es -> do+ let generatedAuditInstances = generateToAuditInstances (defaultSettings {foreignKeyType = MongoKeyInSQL}) es+ generatedAuditInstances `shouldBe` phoneToAuditInstanceByteString++ it "should generate an instance from a model maybe foreign references as fmap ByteString when the MongoKeyInSQL setting is used" $ do+ let parseResult = parseOnly parseEntities phoneWithMaybeModel+ case parseResult of+ Left _ -> False `shouldBe` True+ Right es -> do+ let generatedAuditInstances = generateToAuditInstances (defaultSettings {foreignKeyType = MongoKeyInSQL}) es+ generatedAuditInstances `shouldBe` phoneWithMaybeToAuditInstanceByteString++ it "should generate an instance from a model with foreign references as Int64 when the SQLKeyInMongo setting is used" $ do+ let parseResult = parseOnly parseEntities userModel+ case parseResult of+ Left _ -> False `shouldBe` True+ Right es -> do+ let generatedAuditInstances = generateToAuditInstances (defaultSettings {foreignKeyType = SQLKeyInMongo}) es+ liftIO $ print parseResult+ generatedAuditInstances `shouldBe` userToAuditInstanceInt64+++main :: IO ()+main = hspec spec
+ tests/Database/Persist/Audit/ParserSpec.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.Persist.Audit.ParserSpec ( main+ , spec) where++import Data.Attoparsec.Text+import Data.Either++import Database.Persist.Audit.Parser+import Database.Persist.Audit.Parser.Types+import Database.Persist.Audit.Types++import Test.Hspec ( Spec+ , describe+ , hspec+ , it+ , shouldBe+ , shouldMatchList)++++spec :: Spec+spec = do+ describe "Haskell Function Name Parser" $ do+ -- should pass+ it "Should parse function names starting with an underscore" $ do+ let parseResult = parseOnly haskellFunctionName "_get"+ parseResult `shouldBe` (Right "_get")++ it "Should parse function names starting with a lowercase letter" $ do+ let parseResult = parseOnly haskellFunctionName "get"+ parseResult `shouldBe` (Right "get")++ it "Should parse function names with an numbers" $ do+ let parseResult = parseOnly haskellFunctionName "get1"+ parseResult `shouldBe` (Right "get1")++ it "Should parse function names and ignore the trailing whitespace" $ do+ let parseResult = parseOnly haskellFunctionName "get "+ parseResult `shouldBe` (Right "get")++ it "Should parse function names, ignore the trailing whitespace, and the things that follow the whitespace" $ do+ let parseResult = parseOnly haskellFunctionName "get anotherthing"+ parseResult `shouldBe` (Right "get")++ -- should fail+ it "Should not parse inputs that start with whitespace" $ do+ let parseResult = parseOnly haskellFunctionName " _get"+ isLeft parseResult `shouldBe` True++ it "Should not parse function names starting with an uppercase letter" $ do+ let parseResult = parseOnly haskellFunctionName "Get"+ isLeft parseResult `shouldBe` True++ it "Should not parse function names starting with a number" $ do+ let parseResult = parseOnly haskellFunctionName "1get"+ isLeft parseResult `shouldBe` True++ it "Should not parse function names with symbols other than letters, numbers and underscores" $ do+ let parseResults = [ parseOnly haskellFunctionName "get!"+ , parseOnly haskellFunctionName "get$"+ , parseOnly haskellFunctionName "get+"+ , parseOnly haskellFunctionName "get="+ , parseOnly haskellFunctionName "get-"+ ]+ (rights parseResults) `shouldMatchList` []++ describe "Haskell Type Name Parser" $ do+ -- should pass+ it "Should parse type names starting with an uppercase letter" $ do+ let parseResult = parseOnly haskellTypeName "Person"+ parseResult `shouldBe` (Right "Person")++ it "Should parse type names starting with an uppercase letter" $ do+ let parseResult = parseOnly haskellTypeName "Person"+ parseResult `shouldBe` (Right "Person")++ it "Should parse strict type names" $ do+ let parseResult = parseOnly haskellTypeName "!Get"+ parseResult `shouldBe` (Right "Get")+ + -- parseResult `shouldBe` (Right "!Get")+ + it "Should parse lazy type names" $ do+ let parseResult = parseOnly haskellTypeName "~Get"+ parseResult `shouldBe` (Right "Get")+ + ++ -- should fail++ it "Should not parse type names starting with a lowercase letter" $ do+ let parseResult = parseOnly haskellTypeName "person"+ isLeft parseResult `shouldBe` True++ it "Should not parse type names with symbols other than letters, numbers and underscores" $ do+ let parseResults = [ parseOnly haskellTypeName "Get!"+ , parseOnly haskellTypeName "Get$"+ , parseOnly haskellTypeName "Get+"+ , parseOnly haskellTypeName "Get="+ , parseOnly haskellTypeName "Get-"+ ]+ (rights parseResults) `shouldMatchList` []++ describe "parseEntityPrimary" $ do+ it "should parse" $ do+ let parseResult = parseOnly parseEntityPrimary " Primary name age"+ parseResult `shouldBe` (Right (EntityPrimary ["name","age"]))+ + describe "parseEntityForeign" $ do+ it "should parse" $ do+ let parseResult = parseOnly parseEntityForeign " Foreign Tree fkparent parent"+ parseResult `shouldBe` (Right (EntityForeign "Tree" ["fkparent","parent"]))+ ++ describe "parseMigrationOnlyAndSafeToRemove" $ do++ it "Should parse MigrationOnly" $ do+ let parseResult = parseOnly (parseMigrationOnlyAndSafeToRemove []) " MigrationOnly"+ parseResult `shouldBe` (Right [MigrationOnly])++ it "Should parse SafeToRemove" $ do+ let parseResult = parseOnly (parseMigrationOnlyAndSafeToRemove []) " SafeToRemove"+ parseResult `shouldBe` (Right [SafeToRemove]) ++ it "Should parse empty space" $ do+ let parseResult = parseOnly (parseMigrationOnlyAndSafeToRemove []) " "+ parseResult `shouldBe` (Right [])++ it "Should parse MigrationOnly and SafeToRemove" $ do+ let parseResult = parseOnly (parseMigrationOnlyAndSafeToRemove []) " MigrationOnly SafeToRemove"+ parseResult `shouldBe` (Right [MigrationOnly,SafeToRemove]) ++ it "Should parse SafeToRemove and MigrationOnly" $ do+ let parseResult = parseOnly (parseMigrationOnlyAndSafeToRemove []) " SafeToRemove MigrationOnly"+ parseResult `shouldBe` (Right [SafeToRemove,MigrationOnly]) ++ describe "parseEntityFieldLastItem" $ do+ it "Should parse a default assignment" $ do+ let parseResult = parseOnly (parseEntityFieldLastItem []) " default = Nothing"+ parseResult `shouldBe` (Right [(FieldDefault "Nothing")]) ++ it "Should parse an sql row assignment" $ do+ let parseResult = parseOnly (parseEntityFieldLastItem []) " sql=person"+ parseResult `shouldBe` (Right [(FieldSqlRow "person")])++ it "Should parse an sql type assignment" $ do+ let parseResult = parseOnly (parseEntityFieldLastItem []) " sqltype=date"+ parseResult `shouldBe` (Right [(FieldSqlType "date")])++ it "Should parse an maxlen assignment" $ do+ let parseResult = parseOnly (parseEntityFieldLastItem []) " maxlen=15"+ parseResult `shouldBe` (Right [(FieldMaxLen 15)])++ it "Should parse mulitple items" $ do+ let parseResult = parseOnly (parseEntityFieldLastItem []) " default = Nothing maxlen=15"+ parseResult `shouldBe` (Right [(FieldDefault "Nothing"), (FieldMaxLen 15)])+ + it "Should parse mulitple items" $ do+ let parseResult = parseOnly (parseEntityFieldLastItem []) " default = Nothing maxlen=15 sqltype=date sql=person"+ parseResult `shouldBe` (Right [(FieldDefault "Nothing"), (FieldMaxLen 15),(FieldSqlType "date"), (FieldSqlRow "person")])+ ++ describe "parseEntity" $ do+ it "parses Entity with only a table name" $ do+ let parseResult = parseOnly (parseEntity) "Person"+ parseResult `shouldBe` (Right (Entity "Person" False Nothing []))++ it "parses Entity with table name and derive json" $ do+ let parseResult = parseOnly (parseEntity) "Person json"+ parseResult `shouldBe` (Right (Entity "Person" True Nothing []))+ + it "parses Entity with table name and sql table set to person" $ do+ let parseResult = parseOnly (parseEntity) "Person sql = person"+ parseResult `shouldBe` (Right (Entity "Person" False (Just "person") []))+ + it "parses Entity with table name, derive json, and table set to person" $ do+ let parseResult = parseOnly (parseEntity) "Person json sql= person"+ parseResult `shouldBe` (Right (Entity "Person" True (Just "person") []))+ + it "parses Entity with table name and one field" $ do+ let parseResult = parseOnly (parseEntity) "Person\n name Text"+ parseResult `shouldBe` (Right (Entity "Person" False Nothing [(EntityChildEntityField $ EntityField "name" (EntityFieldType "Text" Strict False False) False False Nothing Nothing Nothing Nothing)]))+ + it "parses Entity with a table name, multiple fields, Unique, Foreign and deriving" $ do+ let parseResult = parseOnly (parseEntity) "Person\n name Text\n phoneNumber Int Maybe\n friends [PersonId]\n UniquePerson name\n deriving Eq Read Show\n Primary name age"+ parseResult `shouldBe` (Right (Entity "Person" False Nothing [(EntityChildEntityField $ EntityField "name" (EntityFieldType "Text" Strict False False) False False Nothing Nothing Nothing Nothing)+ ,(EntityChildEntityField $ EntityField "phoneNumber" (EntityFieldType "Int" Strict False True) False False Nothing Nothing Nothing Nothing)+ ,(EntityChildEntityField $ EntityField "friends" (EntityFieldType "PersonId" Strict True False) False False Nothing Nothing Nothing Nothing)+ ,(EntityChildEntityUnique $ EntityUnique "UniquePerson" ["name"])+ ,(EntityChildEntityDerive $ EntityDerive ["Eq","Read","Show"])+ ,(EntityChildEntityPrimary $ EntityPrimary ["name","age"])]))+ + +++ describe "parseEntityField" $ do+ it "Should parse a well formed entity field" $ do+ let sampleEntityField = " ident Text"+ let eft = EntityFieldType "Text" Strict False False+ let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing+ let parseResult = parseOnly parseEntityField sampleEntityField+ parseResult `shouldBe` (Right ef) + + it "Should parse a well formed entity field with list type" $ do+ let sampleEntityField = " ident [Text]"+ let eft = EntityFieldType "Text" Strict True False+ let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing+ let parseResult = parseOnly parseEntityField sampleEntityField+ parseResult `shouldBe` (Right ef) + + it "Should parse a well formed entity field with maybe type" $ do+ let sampleEntityField = " ident Text Maybe"+ let eft = EntityFieldType "Text" Strict False True+ let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing+ let parseResult = parseOnly parseEntityField sampleEntityField+ parseResult `shouldBe` (Right ef) + + it "Should parse a well formed entity field with maybe list type" $ do+ let sampleEntityField = " ident [Text] Maybe"+ let eft = EntityFieldType "Text" Strict True True+ let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing+ let parseResult = parseOnly parseEntityField sampleEntityField+ parseResult `shouldBe` (Right ef)+++ it "Should parse an entity field with explicit strict type" $ do+ let sampleEntityField = " ident !Text"+ let eft = EntityFieldType "Text" ExplicitStrict False False + let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing+ let parseResult = parseOnly parseEntityField sampleEntityField+ parseResult `shouldBe` (Right ef) ++ it "Should parse an entity field with a lazy type" $ do+ let sampleEntityField = " ident ~Text"+ let eft = EntityFieldType "Text" Lazy False False+ let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing+ let parseResult = parseOnly parseEntityField sampleEntityField+ parseResult `shouldBe` (Right ef) ++ it "Should parse an entity field with a list of lazy types" $ do+ let sampleEntityField = " ident [~Text]"+ let eft = EntityFieldType "Text" Lazy True False+ let ef = EntityField "ident" eft False False Nothing Nothing Nothing Nothing+ let parseResult = parseOnly parseEntityField sampleEntityField+ parseResult `shouldBe` (Right ef) + +main :: IO ()+main = hspec spec
+ tests/Database/Persist/Audit/QueriesSpec.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Database.Persist.Audit.QueriesSpec (main, spec) where++import Control.Monad.IO.Class++import Data.Text (Text)+import Data.Time++import Database.Persist hiding (Update)+import Database.Persist.Sqlite hiding (Update)+import Database.Persist.TH++import Database.Persist.Audit.Class+import Database.Persist.Audit.Queries+import Database.Persist.Audit.Types++import Test.Hspec++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+Person+ name String+ age Int Maybe+ deriving Show++BlogPost+ title String+ authorId PersonId+ deriving Show++PersonAudit+ name String+ age Int Maybe+ deriving Show+ originalId PersonId noreference+ auditAction AuditAction+ editedBy Text+ editedOn UTCTime++BlogPostAudit+ title String+ authorId PersonId noreference+ deriving Show+ originalId BlogPostId noreference+ auditAction AuditAction+ editedBy Text+ editedOn UTCTime+|]+++instance ToAudit Person where+ type AuditResult Person = PersonAudit+ toAudit v k auditAction editedBy editedOn = PersonAudit (personName v)+ (personAge v)+ k auditAction editedBy editedOn++instance ToAudit BlogPost where+ type AuditResult BlogPost = BlogPostAudit+ toAudit v k auditAction editedBy editedOn = BlogPostAudit (blogPostTitle v)+ (blogPostAuthorId v)+ k auditAction editedBy editedOn++spec :: Spec+spec = do+ describe "Audit Queries" $ do+ it "insertAndAudit should insert the original item and insert an audit version" $ do+ mPair <- liftIO $ runSqlite ":memory:" $ do+ runMigration migrateAll+ johnId <- insertAndAudit (Person "John Doe" $ Just 35) "Admin"++ mPerson <- selectFirst [PersonId ==. johnId] []+ mPersonAudit <- selectFirst [PersonAuditOriginalId ==. johnId, PersonAuditAuditAction ==. Create] []++ return $ (,) <$> mPerson <*> mPersonAudit++ case mPair of+ Nothing -> False `shouldBe` True+ Just (person,personAudit) ->+ ((personName . entityVal $ person) == (personAuditName . entityVal $ personAudit)) `shouldBe` True++ it "deleteAndAudit should delete the original item and an insert audit version" $ do+ pair <- liftIO $ runSqlite ":memory:" $ do+ runMigration migrateAll+ johnId <- insertAndAudit (Person "John Doe" $ Just 35) "Admin"+ deleteAndAudit johnId "Admin"++ mPerson <- selectFirst [PersonId ==. johnId] []+ mPersonAudit <- selectList [PersonAuditOriginalId ==. johnId, PersonAuditAuditAction ==. Delete] []++ return $ (,) mPerson mPersonAudit++ case fst pair of+ Just _ -> False `shouldBe` True+ Nothing -> (length $ snd pair) == 1 `shouldBe` True++ it "updateAndAudit should update the original item and insert an audit version" $ do+ mPersonAudit <- liftIO $ runSqlite ":memory:" $ do+ runMigration migrateAll+ johnId <- insertAndAudit (Person "John Doe" $ Just 35) "Admin"++ updateAndAudit johnId [PersonAge =. (Just 30)] "Admin"+ mPersonAudit <- selectFirst [PersonAuditOriginalId ==. johnId, PersonAuditAuditAction ==. Update] []++ return mPersonAudit++ case mPersonAudit of+ Nothing -> False `shouldBe` True+ Just _ -> True `shouldBe` True++main :: IO ()+main = hspec spec