diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for persistent-audit-script + +## 0.0.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/persistent-audit.cabal b/persistent-audit.cabal new file mode 100644 --- /dev/null +++ b/persistent-audit.cabal @@ -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 diff --git a/src/Database/Persist/Audit/Class.hs b/src/Database/Persist/Audit/Class.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Audit/Class.hs @@ -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 diff --git a/src/Database/Persist/Audit/Generator.hs b/src/Database/Persist/Audit/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Audit/Generator.hs @@ -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 _ = [] diff --git a/src/Database/Persist/Audit/MongoDB/Util.hs b/src/Database/Persist/Audit/MongoDB/Util.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Audit/MongoDB/Util.hs @@ -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 + diff --git a/src/Database/Persist/Audit/Parser.hs b/src/Database/Persist/Audit/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Audit/Parser.hs @@ -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 () + diff --git a/src/Database/Persist/Audit/Parser/Types.hs b/src/Database/Persist/Audit/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Audit/Parser/Types.hs @@ -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 diff --git a/src/Database/Persist/Audit/Queries.hs b/src/Database/Persist/Audit/Queries.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Audit/Queries.hs @@ -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 () diff --git a/src/Database/Persist/Audit/Types.hs b/src/Database/Persist/Audit/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Audit/Types.hs @@ -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" diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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' : + [] diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}