diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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'. diff --git a/persistent-audit.cabal b/persistent-audit.cabal --- a/persistent-audit.cabal +++ b/persistent-audit.cabal @@ -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 diff --git a/src/Database/Persist/Audit/MongoDB/Util.hs b/src/Database/Persist/Audit/MongoDB/Util.hs --- a/src/Database/Persist/Audit/MongoDB/Util.hs +++ b/src/Database/Persist/Audit/MongoDB/Util.hs @@ -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 - diff --git a/src/Database/Persist/Audit/Parser.hs b/src/Database/Persist/Audit/Parser.hs --- a/src/Database/Persist/Audit/Parser.hs +++ b/src/Database/Persist/Audit/Parser.hs @@ -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 () - diff --git a/src/Database/Persist/Audit/Types.hs b/src/Database/Persist/Audit/Types.hs --- a/src/Database/Persist/Audit/Types.hs +++ b/src/Database/Persist/Audit/Types.hs @@ -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])] diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/tests/Database/Persist/Audit/GeneratorSpec.hs b/tests/Database/Persist/Audit/GeneratorSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Database/Persist/Audit/GeneratorSpec.hs @@ -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 diff --git a/tests/Database/Persist/Audit/ParserSpec.hs b/tests/Database/Persist/Audit/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Database/Persist/Audit/ParserSpec.hs @@ -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 diff --git a/tests/Database/Persist/Audit/QueriesSpec.hs b/tests/Database/Persist/Audit/QueriesSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Database/Persist/Audit/QueriesSpec.hs @@ -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